/* Solve a triangular system of the form A * X = B or A^T * X = B */
void THLapack_(trtrs)(char uplo, char trans, char diag, int n, int nrhs, real *a, int lda, real *b, int ldb, int* info)
{
#ifdef USE_LAPACK
#if defined(TH_REAL_IS_DOUBLE)
dtrtrs_(&uplo, &trans, &diag, &n, &nrhs, a, &lda, b, &ldb, info);
#else
strtrs_(&uplo, &trans, &diag, &n, &nrhs, a, &lda, b, &ldb, info);
#endif
#else
THError("trtrs : Lapack library not found in compile time\n");
#endif
return;
}
/* Subroutine */ int sgels_(char *trans, integer *m, integer *n, integer *
nrhs, real *a, integer *lda, real *b, integer *ldb, 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 i__, j, nb, mn;
real anrm, bnrm;
integer brow;
logical tpsd;
integer iascl, ibscl;
extern logical lsame_(char *, char *);
integer wsize;
real rwork[1];
extern /* Subroutine */ int slabad_(real *, real *);
extern doublereal slamch_(char *), slange_(char *, integer *,
integer *, real *, integer *, real *);
extern /* Subroutine */ int xerbla_(char *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
integer scllen;
real bignum;
extern /* Subroutine */ int sgelqf_(integer *, integer *, real *, integer
*, real *, real *, integer *, integer *), slascl_(char *, integer
*, integer *, real *, real *, integer *, integer *, real *,
integer *, integer *), sgeqrf_(integer *, integer *, real
*, integer *, real *, real *, integer *, integer *), slaset_(char
*, integer *, integer *, real *, real *, real *, integer *);
real smlnum;
extern /* Subroutine */ int sormlq_(char *, char *, integer *, integer *,
integer *, real *, integer *, real *, real *, integer *, real *,
integer *, integer *);
logical lquery;
extern /* Subroutine */ int sormqr_(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.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SGELS solves overdetermined or underdetermined real linear systems */
/* involving an M-by-N matrix A, or its transpose, using a QR or LQ */
/* factorization of A. It is assumed that A has full rank. */
/* The following options are provided: */
/* 1. If TRANS = 'N' and m >= n: find the least squares solution of */
/* an overdetermined system, i.e., solve the least squares problem */
/* minimize || B - A*X ||. */
/* 2. If TRANS = 'N' and m < n: find the minimum norm solution of */
/* an underdetermined system A * X = B. */
/* 3. If TRANS = 'T' and m >= n: find the minimum norm solution of */
/* an undetermined system A**T * X = B. */
/* 4. If TRANS = 'T' and m < n: find the least squares solution of */
/* an overdetermined system, i.e., solve the least squares problem */
/* minimize || B - A**T * X ||. */
/* Several right hand side vectors b and solution vectors x can be */
/* handled in a single call; they are stored as the columns of the */
/* M-by-NRHS right hand side matrix B and the N-by-NRHS solution */
/* matrix X. */
/* Arguments */
/* ========= */
/* TRANS (input) CHARACTER*1 */
/* = 'N': the linear system involves A; */
/* = 'T': the linear system involves A**T. */
/* M (input) INTEGER */
/* The number of rows of the matrix A. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix A. N >= 0. */
/* NRHS (input) INTEGER */
/* The number of right hand sides, i.e., the number of */
/* columns of the matrices B and X. NRHS >=0. */
/* A (input/output) REAL array, dimension (LDA,N) */
/* On entry, the M-by-N matrix A. */
/* On exit, */
/* if M >= N, A is overwritten by details of its QR */
/* factorization as returned by SGEQRF; */
/* if M < N, A is overwritten by details of its LQ */
/* factorization as returned by SGELQF. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* B (input/output) REAL array, dimension (LDB,NRHS) */
/* On entry, the matrix B of right hand side vectors, stored */
/* columnwise; B is M-by-NRHS if TRANS = 'N', or N-by-NRHS */
/* if TRANS = 'T'. */
/* On exit, if INFO = 0, B is overwritten by the solution */
/* vectors, stored columnwise: */
/* if TRANS = 'N' and m >= n, rows 1 to n of B contain the least */
/* squares solution vectors; the residual sum of squares for the */
/* solution in each column is given by the sum of squares of */
/* elements N+1 to M in that column; */
/* if TRANS = 'N' and m < n, rows 1 to N of B contain the */
/* minimum norm solution vectors; */
/* if TRANS = 'T' and m >= n, rows 1 to M of B contain the */
/* minimum norm solution vectors; */
/* if TRANS = 'T' and m < n, rows 1 to M of B contain the */
/* least squares solution vectors; the residual sum of squares */
/* for the solution in each column is given by the sum of */
/* squares of elements M+1 to N in that column. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= MAX(1,M,N). */
/* 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, MN + max( MN, NRHS ) ). */
/* For optimal performance, */
/* LWORK >= max( 1, MN + max( MN, NRHS )*NB ). */
/* where MN = min(M,N) and NB is the optimum block size. */
/* 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 */
/* > 0: if INFO = i, the i-th diagonal element of the */
/* triangular factor of A is zero, so that A does not have */
/* full rank; the least squares solution could not be */
/* computed. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--work;
/* Function Body */
*info = 0;
mn = min(*m,*n);
lquery = *lwork == -1;
if (! (lsame_(trans, "N") || lsame_(trans, "T"))) {
*info = -1;
} else if (*m < 0) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*nrhs < 0) {
*info = -4;
} else if (*lda < max(1,*m)) {
*info = -6;
} else /* if(complicated condition) */ {
/* Computing MAX */
i__1 = max(1,*m);
if (*ldb < max(i__1,*n)) {
*info = -8;
} else /* if(complicated condition) */ {
/* Computing MAX */
i__1 = 1, i__2 = mn + max(mn,*nrhs);
if (*lwork < max(i__1,i__2) && ! lquery) {
*info = -10;
}
}
}
/* Figure out optimal block size */
if (*info == 0 || *info == -10) {
tpsd = TRUE_;
if (lsame_(trans, "N")) {
tpsd = FALSE_;
}
if (*m >= *n) {
nb = ilaenv_(&c__1, "SGEQRF", " ", m, n, &c_n1, &c_n1);
if (tpsd) {
/* Computing MAX */
i__1 = nb, i__2 = ilaenv_(&c__1, "SORMQR", "LN", m, nrhs, n, &
c_n1);
nb = max(i__1,i__2);
} else {
/* Computing MAX */
i__1 = nb, i__2 = ilaenv_(&c__1, "SORMQR", "LT", m, nrhs, n, &
c_n1);
nb = max(i__1,i__2);
}
} else {
nb = ilaenv_(&c__1, "SGELQF", " ", m, n, &c_n1, &c_n1);
if (tpsd) {
/* Computing MAX */
i__1 = nb, i__2 = ilaenv_(&c__1, "SORMLQ", "LT", n, nrhs, m, &
c_n1);
nb = max(i__1,i__2);
} else {
/* Computing MAX */
i__1 = nb, i__2 = ilaenv_(&c__1, "SORMLQ", "LN", n, nrhs, m, &
c_n1);
nb = max(i__1,i__2);
}
}
/* Computing MAX */
i__1 = 1, i__2 = mn + max(mn,*nrhs) * nb;
wsize = max(i__1,i__2);
work[1] = (real) wsize;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SGELS ", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
/* Computing MIN */
i__1 = min(*m,*n);
if (min(i__1,*nrhs) == 0) {
i__1 = max(*m,*n);
slaset_("Full", &i__1, nrhs, &c_b33, &c_b33, &b[b_offset], ldb);
return 0;
}
/* Get machine parameters */
smlnum = slamch_("S") / slamch_("P");
bignum = 1.f / smlnum;
slabad_(&smlnum, &bignum);
/* Scale A, B if max element outside range [SMLNUM,BIGNUM] */
anrm = slange_("M", m, n, &a[a_offset], lda, rwork);
iascl = 0;
if (anrm > 0.f && anrm < smlnum) {
/* Scale matrix norm up to SMLNUM */
slascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda,
info);
iascl = 1;
} else if (anrm > bignum) {
/* Scale matrix norm down to BIGNUM */
slascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda,
info);
iascl = 2;
} else if (anrm == 0.f) {
/* Matrix all zero. Return zero solution. */
i__1 = max(*m,*n);
slaset_("F", &i__1, nrhs, &c_b33, &c_b33, &b[b_offset], ldb);
goto L50;
}
brow = *m;
if (tpsd) {
brow = *n;
}
bnrm = slange_("M", &brow, nrhs, &b[b_offset], ldb, rwork);
ibscl = 0;
if (bnrm > 0.f && bnrm < smlnum) {
/* Scale matrix norm up to SMLNUM */
slascl_("G", &c__0, &c__0, &bnrm, &smlnum, &brow, nrhs, &b[b_offset],
ldb, info);
ibscl = 1;
} else if (bnrm > bignum) {
/* Scale matrix norm down to BIGNUM */
slascl_("G", &c__0, &c__0, &bnrm, &bignum, &brow, nrhs, &b[b_offset],
ldb, info);
ibscl = 2;
}
if (*m >= *n) {
/* compute QR factorization of A */
i__1 = *lwork - mn;
sgeqrf_(m, n, &a[a_offset], lda, &work[1], &work[mn + 1], &i__1, info)
;
/* workspace at least N, optimally N*NB */
if (! tpsd) {
/* Least-Squares Problem min || A * X - B || */
/* B(1:M,1:NRHS) := Q' * B(1:M,1:NRHS) */
i__1 = *lwork - mn;
sormqr_("Left", "Transpose", m, nrhs, n, &a[a_offset], lda, &work[
1], &b[b_offset], ldb, &work[mn + 1], &i__1, info);
/* workspace at least NRHS, optimally NRHS*NB */
/* B(1:N,1:NRHS) := inv(R) * B(1:N,1:NRHS) */
strtrs_("Upper", "No transpose", "Non-unit", n, nrhs, &a[a_offset]
, lda, &b[b_offset], ldb, info);
if (*info > 0) {
return 0;
}
scllen = *n;
} else {
/* Overdetermined system of equations A' * X = B */
/* B(1:N,1:NRHS) := inv(R') * B(1:N,1:NRHS) */
strtrs_("Upper", "Transpose", "Non-unit", n, nrhs, &a[a_offset],
lda, &b[b_offset], ldb, info);
if (*info > 0) {
return 0;
}
/* B(N+1:M,1:NRHS) = ZERO */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = *n + 1; i__ <= i__2; ++i__) {
b[i__ + j * b_dim1] = 0.f;
/* L10: */
}
/* L20: */
}
/* B(1:M,1:NRHS) := Q(1:N,:) * B(1:N,1:NRHS) */
i__1 = *lwork - mn;
sormqr_("Left", "No transpose", m, nrhs, n, &a[a_offset], lda, &
work[1], &b[b_offset], ldb, &work[mn + 1], &i__1, info);
/* workspace at least NRHS, optimally NRHS*NB */
scllen = *m;
}
} else {
/* Compute LQ factorization of A */
i__1 = *lwork - mn;
sgelqf_(m, n, &a[a_offset], lda, &work[1], &work[mn + 1], &i__1, info)
;
/* workspace at least M, optimally M*NB. */
if (! tpsd) {
/* underdetermined system of equations A * X = B */
/* B(1:M,1:NRHS) := inv(L) * B(1:M,1:NRHS) */
strtrs_("Lower", "No transpose", "Non-unit", m, nrhs, &a[a_offset]
, lda, &b[b_offset], ldb, info);
if (*info > 0) {
return 0;
}
/* B(M+1:N,1:NRHS) = 0 */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = *m + 1; i__ <= i__2; ++i__) {
b[i__ + j * b_dim1] = 0.f;
/* L30: */
}
/* L40: */
}
/* B(1:N,1:NRHS) := Q(1:N,:)' * B(1:M,1:NRHS) */
i__1 = *lwork - mn;
sormlq_("Left", "Transpose", n, nrhs, m, &a[a_offset], lda, &work[
1], &b[b_offset], ldb, &work[mn + 1], &i__1, info);
/* workspace at least NRHS, optimally NRHS*NB */
scllen = *n;
} else {
/* overdetermined system min || A' * X - B || */
/* B(1:N,1:NRHS) := Q * B(1:N,1:NRHS) */
i__1 = *lwork - mn;
sormlq_("Left", "No transpose", n, nrhs, m, &a[a_offset], lda, &
work[1], &b[b_offset], ldb, &work[mn + 1], &i__1, info);
/* workspace at least NRHS, optimally NRHS*NB */
/* B(1:M,1:NRHS) := inv(L') * B(1:M,1:NRHS) */
strtrs_("Lower", "Transpose", "Non-unit", m, nrhs, &a[a_offset],
lda, &b[b_offset], ldb, info);
if (*info > 0) {
return 0;
}
scllen = *m;
}
}
/* Undo scaling */
if (iascl == 1) {
slascl_("G", &c__0, &c__0, &anrm, &smlnum, &scllen, nrhs, &b[b_offset]
, ldb, info);
} else if (iascl == 2) {
slascl_("G", &c__0, &c__0, &anrm, &bignum, &scllen, nrhs, &b[b_offset]
, ldb, info);
}
if (ibscl == 1) {
slascl_("G", &c__0, &c__0, &smlnum, &bnrm, &scllen, nrhs, &b[b_offset]
, ldb, info);
} else if (ibscl == 2) {
slascl_("G", &c__0, &c__0, &bignum, &bnrm, &scllen, nrhs, &b[b_offset]
, ldb, info);
}
L50:
work[1] = (real) wsize;
return 0;
/* End of SGELS */
} /* sgels_ */
/* 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 sggglm_(integer *n, integer *m, integer *p, real *a,
integer *lda, real *b, integer *ldb, real *d__, real *x, real *y,
real *work, integer *lwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4;
/* Local variables */
integer i__, nb, np, 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 *),
xerbla_(char *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
extern /* Subroutine */ int sggqrf_(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 */
/* ======= */
/* SGGGLM solves a general Gauss-Markov linear model (GLM) problem: */
/* minimize || y ||_2 subject to d = A*x + B*y */
/* x */
/* where A is an N-by-M matrix, B is an N-by-P matrix, and d is a */
/* given N-vector. It is assumed that M <= N <= M+P, and */
/* rank(A) = M and rank( A B ) = N. */
/* Under these assumptions, the constrained equation is always */
/* consistent, and there is a unique solution x and a minimal 2-norm */
/* solution y, which is obtained using a generalized QR factorization */
/* of the matrices (A, B) given by */
/* A = Q*(R), B = Q*T*Z. */
/* (0) */
/* In particular, if matrix B is square nonsingular, then the problem */
/* GLM is equivalent to the following weighted linear least squares */
/* problem */
/* minimize || inv(B)*(d-A*x) ||_2 */
/* x */
/* where inv(B) denotes the inverse of B. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The number of rows of the matrices A and B. N >= 0. */
/* M (input) INTEGER */
/* The number of columns of the matrix A. 0 <= M <= N. */
/* P (input) INTEGER */
/* The number of columns of the matrix B. P >= N-M. */
/* A (input/output) REAL array, dimension (LDA,M) */
/* On entry, the N-by-M matrix A. */
/* On exit, the upper triangular part of the array A contains */
/* the M-by-M upper triangular matrix R. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* B (input/output) REAL array, dimension (LDB,P) */
/* On entry, the N-by-P matrix B. */
/* On exit, if N <= P, the upper triangle of the subarray */
/* B(1:N,P-N+1:P) contains the N-by-N upper triangular matrix T; */
/* if N > P, the elements on and above the (N-P)th subdiagonal */
/* contain the N-by-P upper trapezoidal matrix T. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* D (input/output) REAL array, dimension (N) */
/* On entry, D is the left hand side of the GLM equation. */
/* On exit, D is destroyed. */
/* X (output) REAL array, dimension (M) */
/* Y (output) REAL array, dimension (P) */
/* On exit, X and Y are the solutions of the GLM 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,N+M+P). */
/* For optimum performance, LWORK >= M+min(N,P)+max(N,P)*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 A in the */
/* generalized QR factorization of the pair (A, B) is */
/* singular, so that rank(A) < M; the least squares */
/* solution could not be computed. */
/* = 2: the bottom (N-M) by (N-M) part of the upper trapezoidal */
/* factor T associated with B in the generalized QR */
/* factorization of the pair (A, B) is singular, so that */
/* rank( A B ) < N; the least squares solution could not */
/* 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;
--d__;
--x;
--y;
--work;
/* Function Body */
*info = 0;
np = min(*n,*p);
lquery = *lwork == -1;
if (*n < 0) {
*info = -1;
} else if (*m < 0 || *m > *n) {
*info = -2;
} else if (*p < 0 || *p < *n - *m) {
*info = -3;
} else if (*lda < max(1,*n)) {
*info = -5;
} else if (*ldb < max(1,*n)) {
*info = -7;
}
/* Calculate workspace */
if (*info == 0) {
if (*n == 0) {
lwkmin = 1;
lwkopt = 1;
} else {
nb1 = ilaenv_(&c__1, "SGEQRF", " ", n, m, &c_n1, &c_n1);
nb2 = ilaenv_(&c__1, "SGERQF", " ", n, m, &c_n1, &c_n1);
nb3 = ilaenv_(&c__1, "SORMQR", " ", n, m, p, &c_n1);
nb4 = ilaenv_(&c__1, "SORMRQ", " ", n, m, 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 = *m + np + max(*n,*p) * nb;
}
work[1] = (real) lwkopt;
if (*lwork < lwkmin && ! lquery) {
*info = -12;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SGGGLM", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Compute the GQR factorization of matrices A and B: */
/* Q'*A = ( R11 ) M, Q'*B*Z' = ( T11 T12 ) M */
/* ( 0 ) N-M ( 0 T22 ) N-M */
/* M M+P-N N-M */
/* where R11 and T22 are upper triangular, and Q and Z are */
/* orthogonal. */
i__1 = *lwork - *m - np;
sggqrf_(n, m, p, &a[a_offset], lda, &work[1], &b[b_offset], ldb, &work[*m
+ 1], &work[*m + np + 1], &i__1, info);
lopt = work[*m + np + 1];
/* Update left-hand-side vector d = Q'*d = ( d1 ) M */
/* ( d2 ) N-M */
i__1 = max(1,*n);
i__2 = *lwork - *m - np;
sormqr_("Left", "Transpose", n, &c__1, m, &a[a_offset], lda, &work[1], &
d__[1], &i__1, &work[*m + np + 1], &i__2, info);
/* Computing MAX */
i__1 = lopt, i__2 = (integer) work[*m + np + 1];
lopt = max(i__1,i__2);
/* Solve T22*y2 = d2 for y2 */
if (*n > *m) {
i__1 = *n - *m;
i__2 = *n - *m;
strtrs_("Upper", "No transpose", "Non unit", &i__1, &c__1, &b[*m + 1
+ (*m + *p - *n + 1) * b_dim1], ldb, &d__[*m + 1], &i__2,
info);
if (*info > 0) {
*info = 1;
return 0;
}
i__1 = *n - *m;
scopy_(&i__1, &d__[*m + 1], &c__1, &y[*m + *p - *n + 1], &c__1);
}
/* Set y1 = 0 */
i__1 = *m + *p - *n;
for (i__ = 1; i__ <= i__1; ++i__) {
y[i__] = 0.f;
/* L10: */
}
/* Update d1 = d1 - T12*y2 */
i__1 = *n - *m;
sgemv_("No transpose", m, &i__1, &c_b32, &b[(*m + *p - *n + 1) * b_dim1 +
1], ldb, &y[*m + *p - *n + 1], &c__1, &c_b34, &d__[1], &c__1);
/* Solve triangular system: R11*x = d1 */
if (*m > 0) {
strtrs_("Upper", "No Transpose", "Non unit", m, &c__1, &a[a_offset],
lda, &d__[1], m, info);
if (*info > 0) {
*info = 2;
return 0;
}
/* Copy D to X */
scopy_(m, &d__[1], &c__1, &x[1], &c__1);
}
/* Backward transformation y = Z'*y */
/* Computing MAX */
i__1 = 1, i__2 = *n - *p + 1;
i__3 = max(1,*p);
i__4 = *lwork - *m - np;
sormrq_("Left", "Transpose", p, &c__1, &np, &b[max(i__1, i__2)+ b_dim1],
ldb, &work[*m + 1], &y[1], &i__3, &work[*m + np + 1], &i__4, info);
/* Computing MAX */
i__1 = lopt, i__2 = (integer) work[*m + np + 1];
work[1] = (real) (*m + np + max(i__1,i__2));
return 0;
/* End of SGGGLM */
} /* sggglm_ */
/* Subroutine */ int serrtr_(char *path, integer *nunit)
{
/* Builtin functions */
integer s_wsle(cilist *), e_wsle(void);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
real a[4] /* was [2][2] */, b[2], w[2], x[2];
char c2[2];
real r1[2], r2[2];
integer iw[2], info;
real scale, rcond;
extern /* Subroutine */ int strti2_(char *, char *, integer *, real *,
integer *, integer *), alaesm_(char *, logical *,
integer *);
extern logical lsamen_(integer *, char *, char *);
extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical
*, logical *), slatbs_(char *, char *, char *, char *,
integer *, integer *, real *, integer *, real *, real *, real *,
integer *), stbcon_(char *, char *
, char *, integer *, integer *, real *, integer *, real *, real *,
integer *, integer *), stbrfs_(char *,
char *, char *, integer *, integer *, integer *, real *, integer *
, real *, integer *, real *, integer *, real *, real *, real *,
integer *, integer *), slatps_(char *,
char *, char *, char *, integer *, real *, real *, real *, real *,
integer *), stpcon_(char *, char
*, char *, integer *, real *, real *, real *, integer *, integer *
), slatrs_(char *, char *, char *, char *,
integer *, real *, integer *, real *, real *, real *, integer *), strcon_(char *, char *, char *,
integer *, real *, integer *, real *, real *, integer *, integer *
), stbtrs_(char *, char *, char *,
integer *, integer *, integer *, real *, integer *, real *,
integer *, integer *), stprfs_(char *,
char *, char *, integer *, integer *, real *, real *, integer *,
real *, integer *, real *, real *, real *, integer *, integer *), strrfs_(char *, char *, char *, integer *
, integer *, real *, integer *, real *, integer *, real *,
integer *, real *, real *, real *, integer *, integer *), stptri_(char *, char *, integer *, real *,
integer *), strtri_(char *, char *, integer *,
real *, integer *, integer *), stptrs_(char *,
char *, char *, integer *, integer *, real *, real *, integer *,
integer *), strtrs_(char *, char *, char *
, integer *, integer *, real *, integer *, real *, integer *,
integer *);
/* Fortran I/O blocks */
static cilist io___1 = { 0, 0, 0, 0, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SERRTR tests the error exits for the REAL triangular */
/* routines. */
/* Arguments */
/* ========= */
/* PATH (input) CHARACTER*3 */
/* The LAPACK path name for the routines to be tested. */
/* NUNIT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Executable Statements .. */
infoc_1.nout = *nunit;
io___1.ciunit = infoc_1.nout;
s_wsle(&io___1);
e_wsle();
s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
a[0] = 1.f;
a[2] = 2.f;
a[3] = 3.f;
a[1] = 4.f;
infoc_1.ok = TRUE_;
if (lsamen_(&c__2, c2, "TR")) {
/* Test error exits for the general triangular routines. */
/* STRTRI */
s_copy(srnamc_1.srnamt, "STRTRI", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
strtri_("/", "N", &c__0, a, &c__1, &info);
chkxer_("STRTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
strtri_("U", "/", &c__0, a, &c__1, &info);
chkxer_("STRTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
strtri_("U", "N", &c_n1, a, &c__1, &info);
chkxer_("STRTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
strtri_("U", "N", &c__2, a, &c__1, &info);
chkxer_("STRTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* STRTI2 */
s_copy(srnamc_1.srnamt, "STRTI2", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
strti2_("/", "N", &c__0, a, &c__1, &info);
chkxer_("STRTI2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
strti2_("U", "/", &c__0, a, &c__1, &info);
chkxer_("STRTI2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
strti2_("U", "N", &c_n1, a, &c__1, &info);
chkxer_("STRTI2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
strti2_("U", "N", &c__2, a, &c__1, &info);
chkxer_("STRTI2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* STRTRS */
s_copy(srnamc_1.srnamt, "STRTRS", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
strtrs_("/", "N", "N", &c__0, &c__0, a, &c__1, x, &c__1, &info);
chkxer_("STRTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
strtrs_("U", "/", "N", &c__0, &c__0, a, &c__1, x, &c__1, &info);
chkxer_("STRTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
strtrs_("U", "N", "/", &c__0, &c__0, a, &c__1, x, &c__1, &info);
chkxer_("STRTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
strtrs_("U", "N", "N", &c_n1, &c__0, a, &c__1, x, &c__1, &info);
chkxer_("STRTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
strtrs_("U", "N", "N", &c__0, &c_n1, a, &c__1, x, &c__1, &info);
chkxer_("STRTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
strtrs_("U", "N", "N", &c__2, &c__1, a, &c__1, x, &c__2, &info);
chkxer_("STRTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 9;
strtrs_("U", "N", "N", &c__2, &c__1, a, &c__2, x, &c__1, &info);
chkxer_("STRTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* STRRFS */
s_copy(srnamc_1.srnamt, "STRRFS", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
strrfs_("/", "N", "N", &c__0, &c__0, a, &c__1, b, &c__1, x, &c__1, r1,
r2, w, iw, &info);
chkxer_("STRRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
strrfs_("U", "/", "N", &c__0, &c__0, a, &c__1, b, &c__1, x, &c__1, r1,
r2, w, iw, &info);
chkxer_("STRRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
strrfs_("U", "N", "/", &c__0, &c__0, a, &c__1, b, &c__1, x, &c__1, r1,
r2, w, iw, &info);
chkxer_("STRRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
strrfs_("U", "N", "N", &c_n1, &c__0, a, &c__1, b, &c__1, x, &c__1, r1,
r2, w, iw, &info);
chkxer_("STRRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
strrfs_("U", "N", "N", &c__0, &c_n1, a, &c__1, b, &c__1, x, &c__1, r1,
r2, w, iw, &info);
chkxer_("STRRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
strrfs_("U", "N", "N", &c__2, &c__1, a, &c__1, b, &c__2, x, &c__2, r1,
r2, w, iw, &info);
chkxer_("STRRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 9;
strrfs_("U", "N", "N", &c__2, &c__1, a, &c__2, b, &c__1, x, &c__2, r1,
r2, w, iw, &info);
chkxer_("STRRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 11;
strrfs_("U", "N", "N", &c__2, &c__1, a, &c__2, b, &c__2, x, &c__1, r1,
r2, w, iw, &info);
chkxer_("STRRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* STRCON */
s_copy(srnamc_1.srnamt, "STRCON", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
strcon_("/", "U", "N", &c__0, a, &c__1, &rcond, w, iw, &info);
chkxer_("STRCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
strcon_("1", "/", "N", &c__0, a, &c__1, &rcond, w, iw, &info);
chkxer_("STRCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
strcon_("1", "U", "/", &c__0, a, &c__1, &rcond, w, iw, &info);
chkxer_("STRCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
strcon_("1", "U", "N", &c_n1, a, &c__1, &rcond, w, iw, &info);
chkxer_("STRCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
strcon_("1", "U", "N", &c__2, a, &c__1, &rcond, w, iw, &info);
chkxer_("STRCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* SLATRS */
s_copy(srnamc_1.srnamt, "SLATRS", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
slatrs_("/", "N", "N", "N", &c__0, a, &c__1, x, &scale, w, &info);
chkxer_("SLATRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
slatrs_("U", "/", "N", "N", &c__0, a, &c__1, x, &scale, w, &info);
chkxer_("SLATRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
slatrs_("U", "N", "/", "N", &c__0, a, &c__1, x, &scale, w, &info);
chkxer_("SLATRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
slatrs_("U", "N", "N", "/", &c__0, a, &c__1, x, &scale, w, &info);
chkxer_("SLATRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
slatrs_("U", "N", "N", "N", &c_n1, a, &c__1, x, &scale, w, &info);
chkxer_("SLATRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
slatrs_("U", "N", "N", "N", &c__2, a, &c__1, x, &scale, w, &info);
chkxer_("SLATRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
} else if (lsamen_(&c__2, c2, "TP")) {
/* Test error exits for the packed triangular routines. */
/* STPTRI */
s_copy(srnamc_1.srnamt, "STPTRI", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
stptri_("/", "N", &c__0, a, &info);
chkxer_("STPTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
stptri_("U", "/", &c__0, a, &info);
chkxer_("STPTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
stptri_("U", "N", &c_n1, a, &info);
chkxer_("STPTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* STPTRS */
s_copy(srnamc_1.srnamt, "STPTRS", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
stptrs_("/", "N", "N", &c__0, &c__0, a, x, &c__1, &info);
chkxer_("STPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
stptrs_("U", "/", "N", &c__0, &c__0, a, x, &c__1, &info);
chkxer_("STPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
stptrs_("U", "N", "/", &c__0, &c__0, a, x, &c__1, &info);
chkxer_("STPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
stptrs_("U", "N", "N", &c_n1, &c__0, a, x, &c__1, &info);
chkxer_("STPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
stptrs_("U", "N", "N", &c__0, &c_n1, a, x, &c__1, &info);
chkxer_("STPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
stptrs_("U", "N", "N", &c__2, &c__1, a, x, &c__1, &info);
chkxer_("STPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* STPRFS */
s_copy(srnamc_1.srnamt, "STPRFS", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
stprfs_("/", "N", "N", &c__0, &c__0, a, b, &c__1, x, &c__1, r1, r2, w,
iw, &info);
chkxer_("STPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
stprfs_("U", "/", "N", &c__0, &c__0, a, b, &c__1, x, &c__1, r1, r2, w,
iw, &info);
chkxer_("STPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
stprfs_("U", "N", "/", &c__0, &c__0, a, b, &c__1, x, &c__1, r1, r2, w,
iw, &info);
chkxer_("STPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
stprfs_("U", "N", "N", &c_n1, &c__0, a, b, &c__1, x, &c__1, r1, r2, w,
iw, &info);
chkxer_("STPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
stprfs_("U", "N", "N", &c__0, &c_n1, a, b, &c__1, x, &c__1, r1, r2, w,
iw, &info);
chkxer_("STPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
stprfs_("U", "N", "N", &c__2, &c__1, a, b, &c__1, x, &c__2, r1, r2, w,
iw, &info);
chkxer_("STPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 10;
stprfs_("U", "N", "N", &c__2, &c__1, a, b, &c__2, x, &c__1, r1, r2, w,
iw, &info);
chkxer_("STPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* STPCON */
s_copy(srnamc_1.srnamt, "STPCON", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
stpcon_("/", "U", "N", &c__0, a, &rcond, w, iw, &info);
chkxer_("STPCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
stpcon_("1", "/", "N", &c__0, a, &rcond, w, iw, &info);
chkxer_("STPCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
stpcon_("1", "U", "/", &c__0, a, &rcond, w, iw, &info);
chkxer_("STPCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
stpcon_("1", "U", "N", &c_n1, a, &rcond, w, iw, &info);
chkxer_("STPCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* SLATPS */
s_copy(srnamc_1.srnamt, "SLATPS", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
slatps_("/", "N", "N", "N", &c__0, a, x, &scale, w, &info);
chkxer_("SLATPS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
slatps_("U", "/", "N", "N", &c__0, a, x, &scale, w, &info);
chkxer_("SLATPS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
slatps_("U", "N", "/", "N", &c__0, a, x, &scale, w, &info);
chkxer_("SLATPS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
slatps_("U", "N", "N", "/", &c__0, a, x, &scale, w, &info);
chkxer_("SLATPS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
slatps_("U", "N", "N", "N", &c_n1, a, x, &scale, w, &info);
chkxer_("SLATPS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
} else if (lsamen_(&c__2, c2, "TB")) {
/* Test error exits for the banded triangular routines. */
/* STBTRS */
s_copy(srnamc_1.srnamt, "STBTRS", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
stbtrs_("/", "N", "N", &c__0, &c__0, &c__0, a, &c__1, x, &c__1, &info);
chkxer_("STBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
stbtrs_("U", "/", "N", &c__0, &c__0, &c__0, a, &c__1, x, &c__1, &info);
chkxer_("STBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
stbtrs_("U", "N", "/", &c__0, &c__0, &c__0, a, &c__1, x, &c__1, &info);
chkxer_("STBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
stbtrs_("U", "N", "N", &c_n1, &c__0, &c__0, a, &c__1, x, &c__1, &info);
chkxer_("STBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
stbtrs_("U", "N", "N", &c__0, &c_n1, &c__0, a, &c__1, x, &c__1, &info);
chkxer_("STBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
stbtrs_("U", "N", "N", &c__0, &c__0, &c_n1, a, &c__1, x, &c__1, &info);
chkxer_("STBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
stbtrs_("U", "N", "N", &c__2, &c__1, &c__1, a, &c__1, x, &c__2, &info);
chkxer_("STBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 10;
stbtrs_("U", "N", "N", &c__2, &c__0, &c__1, a, &c__1, x, &c__1, &info);
chkxer_("STBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* STBRFS */
s_copy(srnamc_1.srnamt, "STBRFS", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
stbrfs_("/", "N", "N", &c__0, &c__0, &c__0, a, &c__1, b, &c__1, x, &
c__1, r1, r2, w, iw, &info);
chkxer_("STBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
stbrfs_("U", "/", "N", &c__0, &c__0, &c__0, a, &c__1, b, &c__1, x, &
c__1, r1, r2, w, iw, &info);
chkxer_("STBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
stbrfs_("U", "N", "/", &c__0, &c__0, &c__0, a, &c__1, b, &c__1, x, &
c__1, r1, r2, w, iw, &info);
chkxer_("STBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
stbrfs_("U", "N", "N", &c_n1, &c__0, &c__0, a, &c__1, b, &c__1, x, &
c__1, r1, r2, w, iw, &info);
chkxer_("STBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
stbrfs_("U", "N", "N", &c__0, &c_n1, &c__0, a, &c__1, b, &c__1, x, &
c__1, r1, r2, w, iw, &info);
chkxer_("STBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
stbrfs_("U", "N", "N", &c__0, &c__0, &c_n1, a, &c__1, b, &c__1, x, &
c__1, r1, r2, w, iw, &info);
chkxer_("STBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
stbrfs_("U", "N", "N", &c__2, &c__1, &c__1, a, &c__1, b, &c__2, x, &
c__2, r1, r2, w, iw, &info);
chkxer_("STBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 10;
stbrfs_("U", "N", "N", &c__2, &c__1, &c__1, a, &c__2, b, &c__1, x, &
c__2, r1, r2, w, iw, &info);
chkxer_("STBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 12;
stbrfs_("U", "N", "N", &c__2, &c__1, &c__1, a, &c__2, b, &c__2, x, &
c__1, r1, r2, w, iw, &info);
chkxer_("STBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* STBCON */
s_copy(srnamc_1.srnamt, "STBCON", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
stbcon_("/", "U", "N", &c__0, &c__0, a, &c__1, &rcond, w, iw, &info);
chkxer_("STBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
stbcon_("1", "/", "N", &c__0, &c__0, a, &c__1, &rcond, w, iw, &info);
chkxer_("STBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
stbcon_("1", "U", "/", &c__0, &c__0, a, &c__1, &rcond, w, iw, &info);
chkxer_("STBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
stbcon_("1", "U", "N", &c_n1, &c__0, a, &c__1, &rcond, w, iw, &info);
chkxer_("STBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
stbcon_("1", "U", "N", &c__0, &c_n1, a, &c__1, &rcond, w, iw, &info);
chkxer_("STBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
stbcon_("1", "U", "N", &c__2, &c__1, a, &c__1, &rcond, w, iw, &info);
chkxer_("STBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* SLATBS */
s_copy(srnamc_1.srnamt, "SLATBS", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
slatbs_("/", "N", "N", "N", &c__0, &c__0, a, &c__1, x, &scale, w, &
info);
chkxer_("SLATBS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
slatbs_("U", "/", "N", "N", &c__0, &c__0, a, &c__1, x, &scale, w, &
info);
chkxer_("SLATBS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
slatbs_("U", "N", "/", "N", &c__0, &c__0, a, &c__1, x, &scale, w, &
info);
chkxer_("SLATBS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
slatbs_("U", "N", "N", "/", &c__0, &c__0, a, &c__1, x, &scale, w, &
info);
chkxer_("SLATBS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
slatbs_("U", "N", "N", "N", &c_n1, &c__0, a, &c__1, x, &scale, w, &
info);
chkxer_("SLATBS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
slatbs_("U", "N", "N", "N", &c__1, &c_n1, a, &c__1, x, &scale, w, &
info);
chkxer_("SLATBS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
slatbs_("U", "N", "N", "N", &c__2, &c__1, a, &c__1, x, &scale, w, &
info);
chkxer_("SLATBS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
}
/* Print a summary line. */
alaesm_(path, &infoc_1.ok, &infoc_1.nout);
return 0;
/* End of SERRTR */
} /* serrtr_ */
