doublereal dtzt02_(integer *m, integer *n, doublereal *af, integer *lda,
doublereal *tau, doublereal *work, integer *lwork)
{
/* System generated locals */
integer af_dim1, af_offset, i__1, i__2;
doublereal ret_val;
/* Local variables */
static integer i__;
static doublereal rwork[1];
extern doublereal dlamch_(char *), dlange_(char *, integer *,
integer *, doublereal *, integer *, doublereal *);
extern /* Subroutine */ int dlaset_(char *, integer *, integer *,
doublereal *, doublereal *, doublereal *, integer *),
xerbla_(char *, integer *), dlatzm_(char *, integer *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
doublereal *, integer *, doublereal *);
#define af_ref(a_1,a_2) af[(a_2)*af_dim1 + a_1]
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
DTZT02 returns
|| I - Q'*Q || / ( M * eps)
where the matrix Q is defined by the Householder transformations
generated by DTZRQF.
Arguments
=========
M (input) INTEGER
The number of rows of the matrix AF.
N (input) INTEGER
The number of columns of the matrix AF.
AF (input) DOUBLE PRECISION array, dimension (LDA,N)
The output of DTZRQF.
LDA (input) INTEGER
The leading dimension of the array AF.
TAU (input) DOUBLE PRECISION array, dimension (M)
Details of the Householder transformations as returned by
DTZRQF.
WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)
LWORK (input) INTEGER
length of WORK array. Must be >= N*N+N
=====================================================================
Parameter adjustments */
af_dim1 = *lda;
af_offset = 1 + af_dim1 * 1;
af -= af_offset;
--tau;
--work;
/* Function Body */
ret_val = 0.;
if (*lwork < *n * *n + *n) {
xerbla_("DTZT02", &c__7);
return ret_val;
}
/* Quick return if possible */
if (*m <= 0 || *n <= 0) {
return ret_val;
}
/* Q := I */
dlaset_("Full", n, n, &c_b5, &c_b6, &work[1], n);
/* Q := P(1) * ... * P(m) * Q */
for (i__ = *m; i__ >= 1; --i__) {
i__1 = *n - *m + 1;
dlatzm_("Left", &i__1, n, &af_ref(i__, *m + 1), lda, &tau[i__], &work[
i__], &work[*m + 1], n, &work[*n * *n + 1]);
/* L10: */
}
/* Q := P(m) * ... * P(1) * Q */
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = *n - *m + 1;
dlatzm_("Left", &i__2, n, &af_ref(i__, *m + 1), lda, &tau[i__], &work[
i__], &work[*m + 1], n, &work[*n * *n + 1]);
/* L20: */
}
/* Q := Q - I */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
work[(i__ - 1) * *n + i__] += -1.;
/* L30: */
}
ret_val = dlange_("One-norm", n, n, &work[1], n, rwork) / (
dlamch_("Epsilon") * (doublereal) max(*m,*n));
return ret_val;
/* End of DTZT02 */
} /* dtzt02_ */
int zlaqgb_(int *m, int *n, int *kl, int *ku,
doublecomplex *ab, int *ldab, double *r__, double *c__,
double *rowcnd, double *colcnd, double *amax, char *equed)
{
/* System generated locals */
int ab_dim1, ab_offset, i__1, i__2, i__3, i__4, i__5, i__6;
double d__1;
doublecomplex z__1;
/* Local variables */
int i__, j;
double cj, large, small;
extern double dlamch_(char *);
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLAQGB equilibrates a general M by N band matrix A with KL */
/* subdiagonals and KU superdiagonals using the row and scaling factors */
/* in the vectors R and C. */
/* 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. */
/* KL (input) INTEGER */
/* The number of subdiagonals within the band of A. KL >= 0. */
/* KU (input) INTEGER */
/* The number of superdiagonals within the band of A. KU >= 0. */
/* AB (input/output) COMPLEX*16 array, dimension (LDAB,N) */
/* On entry, the matrix A in band storage, 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, the equilibrated matrix, in the same storage format */
/* as A. See EQUED for the form of the equilibrated matrix. */
/* LDAB (input) INTEGER */
/* The leading dimension of the array AB. LDA >= KL+KU+1. */
/* R (input) DOUBLE PRECISION array, dimension (M) */
/* The row scale factors for A. */
/* C (input) DOUBLE PRECISION array, dimension (N) */
/* The column scale factors for A. */
/* ROWCND (input) DOUBLE PRECISION */
/* Ratio of the smallest R(i) to the largest R(i). */
/* COLCND (input) DOUBLE PRECISION */
/* Ratio of the smallest C(i) to the largest C(i). */
/* AMAX (input) DOUBLE PRECISION */
/* Absolute value of largest matrix entry. */
/* EQUED (output) CHARACTER*1 */
/* Specifies the form of equilibration that was done. */
/* = 'N': No equilibration */
/* = 'R': Row equilibration, i.e., A has been premultiplied by */
/* diag(R). */
/* = 'C': Column equilibration, i.e., A has been postmultiplied */
/* by diag(C). */
/* = 'B': Both row and column equilibration, i.e., A has been */
/* replaced by diag(R) * A * diag(C). */
/* Internal Parameters */
/* =================== */
/* THRESH is a threshold value used to decide if row or column scaling */
/* should be done based on the ratio of the row or column scaling */
/* factors. If ROWCND < THRESH, row scaling is done, and if */
/* COLCND < THRESH, column scaling is done. */
/* LARGE and SMALL are threshold values used to decide if row scaling */
/* should be done based on the absolute size of the largest matrix */
/* element. If AMAX > LARGE or AMAX < SMALL, row scaling is done. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick return if possible */
/* Parameter adjustments */
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1;
ab -= ab_offset;
--r__;
--c__;
/* Function Body */
if (*m <= 0 || *n <= 0) {
*(unsigned char *)equed = 'N';
return 0;
}
/* Initialize LARGE and SMALL. */
small = dlamch_("Safe minimum") / dlamch_("Precision");
large = 1. / small;
if (*rowcnd >= .1 && *amax >= small && *amax <= large) {
/* No row scaling */
if (*colcnd >= .1) {
/* No column scaling */
*(unsigned char *)equed = 'N';
} else {
/* Column scaling */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
cj = c__[j];
/* Computing MAX */
i__2 = 1, i__3 = j - *ku;
/* Computing MIN */
i__5 = *m, i__6 = j + *kl;
i__4 = MIN(i__5,i__6);
for (i__ = MAX(i__2,i__3); i__ <= i__4; ++i__) {
i__2 = *ku + 1 + i__ - j + j * ab_dim1;
i__3 = *ku + 1 + i__ - j + j * ab_dim1;
z__1.r = cj * ab[i__3].r, z__1.i = cj * ab[i__3].i;
ab[i__2].r = z__1.r, ab[i__2].i = z__1.i;
/* L10: */
}
/* L20: */
}
*(unsigned char *)equed = 'C';
}
} else if (*colcnd >= .1) {
/* Row scaling, no column scaling */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__4 = 1, i__2 = j - *ku;
/* Computing MIN */
i__5 = *m, i__6 = j + *kl;
i__3 = MIN(i__5,i__6);
for (i__ = MAX(i__4,i__2); i__ <= i__3; ++i__) {
i__4 = *ku + 1 + i__ - j + j * ab_dim1;
i__2 = i__;
i__5 = *ku + 1 + i__ - j + j * ab_dim1;
z__1.r = r__[i__2] * ab[i__5].r, z__1.i = r__[i__2] * ab[i__5]
.i;
ab[i__4].r = z__1.r, ab[i__4].i = z__1.i;
/* L30: */
}
/* L40: */
}
*(unsigned char *)equed = 'R';
} else {
/* Row and column scaling */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
cj = c__[j];
/* Computing MAX */
i__3 = 1, i__4 = j - *ku;
/* Computing MIN */
i__5 = *m, i__6 = j + *kl;
i__2 = MIN(i__5,i__6);
for (i__ = MAX(i__3,i__4); i__ <= i__2; ++i__) {
i__3 = *ku + 1 + i__ - j + j * ab_dim1;
d__1 = cj * r__[i__];
i__4 = *ku + 1 + i__ - j + j * ab_dim1;
z__1.r = d__1 * ab[i__4].r, z__1.i = d__1 * ab[i__4].i;
ab[i__3].r = z__1.r, ab[i__3].i = z__1.i;
/* L50: */
}
/* L60: */
}
*(unsigned char *)equed = 'B';
}
return 0;
/* End of ZLAQGB */
} /* zlaqgb_ */
void
pdgssvx(superlu_options_t_Distributed *options, SuperMatrix *A,
ScalePermstruct_t *ScalePermstruct,
double B[], int ldb, int nrhs, gridinfo_t *grid,
LUstruct_t *LUstruct, SOLVEstruct_t *SOLVEstruct, double *berr,
SuperLUStat_t *stat, int *info)
{
/*
* -- Distributed SuperLU routine (version 2.0) --
* Lawrence Berkeley National Lab, Univ. of California Berkeley.
* March 15, 2003
*
*
* Purpose
* =======
*
* PDGSSVX solves a system of linear equations A*X=B,
* by using Gaussian elimination with "static pivoting" to
* compute the LU factorization of A.
*
* Static pivoting is a technique that combines the numerical stability
* of partial pivoting with the scalability of Cholesky (no pivoting),
* to run accurately and efficiently on large numbers of processors.
*
* See our paper at http://www.nersc.gov/~xiaoye/SuperLU/ for a detailed
* description of the parallel algorithms.
*
* Here are the options for using this code:
*
* 1. Independent of all the other options specified below, the
* user must supply
*
* - B, the matrix of right-hand sides, distributed by block rows,
* and its dimensions ldb (local) and nrhs (global)
* - grid, a structure describing the 2D processor mesh
* - options->IterRefine, which determines whether or not to
* improve the accuracy of the computed solution using
* iterative refinement
*
* On output, B is overwritten with the solution X.
*
* 2. Depending on options->Fact, the user has four options
* for solving A*X=B. The standard option is for factoring
* A "from scratch". (The other options, described below,
* are used when A is sufficiently similar to a previously
* solved problem to save time by reusing part or all of
* the previous factorization.)
*
* - options->Fact = DOFACT: A is factored "from scratch"
*
* In this case the user must also supply
*
* o A, the input matrix
*
* as well as the following options to determine what matrix to
* factorize.
*
* o options->Equil, to specify how to scale the rows and columns
* of A to "equilibrate" it (to try to reduce its
* condition number and so improve the
* accuracy of the computed solution)
*
* o options->RowPerm, to specify how to permute the rows of A
* (typically to control numerical stability)
*
* o options->ColPerm, to specify how to permute the columns of A
* (typically to control fill-in and enhance
* parallelism during factorization)
*
* o options->ReplaceTinyPivot, to specify how to deal with tiny
* pivots encountered during factorization
* (to control numerical stability)
*
* The outputs returned include
*
* o ScalePermstruct, modified to describe how the input matrix A
* was equilibrated and permuted:
* . ScalePermstruct->DiagScale, indicates whether the rows and/or
* columns of A were scaled
* . ScalePermstruct->R, array of row scale factors
* . ScalePermstruct->C, array of column scale factors
* . ScalePermstruct->perm_r, row permutation vector
* . ScalePermstruct->perm_c, column permutation vector
*
* (part of ScalePermstruct may also need to be supplied on input,
* depending on options->RowPerm and options->ColPerm as described
* later).
*
* o A, the input matrix A overwritten by the scaled and permuted
* matrix Pc*Pr*diag(R)*A*diag(C), where
* Pr and Pc are row and columns permutation matrices determined
* by ScalePermstruct->perm_r and ScalePermstruct->perm_c,
* respectively, and
* diag(R) and diag(C) are diagonal scaling matrices determined
* by ScalePermstruct->DiagScale, ScalePermstruct->R and
* ScalePermstruct->C
*
* o LUstruct, which contains the L and U factorization of A1 where
*
* A1 = Pc*Pr*diag(R)*A*diag(C)*Pc^T = L*U
*
* (Note that A1 = Aout * Pc^T, where Aout is the matrix stored
* in A on output.)
*
* 3. The second value of options->Fact assumes that a matrix with the same
* sparsity pattern as A has already been factored:
*
* - options->Fact = SamePattern: A is factored, assuming that it has
* the same nonzero pattern as a previously factored matrix. In
* this case the algorithm saves time by reusing the previously
* computed column permutation vector stored in
* ScalePermstruct->perm_c and the "elimination tree" of A
* stored in LUstruct->etree
*
* In this case the user must still specify the following options
* as before:
*
* o options->Equil
* o options->RowPerm
* o options->ReplaceTinyPivot
*
* but not options->ColPerm, whose value is ignored. This is because the
* previous column permutation from ScalePermstruct->perm_c is used as
* input. The user must also supply
*
* o A, the input matrix
* o ScalePermstruct->perm_c, the column permutation
* o LUstruct->etree, the elimination tree
*
* The outputs returned include
*
* o A, the input matrix A overwritten by the scaled and permuted
* matrix as described above
* o ScalePermstruct, modified to describe how the input matrix A was
* equilibrated and row permuted
* o LUstruct, modified to contain the new L and U factors
*
* 4. The third value of options->Fact assumes that a matrix B with the same
* sparsity pattern as A has already been factored, and where the
* row permutation of B can be reused for A. This is useful when A and B
* have similar numerical values, so that the same row permutation
* will make both factorizations numerically stable. This lets us reuse
* all of the previously computed structure of L and U.
*
* - options->Fact = SamePattern_SameRowPerm: A is factored,
* assuming not only the same nonzero pattern as the previously
* factored matrix B, but reusing B's row permutation.
*
* In this case the user must still specify the following options
* as before:
*
* o options->Equil
* o options->ReplaceTinyPivot
*
* but not options->RowPerm or options->ColPerm, whose values are
* ignored. This is because the permutations from ScalePermstruct->perm_r
* and ScalePermstruct->perm_c are used as input.
*
* The user must also supply
*
* o A, the input matrix
* o ScalePermstruct->DiagScale, how the previous matrix was row
* and/or column scaled
* o ScalePermstruct->R, the row scalings of the previous matrix,
* if any
* o ScalePermstruct->C, the columns scalings of the previous matrix,
* if any
* o ScalePermstruct->perm_r, the row permutation of the previous
* matrix
* o ScalePermstruct->perm_c, the column permutation of the previous
* matrix
* o all of LUstruct, the previously computed information about
* L and U (the actual numerical values of L and U
* stored in LUstruct->Llu are ignored)
*
* The outputs returned include
*
* o A, the input matrix A overwritten by the scaled and permuted
* matrix as described above
* o ScalePermstruct, modified to describe how the input matrix A was
* equilibrated (thus ScalePermstruct->DiagScale,
* R and C may be modified)
* o LUstruct, modified to contain the new L and U factors
*
* 5. The fourth and last value of options->Fact assumes that A is
* identical to a matrix that has already been factored on a previous
* call, and reuses its entire LU factorization
*
* - options->Fact = Factored: A is identical to a previously
* factorized matrix, so the entire previous factorization
* can be reused.
*
* In this case all the other options mentioned above are ignored
* (options->Equil, options->RowPerm, options->ColPerm,
* options->ReplaceTinyPivot)
*
* The user must also supply
*
* o A, the unfactored matrix, only in the case that iterative
* refinment is to be done (specifically A must be the output
* A from the previous call, so that it has been scaled and
* permuted)
* o all of ScalePermstruct
* o all of LUstruct, including the actual numerical values of
* L and U
*
* all of which are unmodified on output.
*
* Arguments
* =========
*
* options (input) superlu_options_t_Distributed* (global)
* The structure defines the input parameters to control
* how the LU decomposition will be performed.
* The following fields should be defined for this structure:
*
* o Fact (fact_t)
* Specifies whether or not the factored form of the matrix
* A is supplied on entry, and if not, how the matrix A should
* be factorized based on the previous history.
*
* = DOFACT: The matrix A will be factorized from scratch.
* Inputs: A
* options->Equil, RowPerm, ColPerm, ReplaceTinyPivot
* Outputs: modified A
* (possibly row and/or column scaled and/or
* permuted)
* all of ScalePermstruct
* all of LUstruct
*
* = SamePattern: the matrix A will be factorized assuming
* that a factorization of a matrix with the same sparsity
* pattern was performed prior to this one. Therefore, this
* factorization will reuse column permutation vector
* ScalePermstruct->perm_c and the elimination tree
* LUstruct->etree
* Inputs: A
* options->Equil, RowPerm, ReplaceTinyPivot
* ScalePermstruct->perm_c
* LUstruct->etree
* Outputs: modified A
* (possibly row and/or column scaled and/or
* permuted)
* rest of ScalePermstruct (DiagScale, R, C, perm_r)
* rest of LUstruct (GLU_persist, Llu)
*
* = SamePattern_SameRowPerm: the matrix A will be factorized
* assuming that a factorization of a matrix with the same
* sparsity pattern and similar numerical values was performed
* prior to this one. Therefore, this factorization will reuse
* both row and column scaling factors R and C, and the
* both row and column permutation vectors perm_r and perm_c,
* distributed data structure set up from the previous symbolic
* factorization.
* Inputs: A
* options->Equil, ReplaceTinyPivot
* all of ScalePermstruct
* all of LUstruct
* Outputs: modified A
* (possibly row and/or column scaled and/or
* permuted)
* modified LUstruct->Llu
* = FACTORED: the matrix A is already factored.
* Inputs: all of ScalePermstruct
* all of LUstruct
*
* o Equil (yes_no_t)
* Specifies whether to equilibrate the system.
* = NO: no equilibration.
* = YES: scaling factors are computed to equilibrate the system:
* diag(R)*A*diag(C)*inv(diag(C))*X = diag(R)*B.
* Whether or not the system will be equilibrated depends
* on the scaling of the matrix A, but if equilibration is
* used, A is overwritten by diag(R)*A*diag(C) and B by
* diag(R)*B.
*
* o RowPerm (rowperm_t)
* Specifies how to permute rows of the matrix A.
* = NATURAL: use the natural ordering.
* = LargeDiag: use the Duff/Koster algorithm to permute rows of
* the original matrix to make the diagonal large
* relative to the off-diagonal.
* = MY_PERMR: use the ordering given in ScalePermstruct->perm_r
* input by the user.
*
* o ColPerm (colperm_t)
* Specifies what type of column permutation to use to reduce fill.
* = NATURAL: natural ordering.
* = MMD_AT_PLUS_A: minimum degree ordering on structure of A'+A.
* = MMD_ATA: minimum degree ordering on structure of A'*A.
* = COLAMD: approximate minimum degree column ordering.
* = MY_PERMC: the ordering given in ScalePermstruct->perm_c.
*
* o ReplaceTinyPivot (yes_no_t)
* = NO: do not modify pivots
* = YES: replace tiny pivots by sqrt(epsilon)*norm(A) during
* LU factorization.
*
* o IterRefine (IterRefine_t)
* Specifies how to perform iterative refinement.
* = NO: no iterative refinement.
* = DOUBLE: accumulate residual in double precision.
* = EXTRA: accumulate residual in extra precision.
*
* NOTE: all options must be indentical on all processes when
* calling this routine.
*
* A (input/output) SuperMatrix* (local)
* On entry, matrix A in A*X=B, of dimension (A->nrow, A->ncol).
* The number of linear equations is A->nrow. The type of A must be:
* Stype = SLU_NR_loc; Dtype = SLU_D; Mtype = SLU_GE.
* That is, A is stored in distributed compressed row format.
* See supermatrix.h for the definition of 'SuperMatrix'.
* This routine only handles square A, however, the LU factorization
* routine PDGSTRF can factorize rectangular matrices.
* On exit, A may be overwtirren by Pc*Pr*diag(R)*A*diag(C),
* depending on ScalePermstruct->DiagScale, options->RowPerm and
* options->ColPerm:
* if ScalePermstruct->DiagScale != NOEQUIL, A is overwritten by
* diag(R)*A*diag(C).
* if options->RowPerm != NATURAL, A is further overwritten by
* Pr*diag(R)*A*diag(C).
* if options->ColPerm != NATURAL, A is further overwritten by
* Pc*Pr*diag(R)*A*diag(C).
* If all the above condition are true, the LU decomposition is
* performed on the matrix Pc*Pr*diag(R)*A*diag(C)*Pc^T.
*
* ScalePermstruct (input/output) ScalePermstruct_t* (global)
* The data structure to store the scaling and permutation vectors
* describing the transformations performed to the matrix A.
* It contains the following fields:
*
* o DiagScale (DiagScale_t)
* Specifies the form of equilibration that was done.
* = NOEQUIL: no equilibration.
* = ROW: row equilibration, i.e., A was premultiplied by
* diag(R).
* = COL: Column equilibration, i.e., A was postmultiplied
* by diag(C).
* = BOTH: both row and column equilibration, i.e., A was
* replaced by diag(R)*A*diag(C).
* If options->Fact = FACTORED or SamePattern_SameRowPerm,
* DiagScale is an input argument; otherwise it is an output
* argument.
*
* o perm_r (int*)
* Row permutation vector, which defines the permutation matrix Pr;
* perm_r[i] = j means row i of A is in position j in Pr*A.
* If options->RowPerm = MY_PERMR, or
* options->Fact = SamePattern_SameRowPerm, perm_r is an
* input argument; otherwise it is an output argument.
*
* o perm_c (int*)
* Column permutation vector, which defines the
* permutation matrix Pc; perm_c[i] = j means column i of A is
* in position j in A*Pc.
* If options->ColPerm = MY_PERMC or options->Fact = SamePattern
* or options->Fact = SamePattern_SameRowPerm, perm_c is an
* input argument; otherwise, it is an output argument.
* On exit, perm_c may be overwritten by the product of the input
* perm_c and a permutation that postorders the elimination tree
* of Pc*A'*A*Pc'; perm_c is not changed if the elimination tree
* is already in postorder.
*
* o R (double*) dimension (A->nrow)
* The row scale factors for A.
* If DiagScale = ROW or BOTH, A is multiplied on the left by
* diag(R).
* If DiagScale = NOEQUIL or COL, R is not defined.
* If options->Fact = FACTORED or SamePattern_SameRowPerm, R is
* an input argument; otherwise, R is an output argument.
*
* o C (double*) dimension (A->ncol)
* The column scale factors for A.
* If DiagScale = COL or BOTH, A is multiplied on the right by
* diag(C).
* If DiagScale = NOEQUIL or ROW, C is not defined.
* If options->Fact = FACTORED or SamePattern_SameRowPerm, C is
* an input argument; otherwise, C is an output argument.
*
* B (input/output) double* (local)
* On entry, the right-hand side matrix of dimension (m_loc, nrhs),
* where, m_loc is the number of rows stored locally on my
* process and is defined in the data structure of matrix A.
* On exit, the solution matrix if info = 0;
*
* ldb (input) int (local)
* The leading dimension of matrix B.
*
* nrhs (input) int (global)
* The number of right-hand sides.
* If nrhs = 0, only LU decomposition is performed, the forward
* and back substitutions are skipped.
*
* grid (input) gridinfo_t* (global)
* The 2D process mesh. It contains the MPI communicator, the number
* of process rows (NPROW), the number of process columns (NPCOL),
* and my process rank. It is an input argument to all the
* parallel routines.
* Grid can be initialized by subroutine SUPERLU_GRIDINIT.
* See superlu_ddefs.h for the definition of 'gridinfo_t'.
*
* LUstruct (input/output) LUstruct_t*
* The data structures to store the distributed L and U factors.
* It contains the following fields:
*
* o etree (int*) dimension (A->ncol) (global)
* Elimination tree of Pc*(A'+A)*Pc' or Pc*A'*A*Pc'.
* It is computed in sp_colorder() during the first factorization,
* and is reused in the subsequent factorizations of the matrices
* with the same nonzero pattern.
* On exit of sp_colorder(), the columns of A are permuted so that
* the etree is in a certain postorder. This postorder is reflected
* in ScalePermstruct->perm_c.
* NOTE:
* Etree is a vector of parent pointers for a forest whose vertices
* are the integers 0 to A->ncol-1; etree[root]==A->ncol.
*
* o Glu_persist (Glu_persist_t*) (global)
* Global data structure (xsup, supno) replicated on all processes,
* describing the supernode partition in the factored matrices
* L and U:
* xsup[s] is the leading column of the s-th supernode,
* supno[i] is the supernode number to which column i belongs.
*
* o Llu (LocalLU_t*) (local)
* The distributed data structures to store L and U factors.
* See superlu_ddefs.h for the definition of 'LocalLU_t'.
*
* SOLVEstruct (input/output) SOLVEstruct_t*
* The data structure to hold the communication pattern used
* in the phases of triangular solution and iterative refinement.
* This pattern should be intialized only once for repeated solutions.
* If options->SolveInitialized = YES, it is an input argument.
* If options->SolveInitialized = NO and nrhs != 0, it is an output
* argument. See superlu_ddefs.h for the definition of 'SOLVEstruct_t'.
*
* berr (output) double*, dimension (nrhs) (global)
* 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).
*
* stat (output) SuperLUStat_t*
* Record the statistics on runtime and floating-point operation count.
* See util.h for the definition of 'SuperLUStat_t'.
*
* info (output) int*
* = 0: successful exit
* > 0: if info = i, and i is
* <= A->ncol: U(i,i) is exactly zero. The factorization has
* been completed, but the factor U is exactly singular,
* so the solution could not be computed.
* > A->ncol: number of bytes allocated when memory allocation
* failure occurred, plus A->ncol.
*
* See superlu_ddefs.h for the definitions of varioous data types.
*
*/
NRformat_loc *Astore;
SuperMatrix GA; /* Global A in NC format */
NCformat *GAstore;
double *a_GA;
SuperMatrix GAC; /* Global A in NCP format (add n end pointers) */
NCPformat *GACstore;
Glu_persist_t *Glu_persist = LUstruct->Glu_persist;
Glu_freeable_t *Glu_freeable;
/* The nonzero structures of L and U factors, which are
replicated on all processrs.
(lsub, xlsub) contains the compressed subscript of
supernodes in L.
(usub, xusub) contains the compressed subscript of
nonzero segments in U.
If options->Fact != SamePattern_SameRowPerm, they are
computed by SYMBFACT routine, and then used by PDDISTRIBUTE
routine. They will be freed after PDDISTRIBUTE routine.
If options->Fact == SamePattern_SameRowPerm, these
structures are not used. */
fact_t Fact;
double *a;
int_t *colptr, *rowind;
int_t *perm_r; /* row permutations from partial pivoting */
int_t *perm_c; /* column permutation vector */
int_t *etree; /* elimination tree */
int_t *rowptr, *colind; /* Local A in NR*/
int_t *rowind_loc, *colptr_loc;
int_t colequ, Equil, factored, job, notran, rowequ, need_value;
int_t i, iinfo, j, irow, m, n, nnz, permc_spec, dist_mem_use;
int_t nnz_loc, m_loc, fst_row, icol;
int iam;
int ldx; /* LDA for matrix X (local). */
char equed[1], norm[1];
double *C, *R, *C1, *R1, amax, anorm, colcnd, rowcnd;
double *X, *b_col, *b_work, *x_col;
double t;
static mem_usage_t_Distributed num_mem_usage, symb_mem_usage;
#if ( PRNTlevel>= 2 )
double dmin, dsum, dprod;
#endif
int_t procs;
/* Initialization. */
m = A->nrow;
n = A->ncol;
Astore = (NRformat_loc *) A->Store;
nnz_loc = Astore->nnz_loc;
m_loc = Astore->m_loc;
fst_row = Astore->fst_row;
a = Astore->nzval;
rowptr = Astore->rowptr;
colind = Astore->colind;
/* Test the input parameters. */
*info = 0;
Fact = options->Fact;
if ( Fact < 0 || Fact > FACTORED )
*info = -1;
else if ( options->RowPerm < 0 || options->RowPerm > MY_PERMR )
*info = -1;
else if ( options->ColPerm < 0 || options->ColPerm > MY_PERMC )
*info = -1;
else if ( options->IterRefine < 0 || options->IterRefine > EXTRA )
*info = -1;
else if ( options->IterRefine == EXTRA ) {
*info = -1;
fprintf(stderr, "Extra precise iterative refinement yet to support.");
} else if ( A->nrow != A->ncol || A->nrow < 0 || A->Stype != SLU_NR_loc
|| A->Dtype != SLU_D || A->Mtype != SLU_GE )
*info = -2;
else if ( ldb < m_loc )
*info = -5;
else if ( nrhs < 0 )
*info = -6;
if ( *info ) {
i = -(*info);
pxerbla("pdgssvx", grid, -*info);
return;
}
factored = (Fact == FACTORED);
Equil = (!factored && options->Equil == YES);
notran = (options->Trans == NOTRANS);
iam = grid->iam;
job = 5;
if ( factored || (Fact == SamePattern_SameRowPerm && Equil) ) {
rowequ = (ScalePermstruct->DiagScale == ROW) ||
(ScalePermstruct->DiagScale == BOTH);
colequ = (ScalePermstruct->DiagScale == COL) ||
(ScalePermstruct->DiagScale == BOTH);
} else rowequ = colequ = FALSE;
/* The following arrays are replicated on all processes. */
perm_r = ScalePermstruct->perm_r;
perm_c = ScalePermstruct->perm_c;
etree = LUstruct->etree;
R = ScalePermstruct->R;
C = ScalePermstruct->C;
/********/
#if ( DEBUGlevel>=1 )
CHECK_MALLOC(iam, "Enter pdgssvx()");
#endif
if ( Equil ) {
/* Allocate storage if not done so before. */
switch ( ScalePermstruct->DiagScale ) {
case NOEQUIL:
if ( !(R = (double *) doubleMalloc_dist(m)) )
ABORT("Malloc fails for R[].");
if ( !(C = (double *) doubleMalloc_dist(n)) )
ABORT("Malloc fails for C[].");
ScalePermstruct->R = R;
ScalePermstruct->C = C;
break;
case ROW:
if ( !(C = (double *) doubleMalloc_dist(n)) )
ABORT("Malloc fails for C[].");
ScalePermstruct->C = C;
break;
case COL:
if ( !(R = (double *) doubleMalloc_dist(m)) )
ABORT("Malloc fails for R[].");
ScalePermstruct->R = R;
break;
}
}
/* ------------------------------------------------------------
Diagonal scaling to equilibrate the matrix.
------------------------------------------------------------*/
if ( Equil ) {
#if ( DEBUGlevel>=1 )
CHECK_MALLOC(iam, "Enter equil");
#endif
t = SuperLU_timer_();
if ( Fact == SamePattern_SameRowPerm ) {
/* Reuse R and C. */
switch ( ScalePermstruct->DiagScale ) {
case NOEQUIL:
break;
case ROW:
irow = fst_row;
for (j = 0; j < m_loc; ++j) {
for (i = rowptr[j]; i < rowptr[j+1]; ++i) {
a[i] *= R[irow]; /* Scale rows. */
}
++irow;
}
break;
case COL:
for (j = 0; j < m_loc; ++j)
for (i = rowptr[j]; i < rowptr[j+1]; ++i) {
icol = colind[i];
a[i] *= C[icol]; /* Scale columns. */
}
break;
case BOTH:
irow = fst_row;
for (j = 0; j < m_loc; ++j) {
for (i = rowptr[j]; i < rowptr[j+1]; ++i) {
icol = colind[i];
a[i] *= R[irow] * C[icol]; /* Scale rows and cols. */
}
++irow;
}
break;
}
} else {
/* Compute the row and column scalings. */
pdgsequ(A, R, C, &rowcnd, &colcnd, &amax, &iinfo, grid);
/* Equilibrate matrix A if it is badly-scaled. */
pdlaqgs(A, R, C, rowcnd, colcnd, amax, equed);
if ( lsame_(equed, "R") ) {
ScalePermstruct->DiagScale = rowequ = ROW;
} else if ( lsame_(equed, "C") ) {
ScalePermstruct->DiagScale = colequ = COL;
} else if ( lsame_(equed, "B") ) {
ScalePermstruct->DiagScale = BOTH;
rowequ = ROW;
colequ = COL;
} else ScalePermstruct->DiagScale = NOEQUIL;
#if ( PRNTlevel>=1 )
if ( !iam ) {
printf(".. equilibrated? *equed = %c\n", *equed);
/*fflush(stdout);*/
}
#endif
} /* if Fact ... */
stat->utime[EQUIL] = SuperLU_timer_() - t;
#if ( DEBUGlevel>=1 )
CHECK_MALLOC(iam, "Exit equil");
#endif
} /* if Equil ... */
/*
* Gather A from the distributed compressed row format to
* global A in compressed column format.
* Numerical values are gathered only when a row permutation
* for large diagonal is sought after.
*/
need_value = (options->RowPerm == LargeDiag &&
Fact != SamePattern_SameRowPerm && !factored);
pdCompRow_loc_to_CompCol_global(need_value, A, grid, &GA);
GAstore = (NCformat *) GA.Store;
colptr = GAstore->colptr;
rowind = GAstore->rowind;
nnz = GAstore->nnz;
if ( need_value ) a_GA = GAstore->nzval;
else assert(GAstore->nzval == NULL);
/* ------------------------------------------------------------
Find the row permutation for A.
------------------------------------------------------------*/
if ( options->RowPerm != NO ) {
t = SuperLU_timer_();
if ( options->RowPerm == MY_PERMR ) { /* Use user's perm_r. */
/* Permute the global matrix GA for symbfact() */
for (i = 0; i < colptr[n]; ++i) {
irow = rowind[i];
rowind[i] = perm_r[irow];
}
} else if ( !factored && Fact != SamePattern_SameRowPerm ) {
/* Get a new perm_r[] */
if ( job == 5 ) {
/* Allocate storage for scaling factors. */
if ( !(R1 = (double *) SUPERLU_MALLOC(m * sizeof(double))) )
ABORT("SUPERLU_MALLOC fails for R1[]");
if ( !(C1 = (double *) SUPERLU_MALLOC(n * sizeof(double))) )
ABORT("SUPERLU_MALLOC fails for C1[]");
}
if ( !iam ) {
/* Process 0 finds a row permutation for large diagonal. */
dldperm(job, m, nnz, colptr, rowind, a_GA, perm_r, R1, C1);
MPI_Bcast( perm_r, m, mpi_int_t, 0, grid->comm );
if ( job == 5 && Equil ) {
MPI_Bcast( R1, m, MPI_DOUBLE, 0, grid->comm );
MPI_Bcast( C1, n, MPI_DOUBLE, 0, grid->comm );
}
} else {
MPI_Bcast( perm_r, m, mpi_int_t, 0, grid->comm );
if ( job == 5 && Equil ) {
MPI_Bcast( R1, m, MPI_DOUBLE, 0, grid->comm );
MPI_Bcast( C1, n, MPI_DOUBLE, 0, grid->comm );
}
}
#if ( PRNTlevel>=2 )
dmin = dlamch_("Overflow");
dsum = 0.0;
dprod = 1.0;
#endif
if ( job == 5 ) {
if ( Equil ) {
for (i = 0; i < n; ++i) {
R1[i] = exp(R1[i]);
C1[i] = exp(C1[i]);
}
/* Permute the global matrix GA for symbfact(). */
for (j = 0; j < n; ++j) {
for (i = colptr[j]; i < colptr[j+1]; ++i) {
irow = rowind[i];
rowind[i] = perm_r[irow];
#if ( PRNTlevel>=2 )
if ( rowind[i] == j ) /* New diagonal */
dprod *= fabs(a[i]);
#endif
}
}
/* Scale the distributed matrix */
irow = fst_row;
for (j = 0; j < m_loc; ++j) {
for (i = rowptr[j]; i < rowptr[j+1]; ++i) {
icol = colind[i];
a[i] *= R1[irow] * C1[icol];
}
++irow;
}
/* Multiply together the scaling factors. */
if ( rowequ ) for (i = 0; i < m; ++i) R[i] *= R1[i];
else for (i = 0; i < m; ++i) R[i] = R1[i];
if ( colequ ) for (i = 0; i < n; ++i) C[i] *= C1[i];
else for (i = 0; i < n; ++i) C[i] = C1[i];
ScalePermstruct->DiagScale = BOTH;
rowequ = colequ = 1;
} else { /* No equilibration. Only permute the global A. */
for (i = colptr[0]; i < colptr[n]; ++i) {
irow = rowind[i];
rowind[i] = perm_r[irow];
}
}
SUPERLU_FREE (R1);
SUPERLU_FREE (C1);
} else { /* job = 2,3,4 */
for (j = 0; j < n; ++j) {
for (i = colptr[j]; i < colptr[j+1]; ++i) {
irow = rowind[i];
rowind[i] = perm_r[irow];
#if ( PRNTlevel>=2 )
if ( rowind[i] == j ) { /* New diagonal */
if ( job == 2 || job == 3 )
dmin = SUPERLU_MIN(dmin, fabs(a[i]));
else if ( job == 4 )
dsum += fabs(a[i]);
else if ( job == 5 )
dprod *= fabs(a[i]);
}
#endif
}
}
}
#if ( PRNTlevel>=2 )
if ( job == 2 || job == 3 ) {
if ( !iam ) printf("\tsmallest diagonal %e\n", dmin);
} else if ( job == 4 ) {
if ( !iam ) printf("\tsum of diagonal %e\n", dsum);
} else if ( job == 5 ) {
if ( !iam ) printf("\t product of diagonal %e\n", dprod);
}
#endif
} /* else !factored */
t = SuperLU_timer_() - t;
stat->utime[ROWPERM] = t;
#if ( PRNTlevel>=1 )
if ( !iam ) printf(".. LDPERM job %d\t time: %.2f\n", job, t);
#endif
} else { /* options->RowPerm == NOROWPERM */
for (i = 0; i <m; ++i) perm_r[i] = i;
}
#if ( DEBUGlevel>=1 )
if ( !iam ) PrintInt10("perm_r", m, perm_r);
#endif
if ( !factored || options->IterRefine ) {
/* Compute norm(A), which will be used to adjust small diagonal. */
if ( notran ) *(unsigned char *)norm = '1';
else *(unsigned char *)norm = 'I';
anorm = pdlangs(norm, A, grid);
#if ( PRNTlevel>=1 )
if ( !iam ) printf(".. anorm %e\n", anorm);
#endif
}
/* ------------------------------------------------------------
Perform the LU factorization.
------------------------------------------------------------*/
if ( !factored ) {
t = SuperLU_timer_();
/*
* Get column permutation vector perm_c[], according to permc_spec:
* permc_spec = NATURAL: natural ordering
* permc_spec = MMD_AT_PLUS_A: minimum degree on structure of A'+A
* permc_spec = MMD_ATA: minimum degree on structure of A'*A
* permc_spec = COLAMD: approximate minimum degree column ordering
* permc_spec = MY_PERMC: the ordering already supplied in perm_c[]
*/
permc_spec = options->ColPerm;
if ( permc_spec != MY_PERMC && Fact == DOFACT )
get_perm_c_dist(iam, permc_spec, &GA, perm_c);
/* Compute the elimination tree of Pc*(A'+A)*Pc' or Pc*A'*A*Pc'
(a.k.a. column etree), depending on the choice of ColPerm.
Adjust perm_c[] to be consistent with a postorder of etree.
Permute columns of A to form A*Pc'. */
sp_colorder(options, &GA, perm_c, etree, &GAC);
/* Form Pc*A*Pc' to preserve the diagonal of the matrix GAC. */
{
int_t *GACcolbeg, *GACcolend, *GACrowind;
GACstore = GAC.Store;
GACcolbeg = GACstore->colbeg;
GACcolend = GACstore->colend;
GACrowind = GACstore->rowind;
for (j = 0; j < n; ++j) {
for (i = GACcolbeg[j]; i < GACcolend[j]; ++i) {
irow = GACrowind[i];
GACrowind[i] = perm_c[irow];
}
}
}
stat->utime[COLPERM] = SuperLU_timer_() - t;
/* Perform a symbolic factorization on Pc*Pr*A*Pc' and set up the
nonzero data structures which are suitable for supernodal GENP. */
if ( Fact != SamePattern_SameRowPerm ) {
#if ( PRNTlevel>=1 )
if ( !iam )
printf(".. symbfact(): relax %4d, maxsuper %4d, fill %4d\n",
sp_ienv_dist(2), sp_ienv_dist(3), sp_ienv_dist(6));
#endif
t = SuperLU_timer_();
if ( !(Glu_freeable = (Glu_freeable_t *)
SUPERLU_MALLOC(sizeof(Glu_freeable_t))) )
ABORT("Malloc fails for Glu_freeable.");
/* Every process does this. */
iinfo = symbfact(iam, &GAC, perm_c, etree,
Glu_persist, Glu_freeable);
stat->utime[SYMBFAC] = SuperLU_timer_() - t;
if ( iinfo < 0 ) { /* Successful return */
QuerySpace_dist(n, -iinfo, Glu_freeable, &symb_mem_usage);
#if ( PRNTlevel>=1 )
if ( !iam ) {
printf("\tNo of supers %ld\n", Glu_persist->supno[n-1]+1);
printf("\tSize of G(L) %ld\n", Glu_freeable->xlsub[n]);
printf("\tSize of G(U) %ld\n", Glu_freeable->xusub[n]);
printf("\tint %d, short %d, float %d, double %d\n",
sizeof(int_t), sizeof(short), sizeof(float),
sizeof(double));
printf("\tSYMBfact (MB):\tL\\U %.2f\ttotal %.2f\texpansions %d\n",
symb_mem_usage.for_lu*1e-6,
symb_mem_usage.total*1e-6,
symb_mem_usage.expansions);
}
#endif
} else {
if ( !iam ) {
fprintf(stderr, "symbfact() error returns %d\n", iinfo);
exit(-1);
}
}
}
/* Apply column permutation to the original distributed A */
for (j = 0; j < nnz_loc; ++j) colind[j] = perm_c[colind[j]];
/* Distribute Pc*Pr*diag(R)*A*diag(C)*Pc' into L and U storage.
NOTE: the row permutation Pc*Pr is applied internally in the
distribution routine. */
t = SuperLU_timer_();
dist_mem_use = pddistribute(Fact, n, A, ScalePermstruct,
Glu_freeable, LUstruct, grid);
stat->utime[DIST] = SuperLU_timer_() - t;
/* Deallocate storage used in symbolic factorization. */
if ( Fact != SamePattern_SameRowPerm ) {
iinfo = symbfact_SubFree(Glu_freeable);
SUPERLU_FREE(Glu_freeable);
}
/* Perform numerical factorization in parallel. */
t = SuperLU_timer_();
pdgstrf(options, m, n, anorm, LUstruct, grid, stat, info);
stat->utime[FACT] = SuperLU_timer_() - t;
#if ( PRNTlevel>=1 )
{
int_t TinyPivots;
float for_lu, total, max, avg, temp;
dQuerySpace_dist(n, LUstruct, grid, &num_mem_usage);
MPI_Reduce( &num_mem_usage.for_lu, &for_lu,
1, MPI_FLOAT, MPI_SUM, 0, grid->comm );
MPI_Reduce( &num_mem_usage.total, &total,
1, MPI_FLOAT, MPI_SUM, 0, grid->comm );
temp = SUPERLU_MAX(symb_mem_usage.total,
symb_mem_usage.for_lu +
(float)dist_mem_use + num_mem_usage.for_lu);
temp = SUPERLU_MAX(temp, num_mem_usage.total);
MPI_Reduce( &temp, &max,
1, MPI_FLOAT, MPI_MAX, 0, grid->comm );
MPI_Reduce( &temp, &avg,
1, MPI_FLOAT, MPI_SUM, 0, grid->comm );
MPI_Allreduce( &stat->TinyPivots, &TinyPivots, 1, mpi_int_t,
MPI_SUM, grid->comm );
stat->TinyPivots = TinyPivots;
if ( !iam ) {
printf("\tNUMfact (MB) all PEs:\tL\\U\t%.2f\tall\t%.2f\n",
for_lu*1e-6, total*1e-6);
printf("\tAll space (MB):"
"\t\ttotal\t%.2f\tAvg\t%.2f\tMax\t%.2f\n",
avg*1e-6, avg/grid->nprow/grid->npcol*1e-6, max*1e-6);
printf("\tNumber of tiny pivots: %10d\n", stat->TinyPivots);
}
}
#endif
} else if ( options->IterRefine ) { /* options->Fact==FACTORED */
/* Permute columns of A to form A*Pc' using the existing perm_c.
* NOTE: rows of A were previously permuted to Pc*A.
*
* XSL: NO; this is different now.
*/
sp_colorder(options, &GA, perm_c, NULL, &GAC); /* ????? */
} /* if !factored ... */
/* Destroy GA */
Destroy_CompCol_Matrix_dist(&GA);
#if ( DEBUGlevel>=1 )
CHECK_MALLOC(iam, "Before solve");
#endif
/* ------------------------------------------------------------
Compute the solution matrix X.
------------------------------------------------------------*/
if ( nrhs ) {
if ( !(b_work = doubleMalloc_dist(n)) )
ABORT("Malloc fails for b_work[]");
/* ------------------------------------------------------------
Scale the right-hand side if equilibration was performed.
------------------------------------------------------------*/
if ( notran ) {
if ( rowequ ) {
b_col = B;
for (j = 0; j < nrhs; ++j) {
irow = fst_row;
for (i = 0; i < m_loc; ++i) {
b_col[i] *= R[irow];
++irow;
}
b_col += ldb;
}
}
} else if ( colequ ) {
b_col = B;
for (j = 0; j < nrhs; ++j) {
irow = fst_row;
for (i = 0; i < m_loc; ++i) {
b_col[i] *= C[irow];
++irow;
}
b_col += ldb;
}
}
/* Save a copy of the right-hand side. */
ldx = ldb;
if ( !(X = doubleMalloc_dist(((size_t)ldx) * nrhs)) )
ABORT("Malloc fails for X[]");
x_col = X;
b_col = B;
for (j = 0; j < nrhs; ++j) {
for (i = 0; i < m_loc; ++i) x_col[i] = b_col[i];
x_col += ldx;
b_col += ldb;
}
/* ------------------------------------------------------------
Solve the linear system.
------------------------------------------------------------*/
if ( options->SolveInitialized == NO ) {
dSolveInit(options, A, perm_r, perm_c, nrhs, LUstruct, grid,
SOLVEstruct);
}
pdgstrs(n, LUstruct, ScalePermstruct, grid, X, m_loc,
fst_row, ldb, nrhs, SOLVEstruct, stat, info);
#if ( DEBUGlevel>=2 )
printf("\n(%d) .. After pdgstrs(): x =\n", iam);
for (i = 0; i < m_loc; ++i)
printf("\t(%d)\t%4d\t%.10f\n", iam, i+fst_row, X[i]);
#endif
/* ------------------------------------------------------------
Use iterative refinement to improve the computed solution and
compute error bounds and backward error estimates for it.
------------------------------------------------------------*/
if ( options->IterRefine ) {
/* Improve the solution by iterative refinement. */
t = SuperLU_timer_();
pdgsrfs(n, A, anorm, LUstruct, ScalePermstruct, grid,
B, ldb, X, ldx, nrhs, SOLVEstruct, berr, stat, info);
stat->utime[REFINE] = SuperLU_timer_() - t;
}
/* Permute the solution matrix B <= Pc'*X. */
pdPermute_Dense_Matrix(fst_row, m_loc, SOLVEstruct->row_to_proc,
SOLVEstruct->inv_perm_c,
X, ldx, B, ldb, nrhs, grid);
#if ( DEBUGlevel>=2 )
printf("\n (%d) .. After pdPermute_Dense_Matrix(): b =\n", iam);
for (i = 0; i < m_loc; ++i)
printf("\t(%d)\t%4d\t%.10f\n", iam, i+fst_row, B[i]);
#endif
/* Transform the solution matrix X to a solution of the original
system before the equilibration. */
if ( notran ) {
if ( colequ ) {
b_col = B;
for (j = 0; j < nrhs; ++j) {
irow = fst_row;
for (i = 0; i < m_loc; ++i) {
b_col[i] *= C[irow];
++irow;
}
b_col += ldb;
}
}
} else if ( rowequ ) {
b_col = B;
for (j = 0; j < nrhs; ++j) {
irow = fst_row;
for (i = 0; i < m_loc; ++i) {
b_col[i] *= R[irow];
++irow;
}
b_col += ldb;
}
}
SUPERLU_FREE(b_work);
SUPERLU_FREE(X);
} /* end if nrhs != 0 */
#if ( PRNTlevel>=1 )
if ( !iam ) printf(".. DiagScale = %d\n", ScalePermstruct->DiagScale);
#endif
/* Deallocate storage. */
if ( Equil && Fact != SamePattern_SameRowPerm ) {
switch ( ScalePermstruct->DiagScale ) {
case NOEQUIL:
SUPERLU_FREE(R);
SUPERLU_FREE(C);
break;
case ROW:
SUPERLU_FREE(C);
break;
case COL:
SUPERLU_FREE(R);
break;
}
}
if ( !factored || (factored && options->IterRefine) )
Destroy_CompCol_Permuted_dist(&GAC);
#if ( DEBUGlevel>=1 )
CHECK_MALLOC(iam, "Exit pdgssvx()");
#endif
}
/*< >*/
/* Subroutine */ int dsapps_(integer *n, integer *kev, integer *np,
doublereal *shift, doublereal *v, integer *ldv, doublereal *h__,
integer *ldh, doublereal *resid, doublereal *q, integer *ldq,
doublereal *workd)
{
/* Initialized data */
static logical first = TRUE_;
/* System generated locals */
integer h_dim1, h_offset, q_dim1, q_offset, v_dim1, v_offset, i__1, i__2,
i__3, i__4;
doublereal d__1, d__2;
/* Local variables */
doublereal c__, f, g;
integer i__, j;
doublereal r__, s, a1, a2, a3, a4;
/* static real t0, t1; */
integer jj;
doublereal big;
integer iend, itop;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *), dgemv_(char *, integer *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *, ftnlen), dcopy_(integer *, doublereal *,
integer *, doublereal *, integer *), daxpy_(integer *, doublereal
*, doublereal *, integer *, doublereal *, integer *);
extern doublereal dlamch_(char *, ftnlen);
extern /* Subroutine */ int second_(real *);
static doublereal epsmch;
integer istart, kplusp /*, msglvl */;
extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, ftnlen),
dlartg_(doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *), dlaset_(char *, integer *, integer *, doublereal *,
doublereal *, doublereal *, integer *, ftnlen);
/* %----------------------------------------------------% */
/* | Include files for debugging and timing information | */
/* %----------------------------------------------------% */
/*< include 'debug.h' >*/
/*< include 'stat.h' >*/
/* \SCCS Information: @(#) */
/* FILE: debug.h SID: 2.3 DATE OF SID: 11/16/95 RELEASE: 2 */
/* %---------------------------------% */
/* | See debug.doc for documentation | */
/* %---------------------------------% */
/*< >*/
/*< integer kev, ldh, ldq, ldv, n, np >*/
/* %------------------% */
/* | Scalar Arguments | */
/* %------------------% */
/* %--------------------------------% */
/* | See stat.doc for documentation | */
/* %--------------------------------% */
/* \SCCS Information: @(#) */
/* FILE: stat.h SID: 2.2 DATE OF SID: 11/16/95 RELEASE: 2 */
/*< save t0, t1, t2, t3, t4, t5 >*/
/*< integer nopx, nbx, nrorth, nitref, nrstrt >*/
/*< >*/
/*< >*/
/* %-----------------% */
/* | Array Arguments | */
/* %-----------------% */
/*< >*/
/* %------------% */
/* | Parameters | */
/* %------------% */
/*< >*/
/*< parameter (one = 1.0D+0, zero = 0.0D+0) >*/
/* %---------------% */
/* | Local Scalars | */
/* %---------------% */
/*< integer i, iend, istart, itop, j, jj, kplusp, msglvl >*/
/*< logical first >*/
/*< >*/
/*< save epsmch, first >*/
/* %----------------------% */
/* | External Subroutines | */
/* %----------------------% */
/*< >*/
/* %--------------------% */
/* | External Functions | */
/* %--------------------% */
/*< >*/
/*< external dlamch >*/
/* %----------------------% */
/* | Intrinsics Functions | */
/* %----------------------% */
/*< intrinsic abs >*/
/* %----------------% */
/* | Data statments | */
/* %----------------% */
/*< data first / .true. / >*/
/* Parameter adjustments */
--workd;
--resid;
--shift;
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
h_dim1 = *ldh;
h_offset = 1 + h_dim1;
h__ -= h_offset;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
/* Function Body */
/* %-----------------------% */
/* | Executable Statements | */
/* %-----------------------% */
/*< if (first) then >*/
if (first) {
/*< epsmch = dlamch('Epsilon-Machine') >*/
epsmch = dlamch_("Epsilon-Machine", (ftnlen)15);
/*< first = .false. >*/
first = FALSE_;
/*< end if >*/
}
/*< itop = 1 >*/
itop = 1;
/* %-------------------------------% */
/* | Initialize timing statistics | */
/* | & message level for debugging | */
/* %-------------------------------% */
/*< call second (t0) >*/
/* second_(&t0); */
/*< msglvl = msapps >*/
/* msglvl = debug_1.msapps; */
/*< kplusp = kev + np >*/
kplusp = *kev + *np;
/* %----------------------------------------------% */
/* | Initialize Q to the identity matrix of order | */
/* | kplusp used to accumulate the rotations. | */
/* %----------------------------------------------% */
/*< call dlaset ('All', kplusp, kplusp, zero, one, q, ldq) >*/
dlaset_("All", &kplusp, &kplusp, &c_b4, &c_b5, &q[q_offset], ldq, (ftnlen)
3);
/* %----------------------------------------------% */
/* | Quick return if there are no shifts to apply | */
/* %----------------------------------------------% */
/*< if (np .eq. 0) go to 9000 >*/
if (*np == 0) {
goto L9000;
}
/* %----------------------------------------------------------% */
/* | Apply the np shifts implicitly. Apply each shift to the | */
/* | whole matrix and not just to the submatrix from which it | */
/* | comes. | */
/* %----------------------------------------------------------% */
/*< do 90 jj = 1, np >*/
i__1 = *np;
for (jj = 1; jj <= i__1; ++jj) {
/*< istart = itop >*/
istart = itop;
/* %----------------------------------------------------------% */
/* | Check for splitting and deflation. Currently we consider | */
/* | an off-diagonal element h(i+1,1) negligible if | */
/* | h(i+1,1) .le. epsmch*( |h(i,2)| + |h(i+1,2)| ) | */
/* | for i=1:KEV+NP-1. | */
/* | If above condition tests true then we set h(i+1,1) = 0. | */
/* | Note that h(1:KEV+NP,1) are assumed to be non negative. | */
/* %----------------------------------------------------------% */
/*< 20 continue >*/
L20:
/* %------------------------------------------------% */
/* | The following loop exits early if we encounter | */
/* | a negligible off diagonal element. | */
/* %------------------------------------------------% */
/*< do 30 i = istart, kplusp-1 >*/
i__2 = kplusp - 1;
for (i__ = istart; i__ <= i__2; ++i__) {
/*< big = abs(h(i,2)) + abs(h(i+1,2)) >*/
big = (d__1 = h__[i__ + (h_dim1 << 1)], abs(d__1)) + (d__2 = h__[
i__ + 1 + (h_dim1 << 1)], abs(d__2));
/*< if (h(i+1,1) .le. epsmch*big) then >*/
if (h__[i__ + 1 + h_dim1] <= epsmch * big) {
/* if (msglvl .gt. 0) then */
/* call ivout (logfil, 1, i, ndigit, */
/* & '_sapps: deflation at row/column no.') */
/* call ivout (logfil, 1, jj, ndigit, */
/* & '_sapps: occurred before shift number.') */
/* call dvout (logfil, 1, h(i+1,1), ndigit, */
/* & '_sapps: the corresponding off diagonal element') */
/* end if */
/*< h(i+1,1) = zero >*/
h__[i__ + 1 + h_dim1] = 0.;
/*< iend = i >*/
iend = i__;
/*< go to 40 >*/
goto L40;
/*< end if >*/
}
/*< 30 continue >*/
/* L30: */
}
/*< iend = kplusp >*/
iend = kplusp;
/*< 40 continue >*/
L40:
/*< if (istart .lt. iend) then >*/
if (istart < iend) {
/* %--------------------------------------------------------% */
/* | Construct the plane rotation G'(istart,istart+1,theta) | */
/* | that attempts to drive h(istart+1,1) to zero. | */
/* %--------------------------------------------------------% */
/*< f = h(istart,2) - shift(jj) >*/
f = h__[istart + (h_dim1 << 1)] - shift[jj];
/*< g = h(istart+1,1) >*/
g = h__[istart + 1 + h_dim1];
/*< call dlartg (f, g, c, s, r) >*/
dlartg_(&f, &g, &c__, &s, &r__);
/* %-------------------------------------------------------% */
/* | Apply rotation to the left and right of H; | */
/* | H <- G' * H * G, where G = G(istart,istart+1,theta). | */
/* | This will create a "bulge". | */
/* %-------------------------------------------------------% */
/*< a1 = c*h(istart,2) + s*h(istart+1,1) >*/
a1 = c__ * h__[istart + (h_dim1 << 1)] + s * h__[istart + 1 +
h_dim1];
/*< a2 = c*h(istart+1,1) + s*h(istart+1,2) >*/
a2 = c__ * h__[istart + 1 + h_dim1] + s * h__[istart + 1 + (
h_dim1 << 1)];
/*< a4 = c*h(istart+1,2) - s*h(istart+1,1) >*/
a4 = c__ * h__[istart + 1 + (h_dim1 << 1)] - s * h__[istart + 1 +
h_dim1];
/*< a3 = c*h(istart+1,1) - s*h(istart,2) >*/
a3 = c__ * h__[istart + 1 + h_dim1] - s * h__[istart + (h_dim1 <<
1)];
/*< h(istart,2) = c*a1 + s*a2 >*/
h__[istart + (h_dim1 << 1)] = c__ * a1 + s * a2;
/*< h(istart+1,2) = c*a4 - s*a3 >*/
h__[istart + 1 + (h_dim1 << 1)] = c__ * a4 - s * a3;
/*< h(istart+1,1) = c*a3 + s*a4 >*/
h__[istart + 1 + h_dim1] = c__ * a3 + s * a4;
/* %----------------------------------------------------% */
/* | Accumulate the rotation in the matrix Q; Q <- Q*G | */
/* %----------------------------------------------------% */
/*< do 60 j = 1, min(istart+jj,kplusp) >*/
/* Computing MIN */
i__3 = istart + jj;
i__2 = min(i__3,kplusp);
for (j = 1; j <= i__2; ++j) {
/*< a1 = c*q(j,istart) + s*q(j,istart+1) >*/
a1 = c__ * q[j + istart * q_dim1] + s * q[j + (istart + 1) *
q_dim1];
/*< q(j,istart+1) = - s*q(j,istart) + c*q(j,istart+1) >*/
q[j + (istart + 1) * q_dim1] = -s * q[j + istart * q_dim1] +
c__ * q[j + (istart + 1) * q_dim1];
/*< q(j,istart) = a1 >*/
q[j + istart * q_dim1] = a1;
/*< 60 continue >*/
/* L60: */
}
/* %----------------------------------------------% */
/* | The following loop chases the bulge created. | */
/* | Note that the previous rotation may also be | */
/* | done within the following loop. But it is | */
/* | kept separate to make the distinction among | */
/* | the bulge chasing sweeps and the first plane | */
/* | rotation designed to drive h(istart+1,1) to | */
/* | zero. | */
/* %----------------------------------------------% */
/*< do 70 i = istart+1, iend-1 >*/
i__2 = iend - 1;
for (i__ = istart + 1; i__ <= i__2; ++i__) {
/* %----------------------------------------------% */
/* | Construct the plane rotation G'(i,i+1,theta) | */
/* | that zeros the i-th bulge that was created | */
/* | by G(i-1,i,theta). g represents the bulge. | */
/* %----------------------------------------------% */
/*< f = h(i,1) >*/
f = h__[i__ + h_dim1];
/*< g = s*h(i+1,1) >*/
g = s * h__[i__ + 1 + h_dim1];
/* %----------------------------------% */
/* | Final update with G(i-1,i,theta) | */
/* %----------------------------------% */
/*< h(i+1,1) = c*h(i+1,1) >*/
h__[i__ + 1 + h_dim1] = c__ * h__[i__ + 1 + h_dim1];
/*< call dlartg (f, g, c, s, r) >*/
dlartg_(&f, &g, &c__, &s, &r__);
/* %-------------------------------------------% */
/* | The following ensures that h(1:iend-1,1), | */
/* | the first iend-2 off diagonal of elements | */
/* | H, remain non negative. | */
/* %-------------------------------------------% */
/*< if (r .lt. zero) then >*/
if (r__ < 0.) {
/*< r = -r >*/
r__ = -r__;
/*< c = -c >*/
c__ = -c__;
/*< s = -s >*/
s = -s;
/*< end if >*/
}
/* %--------------------------------------------% */
/* | Apply rotation to the left and right of H; | */
/* | H <- G * H * G', where G = G(i,i+1,theta) | */
/* %--------------------------------------------% */
/*< h(i,1) = r >*/
h__[i__ + h_dim1] = r__;
/*< a1 = c*h(i,2) + s*h(i+1,1) >*/
a1 = c__ * h__[i__ + (h_dim1 << 1)] + s * h__[i__ + 1 +
h_dim1];
/*< a2 = c*h(i+1,1) + s*h(i+1,2) >*/
a2 = c__ * h__[i__ + 1 + h_dim1] + s * h__[i__ + 1 + (h_dim1
<< 1)];
/*< a3 = c*h(i+1,1) - s*h(i,2) >*/
a3 = c__ * h__[i__ + 1 + h_dim1] - s * h__[i__ + (h_dim1 << 1)
];
/*< a4 = c*h(i+1,2) - s*h(i+1,1) >*/
a4 = c__ * h__[i__ + 1 + (h_dim1 << 1)] - s * h__[i__ + 1 +
h_dim1];
/*< h(i,2) = c*a1 + s*a2 >*/
h__[i__ + (h_dim1 << 1)] = c__ * a1 + s * a2;
/*< h(i+1,2) = c*a4 - s*a3 >*/
h__[i__ + 1 + (h_dim1 << 1)] = c__ * a4 - s * a3;
/*< h(i+1,1) = c*a3 + s*a4 >*/
h__[i__ + 1 + h_dim1] = c__ * a3 + s * a4;
/* %----------------------------------------------------% */
/* | Accumulate the rotation in the matrix Q; Q <- Q*G | */
/* %----------------------------------------------------% */
/*< do 50 j = 1, min( j+jj, kplusp ) >*/
/* Computing MIN */
i__4 = j + jj;
i__3 = min(i__4,kplusp);
for (j = 1; j <= i__3; ++j) {
/*< a1 = c*q(j,i) + s*q(j,i+1) >*/
a1 = c__ * q[j + i__ * q_dim1] + s * q[j + (i__ + 1) *
q_dim1];
/*< q(j,i+1) = - s*q(j,i) + c*q(j,i+1) >*/
q[j + (i__ + 1) * q_dim1] = -s * q[j + i__ * q_dim1] +
c__ * q[j + (i__ + 1) * q_dim1];
/*< q(j,i) = a1 >*/
q[j + i__ * q_dim1] = a1;
/*< 50 continue >*/
/* L50: */
}
/*< 70 continue >*/
/* L70: */
}
/*< end if >*/
}
/* %--------------------------% */
/* | Update the block pointer | */
/* %--------------------------% */
/*< istart = iend + 1 >*/
istart = iend + 1;
/* %------------------------------------------% */
/* | Make sure that h(iend,1) is non-negative | */
/* | If not then set h(iend,1) <-- -h(iend,1) | */
/* | and negate the last column of Q. | */
/* | We have effectively carried out a | */
/* | similarity on transformation H | */
/* %------------------------------------------% */
/*< if (h(iend,1) .lt. zero) then >*/
if (h__[iend + h_dim1] < 0.) {
/*< h(iend,1) = -h(iend,1) >*/
h__[iend + h_dim1] = -h__[iend + h_dim1];
/*< call dscal(kplusp, -one, q(1,iend), 1) >*/
dscal_(&kplusp, &c_b14, &q[iend * q_dim1 + 1], &c__1);
/*< end if >*/
}
/* %--------------------------------------------------------% */
/* | Apply the same shift to the next block if there is any | */
/* %--------------------------------------------------------% */
/*< if (iend .lt. kplusp) go to 20 >*/
if (iend < kplusp) {
goto L20;
}
/* %-----------------------------------------------------% */
/* | Check if we can increase the the start of the block | */
/* %-----------------------------------------------------% */
/*< do 80 i = itop, kplusp-1 >*/
i__2 = kplusp - 1;
for (i__ = itop; i__ <= i__2; ++i__) {
/*< if (h(i+1,1) .gt. zero) go to 90 >*/
if (h__[i__ + 1 + h_dim1] > 0.) {
goto L90;
}
/*< itop = itop + 1 >*/
++itop;
/*< 80 continue >*/
/* L80: */
}
/* %-----------------------------------% */
/* | Finished applying the jj-th shift | */
/* %-----------------------------------% */
/*< 90 continue >*/
L90:
;
}
/* %------------------------------------------% */
/* | All shifts have been applied. Check for | */
/* | more possible deflation that might occur | */
/* | after the last shift is applied. | */
/* %------------------------------------------% */
/*< do 100 i = itop, kplusp-1 >*/
i__1 = kplusp - 1;
for (i__ = itop; i__ <= i__1; ++i__) {
/*< big = abs(h(i,2)) + abs(h(i+1,2)) >*/
big = (d__1 = h__[i__ + (h_dim1 << 1)], abs(d__1)) + (d__2 = h__[i__
+ 1 + (h_dim1 << 1)], abs(d__2));
/*< if (h(i+1,1) .le. epsmch*big) then >*/
if (h__[i__ + 1 + h_dim1] <= epsmch * big) {
/* if (msglvl .gt. 0) then */
/* call ivout (logfil, 1, i, ndigit, */
/* & '_sapps: deflation at row/column no.') */
/* call dvout (logfil, 1, h(i+1,1), ndigit, */
/* & '_sapps: the corresponding off diagonal element') */
/* end if */
/*< h(i+1,1) = zero >*/
h__[i__ + 1 + h_dim1] = 0.;
/*< end if >*/
}
/*< 100 continue >*/
/* L100: */
}
/* %-------------------------------------------------% */
/* | Compute the (kev+1)-st column of (V*Q) and | */
/* | temporarily store the result in WORKD(N+1:2*N). | */
/* | This is not necessary if h(kev+1,1) = 0. | */
/* %-------------------------------------------------% */
/*< >*/
if (h__[*kev + 1 + h_dim1] > 0.) {
dgemv_("N", n, &kplusp, &c_b5, &v[v_offset], ldv, &q[(*kev + 1) *
q_dim1 + 1], &c__1, &c_b4, &workd[*n + 1], &c__1, (ftnlen)1);
}
/* %-------------------------------------------------------% */
/* | Compute column 1 to kev of (V*Q) in backward order | */
/* | taking advantage that Q is an upper triangular matrix | */
/* | with lower bandwidth np. | */
/* | Place results in v(:,kplusp-kev:kplusp) temporarily. | */
/* %-------------------------------------------------------% */
/*< do 130 i = 1, kev >*/
i__1 = *kev;
for (i__ = 1; i__ <= i__1; ++i__) {
/*< >*/
i__2 = kplusp - i__ + 1;
dgemv_("N", n, &i__2, &c_b5, &v[v_offset], ldv, &q[(*kev - i__ + 1) *
q_dim1 + 1], &c__1, &c_b4, &workd[1], &c__1, (ftnlen)1);
/*< call dcopy (n, workd, 1, v(1,kplusp-i+1), 1) >*/
dcopy_(n, &workd[1], &c__1, &v[(kplusp - i__ + 1) * v_dim1 + 1], &
c__1);
/*< 130 continue >*/
/* L130: */
}
/* %-------------------------------------------------% */
/* | Move v(:,kplusp-kev+1:kplusp) into v(:,1:kev). | */
/* %-------------------------------------------------% */
/*< call dlacpy ('All', n, kev, v(1,np+1), ldv, v, ldv) >*/
dlacpy_("All", n, kev, &v[(*np + 1) * v_dim1 + 1], ldv, &v[v_offset], ldv,
(ftnlen)3);
/* %--------------------------------------------% */
/* | Copy the (kev+1)-st column of (V*Q) in the | */
/* | appropriate place if h(kev+1,1) .ne. zero. | */
/* %--------------------------------------------% */
/*< >*/
if (h__[*kev + 1 + h_dim1] > 0.) {
dcopy_(n, &workd[*n + 1], &c__1, &v[(*kev + 1) * v_dim1 + 1], &c__1);
}
/* %-------------------------------------% */
/* | Update the residual vector: | */
/* | r <- sigmak*r + betak*v(:,kev+1) | */
/* | where | */
/* | sigmak = (e_{kev+p}'*Q)*e_{kev} | */
/* | betak = e_{kev+1}'*H*e_{kev} | */
/* %-------------------------------------% */
/*< call dscal (n, q(kplusp,kev), resid, 1) >*/
dscal_(n, &q[kplusp + *kev * q_dim1], &resid[1], &c__1);
/*< >*/
if (h__[*kev + 1 + h_dim1] > 0.) {
daxpy_(n, &h__[*kev + 1 + h_dim1], &v[(*kev + 1) * v_dim1 + 1], &c__1,
&resid[1], &c__1);
}
/* if (msglvl .gt. 1) then */
/* call dvout (logfil, 1, q(kplusp,kev), ndigit, */
/* & '_sapps: sigmak of the updated residual vector') */
/* call dvout (logfil, 1, h(kev+1,1), ndigit, */
/* & '_sapps: betak of the updated residual vector') */
/* call dvout (logfil, kev, h(1,2), ndigit, */
/* & '_sapps: updated main diagonal of H for next iteration') */
/* if (kev .gt. 1) then */
/* call dvout (logfil, kev-1, h(2,1), ndigit, */
/* & '_sapps: updated sub diagonal of H for next iteration') */
/* end if */
/* end if */
/*< call second (t1) >*/
/* second_(&t1); */
/*< tsapps = tsapps + (t1 - t0) >*/
/* timing_1.tsapps += t1 - t0; */
/*< 9000 continue >*/
L9000:
/*< return >*/
return 0;
/* %---------------% */
/* | End of dsapps | */
/* %---------------% */
/*< end >*/
} /* dsapps_ */
/* Subroutine */ int dlanv2_(doublereal *a, doublereal *b, doublereal *c__,
doublereal *d__, doublereal *rt1r, doublereal *rt1i, doublereal *rt2r,
doublereal *rt2i, doublereal *cs, doublereal *sn)
{
/* -- LAPACK driver routine (version 3.1) --
Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
November 2006
Purpose
=======
DLANV2 computes the Schur factorization of a real 2-by-2 nonsymmetric
matrix in standard form:
[ A B ] = [ CS -SN ] [ AA BB ] [ CS SN ]
[ C D ] [ SN CS ] [ CC DD ] [-SN CS ]
where either
1) CC = 0 so that AA and DD are real eigenvalues of the matrix, or
2) AA = DD and BB*CC < 0, so that AA + or - sqrt(BB*CC) are complex
conjugate eigenvalues.
Arguments
=========
A (input/output) DOUBLE PRECISION
B (input/output) DOUBLE PRECISION
C (input/output) DOUBLE PRECISION
D (input/output) DOUBLE PRECISION
On entry, the elements of the input matrix.
On exit, they are overwritten by the elements of the
standardised Schur form.
RT1R (output) DOUBLE PRECISION
RT1I (output) DOUBLE PRECISION
RT2R (output) DOUBLE PRECISION
RT2I (output) DOUBLE PRECISION
The real and imaginary parts of the eigenvalues. If the
eigenvalues are a complex conjugate pair, RT1I > 0.
CS (output) DOUBLE PRECISION
SN (output) DOUBLE PRECISION
Parameters of the rotation matrix.
Further Details
===============
Modified by V. Sima, Research Institute for Informatics, Bucharest,
Romania, to reduce the risk of cancellation errors,
when computing real eigenvalues, and to ensure, if possible, that
abs(RT1R) >= abs(RT2R).
===================================================================== */
/* Table of constant values */
static doublereal c_b4 = 1.;
/* System generated locals */
doublereal d__1, d__2;
/* Builtin functions */
double d_sign(doublereal *, doublereal *), sqrt(doublereal);
/* Local variables */
static doublereal p, z__, aa, bb, cc, dd, cs1, sn1, sab, sac, eps, tau,
temp, scale, bcmax, bcmis, sigma;
extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *);
eps = dlamch_("P");
if (*c__ == 0.) {
*cs = 1.;
*sn = 0.;
goto L10;
} else if (*b == 0.) {
/* Swap rows and columns */
*cs = 0.;
*sn = 1.;
temp = *d__;
*d__ = *a;
*a = temp;
*b = -(*c__);
*c__ = 0.;
goto L10;
} else if (*a - *d__ == 0. && d_sign(&c_b4, b) != d_sign(&c_b4, c__)) {
*cs = 1.;
*sn = 0.;
goto L10;
} else {
temp = *a - *d__;
p = temp * .5;
/* Computing MAX */
d__1 = abs(*b), d__2 = abs(*c__);
bcmax = max(d__1,d__2);
/* Computing MIN */
d__1 = abs(*b), d__2 = abs(*c__);
bcmis = min(d__1,d__2) * d_sign(&c_b4, b) * d_sign(&c_b4, c__);
/* Computing MAX */
d__1 = abs(p);
scale = max(d__1,bcmax);
z__ = p / scale * p + bcmax / scale * bcmis;
/* If Z is of the order of the machine accuracy, postpone the
decision on the nature of eigenvalues */
if (z__ >= eps * 4.) {
/* Real eigenvalues. Compute A and D. */
d__1 = sqrt(scale) * sqrt(z__);
z__ = p + d_sign(&d__1, &p);
*a = *d__ + z__;
*d__ -= bcmax / z__ * bcmis;
/* Compute B and the rotation matrix */
tau = dlapy2_(c__, &z__);
*cs = z__ / tau;
*sn = *c__ / tau;
*b -= *c__;
*c__ = 0.;
} else {
/* Complex eigenvalues, or real (almost) equal eigenvalues.
Make diagonal elements equal. */
sigma = *b + *c__;
tau = dlapy2_(&sigma, &temp);
*cs = sqrt((abs(sigma) / tau + 1.) * .5);
*sn = -(p / (tau * *cs)) * d_sign(&c_b4, &sigma);
/* Compute [ AA BB ] = [ A B ] [ CS -SN ]
[ CC DD ] [ C D ] [ SN CS ] */
aa = *a * *cs + *b * *sn;
bb = -(*a) * *sn + *b * *cs;
cc = *c__ * *cs + *d__ * *sn;
dd = -(*c__) * *sn + *d__ * *cs;
/* Compute [ A B ] = [ CS SN ] [ AA BB ]
[ C D ] [-SN CS ] [ CC DD ] */
*a = aa * *cs + cc * *sn;
*b = bb * *cs + dd * *sn;
*c__ = -aa * *sn + cc * *cs;
*d__ = -bb * *sn + dd * *cs;
temp = (*a + *d__) * .5;
*a = temp;
*d__ = temp;
if (*c__ != 0.) {
if (*b != 0.) {
if (d_sign(&c_b4, b) == d_sign(&c_b4, c__)) {
/* Real eigenvalues: reduce to upper triangular form */
sab = sqrt((abs(*b)));
sac = sqrt((abs(*c__)));
d__1 = sab * sac;
p = d_sign(&d__1, c__);
tau = 1. / sqrt((d__1 = *b + *c__, abs(d__1)));
*a = temp + p;
*d__ = temp - p;
*b -= *c__;
*c__ = 0.;
cs1 = sab * tau;
sn1 = sac * tau;
temp = *cs * cs1 - *sn * sn1;
*sn = *cs * sn1 + *sn * cs1;
*cs = temp;
}
} else {
*b = -(*c__);
*c__ = 0.;
temp = *cs;
*cs = -(*sn);
*sn = temp;
}
}
}
}
L10:
/* Store eigenvalues in (RT1R,RT1I) and (RT2R,RT2I). */
*rt1r = *a;
*rt2r = *d__;
if (*c__ == 0.) {
*rt1i = 0.;
*rt2i = 0.;
} else {
*rt1i = sqrt((abs(*b))) * sqrt((abs(*c__)));
*rt2i = -(*rt1i);
}
return 0;
/* End of DLANV2 */
} /* dlanv2_ */
/* Subroutine */ int zdrgev_(integer *nsizes, integer *nn, integer *ntypes,
logical *dotype, integer *iseed, doublereal *thresh, integer *nounit,
doublecomplex *a, integer *lda, doublecomplex *b, doublecomplex *s,
doublecomplex *t, doublecomplex *q, integer *ldq, doublecomplex *z__,
doublecomplex *qe, integer *ldqe, doublecomplex *alpha, doublecomplex
*beta, doublecomplex *alpha1, doublecomplex *beta1, doublecomplex *
work, integer *lwork, doublereal *rwork, doublereal *result, integer *
info)
{
/* Initialized data */
static integer kclass[26] = { 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,2,2,2,2,2,2,2,
2,2,2,3 };
static integer kbmagn[26] = { 1,1,1,1,1,1,1,1,3,2,3,2,2,3,1,1,1,1,1,1,1,3,
2,3,2,1 };
static integer ktrian[26] = { 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,
1,1,1,1 };
static logical lasign[26] = { FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,
TRUE_,FALSE_,TRUE_,TRUE_,FALSE_,FALSE_,TRUE_,TRUE_,TRUE_,FALSE_,
TRUE_,FALSE_,FALSE_,FALSE_,TRUE_,TRUE_,TRUE_,TRUE_,TRUE_,FALSE_ };
static logical lbsign[26] = { FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,
FALSE_,TRUE_,FALSE_,FALSE_,TRUE_,TRUE_,FALSE_,FALSE_,TRUE_,FALSE_,
TRUE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,
FALSE_ };
static integer kz1[6] = { 0,1,2,1,3,3 };
static integer kz2[6] = { 0,0,1,2,1,1 };
static integer kadd[6] = { 0,0,0,0,3,2 };
static integer katype[26] = { 0,1,0,1,2,3,4,1,4,4,1,1,4,4,4,2,4,5,8,7,9,4,
4,4,4,0 };
static integer kbtype[26] = { 0,0,1,1,2,-3,1,4,1,1,4,4,1,1,-4,2,-4,8,8,8,
8,8,8,8,8,0 };
static integer kazero[26] = { 1,1,1,1,1,1,2,1,2,2,1,1,2,2,3,1,3,5,5,5,5,3,
3,3,3,1 };
static integer kbzero[26] = { 1,1,1,1,1,1,1,2,1,1,2,2,1,1,4,1,4,6,6,6,6,4,
4,4,4,1 };
static integer kamagn[26] = { 1,1,1,1,1,1,1,1,2,3,2,3,2,3,1,1,1,1,1,1,1,2,
3,3,2,1 };
/* Format strings */
static char fmt_9999[] = "(\002 ZDRGEV: \002,a,\002 returned INFO=\002,i"
"6,\002.\002,/3x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
"(\002,3(i5,\002,\002),i5,\002)\002)";
static char fmt_9998[] = "(\002 ZDRGEV: \002,a,\002 Eigenvectors from"
" \002,a,\002 incorrectly \002,\002normalized.\002,/\002 Bits of "
"error=\002,0p,g10.3,\002,\002,3x,\002N=\002,i4,\002, JTYPE=\002,"
"i3,\002, ISEED=(\002,3(i4,\002,\002),i5,\002)\002)";
static char fmt_9997[] = "(/1x,a3,\002 -- Complex Generalized eigenvalue"
" problem \002,\002driver\002)";
static char fmt_9996[] = "(\002 Matrix types (see ZDRGEV for details):"
" \002)";
static char fmt_9995[] = "(\002 Special Matrices:\002,23x,\002(J'=transp"
"osed Jordan block)\002,/\002 1=(0,0) 2=(I,0) 3=(0,I) 4=(I,I"
") 5=(J',J') \002,\0026=(diag(J',I), diag(I,J'))\002,/\002 Diag"
"onal Matrices: ( \002,\002D=diag(0,1,2,...) )\002,/\002 7=(D,"
"I) 9=(large*D, small*I\002,\002) 11=(large*I, small*D) 13=(l"
"arge*D, large*I)\002,/\002 8=(I,D) 10=(small*D, large*I) 12="
"(small*I, large*D) \002,\002 14=(small*D, small*I)\002,/\002 15"
"=(D, reversed D)\002)";
static char fmt_9994[] = "(\002 Matrices Rotated by Random \002,a,\002 M"
"atrices U, V:\002,/\002 16=Transposed Jordan Blocks "
" 19=geometric \002,\002alpha, beta=0,1\002,/\002 17=arithm. alp"
"ha&beta \002,\002 20=arithmetic alpha, beta=0,"
"1\002,/\002 18=clustered \002,\002alpha, beta=0,1 21"
"=random alpha, beta=0,1\002,/\002 Large & Small Matrices:\002,"
"/\002 22=(large, small) \002,\00223=(small,large) 24=(smal"
"l,small) 25=(large,large)\002,/\002 26=random O(1) matrices"
".\002)";
static char fmt_9993[] = "(/\002 Tests performed: \002,/\002 1 = max "
"| ( b A - a B )'*l | / const.,\002,/\002 2 = | |VR(i)| - 1 | / u"
"lp,\002,/\002 3 = max | ( b A - a B )*r | / const.\002,/\002 4 ="
" | |VL(i)| - 1 | / ulp,\002,/\002 5 = 0 if W same no matter if r"
" or l computed,\002,/\002 6 = 0 if l same no matter if l compute"
"d,\002,/\002 7 = 0 if r same no matter if r computed,\002,/1x)";
static char fmt_9992[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2"
",\002, seed=\002,4(i4,\002,\002),\002 result \002,i2,\002 is\002"
",0p,f8.2)";
static char fmt_9991[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2"
",\002, seed=\002,4(i4,\002,\002),\002 result \002,i2,\002 is\002"
",1p,d10.3)";
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, qe_dim1,
qe_offset, s_dim1, s_offset, t_dim1, t_offset, z_dim1, z_offset,
i__1, i__2, i__3, i__4, i__5, i__6, i__7;
doublereal d__1, d__2;
doublecomplex z__1, z__2, z__3;
/* Builtin functions */
double d_sign(doublereal *, doublereal *), z_abs(doublecomplex *);
void d_cnjg(doublecomplex *, doublecomplex *);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
static integer iadd, ierr, nmax, i__, j, n;
static logical badnn;
static doublereal rmagn[4];
static doublecomplex ctemp;
extern /* Subroutine */ int zget52_(logical *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *, doublecomplex *, integer *
, doublecomplex *, doublecomplex *, doublecomplex *, doublereal *,
doublereal *);
static integer nmats, jsize;
extern /* Subroutine */ int zggev_(char *, char *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublereal *, integer *);
static integer nerrs, jtype, n1;
extern /* Subroutine */ int dlabad_(doublereal *, doublereal *), zlatm4_(
integer *, integer *, integer *, integer *, logical *, doublereal
*, doublereal *, doublereal *, integer *, integer *,
doublecomplex *, integer *);
static integer jc, nb, in;
extern doublereal dlamch_(char *);
static integer jr;
extern /* Subroutine */ int zunm2r_(char *, char *, integer *, integer *,
integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *);
static doublereal safmin, safmax;
static integer ioldsd[4];
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
*, integer *), xerbla_(char *, integer *),
zlarfg_(integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *);
extern /* Double Complex */ VOID zlarnd_(doublecomplex *, integer *,
integer *);
extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *),
zlaset_(char *, integer *, integer *, doublecomplex *,
doublecomplex *, doublecomplex *, integer *);
static integer minwrk, maxwrk;
static doublereal ulpinv;
static integer mtypes, ntestt;
static doublereal ulp;
/* Fortran I/O blocks */
static cilist io___40 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___42 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___43 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___44 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___45 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___46 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___47 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___48 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___49 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___50 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___51 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___52 = { 0, 0, 0, fmt_9993, 0 };
static cilist io___53 = { 0, 0, 0, fmt_9992, 0 };
static cilist io___54 = { 0, 0, 0, fmt_9991, 0 };
#define a_subscr(a_1,a_2) (a_2)*a_dim1 + a_1
#define a_ref(a_1,a_2) a[a_subscr(a_1,a_2)]
#define b_subscr(a_1,a_2) (a_2)*b_dim1 + a_1
#define b_ref(a_1,a_2) b[b_subscr(a_1,a_2)]
#define q_subscr(a_1,a_2) (a_2)*q_dim1 + a_1
#define q_ref(a_1,a_2) q[q_subscr(a_1,a_2)]
#define z___subscr(a_1,a_2) (a_2)*z_dim1 + a_1
#define z___ref(a_1,a_2) z__[z___subscr(a_1,a_2)]
#define qe_subscr(a_1,a_2) (a_2)*qe_dim1 + a_1
#define qe_ref(a_1,a_2) qe[qe_subscr(a_1,a_2)]
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
Purpose
=======
ZDRGEV checks the nonsymmetric generalized eigenvalue problem driver
routine ZGGEV.
ZGGEV computes for a pair of n-by-n nonsymmetric matrices (A,B) the
generalized eigenvalues and, optionally, the left and right
eigenvectors.
A generalized eigenvalue for a pair of matrices (A,B) is a scalar w
or a ratio alpha/beta = w, such that A - w*B is singular. It is
usually represented as the pair (alpha,beta), as there is reasonalbe
interpretation for beta=0, and even for both being zero.
A right generalized eigenvector corresponding to a generalized
eigenvalue w for a pair of matrices (A,B) is a vector r such that
(A - wB) * r = 0. A left generalized eigenvector is a vector l such
that l**H * (A - wB) = 0, where l**H is the conjugate-transpose of l.
When ZDRGEV is called, a number of matrix "sizes" ("n's") and a
number of matrix "types" are specified. For each size ("n")
and each type of matrix, a pair of matrices (A, B) will be generated
and used for testing. For each matrix pair, the following tests
will be performed and compared with the threshhold THRESH.
Results from ZGGEV:
(1) max over all left eigenvalue/-vector pairs (alpha/beta,l) of
| VL**H * (beta A - alpha B) |/( ulp max(|beta A|, |alpha B|) )
where VL**H is the conjugate-transpose of VL.
(2) | |VL(i)| - 1 | / ulp and whether largest component real
VL(i) denotes the i-th column of VL.
(3) max over all left eigenvalue/-vector pairs (alpha/beta,r) of
| (beta A - alpha B) * VR | / ( ulp max(|beta A|, |alpha B|) )
(4) | |VR(i)| - 1 | / ulp and whether largest component real
VR(i) denotes the i-th column of VR.
(5) W(full) = W(partial)
W(full) denotes the eigenvalues computed when both l and r
are also computed, and W(partial) denotes the eigenvalues
computed when only W, only W and r, or only W and l are
computed.
(6) VL(full) = VL(partial)
VL(full) denotes the left eigenvectors computed when both l
and r are computed, and VL(partial) denotes the result
when only l is computed.
(7) VR(full) = VR(partial)
VR(full) denotes the right eigenvectors computed when both l
and r are also computed, and VR(partial) denotes the result
when only l is computed.
Test Matrices
---- --------
The sizes of the test matrices are specified by an array
NN(1:NSIZES); the value of each element NN(j) specifies one size.
The "types" are specified by a logical array DOTYPE( 1:NTYPES ); if
DOTYPE(j) is .TRUE., then matrix type "j" will be generated.
Currently, the list of possible types is:
(1) ( 0, 0 ) (a pair of zero matrices)
(2) ( I, 0 ) (an identity and a zero matrix)
(3) ( 0, I ) (an identity and a zero matrix)
(4) ( I, I ) (a pair of identity matrices)
t t
(5) ( J , J ) (a pair of transposed Jordan blocks)
t ( I 0 )
(6) ( X, Y ) where X = ( J 0 ) and Y = ( t )
( 0 I ) ( 0 J )
and I is a k x k identity and J a (k+1)x(k+1)
Jordan block; k=(N-1)/2
(7) ( D, I ) where D is diag( 0, 1,..., N-1 ) (a diagonal
matrix with those diagonal entries.)
(8) ( I, D )
(9) ( big*D, small*I ) where "big" is near overflow and small=1/big
(10) ( small*D, big*I )
(11) ( big*I, small*D )
(12) ( small*I, big*D )
(13) ( big*D, big*I )
(14) ( small*D, small*I )
(15) ( D1, D2 ) where D1 is diag( 0, 0, 1, ..., N-3, 0 ) and
D2 is diag( 0, N-3, N-4,..., 1, 0, 0 )
t t
(16) Q ( J , J ) Z where Q and Z are random orthogonal matrices.
(17) Q ( T1, T2 ) Z where T1 and T2 are upper triangular matrices
with random O(1) entries above the diagonal
and diagonal entries diag(T1) =
( 0, 0, 1, ..., N-3, 0 ) and diag(T2) =
( 0, N-3, N-4,..., 1, 0, 0 )
(18) Q ( T1, T2 ) Z diag(T1) = ( 0, 0, 1, 1, s, ..., s, 0 )
diag(T2) = ( 0, 1, 0, 1,..., 1, 0 )
s = machine precision.
(19) Q ( T1, T2 ) Z diag(T1)=( 0,0,1,1, 1-d, ..., 1-(N-5)*d=s, 0 )
diag(T2) = ( 0, 1, 0, 1, ..., 1, 0 )
N-5
(20) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, 1, a, ..., a =s, 0 )
diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 )
(21) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, r1, r2, ..., r(N-4), 0 )
diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 )
where r1,..., r(N-4) are random.
(22) Q ( big*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
diag(T2) = ( 0, 1, ..., 1, 0, 0 )
(23) Q ( small*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
diag(T2) = ( 0, 1, ..., 1, 0, 0 )
(24) Q ( small*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
diag(T2) = ( 0, 1, ..., 1, 0, 0 )
(25) Q ( big*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
diag(T2) = ( 0, 1, ..., 1, 0, 0 )
(26) Q ( T1, T2 ) Z where T1 and T2 are random upper-triangular
matrices.
Arguments
=========
NSIZES (input) INTEGER
The number of sizes of matrices to use. If it is zero,
ZDRGES does nothing. NSIZES >= 0.
NN (input) INTEGER array, dimension (NSIZES)
An array containing the sizes to be used for the matrices.
Zero values will be skipped. NN >= 0.
NTYPES (input) INTEGER
The number of elements in DOTYPE. If it is zero, ZDRGEV
does nothing. It must be at least zero. If it is MAXTYP+1
and NSIZES is 1, then an additional type, MAXTYP+1 is
defined, which is to use whatever matrix is in A. This
is only useful if DOTYPE(1:MAXTYP) is .FALSE. and
DOTYPE(MAXTYP+1) is .TRUE. .
DOTYPE (input) LOGICAL array, dimension (NTYPES)
If DOTYPE(j) is .TRUE., then for each size in NN a
matrix of that size and of type j will be generated.
If NTYPES is smaller than the maximum number of types
defined (PARAMETER MAXTYP), then types NTYPES+1 through
MAXTYP will not be generated. If NTYPES is larger
than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES)
will be ignored.
ISEED (input/output) INTEGER array, dimension (4)
On entry ISEED specifies the seed of the random number
generator. The array elements should be between 0 and 4095;
if not they will be reduced mod 4096. Also, ISEED(4) must
be odd. The random number generator uses a linear
congruential sequence limited to small integers, and so
should produce machine independent random numbers. The
values of ISEED are changed on exit, and can be used in the
next call to ZDRGES to continue the same random number
sequence.
THRESH (input) DOUBLE PRECISION
A test will count as "failed" if the "error", computed as
described above, exceeds THRESH. Note that the error is
scaled to be O(1), so THRESH should be a reasonably small
multiple of 1, e.g., 10 or 100. In particular, it should
not depend on the precision (single vs. double) or the size
of the matrix. It must be at least zero.
NOUNIT (input) INTEGER
The FORTRAN unit number for printing out error messages
(e.g., if a routine returns IERR not equal to 0.)
A (input/workspace) COMPLEX*16 array, dimension(LDA, max(NN))
Used to hold the original A matrix. Used as input only
if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and
DOTYPE(MAXTYP+1)=.TRUE.
LDA (input) INTEGER
The leading dimension of A, B, S, and T.
It must be at least 1 and at least max( NN ).
B (input/workspace) COMPLEX*16 array, dimension(LDA, max(NN))
Used to hold the original B matrix. Used as input only
if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and
DOTYPE(MAXTYP+1)=.TRUE.
S (workspace) COMPLEX*16 array, dimension (LDA, max(NN))
The Schur form matrix computed from A by ZGGEV. On exit, S
contains the Schur form matrix corresponding to the matrix
in A.
T (workspace) COMPLEX*16 array, dimension (LDA, max(NN))
The upper triangular matrix computed from B by ZGGEV.
Q (workspace) COMPLEX*16 array, dimension (LDQ, max(NN))
The (left) eigenvectors matrix computed by ZGGEV.
LDQ (input) INTEGER
The leading dimension of Q and Z. It must
be at least 1 and at least max( NN ).
Z (workspace) COMPLEX*16 array, dimension( LDQ, max(NN) )
The (right) orthogonal matrix computed by ZGGEV.
QE (workspace) COMPLEX*16 array, dimension( LDQ, max(NN) )
QE holds the computed right or left eigenvectors.
LDQE (input) INTEGER
The leading dimension of QE. LDQE >= max(1,max(NN)).
ALPHA (workspace) COMPLEX*16 array, dimension (max(NN))
BETA (workspace) COMPLEX*16 array, dimension (max(NN))
The generalized eigenvalues of (A,B) computed by ZGGEV.
( ALPHAR(k)+ALPHAI(k)*i ) / BETA(k) is the k-th
generalized eigenvalue of A and B.
ALPHA1 (workspace) COMPLEX*16 array, dimension (max(NN))
BETA1 (workspace) COMPLEX*16 array, dimension (max(NN))
Like ALPHAR, ALPHAI, BETA, these arrays contain the
eigenvalues of A and B, but those computed when ZGGEV only
computes a partial eigendecomposition, i.e. not the
eigenvalues and left and right eigenvectors.
WORK (workspace) COMPLEX*16 array, dimension (LWORK)
LWORK (input) INTEGER
The number of entries in WORK. LWORK >= N*(N+1)
RWORK (workspace) DOUBLE PRECISION array, dimension (8*N)
Real workspace.
RESULT (output) DOUBLE PRECISION array, dimension (2)
The values computed by the tests described above.
The values are currently limited to 1/ulp, to avoid overflow.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value.
> 0: A routine returned an error code. INFO is the
absolute value of the INFO value returned.
=====================================================================
Parameter adjustments */
--nn;
--dotype;
--iseed;
t_dim1 = *lda;
t_offset = 1 + t_dim1 * 1;
t -= t_offset;
s_dim1 = *lda;
s_offset = 1 + s_dim1 * 1;
s -= s_offset;
b_dim1 = *lda;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
z_dim1 = *ldq;
z_offset = 1 + z_dim1 * 1;
z__ -= z_offset;
q_dim1 = *ldq;
q_offset = 1 + q_dim1 * 1;
q -= q_offset;
qe_dim1 = *ldqe;
qe_offset = 1 + qe_dim1 * 1;
qe -= qe_offset;
--alpha;
--beta;
--alpha1;
--beta1;
--work;
--rwork;
--result;
/* Function Body
Check for errors */
*info = 0;
badnn = FALSE_;
nmax = 1;
i__1 = *nsizes;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = nmax, i__3 = nn[j];
nmax = max(i__2,i__3);
if (nn[j] < 0) {
badnn = TRUE_;
}
/* L10: */
}
if (*nsizes < 0) {
*info = -1;
} else if (badnn) {
*info = -2;
} else if (*ntypes < 0) {
*info = -3;
} else if (*thresh < 0.) {
*info = -6;
} else if (*lda <= 1 || *lda < nmax) {
*info = -9;
} else if (*ldq <= 1 || *ldq < nmax) {
*info = -14;
} else if (*ldqe <= 1 || *ldqe < nmax) {
*info = -17;
}
/* Compute workspace
(Note: Comments in the code beginning "Workspace:" describe the
minimal amount of workspace needed at that point in the code,
as well as the preferred amount for good performance.
NB refers to the optimal block size for the immediately
following subroutine, as returned by ILAENV. */
minwrk = 1;
if (*info == 0 && *lwork >= 1) {
minwrk = nmax * (nmax + 1);
/* Computing MAX */
i__1 = 1, i__2 = ilaenv_(&c__1, "ZGEQRF", " ", &nmax, &nmax, &c_n1, &
c_n1, (ftnlen)6, (ftnlen)1), i__1 = max(i__1,i__2), i__2 =
ilaenv_(&c__1, "ZUNMQR", "LC", &nmax, &nmax, &nmax, &c_n1, (
ftnlen)6, (ftnlen)2), i__1 = max(i__1,i__2), i__2 = ilaenv_(&
c__1, "ZUNGQR", " ", &nmax, &nmax, &nmax, &c_n1, (ftnlen)6, (
ftnlen)1);
nb = max(i__1,i__2);
/* Computing MAX */
i__1 = nmax << 1, i__2 = nmax * (nb + 1), i__1 = max(i__1,i__2), i__2
= nmax * (nmax + 1);
maxwrk = max(i__1,i__2);
work[1].r = (doublereal) maxwrk, work[1].i = 0.;
}
if (*lwork < minwrk) {
*info = -23;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZDRGEV", &i__1);
return 0;
}
/* Quick return if possible */
if (*nsizes == 0 || *ntypes == 0) {
return 0;
}
ulp = dlamch_("Precision");
safmin = dlamch_("Safe minimum");
safmin /= ulp;
safmax = 1. / safmin;
dlabad_(&safmin, &safmax);
ulpinv = 1. / ulp;
/* The values RMAGN(2:3) depend on N, see below. */
rmagn[0] = 0.;
rmagn[1] = 1.;
/* Loop over sizes, types */
ntestt = 0;
nerrs = 0;
nmats = 0;
i__1 = *nsizes;
for (jsize = 1; jsize <= i__1; ++jsize) {
n = nn[jsize];
n1 = max(1,n);
rmagn[2] = safmax * ulp / (doublereal) n1;
rmagn[3] = safmin * ulpinv * n1;
if (*nsizes != 1) {
mtypes = min(26,*ntypes);
} else {
mtypes = min(27,*ntypes);
}
i__2 = mtypes;
for (jtype = 1; jtype <= i__2; ++jtype) {
if (! dotype[jtype]) {
goto L210;
}
++nmats;
/* Save ISEED in case of an error. */
for (j = 1; j <= 4; ++j) {
ioldsd[j - 1] = iseed[j];
/* L20: */
}
/* Generate test matrices A and B
Description of control parameters:
KZLASS: =1 means w/o rotation, =2 means w/ rotation,
=3 means random.
KATYPE: the "type" to be passed to ZLATM4 for computing A.
KAZERO: the pattern of zeros on the diagonal for A:
=1: ( xxx ), =2: (0, xxx ) =3: ( 0, 0, xxx, 0 ),
=4: ( 0, xxx, 0, 0 ), =5: ( 0, 0, 1, xxx, 0 ),
=6: ( 0, 1, 0, xxx, 0 ). (xxx means a string of
non-zero entries.)
KAMAGN: the magnitude of the matrix: =0: zero, =1: O(1),
=2: large, =3: small.
LASIGN: .TRUE. if the diagonal elements of A are to be
multiplied by a random magnitude 1 number.
KBTYPE, KBZERO, KBMAGN, LBSIGN: the same, but for B.
KTRIAN: =0: don't fill in the upper triangle, =1: do.
KZ1, KZ2, KADD: used to implement KAZERO and KBZERO.
RMAGN: used to implement KAMAGN and KBMAGN. */
if (mtypes > 26) {
goto L100;
}
ierr = 0;
if (kclass[jtype - 1] < 3) {
/* Generate A (w/o rotation) */
if ((i__3 = katype[jtype - 1], abs(i__3)) == 3) {
in = ((n - 1) / 2 << 1) + 1;
if (in != n) {
zlaset_("Full", &n, &n, &c_b1, &c_b1, &a[a_offset],
lda);
}
} else {
in = n;
}
zlatm4_(&katype[jtype - 1], &in, &kz1[kazero[jtype - 1] - 1],
&kz2[kazero[jtype - 1] - 1], &lasign[jtype - 1], &
rmagn[kamagn[jtype - 1]], &ulp, &rmagn[ktrian[jtype -
1] * kamagn[jtype - 1]], &c__2, &iseed[1], &a[
a_offset], lda);
iadd = kadd[kazero[jtype - 1] - 1];
if (iadd > 0 && iadd <= n) {
i__3 = a_subscr(iadd, iadd);
i__4 = kamagn[jtype - 1];
a[i__3].r = rmagn[i__4], a[i__3].i = 0.;
}
/* Generate B (w/o rotation) */
if ((i__3 = kbtype[jtype - 1], abs(i__3)) == 3) {
in = ((n - 1) / 2 << 1) + 1;
if (in != n) {
zlaset_("Full", &n, &n, &c_b1, &c_b1, &b[b_offset],
lda);
}
} else {
in = n;
}
zlatm4_(&kbtype[jtype - 1], &in, &kz1[kbzero[jtype - 1] - 1],
&kz2[kbzero[jtype - 1] - 1], &lbsign[jtype - 1], &
rmagn[kbmagn[jtype - 1]], &c_b28, &rmagn[ktrian[jtype
- 1] * kbmagn[jtype - 1]], &c__2, &iseed[1], &b[
b_offset], lda);
iadd = kadd[kbzero[jtype - 1] - 1];
if (iadd != 0 && iadd <= n) {
i__3 = b_subscr(iadd, iadd);
i__4 = kbmagn[jtype - 1];
b[i__3].r = rmagn[i__4], b[i__3].i = 0.;
}
if (kclass[jtype - 1] == 2 && n > 0) {
/* Include rotations
Generate Q, Z as Householder transformations times
a diagonal matrix. */
i__3 = n - 1;
for (jc = 1; jc <= i__3; ++jc) {
i__4 = n;
for (jr = jc; jr <= i__4; ++jr) {
i__5 = q_subscr(jr, jc);
zlarnd_(&z__1, &c__3, &iseed[1]);
q[i__5].r = z__1.r, q[i__5].i = z__1.i;
i__5 = z___subscr(jr, jc);
zlarnd_(&z__1, &c__3, &iseed[1]);
z__[i__5].r = z__1.r, z__[i__5].i = z__1.i;
/* L30: */
}
i__4 = n + 1 - jc;
zlarfg_(&i__4, &q_ref(jc, jc), &q_ref(jc + 1, jc), &
c__1, &work[jc]);
i__4 = (n << 1) + jc;
i__5 = q_subscr(jc, jc);
d__2 = q[i__5].r;
d__1 = d_sign(&c_b28, &d__2);
work[i__4].r = d__1, work[i__4].i = 0.;
i__4 = q_subscr(jc, jc);
q[i__4].r = 1., q[i__4].i = 0.;
i__4 = n + 1 - jc;
zlarfg_(&i__4, &z___ref(jc, jc), &z___ref(jc + 1, jc),
&c__1, &work[n + jc]);
i__4 = n * 3 + jc;
i__5 = z___subscr(jc, jc);
d__2 = z__[i__5].r;
d__1 = d_sign(&c_b28, &d__2);
work[i__4].r = d__1, work[i__4].i = 0.;
i__4 = z___subscr(jc, jc);
z__[i__4].r = 1., z__[i__4].i = 0.;
/* L40: */
}
zlarnd_(&z__1, &c__3, &iseed[1]);
ctemp.r = z__1.r, ctemp.i = z__1.i;
i__3 = q_subscr(n, n);
q[i__3].r = 1., q[i__3].i = 0.;
i__3 = n;
work[i__3].r = 0., work[i__3].i = 0.;
i__3 = n * 3;
d__1 = z_abs(&ctemp);
z__1.r = ctemp.r / d__1, z__1.i = ctemp.i / d__1;
work[i__3].r = z__1.r, work[i__3].i = z__1.i;
zlarnd_(&z__1, &c__3, &iseed[1]);
ctemp.r = z__1.r, ctemp.i = z__1.i;
i__3 = z___subscr(n, n);
z__[i__3].r = 1., z__[i__3].i = 0.;
i__3 = n << 1;
work[i__3].r = 0., work[i__3].i = 0.;
i__3 = n << 2;
d__1 = z_abs(&ctemp);
z__1.r = ctemp.r / d__1, z__1.i = ctemp.i / d__1;
work[i__3].r = z__1.r, work[i__3].i = z__1.i;
/* Apply the diagonal matrices */
i__3 = n;
for (jc = 1; jc <= i__3; ++jc) {
i__4 = n;
for (jr = 1; jr <= i__4; ++jr) {
i__5 = a_subscr(jr, jc);
i__6 = (n << 1) + jr;
d_cnjg(&z__3, &work[n * 3 + jc]);
z__2.r = work[i__6].r * z__3.r - work[i__6].i *
z__3.i, z__2.i = work[i__6].r * z__3.i +
work[i__6].i * z__3.r;
i__7 = a_subscr(jr, jc);
z__1.r = z__2.r * a[i__7].r - z__2.i * a[i__7].i,
z__1.i = z__2.r * a[i__7].i + z__2.i * a[
i__7].r;
a[i__5].r = z__1.r, a[i__5].i = z__1.i;
i__5 = b_subscr(jr, jc);
i__6 = (n << 1) + jr;
d_cnjg(&z__3, &work[n * 3 + jc]);
z__2.r = work[i__6].r * z__3.r - work[i__6].i *
z__3.i, z__2.i = work[i__6].r * z__3.i +
work[i__6].i * z__3.r;
i__7 = b_subscr(jr, jc);
z__1.r = z__2.r * b[i__7].r - z__2.i * b[i__7].i,
z__1.i = z__2.r * b[i__7].i + z__2.i * b[
i__7].r;
b[i__5].r = z__1.r, b[i__5].i = z__1.i;
/* L50: */
}
/* L60: */
}
i__3 = n - 1;
zunm2r_("L", "N", &n, &n, &i__3, &q[q_offset], ldq, &work[
1], &a[a_offset], lda, &work[(n << 1) + 1], &ierr);
if (ierr != 0) {
goto L90;
}
i__3 = n - 1;
zunm2r_("R", "C", &n, &n, &i__3, &z__[z_offset], ldq, &
work[n + 1], &a[a_offset], lda, &work[(n << 1) +
1], &ierr);
if (ierr != 0) {
goto L90;
}
i__3 = n - 1;
zunm2r_("L", "N", &n, &n, &i__3, &q[q_offset], ldq, &work[
1], &b[b_offset], lda, &work[(n << 1) + 1], &ierr);
if (ierr != 0) {
goto L90;
}
i__3 = n - 1;
zunm2r_("R", "C", &n, &n, &i__3, &z__[z_offset], ldq, &
work[n + 1], &b[b_offset], lda, &work[(n << 1) +
1], &ierr);
if (ierr != 0) {
goto L90;
}
}
} else {
/* Random matrices */
i__3 = n;
for (jc = 1; jc <= i__3; ++jc) {
i__4 = n;
for (jr = 1; jr <= i__4; ++jr) {
i__5 = a_subscr(jr, jc);
i__6 = kamagn[jtype - 1];
zlarnd_(&z__2, &c__4, &iseed[1]);
z__1.r = rmagn[i__6] * z__2.r, z__1.i = rmagn[i__6] *
z__2.i;
a[i__5].r = z__1.r, a[i__5].i = z__1.i;
i__5 = b_subscr(jr, jc);
i__6 = kbmagn[jtype - 1];
zlarnd_(&z__2, &c__4, &iseed[1]);
z__1.r = rmagn[i__6] * z__2.r, z__1.i = rmagn[i__6] *
z__2.i;
b[i__5].r = z__1.r, b[i__5].i = z__1.i;
/* L70: */
}
/* L80: */
}
}
L90:
if (ierr != 0) {
io___40.ciunit = *nounit;
s_wsfe(&io___40);
do_fio(&c__1, "Generator", (ftnlen)9);
do_fio(&c__1, (char *)&ierr, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(ierr);
return 0;
}
L100:
for (i__ = 1; i__ <= 7; ++i__) {
result[i__] = -1.;
/* L110: */
}
/* Call ZGGEV to compute eigenvalues and eigenvectors. */
zlacpy_(" ", &n, &n, &a[a_offset], lda, &s[s_offset], lda);
zlacpy_(" ", &n, &n, &b[b_offset], lda, &t[t_offset], lda);
zggev_("V", "V", &n, &s[s_offset], lda, &t[t_offset], lda, &alpha[
1], &beta[1], &q[q_offset], ldq, &z__[z_offset], ldq, &
work[1], lwork, &rwork[1], &ierr);
if (ierr != 0 && ierr != n + 1) {
result[1] = ulpinv;
io___42.ciunit = *nounit;
s_wsfe(&io___42);
do_fio(&c__1, "ZGGEV1", (ftnlen)6);
do_fio(&c__1, (char *)&ierr, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(ierr);
goto L190;
}
/* Do the tests (1) and (2) */
zget52_(&c_true, &n, &a[a_offset], lda, &b[b_offset], lda, &q[
q_offset], ldq, &alpha[1], &beta[1], &work[1], &rwork[1],
&result[1]);
if (result[2] > *thresh) {
io___43.ciunit = *nounit;
s_wsfe(&io___43);
do_fio(&c__1, "Left", (ftnlen)4);
do_fio(&c__1, "ZGGEV1", (ftnlen)6);
do_fio(&c__1, (char *)&result[2], (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
}
/* Do the tests (3) and (4) */
zget52_(&c_false, &n, &a[a_offset], lda, &b[b_offset], lda, &z__[
z_offset], ldq, &alpha[1], &beta[1], &work[1], &rwork[1],
&result[3]);
if (result[4] > *thresh) {
io___44.ciunit = *nounit;
s_wsfe(&io___44);
do_fio(&c__1, "Right", (ftnlen)5);
do_fio(&c__1, "ZGGEV1", (ftnlen)6);
do_fio(&c__1, (char *)&result[4], (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
}
/* Do test (5) */
zlacpy_(" ", &n, &n, &a[a_offset], lda, &s[s_offset], lda);
zlacpy_(" ", &n, &n, &b[b_offset], lda, &t[t_offset], lda);
zggev_("N", "N", &n, &s[s_offset], lda, &t[t_offset], lda, &
alpha1[1], &beta1[1], &q[q_offset], ldq, &z__[z_offset],
ldq, &work[1], lwork, &rwork[1], &ierr);
if (ierr != 0 && ierr != n + 1) {
result[1] = ulpinv;
io___45.ciunit = *nounit;
s_wsfe(&io___45);
do_fio(&c__1, "ZGGEV2", (ftnlen)6);
do_fio(&c__1, (char *)&ierr, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(ierr);
goto L190;
}
i__3 = n;
for (j = 1; j <= i__3; ++j) {
i__4 = j;
i__5 = j;
i__6 = j;
i__7 = j;
if (alpha[i__4].r != alpha1[i__5].r || alpha[i__4].i !=
alpha1[i__5].i || (beta[i__6].r != beta1[i__7].r ||
beta[i__6].i != beta1[i__7].i)) {
result[5] = ulpinv;
}
/* L120: */
}
/* Do test (6): Compute eigenvalues and left eigenvectors,
and test them */
zlacpy_(" ", &n, &n, &a[a_offset], lda, &s[s_offset], lda);
zlacpy_(" ", &n, &n, &b[b_offset], lda, &t[t_offset], lda);
zggev_("V", "N", &n, &s[s_offset], lda, &t[t_offset], lda, &
alpha1[1], &beta1[1], &qe[qe_offset], ldqe, &z__[z_offset]
, ldq, &work[1], lwork, &rwork[1], &ierr);
if (ierr != 0 && ierr != n + 1) {
result[1] = ulpinv;
io___46.ciunit = *nounit;
s_wsfe(&io___46);
do_fio(&c__1, "ZGGEV3", (ftnlen)6);
do_fio(&c__1, (char *)&ierr, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(ierr);
goto L190;
}
i__3 = n;
for (j = 1; j <= i__3; ++j) {
i__4 = j;
i__5 = j;
i__6 = j;
i__7 = j;
if (alpha[i__4].r != alpha1[i__5].r || alpha[i__4].i !=
alpha1[i__5].i || (beta[i__6].r != beta1[i__7].r ||
beta[i__6].i != beta1[i__7].i)) {
result[6] = ulpinv;
}
/* L130: */
}
i__3 = n;
for (j = 1; j <= i__3; ++j) {
i__4 = n;
for (jc = 1; jc <= i__4; ++jc) {
i__5 = q_subscr(j, jc);
i__6 = qe_subscr(j, jc);
if (q[i__5].r != qe[i__6].r || q[i__5].i != qe[i__6].i) {
result[6] = ulpinv;
}
/* L140: */
}
/* L150: */
}
/* Do test (7): Compute eigenvalues and right eigenvectors,
and test them */
zlacpy_(" ", &n, &n, &a[a_offset], lda, &s[s_offset], lda);
zlacpy_(" ", &n, &n, &b[b_offset], lda, &t[t_offset], lda);
zggev_("N", "V", &n, &s[s_offset], lda, &t[t_offset], lda, &
alpha1[1], &beta1[1], &q[q_offset], ldq, &qe[qe_offset],
ldqe, &work[1], lwork, &rwork[1], &ierr);
if (ierr != 0 && ierr != n + 1) {
result[1] = ulpinv;
io___47.ciunit = *nounit;
s_wsfe(&io___47);
do_fio(&c__1, "ZGGEV4", (ftnlen)6);
do_fio(&c__1, (char *)&ierr, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(ierr);
goto L190;
}
i__3 = n;
for (j = 1; j <= i__3; ++j) {
i__4 = j;
i__5 = j;
i__6 = j;
i__7 = j;
if (alpha[i__4].r != alpha1[i__5].r || alpha[i__4].i !=
alpha1[i__5].i || (beta[i__6].r != beta1[i__7].r ||
beta[i__6].i != beta1[i__7].i)) {
result[7] = ulpinv;
}
/* L160: */
}
i__3 = n;
for (j = 1; j <= i__3; ++j) {
i__4 = n;
for (jc = 1; jc <= i__4; ++jc) {
i__5 = z___subscr(j, jc);
i__6 = qe_subscr(j, jc);
if (z__[i__5].r != qe[i__6].r || z__[i__5].i != qe[i__6]
.i) {
result[7] = ulpinv;
}
/* L170: */
}
/* L180: */
}
/* End of Loop -- Check for RESULT(j) > THRESH */
L190:
ntestt += 7;
/* Print out tests which fail. */
for (jr = 1; jr <= 9; ++jr) {
if (result[jr] >= *thresh) {
/* If this is the first test to fail,
print a header to the data file. */
if (nerrs == 0) {
io___48.ciunit = *nounit;
s_wsfe(&io___48);
do_fio(&c__1, "ZGV", (ftnlen)3);
e_wsfe();
/* Matrix types */
io___49.ciunit = *nounit;
s_wsfe(&io___49);
e_wsfe();
io___50.ciunit = *nounit;
s_wsfe(&io___50);
e_wsfe();
io___51.ciunit = *nounit;
s_wsfe(&io___51);
do_fio(&c__1, "Orthogonal", (ftnlen)10);
e_wsfe();
/* Tests performed */
io___52.ciunit = *nounit;
s_wsfe(&io___52);
e_wsfe();
}
++nerrs;
if (result[jr] < 1e4) {
io___53.ciunit = *nounit;
s_wsfe(&io___53);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
;
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof(
doublereal));
e_wsfe();
} else {
io___54.ciunit = *nounit;
s_wsfe(&io___54);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
;
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof(
doublereal));
e_wsfe();
}
}
/* L200: */
}
L210:
;
}
/* L220: */
}
/* Summary */
alasvm_("ZGV", nounit, &nerrs, &ntestt, &c__0);
work[1].r = (doublereal) maxwrk, work[1].i = 0.;
return 0;
/* End of ZDRGEV */
} /* zdrgev_ */
/* Subroutine */ int dgbt05_(char *trans, integer *n, integer *kl, integer *
ku, integer *nrhs, doublereal *ab, integer *ldab, doublereal *b,
integer *ldb, doublereal *x, integer *ldx, doublereal *xact, integer *
ldxact, doublereal *ferr, doublereal *berr, doublereal *reslts)
{
/* System generated locals */
integer ab_dim1, ab_offset, b_dim1, b_offset, x_dim1, x_offset, xact_dim1,
xact_offset, i__1, i__2, i__3, i__4, i__5;
doublereal d__1, d__2, d__3;
/* Local variables */
integer i__, j, k, nz;
doublereal eps, tmp, diff, axbi;
integer imax;
doublereal unfl, ovfl;
doublereal xnorm;
doublereal errbnd;
logical notran;
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DGBT05 tests the error bounds from iterative refinement for the */
/* computed solution to a system of equations op(A)*X = B, where A is a */
/* general band matrix of order n with kl subdiagonals and ku */
/* superdiagonals and op(A) = A or A**T, depending on TRANS. */
/* RESLTS(1) = test of the error bound */
/* = norm(X - XACT) / ( norm(X) * FERR ) */
/* A large value is returned if this ratio is not less than one. */
/* RESLTS(2) = residual from the iterative refinement routine */
/* = the maximum of BERR / ( NZ*EPS + (*) ), where */
/* (*) = NZ*UNFL / (min_i (abs(op(A))*abs(X) +abs(b))_i ) */
/* and NZ = max. number of nonzeros in any row of A, plus 1 */
/* Arguments */
/* ========= */
/* 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 = Transpose) */
/* N (input) INTEGER */
/* The number of rows of the matrices X, B, and XACT, and the */
/* order of the matrix A. N >= 0. */
/* KL (input) INTEGER */
/* The number of subdiagonals within the band of A. KL >= 0. */
/* KU (input) INTEGER */
/* The number of superdiagonals within the band of A. KU >= 0. */
/* NRHS (input) INTEGER */
/* The number of columns of the matrices X, B, and XACT. */
/* NRHS >= 0. */
/* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) */
/* The original 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(n,j+kl). */
/* LDAB (input) INTEGER */
/* The leading dimension of the array AB. LDAB >= KL+KU+1. */
/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */
/* The right hand side vectors for the system of linear */
/* equations. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS) */
/* The computed solution vectors. Each vector is stored as a */
/* column of the matrix X. */
/* LDX (input) INTEGER */
/* The leading dimension of the array X. LDX >= max(1,N). */
/* XACT (input) DOUBLE PRECISION array, dimension (LDX,NRHS) */
/* The exact solution vectors. Each vector is stored as a */
/* column of the matrix XACT. */
/* LDXACT (input) INTEGER */
/* The leading dimension of the array XACT. LDXACT >= max(1,N). */
/* FERR (input) DOUBLE PRECISION array, dimension (NRHS) */
/* The estimated forward error bounds for each solution vector */
/* X. If XTRUE is the true solution, FERR bounds the magnitude */
/* of the largest entry in (X - XTRUE) divided by the magnitude */
/* of the largest entry in X. */
/* BERR (input) DOUBLE PRECISION array, dimension (NRHS) */
/* The componentwise relative backward error of each solution */
/* vector (i.e., the smallest relative change in any entry of A */
/* or B that makes X an exact solution). */
/* RESLTS (output) DOUBLE PRECISION array, dimension (2) */
/* The maximum over the NRHS solution vectors of the ratios: */
/* RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR ) */
/* RESLTS(2) = BERR / ( NZ*EPS + (*) ) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick exit if N = 0 or NRHS = 0. */
/* Parameter adjustments */
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1;
ab -= ab_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
xact_dim1 = *ldxact;
xact_offset = 1 + xact_dim1;
xact -= xact_offset;
--ferr;
--berr;
--reslts;
/* Function Body */
if (*n <= 0 || *nrhs <= 0) {
reslts[1] = 0.;
reslts[2] = 0.;
return 0;
}
eps = dlamch_("Epsilon");
unfl = dlamch_("Safe minimum");
ovfl = 1. / unfl;
notran = lsame_(trans, "N");
/* Computing MIN */
i__1 = *kl + *ku + 2, i__2 = *n + 1;
nz = min(i__1,i__2);
/* Test 1: Compute the maximum of */
/* norm(X - XACT) / ( norm(X) * FERR ) */
/* over all the vectors X and XACT using the infinity-norm. */
errbnd = 0.;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
imax = idamax_(n, &x[j * x_dim1 + 1], &c__1);
/* Computing MAX */
d__2 = (d__1 = x[imax + j * x_dim1], abs(d__1));
xnorm = max(d__2,unfl);
diff = 0.;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
d__2 = diff, d__3 = (d__1 = x[i__ + j * x_dim1] - xact[i__ + j *
xact_dim1], abs(d__1));
diff = max(d__2,d__3);
/* L10: */
}
if (xnorm > 1.) {
goto L20;
} else if (diff <= ovfl * xnorm) {
goto L20;
} else {
errbnd = 1. / eps;
goto L30;
}
L20:
if (diff / xnorm <= ferr[j]) {
/* Computing MAX */
d__1 = errbnd, d__2 = diff / xnorm / ferr[j];
errbnd = max(d__1,d__2);
} else {
errbnd = 1. / eps;
}
L30:
;
}
reslts[1] = errbnd;
/* Test 2: Compute the maximum of BERR / ( NZ*EPS + (*) ), where */
/* (*) = NZ*UNFL / (min_i (abs(op(A))*abs(X) +abs(b))_i ) */
i__1 = *nrhs;
for (k = 1; k <= i__1; ++k) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
tmp = (d__1 = b[i__ + k * b_dim1], abs(d__1));
if (notran) {
/* Computing MAX */
i__3 = i__ - *kl;
/* Computing MIN */
i__5 = i__ + *ku;
i__4 = min(i__5,*n);
for (j = max(i__3,1); j <= i__4; ++j) {
tmp += (d__1 = ab[*ku + 1 + i__ - j + j * ab_dim1], abs(
d__1)) * (d__2 = x[j + k * x_dim1], abs(d__2));
/* L40: */
}
} else {
/* Computing MAX */
i__4 = i__ - *ku;
/* Computing MIN */
i__5 = i__ + *kl;
i__3 = min(i__5,*n);
for (j = max(i__4,1); j <= i__3; ++j) {
tmp += (d__1 = ab[*ku + 1 + j - i__ + i__ * ab_dim1], abs(
d__1)) * (d__2 = x[j + k * x_dim1], abs(d__2));
/* L50: */
}
}
if (i__ == 1) {
axbi = tmp;
} else {
axbi = min(axbi,tmp);
}
/* L60: */
}
/* Computing MAX */
d__1 = axbi, d__2 = nz * unfl;
tmp = berr[k] / (nz * eps + nz * unfl / max(d__1,d__2));
if (k == 1) {
reslts[2] = tmp;
} else {
reslts[2] = max(reslts[2],tmp);
}
/* L70: */
}
return 0;
/* End of DGBT05 */
} /* dgbt05_ */
/* Subroutine */ int zlaqhp_(char *uplo, integer *n, doublecomplex *ap,
doublereal *s, doublereal *scond, doublereal *amax, char *equed)
{
/* System generated locals */
integer i__1, i__2, i__3, i__4;
doublereal d__1;
doublecomplex z__1;
/* Local variables */
integer i__, j, jc;
doublereal cj, large;
extern logical lsame_(char *, char *);
doublereal small;
extern doublereal dlamch_(char *);
/* -- LAPACK auxiliary routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLAQHP equilibrates a Hermitian matrix A using the scaling factors */
/* in the vector S. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the upper or lower triangular part of the */
/* Hermitian matrix A is stored. */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* AP (input/output) COMPLEX*16 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)*(2n-j)/2) = A(i,j) for j<=i<=n. */
/* On exit, the equilibrated matrix: diag(S) * A * diag(S), in */
/* the same storage format as A. */
/* S (input) DOUBLE PRECISION array, dimension (N) */
/* The scale factors for A. */
/* SCOND (input) DOUBLE PRECISION */
/* Ratio of the smallest S(i) to the largest S(i). */
/* AMAX (input) DOUBLE PRECISION */
/* Absolute value of largest matrix entry. */
/* EQUED (output) CHARACTER*1 */
/* Specifies whether or not equilibration was done. */
/* = 'N': No equilibration. */
/* = 'Y': Equilibration was done, i.e., A has been replaced by */
/* diag(S) * A * diag(S). */
/* Internal Parameters */
/* =================== */
/* THRESH is a threshold value used to decide if scaling should be done */
/* based on the ratio of the scaling factors. If SCOND < THRESH, */
/* scaling is done. */
/* LARGE and SMALL are threshold values used to decide if scaling should */
/* be done based on the absolute size of the largest matrix element. */
/* If AMAX > LARGE or AMAX < SMALL, scaling is done. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick return if possible */
/* Parameter adjustments */
--s;
--ap;
/* Function Body */
if (*n <= 0) {
*(unsigned char *)equed = 'N';
return 0;
}
/* Initialize LARGE and SMALL. */
small = dlamch_("Safe minimum") / dlamch_("Precision");
large = 1. / small;
if (*scond >= .1 && *amax >= small && *amax <= large) {
/* No equilibration */
*(unsigned char *)equed = 'N';
} else {
/* Replace A by diag(S) * A * diag(S). */
if (lsame_(uplo, "U")) {
/* Upper triangle of A is stored. */
jc = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
cj = s[j];
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = jc + i__ - 1;
d__1 = cj * s[i__];
i__4 = jc + i__ - 1;
z__1.r = d__1 * ap[i__4].r, z__1.i = d__1 * ap[i__4].i;
ap[i__3].r = z__1.r, ap[i__3].i = z__1.i;
/* L10: */
}
i__2 = jc + j - 1;
i__3 = jc + j - 1;
d__1 = cj * cj * ap[i__3].r;
ap[i__2].r = d__1, ap[i__2].i = 0.;
jc += j;
/* L20: */
}
} else {
/* Lower triangle of A is stored. */
jc = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
cj = s[j];
i__2 = jc;
i__3 = jc;
d__1 = cj * cj * ap[i__3].r;
ap[i__2].r = d__1, ap[i__2].i = 0.;
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
i__3 = jc + i__ - j;
d__1 = cj * s[i__];
i__4 = jc + i__ - j;
z__1.r = d__1 * ap[i__4].r, z__1.i = d__1 * ap[i__4].i;
ap[i__3].r = z__1.r, ap[i__3].i = z__1.i;
/* L30: */
}
jc = jc + *n - j + 1;
/* L40: */
}
}
*(unsigned char *)equed = 'Y';
}
return 0;
/* End of ZLAQHP */
} /* zlaqhp_ */
int dgerfs_(char *trans, int *n, int *nrhs,
double *a, int *lda, double *af, int *ldaf, int *
ipiv, double *b, int *ldb, double *x, int *ldx,
double *ferr, double *berr, double *work, int *iwork,
int *info)
{
/* System generated locals */
int a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1,
x_offset, i__1, i__2, i__3;
double d__1, d__2, d__3;
/* Local variables */
int i__, j, k;
double s, xk;
int nz;
double eps;
int kase;
double safe1, safe2;
extern int lsame_(char *, char *);
extern int dgemv_(char *, int *, int *,
double *, double *, int *, double *, int *,
double *, double *, int *);
int isave[3];
extern int dcopy_(int *, double *, int *,
double *, int *), daxpy_(int *, double *,
double *, int *, double *, int *);
int count;
extern int dlacn2_(int *, double *, double *,
int *, double *, int *, int *);
extern double dlamch_(char *);
double safmin;
extern int xerbla_(char *, int *), dgetrs_(
char *, int *, int *, double *, int *, int *,
double *, int *, int *);
int notran;
char transt[1];
double lstres;
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DGERFS improves the computed solution to a system of linear */
/* equations and provides error bounds and backward error estimates for */
/* the solution. */
/* Arguments */
/* ========= */
/* 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 = 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 matrices B and X. NRHS >= 0. */
/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
/* The original N-by-N matrix A. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= MAX(1,N). */
/* AF (input) DOUBLE PRECISION array, dimension (LDAF,N) */
/* The factors L and U from the factorization A = P*L*U */
/* as computed by DGETRF. */
/* LDAF (input) INTEGER */
/* The leading dimension of the array AF. LDAF >= MAX(1,N). */
/* IPIV (input) INTEGER array, dimension (N) */
/* The pivot indices from DGETRF; for 1<=i<=N, row i of the */
/* matrix was interchanged with row IPIV(i). */
/* B (input) DOUBLE PRECISION 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) DOUBLE PRECISION array, dimension (LDX,NRHS) */
/* On entry, the solution matrix X, as computed by DGETRS. */
/* 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) DOUBLE PRECISION array, dimension (3*N) */
/* IWORK (workspace) INTEGER 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. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
af_dim1 = *ldaf;
af_offset = 1 + af_dim1;
af -= af_offset;
--ipiv;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
--ferr;
--berr;
--work;
--iwork;
/* Function Body */
*info = 0;
notran = lsame_(trans, "N");
if (! notran && ! lsame_(trans, "T") && ! lsame_(
trans, "C")) {
*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_("DGERFS", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0 || *nrhs == 0) {
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
ferr[j] = 0.;
berr[j] = 0.;
/* L10: */
}
return 0;
}
if (notran) {
*(unsigned char *)transt = 'T';
} else {
*(unsigned char *)transt = 'N';
}
/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
nz = *n + 1;
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 <= i__1; ++j) {
count = 1;
lstres = 3.;
L20:
/* Loop until stopping criterion is satisfied. */
/* Compute residual R = B - op(A) * X, */
/* where op(A) = A, A**T, or A**H, depending on TRANS. */
dcopy_(n, &b[j * b_dim1 + 1], &c__1, &work[*n + 1], &c__1);
dgemv_(trans, n, n, &c_b15, &a[a_offset], lda, &x[j * x_dim1 + 1], &
c__1, &c_b17, &work[*n + 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 matrix */
/* or vector Z. If the i-th component of the denominator is less */
/* than SAFE2, then SAFE1 is added to the i-th components of the */
/* numerator and denominator before dividing. */
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
work[i__] = (d__1 = b[i__ + j * b_dim1], ABS(d__1));
/* L30: */
}
/* Compute ABS(op(A))*ABS(X) + ABS(B). */
if (notran) {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
xk = (d__1 = x[k + j * x_dim1], ABS(d__1));
i__3 = *n;
for (i__ = 1; i__ <= i__3; ++i__) {
work[i__] += (d__1 = a[i__ + k * a_dim1], ABS(d__1)) * xk;
/* L40: */
}
/* L50: */
}
} else {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
s = 0.;
i__3 = *n;
for (i__ = 1; i__ <= i__3; ++i__) {
s += (d__1 = a[i__ + k * a_dim1], ABS(d__1)) * (d__2 = x[
i__ + j * x_dim1], ABS(d__2));
/* L60: */
}
work[k] += s;
/* L70: */
}
}
s = 0.;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
if (work[i__] > safe2) {
/* Computing MAX */
d__2 = s, d__3 = (d__1 = work[*n + i__], ABS(d__1)) / work[
i__];
s = MAX(d__2,d__3);
} else {
/* Computing MAX */
d__2 = s, d__3 = ((d__1 = work[*n + i__], ABS(d__1)) + safe1)
/ (work[i__] + safe1);
s = MAX(d__2,d__3);
}
/* L80: */
}
berr[j] = s;
/* Test stopping criterion. Continue iterating if */
/* 1) The residual BERR(J) is larger than machine epsilon, and */
/* 2) BERR(J) decreased by at least a factor of 2 during the */
/* last iteration, and */
/* 3) At most ITMAX iterations tried. */
if (berr[j] > eps && berr[j] * 2. <= lstres && count <= 5) {
/* Update solution and try again. */
dgetrs_(trans, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[*n
+ 1], n, info);
daxpy_(n, &c_b17, &work[*n + 1], &c__1, &x[j * x_dim1 + 1], &c__1)
;
lstres = berr[j];
++count;
goto L20;
}
/* 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 or */
/* vector Z */
/* NZ is the maximum number of nonzeros in any row of A, plus 1 */
/* EPS is machine epsilon */
/* The i-th component of ABS(R)+NZ*EPS*(ABS(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 DLACN2 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__ <= i__2; ++i__) {
if (work[i__] > safe2) {
work[i__] = (d__1 = work[*n + i__], ABS(d__1)) + nz * eps *
work[i__];
} else {
work[i__] = (d__1 = work[*n + i__], ABS(d__1)) + nz * eps *
work[i__] + safe1;
}
/* L90: */
}
kase = 0;
L100:
dlacn2_(n, &work[(*n << 1) + 1], &work[*n + 1], &iwork[1], &ferr[j], &
kase, isave);
if (kase != 0) {
if (kase == 1) {
/* Multiply by diag(W)*inv(op(A)**T). */
dgetrs_(transt, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &
work[*n + 1], n, info);
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
work[*n + i__] = work[i__] * work[*n + i__];
/* L110: */
}
} else {
/* Multiply by inv(op(A))*diag(W). */
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
work[*n + i__] = work[i__] * work[*n + i__];
/* L120: */
}
dgetrs_(trans, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &
work[*n + 1], n, info);
}
goto L100;
}
/* Normalize error. */
lstres = 0.;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
d__2 = lstres, d__3 = (d__1 = x[i__ + j * x_dim1], ABS(d__1));
lstres = MAX(d__2,d__3);
/* L130: */
}
if (lstres != 0.) {
ferr[j] /= lstres;
}
/* L140: */
}
return 0;
/* End of DGERFS */
} /* dgerfs_ */
/*< >*/
/* Subroutine */ int dtgsen_(integer *ijob, logical *wantq, logical *wantz,
logical *select, integer *n, doublereal *a, integer *lda, doublereal *
b, integer *ldb, doublereal *alphar, doublereal *alphai, doublereal *
beta, doublereal *q, integer *ldq, doublereal *z__, integer *ldz,
integer *m, doublereal *pl, doublereal *pr, doublereal *dif,
doublereal *work, integer *lwork, integer *iwork, integer *liwork,
integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, z_dim1,
z_offset, i__1, i__2;
doublereal d__1;
/* Builtin functions */
double sqrt(doublereal), d_sign(doublereal *, doublereal *);
/* Local variables */
integer i__, k, n1, n2, kk, ks, mn2, ijb;
doublereal eps;
integer kase;
logical pair;
integer ierr;
doublereal dsum;
logical swap;
extern /* Subroutine */ int dlag2_(doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *);
logical wantd;
integer lwmin;
logical wantp, wantd1, wantd2;
extern doublereal dlamch_(char *, ftnlen);
doublereal dscale;
extern /* Subroutine */ int dlacon_(integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *);
doublereal rdscal;
extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, ftnlen),
xerbla_(char *, integer *, ftnlen), dtgexc_(logical *, logical *,
integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, integer *, integer *,
integer *, doublereal *, integer *, integer *), dlassq_(integer *,
doublereal *, integer *, doublereal *, doublereal *);
integer liwmin;
extern /* Subroutine */ int dtgsyl_(char *, integer *, integer *, integer
*, doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *,
integer *, integer *, integer *, ftnlen);
doublereal smlnum;
logical lquery;
/* -- LAPACK routine (version 3.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* June 30, 1999 */
/* .. Scalar Arguments .. */
/*< LOGICAL WANTQ, WANTZ >*/
/*< >*/
/*< DOUBLE PRECISION PL, PR >*/
/* .. */
/* .. Array Arguments .. */
/*< LOGICAL SELECT( * ) >*/
/*< INTEGER IWORK( * ) >*/
/*< >*/
/* .. */
/* Purpose */
/* ======= */
/* DTGSEN reorders the generalized real Schur decomposition of a real */
/* matrix pair (A, B) (in terms of an orthonormal equivalence trans- */
/* formation Q' * (A, B) * Z), so that a selected cluster of eigenvalues */
/* appears in the leading diagonal blocks of the upper quasi-triangular */
/* matrix A and the upper triangular B. The leading columns of Q and */
/* Z form orthonormal bases of the corresponding left and right eigen- */
/* spaces (deflating subspaces). (A, B) must be in generalized real */
/* Schur canonical form (as returned by DGGES), i.e. A is block upper */
/* triangular with 1-by-1 and 2-by-2 diagonal blocks. B is upper */
/* triangular. */
/* DTGSEN also computes the generalized eigenvalues */
/* w(j) = (ALPHAR(j) + i*ALPHAI(j))/BETA(j) */
/* of the reordered matrix pair (A, B). */
/* Optionally, DTGSEN computes the estimates of reciprocal condition */
/* numbers for eigenvalues and eigenspaces. These are Difu[(A11,B11), */
/* (A22,B22)] and Difl[(A11,B11), (A22,B22)], i.e. the separation(s) */
/* between the matrix pairs (A11, B11) and (A22,B22) that correspond to */
/* the selected cluster and the eigenvalues outside the cluster, resp., */
/* and norms of "projections" onto left and right eigenspaces w.r.t. */
/* the selected cluster in the (1,1)-block. */
/* Arguments */
/* ========= */
/* IJOB (input) INTEGER */
/* Specifies whether condition numbers are required for the */
/* cluster of eigenvalues (PL and PR) or the deflating subspaces */
/* (Difu and Difl): */
/* =0: Only reorder w.r.t. SELECT. No extras. */
/* =1: Reciprocal of norms of "projections" onto left and right */
/* eigenspaces w.r.t. the selected cluster (PL and PR). */
/* =2: Upper bounds on Difu and Difl. F-norm-based estimate */
/* (DIF(1:2)). */
/* =3: Estimate of Difu and Difl. 1-norm-based estimate */
/* (DIF(1:2)). */
/* About 5 times as expensive as IJOB = 2. */
/* =4: Compute PL, PR and DIF (i.e. 0, 1 and 2 above): Economic */
/* version to get it all. */
/* =5: Compute PL, PR and DIF (i.e. 0, 1 and 3 above) */
/* WANTQ (input) LOGICAL */
/* .TRUE. : update the left transformation matrix Q; */
/* .FALSE.: do not update Q. */
/* WANTZ (input) LOGICAL */
/* .TRUE. : update the right transformation matrix Z; */
/* .FALSE.: do not update Z. */
/* SELECT (input) LOGICAL array, dimension (N) */
/* SELECT specifies the eigenvalues in the selected cluster. */
/* To select a real eigenvalue w(j), SELECT(j) must be set to */
/* .TRUE.. To select a complex conjugate pair of eigenvalues */
/* w(j) and w(j+1), corresponding to a 2-by-2 diagonal block, */
/* either SELECT(j) or SELECT(j+1) or both must be set to */
/* .TRUE.; a complex conjugate pair of eigenvalues must be */
/* either both included in the cluster or both excluded. */
/* N (input) INTEGER */
/* The order of the matrices A and B. N >= 0. */
/* A (input/output) DOUBLE PRECISION array, dimension(LDA,N) */
/* On entry, the upper quasi-triangular matrix A, with (A, B) in */
/* generalized real Schur canonical form. */
/* On exit, A is overwritten by the reordered matrix A. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* B (input/output) DOUBLE PRECISION array, dimension(LDB,N) */
/* On entry, the upper triangular matrix B, with (A, B) in */
/* generalized real Schur canonical form. */
/* On exit, B is overwritten by the reordered matrix B. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* ALPHAR (output) DOUBLE PRECISION array, dimension (N) */
/* ALPHAI (output) DOUBLE PRECISION array, dimension (N) */
/* BETA (output) DOUBLE PRECISION array, dimension (N) */
/* On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will */
/* be the generalized eigenvalues. ALPHAR(j) + ALPHAI(j)*i */
/* and BETA(j),j=1,...,N are the diagonals of the complex Schur */
/* form (S,T) that would result if the 2-by-2 diagonal blocks of */
/* the real generalized Schur form of (A,B) were further reduced */
/* to triangular form using complex unitary transformations. */
/* If ALPHAI(j) is zero, then the j-th eigenvalue is real; if */
/* positive, then the j-th and (j+1)-st eigenvalues are a */
/* complex conjugate pair, with ALPHAI(j+1) negative. */
/* Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) */
/* On entry, if WANTQ = .TRUE., Q is an N-by-N matrix. */
/* On exit, Q has been postmultiplied by the left orthogonal */
/* transformation matrix which reorder (A, B); The leading M */
/* columns of Q form orthonormal bases for the specified pair of */
/* left eigenspaces (deflating subspaces). */
/* If WANTQ = .FALSE., Q is not referenced. */
/* LDQ (input) INTEGER */
/* The leading dimension of the array Q. LDQ >= 1; */
/* and if WANTQ = .TRUE., LDQ >= N. */
/* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) */
/* On entry, if WANTZ = .TRUE., Z is an N-by-N matrix. */
/* On exit, Z has been postmultiplied by the left orthogonal */
/* transformation matrix which reorder (A, B); The leading M */
/* columns of Z form orthonormal bases for the specified pair of */
/* left eigenspaces (deflating subspaces). */
/* If WANTZ = .FALSE., Z is not referenced. */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. LDZ >= 1; */
/* If WANTZ = .TRUE., LDZ >= N. */
/* M (output) INTEGER */
/* The dimension of the specified pair of left and right eigen- */
/* spaces (deflating subspaces). 0 <= M <= N. */
/* PL, PR (output) DOUBLE PRECISION */
/* If IJOB = 1, 4 or 5, PL, PR are lower bounds on the */
/* reciprocal of the norm of "projections" onto left and right */
/* eigenspaces with respect to the selected cluster. */
/* 0 < PL, PR <= 1. */
/* If M = 0 or M = N, PL = PR = 1. */
/* If IJOB = 0, 2 or 3, PL and PR are not referenced. */
/* DIF (output) DOUBLE PRECISION array, dimension (2). */
/* If IJOB >= 2, DIF(1:2) store the estimates of Difu and Difl. */
/* If IJOB = 2 or 4, DIF(1:2) are F-norm-based upper bounds on */
/* Difu and Difl. If IJOB = 3 or 5, DIF(1:2) are 1-norm-based */
/* estimates of Difu and Difl. */
/* If M = 0 or N, DIF(1:2) = F-norm([A, B]). */
/* If IJOB = 0 or 1, DIF is not referenced. */
/* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) */
/* IF IJOB = 0, WORK is not referenced. Otherwise, */
/* on exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. LWORK >= 4*N+16. */
/* If IJOB = 1, 2 or 4, LWORK >= MAX(4*N+16, 2*M*(N-M)). */
/* If IJOB = 3 or 5, LWORK >= MAX(4*N+16, 4*M*(N-M)). */
/* 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. */
/* IWORK (workspace/output) INTEGER array, dimension (LIWORK) */
/* IF IJOB = 0, IWORK is not referenced. Otherwise, */
/* on exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */
/* LIWORK (input) INTEGER */
/* The dimension of the array IWORK. LIWORK >= 1. */
/* If IJOB = 1, 2 or 4, LIWORK >= N+6. */
/* If IJOB = 3 or 5, LIWORK >= MAX(2*M*(N-M), N+6). */
/* If LIWORK = -1, then a workspace query is assumed; the */
/* routine only calculates the optimal size of the IWORK array, */
/* returns this value as the first entry of the IWORK array, and */
/* no error message related to LIWORK is issued by XERBLA. */
/* INFO (output) INTEGER */
/* =0: Successful exit. */
/* <0: If INFO = -i, the i-th argument had an illegal value. */
/* =1: Reordering of (A, B) failed because the transformed */
/* matrix pair (A, B) would be too far from generalized */
/* Schur form; the problem is very ill-conditioned. */
/* (A, B) may have been partially reordered. */
/* If requested, 0 is returned in DIF(*), PL and PR. */
/* Further Details */
/* =============== */
/* DTGSEN first collects the selected eigenvalues by computing */
/* orthogonal U and W that move them to the top left corner of (A, B). */
/* In other words, the selected eigenvalues are the eigenvalues of */
/* (A11, B11) in: */
/* U'*(A, B)*W = (A11 A12) (B11 B12) n1 */
/* ( 0 A22),( 0 B22) n2 */
/* n1 n2 n1 n2 */
/* where N = n1+n2 and U' means the transpose of U. The first n1 columns */
/* of U and W span the specified pair of left and right eigenspaces */
/* (deflating subspaces) of (A, B). */
/* If (A, B) has been obtained from the generalized real Schur */
/* decomposition of a matrix pair (C, D) = Q*(A, B)*Z', then the */
/* reordered generalized real Schur form of (C, D) is given by */
/* (C, D) = (Q*U)*(U'*(A, B)*W)*(Z*W)', */
/* and the first n1 columns of Q*U and Z*W span the corresponding */
/* deflating subspaces of (C, D) (Q and Z store Q*U and Z*W, resp.). */
/* Note that if the selected eigenvalue is sufficiently ill-conditioned, */
/* then its value may differ significantly from its value before */
/* reordering. */
/* The reciprocal condition numbers of the left and right eigenspaces */
/* spanned by the first n1 columns of U and W (or Q*U and Z*W) may */
/* be returned in DIF(1:2), corresponding to Difu and Difl, resp. */
/* The Difu and Difl are defined as: */
/* Difu[(A11, B11), (A22, B22)] = sigma-min( Zu ) */
/* and */
/* Difl[(A11, B11), (A22, B22)] = Difu[(A22, B22), (A11, B11)], */
/* where sigma-min(Zu) is the smallest singular value of the */
/* (2*n1*n2)-by-(2*n1*n2) matrix */
/* Zu = [ kron(In2, A11) -kron(A22', In1) ] */
/* [ kron(In2, B11) -kron(B22', In1) ]. */
/* Here, Inx is the identity matrix of size nx and A22' is the */
/* transpose of A22. kron(X, Y) is the Kronecker product between */
/* the matrices X and Y. */
/* When DIF(2) is small, small changes in (A, B) can cause large changes */
/* in the deflating subspace. An approximate (asymptotic) bound on the */
/* maximum angular error in the computed deflating subspaces is */
/* EPS * norm((A, B)) / DIF(2), */
/* where EPS is the machine precision. */
/* The reciprocal norm of the projectors on the left and right */
/* eigenspaces associated with (A11, B11) may be returned in PL and PR. */
/* They are computed as follows. First we compute L and R so that */
/* P*(A, B)*Q is block diagonal, where */
/* P = ( I -L ) n1 Q = ( I R ) n1 */
/* ( 0 I ) n2 and ( 0 I ) n2 */
/* n1 n2 n1 n2 */
/* and (L, R) is the solution to the generalized Sylvester equation */
/* A11*R - L*A22 = -A12 */
/* B11*R - L*B22 = -B12 */
/* Then PL = (F-norm(L)**2+1)**(-1/2) and PR = (F-norm(R)**2+1)**(-1/2). */
/* An approximate (asymptotic) bound on the average absolute error of */
/* the selected eigenvalues is */
/* EPS * norm((A, B)) / PL. */
/* There are also global error bounds which valid for perturbations up */
/* to a certain restriction: A lower bound (x) on the smallest */
/* F-norm(E,F) for which an eigenvalue of (A11, B11) may move and */
/* coalesce with an eigenvalue of (A22, B22) under perturbation (E,F), */
/* (i.e. (A + E, B + F), is */
/* x = min(Difu,Difl)/((1/(PL*PL)+1/(PR*PR))**(1/2)+2*max(1/PL,1/PR)). */
/* An approximate bound on x can be computed from DIF(1:2), PL and PR. */
/* If y = ( F-norm(E,F) / x) <= 1, the angles between the perturbed */
/* (L', R') and unperturbed (L, R) left and right deflating subspaces */
/* associated with the selected cluster in the (1,1)-blocks can be */
/* bounded as */
/* max-angle(L, L') <= arctan( y * PL / (1 - y * (1 - PL * PL)**(1/2)) */
/* max-angle(R, R') <= arctan( y * PR / (1 - y * (1 - PR * PR)**(1/2)) */
/* See LAPACK User's Guide section 4.11 or the following references */
/* for more information. */
/* Note that if the default method for computing the Frobenius-norm- */
/* based estimate DIF is not wanted (see DLATDF), then the parameter */
/* IDIFJB (see below) should be changed from 3 to 4 (routine DLATDF */
/* (IJOB = 2 will be used)). See DTGSYL for more details. */
/* Based on contributions by */
/* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */
/* Umea University, S-901 87 Umea, Sweden. */
/* References */
/* ========== */
/* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the */
/* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in */
/* M.S. Moonen et al (eds), Linear Algebra for Large Scale and */
/* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218. */
/* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified */
/* Eigenvalues of a Regular Matrix Pair (A, B) and Condition */
/* Estimation: Theory, Algorithms and Software, */
/* Report UMINF - 94.04, Department of Computing Science, Umea */
/* University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working */
/* Note 87. To appear in Numerical Algorithms, 1996. */
/* [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software */
/* for Solving the Generalized Sylvester Equation and Estimating the */
/* Separation between Regular Matrix Pairs, Report UMINF - 93.23, */
/* Department of Computing Science, Umea University, S-901 87 Umea, */
/* Sweden, December 1993, Revised April 1994, Also as LAPACK Working */
/* Note 75. To appear in ACM Trans. on Math. Software, Vol 22, No 1, */
/* 1996. */
/* ===================================================================== */
/* .. Parameters .. */
/*< INTEGER IDIFJB >*/
/*< PARAMETER ( IDIFJB = 3 ) >*/
/*< DOUBLE PRECISION ZERO, ONE >*/
/*< PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) >*/
/* .. */
/* .. Local Scalars .. */
/*< >*/
/*< >*/
/*< DOUBLE PRECISION DSCALE, DSUM, EPS, RDSCAL, SMLNUM >*/
/* .. */
/* .. External Subroutines .. */
/*< >*/
/* .. */
/* .. External Functions .. */
/*< DOUBLE PRECISION DLAMCH >*/
/*< EXTERNAL DLAMCH >*/
/* .. */
/* .. Intrinsic Functions .. */
/*< INTRINSIC MAX, SIGN, SQRT >*/
/* .. */
/* .. Executable Statements .. */
/* Decode and test the input parameters */
/*< INFO = 0 >*/
/* Parameter adjustments */
--select;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--alphar;
--alphai;
--beta;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--dif;
--work;
--iwork;
/* Function Body */
*info = 0;
/*< LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 ) >*/
lquery = *lwork == -1 || *liwork == -1;
/*< IF( IJOB.LT.0 .OR. IJOB.GT.5 ) THEN >*/
if (*ijob < 0 || *ijob > 5) {
/*< INFO = -1 >*/
*info = -1;
/*< ELSE IF( N.LT.0 ) THEN >*/
} else if (*n < 0) {
/*< INFO = -5 >*/
*info = -5;
/*< ELSE IF( LDA.LT.MAX( 1, N ) ) THEN >*/
} else if (*lda < max(1,*n)) {
/*< INFO = -7 >*/
*info = -7;
/*< ELSE IF( LDB.LT.MAX( 1, N ) ) THEN >*/
} else if (*ldb < max(1,*n)) {
/*< INFO = -9 >*/
*info = -9;
/*< ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.N ) ) THEN >*/
} else if (*ldq < 1 || (*wantq && *ldq < *n)) {
/*< INFO = -14 >*/
*info = -14;
/*< ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN >*/
} else if (*ldz < 1 || (*wantz && *ldz < *n)) {
/*< INFO = -16 >*/
*info = -16;
/*< END IF >*/
}
/*< IF( INFO.NE.0 ) THEN >*/
if (*info != 0) {
/*< CALL XERBLA( 'DTGSEN', -INFO ) >*/
i__1 = -(*info);
xerbla_("DTGSEN", &i__1, (ftnlen)6);
/*< RETURN >*/
return 0;
/*< END IF >*/
}
/* Get machine constants */
/*< EPS = DLAMCH( 'P' ) >*/
eps = dlamch_("P", (ftnlen)1);
/*< SMLNUM = DLAMCH( 'S' ) / EPS >*/
smlnum = dlamch_("S", (ftnlen)1) / eps;
/*< IERR = 0 >*/
ierr = 0;
/*< WANTP = IJOB.EQ.1 .OR. IJOB.GE.4 >*/
wantp = *ijob == 1 || *ijob >= 4;
/*< WANTD1 = IJOB.EQ.2 .OR. IJOB.EQ.4 >*/
wantd1 = *ijob == 2 || *ijob == 4;
/*< WANTD2 = IJOB.EQ.3 .OR. IJOB.EQ.5 >*/
wantd2 = *ijob == 3 || *ijob == 5;
/*< WANTD = WANTD1 .OR. WANTD2 >*/
wantd = wantd1 || wantd2;
/* Set M to the dimension of the specified pair of deflating */
/* subspaces. */
/*< M = 0 >*/
*m = 0;
/*< PAIR = .FALSE. >*/
pair = FALSE_;
/*< DO 10 K = 1, N >*/
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
/*< IF( PAIR ) THEN >*/
if (pair) {
/*< PAIR = .FALSE. >*/
pair = FALSE_;
/*< ELSE >*/
} else {
/*< IF( K.LT.N ) THEN >*/
if (k < *n) {
/*< IF( A( K+1, K ).EQ.ZERO ) THEN >*/
if (a[k + 1 + k * a_dim1] == 0.) {
/*< >*/
if (select[k]) {
++(*m);
}
/*< ELSE >*/
} else {
/*< PAIR = .TRUE. >*/
pair = TRUE_;
/*< >*/
if (select[k] || select[k + 1]) {
*m += 2;
}
/*< END IF >*/
}
/*< ELSE >*/
} else {
/*< >*/
if (select[*n]) {
++(*m);
}
/*< END IF >*/
}
/*< END IF >*/
}
/*< 10 CONTINUE >*/
/* L10: */
}
/*< IF( IJOB.EQ.1 .OR. IJOB.EQ.2 .OR. IJOB.EQ.4 ) THEN >*/
if (*ijob == 1 || *ijob == 2 || *ijob == 4) {
/*< LWMIN = MAX( 1, 4*N+16, 2*M*( N-M ) ) >*/
/* Computing MAX */
i__1 = 1, i__2 = (*n << 2) + 16, i__1 = max(i__1,i__2), i__2 = (*m <<
1) * (*n - *m);
lwmin = max(i__1,i__2);
/*< LIWMIN = MAX( 1, N+6 ) >*/
/* Computing MAX */
i__1 = 1, i__2 = *n + 6;
liwmin = max(i__1,i__2);
/*< ELSE IF( IJOB.EQ.3 .OR. IJOB.EQ.5 ) THEN >*/
} else if (*ijob == 3 || *ijob == 5) {
/*< LWMIN = MAX( 1, 4*N+16, 4*M*( N-M ) ) >*/
/* Computing MAX */
i__1 = 1, i__2 = (*n << 2) + 16, i__1 = max(i__1,i__2), i__2 = (*m <<
2) * (*n - *m);
lwmin = max(i__1,i__2);
/*< LIWMIN = MAX( 1, 2*M*( N-M ), N+6 ) >*/
/* Computing MAX */
i__1 = 1, i__2 = (*m << 1) * (*n - *m), i__1 = max(i__1,i__2), i__2 =
*n + 6;
liwmin = max(i__1,i__2);
/*< ELSE >*/
} else {
/*< LWMIN = MAX( 1, 4*N+16 ) >*/
/* Computing MAX */
i__1 = 1, i__2 = (*n << 2) + 16;
lwmin = max(i__1,i__2);
/*< LIWMIN = 1 >*/
liwmin = 1;
/*< END IF >*/
}
/*< WORK( 1 ) = LWMIN >*/
work[1] = (doublereal) lwmin;
/*< IWORK( 1 ) = LIWMIN >*/
iwork[1] = liwmin;
/*< IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN >*/
if (*lwork < lwmin && ! lquery) {
/*< INFO = -22 >*/
*info = -22;
/*< ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN >*/
} else if (*liwork < liwmin && ! lquery) {
/*< INFO = -24 >*/
*info = -24;
/*< END IF >*/
}
/*< IF( INFO.NE.0 ) THEN >*/
if (*info != 0) {
/*< CALL XERBLA( 'DTGSEN', -INFO ) >*/
i__1 = -(*info);
xerbla_("DTGSEN", &i__1, (ftnlen)6);
/*< RETURN >*/
return 0;
/*< ELSE IF( LQUERY ) THEN >*/
} else if (lquery) {
/*< RETURN >*/
return 0;
/*< END IF >*/
}
/* Quick return if possible. */
/*< IF( M.EQ.N .OR. M.EQ.0 ) THEN >*/
if (*m == *n || *m == 0) {
/*< IF( WANTP ) THEN >*/
if (wantp) {
/*< PL = ONE >*/
*pl = 1.;
/*< PR = ONE >*/
*pr = 1.;
/*< END IF >*/
}
/*< IF( WANTD ) THEN >*/
if (wantd) {
/*< DSCALE = ZERO >*/
dscale = 0.;
/*< DSUM = ONE >*/
dsum = 1.;
/*< DO 20 I = 1, N >*/
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/*< CALL DLASSQ( N, A( 1, I ), 1, DSCALE, DSUM ) >*/
dlassq_(n, &a[i__ * a_dim1 + 1], &c__1, &dscale, &dsum);
/*< CALL DLASSQ( N, B( 1, I ), 1, DSCALE, DSUM ) >*/
dlassq_(n, &b[i__ * b_dim1 + 1], &c__1, &dscale, &dsum);
/*< 20 CONTINUE >*/
/* L20: */
}
/*< DIF( 1 ) = DSCALE*SQRT( DSUM ) >*/
dif[1] = dscale * sqrt(dsum);
/*< DIF( 2 ) = DIF( 1 ) >*/
dif[2] = dif[1];
/*< END IF >*/
}
/*< GO TO 60 >*/
goto L60;
/*< END IF >*/
}
/* Collect the selected blocks at the top-left corner of (A, B). */
/*< KS = 0 >*/
ks = 0;
/*< PAIR = .FALSE. >*/
pair = FALSE_;
/*< DO 30 K = 1, N >*/
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
/*< IF( PAIR ) THEN >*/
if (pair) {
/*< PAIR = .FALSE. >*/
pair = FALSE_;
/*< ELSE >*/
} else {
/*< SWAP = SELECT( K ) >*/
swap = select[k];
/*< IF( K.LT.N ) THEN >*/
if (k < *n) {
/*< IF( A( K+1, K ).NE.ZERO ) THEN >*/
if (a[k + 1 + k * a_dim1] != 0.) {
/*< PAIR = .TRUE. >*/
pair = TRUE_;
/*< SWAP = SWAP .OR. SELECT( K+1 ) >*/
swap = swap || select[k + 1];
/*< END IF >*/
}
/*< END IF >*/
}
/*< IF( SWAP ) THEN >*/
if (swap) {
/*< KS = KS + 1 >*/
++ks;
/* Swap the K-th block to position KS. */
/* Perform the reordering of diagonal blocks in (A, B) */
/* by orthogonal transformation matrices and update */
/* Q and Z accordingly (if requested): */
/*< KK = K >*/
kk = k;
/*< >*/
if (k != ks) {
dtgexc_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset],
ldb, &q[q_offset], ldq, &z__[z_offset], ldz, &kk,
&ks, &work[1], lwork, &ierr);
}
/*< IF( IERR.GT.0 ) THEN >*/
if (ierr > 0) {
/* Swap is rejected: exit. */
/*< INFO = 1 >*/
*info = 1;
/*< IF( WANTP ) THEN >*/
if (wantp) {
/*< PL = ZERO >*/
*pl = 0.;
/*< PR = ZERO >*/
*pr = 0.;
/*< END IF >*/
}
/*< IF( WANTD ) THEN >*/
if (wantd) {
/*< DIF( 1 ) = ZERO >*/
dif[1] = 0.;
/*< DIF( 2 ) = ZERO >*/
dif[2] = 0.;
/*< END IF >*/
}
/*< GO TO 60 >*/
goto L60;
/*< END IF >*/
}
/*< >*/
if (pair) {
++ks;
}
/*< END IF >*/
}
/*< END IF >*/
}
/*< 30 CONTINUE >*/
/* L30: */
}
/*< IF( WANTP ) THEN >*/
if (wantp) {
/* Solve generalized Sylvester equation for R and L */
/* and compute PL and PR. */
/*< N1 = M >*/
n1 = *m;
/*< N2 = N - M >*/
n2 = *n - *m;
/*< I = N1 + 1 >*/
i__ = n1 + 1;
/*< IJB = 0 >*/
ijb = 0;
/*< CALL DLACPY( 'Full', N1, N2, A( 1, I ), LDA, WORK, N1 ) >*/
dlacpy_("Full", &n1, &n2, &a[i__ * a_dim1 + 1], lda, &work[1], &n1, (
ftnlen)4);
/*< >*/
dlacpy_("Full", &n1, &n2, &b[i__ * b_dim1 + 1], ldb, &work[n1 * n2 +
1], &n1, (ftnlen)4);
/*< >*/
i__1 = *lwork - (n1 << 1) * n2;
dtgsyl_("N", &ijb, &n1, &n2, &a[a_offset], lda, &a[i__ + i__ * a_dim1]
, lda, &work[1], &n1, &b[b_offset], ldb, &b[i__ + i__ *
b_dim1], ldb, &work[n1 * n2 + 1], &n1, &dscale, &dif[1], &
work[(n1 * n2 << 1) + 1], &i__1, &iwork[1], &ierr, (ftnlen)1);
/* Estimate the reciprocal of norms of "projections" onto left */
/* and right eigenspaces. */
/*< RDSCAL = ZERO >*/
rdscal = 0.;
/*< DSUM = ONE >*/
dsum = 1.;
/*< CALL DLASSQ( N1*N2, WORK, 1, RDSCAL, DSUM ) >*/
i__1 = n1 * n2;
dlassq_(&i__1, &work[1], &c__1, &rdscal, &dsum);
/*< PL = RDSCAL*SQRT( DSUM ) >*/
*pl = rdscal * sqrt(dsum);
/*< IF( PL.EQ.ZERO ) THEN >*/
if (*pl == 0.) {
/*< PL = ONE >*/
*pl = 1.;
/*< ELSE >*/
} else {
/*< PL = DSCALE / ( SQRT( DSCALE*DSCALE / PL+PL )*SQRT( PL ) ) >*/
*pl = dscale / (sqrt(dscale * dscale / *pl + *pl) * sqrt(*pl));
/*< END IF >*/
}
/*< RDSCAL = ZERO >*/
rdscal = 0.;
/*< DSUM = ONE >*/
dsum = 1.;
/*< CALL DLASSQ( N1*N2, WORK( N1*N2+1 ), 1, RDSCAL, DSUM ) >*/
i__1 = n1 * n2;
dlassq_(&i__1, &work[n1 * n2 + 1], &c__1, &rdscal, &dsum);
/*< PR = RDSCAL*SQRT( DSUM ) >*/
*pr = rdscal * sqrt(dsum);
/*< IF( PR.EQ.ZERO ) THEN >*/
if (*pr == 0.) {
/*< PR = ONE >*/
*pr = 1.;
/*< ELSE >*/
} else {
/*< PR = DSCALE / ( SQRT( DSCALE*DSCALE / PR+PR )*SQRT( PR ) ) >*/
*pr = dscale / (sqrt(dscale * dscale / *pr + *pr) * sqrt(*pr));
/*< END IF >*/
}
/*< END IF >*/
}
/*< IF( WANTD ) THEN >*/
if (wantd) {
/* Compute estimates of Difu and Difl. */
/*< IF( WANTD1 ) THEN >*/
if (wantd1) {
/*< N1 = M >*/
n1 = *m;
/*< N2 = N - M >*/
n2 = *n - *m;
/*< I = N1 + 1 >*/
i__ = n1 + 1;
/*< IJB = IDIFJB >*/
ijb = 3;
/* Frobenius norm-based Difu-estimate. */
/*< >*/
i__1 = *lwork - (n1 << 1) * n2;
dtgsyl_("N", &ijb, &n1, &n2, &a[a_offset], lda, &a[i__ + i__ *
a_dim1], lda, &work[1], &n1, &b[b_offset], ldb, &b[i__ +
i__ * b_dim1], ldb, &work[n1 * n2 + 1], &n1, &dscale, &
dif[1], &work[(n1 << 1) * n2 + 1], &i__1, &iwork[1], &
ierr, (ftnlen)1);
/* Frobenius norm-based Difl-estimate. */
/*< >*/
i__1 = *lwork - (n1 << 1) * n2;
dtgsyl_("N", &ijb, &n2, &n1, &a[i__ + i__ * a_dim1], lda, &a[
a_offset], lda, &work[1], &n2, &b[i__ + i__ * b_dim1],
ldb, &b[b_offset], ldb, &work[n1 * n2 + 1], &n2, &dscale,
&dif[2], &work[(n1 << 1) * n2 + 1], &i__1, &iwork[1], &
ierr, (ftnlen)1);
/*< ELSE >*/
} else {
/* Compute 1-norm-based estimates of Difu and Difl using */
/* reversed communication with DLACON. In each step a */
/* generalized Sylvester equation or a transposed variant */
/* is solved. */
/*< KASE = 0 >*/
kase = 0;
/*< N1 = M >*/
n1 = *m;
/*< N2 = N - M >*/
n2 = *n - *m;
/*< I = N1 + 1 >*/
i__ = n1 + 1;
/*< IJB = 0 >*/
ijb = 0;
/*< MN2 = 2*N1*N2 >*/
mn2 = (n1 << 1) * n2;
/* 1-norm-based estimate of Difu. */
/*< 40 CONTINUE >*/
L40:
/*< >*/
dlacon_(&mn2, &work[mn2 + 1], &work[1], &iwork[1], &dif[1], &kase)
;
/*< IF( KASE.NE.0 ) THEN >*/
if (kase != 0) {
/*< IF( KASE.EQ.1 ) THEN >*/
if (kase == 1) {
/* Solve generalized Sylvester equation. */
/*< >*/
i__1 = *lwork - (n1 << 1) * n2;
dtgsyl_("N", &ijb, &n1, &n2, &a[a_offset], lda, &a[i__ +
i__ * a_dim1], lda, &work[1], &n1, &b[b_offset],
ldb, &b[i__ + i__ * b_dim1], ldb, &work[n1 * n2 +
1], &n1, &dscale, &dif[1], &work[(n1 << 1) * n2 +
1], &i__1, &iwork[1], &ierr, (ftnlen)1);
/*< ELSE >*/
} else {
/* Solve the transposed variant. */
/*< >*/
i__1 = *lwork - (n1 << 1) * n2;
dtgsyl_("T", &ijb, &n1, &n2, &a[a_offset], lda, &a[i__ +
i__ * a_dim1], lda, &work[1], &n1, &b[b_offset],
ldb, &b[i__ + i__ * b_dim1], ldb, &work[n1 * n2 +
1], &n1, &dscale, &dif[1], &work[(n1 << 1) * n2 +
1], &i__1, &iwork[1], &ierr, (ftnlen)1);
/*< END IF >*/
}
/*< GO TO 40 >*/
goto L40;
/*< END IF >*/
}
/*< DIF( 1 ) = DSCALE / DIF( 1 ) >*/
dif[1] = dscale / dif[1];
/* 1-norm-based estimate of Difl. */
/*< 50 CONTINUE >*/
L50:
/*< >*/
dlacon_(&mn2, &work[mn2 + 1], &work[1], &iwork[1], &dif[2], &kase)
;
/*< IF( KASE.NE.0 ) THEN >*/
if (kase != 0) {
/*< IF( KASE.EQ.1 ) THEN >*/
if (kase == 1) {
/* Solve generalized Sylvester equation. */
/*< >*/
i__1 = *lwork - (n1 << 1) * n2;
dtgsyl_("N", &ijb, &n2, &n1, &a[i__ + i__ * a_dim1], lda,
&a[a_offset], lda, &work[1], &n2, &b[i__ + i__ *
b_dim1], ldb, &b[b_offset], ldb, &work[n1 * n2 +
1], &n2, &dscale, &dif[2], &work[(n1 << 1) * n2 +
1], &i__1, &iwork[1], &ierr, (ftnlen)1);
/*< ELSE >*/
} else {
/* Solve the transposed variant. */
/*< >*/
i__1 = *lwork - (n1 << 1) * n2;
dtgsyl_("T", &ijb, &n2, &n1, &a[i__ + i__ * a_dim1], lda,
&a[a_offset], lda, &work[1], &n2, &b[i__ + i__ *
b_dim1], ldb, &b[b_offset], ldb, &work[n1 * n2 +
1], &n2, &dscale, &dif[2], &work[(n1 << 1) * n2 +
1], &i__1, &iwork[1], &ierr, (ftnlen)1);
/*< END IF >*/
}
/*< GO TO 50 >*/
goto L50;
/*< END IF >*/
}
/*< DIF( 2 ) = DSCALE / DIF( 2 ) >*/
dif[2] = dscale / dif[2];
/*< END IF >*/
}
/*< END IF >*/
}
/*< 60 CONTINUE >*/
L60:
/* Compute generalized eigenvalues of reordered pair (A, B) and */
/* normalize the generalized Schur form. */
/*< PAIR = .FALSE. >*/
pair = FALSE_;
/*< DO 80 K = 1, N >*/
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
/*< IF( PAIR ) THEN >*/
if (pair) {
/*< PAIR = .FALSE. >*/
pair = FALSE_;
/*< ELSE >*/
} else {
/*< IF( K.LT.N ) THEN >*/
if (k < *n) {
/*< IF( A( K+1, K ).NE.ZERO ) THEN >*/
if (a[k + 1 + k * a_dim1] != 0.) {
/*< PAIR = .TRUE. >*/
pair = TRUE_;
/*< END IF >*/
}
/*< END IF >*/
}
/*< IF( PAIR ) THEN >*/
if (pair) {
/* Compute the eigenvalue(s) at position K. */
/*< WORK( 1 ) = A( K, K ) >*/
work[1] = a[k + k * a_dim1];
/*< WORK( 2 ) = A( K+1, K ) >*/
work[2] = a[k + 1 + k * a_dim1];
/*< WORK( 3 ) = A( K, K+1 ) >*/
work[3] = a[k + (k + 1) * a_dim1];
/*< WORK( 4 ) = A( K+1, K+1 ) >*/
work[4] = a[k + 1 + (k + 1) * a_dim1];
/*< WORK( 5 ) = B( K, K ) >*/
work[5] = b[k + k * b_dim1];
/*< WORK( 6 ) = B( K+1, K ) >*/
work[6] = b[k + 1 + k * b_dim1];
/*< WORK( 7 ) = B( K, K+1 ) >*/
work[7] = b[k + (k + 1) * b_dim1];
/*< WORK( 8 ) = B( K+1, K+1 ) >*/
work[8] = b[k + 1 + (k + 1) * b_dim1];
/*< >*/
d__1 = smlnum * eps;
dlag2_(&work[1], &c__2, &work[5], &c__2, &d__1, &beta[k], &
beta[k + 1], &alphar[k], &alphar[k + 1], &alphai[k]);
/*< ALPHAI( K+1 ) = -ALPHAI( K ) >*/
alphai[k + 1] = -alphai[k];
/*< ELSE >*/
} else {
/*< IF( SIGN( ONE, B( K, K ) ).LT.ZERO ) THEN >*/
if (d_sign(&c_b28, &b[k + k * b_dim1]) < 0.) {
/* If B(K,K) is negative, make it positive */
/*< DO 70 I = 1, N >*/
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
/*< A( K, I ) = -A( K, I ) >*/
a[k + i__ * a_dim1] = -a[k + i__ * a_dim1];
/*< B( K, I ) = -B( K, I ) >*/
b[k + i__ * b_dim1] = -b[k + i__ * b_dim1];
/*< Q( I, K ) = -Q( I, K ) >*/
q[i__ + k * q_dim1] = -q[i__ + k * q_dim1];
/*< 70 CONTINUE >*/
/* L70: */
}
/*< END IF >*/
}
/*< ALPHAR( K ) = A( K, K ) >*/
alphar[k] = a[k + k * a_dim1];
/*< ALPHAI( K ) = ZERO >*/
alphai[k] = 0.;
/*< BETA( K ) = B( K, K ) >*/
beta[k] = b[k + k * b_dim1];
/*< END IF >*/
}
/*< END IF >*/
}
/*< 80 CONTINUE >*/
/* L80: */
}
/*< WORK( 1 ) = LWMIN >*/
work[1] = (doublereal) lwmin;
/*< IWORK( 1 ) = LIWMIN >*/
iwork[1] = liwmin;
/*< RETURN >*/
return 0;
/* End of DTGSEN */
/*< END >*/
} /* dtgsen_ */
void
pdgssvx(int nprocs, pdgstrf_options_t *pdgstrf_options, SuperMatrix *A,
int *perm_c, int *perm_r, equed_t *equed, double *R, double *C,
SuperMatrix *L, SuperMatrix *U,
SuperMatrix *B, SuperMatrix *X, double *recip_pivot_growth,
double *rcond, double *ferr, double *berr,
superlu_memusage_t *superlu_memusage, int *info)
{
/*
* -- SuperLU MT routine (version 1.0) --
* Univ. of California Berkeley, Xerox Palo Alto Research Center,
* and Lawrence Berkeley National Lab.
* August 15, 1997
*
* Purpose
* =======
*
* pdgssvx() solves the system of linear equations A*X=B or A'*X=B, using
* the LU factorization from dgstrf(). Error bounds on the solution and
* a condition estimate are also provided. It performs the following steps:
*
* 1. If A is stored column-wise (A->Stype = NC):
*
* 1.1. If fact = EQUILIBRATE, scaling factors are computed to equilibrate
* the system:
* trans = NOTRANS: diag(R)*A*diag(C)*inv(diag(C))*X = diag(R)*B
* trans = TRANS: (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B
* trans = CONJ: (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B
* Whether or not the system will be equilibrated depends on the
* scaling of the matrix A, but if equilibration is used, A is
* overwritten by diag(R)*A*diag(C) and B by diag(R)*B
* (if trans = NOTRANS) or diag(C)*B (if trans = TRANS or CONJ).
*
* 1.2. Permute columns of A, forming A*Pc, where Pc is a permutation matrix
* that usually preserves sparsity.
* For more details of this step, see sp_colorder.c.
*
* 1.3. If fact = DOFACT or EQUILIBRATE, the LU decomposition is used to
* factor the matrix A (after equilibration if fact = EQUILIBRATE) as
* Pr*A*Pc = L*U, with Pr determined by partial pivoting.
*
* 1.4. Compute the reciprocal pivot growth factor.
*
* 1.5. If some U(i,i) = 0, so that U is exactly singular, then the routine
* returns with info = i. Otherwise, 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,
* info = A->ncol+1 is returned as a warning, but the routine still
* goes on to solve for X and computes error bounds as described below.
*
* 1.6. The system of equations is solved for X using the factored form
* of A.
*
* 1.7. Iterative refinement is applied to improve the computed solution
* matrix and calculate error bounds and backward error estimates
* for it.
*
* 1.8. If equilibration was used, the matrix X is premultiplied by
* diag(C) (if trans = NOTRANS) or diag(R) (if trans = TRANS or CONJ)
* so that it solves the original system before equilibration.
*
* 2. If A is stored row-wise (A->Stype = NR), apply the above algorithm
* to the tranpose of A:
*
* 2.1. If fact = EQUILIBRATE, scaling factors are computed to equilibrate
* the system:
* trans = NOTRANS:diag(R)*A'*diag(C)*inv(diag(C))*X = diag(R)*B
* trans = TRANS: (diag(R)*A'*diag(C))**T *inv(diag(R))*X = diag(C)*B
* trans = CONJ: (diag(R)*A'*diag(C))**H *inv(diag(R))*X = diag(C)*B
* Whether or not the system will be equilibrated depends on the
* scaling of the matrix A, but if equilibration is used, A' is
* overwritten by diag(R)*A'*diag(C) and B by diag(R)*B
* (if trans = NOTRANS) or diag(C)*B (if trans = TRANS or CONJ).
*
* 2.2. Permute columns of transpose(A) (rows of A),
* forming transpose(A)*Pc, where Pc is a permutation matrix that
* usually preserves sparsity.
* For more details of this step, see sp_colorder.c.
*
* 2.3. If fact = DOFACT or EQUILIBRATE, the LU decomposition is used to
* factor the matrix A (after equilibration if fact = EQUILIBRATE) as
* Pr*transpose(A)*Pc = L*U, with the permutation Pr determined by
* partial pivoting.
*
* 2.4. Compute the reciprocal pivot growth factor.
*
* 2.5. If some U(i,i) = 0, so that U is exactly singular, then the routine
* returns with info = i. Otherwise, the factored form of transpose(A)
* is used to estimate the condition number of the matrix A.
* If the reciprocal of the condition number is less than machine
* precision, info = A->nrow+1 is returned as a warning, but the
* routine still goes on to solve for X and computes error bounds
* as described below.
*
* 2.6. The system of equations is solved for X using the factored form
* of transpose(A).
*
* 2.7. Iterative refinement is applied to improve the computed solution
* matrix and calculate error bounds and backward error estimates
* for it.
*
* 2.8. If equilibration was used, the matrix X is premultiplied by
* diag(C) (if trans = NOTRANS) or diag(R) (if trans = TRANS or CONJ)
* so that it solves the original system before equilibration.
*
* See supermatrix.h for the definition of 'SuperMatrix' structure.
*
* Arguments
* =========
*
* nprocs (input) int
* Number of processes (or threads) to be spawned and used to perform
* the LU factorization by pdgstrf(). There is a single thread of
* control to call pdgstrf(), and all threads spawned by pdgstrf()
* are terminated before returning from pdgstrf().
*
* pdgstrf_options (input) pdgstrf_options_t*
* The structure defines the input parameters and data structure
* to control how the LU factorization will be performed.
* The following fields should be defined for this structure:
*
* o fact (fact_t)
* Specifies whether or not the factored form of the matrix
* A is supplied on entry, and if not, whether the matrix A should
* be equilibrated before it is factored.
* = FACTORED: On entry, L, U, perm_r and perm_c contain the
* factored form of A. If equed is not NOEQUIL, the matrix A has
* been equilibrated with scaling factors R and C.
* A, L, U, perm_r are not modified.
* = DOFACT: The matrix A will be factored, and the factors will be
* stored in L and U.
* = EQUILIBRATE: The matrix A will be equilibrated if necessary,
* then factored into L and U.
*
* o trans (trans_t)
* Specifies the form of the system of equations:
* = NOTRANS: A * X = B (No transpose)
* = TRANS: A**T * X = B (Transpose)
* = CONJ: A**H * X = B (Transpose)
*
* o refact (yes_no_t)
* Specifies whether this is first time or subsequent factorization.
* = NO: this factorization is treated as the first one;
* = YES: it means that a factorization was performed prior to this
* one. Therefore, this factorization will re-use some
* existing data structures, such as L and U storage, column
* elimination tree, and the symbolic information of the
* Householder matrix.
*
* o panel_size (int)
* A panel consists of at most panel_size consecutive columns.
*
* o relax (int)
* To control degree of relaxing supernodes. If the number
* of nodes (columns) in a subtree of the elimination tree is less
* than relax, this subtree is considered as one supernode,
* regardless of the row structures of those columns.
*
* o diag_pivot_thresh (double)
* Diagonal pivoting threshold. At step j of the Gaussian
* elimination, if
* abs(A_jj) >= diag_pivot_thresh * (max_(i>=j) abs(A_ij)),
* use A_jj as pivot, else use A_ij with maximum magnitude.
* 0 <= diag_pivot_thresh <= 1. The default value is 1,
* corresponding to partial pivoting.
*
* o usepr (yes_no_t)
* Whether the pivoting will use perm_r specified by the user.
* = YES: use perm_r; perm_r is input, unchanged on exit.
* = NO: perm_r is determined by partial pivoting, and is output.
*
* o drop_tol (double) (NOT IMPLEMENTED)
* Drop tolerance parameter. At step j of the Gaussian elimination,
* if abs(A_ij)/(max_i abs(A_ij)) < drop_tol, drop entry A_ij.
* 0 <= drop_tol <= 1. The default value of drop_tol is 0,
* corresponding to not dropping any entry.
*
* o work (void*) of size lwork
* User-supplied work space and space for the output data structures.
* Not referenced if lwork = 0;
*
* o lwork (int)
* Specifies the length of work array.
* = 0: allocate space internally by system malloc;
* > 0: use user-supplied work array of length lwork in bytes,
* returns error if space runs out.
* = -1: the routine guesses the amount of space needed without
* performing the factorization, and returns it in
* superlu_memusage->total_needed; no other side effects.
*
* A (input/output) SuperMatrix*
* Matrix A in A*X=B, of dimension (A->nrow, A->ncol), where
* A->nrow = A->ncol. Currently, the type of A can be:
* Stype = NC or NR, Dtype = _D, Mtype = GE. In the future,
* more general A will be handled.
*
* On entry, If pdgstrf_options->fact = FACTORED and equed is not
* NOEQUIL, then A must have been equilibrated by the scaling factors
* in R and/or C. On exit, A is not modified
* if pdgstrf_options->fact = FACTORED or DOFACT, or
* if pdgstrf_options->fact = EQUILIBRATE and equed = NOEQUIL.
*
* On exit, if pdgstrf_options->fact = EQUILIBRATE and equed is not
* NOEQUIL, A is scaled as follows:
* If A->Stype = NC:
* equed = ROW: A := diag(R) * A
* equed = COL: A := A * diag(C)
* equed = BOTH: A := diag(R) * A * diag(C).
* If A->Stype = NR:
* equed = ROW: transpose(A) := diag(R) * transpose(A)
* equed = COL: transpose(A) := transpose(A) * diag(C)
* equed = BOTH: transpose(A) := diag(R) * transpose(A) * diag(C).
*
* perm_c (input/output) int*
* If A->Stype = NC, Column permutation vector of size A->ncol,
* which defines the permutation matrix Pc; perm_c[i] = j means
* column i of A is in position j in A*Pc.
* On exit, perm_c may be overwritten by the product of the input
* perm_c and a permutation that postorders the elimination tree
* of Pc'*A'*A*Pc; perm_c is not changed if the elimination tree
* is already in postorder.
*
* If A->Stype = NR, column permutation vector of size A->nrow,
* which describes permutation of columns of tranpose(A)
* (rows of A) as described above.
*
* perm_r (input/output) int*
* If A->Stype = NC, row permutation vector of size A->nrow,
* which defines the permutation matrix Pr, and is determined
* by partial pivoting. perm_r[i] = j means row i of A is in
* position j in Pr*A.
*
* If A->Stype = NR, permutation vector of size A->ncol, which
* determines permutation of rows of transpose(A)
* (columns of A) as described above.
*
* If pdgstrf_options->usepr = NO, perm_r is output argument;
* If pdgstrf_options->usepr = YES, the pivoting routine will try
* to use the input perm_r, unless a certain threshold criterion
* is violated. In that case, perm_r is overwritten by a new
* permutation determined by partial pivoting or diagonal
* threshold pivoting.
*
* equed (input/output) equed_t*
* Specifies the form of equilibration that was done.
* = NOEQUIL: No equilibration.
* = ROW: Row equilibration, i.e., A was premultiplied by diag(R).
* = COL: Column equilibration, i.e., A was postmultiplied by diag(C).
* = BOTH: Both row and column equilibration, i.e., A was replaced
* by diag(R)*A*diag(C).
* If pdgstrf_options->fact = FACTORED, equed is an input argument,
* otherwise it is an output argument.
*
* R (input/output) double*, dimension (A->nrow)
* The row scale factors for A or transpose(A).
* If equed = ROW or BOTH, A (if A->Stype = NC) or transpose(A)
* (if A->Stype = NR) is multiplied on the left by diag(R).
* If equed = NOEQUIL or COL, R is not accessed.
* If fact = FACTORED, R is an input argument; otherwise, R is output.
* If fact = FACTORED and equed = ROW or BOTH, each element of R must
* be positive.
*
* C (input/output) double*, dimension (A->ncol)
* The column scale factors for A or transpose(A).
* If equed = COL or BOTH, A (if A->Stype = NC) or trnspose(A)
* (if A->Stype = NR) is multiplied on the right by diag(C).
* If equed = NOEQUIL or ROW, C is not accessed.
* If fact = FACTORED, C is an input argument; otherwise, C is output.
* If fact = FACTORED and equed = COL or BOTH, each element of C must
* be positive.
*
* L (output) SuperMatrix*
* The factor L from the factorization
* Pr*A*Pc=L*U (if A->Stype = NC) or
* Pr*transpose(A)*Pc=L*U (if A->Stype = NR).
* Uses compressed row subscripts storage for supernodes, i.e.,
* L has types: Stype = SCP, Dtype = _D, Mtype = TRLU.
*
* U (output) SuperMatrix*
* The factor U from the factorization
* Pr*A*Pc=L*U (if A->Stype = NC) or
* Pr*transpose(A)*Pc=L*U (if A->Stype = NR).
* Uses column-wise storage scheme, i.e., U has types:
* Stype = NCP, Dtype = _D, Mtype = TRU.
*
* B (input/output) SuperMatrix*
* B has types: Stype = DN, Dtype = _D, Mtype = GE.
* On entry, the right hand side matrix.
* On exit,
* if equed = NOEQUIL, B is not modified; otherwise
* if A->Stype = NC:
* if trans = NOTRANS and equed = ROW or BOTH, B is overwritten
* by diag(R)*B;
* if trans = TRANS or CONJ and equed = COL of BOTH, B is
* overwritten by diag(C)*B;
* if A->Stype = NR:
* if trans = NOTRANS and equed = COL or BOTH, B is overwritten
* by diag(C)*B;
* if trans = TRANS or CONJ and equed = ROW of BOTH, B is
* overwritten by diag(R)*B.
*
* X (output) SuperMatrix*
* X has types: Stype = DN, Dtype = _D, Mtype = GE.
* If info = 0 or info = A->ncol+1, X contains the solution matrix
* to the original system of equations. Note that A and B are modified
* on exit if equed is not NOEQUIL, and the solution to the
* equilibrated system is inv(diag(C))*X if trans = NOTRANS and
* equed = COL or BOTH, or inv(diag(R))*X if trans = TRANS or CONJ
* and equed = ROW or BOTH.
*
* recip_pivot_growth (output) double*
* The reciprocal pivot growth factor computed as
* max_j ( max_i(abs(A_ij)) / max_i(abs(U_ij)) ).
* If recip_pivot_growth is much less than 1, the stability of the
* LU factorization could be poor.
*
* rcond (output) double*
* The estimate of the reciprocal condition number of the matrix A
* after equilibration (if done). 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.
*
* ferr (output) double*, dimension (B->ncol)
* 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*, dimension (B->ncol)
* 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).
*
* superlu_memusage (output) superlu_memusage_t*
* Record the memory usage statistics, consisting of following fields:
* - for_lu (float)
* The amount of space used in bytes for L\U data structures.
* - total_needed (float)
* The amount of space needed in bytes to perform factorization.
* - expansions (int)
* The number of memory expansions during the LU factorization.
*
* info (output) int*
* = 0: successful exit
* < 0: if info = -i, the i-th argument had an illegal value
* > 0: if info = i, and i is
* <= A->ncol: U(i,i) is exactly zero. The factorization has
* been completed, but the factor U is exactly
* singular, so the solution and error bounds
* could not be computed.
* = A->ncol+1: U is nonsingular, but RCOND is less than machine
* precision, meaning that the matrix is singular to
* working precision. Nevertheless, the solution and
* error bounds are computed because there are a number
* of situations where the computed solution can be more
* accurate than the value of RCOND would suggest.
* > A->ncol+1: number of bytes allocated when memory allocation
* failure occurred, plus A->ncol.
*
*/
NCformat *Astore;
DNformat *Bstore, *Xstore;
double *Bmat, *Xmat;
int ldb, ldx, nrhs;
SuperMatrix *AA; /* A in NC format used by the factorization routine.*/
SuperMatrix AC; /* Matrix postmultiplied by Pc */
int colequ, equil, dofact, notran, rowequ;
char norm[1];
trans_t trant;
int i, j, info1;
double amax, anorm, bignum, smlnum, colcnd, rowcnd, rcmax, rcmin;
int n, relax, panel_size;
Gstat_t Gstat;
double t0; /* temporary time */
double *utime;
flops_t *ops, flopcnt;
/* External functions */
extern double dlangs(char *, SuperMatrix *);
extern double dlamch_(char *);
Astore = A->Store;
Bstore = B->Store;
Xstore = X->Store;
Bmat = Bstore->nzval;
Xmat = Xstore->nzval;
n = A->ncol;
ldb = Bstore->lda;
ldx = Xstore->lda;
nrhs = B->ncol;
pdgstrf_options->perm_c = perm_c;
pdgstrf_options->perm_r = perm_r;
*info = 0;
dofact = (pdgstrf_options->fact == DOFACT);
equil = (pdgstrf_options->fact == EQUILIBRATE);
notran = (pdgstrf_options->trans == NOTRANS);
if (dofact || equil) {
*equed = NOEQUIL;
rowequ = FALSE;
colequ = FALSE;
} else {
rowequ = (*equed == ROW) || (*equed == BOTH);
colequ = (*equed == COL) || (*equed == BOTH);
smlnum = dlamch_("Safe minimum");
bignum = 1. / smlnum;
}
/* ------------------------------------------------------------
Test the input parameters.
------------------------------------------------------------*/
if ( nprocs <= 0 ) *info = -1;
else if ( (!dofact && !equil && (pdgstrf_options->fact != FACTORED))
|| (!notran && (pdgstrf_options->trans != TRANS) &&
(pdgstrf_options->trans != CONJ))
|| (pdgstrf_options->refact != YES &&
pdgstrf_options->refact != NO)
|| (pdgstrf_options->usepr != YES &&
pdgstrf_options->usepr != NO)
|| pdgstrf_options->lwork < -1 )
*info = -2;
else if ( A->nrow != A->ncol || A->nrow < 0 ||
(A->Stype != SLU_NC && A->Stype != SLU_NR) ||
A->Dtype != SLU_D || A->Mtype != SLU_GE )
*info = -3;
else if ((pdgstrf_options->fact == FACTORED) &&
!(rowequ || colequ || (*equed == NOEQUIL))) *info = -6;
else {
if (rowequ) {
rcmin = bignum;
rcmax = 0.;
for (j = 0; j < A->nrow; ++j) {
rcmin = MIN(rcmin, R[j]);
rcmax = MAX(rcmax, R[j]);
}
if (rcmin <= 0.) *info = -7;
else if ( A->nrow > 0)
rowcnd = MAX(rcmin,smlnum) / MIN(rcmax,bignum);
else rowcnd = 1.;
}
if (colequ && *info == 0) {
rcmin = bignum;
rcmax = 0.;
for (j = 0; j < A->nrow; ++j) {
rcmin = MIN(rcmin, C[j]);
rcmax = MAX(rcmax, C[j]);
}
if (rcmin <= 0.) *info = -8;
else if (A->nrow > 0)
colcnd = MAX(rcmin,smlnum) / MIN(rcmax,bignum);
else colcnd = 1.;
}
if (*info == 0) {
if ( B->ncol < 0 || Bstore->lda < MAX(0, A->nrow) ||
B->Stype != SLU_DN || B->Dtype != SLU_D ||
B->Mtype != SLU_GE )
*info = -11;
else if ( X->ncol < 0 || Xstore->lda < MAX(0, A->nrow) ||
B->ncol != X->ncol || X->Stype != SLU_DN ||
X->Dtype != SLU_D || X->Mtype != SLU_GE )
*info = -12;
}
}
if (*info != 0) {
i = -(*info);
xerbla_("dgssvx", &i);
return;
}
/* ------------------------------------------------------------
Allocate storage and initialize statistics variables.
------------------------------------------------------------*/
panel_size = pdgstrf_options->panel_size;
relax = pdgstrf_options->relax;
StatAlloc(n, nprocs, panel_size, relax, &Gstat);
StatInit(n, nprocs, &Gstat);
utime = Gstat.utime;
ops = Gstat.ops;
/* ------------------------------------------------------------
Convert A to NC format when necessary.
------------------------------------------------------------*/
if ( A->Stype == SLU_NR ) {
NRformat *Astore = A->Store;
AA = (SuperMatrix *) SUPERLU_MALLOC( sizeof(SuperMatrix) );
dCreate_CompCol_Matrix(AA, A->ncol, A->nrow, Astore->nnz,
Astore->nzval, Astore->colind, Astore->rowptr,
SLU_NC, A->Dtype, A->Mtype);
if ( notran ) { /* Reverse the transpose argument. */
trant = TRANS;
notran = 0;
} else {
trant = NOTRANS;
notran = 1;
}
} else { /* A->Stype == NC */
trant = pdgstrf_options->trans;
AA = A;
}
/* ------------------------------------------------------------
Diagonal scaling to equilibrate the matrix.
------------------------------------------------------------*/
if ( equil ) {
t0 = SuperLU_timer_();
/* Compute row and column scalings to equilibrate the matrix A. */
dgsequ(AA, R, C, &rowcnd, &colcnd, &amax, &info1);
if ( info1 == 0 ) {
/* Equilibrate matrix A. */
dlaqgs(AA, R, C, rowcnd, colcnd, amax, equed);
rowequ = (*equed == ROW) || (*equed == BOTH);
colequ = (*equed == COL) || (*equed == BOTH);
}
utime[EQUIL] = SuperLU_timer_() - t0;
}
/* ------------------------------------------------------------
Scale the right hand side.
------------------------------------------------------------*/
if ( notran ) {
if ( rowequ ) {
for (j = 0; j < nrhs; ++j)
for (i = 0; i < A->nrow; ++i) {
Bmat[i + j*ldb] *= R[i];
}
}
} else if ( colequ ) {
for (j = 0; j < nrhs; ++j)
for (i = 0; i < A->nrow; ++i) {
Bmat[i + j*ldb] *= C[i];
}
}
/* ------------------------------------------------------------
Perform the LU factorization.
------------------------------------------------------------*/
if ( dofact || equil ) {
/* Obtain column etree, the column count (colcnt_h) and supernode
partition (part_super_h) for the Householder matrix. */
t0 = SuperLU_timer_();
sp_colorder(AA, perm_c, pdgstrf_options, &AC);
utime[ETREE] = SuperLU_timer_() - t0;
#if ( PRNTlevel >= 2 )
printf("Factor PA = LU ... relax %d\tw %d\tmaxsuper %d\trowblk %d\n",
relax, panel_size, sp_ienv(3), sp_ienv(4));
fflush(stdout);
#endif
/* Compute the LU factorization of A*Pc. */
t0 = SuperLU_timer_();
pdgstrf(pdgstrf_options, &AC, perm_r, L, U, &Gstat, info);
utime[FACT] = SuperLU_timer_() - t0;
flopcnt = 0;
for (i = 0; i < nprocs; ++i) flopcnt += Gstat.procstat[i].fcops;
ops[FACT] = flopcnt;
if ( pdgstrf_options->lwork == -1 ) {
superlu_memusage->total_needed = *info - A->ncol;
return;
}
}
if ( *info > 0 ) {
if ( *info <= A->ncol ) {
/* Compute the reciprocal pivot growth factor of the leading
rank-deficient *info columns of A. */
*recip_pivot_growth = dPivotGrowth(*info, AA, perm_c, L, U);
}
} else {
/* ------------------------------------------------------------
Compute the reciprocal pivot growth factor *recip_pivot_growth.
------------------------------------------------------------*/
*recip_pivot_growth = dPivotGrowth(A->ncol, AA, perm_c, L, U);
/* ------------------------------------------------------------
Estimate the reciprocal of the condition number of A.
------------------------------------------------------------*/
t0 = SuperLU_timer_();
if ( notran ) {
*(unsigned char *)norm = '1';
} else {
*(unsigned char *)norm = 'I';
}
anorm = dlangs(norm, AA);
dgscon(norm, L, U, anorm, rcond, info);
utime[RCOND] = SuperLU_timer_() - t0;
/* ------------------------------------------------------------
Compute the solution matrix X.
------------------------------------------------------------*/
for (j = 0; j < nrhs; j++) /* Save a copy of the right hand sides */
for (i = 0; i < B->nrow; i++)
Xmat[i + j*ldx] = Bmat[i + j*ldb];
t0 = SuperLU_timer_();
dgstrs(trant, L, U, perm_r, perm_c, X, &Gstat, info);
utime[SOLVE] = SuperLU_timer_() - t0;
ops[SOLVE] = ops[TRISOLVE];
/* ------------------------------------------------------------
Use iterative refinement to improve the computed solution and
compute error bounds and backward error estimates for it.
------------------------------------------------------------*/
t0 = SuperLU_timer_();
dgsrfs(trant, AA, L, U, perm_r, perm_c, *equed,
R, C, B, X, ferr, berr, &Gstat, info);
utime[REFINE] = SuperLU_timer_() - t0;
/* ------------------------------------------------------------
Transform the solution matrix X to a solution of the original
system.
------------------------------------------------------------*/
if ( notran ) {
if ( colequ ) {
for (j = 0; j < nrhs; ++j)
for (i = 0; i < A->nrow; ++i) {
Xmat[i + j*ldx] *= C[i];
}
}
} else if ( rowequ ) {
for (j = 0; j < nrhs; ++j)
for (i = 0; i < A->nrow; ++i) {
Xmat[i + j*ldx] *= R[i];
}
}
/* Set INFO = A->ncol+1 if the matrix is singular to
working precision.*/
if ( *rcond < dlamch_("E") ) *info = A->ncol + 1;
}
superlu_QuerySpace(nprocs, L, U, panel_size, superlu_memusage);
/* ------------------------------------------------------------
Deallocate storage after factorization.
------------------------------------------------------------*/
if ( pdgstrf_options->refact == NO ) {
SUPERLU_FREE(pdgstrf_options->etree);
SUPERLU_FREE(pdgstrf_options->colcnt_h);
SUPERLU_FREE(pdgstrf_options->part_super_h);
}
if ( dofact || equil ) {
Destroy_CompCol_Permuted(&AC);
}
if ( A->Stype == SLU_NR ) {
Destroy_SuperMatrix_Store(AA);
SUPERLU_FREE(AA);
}
/* ------------------------------------------------------------
Print timings, then deallocate statistic variables.
------------------------------------------------------------*/
PrintStat(&Gstat);
StatFree(&Gstat);
}
/* Subroutine */ int zchkhb_(integer *nsizes, integer *nn, integer *nwdths,
integer *kk, integer *ntypes, logical *dotype, integer *iseed,
doublereal *thresh, integer *nounit, doublecomplex *a, integer *lda,
doublereal *sd, doublereal *se, doublecomplex *u, integer *ldu,
doublecomplex *work, integer *lwork, doublereal *rwork, doublereal *
result, integer *info)
{
/* Initialized data */
static integer ktype[15] = { 1,2,4,4,4,4,4,5,5,5,5,5,8,8,8 };
static integer kmagn[15] = { 1,1,1,1,1,2,3,1,1,1,2,3,1,2,3 };
static integer kmode[15] = { 0,0,4,3,1,4,4,4,3,1,4,4,0,0,0 };
/* Format strings */
static char fmt_9999[] = "(\002 ZCHKHB: \002,a,\002 returned INFO=\002,i"
"6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
"(\002,3(i5,\002,\002),i5,\002)\002)";
static char fmt_9998[] = "(/1x,a3,\002 -- Complex Hermitian Banded Tridi"
"agonal Reduction Routines\002)";
static char fmt_9997[] = "(\002 Matrix types (see DCHK23 for details):"
" \002)";
static char fmt_9996[] = "(/\002 Special Matrices:\002,/\002 1=Zero mat"
"rix. \002,\002 5=Diagonal: clustered ent"
"ries.\002,/\002 2=Identity matrix. \002,\002"
" 6=Diagonal: large, evenly spaced.\002,/\002 3=Diagonal: evenl"
"y spaced entries. \002,\002 7=Diagonal: small, evenly spaced."
"\002,/\002 4=Diagonal: geometr. spaced entries.\002)";
static char fmt_9995[] = "(\002 Dense \002,a,\002 Banded Matrices:\002,"
"/\002 8=Evenly spaced eigenvals. \002,\002 12=Small,"
" evenly spaced eigenvals.\002,/\002 9=Geometrically spaced eige"
"nvals. \002,\002 13=Matrix with random O(1) entries.\002,"
"/\002 10=Clustered eigenvalues. \002,\002 14=Matrix"
" with large random entries.\002,/\002 11=Large, evenly spaced ei"
"genvals. \002,\002 15=Matrix with small random entries.\002)";
static char fmt_9994[] = "(/\002 Tests performed: (S is Tridiag, U "
"is \002,a,\002,\002,/20x,a,\002 means \002,a,\002.\002,/\002 UPL"
"O='U':\002,/\002 1= | A - U S U\002,a1,\002 | / ( |A| n ulp ) "
" \002,\002 2= | I - U U\002,a1,\002 | / ( n ulp )\002,/\002 U"
"PLO='L':\002,/\002 3= | A - U S U\002,a1,\002 | / ( |A| n ulp )"
" \002,\002 4= | I - U U\002,a1,\002 | / ( n ulp )\002)";
static char fmt_9993[] = "(\002 N=\002,i5,\002, K=\002,i4,\002, seed="
"\002,4(i4,\002,\002),\002 type \002,i2,\002, test(\002,i2,\002)"
"=\002,g10.3)";
/* System generated locals */
integer a_dim1, a_offset, u_dim1, u_offset, i__1, i__2, i__3, i__4, i__5,
i__6, i__7;
doublereal d__1;
doublecomplex z__1;
/* Local variables */
integer i__, j, k, n, jc, jr;
doublereal ulp, cond;
integer jcol, kmax, nmax;
doublereal unfl, ovfl, temp1;
logical badnn;
integer imode, iinfo;
extern /* Subroutine */ int zhbt21_(char *, integer *, integer *, integer
*, doublecomplex *, integer *, doublereal *, doublereal *,
doublecomplex *, integer *, doublecomplex *, doublereal *,
doublereal *);
doublereal aninv, anorm;
integer nmats, jsize, nerrs, itype, jtype, ntest;
logical badnnb;
extern doublereal dlamch_(char *);
integer idumma[1];
integer ioldsd[4];
extern /* Subroutine */ int dlasum_(char *, integer *, integer *, integer
*);
integer jwidth;
extern /* Subroutine */ int zhbtrd_(char *, char *, integer *, integer *,
doublecomplex *, integer *, doublereal *, doublereal *,
doublecomplex *, integer *, doublecomplex *, integer *), zlacpy_(char *, integer *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *), zlaset_(char *,
integer *, integer *, doublecomplex *, doublecomplex *,
doublecomplex *, integer *), zlatmr_(integer *, integer *,
char *, integer *, char *, doublecomplex *, integer *,
doublereal *, doublecomplex *, char *, char *, doublecomplex *,
integer *, doublereal *, doublecomplex *, integer *, doublereal *,
char *, integer *, integer *, integer *, doublereal *,
doublereal *, char *, doublecomplex *, integer *, integer *,
integer *);
doublereal rtunfl, rtovfl, ulpinv;
extern /* Subroutine */ int zlatms_(integer *, integer *, char *, integer
*, char *, doublereal *, integer *, doublereal *, doublereal *,
integer *, integer *, char *, doublecomplex *, integer *,
doublecomplex *, integer *);
integer mtypes, ntestt;
/* Fortran I/O blocks */
static cilist io___36 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___37 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___40 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___41 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___42 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___43 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___44 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___45 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___46 = { 0, 0, 0, fmt_9993, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZCHKHB tests the reduction of a Hermitian band matrix to tridiagonal */
/* from, used with the Hermitian eigenvalue problem. */
/* ZHBTRD factors a Hermitian band matrix A as U S U* , where * means */
/* conjugate transpose, S is symmetric tridiagonal, and U is unitary. */
/* ZHBTRD can use either just the lower or just the upper triangle */
/* of A; ZCHKHB checks both cases. */
/* When ZCHKHB is called, a number of matrix "sizes" ("n's"), a number */
/* of bandwidths ("k's"), and a number of matrix "types" are */
/* specified. For each size ("n"), each bandwidth ("k") less than or */
/* equal to "n", and each type of matrix, one matrix will be generated */
/* and used to test the hermitian banded reduction routine. For each */
/* matrix, a number of tests will be performed: */
/* (1) | A - V S V* | / ( |A| n ulp ) computed by ZHBTRD with */
/* UPLO='U' */
/* (2) | I - UU* | / ( n ulp ) */
/* (3) | A - V S V* | / ( |A| n ulp ) computed by ZHBTRD with */
/* UPLO='L' */
/* (4) | I - UU* | / ( n ulp ) */
/* The "sizes" are specified by an array NN(1:NSIZES); the value of */
/* each element NN(j) specifies one size. */
/* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); */
/* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. */
/* Currently, the list of possible types is: */
/* (1) The zero matrix. */
/* (2) The identity matrix. */
/* (3) A diagonal matrix with evenly spaced entries */
/* 1, ..., ULP and random signs. */
/* (ULP = (first number larger than 1) - 1 ) */
/* (4) A diagonal matrix with geometrically spaced entries */
/* 1, ..., ULP and random signs. */
/* (5) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP */
/* and random signs. */
/* (6) Same as (4), but multiplied by SQRT( overflow threshold ) */
/* (7) Same as (4), but multiplied by SQRT( underflow threshold ) */
/* (8) A matrix of the form U* D U, where U is unitary and */
/* D has evenly spaced entries 1, ..., ULP with random signs */
/* on the diagonal. */
/* (9) A matrix of the form U* D U, where U is unitary and */
/* D has geometrically spaced entries 1, ..., ULP with random */
/* signs on the diagonal. */
/* (10) A matrix of the form U* D U, where U is unitary and */
/* D has "clustered" entries 1, ULP,..., ULP with random */
/* signs on the diagonal. */
/* (11) Same as (8), but multiplied by SQRT( overflow threshold ) */
/* (12) Same as (8), but multiplied by SQRT( underflow threshold ) */
/* (13) Hermitian matrix with random entries chosen from (-1,1). */
/* (14) Same as (13), but multiplied by SQRT( overflow threshold ) */
/* (15) Same as (13), but multiplied by SQRT( underflow threshold ) */
/* Arguments */
/* ========= */
/* NSIZES (input) INTEGER */
/* The number of sizes of matrices to use. If it is zero, */
/* ZCHKHB does nothing. It must be at least zero. */
/* NN (input) INTEGER array, dimension (NSIZES) */
/* An array containing the sizes to be used for the matrices. */
/* Zero values will be skipped. The values must be at least */
/* zero. */
/* NWDTHS (input) INTEGER */
/* The number of bandwidths to use. If it is zero, */
/* ZCHKHB does nothing. It must be at least zero. */
/* KK (input) INTEGER array, dimension (NWDTHS) */
/* An array containing the bandwidths to be used for the band */
/* matrices. The values must be at least zero. */
/* NTYPES (input) INTEGER */
/* The number of elements in DOTYPE. If it is zero, ZCHKHB */
/* does nothing. It must be at least zero. If it is MAXTYP+1 */
/* and NSIZES is 1, then an additional type, MAXTYP+1 is */
/* defined, which is to use whatever matrix is in A. This */
/* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and */
/* DOTYPE(MAXTYP+1) is .TRUE. . */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* If DOTYPE(j) is .TRUE., then for each size in NN a */
/* matrix of that size and of type j will be generated. */
/* If NTYPES is smaller than the maximum number of types */
/* defined (PARAMETER MAXTYP), then types NTYPES+1 through */
/* MAXTYP will not be generated. If NTYPES is larger */
/* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) */
/* will be ignored. */
/* ISEED (input/output) INTEGER array, dimension (4) */
/* On entry ISEED specifies the seed of the random number */
/* generator. The array elements should be between 0 and 4095; */
/* if not they will be reduced mod 4096. Also, ISEED(4) must */
/* be odd. The random number generator uses a linear */
/* congruential sequence limited to small integers, and so */
/* should produce machine independent random numbers. The */
/* values of ISEED are changed on exit, and can be used in the */
/* next call to ZCHKHB to continue the same random number */
/* sequence. */
/* THRESH (input) DOUBLE PRECISION */
/* A test will count as "failed" if the "error", computed as */
/* described above, exceeds THRESH. Note that the error */
/* is scaled to be O(1), so THRESH should be a reasonably */
/* small multiple of 1, e.g., 10 or 100. In particular, */
/* it should not depend on the precision (single vs. double) */
/* or the size of the matrix. It must be at least zero. */
/* NOUNIT (input) INTEGER */
/* The FORTRAN unit number for printing out error messages */
/* (e.g., if a routine returns IINFO not equal to 0.) */
/* A (input/workspace) DOUBLE PRECISION array, dimension */
/* (LDA, max(NN)) */
/* Used to hold the matrix whose eigenvalues are to be */
/* computed. */
/* LDA (input) INTEGER */
/* The leading dimension of A. It must be at least 2 (not 1!) */
/* and at least max( KK )+1. */
/* SD (workspace) DOUBLE PRECISION array, dimension (max(NN)) */
/* Used to hold the diagonal of the tridiagonal matrix computed */
/* by ZHBTRD. */
/* SE (workspace) DOUBLE PRECISION array, dimension (max(NN)) */
/* Used to hold the off-diagonal of the tridiagonal matrix */
/* computed by ZHBTRD. */
/* U (workspace) DOUBLE PRECISION array, dimension (LDU, max(NN)) */
/* Used to hold the unitary matrix computed by ZHBTRD. */
/* LDU (input) INTEGER */
/* The leading dimension of U. It must be at least 1 */
/* and at least max( NN ). */
/* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) */
/* LWORK (input) INTEGER */
/* The number of entries in WORK. This must be at least */
/* max( LDA+1, max(NN)+1 )*max(NN). */
/* RESULT (output) DOUBLE PRECISION array, dimension (4) */
/* The values computed by the tests described above. */
/* The values are currently limited to 1/ulp, to avoid */
/* overflow. */
/* INFO (output) INTEGER */
/* If 0, then everything ran OK. */
/* ----------------------------------------------------------------------- */
/* Some Local Variables and Parameters: */
/* ---- ----- --------- --- ---------- */
/* ZERO, ONE Real 0 and 1. */
/* MAXTYP The number of types defined. */
/* NTEST The number of tests performed, or which can */
/* be performed so far, for the current matrix. */
/* NTESTT The total number of tests performed so far. */
/* NMAX Largest value in NN. */
/* NMATS The number of matrices generated so far. */
/* NERRS The number of tests which have exceeded THRESH */
/* so far. */
/* COND, IMODE Values to be passed to the matrix generators. */
/* ANORM Norm of A; passed to matrix generators. */
/* OVFL, UNFL Overflow and underflow thresholds. */
/* ULP, ULPINV Finest relative precision and its inverse. */
/* RTOVFL, RTUNFL Square roots of the previous 2 values. */
/* The following four arrays decode JTYPE: */
/* KTYPE(j) The general type (1-10) for type "j". */
/* KMODE(j) The MODE value to be passed to the matrix */
/* generator for type "j". */
/* KMAGN(j) The order of magnitude ( O(1), */
/* O(overflow^(1/2) ), O(underflow^(1/2) ) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--nn;
--kk;
--dotype;
--iseed;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--sd;
--se;
u_dim1 = *ldu;
u_offset = 1 + u_dim1;
u -= u_offset;
--work;
--rwork;
--result;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* Check for errors */
ntestt = 0;
*info = 0;
/* Important constants */
badnn = FALSE_;
nmax = 1;
i__1 = *nsizes;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = nmax, i__3 = nn[j];
nmax = max(i__2,i__3);
if (nn[j] < 0) {
badnn = TRUE_;
}
/* L10: */
}
badnnb = FALSE_;
kmax = 0;
i__1 = *nsizes;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = kmax, i__3 = kk[j];
kmax = max(i__2,i__3);
if (kk[j] < 0) {
badnnb = TRUE_;
}
/* L20: */
}
/* Computing MIN */
i__1 = nmax - 1;
kmax = min(i__1,kmax);
/* Check for errors */
if (*nsizes < 0) {
*info = -1;
} else if (badnn) {
*info = -2;
} else if (*nwdths < 0) {
*info = -3;
} else if (badnnb) {
*info = -4;
} else if (*ntypes < 0) {
*info = -5;
} else if (*lda < kmax + 1) {
*info = -11;
} else if (*ldu < nmax) {
*info = -15;
} else if ((max(*lda,nmax) + 1) * nmax > *lwork) {
*info = -17;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZCHKHB", &i__1);
return 0;
}
/* Quick return if possible */
if (*nsizes == 0 || *ntypes == 0 || *nwdths == 0) {
return 0;
}
/* More Important constants */
unfl = dlamch_("Safe minimum");
ovfl = 1. / unfl;
ulp = dlamch_("Epsilon") * dlamch_("Base");
ulpinv = 1. / ulp;
rtunfl = sqrt(unfl);
rtovfl = sqrt(ovfl);
/* Loop over sizes, types */
nerrs = 0;
nmats = 0;
i__1 = *nsizes;
for (jsize = 1; jsize <= i__1; ++jsize) {
n = nn[jsize];
aninv = 1. / (doublereal) max(1,n);
i__2 = *nwdths;
for (jwidth = 1; jwidth <= i__2; ++jwidth) {
k = kk[jwidth];
if (k > n) {
goto L180;
}
/* Computing MAX */
/* Computing MIN */
i__5 = n - 1;
i__3 = 0, i__4 = min(i__5,k);
k = max(i__3,i__4);
if (*nsizes != 1) {
mtypes = min(15,*ntypes);
} else {
mtypes = min(16,*ntypes);
}
i__3 = mtypes;
for (jtype = 1; jtype <= i__3; ++jtype) {
if (! dotype[jtype]) {
goto L170;
}
++nmats;
ntest = 0;
for (j = 1; j <= 4; ++j) {
ioldsd[j - 1] = iseed[j];
/* L30: */
}
/* Compute "A". */
/* Store as "Upper"; later, we will copy to other format. */
/* Control parameters: */
/* KMAGN KMODE KTYPE */
/* =1 O(1) clustered 1 zero */
/* =2 large clustered 2 identity */
/* =3 small exponential (none) */
/* =4 arithmetic diagonal, (w/ eigenvalues) */
/* =5 random log hermitian, w/ eigenvalues */
/* =6 random (none) */
/* =7 random diagonal */
/* =8 random hermitian */
/* =9 positive definite */
/* =10 diagonally dominant tridiagonal */
if (mtypes > 15) {
goto L100;
}
itype = ktype[jtype - 1];
imode = kmode[jtype - 1];
/* Compute norm */
switch (kmagn[jtype - 1]) {
case 1: goto L40;
case 2: goto L50;
case 3: goto L60;
}
L40:
anorm = 1.;
goto L70;
L50:
anorm = rtovfl * ulp * aninv;
goto L70;
L60:
anorm = rtunfl * n * ulpinv;
goto L70;
L70:
zlaset_("Full", lda, &n, &c_b1, &c_b1, &a[a_offset], lda);
iinfo = 0;
if (jtype <= 15) {
cond = ulpinv;
} else {
cond = ulpinv * aninv / 10.;
}
/* Special Matrices -- Identity & Jordan block */
/* Zero */
if (itype == 1) {
iinfo = 0;
} else if (itype == 2) {
/* Identity */
i__4 = n;
for (jcol = 1; jcol <= i__4; ++jcol) {
i__5 = k + 1 + jcol * a_dim1;
a[i__5].r = anorm, a[i__5].i = 0.;
/* L80: */
}
} else if (itype == 4) {
/* Diagonal Matrix, [Eigen]values Specified */
zlatms_(&n, &n, "S", &iseed[1], "H", &rwork[1], &imode, &
cond, &anorm, &c__0, &c__0, "Q", &a[k + 1 +
a_dim1], lda, &work[1], &iinfo);
} else if (itype == 5) {
/* Hermitian, eigenvalues specified */
zlatms_(&n, &n, "S", &iseed[1], "H", &rwork[1], &imode, &
cond, &anorm, &k, &k, "Q", &a[a_offset], lda, &
work[1], &iinfo);
} else if (itype == 7) {
/* Diagonal, random eigenvalues */
zlatmr_(&n, &n, "S", &iseed[1], "H", &work[1], &c__6, &
c_b32, &c_b2, "T", "N", &work[n + 1], &c__1, &
c_b32, &work[(n << 1) + 1], &c__1, &c_b32, "N",
idumma, &c__0, &c__0, &c_b42, &anorm, "Q", &a[k +
1 + a_dim1], lda, idumma, &iinfo);
} else if (itype == 8) {
/* Hermitian, random eigenvalues */
zlatmr_(&n, &n, "S", &iseed[1], "H", &work[1], &c__6, &
c_b32, &c_b2, "T", "N", &work[n + 1], &c__1, &
c_b32, &work[(n << 1) + 1], &c__1, &c_b32, "N",
idumma, &k, &k, &c_b42, &anorm, "Q", &a[a_offset],
lda, idumma, &iinfo);
} else if (itype == 9) {
/* Positive definite, eigenvalues specified. */
zlatms_(&n, &n, "S", &iseed[1], "P", &rwork[1], &imode, &
cond, &anorm, &k, &k, "Q", &a[a_offset], lda, &
work[n + 1], &iinfo);
} else if (itype == 10) {
/* Positive definite tridiagonal, eigenvalues specified. */
if (n > 1) {
k = max(1,k);
}
zlatms_(&n, &n, "S", &iseed[1], "P", &rwork[1], &imode, &
cond, &anorm, &c__1, &c__1, "Q", &a[k + a_dim1],
lda, &work[1], &iinfo);
i__4 = n;
for (i__ = 2; i__ <= i__4; ++i__) {
i__5 = k + 1 + (i__ - 1) * a_dim1;
i__6 = k + 1 + i__ * a_dim1;
z__1.r = a[i__5].r * a[i__6].r - a[i__5].i * a[i__6]
.i, z__1.i = a[i__5].r * a[i__6].i + a[i__5]
.i * a[i__6].r;
temp1 = z_abs(&a[k + i__ * a_dim1]) / sqrt(z_abs(&
z__1));
if (temp1 > .5) {
i__5 = k + i__ * a_dim1;
i__6 = k + 1 + (i__ - 1) * a_dim1;
i__7 = k + 1 + i__ * a_dim1;
z__1.r = a[i__6].r * a[i__7].r - a[i__6].i * a[
i__7].i, z__1.i = a[i__6].r * a[i__7].i +
a[i__6].i * a[i__7].r;
d__1 = sqrt(z_abs(&z__1)) * .5;
a[i__5].r = d__1, a[i__5].i = 0.;
}
/* L90: */
}
} else {
iinfo = 1;
}
if (iinfo != 0) {
io___36.ciunit = *nounit;
s_wsfe(&io___36);
do_fio(&c__1, "Generator", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
;
e_wsfe();
*info = abs(iinfo);
return 0;
}
L100:
/* Call ZHBTRD to compute S and U from upper triangle. */
i__4 = k + 1;
zlacpy_(" ", &i__4, &n, &a[a_offset], lda, &work[1], lda);
ntest = 1;
zhbtrd_("V", "U", &n, &k, &work[1], lda, &sd[1], &se[1], &u[
u_offset], ldu, &work[*lda * n + 1], &iinfo);
if (iinfo != 0) {
io___37.ciunit = *nounit;
s_wsfe(&io___37);
do_fio(&c__1, "ZHBTRD(U)", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
;
e_wsfe();
*info = abs(iinfo);
if (iinfo < 0) {
return 0;
} else {
result[1] = ulpinv;
goto L150;
}
}
/* Do tests 1 and 2 */
zhbt21_("Upper", &n, &k, &c__1, &a[a_offset], lda, &sd[1], &
se[1], &u[u_offset], ldu, &work[1], &rwork[1], &
result[1]);
/* Convert A from Upper-Triangle-Only storage to */
/* Lower-Triangle-Only storage. */
i__4 = n;
for (jc = 1; jc <= i__4; ++jc) {
/* Computing MIN */
i__6 = k, i__7 = n - jc;
i__5 = min(i__6,i__7);
for (jr = 0; jr <= i__5; ++jr) {
i__6 = jr + 1 + jc * a_dim1;
d_cnjg(&z__1, &a[k + 1 - jr + (jc + jr) * a_dim1]);
a[i__6].r = z__1.r, a[i__6].i = z__1.i;
/* L110: */
}
/* L120: */
}
i__4 = n;
for (jc = n + 1 - k; jc <= i__4; ++jc) {
/* Computing MIN */
i__5 = k, i__6 = n - jc;
i__7 = k;
for (jr = min(i__5,i__6) + 1; jr <= i__7; ++jr) {
i__5 = jr + 1 + jc * a_dim1;
a[i__5].r = 0., a[i__5].i = 0.;
/* L130: */
}
/* L140: */
}
/* Call ZHBTRD to compute S and U from lower triangle */
i__4 = k + 1;
zlacpy_(" ", &i__4, &n, &a[a_offset], lda, &work[1], lda);
ntest = 3;
zhbtrd_("V", "L", &n, &k, &work[1], lda, &sd[1], &se[1], &u[
u_offset], ldu, &work[*lda * n + 1], &iinfo);
if (iinfo != 0) {
io___40.ciunit = *nounit;
s_wsfe(&io___40);
do_fio(&c__1, "ZHBTRD(L)", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
;
e_wsfe();
*info = abs(iinfo);
if (iinfo < 0) {
return 0;
} else {
result[3] = ulpinv;
goto L150;
}
}
ntest = 4;
/* Do tests 3 and 4 */
zhbt21_("Lower", &n, &k, &c__1, &a[a_offset], lda, &sd[1], &
se[1], &u[u_offset], ldu, &work[1], &rwork[1], &
result[3]);
/* End of Loop -- Check for RESULT(j) > THRESH */
L150:
ntestt += ntest;
/* Print out tests which fail. */
i__4 = ntest;
for (jr = 1; jr <= i__4; ++jr) {
if (result[jr] >= *thresh) {
/* If this is the first test to fail, */
/* print a header to the data file. */
if (nerrs == 0) {
io___41.ciunit = *nounit;
s_wsfe(&io___41);
do_fio(&c__1, "ZHB", (ftnlen)3);
e_wsfe();
io___42.ciunit = *nounit;
s_wsfe(&io___42);
e_wsfe();
io___43.ciunit = *nounit;
s_wsfe(&io___43);
e_wsfe();
io___44.ciunit = *nounit;
s_wsfe(&io___44);
do_fio(&c__1, "Hermitian", (ftnlen)9);
e_wsfe();
io___45.ciunit = *nounit;
s_wsfe(&io___45);
do_fio(&c__1, "unitary", (ftnlen)7);
do_fio(&c__1, "*", (ftnlen)1);
do_fio(&c__1, "conjugate transpose", (ftnlen)19);
for (j = 1; j <= 4; ++j) {
do_fio(&c__1, "*", (ftnlen)1);
}
e_wsfe();
}
++nerrs;
io___46.ciunit = *nounit;
s_wsfe(&io___46);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof(
doublereal));
e_wsfe();
}
/* L160: */
}
L170:
;
}
L180:
;
}
/* L190: */
}
/* Summary */
dlasum_("ZHB", nounit, &nerrs, &ntestt);
return 0;
/* End of ZCHKHB */
} /* zchkhb_ */
/* Subroutine */ int dlalsd_(char *uplo, integer *smlsiz, integer *n, integer
*nrhs, doublereal *d__, doublereal *e, doublereal *b, integer *ldb,
doublereal *rcond, integer *rank, doublereal *work, integer *iwork,
integer *info)
{
/* System generated locals */
integer b_dim1, b_offset, i__1, i__2;
doublereal d__1;
/* Builtin functions */
double log(doublereal), d_sign(doublereal *, doublereal *);
/* Local variables */
static integer difl, difr, perm, nsub;
extern /* Subroutine */ int drot_(integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *);
static integer nlvl, sqre, bxst, c__, i__, j, k;
static doublereal r__;
static integer s, u;
extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *);
static integer z__;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *);
static integer poles, sizei, nsize, nwork, icmpq1, icmpq2;
static doublereal cs;
extern doublereal dlamch_(char *);
extern /* Subroutine */ int dlasda_(integer *, integer *, integer *,
integer *, doublereal *, doublereal *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *,
doublereal *, integer *, integer *, integer *, integer *,
doublereal *, doublereal *, doublereal *, doublereal *, integer *,
integer *);
static integer bx;
extern /* Subroutine */ int dlalsa_(integer *, integer *, integer *,
integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *, doublereal *, doublereal *, integer *, integer *,
integer *, integer *, doublereal *, doublereal *, doublereal *,
doublereal *, integer *, integer *);
static doublereal sn;
extern /* Subroutine */ int dlascl_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *);
extern integer idamax_(integer *, doublereal *, integer *);
static integer st;
extern /* Subroutine */ int dlasdq_(char *, integer *, integer *, integer
*, integer *, integer *, doublereal *, doublereal *, doublereal *,
integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *);
static integer vt;
extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *),
dlartg_(doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *), dlaset_(char *, integer *, integer *, doublereal *,
doublereal *, doublereal *, integer *), xerbla_(char *,
integer *);
static integer givcol;
extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *);
extern /* Subroutine */ int dlasrt_(char *, integer *, doublereal *,
integer *);
static doublereal orgnrm;
static integer givnum, givptr, nm1, smlszp, st1;
static doublereal eps;
static integer iwk;
static doublereal tol;
#define b_ref(a_1,a_2) b[(a_2)*b_dim1 + a_1]
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
October 31, 1999
Purpose
=======
DLALSD uses the singular value decomposition of A to solve the least
squares problem of finding X to minimize the Euclidean norm of each
column of A*X-B, where A is N-by-N upper bidiagonal, and X and B
are N-by-NRHS. The solution X overwrites B.
The singular values of A smaller than RCOND times the largest
singular value are treated as zero in solving the least squares
problem; in this case a minimum norm solution is returned.
The actual singular values are returned in D in ascending order.
This code 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 XMP, Cray YMP, Cray C 90, or Cray 2.
It could conceivably fail on hexadecimal or decimal machines
without guard digits, but we know of none.
Arguments
=========
UPLO (input) CHARACTER*1
= 'U': D and E define an upper bidiagonal matrix.
= 'L': D and E define a lower bidiagonal matrix.
SMLSIZ (input) INTEGER
The maximum size of the subproblems at the bottom of the
computation tree.
N (input) INTEGER
The dimension of the bidiagonal matrix. N >= 0.
NRHS (input) INTEGER
The number of columns of B. NRHS must be at least 1.
D (input/output) DOUBLE PRECISION array, dimension (N)
On entry D contains the main diagonal of the bidiagonal
matrix. On exit, if INFO = 0, D contains its singular values.
E (input) DOUBLE PRECISION array, dimension (N-1)
Contains the super-diagonal entries of the bidiagonal matrix.
On exit, E has been destroyed.
B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
On input, B contains the right hand sides of the least
squares problem. On output, B contains the solution X.
LDB (input) INTEGER
The leading dimension of B in the calling subprogram.
LDB must be at least max(1,N).
RCOND (input) DOUBLE PRECISION
The singular values of A less than or equal to RCOND times
the largest singular value are treated as zero in solving
the least squares problem. If RCOND is negative,
machine precision is used instead.
For example, if diag(S)*X=B were the least squares problem,
where diag(S) is a diagonal matrix of singular values, the
solution would be X(i) = B(i) / S(i) if S(i) is greater than
RCOND*max(S), and X(i) = 0 if S(i) is less than or equal to
RCOND*max(S).
RANK (output) INTEGER
The number of singular values of A greater than RCOND times
the largest singular value.
WORK (workspace) DOUBLE PRECISION array, dimension at least
(9*N + 2*N*SMLSIZ + 8*N*NLVL + N*NRHS + (SMLSIZ+1)**2),
where NLVL = max(0, INT(log_2 (N/(SMLSIZ+1))) + 1).
IWORK (workspace) INTEGER array, dimension at least
(3*N*NLVL + 11*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 singular value while
working on the submatrix lying in rows and columns
INFO/(N+1) through MOD(INFO,N+1).
Further Details
===============
Based on contributions by
Ming Gu and Ren-Cang Li, Computer Science Division, University of
California at Berkeley, USA
Osni Marques, LBNL/NERSC, USA
=====================================================================
Test the input parameters.
Parameter adjustments */
--d__;
--e;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
--work;
--iwork;
/* Function Body */
*info = 0;
if (*n < 0) {
*info = -3;
} else if (*nrhs < 1) {
*info = -4;
} else if (*ldb < 1 || *ldb < *n) {
*info = -8;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DLALSD", &i__1);
return 0;
}
eps = dlamch_("Epsilon");
/* Set up the tolerance. */
if (*rcond <= 0. || *rcond >= 1.) {
*rcond = eps;
}
*rank = 0;
/* Quick return if possible. */
if (*n == 0) {
return 0;
} else if (*n == 1) {
if (d__[1] == 0.) {
dlaset_("A", &c__1, nrhs, &c_b6, &c_b6, &b[b_offset], ldb);
} else {
*rank = 1;
dlascl_("G", &c__0, &c__0, &d__[1], &c_b11, &c__1, nrhs, &b[
b_offset], ldb, info);
d__[1] = abs(d__[1]);
}
return 0;
}
/* Rotate the matrix if it is lower bidiagonal. */
if (*(unsigned char *)uplo == 'L') {
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
dlartg_(&d__[i__], &e[i__], &cs, &sn, &r__);
d__[i__] = r__;
e[i__] = sn * d__[i__ + 1];
d__[i__ + 1] = cs * d__[i__ + 1];
if (*nrhs == 1) {
drot_(&c__1, &b_ref(i__, 1), &c__1, &b_ref(i__ + 1, 1), &c__1,
&cs, &sn);
} else {
work[(i__ << 1) - 1] = cs;
work[i__ * 2] = sn;
}
/* L10: */
}
if (*nrhs > 1) {
i__1 = *nrhs;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = *n - 1;
for (j = 1; j <= i__2; ++j) {
cs = work[(j << 1) - 1];
sn = work[j * 2];
drot_(&c__1, &b_ref(j, i__), &c__1, &b_ref(j + 1, i__), &
c__1, &cs, &sn);
/* L20: */
}
/* L30: */
}
}
}
/* Scale. */
nm1 = *n - 1;
orgnrm = dlanst_("M", n, &d__[1], &e[1]);
if (orgnrm == 0.) {
dlaset_("A", n, nrhs, &c_b6, &c_b6, &b[b_offset], ldb);
return 0;
}
dlascl_("G", &c__0, &c__0, &orgnrm, &c_b11, n, &c__1, &d__[1], n, info);
dlascl_("G", &c__0, &c__0, &orgnrm, &c_b11, &nm1, &c__1, &e[1], &nm1,
info);
/* If N is smaller than the minimum divide size SMLSIZ, then solve
the problem with another solver. */
if (*n <= *smlsiz) {
nwork = *n * *n + 1;
dlaset_("A", n, n, &c_b6, &c_b11, &work[1], n);
dlasdq_("U", &c__0, n, n, &c__0, nrhs, &d__[1], &e[1], &work[1], n, &
work[1], n, &b[b_offset], ldb, &work[nwork], info);
if (*info != 0) {
return 0;
}
tol = *rcond * (d__1 = d__[idamax_(n, &d__[1], &c__1)], abs(d__1));
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (d__[i__] <= tol) {
dlaset_("A", &c__1, nrhs, &c_b6, &c_b6, &b_ref(i__, 1), ldb);
} else {
dlascl_("G", &c__0, &c__0, &d__[i__], &c_b11, &c__1, nrhs, &
b_ref(i__, 1), ldb, info);
++(*rank);
}
/* L40: */
}
dgemm_("T", "N", n, nrhs, n, &c_b11, &work[1], n, &b[b_offset], ldb, &
c_b6, &work[nwork], n);
dlacpy_("A", n, nrhs, &work[nwork], n, &b[b_offset], ldb);
/* Unscale. */
dlascl_("G", &c__0, &c__0, &c_b11, &orgnrm, n, &c__1, &d__[1], n,
info);
dlasrt_("D", n, &d__[1], info);
dlascl_("G", &c__0, &c__0, &orgnrm, &c_b11, n, nrhs, &b[b_offset],
ldb, info);
return 0;
}
/* Book-keeping and setting up some constants. */
nlvl = (integer) (log((doublereal) (*n) / (doublereal) (*smlsiz + 1)) /
log(2.)) + 1;
smlszp = *smlsiz + 1;
u = 1;
vt = *smlsiz * *n + 1;
difl = vt + smlszp * *n;
difr = difl + nlvl * *n;
z__ = difr + (nlvl * *n << 1);
c__ = z__ + nlvl * *n;
s = c__ + *n;
poles = s + *n;
givnum = poles + (nlvl << 1) * *n;
bx = givnum + (nlvl << 1) * *n;
nwork = bx + *n * *nrhs;
sizei = *n + 1;
k = sizei + *n;
givptr = k + *n;
perm = givptr + *n;
givcol = perm + nlvl * *n;
iwk = givcol + (nlvl * *n << 1);
st = 1;
sqre = 0;
icmpq1 = 1;
icmpq2 = 0;
nsub = 0;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if ((d__1 = d__[i__], abs(d__1)) < eps) {
d__[i__] = d_sign(&eps, &d__[i__]);
}
/* L50: */
}
i__1 = nm1;
for (i__ = 1; i__ <= i__1; ++i__) {
if ((d__1 = e[i__], abs(d__1)) < eps || i__ == nm1) {
++nsub;
iwork[nsub] = st;
/* Subproblem found. First determine its size and then
apply divide and conquer on it. */
if (i__ < nm1) {
/* A subproblem with E(I) small for I < NM1. */
nsize = i__ - st + 1;
iwork[sizei + nsub - 1] = nsize;
} else if ((d__1 = e[i__], abs(d__1)) >= eps) {
/* A subproblem with E(NM1) not too small but I = NM1. */
nsize = *n - st + 1;
iwork[sizei + nsub - 1] = nsize;
} else {
/* A subproblem with E(NM1) small. This implies an
1-by-1 subproblem at D(N), which is not solved
explicitly. */
nsize = i__ - st + 1;
iwork[sizei + nsub - 1] = nsize;
++nsub;
iwork[nsub] = *n;
iwork[sizei + nsub - 1] = 1;
dcopy_(nrhs, &b_ref(*n, 1), ldb, &work[bx + nm1], n);
}
st1 = st - 1;
if (nsize == 1) {
/* This is a 1-by-1 subproblem and is not solved
explicitly. */
dcopy_(nrhs, &b_ref(st, 1), ldb, &work[bx + st1], n);
} else if (nsize <= *smlsiz) {
/* This is a small subproblem and is solved by DLASDQ. */
dlaset_("A", &nsize, &nsize, &c_b6, &c_b11, &work[vt + st1],
n);
dlasdq_("U", &c__0, &nsize, &nsize, &c__0, nrhs, &d__[st], &e[
st], &work[vt + st1], n, &work[nwork], n, &b_ref(st,
1), ldb, &work[nwork], info);
if (*info != 0) {
return 0;
}
dlacpy_("A", &nsize, nrhs, &b_ref(st, 1), ldb, &work[bx + st1]
, n);
} else {
/* A large problem. Solve it using divide and conquer. */
dlasda_(&icmpq1, smlsiz, &nsize, &sqre, &d__[st], &e[st], &
work[u + st1], n, &work[vt + st1], &iwork[k + st1], &
work[difl + st1], &work[difr + st1], &work[z__ + st1],
&work[poles + st1], &iwork[givptr + st1], &iwork[
givcol + st1], n, &iwork[perm + st1], &work[givnum +
st1], &work[c__ + st1], &work[s + st1], &work[nwork],
&iwork[iwk], info);
if (*info != 0) {
return 0;
}
bxst = bx + st1;
dlalsa_(&icmpq2, smlsiz, &nsize, nrhs, &b_ref(st, 1), ldb, &
work[bxst], n, &work[u + st1], n, &work[vt + st1], &
iwork[k + st1], &work[difl + st1], &work[difr + st1],
&work[z__ + st1], &work[poles + st1], &iwork[givptr +
st1], &iwork[givcol + st1], n, &iwork[perm + st1], &
work[givnum + st1], &work[c__ + st1], &work[s + st1],
&work[nwork], &iwork[iwk], info);
if (*info != 0) {
return 0;
}
}
st = i__ + 1;
}
/* L60: */
}
/* Apply the singular values and treat the tiny ones as zero. */
tol = *rcond * (d__1 = d__[idamax_(n, &d__[1], &c__1)], abs(d__1));
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Some of the elements in D can be negative because 1-by-1
subproblems were not solved explicitly. */
if ((d__1 = d__[i__], abs(d__1)) <= tol) {
dlaset_("A", &c__1, nrhs, &c_b6, &c_b6, &work[bx + i__ - 1], n);
} else {
++(*rank);
dlascl_("G", &c__0, &c__0, &d__[i__], &c_b11, &c__1, nrhs, &work[
bx + i__ - 1], n, info);
}
d__[i__] = (d__1 = d__[i__], abs(d__1));
/* L70: */
}
/* Now apply back the right singular vectors. */
icmpq2 = 1;
i__1 = nsub;
for (i__ = 1; i__ <= i__1; ++i__) {
st = iwork[i__];
st1 = st - 1;
nsize = iwork[sizei + i__ - 1];
bxst = bx + st1;
if (nsize == 1) {
dcopy_(nrhs, &work[bxst], n, &b_ref(st, 1), ldb);
} else if (nsize <= *smlsiz) {
dgemm_("T", "N", &nsize, nrhs, &nsize, &c_b11, &work[vt + st1], n,
&work[bxst], n, &c_b6, &b_ref(st, 1), ldb);
} else {
dlalsa_(&icmpq2, smlsiz, &nsize, nrhs, &work[bxst], n, &b_ref(st,
1), ldb, &work[u + st1], n, &work[vt + st1], &iwork[k +
st1], &work[difl + st1], &work[difr + st1], &work[z__ +
st1], &work[poles + st1], &iwork[givptr + st1], &iwork[
givcol + st1], n, &iwork[perm + st1], &work[givnum + st1],
&work[c__ + st1], &work[s + st1], &work[nwork], &iwork[
iwk], info);
if (*info != 0) {
return 0;
}
}
/* L80: */
}
/* Unscale and sort the singular values. */
dlascl_("G", &c__0, &c__0, &c_b11, &orgnrm, n, &c__1, &d__[1], n, info);
dlasrt_("D", n, &d__[1], info);
dlascl_("G", &c__0, &c__0, &orgnrm, &c_b11, n, nrhs, &b[b_offset], ldb,
info);
return 0;
/* End of DLALSD */
} /* dlalsd_ */
/* Subroutine */ int zchkbl_(integer *nin, integer *nout)
{
/* Format strings */
static char fmt_9999[] = "(1x,\002.. test output of ZGEBAL .. \002)";
static char fmt_9998[] = "(1x,\002value of largest test error "
" = \002,d12.3)";
static char fmt_9997[] = "(1x,\002example number where info is not zero "
" = \002,i4)";
static char fmt_9996[] = "(1x,\002example number where ILO or IHI wrong "
" = \002,i4)";
static char fmt_9995[] = "(1x,\002example number having largest error "
" = \002,i4)";
static char fmt_9994[] = "(1x,\002number of examples where info is not 0"
" = \002,i4)";
static char fmt_9993[] = "(1x,\002total number of examples tested "
" = \002,i4)";
/* System generated locals */
integer i__1, i__2, i__3, i__4;
doublereal d__1, d__2, d__3, d__4, d__5, d__6;
doublecomplex z__1, z__2;
/* Local variables */
doublecomplex a[400] /* was [20][20] */;
integer i__, j, n;
doublecomplex ain[400] /* was [20][20] */;
integer ihi, ilo, knt, info, lmax[3];
doublereal meps, temp, rmax, vmax, scale[20];
integer ihiin, ninfo, iloin;
doublereal anorm, sfmin, dummy[1];
extern doublereal dlamch_(char *);
extern /* Subroutine */ int zgebal_(char *, integer *, doublecomplex *,
integer *, integer *, integer *, doublereal *, integer *);
doublereal scalin[20];
extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
integer *, doublereal *);
/* Fortran I/O blocks */
static cilist io___8 = { 0, 0, 0, 0, 0 };
static cilist io___11 = { 0, 0, 0, 0, 0 };
static cilist io___14 = { 0, 0, 0, 0, 0 };
static cilist io___17 = { 0, 0, 0, 0, 0 };
static cilist io___19 = { 0, 0, 0, 0, 0 };
static cilist io___28 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___29 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___30 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___31 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___32 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___33 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___34 = { 0, 0, 0, fmt_9993, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZCHKBL tests ZGEBAL, a routine for balancing a general complex */
/* matrix and isolating some of its eigenvalues. */
/* Arguments */
/* ========= */
/* NIN (input) INTEGER */
/* The logical unit number for input. NIN > 0. */
/* NOUT (input) INTEGER */
/* The logical unit number for output. NOUT > 0. */
/* ====================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
lmax[0] = 0;
lmax[1] = 0;
lmax[2] = 0;
ninfo = 0;
knt = 0;
rmax = 0.;
vmax = 0.;
sfmin = dlamch_("S");
meps = dlamch_("E");
L10:
io___8.ciunit = *nin;
s_rsle(&io___8);
do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
e_rsle();
if (n == 0) {
goto L70;
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___11.ciunit = *nin;
s_rsle(&io___11);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__7, &c__1, (char *)&a[i__ + j * 20 - 21], (ftnlen)
sizeof(doublecomplex));
}
e_rsle();
/* L20: */
}
io___14.ciunit = *nin;
s_rsle(&io___14);
do_lio(&c__3, &c__1, (char *)&iloin, (ftnlen)sizeof(integer));
do_lio(&c__3, &c__1, (char *)&ihiin, (ftnlen)sizeof(integer));
e_rsle();
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___17.ciunit = *nin;
s_rsle(&io___17);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__7, &c__1, (char *)&ain[i__ + j * 20 - 21], (ftnlen)
sizeof(doublecomplex));
}
e_rsle();
/* L30: */
}
io___19.ciunit = *nin;
s_rsle(&io___19);
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
do_lio(&c__5, &c__1, (char *)&scalin[i__ - 1], (ftnlen)sizeof(
doublereal));
}
e_rsle();
anorm = zlange_("M", &n, &n, a, &c__20, dummy);
++knt;
zgebal_("B", &n, a, &c__20, &ilo, &ihi, scale, &info);
if (info != 0) {
++ninfo;
lmax[0] = knt;
}
if (ilo != iloin || ihi != ihiin) {
++ninfo;
lmax[1] = knt;
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = n;
for (j = 1; j <= i__2; ++j) {
/* Computing MAX */
i__3 = i__ + j * 20 - 21;
i__4 = i__ + j * 20 - 21;
d__5 = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[i__ + j *
20 - 21]), abs(d__2)), d__6 = (d__3 = ain[i__4].r, abs(
d__3)) + (d__4 = d_imag(&ain[i__ + j * 20 - 21]), abs(
d__4));
temp = max(d__5,d__6);
temp = max(temp,sfmin);
i__3 = i__ + j * 20 - 21;
i__4 = i__ + j * 20 - 21;
z__2.r = a[i__3].r - ain[i__4].r, z__2.i = a[i__3].i - ain[i__4]
.i;
z__1.r = z__2.r, z__1.i = z__2.i;
/* Computing MAX */
d__3 = vmax, d__4 = ((d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&
z__1), abs(d__2))) / temp;
vmax = max(d__3,d__4);
/* L40: */
}
/* L50: */
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
d__1 = scale[i__ - 1], d__2 = scalin[i__ - 1];
temp = max(d__1,d__2);
temp = max(temp,sfmin);
/* Computing MAX */
d__2 = vmax, d__3 = (d__1 = scale[i__ - 1] - scalin[i__ - 1], abs(
d__1)) / temp;
vmax = max(d__2,d__3);
/* L60: */
}
if (vmax > rmax) {
lmax[2] = knt;
rmax = vmax;
}
goto L10;
L70:
io___28.ciunit = *nout;
s_wsfe(&io___28);
e_wsfe();
io___29.ciunit = *nout;
s_wsfe(&io___29);
do_fio(&c__1, (char *)&rmax, (ftnlen)sizeof(doublereal));
e_wsfe();
io___30.ciunit = *nout;
s_wsfe(&io___30);
do_fio(&c__1, (char *)&lmax[0], (ftnlen)sizeof(integer));
e_wsfe();
io___31.ciunit = *nout;
s_wsfe(&io___31);
do_fio(&c__1, (char *)&lmax[1], (ftnlen)sizeof(integer));
e_wsfe();
io___32.ciunit = *nout;
s_wsfe(&io___32);
do_fio(&c__1, (char *)&lmax[2], (ftnlen)sizeof(integer));
e_wsfe();
io___33.ciunit = *nout;
s_wsfe(&io___33);
do_fio(&c__1, (char *)&ninfo, (ftnlen)sizeof(integer));
e_wsfe();
io___34.ciunit = *nout;
s_wsfe(&io___34);
do_fio(&c__1, (char *)&knt, (ftnlen)sizeof(integer));
e_wsfe();
return 0;
/* End of ZCHKBL */
} /* zchkbl_ */
/* Subroutine */ int dtgsen_(integer *ijob, logical *wantq, logical *wantz,
logical *select, integer *n, doublereal *a, integer *lda, doublereal *
b, integer *ldb, doublereal *alphar, doublereal *alphai, doublereal *
beta, doublereal *q, integer *ldq, doublereal *z__, integer *ldz,
integer *m, doublereal *pl, doublereal *pr, doublereal *dif,
doublereal *work, integer *lwork, integer *iwork, integer *liwork,
integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, z_dim1,
z_offset, i__1, i__2;
doublereal d__1;
/* Local variables */
integer i__, k, n1, n2, kk, ks, mn2, ijb;
doublereal eps;
integer kase;
logical pair;
integer ierr;
doublereal dsum;
logical swap;
integer isave[3];
logical wantd;
integer lwmin;
logical wantp;
logical wantd1, wantd2;
doublereal dscale, rdscal;
integer liwmin;
doublereal smlnum;
logical lquery;
/* -- LAPACK routine (version 3.2) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* January 2007 */
/* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. */
/* Purpose */
/* ======= */
/* DTGSEN reorders the generalized real Schur decomposition of a real */
/* matrix pair (A, B) (in terms of an orthonormal equivalence trans- */
/* formation Q' * (A, B) * Z), so that a selected cluster of eigenvalues */
/* appears in the leading diagonal blocks of the upper quasi-triangular */
/* matrix A and the upper triangular B. The leading columns of Q and */
/* Z form orthonormal bases of the corresponding left and right eigen- */
/* spaces (deflating subspaces). (A, B) must be in generalized real */
/* Schur canonical form (as returned by DGGES), i.e. A is block upper */
/* triangular with 1-by-1 and 2-by-2 diagonal blocks. B is upper */
/* triangular. */
/* DTGSEN also computes the generalized eigenvalues */
/* w(j) = (ALPHAR(j) + i*ALPHAI(j))/BETA(j) */
/* of the reordered matrix pair (A, B). */
/* Optionally, DTGSEN computes the estimates of reciprocal condition */
/* numbers for eigenvalues and eigenspaces. These are Difu[(A11,B11), */
/* (A22,B22)] and Difl[(A11,B11), (A22,B22)], i.e. the separation(s) */
/* between the matrix pairs (A11, B11) and (A22,B22) that correspond to */
/* the selected cluster and the eigenvalues outside the cluster, resp., */
/* and norms of "projections" onto left and right eigenspaces w.r.t. */
/* the selected cluster in the (1,1)-block. */
/* Arguments */
/* ========= */
/* IJOB (input) INTEGER */
/* Specifies whether condition numbers are required for the */
/* cluster of eigenvalues (PL and PR) or the deflating subspaces */
/* (Difu and Difl): */
/* =0: Only reorder w.r.t. SELECT. No extras. */
/* =1: Reciprocal of norms of "projections" onto left and right */
/* eigenspaces w.r.t. the selected cluster (PL and PR). */
/* =2: Upper bounds on Difu and Difl. F-norm-based estimate */
/* (DIF(1:2)). */
/* =3: Estimate of Difu and Difl. 1-norm-based estimate */
/* (DIF(1:2)). */
/* About 5 times as expensive as IJOB = 2. */
/* =4: Compute PL, PR and DIF (i.e. 0, 1 and 2 above): Economic */
/* version to get it all. */
/* =5: Compute PL, PR and DIF (i.e. 0, 1 and 3 above) */
/* WANTQ (input) LOGICAL */
/* .TRUE. : update the left transformation matrix Q; */
/* .FALSE.: do not update Q. */
/* WANTZ (input) LOGICAL */
/* .TRUE. : update the right transformation matrix Z; */
/* .FALSE.: do not update Z. */
/* SELECT (input) LOGICAL array, dimension (N) */
/* SELECT specifies the eigenvalues in the selected cluster. */
/* To select a real eigenvalue w(j), SELECT(j) must be set to */
/* w(j) and w(j+1), corresponding to a 2-by-2 diagonal block, */
/* either SELECT(j) or SELECT(j+1) or both must be set to */
/* .TRUE.; a complex conjugate pair of eigenvalues must be */
/* either both included in the cluster or both excluded. */
/* N (input) INTEGER */
/* The order of the matrices A and B. N >= 0. */
/* A (input/output) DOUBLE PRECISION array, dimension(LDA,N) */
/* On entry, the upper quasi-triangular matrix A, with (A, B) in */
/* generalized real Schur canonical form. */
/* On exit, A is overwritten by the reordered matrix A. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* B (input/output) DOUBLE PRECISION array, dimension(LDB,N) */
/* On entry, the upper triangular matrix B, with (A, B) in */
/* generalized real Schur canonical form. */
/* On exit, B is overwritten by the reordered matrix B. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* ALPHAR (output) DOUBLE PRECISION array, dimension (N) */
/* ALPHAI (output) DOUBLE PRECISION array, dimension (N) */
/* BETA (output) DOUBLE PRECISION array, dimension (N) */
/* be the generalized eigenvalues. ALPHAR(j) + ALPHAI(j)*i */
/* form (S,T) that would result if the 2-by-2 diagonal blocks of */
/* the real generalized Schur form of (A,B) were further reduced */
/* to triangular form using complex unitary transformations. */
/* If ALPHAI(j) is zero, then the j-th eigenvalue is real; if */
/* positive, then the j-th and (j+1)-st eigenvalues are a */
/* complex conjugate pair, with ALPHAI(j+1) negative. */
/* Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) */
/* On entry, if WANTQ = .TRUE., Q is an N-by-N matrix. */
/* On exit, Q has been postmultiplied by the left orthogonal */
/* transformation matrix which reorder (A, B); The leading M */
/* columns of Q form orthonormal bases for the specified pair of */
/* left eigenspaces (deflating subspaces). */
/* If WANTQ = .FALSE., Q is not referenced. */
/* LDQ (input) INTEGER */
/* The leading dimension of the array Q. LDQ >= 1; */
/* and if WANTQ = .TRUE., LDQ >= N. */
/* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) */
/* On entry, if WANTZ = .TRUE., Z is an N-by-N matrix. */
/* On exit, Z has been postmultiplied by the left orthogonal */
/* transformation matrix which reorder (A, B); The leading M */
/* columns of Z form orthonormal bases for the specified pair of */
/* left eigenspaces (deflating subspaces). */
/* If WANTZ = .FALSE., Z is not referenced. */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. LDZ >= 1; */
/* If WANTZ = .TRUE., LDZ >= N. */
/* M (output) INTEGER */
/* The dimension of the specified pair of left and right eigen- */
/* spaces (deflating subspaces). 0 <= M <= N. */
/* PL (output) DOUBLE PRECISION */
/* PR (output) DOUBLE PRECISION */
/* If IJOB = 1, 4 or 5, PL, PR are lower bounds on the */
/* reciprocal of the norm of "projections" onto left and right */
/* eigenspaces with respect to the selected cluster. */
/* 0 < PL, PR <= 1. */
/* If M = 0 or M = N, PL = PR = 1. */
/* If IJOB = 0, 2 or 3, PL and PR are not referenced. */
/* DIF (output) DOUBLE PRECISION array, dimension (2). */
/* If IJOB >= 2, DIF(1:2) store the estimates of Difu and Difl. */
/* If IJOB = 2 or 4, DIF(1:2) are F-norm-based upper bounds on */
/* Difu and Difl. If IJOB = 3 or 5, DIF(1:2) are 1-norm-based */
/* estimates of Difu and Difl. */
/* If M = 0 or N, DIF(1:2) = F-norm([A, B]). */
/* If IJOB = 0 or 1, DIF is not referenced. */
/* WORK (workspace/output) DOUBLE PRECISION array, */
/* dimension (MAX(1,LWORK)) */
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. LWORK >= 4*N+16. */
/* If IJOB = 1, 2 or 4, LWORK >= MAX(4*N+16, 2*M*(N-M)). */
/* If IJOB = 3 or 5, LWORK >= MAX(4*N+16, 4*M*(N-M)). */
/* 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. */
/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */
/* IF IJOB = 0, IWORK is not referenced. Otherwise, */
/* on exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */
/* LIWORK (input) INTEGER */
/* The dimension of the array IWORK. LIWORK >= 1. */
/* If IJOB = 1, 2 or 4, LIWORK >= N+6. */
/* If IJOB = 3 or 5, LIWORK >= MAX(2*M*(N-M), N+6). */
/* If LIWORK = -1, then a workspace query is assumed; the */
/* routine only calculates the optimal size of the IWORK array, */
/* returns this value as the first entry of the IWORK array, and */
/* no error message related to LIWORK is issued by XERBLA. */
/* INFO (output) INTEGER */
/* =0: Successful exit. */
/* <0: If INFO = -i, the i-th argument had an illegal value. */
/* =1: Reordering of (A, B) failed because the transformed */
/* matrix pair (A, B) would be too far from generalized */
/* Schur form; the problem is very ill-conditioned. */
/* (A, B) may have been partially reordered. */
/* If requested, 0 is returned in DIF(*), PL and PR. */
/* Further Details */
/* =============== */
/* DTGSEN first collects the selected eigenvalues by computing */
/* orthogonal U and W that move them to the top left corner of (A, B). */
/* In other words, the selected eigenvalues are the eigenvalues of */
/* (A11, B11) in: */
/* U'*(A, B)*W = (A11 A12) (B11 B12) n1 */
/* ( 0 A22),( 0 B22) n2 */
/* n1 n2 n1 n2 */
/* where N = n1+n2 and U' means the transpose of U. The first n1 columns */
/* of U and W span the specified pair of left and right eigenspaces */
/* (deflating subspaces) of (A, B). */
/* If (A, B) has been obtained from the generalized real Schur */
/* decomposition of a matrix pair (C, D) = Q*(A, B)*Z', then the */
/* reordered generalized real Schur form of (C, D) is given by */
/* (C, D) = (Q*U)*(U'*(A, B)*W)*(Z*W)', */
/* and the first n1 columns of Q*U and Z*W span the corresponding */
/* deflating subspaces of (C, D) (Q and Z store Q*U and Z*W, resp.). */
/* Note that if the selected eigenvalue is sufficiently ill-conditioned, */
/* then its value may differ significantly from its value before */
/* reordering. */
/* The reciprocal condition numbers of the left and right eigenspaces */
/* spanned by the first n1 columns of U and W (or Q*U and Z*W) may */
/* be returned in DIF(1:2), corresponding to Difu and Difl, resp. */
/* The Difu and Difl are defined as: */
/* Difu[(A11, B11), (A22, B22)] = sigma-min( Zu ) */
/* and */
/* Difl[(A11, B11), (A22, B22)] = Difu[(A22, B22), (A11, B11)], */
/* where sigma-min(Zu) is the smallest singular value of the */
/* (2*n1*n2)-by-(2*n1*n2) matrix */
/* Zu = [ kron(In2, A11) -kron(A22', In1) ] */
/* [ kron(In2, B11) -kron(B22', In1) ]. */
/* Here, Inx is the identity matrix of size nx and A22' is the */
/* transpose of A22. kron(X, Y) is the Kronecker product between */
/* the matrices X and Y. */
/* When DIF(2) is small, small changes in (A, B) can cause large changes */
/* in the deflating subspace. An approximate (asymptotic) bound on the */
/* maximum angular error in the computed deflating subspaces is */
/* EPS * norm((A, B)) / DIF(2), */
/* where EPS is the machine precision. */
/* The reciprocal norm of the projectors on the left and right */
/* eigenspaces associated with (A11, B11) may be returned in PL and PR. */
/* They are computed as follows. First we compute L and R so that */
/* P*(A, B)*Q is block diagonal, where */
/* P = ( I -L ) n1 Q = ( I R ) n1 */
/* ( 0 I ) n2 and ( 0 I ) n2 */
/* n1 n2 n1 n2 */
/* and (L, R) is the solution to the generalized Sylvester equation */
/* A11*R - L*A22 = -A12 */
/* B11*R - L*B22 = -B12 */
/* Then PL = (F-norm(L)**2+1)**(-1/2) and PR = (F-norm(R)**2+1)**(-1/2). */
/* An approximate (asymptotic) bound on the average absolute error of */
/* the selected eigenvalues is */
/* EPS * norm((A, B)) / PL. */
/* There are also global error bounds which valid for perturbations up */
/* to a certain restriction: A lower bound (x) on the smallest */
/* F-norm(E,F) for which an eigenvalue of (A11, B11) may move and */
/* coalesce with an eigenvalue of (A22, B22) under perturbation (E,F), */
/* (i.e. (A + E, B + F), is */
/* x = min(Difu,Difl)/((1/(PL*PL)+1/(PR*PR))**(1/2)+2*max(1/PL,1/PR)). */
/* An approximate bound on x can be computed from DIF(1:2), PL and PR. */
/* If y = ( F-norm(E,F) / x) <= 1, the angles between the perturbed */
/* (L', R') and unperturbed (L, R) left and right deflating subspaces */
/* associated with the selected cluster in the (1,1)-blocks can be */
/* bounded as */
/* max-angle(L, L') <= arctan( y * PL / (1 - y * (1 - PL * PL)**(1/2)) */
/* max-angle(R, R') <= arctan( y * PR / (1 - y * (1 - PR * PR)**(1/2)) */
/* See LAPACK User's Guide section 4.11 or the following references */
/* for more information. */
/* Note that if the default method for computing the Frobenius-norm- */
/* based estimate DIF is not wanted (see DLATDF), then the parameter */
/* IDIFJB (see below) should be changed from 3 to 4 (routine DLATDF */
/* (IJOB = 2 will be used)). See DTGSYL for more details. */
/* Based on contributions by */
/* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */
/* Umea University, S-901 87 Umea, Sweden. */
/* References */
/* ========== */
/* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the */
/* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in */
/* M.S. Moonen et al (eds), Linear Algebra for Large Scale and */
/* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218. */
/* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified */
/* Eigenvalues of a Regular Matrix Pair (A, B) and Condition */
/* Estimation: Theory, Algorithms and Software, */
/* Report UMINF - 94.04, Department of Computing Science, Umea */
/* University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working */
/* Note 87. To appear in Numerical Algorithms, 1996. */
/* [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software */
/* for Solving the Generalized Sylvester Equation and Estimating the */
/* Separation between Regular Matrix Pairs, Report UMINF - 93.23, */
/* Department of Computing Science, Umea University, S-901 87 Umea, */
/* Sweden, December 1993, Revised April 1994, Also as LAPACK Working */
/* Note 75. To appear in ACM Trans. on Math. Software, Vol 22, No 1, */
/* 1996. */
/* ===================================================================== */
/* Decode and test the input parameters */
/* Parameter adjustments */
--select;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--alphar;
--alphai;
--beta;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--dif;
--work;
--iwork;
/* Function Body */
*info = 0;
lquery = *lwork == -1 || *liwork == -1;
if (*ijob < 0 || *ijob > 5) {
*info = -1;
} else if (*n < 0) {
*info = -5;
} else if (*lda < max(1,*n)) {
*info = -7;
} else if (*ldb < max(1,*n)) {
*info = -9;
} else if (*ldq < 1 || *wantq && *ldq < *n) {
*info = -14;
} else if (*ldz < 1 || *wantz && *ldz < *n) {
*info = -16;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DTGSEN", &i__1);
return 0;
}
/* Get machine constants */
eps = dlamch_("P");
smlnum = dlamch_("S") / eps;
ierr = 0;
wantp = *ijob == 1 || *ijob >= 4;
wantd1 = *ijob == 2 || *ijob == 4;
wantd2 = *ijob == 3 || *ijob == 5;
wantd = wantd1 || wantd2;
/* Set M to the dimension of the specified pair of deflating */
/* subspaces. */
*m = 0;
pair = FALSE_;
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
if (pair) {
pair = FALSE_;
} else {
if (k < *n) {
if (a[k + 1 + k * a_dim1] == 0.) {
if (select[k]) {
++(*m);
}
} else {
pair = TRUE_;
if (select[k] || select[k + 1]) {
*m += 2;
}
}
} else {
if (select[*n]) {
++(*m);
}
}
}
}
if (*ijob == 1 || *ijob == 2 || *ijob == 4) {
/* Computing MAX */
i__1 = 1, i__2 = (*n << 2) + 16, i__1 = max(i__1,i__2), i__2 = (*m <<
1) * (*n - *m);
lwmin = max(i__1,i__2);
/* Computing MAX */
i__1 = 1, i__2 = *n + 6;
liwmin = max(i__1,i__2);
} else if (*ijob == 3 || *ijob == 5) {
/* Computing MAX */
i__1 = 1, i__2 = (*n << 2) + 16, i__1 = max(i__1,i__2), i__2 = (*m <<
2) * (*n - *m);
lwmin = max(i__1,i__2);
/* Computing MAX */
i__1 = 1, i__2 = (*m << 1) * (*n - *m), i__1 = max(i__1,i__2), i__2 =
*n + 6;
liwmin = max(i__1,i__2);
} else {
/* Computing MAX */
i__1 = 1, i__2 = (*n << 2) + 16;
lwmin = max(i__1,i__2);
liwmin = 1;
}
work[1] = (doublereal) lwmin;
iwork[1] = liwmin;
if (*lwork < lwmin && ! lquery) {
*info = -22;
} else if (*liwork < liwmin && ! lquery) {
*info = -24;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DTGSEN", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible. */
if (*m == *n || *m == 0) {
if (wantp) {
*pl = 1.;
*pr = 1.;
}
if (wantd) {
dscale = 0.;
dsum = 1.;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
dlassq_(n, &a[i__ * a_dim1 + 1], &c__1, &dscale, &dsum);
dlassq_(n, &b[i__ * b_dim1 + 1], &c__1, &dscale, &dsum);
}
dif[1] = dscale * sqrt(dsum);
dif[2] = dif[1];
}
goto L60;
}
/* Collect the selected blocks at the top-left corner of (A, B). */
ks = 0;
pair = FALSE_;
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
if (pair) {
pair = FALSE_;
} else {
swap = select[k];
if (k < *n) {
if (a[k + 1 + k * a_dim1] != 0.) {
pair = TRUE_;
swap = swap || select[k + 1];
}
}
if (swap) {
++ks;
/* Swap the K-th block to position KS. */
/* Perform the reordering of diagonal blocks in (A, B) */
/* by orthogonal transformation matrices and update */
/* Q and Z accordingly (if requested): */
kk = k;
if (k != ks) {
dtgexc_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset],
ldb, &q[q_offset], ldq, &z__[z_offset], ldz, &kk,
&ks, &work[1], lwork, &ierr);
}
if (ierr > 0) {
/* Swap is rejected: exit. */
*info = 1;
if (wantp) {
*pl = 0.;
*pr = 0.;
}
if (wantd) {
dif[1] = 0.;
dif[2] = 0.;
}
goto L60;
}
if (pair) {
++ks;
}
}
}
}
if (wantp) {
/* Solve generalized Sylvester equation for R and L */
/* and compute PL and PR. */
n1 = *m;
n2 = *n - *m;
i__ = n1 + 1;
ijb = 0;
dlacpy_("Full", &n1, &n2, &a[i__ * a_dim1 + 1], lda, &work[1], &n1);
dlacpy_("Full", &n1, &n2, &b[i__ * b_dim1 + 1], ldb, &work[n1 * n2 +
1], &n1);
i__1 = *lwork - (n1 << 1) * n2;
dtgsyl_("N", &ijb, &n1, &n2, &a[a_offset], lda, &a[i__ + i__ * a_dim1]
, lda, &work[1], &n1, &b[b_offset], ldb, &b[i__ + i__ *
b_dim1], ldb, &work[n1 * n2 + 1], &n1, &dscale, &dif[1], &
work[(n1 * n2 << 1) + 1], &i__1, &iwork[1], &ierr);
/* Estimate the reciprocal of norms of "projections" onto left */
/* and right eigenspaces. */
rdscal = 0.;
dsum = 1.;
i__1 = n1 * n2;
dlassq_(&i__1, &work[1], &c__1, &rdscal, &dsum);
*pl = rdscal * sqrt(dsum);
if (*pl == 0.) {
*pl = 1.;
} else {
*pl = dscale / (sqrt(dscale * dscale / *pl + *pl) * sqrt(*pl));
}
rdscal = 0.;
dsum = 1.;
i__1 = n1 * n2;
dlassq_(&i__1, &work[n1 * n2 + 1], &c__1, &rdscal, &dsum);
*pr = rdscal * sqrt(dsum);
if (*pr == 0.) {
*pr = 1.;
} else {
*pr = dscale / (sqrt(dscale * dscale / *pr + *pr) * sqrt(*pr));
}
}
if (wantd) {
/* Compute estimates of Difu and Difl. */
if (wantd1) {
n1 = *m;
n2 = *n - *m;
i__ = n1 + 1;
ijb = 3;
/* Frobenius norm-based Difu-estimate. */
i__1 = *lwork - (n1 << 1) * n2;
dtgsyl_("N", &ijb, &n1, &n2, &a[a_offset], lda, &a[i__ + i__ *
a_dim1], lda, &work[1], &n1, &b[b_offset], ldb, &b[i__ +
i__ * b_dim1], ldb, &work[n1 * n2 + 1], &n1, &dscale, &
dif[1], &work[(n1 << 1) * n2 + 1], &i__1, &iwork[1], &
ierr);
/* Frobenius norm-based Difl-estimate. */
i__1 = *lwork - (n1 << 1) * n2;
dtgsyl_("N", &ijb, &n2, &n1, &a[i__ + i__ * a_dim1], lda, &a[
a_offset], lda, &work[1], &n2, &b[i__ + i__ * b_dim1],
ldb, &b[b_offset], ldb, &work[n1 * n2 + 1], &n2, &dscale,
&dif[2], &work[(n1 << 1) * n2 + 1], &i__1, &iwork[1], &
ierr);
} else {
/* Compute 1-norm-based estimates of Difu and Difl using */
/* reversed communication with DLACN2. In each step a */
/* generalized Sylvester equation or a transposed variant */
/* is solved. */
kase = 0;
n1 = *m;
n2 = *n - *m;
i__ = n1 + 1;
ijb = 0;
mn2 = (n1 << 1) * n2;
/* 1-norm-based estimate of Difu. */
L40:
dlacn2_(&mn2, &work[mn2 + 1], &work[1], &iwork[1], &dif[1], &kase,
isave);
if (kase != 0) {
if (kase == 1) {
/* Solve generalized Sylvester equation. */
i__1 = *lwork - (n1 << 1) * n2;
dtgsyl_("N", &ijb, &n1, &n2, &a[a_offset], lda, &a[i__ +
i__ * a_dim1], lda, &work[1], &n1, &b[b_offset],
ldb, &b[i__ + i__ * b_dim1], ldb, &work[n1 * n2 +
1], &n1, &dscale, &dif[1], &work[(n1 << 1) * n2 +
1], &i__1, &iwork[1], &ierr);
} else {
/* Solve the transposed variant. */
i__1 = *lwork - (n1 << 1) * n2;
dtgsyl_("T", &ijb, &n1, &n2, &a[a_offset], lda, &a[i__ +
i__ * a_dim1], lda, &work[1], &n1, &b[b_offset],
ldb, &b[i__ + i__ * b_dim1], ldb, &work[n1 * n2 +
1], &n1, &dscale, &dif[1], &work[(n1 << 1) * n2 +
1], &i__1, &iwork[1], &ierr);
}
goto L40;
}
dif[1] = dscale / dif[1];
/* 1-norm-based estimate of Difl. */
L50:
dlacn2_(&mn2, &work[mn2 + 1], &work[1], &iwork[1], &dif[2], &kase,
isave);
if (kase != 0) {
if (kase == 1) {
/* Solve generalized Sylvester equation. */
i__1 = *lwork - (n1 << 1) * n2;
dtgsyl_("N", &ijb, &n2, &n1, &a[i__ + i__ * a_dim1], lda,
&a[a_offset], lda, &work[1], &n2, &b[i__ + i__ *
b_dim1], ldb, &b[b_offset], ldb, &work[n1 * n2 +
1], &n2, &dscale, &dif[2], &work[(n1 << 1) * n2 +
1], &i__1, &iwork[1], &ierr);
} else {
/* Solve the transposed variant. */
i__1 = *lwork - (n1 << 1) * n2;
dtgsyl_("T", &ijb, &n2, &n1, &a[i__ + i__ * a_dim1], lda,
&a[a_offset], lda, &work[1], &n2, &b[i__ + i__ *
b_dim1], ldb, &b[b_offset], ldb, &work[n1 * n2 +
1], &n2, &dscale, &dif[2], &work[(n1 << 1) * n2 +
1], &i__1, &iwork[1], &ierr);
}
goto L50;
}
dif[2] = dscale / dif[2];
}
}
L60:
/* Compute generalized eigenvalues of reordered pair (A, B) and */
/* normalize the generalized Schur form. */
pair = FALSE_;
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
if (pair) {
pair = FALSE_;
} else {
if (k < *n) {
if (a[k + 1 + k * a_dim1] != 0.) {
pair = TRUE_;
}
}
if (pair) {
/* Compute the eigenvalue(s) at position K. */
work[1] = a[k + k * a_dim1];
work[2] = a[k + 1 + k * a_dim1];
work[3] = a[k + (k + 1) * a_dim1];
work[4] = a[k + 1 + (k + 1) * a_dim1];
work[5] = b[k + k * b_dim1];
work[6] = b[k + 1 + k * b_dim1];
work[7] = b[k + (k + 1) * b_dim1];
work[8] = b[k + 1 + (k + 1) * b_dim1];
d__1 = smlnum * eps;
dlag2_(&work[1], &c__2, &work[5], &c__2, &d__1, &beta[k], &
beta[k + 1], &alphar[k], &alphar[k + 1], &alphai[k]);
alphai[k + 1] = -alphai[k];
} else {
if (d_sign(&c_b28, &b[k + k * b_dim1]) < 0.) {
/* If B(K,K) is negative, make it positive */
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
a[k + i__ * a_dim1] = -a[k + i__ * a_dim1];
b[k + i__ * b_dim1] = -b[k + i__ * b_dim1];
if (*wantq) {
q[i__ + k * q_dim1] = -q[i__ + k * q_dim1];
}
}
}
alphar[k] = a[k + k * a_dim1];
alphai[k] = 0.;
beta[k] = b[k + k * b_dim1];
}
}
}
work[1] = (doublereal) lwmin;
iwork[1] = liwmin;
return 0;
/* End of DTGSEN */
} /* dtgsen_ */
/* Subroutine */ int zptt05_(integer *n, integer *nrhs, doublereal *d__,
doublecomplex *e, doublecomplex *b, integer *ldb, doublecomplex *x,
integer *ldx, doublecomplex *xact, integer *ldxact, doublereal *ferr,
doublereal *berr, doublereal *reslts)
{
/* System generated locals */
integer b_dim1, b_offset, x_dim1, x_offset, xact_dim1, xact_offset, i__1,
i__2, i__3, i__4, i__5, i__6, i__7, i__8, i__9;
doublereal d__1, d__2, d__3, d__4, d__5, d__6, d__7, d__8, d__9, d__10,
d__11, d__12;
doublecomplex z__1, z__2;
/* Builtin functions */
double d_imag(doublecomplex *);
/* Local variables */
integer i__, j, k, nz;
doublereal eps, tmp, diff, axbi;
integer imax;
doublereal unfl, ovfl, xnorm;
extern doublereal dlamch_(char *);
doublereal errbnd;
extern integer izamax_(integer *, doublecomplex *, integer *);
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZPTT05 tests the error bounds from iterative refinement for the */
/* computed solution to a system of equations A*X = B, where A is a */
/* Hermitian tridiagonal matrix of order n. */
/* RESLTS(1) = test of the error bound */
/* = norm(X - XACT) / ( norm(X) * FERR ) */
/* A large value is returned if this ratio is not less than one. */
/* RESLTS(2) = residual from the iterative refinement routine */
/* = the maximum of BERR / ( NZ*EPS + (*) ), where */
/* (*) = NZ*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i ) */
/* and NZ = max. number of nonzeros in any row of A, plus 1 */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The number of rows of the matrices X, B, and XACT, and the */
/* order of the matrix A. N >= 0. */
/* NRHS (input) INTEGER */
/* The number of columns of the matrices X, B, and XACT. */
/* NRHS >= 0. */
/* D (input) DOUBLE PRECISION array, dimension (N) */
/* The n diagonal elements of the tridiagonal matrix A. */
/* E (input) COMPLEX*16 array, dimension (N-1) */
/* The (n-1) subdiagonal elements of the tridiagonal matrix A. */
/* B (input) COMPLEX*16 array, dimension (LDB,NRHS) */
/* The right hand side vectors for the system of linear */
/* equations. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* X (input) COMPLEX*16 array, dimension (LDX,NRHS) */
/* The computed solution vectors. Each vector is stored as a */
/* column of the matrix X. */
/* LDX (input) INTEGER */
/* The leading dimension of the array X. LDX >= max(1,N). */
/* XACT (input) COMPLEX*16 array, dimension (LDX,NRHS) */
/* The exact solution vectors. Each vector is stored as a */
/* column of the matrix XACT. */
/* LDXACT (input) INTEGER */
/* The leading dimension of the array XACT. LDXACT >= max(1,N). */
/* FERR (input) DOUBLE PRECISION array, dimension (NRHS) */
/* The estimated forward error bounds for each solution vector */
/* X. If XTRUE is the true solution, FERR bounds the magnitude */
/* of the largest entry in (X - XTRUE) divided by the magnitude */
/* of the largest entry in X. */
/* BERR (input) DOUBLE PRECISION array, dimension (NRHS) */
/* The componentwise relative backward error of each solution */
/* vector (i.e., the smallest relative change in any entry of A */
/* or B that makes X an exact solution). */
/* RESLTS (output) DOUBLE PRECISION array, dimension (2) */
/* The maximum over the NRHS solution vectors of the ratios: */
/* RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR ) */
/* RESLTS(2) = BERR / ( NZ*EPS + (*) ) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick exit if N = 0 or NRHS = 0. */
/* Parameter adjustments */
--d__;
--e;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
xact_dim1 = *ldxact;
xact_offset = 1 + xact_dim1;
xact -= xact_offset;
--ferr;
--berr;
--reslts;
/* Function Body */
if (*n <= 0 || *nrhs <= 0) {
reslts[1] = 0.;
reslts[2] = 0.;
return 0;
}
eps = dlamch_("Epsilon");
unfl = dlamch_("Safe minimum");
ovfl = 1. / unfl;
nz = 4;
/* Test 1: Compute the maximum of */
/* norm(X - XACT) / ( norm(X) * FERR ) */
/* over all the vectors X and XACT using the infinity-norm. */
errbnd = 0.;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
imax = izamax_(n, &x[j * x_dim1 + 1], &c__1);
/* Computing MAX */
i__2 = imax + j * x_dim1;
d__3 = (d__1 = x[i__2].r, abs(d__1)) + (d__2 = d_imag(&x[imax + j *
x_dim1]), abs(d__2));
xnorm = max(d__3,unfl);
diff = 0.;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * x_dim1;
i__4 = i__ + j * xact_dim1;
z__2.r = x[i__3].r - xact[i__4].r, z__2.i = x[i__3].i - xact[i__4]
.i;
z__1.r = z__2.r, z__1.i = z__2.i;
/* Computing MAX */
d__3 = diff, d__4 = (d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&
z__1), abs(d__2));
diff = max(d__3,d__4);
/* L10: */
}
if (xnorm > 1.) {
goto L20;
} else if (diff <= ovfl * xnorm) {
goto L20;
} else {
errbnd = 1. / eps;
goto L30;
}
L20:
if (diff / xnorm <= ferr[j]) {
/* Computing MAX */
d__1 = errbnd, d__2 = diff / xnorm / ferr[j];
errbnd = max(d__1,d__2);
} else {
errbnd = 1. / eps;
}
L30:
;
}
reslts[1] = errbnd;
/* Test 2: Compute the maximum of BERR / ( NZ*EPS + (*) ), where */
/* (*) = NZ*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i ) */
i__1 = *nrhs;
for (k = 1; k <= i__1; ++k) {
if (*n == 1) {
i__2 = k * x_dim1 + 1;
z__2.r = d__[1] * x[i__2].r, z__2.i = d__[1] * x[i__2].i;
z__1.r = z__2.r, z__1.i = z__2.i;
i__3 = k * b_dim1 + 1;
axbi = (d__1 = b[i__3].r, abs(d__1)) + (d__2 = d_imag(&b[k *
b_dim1 + 1]), abs(d__2)) + ((d__3 = z__1.r, abs(d__3)) + (
d__4 = d_imag(&z__1), abs(d__4)));
} else {
i__2 = k * x_dim1 + 1;
z__2.r = d__[1] * x[i__2].r, z__2.i = d__[1] * x[i__2].i;
z__1.r = z__2.r, z__1.i = z__2.i;
i__3 = k * b_dim1 + 1;
i__4 = k * x_dim1 + 2;
axbi = (d__1 = b[i__3].r, abs(d__1)) + (d__2 = d_imag(&b[k *
b_dim1 + 1]), abs(d__2)) + ((d__3 = z__1.r, abs(d__3)) + (
d__4 = d_imag(&z__1), abs(d__4))) + ((d__5 = e[1].r, abs(
d__5)) + (d__6 = d_imag(&e[1]), abs(d__6))) * ((d__7 = x[
i__4].r, abs(d__7)) + (d__8 = d_imag(&x[k * x_dim1 + 2]),
abs(d__8)));
i__2 = *n - 1;
for (i__ = 2; i__ <= i__2; ++i__) {
i__3 = i__;
i__4 = i__ + k * x_dim1;
z__2.r = d__[i__3] * x[i__4].r, z__2.i = d__[i__3] * x[i__4]
.i;
z__1.r = z__2.r, z__1.i = z__2.i;
i__5 = i__ + k * b_dim1;
i__6 = i__ - 1;
i__7 = i__ - 1 + k * x_dim1;
i__8 = i__;
i__9 = i__ + 1 + k * x_dim1;
tmp = (d__1 = b[i__5].r, abs(d__1)) + (d__2 = d_imag(&b[i__ +
k * b_dim1]), abs(d__2)) + ((d__3 = e[i__6].r, abs(
d__3)) + (d__4 = d_imag(&e[i__ - 1]), abs(d__4))) * ((
d__5 = x[i__7].r, abs(d__5)) + (d__6 = d_imag(&x[i__
- 1 + k * x_dim1]), abs(d__6))) + ((d__7 = z__1.r,
abs(d__7)) + (d__8 = d_imag(&z__1), abs(d__8))) + ((
d__9 = e[i__8].r, abs(d__9)) + (d__10 = d_imag(&e[i__]
), abs(d__10))) * ((d__11 = x[i__9].r, abs(d__11)) + (
d__12 = d_imag(&x[i__ + 1 + k * x_dim1]), abs(d__12)))
;
axbi = min(axbi,tmp);
/* L40: */
}
i__2 = *n;
i__3 = *n + k * x_dim1;
z__2.r = d__[i__2] * x[i__3].r, z__2.i = d__[i__2] * x[i__3].i;
z__1.r = z__2.r, z__1.i = z__2.i;
i__4 = *n + k * b_dim1;
i__5 = *n - 1;
i__6 = *n - 1 + k * x_dim1;
tmp = (d__1 = b[i__4].r, abs(d__1)) + (d__2 = d_imag(&b[*n + k *
b_dim1]), abs(d__2)) + ((d__3 = e[i__5].r, abs(d__3)) + (
d__4 = d_imag(&e[*n - 1]), abs(d__4))) * ((d__5 = x[i__6]
.r, abs(d__5)) + (d__6 = d_imag(&x[*n - 1 + k * x_dim1]),
abs(d__6))) + ((d__7 = z__1.r, abs(d__7)) + (d__8 =
d_imag(&z__1), abs(d__8)));
axbi = min(axbi,tmp);
}
/* Computing MAX */
d__1 = axbi, d__2 = nz * unfl;
tmp = berr[k] / (nz * eps + nz * unfl / max(d__1,d__2));
if (k == 1) {
reslts[2] = tmp;
} else {
reslts[2] = max(reslts[2],tmp);
}
/* L50: */
}
return 0;
/* End of ZPTT05 */
} /* zptt05_ */
/* Subroutine */ int dsterf_(integer *n, doublereal *d__, doublereal *e,
integer *info)
{
/* System generated locals */
integer i__1;
doublereal d__1, d__2, d__3;
/* Builtin functions */
double sqrt(doublereal), d_sign(doublereal *, doublereal *);
/* Local variables */
doublereal c__;
integer i__, l, m;
doublereal p, r__, s;
integer l1;
doublereal bb, rt1, rt2, eps, rte;
integer lsv;
doublereal eps2, oldc;
integer lend, jtot;
extern /* Subroutine */ int dlae2_(doublereal *, doublereal *, doublereal
*, doublereal *, doublereal *);
doublereal gamma, alpha, sigma, anorm;
extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *);
integer iscale;
extern /* Subroutine */ int dlascl_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *);
doublereal oldgam, safmin;
extern /* Subroutine */ int xerbla_(char *, integer *);
doublereal safmax;
extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *);
extern /* Subroutine */ int dlasrt_(char *, integer *, doublereal *,
integer *);
integer lendsv;
doublereal ssfmin;
integer nmaxit;
doublereal ssfmax;
/* -- LAPACK routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DSTERF computes all eigenvalues of a symmetric tridiagonal matrix */
/* using the Pal-Walker-Kahan variant of the QL or QR algorithm. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The order of the matrix. N >= 0. */
/* D (input/output) DOUBLE PRECISION array, dimension (N) */
/* On entry, the n diagonal elements of the tridiagonal matrix. */
/* On exit, if INFO = 0, the eigenvalues in ascending order. */
/* E (input/output) DOUBLE PRECISION array, dimension (N-1) */
/* On entry, the (n-1) subdiagonal elements of the tridiagonal */
/* matrix. */
/* On exit, E has been destroyed. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: the algorithm failed to find all of the eigenvalues in */
/* a total of 30*N iterations; if INFO = i, then i */
/* elements of E have not converged to zero. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--e;
--d__;
/* Function Body */
*info = 0;
/* Quick return if possible */
if (*n < 0) {
*info = -1;
i__1 = -(*info);
xerbla_("DSTERF", &i__1);
return 0;
}
if (*n <= 1) {
return 0;
}
/* Determine the unit roundoff for this environment. */
eps = dlamch_("E");
/* Computing 2nd power */
d__1 = eps;
eps2 = d__1 * d__1;
safmin = dlamch_("S");
safmax = 1. / safmin;
ssfmax = sqrt(safmax) / 3.;
ssfmin = sqrt(safmin) / eps2;
/* Compute the eigenvalues of the tridiagonal matrix. */
nmaxit = *n * 30;
sigma = 0.;
jtot = 0;
/* Determine where the matrix splits and choose QL or QR iteration */
/* for each block, according to whether top or bottom diagonal */
/* element is smaller. */
l1 = 1;
L10:
if (l1 > *n) {
goto L170;
}
if (l1 > 1) {
e[l1 - 1] = 0.;
}
i__1 = *n - 1;
for (m = l1; m <= i__1; ++m) {
if ((d__3 = e[m], abs(d__3)) <= sqrt((d__1 = d__[m], abs(d__1))) *
sqrt((d__2 = d__[m + 1], abs(d__2))) * eps) {
e[m] = 0.;
goto L30;
}
/* L20: */
}
m = *n;
L30:
l = l1;
lsv = l;
lend = m;
lendsv = lend;
l1 = m + 1;
if (lend == l) {
goto L10;
}
/* Scale submatrix in rows and columns L to LEND */
i__1 = lend - l + 1;
anorm = dlanst_("I", &i__1, &d__[l], &e[l]);
iscale = 0;
if (anorm > ssfmax) {
iscale = 1;
i__1 = lend - l + 1;
dlascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &d__[l], n,
info);
i__1 = lend - l;
dlascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &e[l], n,
info);
} else if (anorm < ssfmin) {
iscale = 2;
i__1 = lend - l + 1;
dlascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &d__[l], n,
info);
i__1 = lend - l;
dlascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &e[l], n,
info);
}
i__1 = lend - 1;
for (i__ = l; i__ <= i__1; ++i__) {
/* Computing 2nd power */
d__1 = e[i__];
e[i__] = d__1 * d__1;
/* L40: */
}
/* Choose between QL and QR iteration */
if ((d__1 = d__[lend], abs(d__1)) < (d__2 = d__[l], abs(d__2))) {
lend = lsv;
l = lendsv;
}
if (lend >= l) {
/* QL Iteration */
/* Look for small subdiagonal element. */
L50:
if (l != lend) {
i__1 = lend - 1;
for (m = l; m <= i__1; ++m) {
if ((d__2 = e[m], abs(d__2)) <= eps2 * (d__1 = d__[m] * d__[m
+ 1], abs(d__1))) {
goto L70;
}
/* L60: */
}
}
m = lend;
L70:
if (m < lend) {
e[m] = 0.;
}
p = d__[l];
if (m == l) {
goto L90;
}
/* If remaining matrix is 2 by 2, use DLAE2 to compute its */
/* eigenvalues. */
if (m == l + 1) {
rte = sqrt(e[l]);
dlae2_(&d__[l], &rte, &d__[l + 1], &rt1, &rt2);
d__[l] = rt1;
d__[l + 1] = rt2;
e[l] = 0.;
l += 2;
if (l <= lend) {
goto L50;
}
goto L150;
}
if (jtot == nmaxit) {
goto L150;
}
++jtot;
/* Form shift. */
rte = sqrt(e[l]);
sigma = (d__[l + 1] - p) / (rte * 2.);
r__ = dlapy2_(&sigma, &c_b32);
sigma = p - rte / (sigma + d_sign(&r__, &sigma));
c__ = 1.;
s = 0.;
gamma = d__[m] - sigma;
p = gamma * gamma;
/* Inner loop */
i__1 = l;
for (i__ = m - 1; i__ >= i__1; --i__) {
bb = e[i__];
r__ = p + bb;
if (i__ != m - 1) {
e[i__ + 1] = s * r__;
}
oldc = c__;
c__ = p / r__;
s = bb / r__;
oldgam = gamma;
alpha = d__[i__];
gamma = c__ * (alpha - sigma) - s * oldgam;
d__[i__ + 1] = oldgam + (alpha - gamma);
if (c__ != 0.) {
p = gamma * gamma / c__;
} else {
p = oldc * bb;
}
/* L80: */
}
e[l] = s * p;
d__[l] = sigma + gamma;
goto L50;
/* Eigenvalue found. */
L90:
d__[l] = p;
++l;
if (l <= lend) {
goto L50;
}
goto L150;
} else {
/* QR Iteration */
/* Look for small superdiagonal element. */
L100:
i__1 = lend + 1;
for (m = l; m >= i__1; --m) {
if ((d__2 = e[m - 1], abs(d__2)) <= eps2 * (d__1 = d__[m] * d__[m
- 1], abs(d__1))) {
goto L120;
}
/* L110: */
}
m = lend;
L120:
if (m > lend) {
e[m - 1] = 0.;
}
p = d__[l];
if (m == l) {
goto L140;
}
/* If remaining matrix is 2 by 2, use DLAE2 to compute its */
/* eigenvalues. */
if (m == l - 1) {
rte = sqrt(e[l - 1]);
dlae2_(&d__[l], &rte, &d__[l - 1], &rt1, &rt2);
d__[l] = rt1;
d__[l - 1] = rt2;
e[l - 1] = 0.;
l += -2;
if (l >= lend) {
goto L100;
}
goto L150;
}
if (jtot == nmaxit) {
goto L150;
}
++jtot;
/* Form shift. */
rte = sqrt(e[l - 1]);
sigma = (d__[l - 1] - p) / (rte * 2.);
r__ = dlapy2_(&sigma, &c_b32);
sigma = p - rte / (sigma + d_sign(&r__, &sigma));
c__ = 1.;
s = 0.;
gamma = d__[m] - sigma;
p = gamma * gamma;
/* Inner loop */
i__1 = l - 1;
for (i__ = m; i__ <= i__1; ++i__) {
bb = e[i__];
r__ = p + bb;
if (i__ != m) {
e[i__ - 1] = s * r__;
}
oldc = c__;
c__ = p / r__;
s = bb / r__;
oldgam = gamma;
alpha = d__[i__ + 1];
gamma = c__ * (alpha - sigma) - s * oldgam;
d__[i__] = oldgam + (alpha - gamma);
if (c__ != 0.) {
p = gamma * gamma / c__;
} else {
p = oldc * bb;
}
/* L130: */
}
e[l - 1] = s * p;
d__[l] = sigma + gamma;
goto L100;
/* Eigenvalue found. */
L140:
d__[l] = p;
--l;
if (l >= lend) {
goto L100;
}
goto L150;
}
/* Undo scaling if necessary */
L150:
if (iscale == 1) {
i__1 = lendsv - lsv + 1;
dlascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &d__[lsv],
n, info);
}
if (iscale == 2) {
i__1 = lendsv - lsv + 1;
dlascl_("G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &d__[lsv],
n, info);
}
/* Check for no convergence to an eigenvalue after a total */
/* of N*MAXIT iterations. */
if (jtot < nmaxit) {
goto L10;
}
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
if (e[i__] != 0.) {
++(*info);
}
/* L160: */
}
goto L180;
/* Sort eigenvalues in increasing order. */
L170:
dlasrt_("I", n, &d__[1], info);
L180:
return 0;
/* End of DSTERF */
} /* dsterf_ */
/* Subroutine */ int dlatbs_(char *uplo, char *trans, char *diag, char *
normin, integer *n, integer *kd, doublereal *ab, integer *ldab,
doublereal *x, doublereal *scale, doublereal *cnorm, 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
June 30, 1992
Purpose
=======
DLATBS solves one of the triangular systems
A *x = s*b or A'*x = s*b
with scaling to prevent overflow, where A is an upper or lower
triangular band matrix. Here A' denotes the transpose of A, x and b
are n-element vectors, and s is a scaling factor, usually less than
or equal to 1, chosen so that the components of x will be less than
the overflow threshold. If the unscaled problem will not cause
overflow, the Level 2 BLAS routine DTBSV is called. If the matrix A
is singular (A(j,j) = 0 for some j), then s is set to 0 and a
non-trivial solution to A*x = 0 is returned.
Arguments
=========
UPLO (input) CHARACTER*1
Specifies whether the matrix A is upper or lower triangular.
= 'U': Upper triangular
= 'L': Lower triangular
TRANS (input) CHARACTER*1
Specifies the operation applied to A.
= 'N': Solve A * x = s*b (No transpose)
= 'T': Solve A'* x = s*b (Transpose)
= 'C': Solve A'* x = s*b (Conjugate transpose = Transpose)
DIAG (input) CHARACTER*1
Specifies whether or not the matrix A is unit triangular.
= 'N': Non-unit triangular
= 'U': Unit triangular
NORMIN (input) CHARACTER*1
Specifies whether CNORM has been set or not.
= 'Y': CNORM contains the column norms on entry
= 'N': CNORM is not set on entry. On exit, the norms will
be computed and stored in CNORM.
N (input) INTEGER
The order of the matrix A. N >= 0.
KD (input) INTEGER
The number of subdiagonals or superdiagonals in the
triangular matrix A. KD >= 0.
AB (input) DOUBLE PRECISION 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).
LDAB (input) INTEGER
The leading dimension of the array AB. LDAB >= KD+1.
X (input/output) DOUBLE PRECISION array, dimension (N)
On entry, the right hand side b of the triangular system.
On exit, X is overwritten by the solution vector x.
SCALE (output) DOUBLE PRECISION
The scaling factor s for the triangular system
A * x = s*b or A'* x = s*b.
If SCALE = 0, the matrix A is singular or badly scaled, and
the vector x is an exact or approximate solution to A*x = 0.
CNORM (input or output) DOUBLE PRECISION array, dimension (N)
If NORMIN = 'Y', CNORM is an input argument and CNORM(j)
contains the norm of the off-diagonal part of the j-th column
of A. If TRANS = 'N', CNORM(j) must be greater than or equal
to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j)
must be greater than or equal to the 1-norm.
If NORMIN = 'N', CNORM is an output argument and CNORM(j)
returns the 1-norm of the offdiagonal part of the j-th column
of A.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -k, the k-th argument had an illegal value
Further Details
======= =======
A rough bound on x is computed; if that is less than overflow, DTBSV
is called, otherwise, specific code is used which checks for possible
overflow or divide-by-zero at every operation.
A columnwise scheme is used for solving A*x = b. The basic algorithm
if A is lower triangular is
x[1:n] := b[1:n]
for j = 1, ..., n
x(j) := x(j) / A(j,j)
x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j]
end
Define bounds on the components of x after j iterations of the loop:
M(j) = bound on x[1:j]
G(j) = bound on x[j+1:n]
Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}.
Then for iteration j+1 we have
M(j+1) <= G(j) / | A(j+1,j+1) |
G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] |
<= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | )
where CNORM(j+1) is greater than or equal to the infinity-norm of
column j+1 of A, not counting the diagonal. Hence
G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | )
1<=i<=j
and
|x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| )
1<=i< j
Since |x(j)| <= M(j), we use the Level 2 BLAS routine DTBSV if the
reciprocal of the largest M(j), j=1,..,n, is larger than
max(underflow, 1/overflow).
The bound on x(j) is also used to determine when a step in the
columnwise method can be performed without fear of overflow. If
the computed bound is greater than a large constant, x is scaled to
prevent overflow, but if the bound overflows, x is set to 0, x(j) to
1, and scale to 0, and a non-trivial solution to A*x = 0 is found.
Similarly, a row-wise scheme is used to solve A'*x = b. The basic
algorithm for A upper triangular is
for j = 1, ..., n
x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j)
end
We simultaneously compute two bounds
G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j
M(j) = bound on x(i), 1<=i<=j
The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we
add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1.
Then the bound on x(j) is
M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) |
<= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| )
1<=i<=j
and we can safely call DTBSV if 1/M(n) and 1/G(n) are both greater
than max(underflow, 1/overflow).
=====================================================================
Parameter adjustments
Function Body */
/* Table of constant values */
static integer c__1 = 1;
static doublereal c_b36 = .5;
/* System generated locals */
integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4;
doublereal d__1, d__2, d__3;
/* Local variables */
static integer jinc, jlen;
extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
integer *);
static doublereal xbnd;
static integer imax;
static doublereal tmax, tjjs, xmax, grow, sumj;
static integer i, j;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
static integer maind;
extern logical lsame_(char *, char *);
static doublereal tscal, uscal;
extern doublereal dasum_(integer *, doublereal *, integer *);
static integer jlast;
extern /* Subroutine */ int dtbsv_(char *, char *, char *, integer *,
integer *, doublereal *, integer *, doublereal *, integer *), daxpy_(integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *);
static logical upper;
extern doublereal dlamch_(char *);
static doublereal xj;
extern integer idamax_(integer *, doublereal *, integer *);
extern /* Subroutine */ int xerbla_(char *, integer *);
static doublereal bignum;
static logical notran;
static integer jfirst;
static doublereal smlnum;
static logical nounit;
static doublereal rec, tjj;
#define X(I) x[(I)-1]
#define CNORM(I) cnorm[(I)-1]
#define AB(I,J) ab[(I)-1 + ((J)-1)* ( *ldab)]
*info = 0;
upper = lsame_(uplo, "U");
notran = lsame_(trans, "N");
nounit = lsame_(diag, "N");
/* Test the input parameters. */
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 (! lsame_(normin, "Y") && ! lsame_(normin, "N"))
{
*info = -4;
} else if (*n < 0) {
*info = -5;
} else if (*kd < 0) {
*info = -6;
} else if (*ldab < *kd + 1) {
*info = -8;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DLATBS", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Determine machine dependent parameters to control overflow. */
smlnum = dlamch_("Safe minimum") / dlamch_("Precision");
bignum = 1. / smlnum;
*scale = 1.;
if (lsame_(normin, "N")) {
/* Compute the 1-norm of each column, not including the diagona
l. */
if (upper) {
/* A is upper triangular. */
i__1 = *n;
for (j = 1; j <= *n; ++j) {
/* Computing MIN */
i__2 = *kd, i__3 = j - 1;
jlen = min(i__2,i__3);
CNORM(j) = dasum_(&jlen, &AB(*kd+1-jlen,j), &
c__1);
/* L10: */
}
} else {
/* A is lower triangular. */
i__1 = *n;
for (j = 1; j <= *n; ++j) {
/* Computing MIN */
i__2 = *kd, i__3 = *n - j;
jlen = min(i__2,i__3);
if (jlen > 0) {
CNORM(j) = dasum_(&jlen, &AB(2,j), &c__1);
} else {
CNORM(j) = 0.;
}
/* L20: */
}
}
}
/* Scale the column norms by TSCAL if the maximum element in CNORM is
greater than BIGNUM. */
imax = idamax_(n, &CNORM(1), &c__1);
tmax = CNORM(imax);
if (tmax <= bignum) {
tscal = 1.;
} else {
tscal = 1. / (smlnum * tmax);
dscal_(n, &tscal, &CNORM(1), &c__1);
}
/* Compute a bound on the computed solution vector to see if the
Level 2 BLAS routine DTBSV can be used. */
j = idamax_(n, &X(1), &c__1);
xmax = (d__1 = X(j), abs(d__1));
xbnd = xmax;
if (notran) {
/* Compute the growth in A * x = b. */
if (upper) {
jfirst = *n;
jlast = 1;
jinc = -1;
maind = *kd + 1;
} else {
jfirst = 1;
jlast = *n;
jinc = 1;
maind = 1;
}
if (tscal != 1.) {
grow = 0.;
goto L50;
}
if (nounit) {
/* A is non-unit triangular.
Compute GROW = 1/G(j) and XBND = 1/M(j).
Initially, G(0) = max{x(i), i=1,...,n}. */
grow = 1. / max(xbnd,smlnum);
xbnd = grow;
i__1 = jlast;
i__2 = jinc;
for (j = jfirst; jinc < 0 ? j >= jlast : j <= jlast; j += jinc) {
/* Exit the loop if the growth factor is too smal
l. */
if (grow <= smlnum) {
goto L50;
}
/* M(j) = G(j-1) / abs(A(j,j)) */
tjj = (d__1 = AB(maind,j), abs(d__1));
/* Computing MIN */
d__1 = xbnd, d__2 = min(1.,tjj) * grow;
xbnd = min(d__1,d__2);
if (tjj + CNORM(j) >= smlnum) {
/* G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,
j)) ) */
grow *= tjj / (tjj + CNORM(j));
} else {
/* G(j) could overflow, set GROW to 0. */
grow = 0.;
}
/* L30: */
}
grow = xbnd;
} else {
/* A is unit triangular.
Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...
,n}.
Computing MIN */
d__1 = 1., d__2 = 1. / max(xbnd,smlnum);
grow = min(d__1,d__2);
i__2 = jlast;
i__1 = jinc;
for (j = jfirst; jinc < 0 ? j >= jlast : j <= jlast; j += jinc) {
/* Exit the loop if the growth factor is too smal
l. */
if (grow <= smlnum) {
goto L50;
}
/* G(j) = G(j-1)*( 1 + CNORM(j) ) */
grow *= 1. / (CNORM(j) + 1.);
/* L40: */
}
}
L50:
;
} else {
/* Compute the growth in A' * x = b. */
if (upper) {
jfirst = 1;
jlast = *n;
jinc = 1;
maind = *kd + 1;
} else {
jfirst = *n;
jlast = 1;
jinc = -1;
maind = 1;
}
if (tscal != 1.) {
grow = 0.;
goto L80;
}
if (nounit) {
/* A is non-unit triangular.
Compute GROW = 1/G(j) and XBND = 1/M(j).
Initially, M(0) = max{x(i), i=1,...,n}. */
grow = 1. / max(xbnd,smlnum);
xbnd = grow;
i__1 = jlast;
i__2 = jinc;
for (j = jfirst; jinc < 0 ? j >= jlast : j <= jlast; j += jinc) {
/* Exit the loop if the growth factor is too smal
l. */
if (grow <= smlnum) {
goto L80;
}
/* G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) )
*/
xj = CNORM(j) + 1.;
/* Computing MIN */
d__1 = grow, d__2 = xbnd / xj;
grow = min(d__1,d__2);
/* M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j))
*/
tjj = (d__1 = AB(maind,j), abs(d__1));
if (xj > tjj) {
xbnd *= tjj / xj;
}
/* L60: */
}
grow = min(grow,xbnd);
} else {
/* A is unit triangular.
Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...
,n}.
Computing MIN */
d__1 = 1., d__2 = 1. / max(xbnd,smlnum);
grow = min(d__1,d__2);
i__2 = jlast;
i__1 = jinc;
for (j = jfirst; jinc < 0 ? j >= jlast : j <= jlast; j += jinc) {
/* Exit the loop if the growth factor is too smal
l. */
if (grow <= smlnum) {
goto L80;
}
/* G(j) = ( 1 + CNORM(j) )*G(j-1) */
xj = CNORM(j) + 1.;
grow /= xj;
/* L70: */
}
}
L80:
;
}
if (grow * tscal > smlnum) {
/* Use the Level 2 BLAS solve if the reciprocal of the bound on
elements of X is not too small. */
dtbsv_(uplo, trans, diag, n, kd, &AB(1,1), ldab, &X(1), &c__1);
} else {
/* Use a Level 1 BLAS solve, scaling intermediate results. */
if (xmax > bignum) {
/* Scale X so that its components are less than or equal
to
BIGNUM in absolute value. */
*scale = bignum / xmax;
dscal_(n, scale, &X(1), &c__1);
xmax = bignum;
}
if (notran) {
/* Solve A * x = b */
i__1 = jlast;
i__2 = jinc;
for (j = jfirst; jinc < 0 ? j >= jlast : j <= jlast; j += jinc) {
/* Compute x(j) = b(j) / A(j,j), scaling x if nec
essary. */
xj = (d__1 = X(j), abs(d__1));
if (nounit) {
tjjs = AB(maind,j) * tscal;
} else {
tjjs = tscal;
if (tscal == 1.) {
goto L100;
}
}
tjj = abs(tjjs);
if (tjj > smlnum) {
/* abs(A(j,j)) > SMLNUM: */
if (tjj < 1.) {
if (xj > tjj * bignum) {
/* Scale x by 1/b(j). */
rec = 1. / xj;
dscal_(n, &rec, &X(1), &c__1);
*scale *= rec;
xmax *= rec;
}
}
X(j) /= tjjs;
xj = (d__1 = X(j), abs(d__1));
} else if (tjj > 0.) {
/* 0 < abs(A(j,j)) <= SMLNUM: */
if (xj > tjj * bignum) {
/* Scale x by (1/abs(x(j)))*abs(
A(j,j))*BIGNUM
to avoid overflow when dividi
ng by A(j,j). */
rec = tjj * bignum / xj;
if (CNORM(j) > 1.) {
/* Scale by 1/CNORM(j) to
avoid overflow when
multiplying x(j) times
column j. */
rec /= CNORM(j);
}
dscal_(n, &rec, &X(1), &c__1);
*scale *= rec;
xmax *= rec;
}
X(j) /= tjjs;
xj = (d__1 = X(j), abs(d__1));
} else {
/* A(j,j) = 0: Set x(1:n) = 0, x(j) =
1, and
scale = 0, and compute a solution to
A*x = 0. */
i__3 = *n;
for (i = 1; i <= *n; ++i) {
X(i) = 0.;
/* L90: */
}
X(j) = 1.;
xj = 1.;
*scale = 0.;
xmax = 0.;
}
L100:
/* Scale x if necessary to avoid overflow when ad
ding a
multiple of column j of A. */
if (xj > 1.) {
rec = 1. / xj;
if (CNORM(j) > (bignum - xmax) * rec) {
/* Scale x by 1/(2*abs(x(j))). */
rec *= .5;
dscal_(n, &rec, &X(1), &c__1);
*scale *= rec;
}
} else if (xj * CNORM(j) > bignum - xmax) {
/* Scale x by 1/2. */
dscal_(n, &c_b36, &X(1), &c__1);
*scale *= .5;
}
if (upper) {
if (j > 1) {
/* Compute the update
x(max(1,j-kd):j-1) := x(max(1
,j-kd):j-1) -
x(j)* A
(max(1,j-kd):j-1,j)
Computing MIN */
i__3 = *kd, i__4 = j - 1;
jlen = min(i__3,i__4);
d__1 = -X(j) * tscal;
daxpy_(&jlen, &d__1, &AB(*kd+1-jlen,j)
, &c__1, &X(j - jlen), &c__1);
i__3 = j - 1;
i = idamax_(&i__3, &X(1), &c__1);
xmax = (d__1 = X(i), abs(d__1));
}
} else if (j < *n) {
/* Compute the update
x(j+1:min(j+kd,n)) := x(j+1:min(j+kd
,n)) -
x(j) * A(j+1:m
in(j+kd,n),j)
Computing MIN */
i__3 = *kd, i__4 = *n - j;
jlen = min(i__3,i__4);
if (jlen > 0) {
d__1 = -X(j) * tscal;
daxpy_(&jlen, &d__1, &AB(2,j), &c__1, &X(
j + 1), &c__1);
}
i__3 = *n - j;
i = j + idamax_(&i__3, &X(j + 1), &c__1);
xmax = (d__1 = X(i), abs(d__1));
}
/* L110: */
}
} else {
/* Solve A' * x = b */
i__2 = jlast;
i__1 = jinc;
for (j = jfirst; jinc < 0 ? j >= jlast : j <= jlast; j += jinc) {
/* Compute x(j) = b(j) - sum A(k,j)*x(k).
k<>j */
xj = (d__1 = X(j), abs(d__1));
uscal = tscal;
rec = 1. / max(xmax,1.);
if (CNORM(j) > (bignum - xj) * rec) {
/* If x(j) could overflow, scale x by 1/(2
*XMAX). */
rec *= .5;
if (nounit) {
tjjs = AB(maind,j) * tscal;
} else {
tjjs = tscal;
}
tjj = abs(tjjs);
if (tjj > 1.) {
/* Divide by A(j,j) when scaling
x if A(j,j) > 1.
Computing MIN */
d__1 = 1., d__2 = rec * tjj;
rec = min(d__1,d__2);
uscal /= tjjs;
}
if (rec < 1.) {
dscal_(n, &rec, &X(1), &c__1);
*scale *= rec;
xmax *= rec;
}
}
sumj = 0.;
if (uscal == 1.) {
/* If the scaling needed for A in the dot
product is 1,
call DDOT to perform the dot product.
*/
if (upper) {
/* Computing MIN */
i__3 = *kd, i__4 = j - 1;
jlen = min(i__3,i__4);
sumj = ddot_(&jlen, &AB(*kd+1-jlen,j),
&c__1, &X(j - jlen), &c__1);
} else {
/* Computing MIN */
i__3 = *kd, i__4 = *n - j;
jlen = min(i__3,i__4);
if (jlen > 0) {
sumj = ddot_(&jlen, &AB(2,j), &c__1, &
X(j + 1), &c__1);
}
}
} else {
/* Otherwise, use in-line code for the dot
product. */
if (upper) {
/* Computing MIN */
i__3 = *kd, i__4 = j - 1;
jlen = min(i__3,i__4);
i__3 = jlen;
for (i = 1; i <= jlen; ++i) {
sumj += AB(*kd+i-jlen,j) * uscal *
X(j - jlen - 1 + i);
/* L120: */
}
} else {
/* Computing MIN */
i__3 = *kd, i__4 = *n - j;
jlen = min(i__3,i__4);
i__3 = jlen;
for (i = 1; i <= jlen; ++i) {
sumj += AB(i+1,j) * uscal * X(j + i)
;
/* L130: */
}
}
}
if (uscal == tscal) {
/* Compute x(j) := ( x(j) - sumj ) / A(j,j
) if 1/A(j,j)
was not used to scale the dotproduct.
*/
X(j) -= sumj;
xj = (d__1 = X(j), abs(d__1));
if (nounit) {
/* Compute x(j) = x(j) / A(j,j), sc
aling if necessary. */
tjjs = AB(maind,j) * tscal;
} else {
tjjs = tscal;
if (tscal == 1.) {
goto L150;
}
}
tjj = abs(tjjs);
if (tjj > smlnum) {
/* abs(A(j,j)) > SMLNUM: */
if (tjj < 1.) {
if (xj > tjj * bignum) {
/* Scale X by 1/ab
s(x(j)). */
rec = 1. / xj;
dscal_(n, &rec, &X(1), &c__1);
*scale *= rec;
xmax *= rec;
}
}
X(j) /= tjjs;
} else if (tjj > 0.) {
/* 0 < abs(A(j,j)) <= SMLNUM: */
if (xj > tjj * bignum) {
/* Scale x by (1/abs(x(j)
))*abs(A(j,j))*BIGNUM. */
rec = tjj * bignum / xj;
dscal_(n, &rec, &X(1), &c__1);
*scale *= rec;
xmax *= rec;
}
X(j) /= tjjs;
} else {
/* A(j,j) = 0: Set x(1:n) = 0,
x(j) = 1, and
scale = 0, and compute a solu
tion to A'*x = 0. */
i__3 = *n;
for (i = 1; i <= *n; ++i) {
X(i) = 0.;
/* L140: */
}
X(j) = 1.;
*scale = 0.;
xmax = 0.;
}
L150:
;
} else {
/* Compute x(j) := x(j) / A(j,j) - sumj if
the dot
product has already been divided by 1/A
(j,j). */
X(j) = X(j) / tjjs - sumj;
}
/* Computing MAX */
d__2 = xmax, d__3 = (d__1 = X(j), abs(d__1));
xmax = max(d__2,d__3);
/* L160: */
}
}
*scale /= tscal;
}
/* Scale the column norms by 1/TSCAL for return. */
if (tscal != 1.) {
d__1 = 1. / tscal;
dscal_(n, &d__1, &CNORM(1), &c__1);
}
return 0;
/* End of DLATBS */
} /* dlatbs_ */
void
zgssvx(char *fact, char *trans, char *refact,
SuperMatrix *A, factor_param_t *factor_params, int *perm_c,
int *perm_r, int *etree, char *equed, double *R, double *C,
SuperMatrix *L, SuperMatrix *U, void *work, int lwork,
SuperMatrix *B, SuperMatrix *X, double *recip_pivot_growth,
double *rcond, double *ferr, double *berr,
mem_usage_t *mem_usage, int *info )
{
/*
* Purpose
* =======
*
* ZGSSVX solves the system of linear equations A*X=B or A'*X=B, using
* the LU factorization from zgstrf(). Error bounds on the solution and
* a condition estimate are also provided. It performs the following steps:
*
* 1. If A is stored column-wise (A->Stype = SLU_NC):
*
* 1.1. If fact = 'E', scaling factors are computed to equilibrate the
* system:
* trans = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B
* trans = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B
* trans = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B
* Whether or not the system will be equilibrated depends on the
* scaling of the matrix A, but if equilibration is used, A is
* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if trans='N')
* or diag(C)*B (if trans = 'T' or 'C').
*
* 1.2. Permute columns of A, forming A*Pc, where Pc is a permutation
* matrix that usually preserves sparsity.
* For more details of this step, see sp_preorder.c.
*
* 1.3. If fact = 'N' or 'E', the LU decomposition is used to factor the
* matrix A (after equilibration if fact = 'E') as Pr*A*Pc = L*U,
* with Pr determined by partial pivoting.
*
* 1.4. Compute the reciprocal pivot growth factor.
*
* 1.5. If some U(i,i) = 0, so that U is exactly singular, then the
* routine returns with info = i. Otherwise, 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, info = A->ncol+1 is returned as a warning, but the
* routine still goes on to solve for X and computes error bounds
* as described below.
*
* 1.6. The system of equations is solved for X using the factored form
* of A.
*
* 1.7. Iterative refinement is applied to improve the computed solution
* matrix and calculate error bounds and backward error estimates
* for it.
*
* 1.8. If equilibration was used, the matrix X is premultiplied by
* diag(C) (if trans = 'N') or diag(R) (if trans = 'T' or 'C') so
* that it solves the original system before equilibration.
*
* 2. If A is stored row-wise (A->Stype = SLU_NR), apply the above algorithm
* to the transpose of A:
*
* 2.1. If fact = 'E', scaling factors are computed to equilibrate the
* system:
* trans = 'N': diag(R)*A'*diag(C) *inv(diag(C))*X = diag(R)*B
* trans = 'T': (diag(R)*A'*diag(C))**T *inv(diag(R))*X = diag(C)*B
* trans = 'C': (diag(R)*A'*diag(C))**H *inv(diag(R))*X = diag(C)*B
* Whether or not the system will be equilibrated depends on the
* scaling of the matrix A, but if equilibration is used, A' is
* overwritten by diag(R)*A'*diag(C) and B by diag(R)*B
* (if trans='N') or diag(C)*B (if trans = 'T' or 'C').
*
* 2.2. Permute columns of transpose(A) (rows of A),
* forming transpose(A)*Pc, where Pc is a permutation matrix that
* usually preserves sparsity.
* For more details of this step, see sp_preorder.c.
*
* 2.3. If fact = 'N' or 'E', the LU decomposition is used to factor the
* transpose(A) (after equilibration if fact = 'E') as
* Pr*transpose(A)*Pc = L*U with the permutation Pr determined by
* partial pivoting.
*
* 2.4. Compute the reciprocal pivot growth factor.
*
* 2.5. If some U(i,i) = 0, so that U is exactly singular, then the
* routine returns with info = i. Otherwise, the factored form
* of transpose(A) is used to estimate the condition number of the
* matrix A. If the reciprocal of the condition number
* is less than machine precision, info = A->nrow+1 is returned as
* a warning, but the routine still goes on to solve for X and
* computes error bounds as described below.
*
* 2.6. The system of equations is solved for X using the factored form
* of transpose(A).
*
* 2.7. Iterative refinement is applied to improve the computed solution
* matrix and calculate error bounds and backward error estimates
* for it.
*
* 2.8. If equilibration was used, the matrix X is premultiplied by
* diag(C) (if trans = 'N') or diag(R) (if trans = 'T' or 'C') so
* that it solves the original system before equilibration.
*
* See supermatrix.h for the definition of 'SuperMatrix' structure.
*
* Arguments
* =========
*
* fact (input) char*
* Specifies whether or not the factored form of the matrix
* A is supplied on entry, and if not, whether the matrix A should
* be equilibrated before it is factored.
* = 'F': On entry, L, U, perm_r and perm_c contain the factored
* form of A. If equed is not 'N', the matrix A has been
* equilibrated with scaling factors R and C.
* A, L, U, perm_r are not modified.
* = 'N': The matrix A will be factored, and the factors will be
* stored in L and U.
* = 'E': The matrix A will be equilibrated if necessary, then
* factored into L and U.
*
* trans (input) char*
* 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 (Transpose)
*
* refact (input) char*
* Specifies whether we want to re-factor the matrix.
* = 'N': Factor the matrix A.
* = 'Y': Matrix A was factored before, now we want to re-factor
* matrix A with perm_r and etree as inputs. Use
* the same storage for the L\U factors previously allocated,
* expand it if necessary. User should insure to use the same
* memory model. In this case, perm_r may be modified due to
* different pivoting determined by diagonal threshold.
* If fact = 'F', then refact is not accessed.
*
* A (input/output) SuperMatrix*
* Matrix A in A*X=B, of dimension (A->nrow, A->ncol). The number
* of the linear equations is A->nrow. Currently, the type of A can be:
* Stype = SLU_NC or SLU_NR, Dtype = SLU_Z, Mtype = SLU_GE.
* In the future, more general A may be handled.
*
* On entry, If fact = 'F' and equed is not 'N', then A must have
* been equilibrated by the scaling factors in R and/or C.
* A is not modified if fact = 'F' or 'N', or if fact = 'E' and
* equed = 'N' on exit.
*
* On exit, if fact = 'E' and equed is not 'N', A is scaled as follows:
* If A->Stype = SLU_NC:
* equed = 'R': A := diag(R) * A
* equed = 'C': A := A * diag(C)
* equed = 'B': A := diag(R) * A * diag(C).
* If A->Stype = SLU_NR:
* equed = 'R': transpose(A) := diag(R) * transpose(A)
* equed = 'C': transpose(A) := transpose(A) * diag(C)
* equed = 'B': transpose(A) := diag(R) * transpose(A) * diag(C).
*
* factor_params (input) factor_param_t*
* The structure defines the input scalar parameters, consisting of
* the following fields. If factor_params = NULL, the default
* values are used for all the fields; otherwise, the values
* are given by the user.
* - panel_size (int): Panel size. A panel consists of at most
* panel_size consecutive columns. If panel_size = -1, use
* default value 8.
* - relax (int): To control degree of relaxing supernodes. If the
* number of nodes (columns) in a subtree of the elimination
* tree is less than relax, this subtree is considered as one
* supernode, regardless of the row structures of those columns.
* If relax = -1, use default value 8.
* - diag_pivot_thresh (double): Diagonal pivoting threshold.
* At step j of the Gaussian elimination, if
* abs(A_jj) >= diag_pivot_thresh * (max_(i>=j) abs(A_ij)),
* then use A_jj as pivot. 0 <= diag_pivot_thresh <= 1.
* If diag_pivot_thresh = -1, use default value 1.0,
* which corresponds to standard partial pivoting.
* - drop_tol (double): Drop tolerance threshold. (NOT IMPLEMENTED)
* At step j of the Gaussian elimination, if
* abs(A_ij)/(max_i abs(A_ij)) < drop_tol,
* then drop entry A_ij. 0 <= drop_tol <= 1.
* If drop_tol = -1, use default value 0.0, which corresponds to
* standard Gaussian elimination.
*
* perm_c (input/output) int*
* If A->Stype = SLU_NC, Column permutation vector of size A->ncol,
* which defines the permutation matrix Pc; perm_c[i] = j means
* column i of A is in position j in A*Pc.
* On exit, perm_c may be overwritten by the product of the input
* perm_c and a permutation that postorders the elimination tree
* of Pc'*A'*A*Pc; perm_c is not changed if the elimination tree
* is already in postorder.
*
* If A->Stype = SLU_NR, column permutation vector of size A->nrow,
* which describes permutation of columns of transpose(A)
* (rows of A) as described above.
*
* perm_r (input/output) int*
* If A->Stype = SLU_NC, row permutation vector of size A->nrow,
* which defines the permutation matrix Pr, and is determined
* by partial pivoting. perm_r[i] = j means row i of A is in
* position j in Pr*A.
*
* If A->Stype = SLU_NR, permutation vector of size A->ncol, which
* determines permutation of rows of transpose(A)
* (columns of A) as described above.
*
* If refact is not 'Y', perm_r is output argument;
* If refact = 'Y', the pivoting routine will try to use the input
* perm_r, unless a certain threshold criterion is violated.
* In that case, perm_r is overwritten by a new permutation
* determined by partial pivoting or diagonal threshold pivoting.
*
* etree (input/output) int*, dimension (A->ncol)
* Elimination tree of Pc'*A'*A*Pc.
* If fact is not 'F' and refact = 'Y', etree is an input argument,
* otherwise it is an output argument.
* Note: etree is a vector of parent pointers for a forest whose
* vertices are the integers 0 to A->ncol-1; etree[root]==A->ncol.
*
* equed (input/output) char*
* Specifies the form of equilibration that was done.
* = 'N': No equilibration.
* = 'R': Row equilibration, i.e., A was premultiplied by diag(R).
* = 'C': Column equilibration, i.e., A was postmultiplied by diag(C).
* = 'B': Both row and column equilibration, i.e., A was replaced
* by diag(R)*A*diag(C).
* If fact = 'F', equed is an input argument, otherwise it is
* an output argument.
*
* R (input/output) double*, dimension (A->nrow)
* The row scale factors for A or transpose(A).
* If equed = 'R' or 'B', A (if A->Stype = SLU_NC) or transpose(A)
* (if A->Stype = SLU_NR) is multiplied on the left by diag(R).
* If equed = 'N' or 'C', R is not accessed.
* If fact = 'F', R is an input argument; otherwise, R is output.
* If fact = 'F' and equed = 'R' or 'B', each element of R must
* be positive.
*
* C (input/output) double*, dimension (A->ncol)
* The column scale factors for A or transpose(A).
* If equed = 'C' or 'B', A (if A->Stype = SLU_NC) or transpose(A)
* (if A->Stype = SLU_NR) is multiplied on the right by diag(C).
* If equed = 'N' or 'R', C is not accessed.
* If fact = 'F', C is an input argument; otherwise, C is output.
* If fact = 'F' and equed = 'C' or 'B', each element of C must
* be positive.
*
* L (output) SuperMatrix*
* The factor L from the factorization
* Pr*A*Pc=L*U (if A->Stype SLU_= NC) or
* Pr*transpose(A)*Pc=L*U (if A->Stype = SLU_NR).
* Uses compressed row subscripts storage for supernodes, i.e.,
* L has types: Stype = SC, Dtype = SLU_Z, Mtype = TRLU.
*
* U (output) SuperMatrix*
* The factor U from the factorization
* Pr*A*Pc=L*U (if A->Stype = SLU_NC) or
* Pr*transpose(A)*Pc=L*U (if A->Stype = SLU_NR).
* Uses column-wise storage scheme, i.e., U has types:
* Stype = SLU_NC, Dtype = SLU_Z, Mtype = TRU.
*
* work (workspace/output) void*, size (lwork) (in bytes)
* User supplied workspace, should be large enough
* to hold data structures for factors L and U.
* On exit, if fact is not 'F', L and U point to this array.
*
* lwork (input) int
* Specifies the size of work array in bytes.
* = 0: allocate space internally by system malloc;
* > 0: use user-supplied work array of length lwork in bytes,
* returns error if space runs out.
* = -1: the routine guesses the amount of space needed without
* performing the factorization, and returns it in
* mem_usage->total_needed; no other side effects.
*
* See argument 'mem_usage' for memory usage statistics.
*
* B (input/output) SuperMatrix*
* B has types: Stype = SLU_DN, Dtype = SLU_Z, Mtype = SLU_GE.
* On entry, the right hand side matrix.
* On exit,
* if equed = 'N', B is not modified; otherwise
* if A->Stype = SLU_NC:
* if trans = 'N' and equed = 'R' or 'B', B is overwritten by
* diag(R)*B;
* if trans = 'T' or 'C' and equed = 'C' of 'B', B is
* overwritten by diag(C)*B;
* if A->Stype = SLU_NR:
* if trans = 'N' and equed = 'C' or 'B', B is overwritten by
* diag(C)*B;
* if trans = 'T' or 'C' and equed = 'R' of 'B', B is
* overwritten by diag(R)*B.
*
* X (output) SuperMatrix*
* X has types: Stype = SLU_DN, Dtype = SLU_Z, Mtype = SLU_GE.
* If info = 0 or info = A->ncol+1, X contains the solution matrix
* to the original system of equations. Note that A and B are modified
* on exit if equed is not 'N', and the solution to the equilibrated
* system is inv(diag(C))*X if trans = 'N' and equed = 'C' or 'B',
* or inv(diag(R))*X if trans = 'T' or 'C' and equed = 'R' or 'B'.
*
* recip_pivot_growth (output) double*
* The reciprocal pivot growth factor max_j( norm(A_j)/norm(U_j) ).
* The infinity norm is used. If recip_pivot_growth is much less
* than 1, the stability of the LU factorization could be poor.
*
* rcond (output) double*
* The estimate of the reciprocal condition number of the matrix A
* after equilibration (if done). 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.
*
* FERR (output) double*, dimension (B->ncol)
* 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*, dimension (B->ncol)
* 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).
*
* mem_usage (output) mem_usage_t*
* Record the memory usage statistics, consisting of following fields:
* - for_lu (float)
* The amount of space used in bytes for L\U data structures.
* - total_needed (float)
* The amount of space needed in bytes to perform factorization.
* - expansions (int)
* The number of memory expansions during the LU factorization.
*
* info (output) int*
* = 0: successful exit
* < 0: if info = -i, the i-th argument had an illegal value
* > 0: if info = i, and i is
* <= A->ncol: U(i,i) is exactly zero. The factorization has
* been completed, but the factor U is exactly
* singular, so the solution and error bounds
* could not be computed.
* = A->ncol+1: U is nonsingular, but RCOND is less than machine
* precision, meaning that the matrix is singular to
* working precision. Nevertheless, the solution and
* error bounds are computed because there are a number
* of situations where the computed solution can be more
* accurate than the value of RCOND would suggest.
* > A->ncol+1: number of bytes allocated when memory allocation
* failure occurred, plus A->ncol.
*
*/
DNformat *Bstore, *Xstore;
doublecomplex *Bmat, *Xmat;
int ldb, ldx, nrhs;
SuperMatrix *AA;/* A in SLU_NC format used by the factorization routine.*/
SuperMatrix AC; /* Matrix postmultiplied by Pc */
int colequ, equil, nofact, notran, rowequ;
char trant[1], norm[1];
int i, j, info1;
double amax, anorm, bignum, smlnum, colcnd, rowcnd, rcmax, rcmin;
int relax, panel_size;
double diag_pivot_thresh, drop_tol;
double t0; /* temporary time */
double *utime;
extern SuperLUStat_t SuperLUStat;
/* External functions */
extern double zlangs(char *, SuperMatrix *);
extern double dlamch_(char *);
Bstore = B->Store;
Xstore = X->Store;
Bmat = Bstore->nzval;
Xmat = Xstore->nzval;
ldb = Bstore->lda;
ldx = Xstore->lda;
nrhs = B->ncol;
#if 0
printf("zgssvx: fact=%c, trans=%c, refact=%c, equed=%c\n",
*fact, *trans, *refact, *equed);
#endif
*info = 0;
nofact = lsame_(fact, "N");
equil = lsame_(fact, "E");
notran = lsame_(trans, "N");
if (nofact || equil) {
*(unsigned char *)equed = 'N';
rowequ = FALSE;
colequ = FALSE;
} else {
rowequ = lsame_(equed, "R") || lsame_(equed, "B");
colequ = lsame_(equed, "C") || lsame_(equed, "B");
smlnum = dlamch_("Safe minimum");
bignum = 1. / smlnum;
}
/* Test the input parameters */
if (!nofact && !equil && !lsame_(fact, "F")) *info = -1;
else if (!notran && !lsame_(trans, "T") && !lsame_(trans, "C")) *info = -2;
else if ( !(lsame_(refact,"Y") || lsame_(refact, "N")) ) *info = -3;
else if ( A->nrow != A->ncol || A->nrow < 0 ||
(A->Stype != SLU_NC && A->Stype != SLU_NR) ||
A->Dtype != SLU_Z || A->Mtype != SLU_GE )
*info = -4;
else if (lsame_(fact, "F") && !(rowequ || colequ || lsame_(equed, "N")))
*info = -9;
else {
if (rowequ) {
rcmin = bignum;
rcmax = 0.;
for (j = 0; j < A->nrow; ++j) {
rcmin = SUPERLU_MIN(rcmin, R[j]);
rcmax = SUPERLU_MAX(rcmax, R[j]);
}
if (rcmin <= 0.) *info = -10;
else if ( A->nrow > 0)
rowcnd = SUPERLU_MAX(rcmin,smlnum) / SUPERLU_MIN(rcmax,bignum);
else rowcnd = 1.;
}
if (colequ && *info == 0) {
rcmin = bignum;
rcmax = 0.;
for (j = 0; j < A->nrow; ++j) {
rcmin = SUPERLU_MIN(rcmin, C[j]);
rcmax = SUPERLU_MAX(rcmax, C[j]);
}
if (rcmin <= 0.) *info = -11;
else if (A->nrow > 0)
colcnd = SUPERLU_MAX(rcmin,smlnum) / SUPERLU_MIN(rcmax,bignum);
else colcnd = 1.;
}
if (*info == 0) {
if ( lwork < -1 ) *info = -15;
else if ( B->ncol < 0 || Bstore->lda < SUPERLU_MAX(0, A->nrow) ||
B->Stype != SLU_DN || B->Dtype != SLU_Z ||
B->Mtype != SLU_GE )
*info = -16;
else if ( X->ncol < 0 || Xstore->lda < SUPERLU_MAX(0, A->nrow) ||
B->ncol != X->ncol || X->Stype != SLU_DN ||
X->Dtype != SLU_Z || X->Mtype != SLU_GE )
*info = -17;
}
}
if (*info != 0) {
i = -(*info);
xerbla_("zgssvx", &i);
return;
}
/* Default values for factor_params */
panel_size = sp_ienv(1);
relax = sp_ienv(2);
diag_pivot_thresh = 1.0;
drop_tol = 0.0;
if ( factor_params != NULL ) {
if ( factor_params->panel_size != -1 )
panel_size = factor_params->panel_size;
if ( factor_params->relax != -1 ) relax = factor_params->relax;
if ( factor_params->diag_pivot_thresh != -1 )
diag_pivot_thresh = factor_params->diag_pivot_thresh;
if ( factor_params->drop_tol != -1 )
drop_tol = factor_params->drop_tol;
}
StatInit(panel_size, relax);
utime = SuperLUStat.utime;
/* Convert A to SLU_NC format when necessary. */
if ( A->Stype == SLU_NR ) {
NRformat *Astore = A->Store;
AA = (SuperMatrix *) SUPERLU_MALLOC( sizeof(SuperMatrix) );
zCreate_CompCol_Matrix(AA, A->ncol, A->nrow, Astore->nnz,
Astore->nzval, Astore->colind, Astore->rowptr,
SLU_NC, A->Dtype, A->Mtype);
if ( notran ) { /* Reverse the transpose argument. */
*trant = 'T';
notran = 0;
} else {
*trant = 'N';
notran = 1;
}
} else { /* A->Stype == SLU_NC */
*trant = *trans;
AA = A;
}
if ( equil ) {
t0 = SuperLU_timer_();
/* Compute row and column scalings to equilibrate the matrix A. */
zgsequ(AA, R, C, &rowcnd, &colcnd, &amax, &info1);
if ( info1 == 0 ) {
/* Equilibrate matrix A. */
zlaqgs(AA, R, C, rowcnd, colcnd, amax, equed);
rowequ = lsame_(equed, "R") || lsame_(equed, "B");
colequ = lsame_(equed, "C") || lsame_(equed, "B");
}
utime[EQUIL] = SuperLU_timer_() - t0;
}
/* Scale the right hand side if equilibration was performed. */
if ( notran ) {
if ( rowequ ) {
for (j = 0; j < nrhs; ++j)
for (i = 0; i < A->nrow; ++i) {
zd_mult(&Bmat[i + j*ldb], &Bmat[i + j*ldb], R[i]);
}
}
} else if ( colequ ) {
for (j = 0; j < nrhs; ++j)
for (i = 0; i < A->nrow; ++i) {
zd_mult(&Bmat[i + j*ldb], &Bmat[i + j*ldb], C[i]);
}
}
if ( nofact || equil ) {
t0 = SuperLU_timer_();
sp_preorder(refact, AA, perm_c, etree, &AC);
utime[ETREE] = SuperLU_timer_() - t0;
/* printf("Factor PA = LU ... relax %d\tw %d\tmaxsuper %d\trowblk %d\n",
relax, panel_size, sp_ienv(3), sp_ienv(4));
fflush(stdout); */
/* Compute the LU factorization of A*Pc. */
t0 = SuperLU_timer_();
zgstrf(refact, &AC, diag_pivot_thresh, drop_tol, relax, panel_size,
etree, work, lwork, perm_r, perm_c, L, U, info);
utime[FACT] = SuperLU_timer_() - t0;
if ( lwork == -1 ) {
mem_usage->total_needed = *info - A->ncol;
return;
}
}
if ( *info > 0 ) {
if ( *info <= A->ncol ) {
/* Compute the reciprocal pivot growth factor of the leading
rank-deficient *info columns of A. */
*recip_pivot_growth = zPivotGrowth(*info, AA, perm_c, L, U);
}
return;
}
/* Compute the reciprocal pivot growth factor *recip_pivot_growth. */
*recip_pivot_growth = zPivotGrowth(A->ncol, AA, perm_c, L, U);
/* Estimate the reciprocal of the condition number of A. */
t0 = SuperLU_timer_();
if ( notran ) {
*(unsigned char *)norm = '1';
} else {
*(unsigned char *)norm = 'I';
}
anorm = zlangs(norm, AA);
zgscon(norm, L, U, anorm, rcond, info);
utime[RCOND] = SuperLU_timer_() - t0;
/* Compute the solution matrix X. */
for (j = 0; j < nrhs; j++) /* Save a copy of the right hand sides */
for (i = 0; i < B->nrow; i++)
Xmat[i + j*ldx] = Bmat[i + j*ldb];
t0 = SuperLU_timer_();
zgstrs (trant, L, U, perm_r, perm_c, X, info);
utime[SOLVE] = SuperLU_timer_() - t0;
/* Use iterative refinement to improve the computed solution and compute
error bounds and backward error estimates for it. */
t0 = SuperLU_timer_();
zgsrfs(trant, AA, L, U, perm_r, perm_c, equed, R, C, B,
X, ferr, berr, info);
utime[REFINE] = SuperLU_timer_() - t0;
/* Transform the solution matrix X to a solution of the original system. */
if ( notran ) {
if ( colequ ) {
for (j = 0; j < nrhs; ++j)
for (i = 0; i < A->nrow; ++i) {
zd_mult(&Xmat[i + j*ldx], &Xmat[i + j*ldx], C[i]);
}
}
} else if ( rowequ ) {
for (j = 0; j < nrhs; ++j)
for (i = 0; i < A->nrow; ++i) {
zd_mult(&Xmat[i+ j*ldx], &Xmat[i+ j*ldx], R[i]);
}
}
/* Set INFO = A->ncol+1 if the matrix is singular to working precision. */
if ( *rcond < dlamch_("E") ) *info = A->ncol + 1;
zQuerySpace(L, U, panel_size, mem_usage);
if ( nofact || equil ) Destroy_CompCol_Permuted(&AC);
if ( A->Stype == SLU_NR ) {
Destroy_SuperMatrix_Store(AA);
SUPERLU_FREE(AA);
}
PrintStat( &SuperLUStat );
StatFree();
}
/* Subroutine */ int dtrt05_(char *uplo, char *trans, char *diag, integer *n,
integer *nrhs, doublereal *a, integer *lda, doublereal *b, integer *
ldb, doublereal *x, integer *ldx, doublereal *xact, integer *ldxact,
doublereal *ferr, doublereal *berr, doublereal *reslts)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, xact_dim1,
xact_offset, i__1, i__2, i__3;
doublereal d__1, d__2, d__3;
/* Local variables */
integer i__, j, k, ifu;
doublereal eps, tmp, diff, axbi;
integer imax;
doublereal unfl, ovfl;
logical unit;
extern logical lsame_(char *, char *);
logical upper;
doublereal xnorm;
extern doublereal dlamch_(char *);
extern integer idamax_(integer *, doublereal *, integer *);
doublereal errbnd;
logical notran;
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DTRT05 tests the error bounds from iterative refinement for the */
/* computed solution to a system of equations A*X = B, where A is a */
/* triangular n by n matrix. */
/* RESLTS(1) = test of the error bound */
/* = norm(X - XACT) / ( norm(X) * FERR ) */
/* A large value is returned if this ratio is not less than one. */
/* RESLTS(2) = residual from the iterative refinement routine */
/* = the maximum of BERR / ( (n+1)*EPS + (*) ), where */
/* (*) = (n+1)*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i ) */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the matrix A is upper or lower triangular. */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* TRANS (input) CHARACTER*1 */
/* Specifies the form of the system of equations. */
/* = 'N': A * X = B (No transpose) */
/* = 'T': A'* X = B (Transpose) */
/* = 'C': A'* X = B (Conjugate transpose = Transpose) */
/* DIAG (input) CHARACTER*1 */
/* Specifies whether or not the matrix A is unit triangular. */
/* = 'N': Non-unit triangular */
/* = 'U': Unit triangular */
/* N (input) INTEGER */
/* The number of rows of the matrices X, B, and XACT, and the */
/* order of the matrix A. N >= 0. */
/* NRHS (input) INTEGER */
/* The number of columns of the matrices X, B, and XACT. */
/* NRHS >= 0. */
/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
/* The triangular matrix A. If UPLO = 'U', the leading n by n */
/* upper triangular part of the array A contains the upper */
/* triangular matrix, and the strictly lower triangular part of */
/* A is not referenced. If UPLO = 'L', the leading n by n lower */
/* triangular part of the array A contains the lower triangular */
/* matrix, and the strictly upper triangular part of A is not */
/* referenced. If DIAG = 'U', the diagonal elements of A are */
/* also not referenced and are assumed to be 1. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */
/* The right hand side vectors for the system of linear */
/* equations. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS) */
/* The computed solution vectors. Each vector is stored as a */
/* column of the matrix X. */
/* LDX (input) INTEGER */
/* The leading dimension of the array X. LDX >= max(1,N). */
/* XACT (input) DOUBLE PRECISION array, dimension (LDX,NRHS) */
/* The exact solution vectors. Each vector is stored as a */
/* column of the matrix XACT. */
/* LDXACT (input) INTEGER */
/* The leading dimension of the array XACT. LDXACT >= max(1,N). */
/* FERR (input) DOUBLE PRECISION array, dimension (NRHS) */
/* The estimated forward error bounds for each solution vector */
/* X. If XTRUE is the true solution, FERR bounds the magnitude */
/* of the largest entry in (X - XTRUE) divided by the magnitude */
/* of the largest entry in X. */
/* BERR (input) DOUBLE PRECISION array, dimension (NRHS) */
/* The componentwise relative backward error of each solution */
/* vector (i.e., the smallest relative change in any entry of A */
/* or B that makes X an exact solution). */
/* RESLTS (output) DOUBLE PRECISION array, dimension (2) */
/* The maximum over the NRHS solution vectors of the ratios: */
/* RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR ) */
/* RESLTS(2) = BERR / ( (n+1)*EPS + (*) ) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick exit if N = 0 or NRHS = 0. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
xact_dim1 = *ldxact;
xact_offset = 1 + xact_dim1;
xact -= xact_offset;
--ferr;
--berr;
--reslts;
/* Function Body */
if (*n <= 0 || *nrhs <= 0) {
reslts[1] = 0.;
reslts[2] = 0.;
return 0;
}
eps = dlamch_("Epsilon");
unfl = dlamch_("Safe minimum");
ovfl = 1. / unfl;
upper = lsame_(uplo, "U");
notran = lsame_(trans, "N");
unit = lsame_(diag, "U");
/* Test 1: Compute the maximum of */
/* norm(X - XACT) / ( norm(X) * FERR ) */
/* over all the vectors X and XACT using the infinity-norm. */
errbnd = 0.;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
imax = idamax_(n, &x[j * x_dim1 + 1], &c__1);
/* Computing MAX */
d__2 = (d__1 = x[imax + j * x_dim1], abs(d__1));
xnorm = max(d__2,unfl);
diff = 0.;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
d__2 = diff, d__3 = (d__1 = x[i__ + j * x_dim1] - xact[i__ + j *
xact_dim1], abs(d__1));
diff = max(d__2,d__3);
/* L10: */
}
if (xnorm > 1.) {
goto L20;
} else if (diff <= ovfl * xnorm) {
goto L20;
} else {
errbnd = 1. / eps;
goto L30;
}
L20:
if (diff / xnorm <= ferr[j]) {
/* Computing MAX */
d__1 = errbnd, d__2 = diff / xnorm / ferr[j];
errbnd = max(d__1,d__2);
} else {
errbnd = 1. / eps;
}
L30:
;
}
reslts[1] = errbnd;
/* Test 2: Compute the maximum of BERR / ( (n+1)*EPS + (*) ), where */
/* (*) = (n+1)*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i ) */
ifu = 0;
if (unit) {
ifu = 1;
}
i__1 = *nrhs;
for (k = 1; k <= i__1; ++k) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
tmp = (d__1 = b[i__ + k * b_dim1], abs(d__1));
if (upper) {
if (! notran) {
i__3 = i__ - ifu;
for (j = 1; j <= i__3; ++j) {
tmp += (d__1 = a[j + i__ * a_dim1], abs(d__1)) * (
d__2 = x[j + k * x_dim1], abs(d__2));
/* L40: */
}
if (unit) {
tmp += (d__1 = x[i__ + k * x_dim1], abs(d__1));
}
} else {
if (unit) {
tmp += (d__1 = x[i__ + k * x_dim1], abs(d__1));
}
i__3 = *n;
for (j = i__ + ifu; j <= i__3; ++j) {
tmp += (d__1 = a[i__ + j * a_dim1], abs(d__1)) * (
d__2 = x[j + k * x_dim1], abs(d__2));
/* L50: */
}
}
} else {
if (notran) {
i__3 = i__ - ifu;
for (j = 1; j <= i__3; ++j) {
tmp += (d__1 = a[i__ + j * a_dim1], abs(d__1)) * (
d__2 = x[j + k * x_dim1], abs(d__2));
/* L60: */
}
if (unit) {
tmp += (d__1 = x[i__ + k * x_dim1], abs(d__1));
}
} else {
if (unit) {
tmp += (d__1 = x[i__ + k * x_dim1], abs(d__1));
}
i__3 = *n;
for (j = i__ + ifu; j <= i__3; ++j) {
tmp += (d__1 = a[j + i__ * a_dim1], abs(d__1)) * (
d__2 = x[j + k * x_dim1], abs(d__2));
/* L70: */
}
}
}
if (i__ == 1) {
axbi = tmp;
} else {
axbi = min(axbi,tmp);
}
/* L80: */
}
/* Computing MAX */
d__1 = axbi, d__2 = (*n + 1) * unfl;
tmp = berr[k] / ((*n + 1) * eps + (*n + 1) * unfl / max(d__1,d__2));
if (k == 1) {
reslts[2] = tmp;
} else {
reslts[2] = max(reslts[2],tmp);
}
/* L90: */
}
return 0;
/* End of DTRT05 */
} /* dtrt05_ */
/* 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)
{
/* 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 */
integer i__, j, k, l;
doublereal s, xk;
integer nz;
doublereal eps;
integer kase;
doublereal safe1, safe2;
extern logical lsame_(char *, char *);
integer isave[3];
extern /* Subroutine */ int zhbmv_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *);
integer count;
logical upper;
extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zaxpy_(integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *), zlacn2_(
integer *, doublecomplex *, doublecomplex *, doublereal *,
integer *, integer *);
extern doublereal dlamch_(char *);
doublereal safmin;
extern /* Subroutine */ int xerbla_(char *, integer *);
doublereal lstres;
extern /* Subroutine */ int zpbtrs_(char *, integer *, integer *, integer
*, doublecomplex *, integer *, doublecomplex *, integer *,
integer *);
/* -- LAPACK routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* Modified to call ZLACN2 in place of ZLACON, 10 Feb 03, SJH. */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* 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. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1;
ab -= ab_offset;
afb_dim1 = *ldafb;
afb_offset = 1 + afb_dim1;
afb -= afb_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
--ferr;
--berr;
--work;
--rwork;
/* Function Body */
*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 <= i__1; ++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 <= i__1; ++j) {
count = 1;
lstres = 3.;
L20:
/* Loop until stopping criterion is satisfied. */
/* Compute residual R = B - A * X */
zcopy_(n, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
z__1.r = -1., z__1.i = -0.;
zhbmv_(uplo, n, kd, &z__1, &ab[ab_offset], ldab, &x[j * x_dim1 + 1], &
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 matrix */
/* or vector Z. If the i-th component of the denominator is less */
/* than SAFE2, then SAFE1 is added to the i-th components of the */
/* numerator and denominator before dividing. */
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * b_dim1;
rwork[i__] = (d__1 = b[i__3].r, abs(d__1)) + (d__2 = d_imag(&b[
i__ + j * b_dim1]), abs(d__2));
/* L30: */
}
/* Compute abs(A)*abs(X) + abs(B). */
if (upper) {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
s = 0.;
i__3 = k + j * x_dim1;
xk = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[k + j *
x_dim1]), abs(d__2));
l = *kd + 1 - k;
/* Computing MAX */
i__3 = 1, i__4 = k - *kd;
i__5 = k - 1;
for (i__ = max(i__3,i__4); i__ <= i__5; ++i__) {
i__3 = l + i__ + k * ab_dim1;
rwork[i__] += ((d__1 = ab[i__3].r, abs(d__1)) + (d__2 =
d_imag(&ab[l + i__ + k * ab_dim1]), abs(d__2))) *
xk;
i__3 = l + i__ + k * ab_dim1;
i__4 = i__ + j * x_dim1;
s += ((d__1 = ab[i__3].r, abs(d__1)) + (d__2 = d_imag(&ab[
l + i__ + k * ab_dim1]), abs(d__2))) * ((d__3 = x[
i__4].r, abs(d__3)) + (d__4 = d_imag(&x[i__ + j *
x_dim1]), abs(d__4)));
/* L40: */
}
i__5 = *kd + 1 + k * ab_dim1;
rwork[k] = rwork[k] + (d__1 = ab[i__5].r, abs(d__1)) * xk + s;
/* L50: */
}
} else {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
s = 0.;
i__5 = k + j * x_dim1;
xk = (d__1 = x[i__5].r, abs(d__1)) + (d__2 = d_imag(&x[k + j *
x_dim1]), abs(d__2));
i__5 = k * ab_dim1 + 1;
rwork[k] += (d__1 = ab[i__5].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__ <= i__5; ++i__) {
i__3 = l + i__ + k * ab_dim1;
rwork[i__] += ((d__1 = ab[i__3].r, abs(d__1)) + (d__2 =
d_imag(&ab[l + i__ + k * ab_dim1]), abs(d__2))) *
xk;
i__3 = l + i__ + k * ab_dim1;
i__4 = i__ + j * x_dim1;
s += ((d__1 = ab[i__3].r, abs(d__1)) + (d__2 = d_imag(&ab[
l + i__ + k * ab_dim1]), abs(d__2))) * ((d__3 = x[
i__4].r, abs(d__3)) + (d__4 = d_imag(&x[i__ + j *
x_dim1]), abs(d__4)));
/* L60: */
}
rwork[k] += s;
/* L70: */
}
}
s = 0.;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
if (rwork[i__] > safe2) {
/* Computing MAX */
i__5 = i__;
d__3 = s, d__4 = ((d__1 = work[i__5].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__5].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, and */
/* 2) BERR(J) decreased by at least a factor of 2 during the */
/* last iteration, and */
/* 3) At most ITMAX iterations tried. */
if (berr[j] > eps && berr[j] * 2. <= lstres && count <= 5) {
/* Update solution and try again. */
zpbtrs_(uplo, n, kd, &c__1, &afb[afb_offset], ldafb, &work[1], n,
info);
zaxpy_(n, &c_b1, &work[1], &c__1, &x[j * x_dim1 + 1], &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 or */
/* vector Z */
/* NZ is the maximum number of nonzeros in any row of A, plus 1 */
/* EPS is machine epsilon */
/* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B)) */
/* is incremented by SAFE1 if the i-th component of */
/* abs(A)*abs(X) + abs(B) is less than SAFE2. */
/* Use ZLACN2 to estimate the infinity-norm of the matrix */
/* inv(A) * diag(W), */
/* where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) */
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
if (rwork[i__] > safe2) {
i__5 = i__;
rwork[i__] = (d__1 = work[i__5].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__5].r, abs(d__1)) + (d__2 =
d_imag(&work[i__]), abs(d__2)) + nz * eps * rwork[i__]
+ safe1;
}
/* L90: */
}
kase = 0;
L100:
zlacn2_(n, &work[*n + 1], &work[1], &ferr[j], &kase, isave);
if (kase != 0) {
if (kase == 1) {
/* Multiply by diag(W)*inv(A'). */
zpbtrs_(uplo, n, kd, &c__1, &afb[afb_offset], ldafb, &work[1],
n, info);
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__5 = i__;
i__3 = i__;
i__4 = i__;
z__1.r = rwork[i__3] * work[i__4].r, z__1.i = rwork[i__3]
* work[i__4].i;
work[i__5].r = z__1.r, work[i__5].i = z__1.i;
/* L110: */
}
} else if (kase == 2) {
/* Multiply by inv(A)*diag(W). */
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__5 = i__;
i__3 = i__;
i__4 = i__;
z__1.r = rwork[i__3] * work[i__4].r, z__1.i = rwork[i__3]
* work[i__4].i;
work[i__5].r = z__1.r, work[i__5].i = z__1.i;
/* L120: */
}
zpbtrs_(uplo, n, kd, &c__1, &afb[afb_offset], ldafb, &work[1],
n, info);
}
goto L100;
}
/* Normalize error. */
lstres = 0.;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
i__5 = i__ + j * x_dim1;
d__3 = lstres, d__4 = (d__1 = x[i__5].r, abs(d__1)) + (d__2 =
d_imag(&x[i__ + j * x_dim1]), 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 zptt05_(integer *n, integer *nrhs, doublereal *d__,
doublecomplex *e, doublecomplex *b, integer *ldb, doublecomplex *x,
integer *ldx, doublecomplex *xact, integer *ldxact, doublereal *ferr,
doublereal *berr, doublereal *reslts)
{
/* System generated locals */
integer b_dim1, b_offset, x_dim1, x_offset, xact_dim1, xact_offset, i__1,
i__2, i__3, i__4, i__5, i__6, i__7, i__8, i__9;
doublereal d__1, d__2, d__3, d__4, d__5, d__6, d__7, d__8, d__9, d__10,
d__11, d__12;
doublecomplex z__1, z__2;
/* Builtin functions */
double d_imag(doublecomplex *);
/* Local variables */
static doublereal diff, axbi;
static integer imax;
static doublereal unfl, ovfl;
static integer i__, j, k;
static doublereal xnorm;
extern doublereal dlamch_(char *);
static integer nz;
static doublereal errbnd;
extern integer izamax_(integer *, doublecomplex *, integer *);
static doublereal eps, tmp;
#define xact_subscr(a_1,a_2) (a_2)*xact_dim1 + a_1
#define xact_ref(a_1,a_2) xact[xact_subscr(a_1,a_2)]
#define b_subscr(a_1,a_2) (a_2)*b_dim1 + a_1
#define b_ref(a_1,a_2) b[b_subscr(a_1,a_2)]
#define x_subscr(a_1,a_2) (a_2)*x_dim1 + a_1
#define x_ref(a_1,a_2) x[x_subscr(a_1,a_2)]
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
February 29, 1992
Purpose
=======
ZPTT05 tests the error bounds from iterative refinement for the
computed solution to a system of equations A*X = B, where A is a
Hermitian tridiagonal matrix of order n.
RESLTS(1) = test of the error bound
= norm(X - XACT) / ( norm(X) * FERR )
A large value is returned if this ratio is not less than one.
RESLTS(2) = residual from the iterative refinement routine
= the maximum of BERR / ( NZ*EPS + (*) ), where
(*) = NZ*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i )
and NZ = max. number of nonzeros in any row of A, plus 1
Arguments
=========
N (input) INTEGER
The number of rows of the matrices X, B, and XACT, and the
order of the matrix A. N >= 0.
NRHS (input) INTEGER
The number of columns of the matrices X, B, and XACT.
NRHS >= 0.
D (input) DOUBLE PRECISION array, dimension (N)
The n diagonal elements of the tridiagonal matrix A.
E (input) COMPLEX*16 array, dimension (N-1)
The (n-1) subdiagonal elements of the tridiagonal matrix A.
B (input) COMPLEX*16 array, dimension (LDB,NRHS)
The right hand side vectors for the system of linear
equations.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
X (input) COMPLEX*16 array, dimension (LDX,NRHS)
The computed solution vectors. Each vector is stored as a
column of the matrix X.
LDX (input) INTEGER
The leading dimension of the array X. LDX >= max(1,N).
XACT (input) COMPLEX*16 array, dimension (LDX,NRHS)
The exact solution vectors. Each vector is stored as a
column of the matrix XACT.
LDXACT (input) INTEGER
The leading dimension of the array XACT. LDXACT >= max(1,N).
FERR (input) DOUBLE PRECISION array, dimension (NRHS)
The estimated forward error bounds for each solution vector
X. If XTRUE is the true solution, FERR bounds the magnitude
of the largest entry in (X - XTRUE) divided by the magnitude
of the largest entry in X.
BERR (input) DOUBLE PRECISION array, dimension (NRHS)
The componentwise relative backward error of each solution
vector (i.e., the smallest relative change in any entry of A
or B that makes X an exact solution).
RESLTS (output) DOUBLE PRECISION array, dimension (2)
The maximum over the NRHS solution vectors of the ratios:
RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR )
RESLTS(2) = BERR / ( NZ*EPS + (*) )
=====================================================================
Quick exit if N = 0 or NRHS = 0.
Parameter adjustments */
--d__;
--e;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1 * 1;
x -= x_offset;
xact_dim1 = *ldxact;
xact_offset = 1 + xact_dim1 * 1;
xact -= xact_offset;
--ferr;
--berr;
--reslts;
/* Function Body */
if (*n <= 0 || *nrhs <= 0) {
reslts[1] = 0.;
reslts[2] = 0.;
return 0;
}
eps = dlamch_("Epsilon");
unfl = dlamch_("Safe minimum");
ovfl = 1. / unfl;
nz = 4;
/* Test 1: Compute the maximum of
norm(X - XACT) / ( norm(X) * FERR )
over all the vectors X and XACT using the infinity-norm. */
errbnd = 0.;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
imax = izamax_(n, &x_ref(1, j), &c__1);
/* Computing MAX */
i__2 = x_subscr(imax, j);
d__3 = (d__1 = x[i__2].r, abs(d__1)) + (d__2 = d_imag(&x_ref(imax, j))
, abs(d__2));
xnorm = max(d__3,unfl);
diff = 0.;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = x_subscr(i__, j);
i__4 = xact_subscr(i__, j);
z__2.r = x[i__3].r - xact[i__4].r, z__2.i = x[i__3].i - xact[i__4]
.i;
z__1.r = z__2.r, z__1.i = z__2.i;
/* Computing MAX */
d__3 = diff, d__4 = (d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&
z__1), abs(d__2));
diff = max(d__3,d__4);
/* L10: */
}
if (xnorm > 1.) {
goto L20;
} else if (diff <= ovfl * xnorm) {
goto L20;
} else {
errbnd = 1. / eps;
goto L30;
}
L20:
if (diff / xnorm <= ferr[j]) {
/* Computing MAX */
d__1 = errbnd, d__2 = diff / xnorm / ferr[j];
errbnd = max(d__1,d__2);
} else {
errbnd = 1. / eps;
}
L30:
;
}
reslts[1] = errbnd;
/* Test 2: Compute the maximum of BERR / ( NZ*EPS + (*) ), where
(*) = NZ*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i ) */
i__1 = *nrhs;
for (k = 1; k <= i__1; ++k) {
if (*n == 1) {
i__2 = x_subscr(1, k);
z__2.r = d__[1] * x[i__2].r, z__2.i = d__[1] * x[i__2].i;
z__1.r = z__2.r, z__1.i = z__2.i;
i__3 = b_subscr(1, k);
axbi = (d__1 = b[i__3].r, abs(d__1)) + (d__2 = d_imag(&b_ref(1, k)
), abs(d__2)) + ((d__3 = z__1.r, abs(d__3)) + (d__4 =
d_imag(&z__1), abs(d__4)));
} else {
i__2 = x_subscr(1, k);
z__2.r = d__[1] * x[i__2].r, z__2.i = d__[1] * x[i__2].i;
z__1.r = z__2.r, z__1.i = z__2.i;
i__3 = b_subscr(1, k);
i__4 = x_subscr(2, k);
axbi = (d__1 = b[i__3].r, abs(d__1)) + (d__2 = d_imag(&b_ref(1, k)
), abs(d__2)) + ((d__3 = z__1.r, abs(d__3)) + (d__4 =
d_imag(&z__1), abs(d__4))) + ((d__5 = e[1].r, abs(d__5))
+ (d__6 = d_imag(&e[1]), abs(d__6))) * ((d__7 = x[i__4].r,
abs(d__7)) + (d__8 = d_imag(&x_ref(2, k)), abs(d__8)));
i__2 = *n - 1;
for (i__ = 2; i__ <= i__2; ++i__) {
i__3 = i__;
i__4 = x_subscr(i__, k);
z__2.r = d__[i__3] * x[i__4].r, z__2.i = d__[i__3] * x[i__4]
.i;
z__1.r = z__2.r, z__1.i = z__2.i;
i__5 = b_subscr(i__, k);
i__6 = i__ - 1;
i__7 = x_subscr(i__ - 1, k);
i__8 = i__;
i__9 = x_subscr(i__ + 1, k);
tmp = (d__1 = b[i__5].r, abs(d__1)) + (d__2 = d_imag(&b_ref(
i__, k)), abs(d__2)) + ((d__3 = e[i__6].r, abs(d__3))
+ (d__4 = d_imag(&e[i__ - 1]), abs(d__4))) * ((d__5 =
x[i__7].r, abs(d__5)) + (d__6 = d_imag(&x_ref(i__ - 1,
k)), abs(d__6))) + ((d__7 = z__1.r, abs(d__7)) + (
d__8 = d_imag(&z__1), abs(d__8))) + ((d__9 = e[i__8]
.r, abs(d__9)) + (d__10 = d_imag(&e[i__]), abs(d__10))
) * ((d__11 = x[i__9].r, abs(d__11)) + (d__12 =
d_imag(&x_ref(i__ + 1, k)), abs(d__12)));
axbi = min(axbi,tmp);
/* L40: */
}
i__2 = *n;
i__3 = x_subscr(*n, k);
z__2.r = d__[i__2] * x[i__3].r, z__2.i = d__[i__2] * x[i__3].i;
z__1.r = z__2.r, z__1.i = z__2.i;
i__4 = b_subscr(*n, k);
i__5 = *n - 1;
i__6 = x_subscr(*n - 1, k);
tmp = (d__1 = b[i__4].r, abs(d__1)) + (d__2 = d_imag(&b_ref(*n, k)
), abs(d__2)) + ((d__3 = e[i__5].r, abs(d__3)) + (d__4 =
d_imag(&e[*n - 1]), abs(d__4))) * ((d__5 = x[i__6].r, abs(
d__5)) + (d__6 = d_imag(&x_ref(*n - 1, k)), abs(d__6))) +
((d__7 = z__1.r, abs(d__7)) + (d__8 = d_imag(&z__1), abs(
d__8)));
axbi = min(axbi,tmp);
}
/* Computing MAX */
d__1 = axbi, d__2 = nz * unfl;
tmp = berr[k] / (nz * eps + nz * unfl / max(d__1,d__2));
if (k == 1) {
reslts[2] = tmp;
} else {
reslts[2] = max(reslts[2],tmp);
}
/* L50: */
}
return 0;
/* End of ZPTT05 */
} /* zptt05_ */
/* Subroutine */ int dppsvx_(char *fact, char *uplo, integer *n, integer *
nrhs, doublereal *ap, doublereal *afp, char *equed, doublereal *s,
doublereal *b, integer *ldb, doublereal *x, integer *ldx, doublereal *
rcond, doublereal *ferr, doublereal *berr, doublereal *work, integer *
iwork, integer *info)
{
/* System generated locals */
integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2;
doublereal d__1, d__2;
/* Local variables */
integer i__, j;
doublereal amax, smin, smax;
extern logical lsame_(char *, char *);
doublereal scond, anorm;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *);
logical equil, rcequ;
extern doublereal dlamch_(char *);
logical nofact;
extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *),
xerbla_(char *, integer *);
doublereal bignum;
extern doublereal dlansp_(char *, char *, integer *, doublereal *,
doublereal *);
extern /* Subroutine */ int dppcon_(char *, integer *, doublereal *,
doublereal *, doublereal *, doublereal *, integer *, integer *), dlaqsp_(char *, integer *, doublereal *, doublereal *,
doublereal *, doublereal *, char *);
integer infequ;
extern /* Subroutine */ int dppequ_(char *, integer *, doublereal *,
doublereal *, doublereal *, doublereal *, integer *),
dpprfs_(char *, integer *, integer *, doublereal *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *, doublereal *, integer *, integer *),
dpptrf_(char *, integer *, doublereal *, integer *);
doublereal smlnum;
extern /* Subroutine */ int dpptrs_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *);
/* -- LAPACK driver routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DPPSVX uses the Cholesky factorization A = U**T*U or A = L*L**T to */
/* compute the solution to a real system of linear equations */
/* A * X = B, */
/* where A is an N-by-N symmetric positive definite matrix stored in */
/* packed format and X and B are N-by-NRHS matrices. */
/* Error bounds on the solution and a condition estimate are also */
/* provided. */
/* Description */
/* =========== */
/* The following steps are performed: */
/* 1. If FACT = 'E', real scaling factors are computed to equilibrate */
/* the system: */
/* diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B */
/* Whether or not the system will be equilibrated depends on the */
/* scaling of the matrix A, but if equilibration is used, A is */
/* overwritten by diag(S)*A*diag(S) and B by diag(S)*B. */
/* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to */
/* factor the matrix A (after equilibration if FACT = 'E') as */
/* A = U**T* U, if UPLO = 'U', or */
/* A = L * L**T, if UPLO = 'L', */
/* where U is an upper triangular matrix and L is a lower triangular */
/* matrix. */
/* 3. If the leading i-by-i principal minor is not positive definite, */
/* then the routine returns with INFO = i. Otherwise, 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, INFO = N+1 is returned as a warning, but the routine */
/* still goes on to solve for X and compute error bounds as */
/* described below. */
/* 4. The system of equations is solved for X using the factored form */
/* of A. */
/* 5. Iterative refinement is applied to improve the computed solution */
/* matrix and calculate error bounds and backward error estimates */
/* for it. */
/* 6. If equilibration was used, the matrix X is premultiplied by */
/* diag(S) so that it solves the original system before */
/* equilibration. */
/* Arguments */
/* ========= */
/* FACT (input) CHARACTER*1 */
/* Specifies whether or not the factored form of the matrix A is */
/* supplied on entry, and if not, whether the matrix A should be */
/* equilibrated before it is factored. */
/* = 'F': On entry, AFP contains the factored form of A. */
/* If EQUED = 'Y', the matrix A has been equilibrated */
/* with scaling factors given by S. AP and AFP will not */
/* be modified. */
/* = 'N': The matrix A will be copied to AFP and factored. */
/* = 'E': The matrix A will be equilibrated if necessary, then */
/* copied to AFP 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. */
/* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
/* On entry, the upper or lower triangle of the symmetric matrix */
/* A, packed columnwise in a linear array, except if FACT = 'F' */
/* and EQUED = 'Y', then A must contain the equilibrated matrix */
/* diag(S)*A*diag(S). 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)*(2n-j)/2) = A(i,j) for j<=i<=n. */
/* See below for further details. A is not modified if */
/* FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit. */
/* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by */
/* diag(S)*A*diag(S). */
/* AFP (input or output) DOUBLE PRECISION array, dimension */
/* (N*(N+1)/2) */
/* If FACT = 'F', then AFP is an input argument and on entry */
/* contains the triangular factor U or L from the Cholesky */
/* factorization A = U'*U or A = L*L', in the same storage */
/* format as A. If EQUED .ne. 'N', then AFP is the factored */
/* form of the equilibrated matrix A. */
/* If FACT = 'N', then AFP is an output argument and on exit */
/* returns the triangular factor U or L from the Cholesky */
/* factorization A = U'*U or A = L*L' of the original matrix A. */
/* If FACT = 'E', then AFP is an output argument and on exit */
/* returns the triangular factor U or L from the Cholesky */
/* factorization A = U'*U or A = L*L' of the equilibrated */
/* matrix A (see the description of AP for the form of the */
/* equilibrated matrix). */
/* EQUED (input or output) CHARACTER*1 */
/* Specifies the form of equilibration that was done. */
/* = 'N': No equilibration (always true if FACT = 'N'). */
/* = 'Y': Equilibration was done, i.e., A has been replaced by */
/* diag(S) * A * diag(S). */
/* EQUED is an input argument if FACT = 'F'; otherwise, it is an */
/* output argument. */
/* S (input or output) DOUBLE PRECISION array, dimension (N) */
/* The scale factors for A; not accessed if EQUED = 'N'. S is */
/* an input argument if FACT = 'F'; otherwise, S is an output */
/* argument. If FACT = 'F' and EQUED = 'Y', each element of S */
/* must be positive. */
/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
/* On entry, the N-by-NRHS right hand side matrix B. */
/* On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y', */
/* B is overwritten by diag(S) * B. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS) */
/* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to */
/* the original system of equations. Note that if EQUED = 'Y', */
/* A and B are modified on exit, and the solution to the */
/* equilibrated system is inv(diag(S))*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 after equilibration (if done). 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. */
/* 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) DOUBLE PRECISION array, dimension (3*N) */
/* IWORK (workspace) INTEGER 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: the leading minor of order i of A is */
/* not positive definite, so the factorization */
/* could not be completed, and the solution has not */
/* been computed. RCOND = 0 is returned. */
/* = N+1: U is nonsingular, but RCOND is less than machine */
/* precision, meaning that the matrix is singular */
/* to working precision. Nevertheless, the */
/* solution and error bounds are computed because */
/* there are a number of situations where the */
/* computed solution can be more accurate than the */
/* value of RCOND would suggest. */
/* Further Details */
/* =============== */
/* The packed storage scheme is illustrated by the following example */
/* when N = 4, UPLO = 'U': */
/* Two-dimensional storage of the symmetric matrix A: */
/* a11 a12 a13 a14 */
/* a22 a23 a24 */
/* a33 a34 (aij = conjg(aji)) */
/* a44 */
/* Packed storage of the upper triangle of A: */
/* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ] */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--ap;
--afp;
--s;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
--ferr;
--berr;
--work;
--iwork;
/* Function Body */
*info = 0;
nofact = lsame_(fact, "N");
equil = lsame_(fact, "E");
if (nofact || equil) {
*(unsigned char *)equed = 'N';
rcequ = FALSE_;
} else {
rcequ = lsame_(equed, "Y");
smlnum = dlamch_("Safe minimum");
bignum = 1. / smlnum;
}
/* Test the input parameters. */
if (! nofact && ! equil && ! 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 (lsame_(fact, "F") && ! (rcequ || lsame_(
equed, "N"))) {
*info = -7;
} else {
if (rcequ) {
smin = bignum;
smax = 0.;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
d__1 = smin, d__2 = s[j];
smin = min(d__1,d__2);
/* Computing MAX */
d__1 = smax, d__2 = s[j];
smax = max(d__1,d__2);
/* L10: */
}
if (smin <= 0.) {
*info = -8;
} else if (*n > 0) {
scond = max(smin,smlnum) / min(smax,bignum);
} else {
scond = 1.;
}
}
if (*info == 0) {
if (*ldb < max(1,*n)) {
*info = -10;
} else if (*ldx < max(1,*n)) {
*info = -12;
}
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DPPSVX", &i__1);
return 0;
}
if (equil) {
/* Compute row and column scalings to equilibrate the matrix A. */
dppequ_(uplo, n, &ap[1], &s[1], &scond, &amax, &infequ);
if (infequ == 0) {
/* Equilibrate the matrix. */
dlaqsp_(uplo, n, &ap[1], &s[1], &scond, &amax, equed);
rcequ = lsame_(equed, "Y");
}
}
/* Scale the right-hand side. */
if (rcequ) {
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
b[i__ + j * b_dim1] = s[i__] * b[i__ + j * b_dim1];
/* L20: */
}
/* L30: */
}
}
if (nofact || equil) {
/* Compute the Cholesky factorization A = U'*U or A = L*L'. */
i__1 = *n * (*n + 1) / 2;
dcopy_(&i__1, &ap[1], &c__1, &afp[1], &c__1);
dpptrf_(uplo, n, &afp[1], info);
/* Return if INFO is non-zero. */
if (*info > 0) {
*rcond = 0.;
return 0;
}
}
/* Compute the norm of the matrix A. */
anorm = dlansp_("I", uplo, n, &ap[1], &work[1]);
/* Compute the reciprocal of the condition number of A. */
dppcon_(uplo, n, &afp[1], &anorm, rcond, &work[1], &iwork[1], info);
/* Compute the solution matrix X. */
dlacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
dpptrs_(uplo, n, nrhs, &afp[1], &x[x_offset], ldx, info);
/* Use iterative refinement to improve the computed solution and */
/* compute error bounds and backward error estimates for it. */
dpprfs_(uplo, n, nrhs, &ap[1], &afp[1], &b[b_offset], ldb, &x[x_offset],
ldx, &ferr[1], &berr[1], &work[1], &iwork[1], info);
/* Transform the solution matrix X to a solution of the original */
/* system. */
if (rcequ) {
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
x[i__ + j * x_dim1] = s[i__] * x[i__ + j * x_dim1];
/* L40: */
}
/* L50: */
}
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
ferr[j] /= scond;
/* L60: */
}
}
/* Set INFO = N+1 if the matrix is singular to working precision. */
if (*rcond < dlamch_("Epsilon")) {
*info = *n + 1;
}
return 0;
/* End of DPPSVX */
} /* dppsvx_ */
/* Subroutine */ int dppcon_(char *uplo, integer *n, doublereal *ap,
doublereal *anorm, doublereal *rcond, doublereal *work, integer *
iwork, integer *info)
{
/* System generated locals */
integer i__1;
doublereal d__1;
/* Local variables */
integer ix, kase;
doublereal scale;
extern logical lsame_(char *, char *);
integer isave[3];
extern /* Subroutine */ int drscl_(integer *, doublereal *, doublereal *,
integer *);
logical upper;
extern /* Subroutine */ int dlacn2_(integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, integer *);
extern doublereal dlamch_(char *);
doublereal scalel;
extern integer idamax_(integer *, doublereal *, integer *);
doublereal scaleu;
extern /* Subroutine */ int xerbla_(char *, integer *), dlatps_(
char *, char *, char *, char *, integer *, doublereal *,
doublereal *, doublereal *, doublereal *, integer *);
doublereal ainvnm;
char normin[1];
doublereal smlnum;
/* -- LAPACK routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DPPCON estimates the reciprocal of the condition number (in the */
/* 1-norm) of a real symmetric positive definite packed matrix using */
/* the Cholesky factorization A = U**T*U or A = L*L**T computed by */
/* DPPTRF. */
/* 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) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
/* The triangular factor U or L from the Cholesky factorization */
/* A = U**T*U or A = L*L**T, 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 symmetric 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) DOUBLE PRECISION array, dimension (3*N) */
/* IWORK (workspace) INTEGER array, dimension (N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--iwork;
--work;
--ap;
/* Function Body */
*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_("DPPCON", &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:
dlacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave);
if (kase != 0) {
if (upper) {
/* Multiply by inv(U'). */
dlatps_("Upper", "Transpose", "Non-unit", normin, n, &ap[1], &
work[1], &scalel, &work[(*n << 1) + 1], info);
*(unsigned char *)normin = 'Y';
/* Multiply by inv(U). */
dlatps_("Upper", "No transpose", "Non-unit", normin, n, &ap[1], &
work[1], &scaleu, &work[(*n << 1) + 1], info);
} else {
/* Multiply by inv(L). */
dlatps_("Lower", "No transpose", "Non-unit", normin, n, &ap[1], &
work[1], &scalel, &work[(*n << 1) + 1], info);
*(unsigned char *)normin = 'Y';
/* Multiply by inv(L'). */
dlatps_("Lower", "Transpose", "Non-unit", normin, n, &ap[1], &
work[1], &scaleu, &work[(*n << 1) + 1], info);
}
/* Multiply by 1/SCALE if doing so will not cause overflow. */
scale = scalel * scaleu;
if (scale != 1.) {
ix = idamax_(n, &work[1], &c__1);
if (scale < (d__1 = work[ix], abs(d__1)) * smlnum || scale == 0.)
{
goto L20;
}
drscl_(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 DPPCON */
} /* dppcon_ */
/* Subroutine */ int dget10_(integer *m, integer *n, doublereal *a, integer *
lda, doublereal *b, integer *ldb, doublereal *work, doublereal *
result)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1;
doublereal d__1, d__2;
/* Local variables */
static doublereal unfl;
static integer j;
extern doublereal dasum_(integer *, doublereal *, integer *);
static doublereal anorm;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *), daxpy_(integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *);
static doublereal wnorm;
extern doublereal dlamch_(char *), dlange_(char *, integer *,
integer *, doublereal *, integer *, doublereal *);
static doublereal eps;
#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
#define b_ref(a_1,a_2) b[(a_2)*b_dim1 + a_1]
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
February 29, 1992
Purpose
=======
DGET10 compares two matrices A and B and computes the ratio
RESULT = norm( A - B ) / ( norm(A) * M * EPS )
Arguments
=========
M (input) INTEGER
The number of rows of the matrices A and B.
N (input) INTEGER
The number of columns of the matrices A and B.
A (input) DOUBLE PRECISION array, dimension (LDA,N)
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)
The m by n matrix B.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,M).
WORK (workspace) DOUBLE PRECISION array, dimension (M)
RESULT (output) DOUBLE PRECISION
RESULT = norm( A - B ) / ( norm(A) * M * EPS )
=====================================================================
Quick return if possible
Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
--work;
/* Function Body */
if (*m <= 0 || *n <= 0) {
*result = 0.;
return 0;
}
unfl = dlamch_("Safe minimum");
eps = dlamch_("Precision");
wnorm = 0.;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
dcopy_(m, &a_ref(1, j), &c__1, &work[1], &c__1);
daxpy_(m, &c_b7, &b_ref(1, j), &c__1, &work[1], &c__1);
/* Computing MAX */
d__1 = wnorm, d__2 = dasum_(n, &work[1], &c__1);
wnorm = max(d__1,d__2);
/* L10: */
}
/* Computing MAX */
d__1 = dlange_("1", m, n, &a[a_offset], lda, &work[1]);
anorm = max(d__1,unfl);
if (anorm > wnorm) {
*result = wnorm / anorm / (*m * eps);
} else {
if (anorm < 1.) {
/* Computing MIN */
d__1 = wnorm, d__2 = *m * anorm;
*result = min(d__1,d__2) / anorm / (*m * eps);
} else {
/* Computing MIN */
d__1 = wnorm / anorm, d__2 = (doublereal) (*m);
*result = min(d__1,d__2) / (*m * eps);
}
}
return 0;
/* End of DGET10 */
} /* dget10_ */
/* Subroutine */ int dsyequb_(char *uplo, integer *n, doublereal *a, integer *
lda, doublereal *s, doublereal *scond, doublereal *amax, doublereal *
work, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
doublereal d__1, d__2, d__3;
/* Builtin functions */
double sqrt(doublereal), log(doublereal), pow_di(doublereal *, integer *);
/* Local variables */
doublereal d__;
integer i__, j;
doublereal t, u, c0, c1, c2, si;
logical up;
doublereal avg, std, tol, base;
integer iter;
doublereal smin, smax, scale;
extern logical lsame_(char *, char *);
doublereal sumsq;
extern doublereal dlamch_(char *);
extern /* Subroutine */ int xerbla_(char *, integer *);
doublereal bignum;
extern /* Subroutine */ int dlassq_(integer *, doublereal *, integer *,
doublereal *, doublereal *);
doublereal smlnum;
/* -- LAPACK routine (version 3.2) -- */
/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
/* -- Jason Riedy of Univ. of California Berkeley. -- */
/* -- November 2008 -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley and NAG Ltd. -- */
/* .. */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DSYEQUB computes row and column scalings intended to equilibrate a */
/* symmetric matrix A and reduce its condition number */
/* (with respect to the two-norm). S contains the scale factors, */
/* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with */
/* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This */
/* choice of S puts the condition number of B within a factor N of the */
/* smallest possible condition number over all possible diagonal */
/* scalings. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
/* The N-by-N symmetric matrix whose scaling */
/* factors are to be computed. Only the diagonal elements of A */
/* are referenced. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* S (output) DOUBLE PRECISION array, dimension (N) */
/* If INFO = 0, S contains the scale factors for A. */
/* SCOND (output) DOUBLE PRECISION */
/* If INFO = 0, S contains the ratio of the smallest S(i) to */
/* the largest S(i). If SCOND >= 0.1 and AMAX is neither too */
/* large nor too small, it is not worth scaling by S. */
/* AMAX (output) DOUBLE PRECISION */
/* Absolute value of largest matrix element. If AMAX is very */
/* close to overflow or very close to underflow, the matrix */
/* should be scaled. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, the i-th diagonal element is nonpositive. */
/* Further Details */
/* ======= ======= */
/* Reference: Livne, O.E. and Golub, G.H., "Scaling by Binormalization", */
/* Numerical Algorithms, vol. 35, no. 1, pp. 97-120, January 2004. */
/* DOI 10.1023/B:NUMA.0000016606.32820.69 */
/* Tech report version: http://ruready.utah.edu/archive/papers/bin.pdf */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Executable Statements .. */
/* Test input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--s;
--work;
/* Function Body */
*info = 0;
if (! (lsame_(uplo, "U") || lsame_(uplo, "L"))) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*n)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DSYEQUB", &i__1);
return 0;
}
up = lsame_(uplo, "U");
*amax = 0.;
/* Quick return if possible. */
if (*n == 0) {
*scond = 1.;
return 0;
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
s[i__] = 0.;
}
*amax = 0.;
if (up) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
d__2 = s[i__], d__3 = (d__1 = a[i__ + j * a_dim1], abs(d__1));
s[i__] = max(d__2,d__3);
/* Computing MAX */
d__2 = s[j], d__3 = (d__1 = a[i__ + j * a_dim1], abs(d__1));
s[j] = max(d__2,d__3);
/* Computing MAX */
d__2 = *amax, d__3 = (d__1 = a[i__ + j * a_dim1], abs(d__1));
*amax = max(d__2,d__3);
}
/* Computing MAX */
d__2 = s[j], d__3 = (d__1 = a[j + j * a_dim1], abs(d__1));
s[j] = max(d__2,d__3);
/* Computing MAX */
d__2 = *amax, d__3 = (d__1 = a[j + j * a_dim1], abs(d__1));
*amax = max(d__2,d__3);
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
d__2 = s[j], d__3 = (d__1 = a[j + j * a_dim1], abs(d__1));
s[j] = max(d__2,d__3);
/* Computing MAX */
d__2 = *amax, d__3 = (d__1 = a[j + j * a_dim1], abs(d__1));
*amax = max(d__2,d__3);
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
/* Computing MAX */
d__2 = s[i__], d__3 = (d__1 = a[i__ + j * a_dim1], abs(d__1));
s[i__] = max(d__2,d__3);
/* Computing MAX */
d__2 = s[j], d__3 = (d__1 = a[i__ + j * a_dim1], abs(d__1));
s[j] = max(d__2,d__3);
/* Computing MAX */
d__2 = *amax, d__3 = (d__1 = a[i__ + j * a_dim1], abs(d__1));
*amax = max(d__2,d__3);
}
}
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
s[j] = 1. / s[j];
}
tol = 1. / sqrt(*n * 2.);
for (iter = 1; iter <= 100; ++iter) {
scale = 0.;
sumsq = 0.;
/* BETA = |A|S */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 0.;
}
if (up) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
t = (d__1 = a[i__ + j * a_dim1], abs(d__1));
work[i__] += (d__1 = a[i__ + j * a_dim1], abs(d__1)) * s[
j];
work[j] += (d__1 = a[i__ + j * a_dim1], abs(d__1)) * s[
i__];
}
work[j] += (d__1 = a[j + j * a_dim1], abs(d__1)) * s[j];
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
work[j] += (d__1 = a[j + j * a_dim1], abs(d__1)) * s[j];
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
t = (d__1 = a[i__ + j * a_dim1], abs(d__1));
work[i__] += (d__1 = a[i__ + j * a_dim1], abs(d__1)) * s[
j];
work[j] += (d__1 = a[i__ + j * a_dim1], abs(d__1)) * s[
i__];
}
}
}
/* avg = s^T beta / n */
avg = 0.;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
avg += s[i__] * work[i__];
}
avg /= *n;
std = 0.;
i__1 = *n * 3;
for (i__ = (*n << 1) + 1; i__ <= i__1; ++i__) {
work[i__] = s[i__ - (*n << 1)] * work[i__ - (*n << 1)] - avg;
}
dlassq_(n, &work[(*n << 1) + 1], &c__1, &scale, &sumsq);
std = scale * sqrt(sumsq / *n);
if (std < tol * avg) {
goto L999;
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
t = (d__1 = a[i__ + i__ * a_dim1], abs(d__1));
si = s[i__];
c2 = (*n - 1) * t;
c1 = (*n - 2) * (work[i__] - t * si);
c0 = -(t * si) * si + work[i__] * 2 * si - *n * avg;
d__ = c1 * c1 - c0 * 4 * c2;
if (d__ <= 0.) {
*info = -1;
return 0;
}
si = c0 * -2 / (c1 + sqrt(d__));
d__ = si - s[i__];
u = 0.;
if (up) {
i__2 = i__;
for (j = 1; j <= i__2; ++j) {
t = (d__1 = a[j + i__ * a_dim1], abs(d__1));
u += s[j] * t;
work[j] += d__ * t;
}
i__2 = *n;
for (j = i__ + 1; j <= i__2; ++j) {
t = (d__1 = a[i__ + j * a_dim1], abs(d__1));
u += s[j] * t;
work[j] += d__ * t;
}
} else {
i__2 = i__;
for (j = 1; j <= i__2; ++j) {
t = (d__1 = a[i__ + j * a_dim1], abs(d__1));
u += s[j] * t;
work[j] += d__ * t;
}
i__2 = *n;
for (j = i__ + 1; j <= i__2; ++j) {
t = (d__1 = a[j + i__ * a_dim1], abs(d__1));
u += s[j] * t;
work[j] += d__ * t;
}
}
avg += (u + work[i__]) * d__ / *n;
s[i__] = si;
}
}
L999:
smlnum = dlamch_("SAFEMIN");
bignum = 1. / smlnum;
smin = bignum;
smax = 0.;
t = 1. / sqrt(avg);
base = dlamch_("B");
u = 1. / log(base);
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = (integer) (u * log(s[i__] * t));
s[i__] = pow_di(&base, &i__2);
/* Computing MIN */
d__1 = smin, d__2 = s[i__];
smin = min(d__1,d__2);
/* Computing MAX */
d__1 = smax, d__2 = s[i__];
smax = max(d__1,d__2);
}
*scond = max(smin,smlnum) / min(smax,bignum);
return 0;
} /* dsyequb_ */
doublereal zqrt14_(char *trans, integer *m, integer *n, integer *nrhs,
doublecomplex *a, integer *lda, doublecomplex *x, integer *ldx,
doublecomplex *work, integer *lwork)
{
/* System generated locals */
integer a_dim1, a_offset, x_dim1, x_offset, i__1, i__2, i__3;
doublereal ret_val, d__1, d__2;
doublecomplex z__1;
/* Builtin functions */
double z_abs(doublecomplex *);
void d_cnjg(doublecomplex *, doublecomplex *);
/* Local variables */
integer i__, j;
doublereal err;
integer info;
doublereal anrm;
logical tpsd;
doublereal xnrm;
extern logical lsame_(char *, char *);
doublereal rwork[1];
extern /* Subroutine */ int zgelq2_(integer *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *), zgeqr2_(
integer *, integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *);
extern doublereal dlamch_(char *);
extern /* Subroutine */ int xerbla_(char *, integer *);
extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
integer *, doublereal *);
extern /* Subroutine */ int zlascl_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublecomplex *,
integer *, integer *);
integer ldwork;
extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZQRT14 checks whether X is in the row space of A or A'. It does so */
/* by scaling both X and A such that their norms are in the range */
/* [sqrt(eps), 1/sqrt(eps)], then computing a QR factorization of [A,X] */
/* (if TRANS = 'C') or an LQ factorization of [A',X]' (if TRANS = 'N'), */
/* and returning the norm of the trailing triangle, scaled by */
/* MAX(M,N,NRHS)*eps. */
/* Arguments */
/* ========= */
/* TRANS (input) CHARACTER*1 */
/* = 'N': No transpose, check for X in the row space of A */
/* = 'C': Conjugate transpose, check for X in row space of A'. */
/* M (input) INTEGER */
/* The number of rows of the matrix A. */
/* N (input) INTEGER */
/* The number of columns of the matrix A. */
/* NRHS (input) INTEGER */
/* The number of right hand sides, i.e., the number of columns */
/* of X. */
/* A (input) COMPLEX*16 array, dimension (LDA,N) */
/* The M-by-N matrix A. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. */
/* X (input) COMPLEX*16 array, dimension (LDX,NRHS) */
/* If TRANS = 'N', the N-by-NRHS matrix X. */
/* IF TRANS = 'C', the M-by-NRHS matrix X. */
/* LDX (input) INTEGER */
/* The leading dimension of the array X. */
/* WORK (workspace) COMPLEX*16 array dimension (LWORK) */
/* LWORK (input) INTEGER */
/* length of workspace array required */
/* If TRANS = 'N', LWORK >= (M+NRHS)*(N+2); */
/* if TRANS = 'C', LWORK >= (N+NRHS)*(M+2). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
--work;
/* Function Body */
ret_val = 0.;
if (lsame_(trans, "N")) {
ldwork = *m + *nrhs;
tpsd = FALSE_;
if (*lwork < (*m + *nrhs) * (*n + 2)) {
xerbla_("ZQRT14", &c__10);
return ret_val;
} else if (*n <= 0 || *nrhs <= 0) {
return ret_val;
}
} else if (lsame_(trans, "C")) {
ldwork = *m;
tpsd = TRUE_;
if (*lwork < (*n + *nrhs) * (*m + 2)) {
xerbla_("ZQRT14", &c__10);
return ret_val;
} else if (*m <= 0 || *nrhs <= 0) {
return ret_val;
}
} else {
xerbla_("ZQRT14", &c__1);
return ret_val;
}
/* Copy and scale A */
zlacpy_("All", m, n, &a[a_offset], lda, &work[1], &ldwork);
anrm = zlange_("M", m, n, &work[1], &ldwork, rwork);
if (anrm != 0.) {
zlascl_("G", &c__0, &c__0, &anrm, &c_b15, m, n, &work[1], &ldwork, &
info);
}
/* Copy X or X' into the right place and scale it */
if (tpsd) {
/* Copy X into columns n+1:n+nrhs of work */
zlacpy_("All", m, nrhs, &x[x_offset], ldx, &work[*n * ldwork + 1], &
ldwork);
xnrm = zlange_("M", m, nrhs, &work[*n * ldwork + 1], &ldwork, rwork);
if (xnrm != 0.) {
zlascl_("G", &c__0, &c__0, &xnrm, &c_b15, m, nrhs, &work[*n *
ldwork + 1], &ldwork, &info);
}
i__1 = *n + *nrhs;
anrm = zlange_("One-norm", m, &i__1, &work[1], &ldwork, rwork);
/* Compute QR factorization of X */
i__1 = *n + *nrhs;
/* Computing MIN */
i__2 = *m, i__3 = *n + *nrhs;
zgeqr2_(m, &i__1, &work[1], &ldwork, &work[ldwork * (*n + *nrhs) + 1],
&work[ldwork * (*n + *nrhs) + min(i__2, i__3)+ 1], &info);
/* Compute largest entry in upper triangle of */
/* work(n+1:m,n+1:n+nrhs) */
err = 0.;
i__1 = *n + *nrhs;
for (j = *n + 1; j <= i__1; ++j) {
i__2 = min(*m,j);
for (i__ = *n + 1; i__ <= i__2; ++i__) {
/* Computing MAX */
d__1 = err, d__2 = z_abs(&work[i__ + (j - 1) * *m]);
err = max(d__1,d__2);
/* L10: */
}
/* L20: */
}
} else {
/* Copy X' into rows m+1:m+nrhs of work */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = *nrhs;
for (j = 1; j <= i__2; ++j) {
i__3 = *m + j + (i__ - 1) * ldwork;
d_cnjg(&z__1, &x[i__ + j * x_dim1]);
work[i__3].r = z__1.r, work[i__3].i = z__1.i;
/* L30: */
}
/* L40: */
}
xnrm = zlange_("M", nrhs, n, &work[*m + 1], &ldwork, rwork)
;
if (xnrm != 0.) {
zlascl_("G", &c__0, &c__0, &xnrm, &c_b15, nrhs, n, &work[*m + 1],
&ldwork, &info);
}
/* Compute LQ factorization of work */
zgelq2_(&ldwork, n, &work[1], &ldwork, &work[ldwork * *n + 1], &work[
ldwork * (*n + 1) + 1], &info);
/* Compute largest entry in lower triangle in */
/* work(m+1:m+nrhs,m+1:n) */
err = 0.;
i__1 = *n;
for (j = *m + 1; j <= i__1; ++j) {
i__2 = ldwork;
for (i__ = j; i__ <= i__2; ++i__) {
/* Computing MAX */
d__1 = err, d__2 = z_abs(&work[i__ + (j - 1) * ldwork]);
err = max(d__1,d__2);
/* L50: */
}
/* L60: */
}
}
/* Computing MAX */
i__1 = max(*m,*n);
ret_val = err / ((doublereal) max(i__1,*nrhs) * dlamch_("Epsilon"));
return ret_val;
/* End of ZQRT14 */
} /* zqrt14_ */
/* Subroutine */ int zsteqr_(char *compz, integer *n, doublereal *d__,
doublereal *e, doublecomplex *z__, integer *ldz, doublereal *work,
integer *info)
{
/* System generated locals */
integer z_dim1, z_offset, i__1, i__2;
doublereal d__1, d__2;
/* Builtin functions */
double sqrt(doublereal), d_sign(doublereal *, doublereal *);
/* Local variables */
doublereal b, c__, f, g;
integer i__, j, k, l, m;
doublereal p, r__, s;
integer l1, ii, mm, lm1, mm1, nm1;
doublereal rt1, rt2, eps;
integer lsv;
doublereal tst, eps2;
integer lend, jtot;
extern /* Subroutine */ int dlae2_(doublereal *, doublereal *, doublereal
*, doublereal *, doublereal *);
extern logical lsame_(char *, char *);
doublereal anorm;
extern /* Subroutine */ int zlasr_(char *, char *, char *, integer *,
integer *, doublereal *, doublereal *, doublecomplex *, integer *), zswap_(integer *, doublecomplex *,
integer *, doublecomplex *, integer *), dlaev2_(doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *);
integer lendm1, lendp1;
extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *);
integer iscale;
extern /* Subroutine */ int dlascl_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *);
doublereal safmin;
extern /* Subroutine */ int dlartg_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *);
doublereal safmax;
extern /* Subroutine */ int xerbla_(char *, integer *);
extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *);
extern /* Subroutine */ int dlasrt_(char *, integer *, doublereal *,
integer *);
integer lendsv;
doublereal ssfmin;
integer nmaxit, icompz;
doublereal ssfmax;
extern /* Subroutine */ int zlaset_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZSTEQR computes all eigenvalues and, optionally, eigenvectors of a */
/* symmetric tridiagonal matrix using the implicit QL or QR method. */
/* The eigenvectors of a full or band complex Hermitian matrix can also */
/* be found if ZHETRD or ZHPTRD or ZHBTRD has been used to reduce this */
/* matrix to tridiagonal form. */
/* Arguments */
/* ========= */
/* COMPZ (input) CHARACTER*1 */
/* = 'N': Compute eigenvalues only. */
/* = 'V': Compute eigenvalues and eigenvectors of the original */
/* Hermitian matrix. On entry, Z must contain the */
/* unitary matrix used to reduce the original matrix */
/* to tridiagonal form. */
/* = 'I': Compute eigenvalues and eigenvectors of the */
/* tridiagonal matrix. Z is initialized to the identity */
/* matrix. */
/* N (input) INTEGER */
/* The order of the matrix. N >= 0. */
/* D (input/output) DOUBLE PRECISION array, dimension (N) */
/* On entry, the diagonal elements of the tridiagonal matrix. */
/* On exit, if INFO = 0, the eigenvalues in ascending order. */
/* E (input/output) DOUBLE PRECISION array, dimension (N-1) */
/* On entry, the (n-1) subdiagonal elements of the tridiagonal */
/* matrix. */
/* On exit, E has been destroyed. */
/* Z (input/output) COMPLEX*16 array, dimension (LDZ, N) */
/* On entry, if COMPZ = 'V', then Z contains the unitary */
/* matrix used in the reduction to tridiagonal form. */
/* On exit, if INFO = 0, then if COMPZ = 'V', Z contains the */
/* orthonormal eigenvectors of the original Hermitian matrix, */
/* and if COMPZ = 'I', Z contains the orthonormal eigenvectors */
/* of the symmetric tridiagonal matrix. */
/* If COMPZ = 'N', then Z is not referenced. */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. LDZ >= 1, and if */
/* eigenvectors are desired, then LDZ >= max(1,N). */
/* WORK (workspace) DOUBLE PRECISION array, dimension (max(1,2*N-2)) */
/* If COMPZ = 'N', then WORK is not referenced. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: the algorithm has failed to find all the eigenvalues in */
/* a total of 30*N iterations; if INFO = i, then i */
/* elements of E have not converged to zero; on exit, D */
/* and E contain the elements of a symmetric tridiagonal */
/* matrix which is unitarily similar to the original */
/* matrix. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--d__;
--e;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--work;
/* Function Body */
*info = 0;
if (lsame_(compz, "N")) {
icompz = 0;
} else if (lsame_(compz, "V")) {
icompz = 1;
} else if (lsame_(compz, "I")) {
icompz = 2;
} else {
icompz = -1;
}
if (icompz < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*ldz < 1 || icompz > 0 && *ldz < max(1,*n)) {
*info = -6;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZSTEQR", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (*n == 1) {
if (icompz == 2) {
i__1 = z_dim1 + 1;
z__[i__1].r = 1., z__[i__1].i = 0.;
}
return 0;
}
/* Determine the unit roundoff and over/underflow thresholds. */
eps = dlamch_("E");
/* Computing 2nd power */
d__1 = eps;
eps2 = d__1 * d__1;
safmin = dlamch_("S");
safmax = 1. / safmin;
ssfmax = sqrt(safmax) / 3.;
ssfmin = sqrt(safmin) / eps2;
/* Compute the eigenvalues and eigenvectors of the tridiagonal */
/* matrix. */
if (icompz == 2) {
zlaset_("Full", n, n, &c_b1, &c_b2, &z__[z_offset], ldz);
}
nmaxit = *n * 30;
jtot = 0;
/* Determine where the matrix splits and choose QL or QR iteration */
/* for each block, according to whether top or bottom diagonal */
/* element is smaller. */
l1 = 1;
nm1 = *n - 1;
L10:
if (l1 > *n) {
goto L160;
}
if (l1 > 1) {
e[l1 - 1] = 0.;
}
if (l1 <= nm1) {
i__1 = nm1;
for (m = l1; m <= i__1; ++m) {
tst = (d__1 = e[m], abs(d__1));
if (tst == 0.) {
goto L30;
}
if (tst <= sqrt((d__1 = d__[m], abs(d__1))) * sqrt((d__2 = d__[m
+ 1], abs(d__2))) * eps) {
e[m] = 0.;
goto L30;
}
/* L20: */
}
}
m = *n;
L30:
l = l1;
lsv = l;
lend = m;
lendsv = lend;
l1 = m + 1;
if (lend == l) {
goto L10;
}
/* Scale submatrix in rows and columns L to LEND */
i__1 = lend - l + 1;
anorm = dlanst_("I", &i__1, &d__[l], &e[l]);
iscale = 0;
if (anorm == 0.) {
goto L10;
}
if (anorm > ssfmax) {
iscale = 1;
i__1 = lend - l + 1;
dlascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &d__[l], n,
info);
i__1 = lend - l;
dlascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &e[l], n,
info);
} else if (anorm < ssfmin) {
iscale = 2;
i__1 = lend - l + 1;
dlascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &d__[l], n,
info);
i__1 = lend - l;
dlascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &e[l], n,
info);
}
/* Choose between QL and QR iteration */
if ((d__1 = d__[lend], abs(d__1)) < (d__2 = d__[l], abs(d__2))) {
lend = lsv;
l = lendsv;
}
if (lend > l) {
/* QL Iteration */
/* Look for small subdiagonal element. */
L40:
if (l != lend) {
lendm1 = lend - 1;
i__1 = lendm1;
for (m = l; m <= i__1; ++m) {
/* Computing 2nd power */
d__2 = (d__1 = e[m], abs(d__1));
tst = d__2 * d__2;
if (tst <= eps2 * (d__1 = d__[m], abs(d__1)) * (d__2 = d__[m
+ 1], abs(d__2)) + safmin) {
goto L60;
}
/* L50: */
}
}
m = lend;
L60:
if (m < lend) {
e[m] = 0.;
}
p = d__[l];
if (m == l) {
goto L80;
}
/* If remaining matrix is 2-by-2, use DLAE2 or SLAEV2 */
/* to compute its eigensystem. */
if (m == l + 1) {
if (icompz > 0) {
dlaev2_(&d__[l], &e[l], &d__[l + 1], &rt1, &rt2, &c__, &s);
work[l] = c__;
work[*n - 1 + l] = s;
zlasr_("R", "V", "B", n, &c__2, &work[l], &work[*n - 1 + l], &
z__[l * z_dim1 + 1], ldz);
} else {
dlae2_(&d__[l], &e[l], &d__[l + 1], &rt1, &rt2);
}
d__[l] = rt1;
d__[l + 1] = rt2;
e[l] = 0.;
l += 2;
if (l <= lend) {
goto L40;
}
goto L140;
}
if (jtot == nmaxit) {
goto L140;
}
++jtot;
/* Form shift. */
g = (d__[l + 1] - p) / (e[l] * 2.);
r__ = dlapy2_(&g, &c_b41);
g = d__[m] - p + e[l] / (g + d_sign(&r__, &g));
s = 1.;
c__ = 1.;
p = 0.;
/* Inner loop */
mm1 = m - 1;
i__1 = l;
for (i__ = mm1; i__ >= i__1; --i__) {
f = s * e[i__];
b = c__ * e[i__];
dlartg_(&g, &f, &c__, &s, &r__);
if (i__ != m - 1) {
e[i__ + 1] = r__;
}
g = d__[i__ + 1] - p;
r__ = (d__[i__] - g) * s + c__ * 2. * b;
p = s * r__;
d__[i__ + 1] = g + p;
g = c__ * r__ - b;
/* If eigenvectors are desired, then save rotations. */
if (icompz > 0) {
work[i__] = c__;
work[*n - 1 + i__] = -s;
}
/* L70: */
}
/* If eigenvectors are desired, then apply saved rotations. */
if (icompz > 0) {
mm = m - l + 1;
zlasr_("R", "V", "B", n, &mm, &work[l], &work[*n - 1 + l], &z__[l
* z_dim1 + 1], ldz);
}
d__[l] -= p;
e[l] = g;
goto L40;
/* Eigenvalue found. */
L80:
d__[l] = p;
++l;
if (l <= lend) {
goto L40;
}
goto L140;
} else {
/* QR Iteration */
/* Look for small superdiagonal element. */
L90:
if (l != lend) {
lendp1 = lend + 1;
i__1 = lendp1;
for (m = l; m >= i__1; --m) {
/* Computing 2nd power */
d__2 = (d__1 = e[m - 1], abs(d__1));
tst = d__2 * d__2;
if (tst <= eps2 * (d__1 = d__[m], abs(d__1)) * (d__2 = d__[m
- 1], abs(d__2)) + safmin) {
goto L110;
}
/* L100: */
}
}
m = lend;
L110:
if (m > lend) {
e[m - 1] = 0.;
}
p = d__[l];
if (m == l) {
goto L130;
}
/* If remaining matrix is 2-by-2, use DLAE2 or SLAEV2 */
/* to compute its eigensystem. */
if (m == l - 1) {
if (icompz > 0) {
dlaev2_(&d__[l - 1], &e[l - 1], &d__[l], &rt1, &rt2, &c__, &s)
;
work[m] = c__;
work[*n - 1 + m] = s;
zlasr_("R", "V", "F", n, &c__2, &work[m], &work[*n - 1 + m], &
z__[(l - 1) * z_dim1 + 1], ldz);
} else {
dlae2_(&d__[l - 1], &e[l - 1], &d__[l], &rt1, &rt2);
}
d__[l - 1] = rt1;
d__[l] = rt2;
e[l - 1] = 0.;
l += -2;
if (l >= lend) {
goto L90;
}
goto L140;
}
if (jtot == nmaxit) {
goto L140;
}
++jtot;
/* Form shift. */
g = (d__[l - 1] - p) / (e[l - 1] * 2.);
r__ = dlapy2_(&g, &c_b41);
g = d__[m] - p + e[l - 1] / (g + d_sign(&r__, &g));
s = 1.;
c__ = 1.;
p = 0.;
/* Inner loop */
lm1 = l - 1;
i__1 = lm1;
for (i__ = m; i__ <= i__1; ++i__) {
f = s * e[i__];
b = c__ * e[i__];
dlartg_(&g, &f, &c__, &s, &r__);
if (i__ != m) {
e[i__ - 1] = r__;
}
g = d__[i__] - p;
r__ = (d__[i__ + 1] - g) * s + c__ * 2. * b;
p = s * r__;
d__[i__] = g + p;
g = c__ * r__ - b;
/* If eigenvectors are desired, then save rotations. */
if (icompz > 0) {
work[i__] = c__;
work[*n - 1 + i__] = s;
}
/* L120: */
}
/* If eigenvectors are desired, then apply saved rotations. */
if (icompz > 0) {
mm = l - m + 1;
zlasr_("R", "V", "F", n, &mm, &work[m], &work[*n - 1 + m], &z__[m
* z_dim1 + 1], ldz);
}
d__[l] -= p;
e[lm1] = g;
goto L90;
/* Eigenvalue found. */
L130:
d__[l] = p;
--l;
if (l >= lend) {
goto L90;
}
goto L140;
}
/* Undo scaling if necessary */
L140:
if (iscale == 1) {
i__1 = lendsv - lsv + 1;
dlascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &d__[lsv],
n, info);
i__1 = lendsv - lsv;
dlascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &e[lsv], n,
info);
} else if (iscale == 2) {
i__1 = lendsv - lsv + 1;
dlascl_("G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &d__[lsv],
n, info);
i__1 = lendsv - lsv;
dlascl_("G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &e[lsv], n,
info);
}
/* Check for no convergence to an eigenvalue after a total */
/* of N*MAXIT iterations. */
if (jtot == nmaxit) {
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
if (e[i__] != 0.) {
++(*info);
}
/* L150: */
}
return 0;
}
goto L10;
/* Order eigenvalues and eigenvectors. */
L160:
if (icompz == 0) {
/* Use Quick Sort */
dlasrt_("I", n, &d__[1], info);
} else {
/* Use Selection Sort to minimize swaps of eigenvectors */
i__1 = *n;
for (ii = 2; ii <= i__1; ++ii) {
i__ = ii - 1;
k = i__;
p = d__[i__];
i__2 = *n;
for (j = ii; j <= i__2; ++j) {
if (d__[j] < p) {
k = j;
p = d__[j];
}
/* L170: */
}
if (k != i__) {
d__[k] = d__[i__];
d__[i__] = p;
zswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[k * z_dim1 + 1],
&c__1);
}
/* L180: */
}
}
return 0;
/* End of ZSTEQR */
} /* zsteqr_ */
/* Subroutine */ int zsyt03_(char *uplo, integer *n, doublecomplex *a,
integer *lda, doublecomplex *ainv, integer *ldainv, doublecomplex *
work, integer *ldwork, doublereal *rwork, doublereal *rcond,
doublereal *resid)
{
/* System generated locals */
integer a_dim1, a_offset, ainv_dim1, ainv_offset, work_dim1, work_offset,
i__1, i__2, i__3, i__4;
doublecomplex z__1;
/* Local variables */
integer i__, j;
doublereal eps;
extern logical lsame_(char *, char *);
doublereal anorm;
extern /* Subroutine */ int zsymm_(char *, char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *);
extern doublereal dlamch_(char *), zlange_(char *, integer *,
integer *, doublecomplex *, integer *, doublereal *);
doublereal ainvnm;
extern doublereal zlansy_(char *, char *, integer *, doublecomplex *,
integer *, doublereal *);
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZSYT03 computes the residual for a complex symmetric matrix times */
/* its inverse: */
/* norm( I - A*AINV ) / ( N * norm(A) * norm(AINV) * EPS ) */
/* where EPS is the machine epsilon. */
/* Arguments */
/* ========== */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the upper or lower triangular part of the */
/* complex symmetric matrix A is stored: */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* N (input) INTEGER */
/* The number of rows and columns of the matrix A. N >= 0. */
/* A (input) COMPLEX*16 array, dimension (LDA,N) */
/* The original complex symmetric matrix A. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N) */
/* AINV (input/output) COMPLEX*16 array, dimension (LDAINV,N) */
/* On entry, the inverse of the matrix A, stored as a symmetric */
/* matrix in the same format as A. */
/* In this version, AINV is expanded into a full matrix and */
/* multiplied by A, so the opposing triangle of AINV will be */
/* changed; i.e., if the upper triangular part of AINV is */
/* stored, the lower triangular part will be used as work space. */
/* LDAINV (input) INTEGER */
/* The leading dimension of the array AINV. LDAINV >= max(1,N). */
/* WORK (workspace) COMPLEX*16 array, dimension (LDWORK,N) */
/* LDWORK (input) INTEGER */
/* The leading dimension of the array WORK. LDWORK >= max(1,N). */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
/* RCOND (output) DOUBLE PRECISION */
/* The reciprocal of the condition number of A, computed as */
/* RCOND = 1/ (norm(A) * norm(AINV)). */
/* RESID (output) DOUBLE PRECISION */
/* norm(I - A*AINV) / ( N * norm(A) * norm(AINV) * EPS ) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick exit if N = 0 */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
ainv_dim1 = *ldainv;
ainv_offset = 1 + ainv_dim1;
ainv -= ainv_offset;
work_dim1 = *ldwork;
work_offset = 1 + work_dim1;
work -= work_offset;
--rwork;
/* Function Body */
if (*n <= 0) {
*rcond = 1.;
*resid = 0.;
return 0;
}
/* Exit with RESID = 1/EPS if ANORM = 0 or AINVNM = 0. */
eps = dlamch_("Epsilon");
anorm = zlansy_("1", uplo, n, &a[a_offset], lda, &rwork[1]);
ainvnm = zlansy_("1", uplo, n, &ainv[ainv_offset], ldainv, &rwork[1]);
if (anorm <= 0. || ainvnm <= 0.) {
*rcond = 0.;
*resid = 1. / eps;
return 0;
}
*rcond = 1. / anorm / ainvnm;
/* Expand AINV into a full matrix and call ZSYMM to multiply */
/* AINV on the left by A (store the result in WORK). */
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = j + i__ * ainv_dim1;
i__4 = i__ + j * ainv_dim1;
ainv[i__3].r = ainv[i__4].r, ainv[i__3].i = ainv[i__4].i;
/* L10: */
}
/* L20: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
i__3 = j + i__ * ainv_dim1;
i__4 = i__ + j * ainv_dim1;
ainv[i__3].r = ainv[i__4].r, ainv[i__3].i = ainv[i__4].i;
/* L30: */
}
/* L40: */
}
}
z__1.r = -1., z__1.i = -0.;
zsymm_("Left", uplo, n, n, &z__1, &a[a_offset], lda, &ainv[ainv_offset],
ldainv, &c_b1, &work[work_offset], ldwork);
/* Add the identity matrix to WORK . */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__ + i__ * work_dim1;
i__3 = i__ + i__ * work_dim1;
z__1.r = work[i__3].r + 1., z__1.i = work[i__3].i + 0.;
work[i__2].r = z__1.r, work[i__2].i = z__1.i;
/* L50: */
}
/* Compute norm(I - A*AINV) / (N * norm(A) * norm(AINV) * EPS) */
*resid = zlange_("1", n, n, &work[work_offset], ldwork, &rwork[1]);
*resid = *resid * *rcond / eps / (doublereal) (*n);
return 0;
/* End of ZSYT03 */
} /* zsyt03_ */
/* Subroutine */ int dget07_(char *trans, integer *n, integer *nrhs,
doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal *
x, integer *ldx, doublereal *xact, integer *ldxact, doublereal *ferr,
logical *chkferr, doublereal *berr, doublereal *reslts)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, xact_dim1,
xact_offset, i__1, i__2, i__3;
doublereal d__1, d__2, d__3;
/* Local variables */
integer i__, j, k;
doublereal eps, tmp, diff, axbi;
integer imax;
doublereal unfl, ovfl;
doublereal xnorm;
doublereal errbnd;
logical notran;
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DGET07 tests the error bounds from iterative refinement for the */
/* computed solution to a system of equations op(A)*X = B, where A is a */
/* general n by n matrix and op(A) = A or A**T, depending on TRANS. */
/* RESLTS(1) = test of the error bound */
/* = norm(X - XACT) / ( norm(X) * FERR ) */
/* A large value is returned if this ratio is not less than one. */
/* RESLTS(2) = residual from the iterative refinement routine */
/* = the maximum of BERR / ( (n+1)*EPS + (*) ), where */
/* (*) = (n+1)*UNFL / (min_i (abs(op(A))*abs(X) +abs(b))_i ) */
/* Arguments */
/* ========= */
/* 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 = Transpose) */
/* N (input) INTEGER */
/* The number of rows of the matrices X and XACT. N >= 0. */
/* NRHS (input) INTEGER */
/* The number of columns of the matrices X and XACT. NRHS >= 0. */
/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
/* The original n by n matrix A. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */
/* The right hand side vectors for the system of linear */
/* equations. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS) */
/* The computed solution vectors. Each vector is stored as a */
/* column of the matrix X. */
/* LDX (input) INTEGER */
/* The leading dimension of the array X. LDX >= max(1,N). */
/* XACT (input) DOUBLE PRECISION array, dimension (LDX,NRHS) */
/* The exact solution vectors. Each vector is stored as a */
/* column of the matrix XACT. */
/* LDXACT (input) INTEGER */
/* The leading dimension of the array XACT. LDXACT >= max(1,N). */
/* FERR (input) DOUBLE PRECISION array, dimension (NRHS) */
/* The estimated forward error bounds for each solution vector */
/* X. If XTRUE is the true solution, FERR bounds the magnitude */
/* of the largest entry in (X - XTRUE) divided by the magnitude */
/* of the largest entry in X. */
/* CHKFERR (input) LOGICAL */
/* Set to .TRUE. to check FERR, .FALSE. not to check FERR. */
/* When the test system is ill-conditioned, the "true" */
/* solution in XACT may be incorrect. */
/* BERR (input) DOUBLE PRECISION array, dimension (NRHS) */
/* The componentwise relative backward error of each solution */
/* vector (i.e., the smallest relative change in any entry of A */
/* or B that makes X an exact solution). */
/* RESLTS (output) DOUBLE PRECISION array, dimension (2) */
/* The maximum over the NRHS solution vectors of the ratios: */
/* RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR ) */
/* RESLTS(2) = BERR / ( (n+1)*EPS + (*) ) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick exit if N = 0 or NRHS = 0. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
xact_dim1 = *ldxact;
xact_offset = 1 + xact_dim1;
xact -= xact_offset;
--ferr;
--berr;
--reslts;
/* Function Body */
if (*n <= 0 || *nrhs <= 0) {
reslts[1] = 0.;
reslts[2] = 0.;
return 0;
}
eps = dlamch_("Epsilon");
unfl = dlamch_("Safe minimum");
ovfl = 1. / unfl;
notran = lsame_(trans, "N");
/* Test 1: Compute the maximum of */
/* norm(X - XACT) / ( norm(X) * FERR ) */
/* over all the vectors X and XACT using the infinity-norm. */
errbnd = 0.;
if (*chkferr) {
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
imax = idamax_(n, &x[j * x_dim1 + 1], &c__1);
/* Computing MAX */
d__2 = (d__1 = x[imax + j * x_dim1], abs(d__1));
xnorm = max(d__2,unfl);
diff = 0.;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
d__2 = diff, d__3 = (d__1 = x[i__ + j * x_dim1] - xact[i__ +
j * xact_dim1], abs(d__1));
diff = max(d__2,d__3);
/* L10: */
}
if (xnorm > 1.) {
goto L20;
} else if (diff <= ovfl * xnorm) {
goto L20;
} else {
errbnd = 1. / eps;
goto L30;
}
L20:
if (diff / xnorm <= ferr[j]) {
/* Computing MAX */
d__1 = errbnd, d__2 = diff / xnorm / ferr[j];
errbnd = max(d__1,d__2);
} else {
errbnd = 1. / eps;
}
L30:
;
}
}
reslts[1] = errbnd;
/* Test 2: Compute the maximum of BERR / ( (n+1)*EPS + (*) ), where */
/* (*) = (n+1)*UNFL / (min_i (abs(op(A))*abs(X) +abs(b))_i ) */
i__1 = *nrhs;
for (k = 1; k <= i__1; ++k) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
tmp = (d__1 = b[i__ + k * b_dim1], abs(d__1));
if (notran) {
i__3 = *n;
for (j = 1; j <= i__3; ++j) {
tmp += (d__1 = a[i__ + j * a_dim1], abs(d__1)) * (d__2 =
x[j + k * x_dim1], abs(d__2));
/* L40: */
}
} else {
i__3 = *n;
for (j = 1; j <= i__3; ++j) {
tmp += (d__1 = a[j + i__ * a_dim1], abs(d__1)) * (d__2 =
x[j + k * x_dim1], abs(d__2));
/* L50: */
}
}
if (i__ == 1) {
axbi = tmp;
} else {
axbi = min(axbi,tmp);
}
/* L60: */
}
/* Computing MAX */
d__1 = axbi, d__2 = (*n + 1) * unfl;
tmp = berr[k] / ((*n + 1) * eps + (*n + 1) * unfl / max(d__1,d__2));
if (k == 1) {
reslts[2] = tmp;
} else {
reslts[2] = max(reslts[2],tmp);
}
/* L70: */
}
return 0;
/* End of DGET07 */
} /* dget07_ */