int
f2c_strmv(char* uplo, char *trans, char* diag, integer *N,
real *A, integer *lda,
real *X, integer *incX)
{
strmv_(uplo, trans, diag,
N, A, lda, X, incX);
return 0;
}
/* Subroutine */ int strt02_(char *uplo, char *trans, char *diag, integer *n,
integer *nrhs, real *a, integer *lda, real *x, integer *ldx, real *b,
integer *ldb, real *work, real *resid)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1;
real r__1, r__2;
/* Local variables */
integer j;
real eps;
real anorm, bnorm;
real xnorm;
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* STRT02 computes the residual for the computed solution to a */
/* triangular system of linear equations A*x = b or A'*x = b. */
/* Here A is a triangular matrix, A' is the transpose of A, and x and b */
/* are N by NRHS matrices. The test ratio is the maximum over the */
/* number of right hand sides of */
/* norm(b - op(A)*x) / ( norm(op(A)) * norm(x) * EPS ), */
/* where op(A) denotes A or A' and EPS is the machine epsilon. */
/* 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': 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 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 X and B. NRHS >= 0. */
/* A (input) REAL 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). */
/* X (input) REAL array, dimension (LDX,NRHS) */
/* The computed solution vectors for the system of linear */
/* equations. */
/* LDX (input) INTEGER */
/* The leading dimension of the array X. LDX >= max(1,N). */
/* B (input) REAL 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). */
/* WORK (workspace) REAL array, dimension (N) */
/* RESID (output) REAL */
/* The maximum over the number of right hand sides of */
/* norm(op(A)*x - b) / ( norm(op(A)) * norm(x) * EPS ). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. 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;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--work;
/* Function Body */
if (*n <= 0 || *nrhs <= 0) {
*resid = 0.f;
return 0;
}
/* Compute the 1-norm of A or A'. */
if (lsame_(trans, "N")) {
anorm = slantr_("1", uplo, diag, n, n, &a[a_offset], lda, &work[1]);
} else {
anorm = slantr_("I", uplo, diag, n, n, &a[a_offset], lda, &work[1]);
}
/* Exit with RESID = 1/EPS if ANORM = 0. */
eps = slamch_("Epsilon");
if (anorm <= 0.f) {
*resid = 1.f / eps;
return 0;
}
/* Compute the maximum over the number of right hand sides of */
/* norm(op(A)*x - b) / ( norm(op(A)) * norm(x) * EPS ) */
*resid = 0.f;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
scopy_(n, &x[j * x_dim1 + 1], &c__1, &work[1], &c__1);
strmv_(uplo, trans, diag, n, &a[a_offset], lda, &work[1], &c__1);
saxpy_(n, &c_b10, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
bnorm = sasum_(n, &work[1], &c__1);
xnorm = sasum_(n, &x[j * x_dim1 + 1], &c__1);
if (xnorm <= 0.f) {
*resid = 1.f / eps;
} else {
/* Computing MAX */
r__1 = *resid, r__2 = bnorm / anorm / xnorm / eps;
*resid = dmax(r__1,r__2);
}
/* L10: */
}
return 0;
/* End of STRT02 */
} /* strt02_ */
/* Subroutine */ int sget01_(integer *m, integer *n, real *a, integer *lda,
real *afac, integer *ldafac, integer *ipiv, real *rwork, real *resid)
{
/* System generated locals */
integer a_dim1, a_offset, afac_dim1, afac_offset, i__1, i__2;
/* Local variables */
integer i__, j, k;
real t, eps;
extern doublereal sdot_(integer *, real *, integer *, real *, integer *);
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
real anorm;
extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *,
real *, integer *, real *, integer *, real *, real *, integer *), strmv_(char *, char *, char *, integer *, real *,
integer *, real *, integer *);
extern doublereal slamch_(char *), slange_(char *, integer *,
integer *, real *, integer *, real *);
extern /* Subroutine */ int slaswp_(integer *, real *, integer *, integer
*, integer *, integer *, integer *);
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SGET01 reconstructs a matrix A from its L*U factorization and */
/* computes the residual */
/* norm(L*U - A) / ( N * norm(A) * EPS ), */
/* where EPS is the machine epsilon. */
/* Arguments */
/* ========== */
/* M (input) INTEGER */
/* The number of rows of the matrix A. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix A. N >= 0. */
/* A (input) REAL array, dimension (LDA,N) */
/* The original M x N matrix A. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* AFAC (input/output) REAL array, dimension (LDAFAC,N) */
/* The factored form of the matrix A. AFAC contains the factors */
/* L and U from the L*U factorization as computed by SGETRF. */
/* Overwritten with the reconstructed matrix, and then with the */
/* difference L*U - A. */
/* LDAFAC (input) INTEGER */
/* The leading dimension of the array AFAC. LDAFAC >= max(1,M). */
/* IPIV (input) INTEGER array, dimension (N) */
/* The pivot indices from SGETRF. */
/* RWORK (workspace) REAL array, dimension (M) */
/* RESID (output) REAL */
/* norm(L*U - A) / ( N * norm(A) * EPS ) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick exit if M = 0 or N = 0. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
afac_dim1 = *ldafac;
afac_offset = 1 + afac_dim1;
afac -= afac_offset;
--ipiv;
--rwork;
/* Function Body */
if (*m <= 0 || *n <= 0) {
*resid = 0.f;
return 0;
}
/* Determine EPS and the norm of A. */
eps = slamch_("Epsilon");
anorm = slange_("1", m, n, &a[a_offset], lda, &rwork[1]);
/* Compute the product L*U and overwrite AFAC with the result. */
/* A column at a time of the product is obtained, starting with */
/* column N. */
for (k = *n; k >= 1; --k) {
if (k > *m) {
strmv_("Lower", "No transpose", "Unit", m, &afac[afac_offset],
ldafac, &afac[k * afac_dim1 + 1], &c__1);
} else {
/* Compute elements (K+1:M,K) */
t = afac[k + k * afac_dim1];
if (k + 1 <= *m) {
i__1 = *m - k;
sscal_(&i__1, &t, &afac[k + 1 + k * afac_dim1], &c__1);
i__1 = *m - k;
i__2 = k - 1;
sgemv_("No transpose", &i__1, &i__2, &c_b11, &afac[k + 1 +
afac_dim1], ldafac, &afac[k * afac_dim1 + 1], &c__1, &
c_b11, &afac[k + 1 + k * afac_dim1], &c__1);
}
/* Compute the (K,K) element */
i__1 = k - 1;
afac[k + k * afac_dim1] = t + sdot_(&i__1, &afac[k + afac_dim1],
ldafac, &afac[k * afac_dim1 + 1], &c__1);
/* Compute elements (1:K-1,K) */
i__1 = k - 1;
strmv_("Lower", "No transpose", "Unit", &i__1, &afac[afac_offset],
ldafac, &afac[k * afac_dim1 + 1], &c__1);
}
/* L10: */
}
i__1 = min(*m,*n);
slaswp_(n, &afac[afac_offset], ldafac, &c__1, &i__1, &ipiv[1], &c_n1);
/* Compute the difference L*U - A and store in AFAC. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
afac[i__ + j * afac_dim1] -= a[i__ + j * a_dim1];
/* L20: */
}
/* L30: */
}
/* Compute norm( L*U - A ) / ( N * norm(A) * EPS ) */
*resid = slange_("1", m, n, &afac[afac_offset], ldafac, &rwork[1]);
if (anorm <= 0.f) {
if (*resid != 0.f) {
*resid = 1.f / eps;
}
} else {
*resid = *resid / (real) (*n) / anorm / eps;
}
return 0;
/* End of SGET01 */
} /* sget01_ */
/* Subroutine */ int sgglse_(integer *m, integer *n, integer *p, real *a,
integer *lda, real *b, integer *ldb, real *c, real *d, real *x, real *
work, integer *lwork, integer *info)
{
/* -- LAPACK driver routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
SGGLSE solves the linear equality-constrained least squares (LSE)
problem:
minimize || c - A*x ||_2 subject to B*x = d
where A is an M-by-N matrix, B is a P-by-N matrix, c is a given
M-vector, and d is a given P-vector. It is assumed that
P <= N <= M+P, and
rank(B) = P and rank( ( A ) ) = N.
( ( B ) )
These conditions ensure that the LSE problem has a unique solution,
which is obtained using a GRQ factorization of the matrices B and A.
Arguments
=========
M (input) INTEGER
The number of rows of the matrix A. M >= 0.
N (input) INTEGER
The number of columns of the matrices A and B. N >= 0.
P (input) INTEGER
The number of rows of the matrix B. 0 <= P <= N <= M+P.
A (input/output) REAL array, dimension (LDA,N)
On entry, the M-by-N matrix A.
On exit, A is destroyed.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,M).
B (input/output) REAL array, dimension (LDB,N)
On entry, the P-by-N matrix B.
On exit, B is destroyed.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,P).
C (input/output) REAL array, dimension (M)
On entry, C contains the right hand side vector for the
least squares part of the LSE problem.
On exit, the residual sum of squares for the solution
is given by the sum of squares of elements N-P+1 to M of
vector C.
D (input/output) REAL array, dimension (P)
On entry, D contains the right hand side vector for the
constrained equation.
On exit, D is destroyed.
X (output) REAL array, dimension (N)
On exit, X is the solution of the LSE problem.
WORK (workspace/output) REAL array, dimension (LWORK)
On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
LWORK (input) INTEGER
The dimension of the array WORK. LWORK >= max(1,M+N+P).
For optimum performance LWORK >= P+min(M,N)+max(M,N)*NB,
where NB is an upper bound for the optimal blocksizes for
SGEQRF, SGERQF, SORMQR and SORMRQ.
INFO (output) INTEGER
= 0: successful exit.
< 0: if INFO = -i, the i-th argument had an illegal value.
=====================================================================
Test the input parameters
Parameter adjustments
Function Body */
/* Table of constant values */
static integer c__1 = 1;
static real c_b11 = -1.f;
static real c_b13 = 1.f;
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
/* Local variables */
static integer lopt;
extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *,
real *, integer *, real *, integer *, real *, real *, integer *), scopy_(integer *, real *, integer *, real *, integer *),
saxpy_(integer *, real *, real *, integer *, real *, integer *),
strmv_(char *, char *, char *, integer *, real *, integer *, real
*, integer *), strsv_(char *, char *,
char *, integer *, real *, integer *, real *, integer *);
static integer mn, nr;
extern /* Subroutine */ int xerbla_(char *, integer *), sggrqf_(
integer *, integer *, integer *, real *, integer *, real *, real *
, integer *, real *, real *, integer *, integer *), sormqr_(char *
, char *, integer *, integer *, integer *, real *, integer *,
real *, real *, integer *, real *, integer *, integer *), sormrq_(char *, char *, integer *, integer *, integer *,
real *, integer *, real *, real *, integer *, real *, integer *,
integer *);
#define C(I) c[(I)-1]
#define D(I) d[(I)-1]
#define X(I) x[(I)-1]
#define WORK(I) work[(I)-1]
#define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)]
#define B(I,J) b[(I)-1 + ((J)-1)* ( *ldb)]
*info = 0;
mn = min(*m,*n);
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*p < 0 || *p > *n || *p < *n - *m) {
*info = -3;
} else if (*lda < max(1,*m)) {
*info = -5;
} else if (*ldb < max(1,*p)) {
*info = -7;
} else /* if(complicated condition) */ {
/* Computing MAX */
i__1 = 1, i__2 = *m + *n + *p;
if (*lwork < max(i__1,i__2)) {
*info = -12;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SGGLSE", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Compute the GRQ factorization of matrices B and A:
B*Q' = ( 0 T12 ) P Z'*A*Q' = ( R11 R12 ) N-P
N-P P ( 0 R22 ) M+P-N
N-P P
where T12 and R11 are upper triangular, and Q and Z are
orthogonal. */
i__1 = *lwork - *p - mn;
sggrqf_(p, m, n, &B(1,1), ldb, &WORK(1), &A(1,1), lda, &WORK(*p
+ 1), &WORK(*p + mn + 1), &i__1, info);
lopt = WORK(*p + mn + 1);
/* Update c = Z'*c = ( c1 ) N-P
( c2 ) M+P-N */
i__1 = max(1,*m);
i__2 = *lwork - *p - mn;
sormqr_("Left", "Transpose", m, &c__1, &mn, &A(1,1), lda, &WORK(*p +
1), &C(1), &i__1, &WORK(*p + mn + 1), &i__2, info);
/* Computing MAX */
i__1 = lopt, i__2 = (integer) WORK(*p + mn + 1);
lopt = max(i__1,i__2);
/* Solve T12*x2 = d for x2 */
strsv_("Upper", "No transpose", "Non unit", p, &B(1,*n-*p+1), ldb, &D(1), &c__1);
/* Update c1 */
i__1 = *n - *p;
sgemv_("No transpose", &i__1, p, &c_b11, &A(1,*n-*p+1),
lda, &D(1), &c__1, &c_b13, &C(1), &c__1);
/* Sovle R11*x1 = c1 for x1 */
i__1 = *n - *p;
strsv_("Upper", "No transpose", "Non unit", &i__1, &A(1,1), lda, &C(
1), &c__1);
/* Put the solutions in X */
i__1 = *n - *p;
scopy_(&i__1, &C(1), &c__1, &X(1), &c__1);
scopy_(p, &D(1), &c__1, &X(*n - *p + 1), &c__1);
/* Compute the residual vector: */
if (*m < *n) {
nr = *m + *p - *n;
i__1 = *n - *m;
sgemv_("No transpose", &nr, &i__1, &c_b11, &A(*n-*p+1,*m+1), lda, &D(nr + 1), &c__1, &c_b13, &C(*n - *p + 1), &
c__1);
} else {
nr = *p;
}
strmv_("Upper", "No transpose", "Non unit", &nr, &A(*n-*p+1,*n-*p+1), lda, &D(1), &c__1);
saxpy_(&nr, &c_b11, &D(1), &c__1, &C(*n - *p + 1), &c__1);
/* Backward transformation x = Q'*x */
i__1 = *lwork - *p - mn;
sormrq_("Left", "Transpose", n, &c__1, p, &B(1,1), ldb, &WORK(1), &X(
1), n, &WORK(*p + mn + 1), &i__1, info);
/* Computing MAX */
i__1 = lopt, i__2 = (integer) WORK(*p + mn + 1);
WORK(1) = (real) (*p + mn + max(i__1,i__2));
return 0;
/* End of SGGLSE */
} /* sgglse_ */
/* Subroutine */ int strrfs_(char *uplo, char *trans, char *diag, integer *n,
integer *nrhs, real *a, integer *lda, real *b, integer *ldb, real *x,
integer *ldx, real *ferr, real *berr, real *work, integer *iwork,
integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1, i__2,
i__3;
real r__1, r__2, r__3;
/* Local variables */
integer i__, j, k;
real s, xk;
integer nz;
real eps;
integer kase;
real safe1, safe2;
integer isave[3];
logical upper;
real safmin;
logical notran;
char transt[1];
logical nounit;
real lstres;
/* -- LAPACK routine (version 3.2) -- */
/* November 2006 */
/* Modified to call SLACN2 in place of SLACON, 7 Feb 03, SJH. */
/* Purpose */
/* ======= */
/* STRRFS provides error bounds and backward error estimates for the */
/* solution to a system of linear equations with a triangular */
/* coefficient matrix. */
/* The solution matrix X must be computed by STRTRS or some other */
/* means before entering this routine. STRRFS does not do iterative */
/* refinement because doing so cannot improve the backward error. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* = 'U': A is upper triangular; */
/* = 'L': A is lower triangular. */
/* TRANS (input) CHARACTER*1 */
/* Specifies the form of the system of equations: */
/* = 'N': A * X = B (No transpose) */
/* = 'T': A**T * X = B (Transpose) */
/* = 'C': A**H * X = B (Conjugate transpose = Transpose) */
/* DIAG (input) CHARACTER*1 */
/* = 'N': A is non-unit triangular; */
/* = 'U': A is unit triangular. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* 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) REAL 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) REAL 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) REAL array, dimension (LDX,NRHS) */
/* The solution matrix X. */
/* LDX (input) INTEGER */
/* The leading dimension of the array X. LDX >= max(1,N). */
/* FERR (output) REAL array, dimension (NRHS) */
/* The estimated forward error bound for each solution vector */
/* X(j) (the j-th column of the solution matrix X). */
/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
/* is an estimated upper bound for the magnitude of the largest */
/* element in (X(j) - XTRUE) divided by the magnitude of the */
/* largest element in X(j). The estimate is as reliable as */
/* the estimate for RCOND, and is almost always a slight */
/* overestimate of the true error. */
/* BERR (output) REAL array, dimension (NRHS) */
/* The componentwise relative backward error of each solution */
/* vector X(j) (i.e., the smallest relative change in */
/* any element of A or B that makes X(j) an exact solution). */
/* WORK (workspace) REAL 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 */
/* ===================================================================== */
/* Test the input parameters. */
/* 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;
--ferr;
--berr;
--work;
--iwork;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
notran = lsame_(trans, "N");
nounit = lsame_(diag, "N");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (! notran && ! lsame_(trans, "T") && !
lsame_(trans, "C")) {
*info = -2;
} else if (! nounit && ! lsame_(diag, "U")) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*nrhs < 0) {
*info = -5;
} else if (*lda < max(1,*n)) {
*info = -7;
} else if (*ldb < max(1,*n)) {
*info = -9;
} else if (*ldx < max(1,*n)) {
*info = -11;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("STRRFS", &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.f;
berr[j] = 0.f;
}
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 = slamch_("Epsilon");
safmin = slamch_("Safe minimum");
safe1 = nz * safmin;
safe2 = safe1 / eps;
/* Do for each right hand side */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
/* Compute residual R = B - op(A) * X, */
/* where op(A) = A or A', depending on TRANS. */
scopy_(n, &x[j * x_dim1 + 1], &c__1, &work[*n + 1], &c__1);
strmv_(uplo, trans, diag, n, &a[a_offset], lda, &work[*n + 1], &c__1);
saxpy_(n, &c_b19, &b[j * b_dim1 + 1], &c__1, &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__] = (r__1 = b[i__ + j * b_dim1], dabs(r__1));
}
if (notran) {
/* Compute abs(A)*abs(X) + abs(B). */
if (upper) {
if (nounit) {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
xk = (r__1 = x[k + j * x_dim1], dabs(r__1));
i__3 = k;
for (i__ = 1; i__ <= i__3; ++i__) {
work[i__] += (r__1 = a[i__ + k * a_dim1], dabs(
r__1)) * xk;
}
}
} else {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
xk = (r__1 = x[k + j * x_dim1], dabs(r__1));
i__3 = k - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
work[i__] += (r__1 = a[i__ + k * a_dim1], dabs(
r__1)) * xk;
}
work[k] += xk;
}
}
} else {
if (nounit) {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
xk = (r__1 = x[k + j * x_dim1], dabs(r__1));
i__3 = *n;
for (i__ = k; i__ <= i__3; ++i__) {
work[i__] += (r__1 = a[i__ + k * a_dim1], dabs(
r__1)) * xk;
}
}
} else {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
xk = (r__1 = x[k + j * x_dim1], dabs(r__1));
i__3 = *n;
for (i__ = k + 1; i__ <= i__3; ++i__) {
work[i__] += (r__1 = a[i__ + k * a_dim1], dabs(
r__1)) * xk;
}
work[k] += xk;
}
}
}
} else {
/* Compute abs(A')*abs(X) + abs(B). */
if (upper) {
if (nounit) {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
s = 0.f;
i__3 = k;
for (i__ = 1; i__ <= i__3; ++i__) {
s += (r__1 = a[i__ + k * a_dim1], dabs(r__1)) * (
r__2 = x[i__ + j * x_dim1], dabs(r__2));
}
work[k] += s;
}
} else {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
s = (r__1 = x[k + j * x_dim1], dabs(r__1));
i__3 = k - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
s += (r__1 = a[i__ + k * a_dim1], dabs(r__1)) * (
r__2 = x[i__ + j * x_dim1], dabs(r__2));
}
work[k] += s;
}
}
} else {
if (nounit) {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
s = 0.f;
i__3 = *n;
for (i__ = k; i__ <= i__3; ++i__) {
s += (r__1 = a[i__ + k * a_dim1], dabs(r__1)) * (
r__2 = x[i__ + j * x_dim1], dabs(r__2));
}
work[k] += s;
}
} else {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
s = (r__1 = x[k + j * x_dim1], dabs(r__1));
i__3 = *n;
for (i__ = k + 1; i__ <= i__3; ++i__) {
s += (r__1 = a[i__ + k * a_dim1], dabs(r__1)) * (
r__2 = x[i__ + j * x_dim1], dabs(r__2));
}
work[k] += s;
}
}
}
}
s = 0.f;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
if (work[i__] > safe2) {
/* Computing MAX */
r__2 = s, r__3 = (r__1 = work[*n + i__], dabs(r__1)) / work[
i__];
s = dmax(r__2,r__3);
} else {
/* Computing MAX */
r__2 = s, r__3 = ((r__1 = work[*n + i__], dabs(r__1)) + safe1)
/ (work[i__] + safe1);
s = dmax(r__2,r__3);
}
}
berr[j] = s;
/* Bound error from formula */
/* norm(X - XTRUE) / norm(X) .le. FERR = */
/* norm( abs(inv(op(A)))* */
/* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X) */
/* where */
/* norm(Z) is the magnitude of the largest component of Z */
/* inv(op(A)) is the inverse of op(A) */
/* abs(Z) is the componentwise absolute value of the matrix 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 SLACN2 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__] = (r__1 = work[*n + i__], dabs(r__1)) + nz * eps *
work[i__];
} else {
work[i__] = (r__1 = work[*n + i__], dabs(r__1)) + nz * eps *
work[i__] + safe1;
}
}
kase = 0;
L210:
slacn2_(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)'). */
strsv_(uplo, transt, diag, n, &a[a_offset], lda, &work[*n + 1]
, &c__1);
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
work[*n + i__] = work[i__] * work[*n + i__];
}
} 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__];
}
strsv_(uplo, trans, diag, n, &a[a_offset], lda, &work[*n + 1],
&c__1);
}
goto L210;
}
/* Normalize error. */
lstres = 0.f;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
r__2 = lstres, r__3 = (r__1 = x[i__ + j * x_dim1], dabs(r__1));
lstres = dmax(r__2,r__3);
}
if (lstres != 0.f) {
ferr[j] /= lstres;
}
}
return 0;
/* End of STRRFS */
} /* strrfs_ */
/* Subroutine */ int strti2_(char *uplo, char *diag, integer *n, real *a,
integer *lda, integer *info)
{
/* -- LAPACK 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
=======
STRTI2 computes the inverse of a real upper or lower triangular
matrix.
This is the Level 2 BLAS version of the algorithm.
Arguments
=========
UPLO (input) CHARACTER*1
Specifies whether the matrix A is upper or lower triangular.
= 'U': Upper triangular
= 'L': Lower triangular
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 order of the matrix A. N >= 0.
A (input/output) REAL array, dimension (LDA,N)
On entry, 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.
On exit, the (triangular) inverse of the original matrix, in
the same storage format.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -k, the k-th argument had an illegal value
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
/* Local variables */
static integer j;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
static logical upper;
extern /* Subroutine */ int strmv_(char *, char *, char *, integer *,
real *, integer *, real *, integer *),
xerbla_(char *, integer *);
static logical nounit;
static real ajj;
#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
nounit = lsame_(diag, "N");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (! nounit && ! lsame_(diag, "U")) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*lda < max(1,*n)) {
*info = -5;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("STRTI2", &i__1);
return 0;
}
if (upper) {
/* Compute inverse of upper triangular matrix. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (nounit) {
a_ref(j, j) = 1.f / a_ref(j, j);
ajj = -a_ref(j, j);
} else {
ajj = -1.f;
}
/* Compute elements 1:j-1 of j-th column. */
i__2 = j - 1;
strmv_("Upper", "No transpose", diag, &i__2, &a[a_offset], lda, &
a_ref(1, j), &c__1);
i__2 = j - 1;
sscal_(&i__2, &ajj, &a_ref(1, j), &c__1);
/* L10: */
}
} else {
/* Compute inverse of lower triangular matrix. */
for (j = *n; j >= 1; --j) {
if (nounit) {
a_ref(j, j) = 1.f / a_ref(j, j);
ajj = -a_ref(j, j);
} else {
ajj = -1.f;
}
if (j < *n) {
/* Compute elements j+1:n of j-th column. */
i__1 = *n - j;
strmv_("Lower", "No transpose", diag, &i__1, &a_ref(j + 1, j
+ 1), lda, &a_ref(j + 1, j), &c__1);
i__1 = *n - j;
sscal_(&i__1, &ajj, &a_ref(j + 1, j), &c__1);
}
/* L20: */
}
}
return 0;
/* End of STRTI2 */
} /* strti2_ */
void
strmv(char uplo, char transa, char diag, int n, float *a, int lda, float *x, int incx)
{
strmv_( &uplo, &transa, &diag, &n, a, &lda, x, &incx);
}
/* Subroutine */ int slarft_(char *direct, char *storev, integer *n, integer *
k, real *v, integer *ldv, real *tau, real *t, integer *ldt)
{
/* System generated locals */
integer t_dim1, t_offset, v_dim1, v_offset, i__1, i__2, i__3;
real r__1;
/* Local variables */
integer i__, j, prevlastv;
real vii;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *,
real *, integer *, real *, integer *, real *, real *, integer *);
integer lastv;
extern /* Subroutine */ int strmv_(char *, char *, char *, integer *,
real *, integer *, real *, integer *);
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SLARFT forms the triangular factor T of a real block reflector H */
/* of order n, which is defined as a product of k elementary reflectors. */
/* If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular; */
/* If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular. */
/* If STOREV = 'C', the vector which defines the elementary reflector */
/* H(i) is stored in the i-th column of the array V, and */
/* H = I - V * T * V' */
/* If STOREV = 'R', the vector which defines the elementary reflector */
/* H(i) is stored in the i-th row of the array V, and */
/* H = I - V' * T * V */
/* Arguments */
/* ========= */
/* DIRECT (input) CHARACTER*1 */
/* Specifies the order in which the elementary reflectors are */
/* multiplied to form the block reflector: */
/* = 'F': H = H(1) H(2) . . . H(k) (Forward) */
/* = 'B': H = H(k) . . . H(2) H(1) (Backward) */
/* STOREV (input) CHARACTER*1 */
/* Specifies how the vectors which define the elementary */
/* reflectors are stored (see also Further Details): */
/* = 'C': columnwise */
/* = 'R': rowwise */
/* N (input) INTEGER */
/* The order of the block reflector H. N >= 0. */
/* K (input) INTEGER */
/* The order of the triangular factor T (= the number of */
/* elementary reflectors). K >= 1. */
/* V (input/output) REAL array, dimension */
/* (LDV,K) if STOREV = 'C' */
/* (LDV,N) if STOREV = 'R' */
/* The matrix V. See further details. */
/* LDV (input) INTEGER */
/* The leading dimension of the array V. */
/* If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K. */
/* TAU (input) REAL array, dimension (K) */
/* TAU(i) must contain the scalar factor of the elementary */
/* reflector H(i). */
/* T (output) REAL array, dimension (LDT,K) */
/* The k by k triangular factor T of the block reflector. */
/* If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is */
/* lower triangular. The rest of the array is not used. */
/* LDT (input) INTEGER */
/* The leading dimension of the array T. LDT >= K. */
/* Further Details */
/* =============== */
/* The shape of the matrix V and the storage of the vectors which define */
/* the H(i) is best illustrated by the following example with n = 5 and */
/* k = 3. The elements equal to 1 are not stored; the corresponding */
/* array elements are modified but restored on exit. The rest of the */
/* array is not used. */
/* DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': */
/* V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) */
/* ( v1 1 ) ( 1 v2 v2 v2 ) */
/* ( v1 v2 1 ) ( 1 v3 v3 ) */
/* ( v1 v2 v3 ) */
/* ( v1 v2 v3 ) */
/* DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': */
/* V = ( v1 v2 v3 ) V = ( v1 v1 1 ) */
/* ( v1 v2 v3 ) ( v2 v2 v2 1 ) */
/* ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) */
/* ( 1 v3 ) */
/* ( 1 ) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick return if possible */
/* Parameter adjustments */
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
--tau;
t_dim1 = *ldt;
t_offset = 1 + t_dim1;
t -= t_offset;
/* Function Body */
if (*n == 0) {
return 0;
}
if (lsame_(direct, "F")) {
prevlastv = *n;
i__1 = *k;
for (i__ = 1; i__ <= i__1; ++i__) {
prevlastv = max(i__,prevlastv);
if (tau[i__] == 0.f) {
/* H(i) = I */
i__2 = i__;
for (j = 1; j <= i__2; ++j) {
t[j + i__ * t_dim1] = 0.f;
/* L10: */
}
} else {
/* general case */
vii = v[i__ + i__ * v_dim1];
v[i__ + i__ * v_dim1] = 1.f;
if (lsame_(storev, "C")) {
/* Skip any trailing zeros. */
i__2 = i__ + 1;
for (lastv = *n; lastv >= i__2; --lastv) {
if (v[lastv + i__ * v_dim1] != 0.f) {
break;
}
}
j = min(lastv,prevlastv);
/* T(1:i-1,i) := - tau(i) * V(i:j,1:i-1)' * V(i:j,i) */
i__2 = j - i__ + 1;
i__3 = i__ - 1;
r__1 = -tau[i__];
sgemv_("Transpose", &i__2, &i__3, &r__1, &v[i__ + v_dim1],
ldv, &v[i__ + i__ * v_dim1], &c__1, &c_b8, &t[
i__ * t_dim1 + 1], &c__1);
} else {
/* Skip any trailing zeros. */
i__2 = i__ + 1;
for (lastv = *n; lastv >= i__2; --lastv) {
if (v[i__ + lastv * v_dim1] != 0.f) {
break;
}
}
j = min(lastv,prevlastv);
/* T(1:i-1,i) := - tau(i) * V(1:i-1,i:j) * V(i,i:j)' */
i__2 = i__ - 1;
i__3 = j - i__ + 1;
r__1 = -tau[i__];
sgemv_("No transpose", &i__2, &i__3, &r__1, &v[i__ *
v_dim1 + 1], ldv, &v[i__ + i__ * v_dim1], ldv, &
c_b8, &t[i__ * t_dim1 + 1], &c__1);
}
v[i__ + i__ * v_dim1] = vii;
/* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) */
i__2 = i__ - 1;
strmv_("Upper", "No transpose", "Non-unit", &i__2, &t[
t_offset], ldt, &t[i__ * t_dim1 + 1], &c__1);
t[i__ + i__ * t_dim1] = tau[i__];
if (i__ > 1) {
prevlastv = max(prevlastv,lastv);
} else {
prevlastv = lastv;
}
}
/* L20: */
}
} else {
prevlastv = 1;
for (i__ = *k; i__ >= 1; --i__) {
if (tau[i__] == 0.f) {
/* H(i) = I */
i__1 = *k;
for (j = i__; j <= i__1; ++j) {
t[j + i__ * t_dim1] = 0.f;
/* L30: */
}
} else {
/* general case */
if (i__ < *k) {
if (lsame_(storev, "C")) {
vii = v[*n - *k + i__ + i__ * v_dim1];
v[*n - *k + i__ + i__ * v_dim1] = 1.f;
/* Skip any leading zeros. */
i__1 = i__ - 1;
for (lastv = 1; lastv <= i__1; ++lastv) {
if (v[lastv + i__ * v_dim1] != 0.f) {
break;
}
}
j = max(lastv,prevlastv);
/* T(i+1:k,i) := */
/* - tau(i) * V(j:n-k+i,i+1:k)' * V(j:n-k+i,i) */
i__1 = *n - *k + i__ - j + 1;
i__2 = *k - i__;
r__1 = -tau[i__];
sgemv_("Transpose", &i__1, &i__2, &r__1, &v[j + (i__
+ 1) * v_dim1], ldv, &v[j + i__ * v_dim1], &
c__1, &c_b8, &t[i__ + 1 + i__ * t_dim1], &
c__1);
v[*n - *k + i__ + i__ * v_dim1] = vii;
} else {
vii = v[i__ + (*n - *k + i__) * v_dim1];
v[i__ + (*n - *k + i__) * v_dim1] = 1.f;
/* Skip any leading zeros. */
i__1 = i__ - 1;
for (lastv = 1; lastv <= i__1; ++lastv) {
if (v[i__ + lastv * v_dim1] != 0.f) {
break;
}
}
j = max(lastv,prevlastv);
/* T(i+1:k,i) := */
/* - tau(i) * V(i+1:k,j:n-k+i) * V(i,j:n-k+i)' */
i__1 = *k - i__;
i__2 = *n - *k + i__ - j + 1;
r__1 = -tau[i__];
sgemv_("No transpose", &i__1, &i__2, &r__1, &v[i__ +
1 + j * v_dim1], ldv, &v[i__ + j * v_dim1],
ldv, &c_b8, &t[i__ + 1 + i__ * t_dim1], &c__1);
v[i__ + (*n - *k + i__) * v_dim1] = vii;
}
/* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i) */
i__1 = *k - i__;
strmv_("Lower", "No transpose", "Non-unit", &i__1, &t[i__
+ 1 + (i__ + 1) * t_dim1], ldt, &t[i__ + 1 + i__ *
t_dim1], &c__1)
;
if (i__ > 1) {
prevlastv = min(prevlastv,lastv);
} else {
prevlastv = lastv;
}
}
t[i__ + i__ * t_dim1] = tau[i__];
}
/* L40: */
}
}
return 0;
/* End of SLARFT */
} /* slarft_ */
/* Subroutine */ int strti2_(char *uplo, char *diag, integer *n, real *a,
integer *lda, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
/* Local variables */
integer j;
real ajj;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
logical upper;
extern /* Subroutine */ int strmv_(char *, char *, char *, integer *,
real *, integer *, real *, integer *),
xerbla_(char *, integer *);
logical nounit;
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* STRTI2 computes the inverse of a real upper or lower triangular */
/* matrix. */
/* This is the Level 2 BLAS version of the algorithm. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the matrix A is upper or lower triangular. */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* 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 order of the matrix A. N >= 0. */
/* A (input/output) REAL array, dimension (LDA,N) */
/* On entry, 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. */
/* On exit, the (triangular) inverse of the original matrix, in */
/* the same storage format. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -k, the k-th argument had an illegal value */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
nounit = lsame_(diag, "N");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (! nounit && ! lsame_(diag, "U")) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*lda < max(1,*n)) {
*info = -5;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("STRTI2", &i__1);
return 0;
}
if (upper) {
/* Compute inverse of upper triangular matrix. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (nounit) {
a[j + j * a_dim1] = 1.f / a[j + j * a_dim1];
ajj = -a[j + j * a_dim1];
} else {
ajj = -1.f;
}
/* Compute elements 1:j-1 of j-th column. */
i__2 = j - 1;
strmv_("Upper", "No transpose", diag, &i__2, &a[a_offset], lda, &
a[j * a_dim1 + 1], &c__1);
i__2 = j - 1;
sscal_(&i__2, &ajj, &a[j * a_dim1 + 1], &c__1);
/* L10: */
}
} else {
/* Compute inverse of lower triangular matrix. */
for (j = *n; j >= 1; --j) {
if (nounit) {
a[j + j * a_dim1] = 1.f / a[j + j * a_dim1];
ajj = -a[j + j * a_dim1];
} else {
ajj = -1.f;
}
if (j < *n) {
/* Compute elements j+1:n of j-th column. */
i__1 = *n - j;
strmv_("Lower", "No transpose", diag, &i__1, &a[j + 1 + (j +
1) * a_dim1], lda, &a[j + 1 + j * a_dim1], &c__1);
i__1 = *n - j;
sscal_(&i__1, &ajj, &a[j + 1 + j * a_dim1], &c__1);
}
/* L20: */
}
}
return 0;
/* End of STRTI2 */
} /* strti2_ */
/* Subroutine */ int strt03_(char *uplo, char *trans, char *diag, integer *n,
integer *nrhs, real *a, integer *lda, real *scale, real *cnorm, real *
tscal, real *x, integer *ldx, real *b, integer *ldb, real *work, real
*resid)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1;
real r__1, r__2, r__3;
/* Local variables */
integer j, ix;
real eps, err;
real xscal;
real tnorm, xnorm;
real bignum;
real smlnum;
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* STRT03 computes the residual for the solution to a scaled triangular */
/* system of equations A*x = s*b or A'*x = s*b. */
/* Here A is a triangular matrix, A' is the transpose of A, s is a */
/* scalar, and x and b are N by NRHS matrices. The test ratio is the */
/* maximum over the number of right hand sides of */
/* norm(s*b - op(A)*x) / ( norm(op(A)) * norm(x) * EPS ), */
/* where op(A) denotes A or A' and EPS is the machine epsilon. */
/* 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': A *x = s*b (No transpose) */
/* = 'T': A'*x = s*b (Transpose) */
/* = 'C': 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 */
/* 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 X and B. NRHS >= 0. */
/* A (input) REAL 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). */
/* SCALE (input) REAL */
/* The scaling factor s used in solving the triangular system. */
/* CNORM (input) REAL array, dimension (N) */
/* The 1-norms of the columns of A, not counting the diagonal. */
/* TSCAL (input) REAL */
/* The scaling factor used in computing the 1-norms in CNORM. */
/* CNORM actually contains the column norms of TSCAL*A. */
/* X (input) REAL array, dimension (LDX,NRHS) */
/* The computed solution vectors for the system of linear */
/* equations. */
/* LDX (input) INTEGER */
/* The leading dimension of the array X. LDX >= max(1,N). */
/* B (input) REAL 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). */
/* WORK (workspace) REAL array, dimension (N) */
/* RESID (output) REAL */
/* The maximum over the number of right hand sides of */
/* norm(op(A)*x - s*b) / ( norm(op(A)) * norm(x) * 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;
--cnorm;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--work;
/* Function Body */
if (*n <= 0 || *nrhs <= 0) {
*resid = 0.f;
return 0;
}
eps = slamch_("Epsilon");
smlnum = slamch_("Safe minimum");
bignum = 1.f / smlnum;
slabad_(&smlnum, &bignum);
/* Compute the norm of the triangular matrix A using the column */
/* norms already computed by SLATRS. */
tnorm = 0.f;
if (lsame_(diag, "N")) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
r__2 = tnorm, r__3 = *tscal * (r__1 = a[j + j * a_dim1], dabs(
r__1)) + cnorm[j];
tnorm = dmax(r__2,r__3);
/* L10: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
r__1 = tnorm, r__2 = *tscal + cnorm[j];
tnorm = dmax(r__1,r__2);
/* L20: */
}
}
/* Compute the maximum over the number of right hand sides of */
/* norm(op(A)*x - s*b) / ( norm(op(A)) * norm(x) * EPS ). */
*resid = 0.f;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
scopy_(n, &x[j * x_dim1 + 1], &c__1, &work[1], &c__1);
ix = isamax_(n, &work[1], &c__1);
/* Computing MAX */
r__2 = 1.f, r__3 = (r__1 = x[ix + j * x_dim1], dabs(r__1));
xnorm = dmax(r__2,r__3);
xscal = 1.f / xnorm / (real) (*n);
sscal_(n, &xscal, &work[1], &c__1);
strmv_(uplo, trans, diag, n, &a[a_offset], lda, &work[1], &c__1);
r__1 = -(*scale) * xscal;
saxpy_(n, &r__1, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
ix = isamax_(n, &work[1], &c__1);
err = *tscal * (r__1 = work[ix], dabs(r__1));
ix = isamax_(n, &x[j * x_dim1 + 1], &c__1);
xnorm = (r__1 = x[ix + j * x_dim1], dabs(r__1));
if (err * smlnum <= xnorm) {
if (xnorm > 0.f) {
err /= xnorm;
}
} else {
if (err > 0.f) {
err = 1.f / eps;
}
}
if (err * smlnum <= tnorm) {
if (tnorm > 0.f) {
err /= tnorm;
}
} else {
if (err > 0.f) {
err = 1.f / eps;
}
}
*resid = dmax(*resid,err);
/* L30: */
}
return 0;
/* End of STRT03 */
} /* strt03_ */
/* Subroutine */ int strt03_(char *uplo, char *trans, char *diag, integer *n,
integer *nrhs, real *a, integer *lda, real *scale, real *cnorm, real *
tscal, real *x, integer *ldx, real *b, integer *ldb, real *work, real
*resid)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1;
real r__1, r__2, r__3;
/* Local variables */
static integer j;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
static real xscal;
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *);
static real tnorm, xnorm;
extern /* Subroutine */ int saxpy_(integer *, real *, real *, integer *,
real *, integer *), strmv_(char *, char *, char *, integer *,
real *, integer *, real *, integer *),
slabad_(real *, real *);
static integer ix;
extern doublereal slamch_(char *);
static real bignum;
extern integer isamax_(integer *, real *, integer *);
static real smlnum, eps, err;
#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]
#define x_ref(a_1,a_2) x[(a_2)*x_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
=======
STRT03 computes the residual for the solution to a scaled triangular
system of equations A*x = s*b or A'*x = s*b.
Here A is a triangular matrix, A' is the transpose of A, s is a
scalar, and x and b are N by NRHS matrices. The test ratio is the
maximum over the number of right hand sides of
norm(s*b - op(A)*x) / ( norm(op(A)) * norm(x) * EPS ),
where op(A) denotes A or A' and EPS is the machine epsilon.
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': A *x = s*b (No transpose)
= 'T': A'*x = s*b (Transpose)
= 'C': 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
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 X and B. NRHS >= 0.
A (input) REAL 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).
SCALE (input) REAL
The scaling factor s used in solving the triangular system.
CNORM (input) REAL array, dimension (N)
The 1-norms of the columns of A, not counting the diagonal.
TSCAL (input) REAL
The scaling factor used in computing the 1-norms in CNORM.
CNORM actually contains the column norms of TSCAL*A.
X (input) REAL array, dimension (LDX,NRHS)
The computed solution vectors for the system of linear
equations.
LDX (input) INTEGER
The leading dimension of the array X. LDX >= max(1,N).
B (input) REAL 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).
WORK (workspace) REAL array, dimension (N)
RESID (output) REAL
The maximum over the number of right hand sides of
norm(op(A)*x - s*b) / ( norm(op(A)) * norm(x) * EPS ).
=====================================================================
Quick exit if N = 0
Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--cnorm;
x_dim1 = *ldx;
x_offset = 1 + x_dim1 * 1;
x -= x_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
--work;
/* Function Body */
if (*n <= 0 || *nrhs <= 0) {
*resid = 0.f;
return 0;
}
eps = slamch_("Epsilon");
smlnum = slamch_("Safe minimum");
bignum = 1.f / smlnum;
slabad_(&smlnum, &bignum);
/* Compute the norm of the triangular matrix A using the column
norms already computed by SLATRS. */
tnorm = 0.f;
if (lsame_(diag, "N")) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
r__2 = tnorm, r__3 = *tscal * (r__1 = a_ref(j, j), dabs(r__1)) +
cnorm[j];
tnorm = dmax(r__2,r__3);
/* L10: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
r__1 = tnorm, r__2 = *tscal + cnorm[j];
tnorm = dmax(r__1,r__2);
/* L20: */
}
}
/* Compute the maximum over the number of right hand sides of
norm(op(A)*x - s*b) / ( norm(op(A)) * norm(x) * EPS ). */
*resid = 0.f;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
scopy_(n, &x_ref(1, j), &c__1, &work[1], &c__1);
ix = isamax_(n, &work[1], &c__1);
/* Computing MAX */
r__2 = 1.f, r__3 = (r__1 = x_ref(ix, j), dabs(r__1));
xnorm = dmax(r__2,r__3);
xscal = 1.f / xnorm / (real) (*n);
sscal_(n, &xscal, &work[1], &c__1);
strmv_(uplo, trans, diag, n, &a[a_offset], lda, &work[1], &c__1);
r__1 = -(*scale) * xscal;
saxpy_(n, &r__1, &b_ref(1, j), &c__1, &work[1], &c__1);
ix = isamax_(n, &work[1], &c__1);
err = *tscal * (r__1 = work[ix], dabs(r__1));
ix = isamax_(n, &x_ref(1, j), &c__1);
xnorm = (r__1 = x_ref(ix, j), dabs(r__1));
if (err * smlnum <= xnorm) {
if (xnorm > 0.f) {
err /= xnorm;
}
} else {
if (err > 0.f) {
err = 1.f / eps;
}
}
if (err * smlnum <= tnorm) {
if (tnorm > 0.f) {
err /= tnorm;
}
} else {
if (err > 0.f) {
err = 1.f / eps;
}
}
*resid = dmax(*resid,err);
/* L30: */
}
return 0;
/* End of STRT03 */
} /* strt03_ */
/* Subroutine */ int spbt01_(char *uplo, integer *n, integer *kd, real *a,
integer *lda, real *afac, integer *ldafac, real *rwork, real *resid)
{
/* System generated locals */
integer a_dim1, a_offset, afac_dim1, afac_offset, i__1, i__2, i__3;
/* Local variables */
integer i__, j, k;
real t;
integer kc, ml, mu;
real eps;
integer klen;
extern doublereal sdot_(integer *, real *, integer *, real *, integer *);
extern /* Subroutine */ int ssyr_(char *, integer *, real *, real *,
integer *, real *, integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
real anorm;
extern /* Subroutine */ int strmv_(char *, char *, char *, integer *,
real *, integer *, real *, integer *);
extern doublereal slamch_(char *), slansb_(char *, char *,
integer *, integer *, real *, integer *, real *);
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SPBT01 reconstructs a symmetric positive definite band matrix A from */
/* its L*L' or U'*U factorization and computes the residual */
/* norm( L*L' - A ) / ( N * norm(A) * EPS ) or */
/* norm( U'*U - A ) / ( N * norm(A) * EPS ), */
/* where EPS is the machine epsilon, L' is the conjugate transpose of */
/* L, and U' is the conjugate transpose of U. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the upper or lower triangular part of the */
/* 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. */
/* KD (input) INTEGER */
/* The number of super-diagonals of the matrix A if UPLO = 'U', */
/* or the number of sub-diagonals if UPLO = 'L'. KD >= 0. */
/* A (input) REAL array, dimension (LDA,N) */
/* The original symmetric band matrix A. If UPLO = 'U', the */
/* upper triangular part of A is stored as a band matrix; if */
/* UPLO = 'L', the lower triangular part of A is stored. The */
/* columns of the appropriate triangle are stored in the columns */
/* of A and the diagonals of the triangle are stored in the rows */
/* of A. See SPBTRF for further details. */
/* LDA (input) INTEGER. */
/* The leading dimension of the array A. LDA >= max(1,KD+1). */
/* AFAC (input) REAL array, dimension (LDAFAC,N) */
/* The factored form of the matrix A. AFAC contains the factor */
/* L or U from the L*L' or U'*U factorization in band storage */
/* format, as computed by SPBTRF. */
/* LDAFAC (input) INTEGER */
/* The leading dimension of the array AFAC. */
/* LDAFAC >= max(1,KD+1). */
/* RWORK (workspace) REAL array, dimension (N) */
/* RESID (output) REAL */
/* If UPLO = 'L', norm(L*L' - A) / ( N * norm(A) * EPS ) */
/* If UPLO = 'U', norm(U'*U - A) / ( N * norm(A) * 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;
afac_dim1 = *ldafac;
afac_offset = 1 + afac_dim1;
afac -= afac_offset;
--rwork;
/* Function Body */
if (*n <= 0) {
*resid = 0.f;
return 0;
}
/* Exit with RESID = 1/EPS if ANORM = 0. */
eps = slamch_("Epsilon");
anorm = slansb_("1", uplo, n, kd, &a[a_offset], lda, &rwork[1]);
if (anorm <= 0.f) {
*resid = 1.f / eps;
return 0;
}
/* Compute the product U'*U, overwriting U. */
if (lsame_(uplo, "U")) {
for (k = *n; k >= 1; --k) {
/* Computing MAX */
i__1 = 1, i__2 = *kd + 2 - k;
kc = max(i__1,i__2);
klen = *kd + 1 - kc;
/* Compute the (K,K) element of the result. */
i__1 = klen + 1;
t = sdot_(&i__1, &afac[kc + k * afac_dim1], &c__1, &afac[kc + k *
afac_dim1], &c__1);
afac[*kd + 1 + k * afac_dim1] = t;
/* Compute the rest of column K. */
if (klen > 0) {
i__1 = *ldafac - 1;
strmv_("Upper", "Transpose", "Non-unit", &klen, &afac[*kd + 1
+ (k - klen) * afac_dim1], &i__1, &afac[kc + k *
afac_dim1], &c__1);
}
/* L10: */
}
/* UPLO = 'L': Compute the product L*L', overwriting L. */
} else {
for (k = *n; k >= 1; --k) {
/* Computing MIN */
i__1 = *kd, i__2 = *n - k;
klen = min(i__1,i__2);
/* Add a multiple of column K of the factor L to each of */
/* columns K+1 through N. */
if (klen > 0) {
i__1 = *ldafac - 1;
ssyr_("Lower", &klen, &c_b14, &afac[k * afac_dim1 + 2], &c__1,
&afac[(k + 1) * afac_dim1 + 1], &i__1);
}
/* Scale column K by the diagonal element. */
t = afac[k * afac_dim1 + 1];
i__1 = klen + 1;
sscal_(&i__1, &t, &afac[k * afac_dim1 + 1], &c__1);
/* L20: */
}
}
/* Compute the difference L*L' - A or U'*U - A. */
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = 1, i__3 = *kd + 2 - j;
mu = max(i__2,i__3);
i__2 = *kd + 1;
for (i__ = mu; i__ <= i__2; ++i__) {
afac[i__ + j * afac_dim1] -= a[i__ + j * a_dim1];
/* L30: */
}
/* L40: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
i__2 = *kd + 1, i__3 = *n - j + 1;
ml = min(i__2,i__3);
i__2 = ml;
for (i__ = 1; i__ <= i__2; ++i__) {
afac[i__ + j * afac_dim1] -= a[i__ + j * a_dim1];
/* L50: */
}
/* L60: */
}
}
/* Compute norm( L*L' - A ) / ( N * norm(A) * EPS ) */
*resid = slansb_("I", uplo, n, kd, &afac[afac_offset], ldafac, &rwork[1]);
*resid = *resid / (real) (*n) / anorm / eps;
return 0;
/* End of SPBT01 */
} /* spbt01_ */
/* Subroutine */
int slarft_(char *direct, char *storev, integer *n, integer * k, real *v, integer *ldv, real *tau, real *t, integer *ldt)
{
/* System generated locals */
integer t_dim1, t_offset, v_dim1, v_offset, i__1, i__2, i__3;
real r__1;
/* Local variables */
integer i__, j, prevlastv;
extern logical lsame_(char *, char *);
extern /* Subroutine */
int sgemv_(char *, integer *, integer *, real *, real *, integer *, real *, integer *, real *, real *, integer *);
integer lastv;
extern /* Subroutine */
int strmv_(char *, char *, char *, integer *, real *, integer *, real *, integer *);
/* -- LAPACK auxiliary routine (version 3.4.2) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* September 2012 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick return if possible */
/* Parameter adjustments */
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
--tau;
t_dim1 = *ldt;
t_offset = 1 + t_dim1;
t -= t_offset;
/* Function Body */
if (*n == 0)
{
return 0;
}
if (lsame_(direct, "F"))
{
prevlastv = *n;
i__1 = *k;
for (i__ = 1;
i__ <= i__1;
++i__)
{
prevlastv = max(i__,prevlastv);
if (tau[i__] == 0.f)
{
/* H(i) = I */
i__2 = i__;
for (j = 1;
j <= i__2;
++j)
{
t[j + i__ * t_dim1] = 0.f;
}
}
else
{
/* general case */
if (lsame_(storev, "C"))
{
/* Skip any trailing zeros. */
i__2 = i__ + 1;
for (lastv = *n;
lastv >= i__2;
--lastv)
{
if (v[lastv + i__ * v_dim1] != 0.f)
{
break;
}
}
i__2 = i__ - 1;
for (j = 1;
j <= i__2;
++j)
{
t[j + i__ * t_dim1] = -tau[i__] * v[i__ + j * v_dim1];
}
j = min(lastv,prevlastv);
/* T(1:i-1,i) := - tau(i) * V(i:j,1:i-1)**T * V(i:j,i) */
i__2 = j - i__;
i__3 = i__ - 1;
r__1 = -tau[i__];
sgemv_("Transpose", &i__2, &i__3, &r__1, &v[i__ + 1 + v_dim1], ldv, &v[i__ + 1 + i__ * v_dim1], &c__1, & c_b6, &t[i__ * t_dim1 + 1], &c__1);
}
else
{
/* Skip any trailing zeros. */
i__2 = i__ + 1;
for (lastv = *n;
lastv >= i__2;
--lastv)
{
if (v[i__ + lastv * v_dim1] != 0.f)
{
break;
}
}
i__2 = i__ - 1;
for (j = 1;
j <= i__2;
++j)
{
t[j + i__ * t_dim1] = -tau[i__] * v[j + i__ * v_dim1];
}
j = min(lastv,prevlastv);
/* T(1:i-1,i) := - tau(i) * V(1:i-1,i:j) * V(i,i:j)**T */
i__2 = i__ - 1;
i__3 = j - i__;
r__1 = -tau[i__];
sgemv_("No transpose", &i__2, &i__3, &r__1, &v[(i__ + 1) * v_dim1 + 1], ldv, &v[i__ + (i__ + 1) * v_dim1], ldv, &c_b6, &t[i__ * t_dim1 + 1], &c__1);
}
/* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) */
i__2 = i__ - 1;
strmv_("Upper", "No transpose", "Non-unit", &i__2, &t[ t_offset], ldt, &t[i__ * t_dim1 + 1], &c__1);
t[i__ + i__ * t_dim1] = tau[i__];
if (i__ > 1)
{
prevlastv = max(prevlastv,lastv);
}
else
{
prevlastv = lastv;
}
}
}
}
else
{
prevlastv = 1;
for (i__ = *k;
i__ >= 1;
--i__)
{
if (tau[i__] == 0.f)
{
/* H(i) = I */
i__1 = *k;
for (j = i__;
j <= i__1;
++j)
{
t[j + i__ * t_dim1] = 0.f;
}
}
else
{
/* general case */
if (i__ < *k)
{
if (lsame_(storev, "C"))
{
/* Skip any leading zeros. */
i__1 = i__ - 1;
for (lastv = 1;
lastv <= i__1;
++lastv)
{
if (v[lastv + i__ * v_dim1] != 0.f)
{
break;
}
}
i__1 = *k;
for (j = i__ + 1;
j <= i__1;
++j)
{
t[j + i__ * t_dim1] = -tau[i__] * v[*n - *k + i__ + j * v_dim1];
}
j = max(lastv,prevlastv);
/* T(i+1:k,i) = -tau(i) * V(j:n-k+i,i+1:k)**T * V(j:n-k+i,i) */
i__1 = *n - *k + i__ - j;
i__2 = *k - i__;
r__1 = -tau[i__];
sgemv_("Transpose", &i__1, &i__2, &r__1, &v[j + (i__ + 1) * v_dim1], ldv, &v[j + i__ * v_dim1], & c__1, &c_b6, &t[i__ + 1 + i__ * t_dim1], & c__1);
}
else
{
/* Skip any leading zeros. */
i__1 = i__ - 1;
for (lastv = 1;
lastv <= i__1;
++lastv)
{
if (v[i__ + lastv * v_dim1] != 0.f)
{
break;
}
}
i__1 = *k;
for (j = i__ + 1;
j <= i__1;
++j)
{
t[j + i__ * t_dim1] = -tau[i__] * v[j + (*n - *k + i__) * v_dim1];
}
j = max(lastv,prevlastv);
/* T(i+1:k,i) = -tau(i) * V(i+1:k,j:n-k+i) * V(i,j:n-k+i)**T */
i__1 = *k - i__;
i__2 = *n - *k + i__ - j;
r__1 = -tau[i__];
sgemv_("No transpose", &i__1, &i__2, &r__1, &v[i__ + 1 + j * v_dim1], ldv, &v[i__ + j * v_dim1], ldv, &c_b6, &t[i__ + 1 + i__ * t_dim1], &c__1);
}
/* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i) */
i__1 = *k - i__;
strmv_("Lower", "No transpose", "Non-unit", &i__1, &t[i__ + 1 + (i__ + 1) * t_dim1], ldt, &t[i__ + 1 + i__ * t_dim1], &c__1) ;
if (i__ > 1)
{
prevlastv = min(prevlastv,lastv);
}
else
{
prevlastv = lastv;
}
}
t[i__ + i__ * t_dim1] = tau[i__];
}
}
}
return 0;
/* End of SLARFT */
}
/* Subroutine */ int strrfs_(char *uplo, char *trans, char *diag, integer *n,
integer *nrhs, real *a, integer *lda, real *b, integer *ldb, real *x,
integer *ldx, real *ferr, real *berr, real *work, integer *iwork,
integer *info)
{
/* -- LAPACK 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
=======
STRRFS provides error bounds and backward error estimates for the
solution to a system of linear equations with a triangular
coefficient matrix.
The solution matrix X must be computed by STRTRS or some other
means before entering this routine. STRRFS does not do iterative
refinement because doing so cannot improve the backward error.
Arguments
=========
UPLO (input) CHARACTER*1
= 'U': A is upper triangular;
= 'L': A is lower triangular.
TRANS (input) CHARACTER*1
Specifies the form of the system of equations:
= 'N': A * X = B (No transpose)
= 'T': A**T * X = B (Transpose)
= 'C': A**H * X = B (Conjugate transpose = Transpose)
DIAG (input) CHARACTER*1
= 'N': A is non-unit triangular;
= 'U': A is unit triangular.
N (input) INTEGER
The order of the matrix A. N >= 0.
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) REAL 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) REAL 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) REAL array, dimension (LDX,NRHS)
The solution matrix X.
LDX (input) INTEGER
The leading dimension of the array X. LDX >= max(1,N).
FERR (output) REAL array, dimension (NRHS)
The estimated forward error bound for each solution vector
X(j) (the j-th column of the solution matrix X).
If XTRUE is the true solution corresponding to X(j), FERR(j)
is an estimated upper bound for the magnitude of the largest
element in (X(j) - XTRUE) divided by the magnitude of the
largest element in X(j). The estimate is as reliable as
the estimate for RCOND, and is almost always a slight
overestimate of the true error.
BERR (output) REAL array, dimension (NRHS)
The componentwise relative backward error of each solution
vector X(j) (i.e., the smallest relative change in
any element of A or B that makes X(j) an exact solution).
WORK (workspace) REAL 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
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
static real c_b19 = -1.f;
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1, i__2,
i__3;
real r__1, r__2, r__3;
/* Local variables */
static integer kase;
static real safe1, safe2;
static integer i__, j, k;
static real s;
extern logical lsame_(char *, char *);
static logical upper;
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *), saxpy_(integer *, real *, real *, integer *, real *,
integer *), strmv_(char *, char *, char *, integer *, real *,
integer *, real *, integer *), strsv_(
char *, char *, char *, integer *, real *, integer *, real *,
integer *);
static real xk;
extern doublereal slamch_(char *);
static integer nz;
static real safmin;
extern /* Subroutine */ int xerbla_(char *, integer *), slacon_(
integer *, real *, real *, integer *, real *, integer *);
static logical notran;
static char transt[1];
static logical nounit;
static real lstres, 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]
#define x_ref(a_1,a_2) x[(a_2)*x_dim1 + a_1]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1 * 1;
x -= x_offset;
--ferr;
--berr;
--work;
--iwork;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
notran = lsame_(trans, "N");
nounit = lsame_(diag, "N");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (! notran && ! lsame_(trans, "T") && !
lsame_(trans, "C")) {
*info = -2;
} else if (! nounit && ! lsame_(diag, "U")) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*nrhs < 0) {
*info = -5;
} else if (*lda < max(1,*n)) {
*info = -7;
} else if (*ldb < max(1,*n)) {
*info = -9;
} else if (*ldx < max(1,*n)) {
*info = -11;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("STRRFS", &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.f;
berr[j] = 0.f;
/* 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 = slamch_("Epsilon");
safmin = slamch_("Safe minimum");
safe1 = nz * safmin;
safe2 = safe1 / eps;
/* Do for each right hand side */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
/* Compute residual R = B - op(A) * X,
where op(A) = A or A', depending on TRANS. */
scopy_(n, &x_ref(1, j), &c__1, &work[*n + 1], &c__1);
strmv_(uplo, trans, diag, n, &a[a_offset], lda, &work[*n + 1], &c__1);
saxpy_(n, &c_b19, &b_ref(1, j), &c__1, &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__] = (r__1 = b_ref(i__, j), dabs(r__1));
/* L20: */
}
if (notran) {
/* Compute abs(A)*abs(X) + abs(B). */
if (upper) {
if (nounit) {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
xk = (r__1 = x_ref(k, j), dabs(r__1));
i__3 = k;
for (i__ = 1; i__ <= i__3; ++i__) {
work[i__] += (r__1 = a_ref(i__, k), dabs(r__1)) *
xk;
/* L30: */
}
/* L40: */
}
} else {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
xk = (r__1 = x_ref(k, j), dabs(r__1));
i__3 = k - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
work[i__] += (r__1 = a_ref(i__, k), dabs(r__1)) *
xk;
/* L50: */
}
work[k] += xk;
/* L60: */
}
}
} else {
if (nounit) {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
xk = (r__1 = x_ref(k, j), dabs(r__1));
i__3 = *n;
for (i__ = k; i__ <= i__3; ++i__) {
work[i__] += (r__1 = a_ref(i__, k), dabs(r__1)) *
xk;
/* L70: */
}
/* L80: */
}
} else {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
xk = (r__1 = x_ref(k, j), dabs(r__1));
i__3 = *n;
for (i__ = k + 1; i__ <= i__3; ++i__) {
work[i__] += (r__1 = a_ref(i__, k), dabs(r__1)) *
xk;
/* L90: */
}
work[k] += xk;
/* L100: */
}
}
}
} else {
/* Compute abs(A')*abs(X) + abs(B). */
if (upper) {
if (nounit) {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
s = 0.f;
i__3 = k;
for (i__ = 1; i__ <= i__3; ++i__) {
s += (r__1 = a_ref(i__, k), dabs(r__1)) * (r__2 =
x_ref(i__, j), dabs(r__2));
/* L110: */
}
work[k] += s;
/* L120: */
}
} else {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
s = (r__1 = x_ref(k, j), dabs(r__1));
i__3 = k - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
s += (r__1 = a_ref(i__, k), dabs(r__1)) * (r__2 =
x_ref(i__, j), dabs(r__2));
/* L130: */
}
work[k] += s;
/* L140: */
}
}
} else {
if (nounit) {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
s = 0.f;
i__3 = *n;
for (i__ = k; i__ <= i__3; ++i__) {
s += (r__1 = a_ref(i__, k), dabs(r__1)) * (r__2 =
x_ref(i__, j), dabs(r__2));
/* L150: */
}
work[k] += s;
/* L160: */
}
} else {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
s = (r__1 = x_ref(k, j), dabs(r__1));
i__3 = *n;
for (i__ = k + 1; i__ <= i__3; ++i__) {
s += (r__1 = a_ref(i__, k), dabs(r__1)) * (r__2 =
x_ref(i__, j), dabs(r__2));
/* L170: */
}
work[k] += s;
/* L180: */
}
}
}
}
s = 0.f;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
if (work[i__] > safe2) {
/* Computing MAX */
r__2 = s, r__3 = (r__1 = work[*n + i__], dabs(r__1)) / work[
i__];
s = dmax(r__2,r__3);
} else {
/* Computing MAX */
r__2 = s, r__3 = ((r__1 = work[*n + i__], dabs(r__1)) + safe1)
/ (work[i__] + safe1);
s = dmax(r__2,r__3);
}
/* L190: */
}
berr[j] = s;
/* Bound error from formula
norm(X - XTRUE) / norm(X) .le. FERR =
norm( abs(inv(op(A)))*
( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X)
where
norm(Z) is the magnitude of the largest component of Z
inv(op(A)) is the inverse of op(A)
abs(Z) is the componentwise absolute value of the matrix 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 SLACON 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__] = (r__1 = work[*n + i__], dabs(r__1)) + nz * eps *
work[i__];
} else {
work[i__] = (r__1 = work[*n + i__], dabs(r__1)) + nz * eps *
work[i__] + safe1;
}
/* L200: */
}
kase = 0;
L210:
slacon_(n, &work[(*n << 1) + 1], &work[*n + 1], &iwork[1], &ferr[j], &
kase);
if (kase != 0) {
if (kase == 1) {
/* Multiply by diag(W)*inv(op(A)'). */
strsv_(uplo, transt, diag, n, &a[a_offset], lda, &work[*n + 1]
, &c__1);
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
work[*n + i__] = work[i__] * work[*n + i__];
/* L220: */
}
} 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__];
/* L230: */
}
strsv_(uplo, trans, diag, n, &a[a_offset], lda, &work[*n + 1],
&c__1);
}
goto L210;
}
/* Normalize error. */
lstres = 0.f;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
r__2 = lstres, r__3 = (r__1 = x_ref(i__, j), dabs(r__1));
lstres = dmax(r__2,r__3);
/* L240: */
}
if (lstres != 0.f) {
ferr[j] /= lstres;
}
/* L250: */
}
return 0;
/* End of STRRFS */
} /* strrfs_ */
/* Subroutine */ int slarzt_(char *direct, char *storev, integer *n, integer *
k, real *v, integer *ldv, real *tau, real *t, integer *ldt)
{
/* System generated locals */
integer t_dim1, t_offset, v_dim1, v_offset, i__1;
real r__1;
/* Local variables */
integer i__, j, info;
/* -- LAPACK routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* SLARZT forms the triangular factor T of a real block reflector */
/* H of order > n, which is defined as a product of k elementary */
/* reflectors. */
/* If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular; */
/* If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular. */
/* If STOREV = 'C', the vector which defines the elementary reflector */
/* H(i) is stored in the i-th column of the array V, and */
/* H = I - V * T * V' */
/* If STOREV = 'R', the vector which defines the elementary reflector */
/* H(i) is stored in the i-th row of the array V, and */
/* H = I - V' * T * V */
/* Currently, only STOREV = 'R' and DIRECT = 'B' are supported. */
/* Arguments */
/* ========= */
/* DIRECT (input) CHARACTER*1 */
/* Specifies the order in which the elementary reflectors are */
/* multiplied to form the block reflector: */
/* = 'F': H = H(1) H(2) . . . H(k) (Forward, not supported yet) */
/* = 'B': H = H(k) . . . H(2) H(1) (Backward) */
/* STOREV (input) CHARACTER*1 */
/* Specifies how the vectors which define the elementary */
/* reflectors are stored (see also Further Details): */
/* = 'C': columnwise (not supported yet) */
/* = 'R': rowwise */
/* N (input) INTEGER */
/* The order of the block reflector H. N >= 0. */
/* K (input) INTEGER */
/* The order of the triangular factor T (= the number of */
/* elementary reflectors). K >= 1. */
/* V (input/output) REAL array, dimension */
/* (LDV,K) if STOREV = 'C' */
/* (LDV,N) if STOREV = 'R' */
/* The matrix V. See further details. */
/* LDV (input) INTEGER */
/* The leading dimension of the array V. */
/* If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K. */
/* TAU (input) REAL array, dimension (K) */
/* TAU(i) must contain the scalar factor of the elementary */
/* reflector H(i). */
/* T (output) REAL array, dimension (LDT,K) */
/* The k by k triangular factor T of the block reflector. */
/* If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is */
/* lower triangular. The rest of the array is not used. */
/* LDT (input) INTEGER */
/* The leading dimension of the array T. LDT >= K. */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA */
/* The shape of the matrix V and the storage of the vectors which define */
/* the H(i) is best illustrated by the following example with n = 5 and */
/* k = 3. The elements equal to 1 are not stored; the corresponding */
/* array elements are modified but restored on exit. The rest of the */
/* array is not used. */
/* DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': */
/* ______V_____ */
/* ( v1 v2 v3 ) / \ */
/* ( v1 v2 v3 ) ( v1 v1 v1 v1 v1 . . . . 1 ) */
/* V = ( v1 v2 v3 ) ( v2 v2 v2 v2 v2 . . . 1 ) */
/* ( v1 v2 v3 ) ( v3 v3 v3 v3 v3 . . 1 ) */
/* ( v1 v2 v3 ) */
/* . . . */
/* . . . */
/* 1 . . */
/* 1 . */
/* 1 */
/* DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': */
/* ______V_____ */
/* 1 / \ */
/* . 1 ( 1 . . . . v1 v1 v1 v1 v1 ) */
/* . . 1 ( . 1 . . . v2 v2 v2 v2 v2 ) */
/* . . . ( . . 1 . . v3 v3 v3 v3 v3 ) */
/* . . . */
/* ( v1 v2 v3 ) */
/* ( v1 v2 v3 ) */
/* V = ( v1 v2 v3 ) */
/* ( v1 v2 v3 ) */
/* ( v1 v2 v3 ) */
/* ===================================================================== */
/* Check for currently supported options */
/* Parameter adjustments */
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
--tau;
t_dim1 = *ldt;
t_offset = 1 + t_dim1;
t -= t_offset;
/* Function Body */
info = 0;
if (! lsame_(direct, "B")) {
info = -1;
} else if (! lsame_(storev, "R")) {
info = -2;
}
if (info != 0) {
i__1 = -info;
xerbla_("SLARZT", &i__1);
return 0;
}
for (i__ = *k; i__ >= 1; --i__) {
if (tau[i__] == 0.f) {
/* H(i) = I */
i__1 = *k;
for (j = i__; j <= i__1; ++j) {
t[j + i__ * t_dim1] = 0.f;
}
} else {
/* general case */
if (i__ < *k) {
/* T(i+1:k,i) = - tau(i) * V(i+1:k,1:n) * V(i,1:n)' */
i__1 = *k - i__;
r__1 = -tau[i__];
sgemv_("No transpose", &i__1, n, &r__1, &v[i__ + 1 + v_dim1],
ldv, &v[i__ + v_dim1], ldv, &c_b8, &t[i__ + 1 + i__ *
t_dim1], &c__1);
/* T(i+1:k,i) = T(i+1:k,i+1:k) * T(i+1:k,i) */
i__1 = *k - i__;
strmv_("Lower", "No transpose", "Non-unit", &i__1, &t[i__ + 1
+ (i__ + 1) * t_dim1], ldt, &t[i__ + 1 + i__ * t_dim1]
, &c__1);
}
t[i__ + i__ * t_dim1] = tau[i__];
}
}
return 0;
/* End of SLARZT */
} /* slarzt_ */
/* Subroutine */ int ssygs2_(integer *itype, char *uplo, integer *n, real *a,
integer *lda, real *b, integer *ldb, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
real r__1;
/* Local variables */
integer k;
real ct, akk, bkk;
extern /* Subroutine */ int ssyr2_(char *, integer *, real *, real *,
integer *, real *, integer *, real *, integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
logical upper;
extern /* Subroutine */ int saxpy_(integer *, real *, real *, integer *,
real *, integer *), strmv_(char *, char *, char *, integer *,
real *, integer *, real *, integer *),
strsv_(char *, char *, char *, integer *, real *, integer *, real
*, integer *), xerbla_(char *, integer *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SSYGS2 reduces a real symmetric-definite generalized eigenproblem */
/* to standard form. */
/* If ITYPE = 1, the problem is A*x = lambda*B*x, */
/* and A is overwritten by inv(U')*A*inv(U) or inv(L)*A*inv(L') */
/* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or */
/* B*A*x = lambda*x, and A is overwritten by U*A*U` or L'*A*L. */
/* B must have been previously factorized as U'*U or L*L' by SPOTRF. */
/* Arguments */
/* ========= */
/* ITYPE (input) INTEGER */
/* = 1: compute inv(U')*A*inv(U) or inv(L)*A*inv(L'); */
/* = 2 or 3: compute U*A*U' or L'*A*L. */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the upper or lower triangular part of the */
/* symmetric matrix A is stored, and how B has been factorized. */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* N (input) INTEGER */
/* The order of the matrices A and B. N >= 0. */
/* A (input/output) REAL array, dimension (LDA,N) */
/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */
/* n by n upper triangular part of A contains the upper */
/* triangular part of the matrix A, and the strictly lower */
/* triangular part of A is not referenced. If UPLO = 'L', the */
/* leading n by n lower triangular part of A contains the lower */
/* triangular part of the matrix A, and the strictly upper */
/* triangular part of A is not referenced. */
/* On exit, if INFO = 0, the transformed matrix, stored in the */
/* same format as A. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* B (input) REAL array, dimension (LDB,N) */
/* The triangular factor from the Cholesky factorization of B, */
/* as returned by SPOTRF. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* INFO (output) INTEGER */
/* = 0: successful exit. */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. 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;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (*itype < 1 || *itype > 3) {
*info = -1;
} else if (! upper && ! lsame_(uplo, "L")) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*lda < max(1,*n)) {
*info = -5;
} else if (*ldb < max(1,*n)) {
*info = -7;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SSYGS2", &i__1);
return 0;
}
if (*itype == 1) {
if (upper) {
/* Compute inv(U')*A*inv(U) */
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
/* Update the upper triangle of A(k:n,k:n) */
akk = a[k + k * a_dim1];
bkk = b[k + k * b_dim1];
/* Computing 2nd power */
r__1 = bkk;
akk /= r__1 * r__1;
a[k + k * a_dim1] = akk;
if (k < *n) {
i__2 = *n - k;
r__1 = 1.f / bkk;
sscal_(&i__2, &r__1, &a[k + (k + 1) * a_dim1], lda);
ct = akk * -.5f;
i__2 = *n - k;
saxpy_(&i__2, &ct, &b[k + (k + 1) * b_dim1], ldb, &a[k + (
k + 1) * a_dim1], lda);
i__2 = *n - k;
ssyr2_(uplo, &i__2, &c_b6, &a[k + (k + 1) * a_dim1], lda,
&b[k + (k + 1) * b_dim1], ldb, &a[k + 1 + (k + 1)
* a_dim1], lda);
i__2 = *n - k;
saxpy_(&i__2, &ct, &b[k + (k + 1) * b_dim1], ldb, &a[k + (
k + 1) * a_dim1], lda);
i__2 = *n - k;
strsv_(uplo, "Transpose", "Non-unit", &i__2, &b[k + 1 + (
k + 1) * b_dim1], ldb, &a[k + (k + 1) * a_dim1],
lda);
}
/* L10: */
}
} else {
/* Compute inv(L)*A*inv(L') */
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
/* Update the lower triangle of A(k:n,k:n) */
akk = a[k + k * a_dim1];
bkk = b[k + k * b_dim1];
/* Computing 2nd power */
r__1 = bkk;
akk /= r__1 * r__1;
a[k + k * a_dim1] = akk;
if (k < *n) {
i__2 = *n - k;
r__1 = 1.f / bkk;
sscal_(&i__2, &r__1, &a[k + 1 + k * a_dim1], &c__1);
ct = akk * -.5f;
i__2 = *n - k;
saxpy_(&i__2, &ct, &b[k + 1 + k * b_dim1], &c__1, &a[k +
1 + k * a_dim1], &c__1);
i__2 = *n - k;
ssyr2_(uplo, &i__2, &c_b6, &a[k + 1 + k * a_dim1], &c__1,
&b[k + 1 + k * b_dim1], &c__1, &a[k + 1 + (k + 1)
* a_dim1], lda);
i__2 = *n - k;
saxpy_(&i__2, &ct, &b[k + 1 + k * b_dim1], &c__1, &a[k +
1 + k * a_dim1], &c__1);
i__2 = *n - k;
strsv_(uplo, "No transpose", "Non-unit", &i__2, &b[k + 1
+ (k + 1) * b_dim1], ldb, &a[k + 1 + k * a_dim1],
&c__1);
}
/* L20: */
}
}
} else {
if (upper) {
/* Compute U*A*U' */
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
/* Update the upper triangle of A(1:k,1:k) */
akk = a[k + k * a_dim1];
bkk = b[k + k * b_dim1];
i__2 = k - 1;
strmv_(uplo, "No transpose", "Non-unit", &i__2, &b[b_offset],
ldb, &a[k * a_dim1 + 1], &c__1);
ct = akk * .5f;
i__2 = k - 1;
saxpy_(&i__2, &ct, &b[k * b_dim1 + 1], &c__1, &a[k * a_dim1 +
1], &c__1);
i__2 = k - 1;
ssyr2_(uplo, &i__2, &c_b27, &a[k * a_dim1 + 1], &c__1, &b[k *
b_dim1 + 1], &c__1, &a[a_offset], lda);
i__2 = k - 1;
saxpy_(&i__2, &ct, &b[k * b_dim1 + 1], &c__1, &a[k * a_dim1 +
1], &c__1);
i__2 = k - 1;
sscal_(&i__2, &bkk, &a[k * a_dim1 + 1], &c__1);
/* Computing 2nd power */
r__1 = bkk;
a[k + k * a_dim1] = akk * (r__1 * r__1);
/* L30: */
}
} else {
/* Compute L'*A*L */
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
/* Update the lower triangle of A(1:k,1:k) */
akk = a[k + k * a_dim1];
bkk = b[k + k * b_dim1];
i__2 = k - 1;
strmv_(uplo, "Transpose", "Non-unit", &i__2, &b[b_offset],
ldb, &a[k + a_dim1], lda);
ct = akk * .5f;
i__2 = k - 1;
saxpy_(&i__2, &ct, &b[k + b_dim1], ldb, &a[k + a_dim1], lda);
i__2 = k - 1;
ssyr2_(uplo, &i__2, &c_b27, &a[k + a_dim1], lda, &b[k +
b_dim1], ldb, &a[a_offset], lda);
i__2 = k - 1;
saxpy_(&i__2, &ct, &b[k + b_dim1], ldb, &a[k + a_dim1], lda);
i__2 = k - 1;
sscal_(&i__2, &bkk, &a[k + a_dim1], lda);
/* Computing 2nd power */
r__1 = bkk;
a[k + k * a_dim1] = akk * (r__1 * r__1);
/* L40: */
}
}
}
return 0;
/* End of SSYGS2 */
} /* ssygs2_ */
/* Subroutine */ int strt02_(char *uplo, char *trans, char *diag, integer *n,
integer *nrhs, real *a, integer *lda, real *x, integer *ldx, real *b,
integer *ldb, real *work, real *resid)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1;
real r__1, r__2;
/* Local variables */
static integer j;
extern logical lsame_(char *, char *);
static real anorm, bnorm;
extern doublereal sasum_(integer *, real *, integer *);
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *);
static real xnorm;
extern /* Subroutine */ int saxpy_(integer *, real *, real *, integer *,
real *, integer *), strmv_(char *, char *, char *, integer *,
real *, integer *, real *, integer *);
extern doublereal slamch_(char *), slantr_(char *, char *, char *,
integer *, integer *, real *, integer *, real *);
static real eps;
#define b_ref(a_1,a_2) b[(a_2)*b_dim1 + a_1]
#define x_ref(a_1,a_2) x[(a_2)*x_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
=======
STRT02 computes the residual for the computed solution to a
triangular system of linear equations A*x = b or A'*x = b.
Here A is a triangular matrix, A' is the transpose of A, and x and b
are N by NRHS matrices. The test ratio is the maximum over the
number of right hand sides of
norm(b - op(A)*x) / ( norm(op(A)) * norm(x) * EPS ),
where op(A) denotes A or A' and EPS is the machine epsilon.
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': 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 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 X and B. NRHS >= 0.
A (input) REAL 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).
X (input) REAL array, dimension (LDX,NRHS)
The computed solution vectors for the system of linear
equations.
LDX (input) INTEGER
The leading dimension of the array X. LDX >= max(1,N).
B (input) REAL 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).
WORK (workspace) REAL array, dimension (N)
RESID (output) REAL
The maximum over the number of right hand sides of
norm(op(A)*x - b) / ( norm(op(A)) * norm(x) * EPS ).
=====================================================================
Quick exit if N = 0 or NRHS = 0
Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1 * 1;
x -= x_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
--work;
/* Function Body */
if (*n <= 0 || *nrhs <= 0) {
*resid = 0.f;
return 0;
}
/* Compute the 1-norm of A or A'. */
if (lsame_(trans, "N")) {
anorm = slantr_("1", uplo, diag, n, n, &a[a_offset], lda, &work[1]);
} else {
anorm = slantr_("I", uplo, diag, n, n, &a[a_offset], lda, &work[1]);
}
/* Exit with RESID = 1/EPS if ANORM = 0. */
eps = slamch_("Epsilon");
if (anorm <= 0.f) {
*resid = 1.f / eps;
return 0;
}
/* Compute the maximum over the number of right hand sides of
norm(op(A)*x - b) / ( norm(op(A)) * norm(x) * EPS ) */
*resid = 0.f;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
scopy_(n, &x_ref(1, j), &c__1, &work[1], &c__1);
strmv_(uplo, trans, diag, n, &a[a_offset], lda, &work[1], &c__1);
saxpy_(n, &c_b10, &b_ref(1, j), &c__1, &work[1], &c__1);
bnorm = sasum_(n, &work[1], &c__1);
xnorm = sasum_(n, &x_ref(1, j), &c__1);
if (xnorm <= 0.f) {
*resid = 1.f / eps;
} else {
/* Computing MAX */
r__1 = *resid, r__2 = bnorm / anorm / xnorm / eps;
*resid = dmax(r__1,r__2);
}
/* L10: */
}
return 0;
/* End of STRT02 */
} /* strt02_ */
/* Subroutine */ int spst01_(char *uplo, integer *n, real *a, integer *lda,
real *afac, integer *ldafac, real *perm, integer *ldperm, integer *
piv, real *rwork, real *resid, integer *rank)
{
/* System generated locals */
integer a_dim1, a_offset, afac_dim1, afac_offset, perm_dim1, perm_offset,
i__1, i__2;
/* Local variables */
integer i__, j, k;
real t, eps;
extern doublereal sdot_(integer *, real *, integer *, real *, integer *);
extern /* Subroutine */ int ssyr_(char *, integer *, real *, real *,
integer *, real *, integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
real anorm;
extern /* Subroutine */ int strmv_(char *, char *, char *, integer *,
real *, integer *, real *, integer *);
extern doublereal slamch_(char *), slansy_(char *, char *,
integer *, real *, integer *, real *);
/* -- LAPACK test routine (version 3.1) -- */
/* Craig Lucas, University of Manchester / NAG Ltd. */
/* October, 2008 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SPST01 reconstructs a symmetric positive semidefinite matrix A */
/* from its L or U factors and the permutation matrix P and computes */
/* the residual */
/* norm( P*L*L'*P' - A ) / ( N * norm(A) * EPS ) or */
/* norm( P*U'*U*P' - A ) / ( N * norm(A) * EPS ), */
/* where EPS is the machine epsilon. */
/* Arguments */
/* ========== */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the upper or lower triangular part of the */
/* 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) REAL array, dimension (LDA,N) */
/* The original symmetric matrix A. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N) */
/* AFAC (input) REAL array, dimension (LDAFAC,N) */
/* The factor L or U from the L*L' or U'*U */
/* factorization of A. */
/* LDAFAC (input) INTEGER */
/* The leading dimension of the array AFAC. LDAFAC >= max(1,N). */
/* PERM (output) REAL array, dimension (LDPERM,N) */
/* Overwritten with the reconstructed matrix, and then with the */
/* difference P*L*L'*P' - A (or P*U'*U*P' - A) */
/* LDPERM (input) INTEGER */
/* The leading dimension of the array PERM. */
/* LDAPERM >= max(1,N). */
/* PIV (input) INTEGER array, dimension (N) */
/* PIV is such that the nonzero entries are */
/* P( PIV( K ), K ) = 1. */
/* RWORK (workspace) REAL array, dimension (N) */
/* RESID (output) REAL */
/* If UPLO = 'L', norm(L*L' - A) / ( N * norm(A) * EPS ) */
/* If UPLO = 'U', norm(U'*U - A) / ( N * norm(A) * 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;
afac_dim1 = *ldafac;
afac_offset = 1 + afac_dim1;
afac -= afac_offset;
perm_dim1 = *ldperm;
perm_offset = 1 + perm_dim1;
perm -= perm_offset;
--piv;
--rwork;
/* Function Body */
if (*n <= 0) {
*resid = 0.f;
return 0;
}
/* Exit with RESID = 1/EPS if ANORM = 0. */
eps = slamch_("Epsilon");
anorm = slansy_("1", uplo, n, &a[a_offset], lda, &rwork[1]);
if (anorm <= 0.f) {
*resid = 1.f / eps;
return 0;
}
/* Compute the product U'*U, overwriting U. */
if (lsame_(uplo, "U")) {
if (*rank < *n) {
i__1 = *n;
for (j = *rank + 1; j <= i__1; ++j) {
i__2 = j;
for (i__ = *rank + 1; i__ <= i__2; ++i__) {
afac[i__ + j * afac_dim1] = 0.f;
/* L100: */
}
/* L110: */
}
}
for (k = *n; k >= 1; --k) {
/* Compute the (K,K) element of the result. */
t = sdot_(&k, &afac[k * afac_dim1 + 1], &c__1, &afac[k *
afac_dim1 + 1], &c__1);
afac[k + k * afac_dim1] = t;
/* Compute the rest of column K. */
i__1 = k - 1;
strmv_("Upper", "Transpose", "Non-unit", &i__1, &afac[afac_offset]
, ldafac, &afac[k * afac_dim1 + 1], &c__1);
/* L120: */
}
/* Compute the product L*L', overwriting L. */
} else {
if (*rank < *n) {
i__1 = *n;
for (j = *rank + 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = j; i__ <= i__2; ++i__) {
afac[i__ + j * afac_dim1] = 0.f;
/* L130: */
}
/* L140: */
}
}
for (k = *n; k >= 1; --k) {
/* Add a multiple of column K of the factor L to each of */
/* columns K+1 through N. */
if (k + 1 <= *n) {
i__1 = *n - k;
ssyr_("Lower", &i__1, &c_b18, &afac[k + 1 + k * afac_dim1], &
c__1, &afac[k + 1 + (k + 1) * afac_dim1], ldafac);
}
/* Scale column K by the diagonal element. */
t = afac[k + k * afac_dim1];
i__1 = *n - k + 1;
sscal_(&i__1, &t, &afac[k + k * afac_dim1], &c__1);
/* L150: */
}
}
/* Form P*L*L'*P' or P*U'*U*P' */
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
if (piv[i__] <= piv[j]) {
if (i__ <= j) {
perm[piv[i__] + piv[j] * perm_dim1] = afac[i__ + j *
afac_dim1];
} else {
perm[piv[i__] + piv[j] * perm_dim1] = afac[j + i__ *
afac_dim1];
}
}
/* L160: */
}
/* L170: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
if (piv[i__] >= piv[j]) {
if (i__ >= j) {
perm[piv[i__] + piv[j] * perm_dim1] = afac[i__ + j *
afac_dim1];
} else {
perm[piv[i__] + piv[j] * perm_dim1] = afac[j + i__ *
afac_dim1];
}
}
/* L180: */
}
/* L190: */
}
}
/* Compute the difference P*L*L'*P' - A (or P*U'*U*P' - A). */
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
for (i__ = 1; i__ <= i__2; ++i__) {
perm[i__ + j * perm_dim1] -= a[i__ + j * a_dim1];
/* L200: */
}
/* L210: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = j; i__ <= i__2; ++i__) {
perm[i__ + j * perm_dim1] -= a[i__ + j * a_dim1];
/* L220: */
}
/* L230: */
}
}
/* Compute norm( P*L*L'P - A ) / ( N * norm(A) * EPS ), or */
/* ( P*U'*U*P' - A )/ ( N * norm(A) * EPS ). */
*resid = slansy_("1", uplo, n, &perm[perm_offset], ldafac, &rwork[1]);
*resid = *resid / (real) (*n) / anorm / eps;
return 0;
/* End of SPST01 */
} /* spst01_ */
/* Subroutine */ int strt01_(char *uplo, char *diag, integer *n, real *a,
integer *lda, real *ainv, integer *ldainv, real *rcond, real *work,
real *resid)
{
/* System generated locals */
integer a_dim1, a_offset, ainv_dim1, ainv_offset, i__1, i__2;
/* Local variables */
integer j;
real eps;
extern logical lsame_(char *, char *);
real anorm;
extern /* Subroutine */ int strmv_(char *, char *, char *, integer *,
real *, integer *, real *, integer *);
extern doublereal slamch_(char *);
real ainvnm;
extern doublereal slantr_(char *, char *, char *, integer *, integer *,
real *, integer *, real *);
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* STRT01 computes the residual for a triangular matrix A times its */
/* inverse: */
/* RESID = norm( A*AINV - I ) / ( N * norm(A) * norm(AINV) * EPS ), */
/* where EPS is the machine epsilon. */
/* Arguments */
/* ========== */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the matrix A is upper or lower triangular. */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* 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 order of the matrix A. N >= 0. */
/* A (input) REAL 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). */
/* AINV (input/output) REAL array, dimension (LDAINV,N) */
/* On entry, the (triangular) inverse of the matrix A, in the */
/* same storage format as A. */
/* On exit, the contents of AINV are destroyed. */
/* LDAINV (input) INTEGER */
/* The leading dimension of the array AINV. LDAINV >= max(1,N). */
/* RCOND (output) REAL */
/* The reciprocal condition number of A, computed as */
/* 1/(norm(A) * norm(AINV)). */
/* WORK (workspace) REAL array, dimension (N) */
/* RESID (output) REAL */
/* norm(A*AINV - I) / ( 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;
/* Function Body */
if (*n <= 0) {
*rcond = 1.f;
*resid = 0.f;
return 0;
}
/* Exit with RESID = 1/EPS if ANORM = 0 or AINVNM = 0. */
eps = slamch_("Epsilon");
anorm = slantr_("1", uplo, diag, n, n, &a[a_offset], lda, &work[1]);
ainvnm = slantr_("1", uplo, diag, n, n, &ainv[ainv_offset], ldainv, &work[
1]);
if (anorm <= 0.f || ainvnm <= 0.f) {
*rcond = 0.f;
*resid = 1.f / eps;
return 0;
}
*rcond = 1.f / anorm / ainvnm;
/* Set the diagonal of AINV to 1 if AINV has unit diagonal. */
if (lsame_(diag, "U")) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
ainv[j + j * ainv_dim1] = 1.f;
/* L10: */
}
}
/* Compute A * AINV, overwriting AINV. */
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
strmv_("Upper", "No transpose", diag, &j, &a[a_offset], lda, &
ainv[j * ainv_dim1 + 1], &c__1);
/* L20: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n - j + 1;
strmv_("Lower", "No transpose", diag, &i__2, &a[j + j * a_dim1],
lda, &ainv[j + j * ainv_dim1], &c__1);
/* L30: */
}
}
/* Subtract 1 from each diagonal element to form A*AINV - I. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
ainv[j + j * ainv_dim1] += -1.f;
/* L40: */
}
/* Compute norm(A*AINV - I) / (N * norm(A) * norm(AINV) * EPS) */
*resid = slantr_("1", uplo, "Non-unit", n, n, &ainv[ainv_offset], ldainv,
&work[1]);
*resid = *resid * *rcond / (real) (*n) / eps;
return 0;
/* End of STRT01 */
} /* strt01_ */
/* Subroutine */ int slahr2_(integer *n, integer *k, integer *nb, real *a,
integer *lda, real *tau, real *t, integer *ldt, real *y, integer *ldy)
{
/* System generated locals */
integer a_dim1, a_offset, t_dim1, t_offset, y_dim1, y_offset, i__1, i__2,
i__3;
real r__1;
/* Local variables */
integer i__;
real ei;
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *),
sgemm_(char *, char *, integer *, integer *, integer *, real *,
real *, integer *, real *, integer *, real *, real *, integer *), sgemv_(char *, integer *, integer *, real *,
real *, integer *, real *, integer *, real *, real *, integer *), scopy_(integer *, real *, integer *, real *, integer *),
strmm_(char *, char *, char *, char *, integer *, integer *, real
*, real *, integer *, real *, integer *), saxpy_(integer *, real *, real *, integer *, real *,
integer *), strmv_(char *, char *, char *, integer *, real *,
integer *, real *, integer *), slarfg_(
integer *, real *, real *, integer *, real *), slacpy_(char *,
integer *, integer *, real *, integer *, real *, integer *);
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SLAHR2 reduces the first NB columns of A real general n-BY-(n-k+1) */
/* matrix A so that elements below the k-th subdiagonal are zero. The */
/* reduction is performed by an orthogonal similarity transformation */
/* Q' * A * Q. The routine returns the matrices V and T which determine */
/* Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T. */
/* This is an auxiliary routine called by SGEHRD. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The order of the matrix A. */
/* K (input) INTEGER */
/* The offset for the reduction. Elements below the k-th */
/* subdiagonal in the first NB columns are reduced to zero. */
/* K < N. */
/* NB (input) INTEGER */
/* The number of columns to be reduced. */
/* A (input/output) REAL array, dimension (LDA,N-K+1) */
/* On entry, the n-by-(n-k+1) general matrix A. */
/* On exit, the elements on and above the k-th subdiagonal in */
/* the first NB columns are overwritten with the corresponding */
/* elements of the reduced matrix; the elements below the k-th */
/* subdiagonal, with the array TAU, represent the matrix Q as a */
/* product of elementary reflectors. The other columns of A are */
/* unchanged. See Further Details. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* TAU (output) REAL array, dimension (NB) */
/* The scalar factors of the elementary reflectors. See Further */
/* Details. */
/* T (output) REAL array, dimension (LDT,NB) */
/* The upper triangular matrix T. */
/* LDT (input) INTEGER */
/* The leading dimension of the array T. LDT >= NB. */
/* Y (output) REAL array, dimension (LDY,NB) */
/* The n-by-nb matrix Y. */
/* LDY (input) INTEGER */
/* The leading dimension of the array Y. LDY >= N. */
/* Further Details */
/* =============== */
/* The matrix Q is represented as a product of nb elementary reflectors */
/* Q = H(1) H(2) . . . H(nb). */
/* Each H(i) has the form */
/* H(i) = I - tau * v * v' */
/* where tau is a real scalar, and v is a real vector with */
/* v(1:i+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in */
/* A(i+k+1:n,i), and tau in TAU(i). */
/* The elements of the vectors v together form the (n-k+1)-by-nb matrix */
/* V which is needed, with T and Y, to apply the transformation to the */
/* unreduced part of the matrix, using an update of the form: */
/* A := (I - V*T*V') * (A - Y*V'). */
/* The contents of A on exit are illustrated by the following example */
/* with n = 7, k = 3 and nb = 2: */
/* ( a a a a a ) */
/* ( a a a a a ) */
/* ( a a a a a ) */
/* ( h h a a a ) */
/* ( v1 h a a a ) */
/* ( v1 v2 a a a ) */
/* ( v1 v2 a a a ) */
/* where a denotes an element of the original matrix A, h denotes a */
/* modified element of the upper Hessenberg matrix H, and vi denotes an */
/* element of the vector defining H(i). */
/* This file is a slight modification of LAPACK-3.0's SLAHRD */
/* incorporating improvements proposed by Quintana-Orti and Van de */
/* Gejin. Note that the entries of A(1:K,2:NB) differ from those */
/* returned by the original LAPACK routine. This function is */
/* not backward compatible with LAPACK3.0. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick return if possible */
/* Parameter adjustments */
--tau;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
t_dim1 = *ldt;
t_offset = 1 + t_dim1;
t -= t_offset;
y_dim1 = *ldy;
y_offset = 1 + y_dim1;
y -= y_offset;
/* Function Body */
if (*n <= 1) {
return 0;
}
i__1 = *nb;
for (i__ = 1; i__ <= i__1; ++i__) {
if (i__ > 1) {
/* Update A(K+1:N,I) */
/* Update I-th column of A - Y * V' */
i__2 = *n - *k;
i__3 = i__ - 1;
sgemv_("NO TRANSPOSE", &i__2, &i__3, &c_b4, &y[*k + 1 + y_dim1],
ldy, &a[*k + i__ - 1 + a_dim1], lda, &c_b5, &a[*k + 1 +
i__ * a_dim1], &c__1);
/* Apply I - V * T' * V' to this column (call it b) from the */
/* left, using the last column of T as workspace */
/* Let V = ( V1 ) and b = ( b1 ) (first I-1 rows) */
/* ( V2 ) ( b2 ) */
/* where V1 is unit lower triangular */
/* w := V1' * b1 */
i__2 = i__ - 1;
scopy_(&i__2, &a[*k + 1 + i__ * a_dim1], &c__1, &t[*nb * t_dim1 +
1], &c__1);
i__2 = i__ - 1;
strmv_("Lower", "Transpose", "UNIT", &i__2, &a[*k + 1 + a_dim1],
lda, &t[*nb * t_dim1 + 1], &c__1);
/* w := w + V2'*b2 */
i__2 = *n - *k - i__ + 1;
i__3 = i__ - 1;
sgemv_("Transpose", &i__2, &i__3, &c_b5, &a[*k + i__ + a_dim1],
lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b5, &t[*nb *
t_dim1 + 1], &c__1);
/* w := T'*w */
i__2 = i__ - 1;
strmv_("Upper", "Transpose", "NON-UNIT", &i__2, &t[t_offset], ldt,
&t[*nb * t_dim1 + 1], &c__1);
/* b2 := b2 - V2*w */
i__2 = *n - *k - i__ + 1;
i__3 = i__ - 1;
sgemv_("NO TRANSPOSE", &i__2, &i__3, &c_b4, &a[*k + i__ + a_dim1],
lda, &t[*nb * t_dim1 + 1], &c__1, &c_b5, &a[*k + i__ +
i__ * a_dim1], &c__1);
/* b1 := b1 - V1*w */
i__2 = i__ - 1;
strmv_("Lower", "NO TRANSPOSE", "UNIT", &i__2, &a[*k + 1 + a_dim1]
, lda, &t[*nb * t_dim1 + 1], &c__1);
i__2 = i__ - 1;
saxpy_(&i__2, &c_b4, &t[*nb * t_dim1 + 1], &c__1, &a[*k + 1 + i__
* a_dim1], &c__1);
a[*k + i__ - 1 + (i__ - 1) * a_dim1] = ei;
}
/* Generate the elementary reflector H(I) to annihilate */
/* A(K+I+1:N,I) */
i__2 = *n - *k - i__ + 1;
/* Computing MIN */
i__3 = *k + i__ + 1;
slarfg_(&i__2, &a[*k + i__ + i__ * a_dim1], &a[min(i__3, *n)+ i__ *
a_dim1], &c__1, &tau[i__]);
ei = a[*k + i__ + i__ * a_dim1];
a[*k + i__ + i__ * a_dim1] = 1.f;
/* Compute Y(K+1:N,I) */
i__2 = *n - *k;
i__3 = *n - *k - i__ + 1;
sgemv_("NO TRANSPOSE", &i__2, &i__3, &c_b5, &a[*k + 1 + (i__ + 1) *
a_dim1], lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b38, &y[*
k + 1 + i__ * y_dim1], &c__1);
i__2 = *n - *k - i__ + 1;
i__3 = i__ - 1;
sgemv_("Transpose", &i__2, &i__3, &c_b5, &a[*k + i__ + a_dim1], lda, &
a[*k + i__ + i__ * a_dim1], &c__1, &c_b38, &t[i__ * t_dim1 +
1], &c__1);
i__2 = *n - *k;
i__3 = i__ - 1;
sgemv_("NO TRANSPOSE", &i__2, &i__3, &c_b4, &y[*k + 1 + y_dim1], ldy,
&t[i__ * t_dim1 + 1], &c__1, &c_b5, &y[*k + 1 + i__ * y_dim1],
&c__1);
i__2 = *n - *k;
sscal_(&i__2, &tau[i__], &y[*k + 1 + i__ * y_dim1], &c__1);
/* Compute T(1:I,I) */
i__2 = i__ - 1;
r__1 = -tau[i__];
sscal_(&i__2, &r__1, &t[i__ * t_dim1 + 1], &c__1);
i__2 = i__ - 1;
strmv_("Upper", "No Transpose", "NON-UNIT", &i__2, &t[t_offset], ldt,
&t[i__ * t_dim1 + 1], &c__1)
;
t[i__ + i__ * t_dim1] = tau[i__];
/* L10: */
}
a[*k + *nb + *nb * a_dim1] = ei;
/* Compute Y(1:K,1:NB) */
slacpy_("ALL", k, nb, &a[(a_dim1 << 1) + 1], lda, &y[y_offset], ldy);
strmm_("RIGHT", "Lower", "NO TRANSPOSE", "UNIT", k, nb, &c_b5, &a[*k + 1
+ a_dim1], lda, &y[y_offset], ldy);
if (*n > *k + *nb) {
i__1 = *n - *k - *nb;
sgemm_("NO TRANSPOSE", "NO TRANSPOSE", k, nb, &i__1, &c_b5, &a[(*nb +
2) * a_dim1 + 1], lda, &a[*k + 1 + *nb + a_dim1], lda, &c_b5,
&y[y_offset], ldy);
}
strmm_("RIGHT", "Upper", "NO TRANSPOSE", "NON-UNIT", k, nb, &c_b5, &t[
t_offset], ldt, &y[y_offset], ldy);
return 0;
/* End of SLAHR2 */
} /* slahr2_ */
/* Subroutine */ int sgglse_(integer *m, integer *n, integer *p, real *a,
integer *lda, real *b, integer *ldb, real *c__, real *d__, real *x,
real *work, integer *lwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
/* Local variables */
integer nb, mn, nr, nb1, nb2, nb3, nb4, lopt;
extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *,
real *, integer *, real *, integer *, real *, real *, integer *), scopy_(integer *, real *, integer *, real *, integer *),
saxpy_(integer *, real *, real *, integer *, real *, integer *),
strmv_(char *, char *, char *, integer *, real *, integer *, real
*, integer *), xerbla_(char *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
extern /* Subroutine */ int sggrqf_(integer *, integer *, integer *, real
*, integer *, real *, real *, integer *, real *, real *, integer *
, integer *);
integer lwkmin, lwkopt;
logical lquery;
extern /* Subroutine */ int sormqr_(char *, char *, integer *, integer *,
integer *, real *, integer *, real *, real *, integer *, real *,
integer *, integer *), sormrq_(char *, char *,
integer *, integer *, integer *, real *, integer *, real *, real *
, integer *, real *, integer *, integer *),
strtrs_(char *, char *, char *, integer *, integer *, real *,
integer *, real *, integer *, integer *);
/* -- LAPACK driver routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SGGLSE solves the linear equality-constrained least squares (LSE) */
/* problem: */
/* minimize || c - A*x ||_2 subject to B*x = d */
/* where A is an M-by-N matrix, B is a P-by-N matrix, c is a given */
/* M-vector, and d is a given P-vector. It is assumed that */
/* P <= N <= M+P, and */
/* rank(B) = P and rank( (A) ) = N. */
/* ( (B) ) */
/* These conditions ensure that the LSE problem has a unique solution, */
/* which is obtained using a generalized RQ factorization of the */
/* matrices (B, A) given by */
/* B = (0 R)*Q, A = Z*T*Q. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows of the matrix A. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrices A and B. N >= 0. */
/* P (input) INTEGER */
/* The number of rows of the matrix B. 0 <= P <= N <= M+P. */
/* A (input/output) REAL array, dimension (LDA,N) */
/* On entry, the M-by-N matrix A. */
/* On exit, the elements on and above the diagonal of the array */
/* contain the min(M,N)-by-N upper trapezoidal matrix T. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* B (input/output) REAL array, dimension (LDB,N) */
/* On entry, the P-by-N matrix B. */
/* On exit, the upper triangle of the subarray B(1:P,N-P+1:N) */
/* contains the P-by-P upper triangular matrix R. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,P). */
/* C (input/output) REAL array, dimension (M) */
/* On entry, C contains the right hand side vector for the */
/* least squares part of the LSE problem. */
/* On exit, the residual sum of squares for the solution */
/* is given by the sum of squares of elements N-P+1 to M of */
/* vector C. */
/* D (input/output) REAL array, dimension (P) */
/* On entry, D contains the right hand side vector for the */
/* constrained equation. */
/* On exit, D is destroyed. */
/* X (output) REAL array, dimension (N) */
/* On exit, X is the solution of the LSE problem. */
/* WORK (workspace/output) REAL 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 >= max(1,M+N+P). */
/* For optimum performance LWORK >= P+min(M,N)+max(M,N)*NB, */
/* where NB is an upper bound for the optimal blocksizes for */
/* SGEQRF, SGERQF, SORMQR and SORMRQ. */
/* 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. */
/* INFO (output) INTEGER */
/* = 0: successful exit. */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* = 1: the upper triangular factor R associated with B in the */
/* generalized RQ factorization of the pair (B, A) is */
/* singular, so that rank(B) < P; the least squares */
/* solution could not be computed. */
/* = 2: the (N-P) by (N-P) part of the upper trapezoidal factor */
/* T associated with A in the generalized RQ factorization */
/* of the pair (B, A) is singular, so that */
/* rank( (A) ) < N; the least squares solution could not */
/* ( (B) ) */
/* be computed. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--c__;
--d__;
--x;
--work;
/* Function Body */
*info = 0;
mn = min(*m,*n);
lquery = *lwork == -1;
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*p < 0 || *p > *n || *p < *n - *m) {
*info = -3;
} else if (*lda < max(1,*m)) {
*info = -5;
} else if (*ldb < max(1,*p)) {
*info = -7;
}
/* Calculate workspace */
if (*info == 0) {
if (*n == 0) {
lwkmin = 1;
lwkopt = 1;
} else {
nb1 = ilaenv_(&c__1, "SGEQRF", " ", m, n, &c_n1, &c_n1);
nb2 = ilaenv_(&c__1, "SGERQF", " ", m, n, &c_n1, &c_n1);
nb3 = ilaenv_(&c__1, "SORMQR", " ", m, n, p, &c_n1);
nb4 = ilaenv_(&c__1, "SORMRQ", " ", m, n, p, &c_n1);
/* Computing MAX */
i__1 = max(nb1,nb2), i__1 = max(i__1,nb3);
nb = max(i__1,nb4);
lwkmin = *m + *n + *p;
lwkopt = *p + mn + max(*m,*n) * nb;
}
work[1] = (real) lwkopt;
if (*lwork < lwkmin && ! lquery) {
*info = -12;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SGGLSE", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Compute the GRQ factorization of matrices B and A: */
/* B*Q' = ( 0 T12 ) P Z'*A*Q' = ( R11 R12 ) N-P */
/* N-P P ( 0 R22 ) M+P-N */
/* N-P P */
/* where T12 and R11 are upper triangular, and Q and Z are */
/* orthogonal. */
i__1 = *lwork - *p - mn;
sggrqf_(p, m, n, &b[b_offset], ldb, &work[1], &a[a_offset], lda, &work[*p
+ 1], &work[*p + mn + 1], &i__1, info);
lopt = work[*p + mn + 1];
/* Update c = Z'*c = ( c1 ) N-P */
/* ( c2 ) M+P-N */
i__1 = max(1,*m);
i__2 = *lwork - *p - mn;
sormqr_("Left", "Transpose", m, &c__1, &mn, &a[a_offset], lda, &work[*p +
1], &c__[1], &i__1, &work[*p + mn + 1], &i__2, info);
/* Computing MAX */
i__1 = lopt, i__2 = (integer) work[*p + mn + 1];
lopt = max(i__1,i__2);
/* Solve T12*x2 = d for x2 */
if (*p > 0) {
strtrs_("Upper", "No transpose", "Non-unit", p, &c__1, &b[(*n - *p +
1) * b_dim1 + 1], ldb, &d__[1], p, info);
if (*info > 0) {
*info = 1;
return 0;
}
/* Put the solution in X */
scopy_(p, &d__[1], &c__1, &x[*n - *p + 1], &c__1);
/* Update c1 */
i__1 = *n - *p;
sgemv_("No transpose", &i__1, p, &c_b31, &a[(*n - *p + 1) * a_dim1 +
1], lda, &d__[1], &c__1, &c_b33, &c__[1], &c__1);
}
/* Solve R11*x1 = c1 for x1 */
if (*n > *p) {
i__1 = *n - *p;
i__2 = *n - *p;
strtrs_("Upper", "No transpose", "Non-unit", &i__1, &c__1, &a[
a_offset], lda, &c__[1], &i__2, info);
if (*info > 0) {
*info = 2;
return 0;
}
/* Put the solution in X */
i__1 = *n - *p;
scopy_(&i__1, &c__[1], &c__1, &x[1], &c__1);
}
/* Compute the residual vector: */
if (*m < *n) {
nr = *m + *p - *n;
if (nr > 0) {
i__1 = *n - *m;
sgemv_("No transpose", &nr, &i__1, &c_b31, &a[*n - *p + 1 + (*m +
1) * a_dim1], lda, &d__[nr + 1], &c__1, &c_b33, &c__[*n -
*p + 1], &c__1);
}
} else {
nr = *p;
}
if (nr > 0) {
strmv_("Upper", "No transpose", "Non unit", &nr, &a[*n - *p + 1 + (*n
- *p + 1) * a_dim1], lda, &d__[1], &c__1);
saxpy_(&nr, &c_b31, &d__[1], &c__1, &c__[*n - *p + 1], &c__1);
}
/* Backward transformation x = Q'*x */
i__1 = *lwork - *p - mn;
sormrq_("Left", "Transpose", n, &c__1, p, &b[b_offset], ldb, &work[1], &x[
1], n, &work[*p + mn + 1], &i__1, info);
/* Computing MAX */
i__1 = lopt, i__2 = (integer) work[*p + mn + 1];
work[1] = (real) (*p + mn + max(i__1,i__2));
return 0;
/* End of SGGLSE */
} /* sgglse_ */
/* Subroutine */ int sgglse_(integer *m, integer *n, integer *p, real *a,
integer *lda, real *b, integer *ldb, real *c__, real *d__, real *x,
real *work, integer *lwork, integer *info)
{
/* -- LAPACK driver 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
=======
SGGLSE solves the linear equality-constrained least squares (LSE)
problem:
minimize || c - A*x ||_2 subject to B*x = d
where A is an M-by-N matrix, B is a P-by-N matrix, c is a given
M-vector, and d is a given P-vector. It is assumed that
P <= N <= M+P, and
rank(B) = P and rank( ( A ) ) = N.
( ( B ) )
These conditions ensure that the LSE problem has a unique solution,
which is obtained using a GRQ factorization of the matrices B and A.
Arguments
=========
M (input) INTEGER
The number of rows of the matrix A. M >= 0.
N (input) INTEGER
The number of columns of the matrices A and B. N >= 0.
P (input) INTEGER
The number of rows of the matrix B. 0 <= P <= N <= M+P.
A (input/output) REAL array, dimension (LDA,N)
On entry, the M-by-N matrix A.
On exit, A is destroyed.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,M).
B (input/output) REAL array, dimension (LDB,N)
On entry, the P-by-N matrix B.
On exit, B is destroyed.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,P).
C (input/output) REAL array, dimension (M)
On entry, C contains the right hand side vector for the
least squares part of the LSE problem.
On exit, the residual sum of squares for the solution
is given by the sum of squares of elements N-P+1 to M of
vector C.
D (input/output) REAL array, dimension (P)
On entry, D contains the right hand side vector for the
constrained equation.
On exit, D is destroyed.
X (output) REAL array, dimension (N)
On exit, X is the solution of the LSE problem.
WORK (workspace/output) REAL array, dimension (LWORK)
On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
LWORK (input) INTEGER
The dimension of the array WORK. LWORK >= max(1,M+N+P).
For optimum performance LWORK >= P+min(M,N)+max(M,N)*NB,
where NB is an upper bound for the optimal blocksizes for
SGEQRF, SGERQF, SORMQR and SORMRQ.
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.
INFO (output) INTEGER
= 0: successful exit.
< 0: if INFO = -i, the i-th argument had an illegal value.
=====================================================================
Test the input parameters
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
static integer c_n1 = -1;
static real c_b29 = -1.f;
static real c_b31 = 1.f;
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
/* Local variables */
static integer lopt;
extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *,
real *, integer *, real *, integer *, real *, real *, integer *), scopy_(integer *, real *, integer *, real *, integer *),
saxpy_(integer *, real *, real *, integer *, real *, integer *),
strmv_(char *, char *, char *, integer *, real *, integer *, real
*, integer *), strsv_(char *, char *,
char *, integer *, real *, integer *, real *, integer *);
static integer nb, mn, nr;
extern /* Subroutine */ int xerbla_(char *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
extern /* Subroutine */ int sggrqf_(integer *, integer *, integer *, real
*, integer *, real *, real *, integer *, real *, real *, integer *
, integer *);
static integer nb1, nb2, nb3, nb4, lwkopt;
static logical lquery;
extern /* Subroutine */ int sormqr_(char *, char *, integer *, integer *,
integer *, real *, integer *, real *, real *, integer *, real *,
integer *, integer *), sormrq_(char *, char *,
integer *, integer *, integer *, real *, integer *, real *, real *
, integer *, real *, integer *, integer *);
#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]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
--c__;
--d__;
--x;
--work;
/* Function Body */
*info = 0;
mn = min(*m,*n);
nb1 = ilaenv_(&c__1, "SGEQRF", " ", m, n, &c_n1, &c_n1, (ftnlen)6, (
ftnlen)1);
nb2 = ilaenv_(&c__1, "SGERQF", " ", m, n, &c_n1, &c_n1, (ftnlen)6, (
ftnlen)1);
nb3 = ilaenv_(&c__1, "SORMQR", " ", m, n, p, &c_n1, (ftnlen)6, (ftnlen)1);
nb4 = ilaenv_(&c__1, "SORMRQ", " ", m, n, p, &c_n1, (ftnlen)6, (ftnlen)1);
/* Computing MAX */
i__1 = max(nb1,nb2), i__1 = max(i__1,nb3);
nb = max(i__1,nb4);
lwkopt = *p + mn + max(*m,*n) * nb;
work[1] = (real) lwkopt;
lquery = *lwork == -1;
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*p < 0 || *p > *n || *p < *n - *m) {
*info = -3;
} else if (*lda < max(1,*m)) {
*info = -5;
} else if (*ldb < max(1,*p)) {
*info = -7;
} else /* if(complicated condition) */ {
/* Computing MAX */
i__1 = 1, i__2 = *m + *n + *p;
if (*lwork < max(i__1,i__2) && ! lquery) {
*info = -12;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SGGLSE", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Compute the GRQ factorization of matrices B and A:
B*Q' = ( 0 T12 ) P Z'*A*Q' = ( R11 R12 ) N-P
N-P P ( 0 R22 ) M+P-N
N-P P
where T12 and R11 are upper triangular, and Q and Z are
orthogonal. */
i__1 = *lwork - *p - mn;
sggrqf_(p, m, n, &b[b_offset], ldb, &work[1], &a[a_offset], lda, &work[*p
+ 1], &work[*p + mn + 1], &i__1, info);
lopt = work[*p + mn + 1];
/* Update c = Z'*c = ( c1 ) N-P
( c2 ) M+P-N */
i__1 = max(1,*m);
i__2 = *lwork - *p - mn;
sormqr_("Left", "Transpose", m, &c__1, &mn, &a[a_offset], lda, &work[*p +
1], &c__[1], &i__1, &work[*p + mn + 1], &i__2, info);
/* Computing MAX */
i__1 = lopt, i__2 = (integer) work[*p + mn + 1];
lopt = max(i__1,i__2);
/* Solve T12*x2 = d for x2 */
strsv_("Upper", "No transpose", "Non unit", p, &b_ref(1, *n - *p + 1),
ldb, &d__[1], &c__1);
/* Update c1 */
i__1 = *n - *p;
sgemv_("No transpose", &i__1, p, &c_b29, &a_ref(1, *n - *p + 1), lda, &
d__[1], &c__1, &c_b31, &c__[1], &c__1);
/* Sovle R11*x1 = c1 for x1 */
i__1 = *n - *p;
strsv_("Upper", "No transpose", "Non unit", &i__1, &a[a_offset], lda, &
c__[1], &c__1);
/* Put the solutions in X */
i__1 = *n - *p;
scopy_(&i__1, &c__[1], &c__1, &x[1], &c__1);
scopy_(p, &d__[1], &c__1, &x[*n - *p + 1], &c__1);
/* Compute the residual vector: */
if (*m < *n) {
nr = *m + *p - *n;
i__1 = *n - *m;
sgemv_("No transpose", &nr, &i__1, &c_b29, &a_ref(*n - *p + 1, *m + 1)
, lda, &d__[nr + 1], &c__1, &c_b31, &c__[*n - *p + 1], &c__1);
} else {
nr = *p;
}
strmv_("Upper", "No transpose", "Non unit", &nr, &a_ref(*n - *p + 1, *n -
*p + 1), lda, &d__[1], &c__1);
saxpy_(&nr, &c_b29, &d__[1], &c__1, &c__[*n - *p + 1], &c__1);
/* Backward transformation x = Q'*x */
i__1 = *lwork - *p - mn;
sormrq_("Left", "Transpose", n, &c__1, p, &b[b_offset], ldb, &work[1], &x[
1], n, &work[*p + mn + 1], &i__1, info);
/* Computing MAX */
i__1 = lopt, i__2 = (integer) work[*p + mn + 1];
work[1] = (real) (*p + mn + max(i__1,i__2));
return 0;
/* End of SGGLSE */
} /* sgglse_ */
void STARPU_STRMV(const char *uplo, const char *transA, const char *diag,
const int n, const float *A, const int lda, float *X,
const int incX)
{
strmv_(uplo, transA, diag, &n, A, &lda, X, &incX);
}
