/* Subroutine */ int sppcon_(char *uplo, integer *n, real *ap, real *anorm,
real *rcond, real *work, integer *iwork, integer *info, ftnlen
uplo_len)
{
/* System generated locals */
integer i__1;
real r__1;
/* Local variables */
static integer ix, kase;
static real scale;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
extern /* Subroutine */ int srscl_(integer *, real *, real *, integer *);
static logical upper;
static real scalel;
extern doublereal slamch_(char *, ftnlen);
static real scaleu;
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), slacon_(
integer *, real *, real *, integer *, real *, integer *);
extern integer isamax_(integer *, real *, integer *);
static real ainvnm;
static char normin[1];
extern /* Subroutine */ int slatps_(char *, char *, char *, char *,
integer *, real *, real *, real *, real *, integer *, ftnlen,
ftnlen, ftnlen, ftnlen);
static real smlnum;
/* -- LAPACK routine (version 3.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* March 31, 1993 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SPPCON estimates the reciprocal of the condition number (in the */
/* 1-norm) of a real symmetric positive definite packed matrix using */
/* the Cholesky factorization A = U**T*U or A = L*L**T computed by */
/* SPPTRF. */
/* An estimate is obtained for norm(inv(A)), and the reciprocal of the */
/* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* = 'U': Upper triangle of A is stored; */
/* = 'L': Lower triangle of A is stored. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* AP (input) REAL array, dimension (N*(N+1)/2) */
/* The triangular factor U or L from the Cholesky factorization */
/* A = U**T*U or A = L*L**T, packed columnwise in a linear */
/* array. The j-th column of U or L is stored in the array AP */
/* as follows: */
/* if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j; */
/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n. */
/* ANORM (input) REAL */
/* The 1-norm (or infinity-norm) of the symmetric matrix A. */
/* RCOND (output) REAL */
/* The reciprocal of the condition number of the matrix A, */
/* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an */
/* estimate of the 1-norm of inv(A) computed in this routine. */
/* WORK (workspace) 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 */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--iwork;
--work;
--ap;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U", (ftnlen)1, (ftnlen)1);
if (! upper && ! lsame_(uplo, "L", (ftnlen)1, (ftnlen)1)) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*anorm < 0.f) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SPPCON", &i__1, (ftnlen)6);
return 0;
}
/* Quick return if possible */
*rcond = 0.f;
if (*n == 0) {
*rcond = 1.f;
return 0;
} else if (*anorm == 0.f) {
return 0;
}
smlnum = slamch_("Safe minimum", (ftnlen)12);
/* Estimate the 1-norm of the inverse. */
kase = 0;
*(unsigned char *)normin = 'N';
L10:
slacon_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase);
if (kase != 0) {
if (upper) {
/* Multiply by inv(U'). */
slatps_("Upper", "Transpose", "Non-unit", normin, n, &ap[1], &
work[1], &scalel, &work[(*n << 1) + 1], info, (ftnlen)5, (
ftnlen)9, (ftnlen)8, (ftnlen)1);
*(unsigned char *)normin = 'Y';
/* Multiply by inv(U). */
slatps_("Upper", "No transpose", "Non-unit", normin, n, &ap[1], &
work[1], &scaleu, &work[(*n << 1) + 1], info, (ftnlen)5, (
ftnlen)12, (ftnlen)8, (ftnlen)1);
} else {
/* Multiply by inv(L). */
slatps_("Lower", "No transpose", "Non-unit", normin, n, &ap[1], &
work[1], &scalel, &work[(*n << 1) + 1], info, (ftnlen)5, (
ftnlen)12, (ftnlen)8, (ftnlen)1);
*(unsigned char *)normin = 'Y';
/* Multiply by inv(L'). */
slatps_("Lower", "Transpose", "Non-unit", normin, n, &ap[1], &
work[1], &scaleu, &work[(*n << 1) + 1], info, (ftnlen)5, (
ftnlen)9, (ftnlen)8, (ftnlen)1);
}
/* Multiply by 1/SCALE if doing so will not cause overflow. */
scale = scalel * scaleu;
if (scale != 1.f) {
ix = isamax_(n, &work[1], &c__1);
if (scale < (r__1 = work[ix], dabs(r__1)) * smlnum || scale ==
0.f) {
goto L20;
}
srscl_(n, &scale, &work[1], &c__1);
}
goto L10;
}
/* Compute the estimate of the reciprocal condition number. */
if (ainvnm != 0.f) {
*rcond = 1.f / ainvnm / *anorm;
}
L20:
return 0;
/* End of SPPCON */
} /* sppcon_ */
/* Subroutine */ int sgecon_(char *norm, integer *n, real *a, integer *lda,
real *anorm, real *rcond, 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
February 29, 1992
Purpose
=======
SGECON estimates the reciprocal of the condition number of a general
real matrix A, in either the 1-norm or the infinity-norm, using
the LU factorization computed by SGETRF.
An estimate is obtained for norm(inv(A)), and the reciprocal of the
condition number is computed as
RCOND = 1 / ( norm(A) * norm(inv(A)) ).
Arguments
=========
NORM (input) CHARACTER*1
Specifies whether the 1-norm condition number or the
infinity-norm condition number is required:
= '1' or 'O': 1-norm;
= 'I': Infinity-norm.
N (input) INTEGER
The order of the matrix A. N >= 0.
A (input) REAL array, dimension (LDA,N)
The factors L and U from the factorization A = P*L*U
as computed by SGETRF.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
ANORM (input) REAL
If NORM = '1' or 'O', the 1-norm of the original matrix A.
If NORM = 'I', the infinity-norm of the original matrix A.
RCOND (output) REAL
The reciprocal of the condition number of the matrix A,
computed as RCOND = 1/(norm(A) * norm(inv(A))).
WORK (workspace) REAL array, dimension (4*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;
/* System generated locals */
integer a_dim1, a_offset, i__1;
real r__1;
/* Local variables */
static integer kase, kase1;
static real scale;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int srscl_(integer *, real *, real *, integer *);
static real sl;
static integer ix;
extern doublereal slamch_(char *);
static real su;
extern /* Subroutine */ int xerbla_(char *, integer *), slacon_(
integer *, real *, real *, integer *, real *, integer *);
extern integer isamax_(integer *, real *, integer *);
static real ainvnm;
static logical onenrm;
static char normin[1];
extern /* Subroutine */ int slatrs_(char *, char *, char *, char *,
integer *, real *, integer *, real *, real *, real *, integer *);
static real smlnum;
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--work;
--iwork;
/* Function Body */
*info = 0;
onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O");
if (! onenrm && ! lsame_(norm, "I")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*n)) {
*info = -4;
} else if (*anorm < 0.f) {
*info = -5;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SGECON", &i__1);
return 0;
}
/* Quick return if possible */
*rcond = 0.f;
if (*n == 0) {
*rcond = 1.f;
return 0;
} else if (*anorm == 0.f) {
return 0;
}
smlnum = slamch_("Safe minimum");
/* Estimate the norm of inv(A). */
ainvnm = 0.f;
*(unsigned char *)normin = 'N';
if (onenrm) {
kase1 = 1;
} else {
kase1 = 2;
}
kase = 0;
L10:
slacon_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase);
if (kase != 0) {
if (kase == kase1) {
/* Multiply by inv(L). */
slatrs_("Lower", "No transpose", "Unit", normin, n, &a[a_offset],
lda, &work[1], &sl, &work[(*n << 1) + 1], info);
/* Multiply by inv(U). */
slatrs_("Upper", "No transpose", "Non-unit", normin, n, &a[
a_offset], lda, &work[1], &su, &work[*n * 3 + 1], info);
} else {
/* Multiply by inv(U'). */
slatrs_("Upper", "Transpose", "Non-unit", normin, n, &a[a_offset],
lda, &work[1], &su, &work[*n * 3 + 1], info);
/* Multiply by inv(L'). */
slatrs_("Lower", "Transpose", "Unit", normin, n, &a[a_offset],
lda, &work[1], &sl, &work[(*n << 1) + 1], info);
}
/* Divide X by 1/(SL*SU) if doing so will not cause overflow. */
scale = sl * su;
*(unsigned char *)normin = 'Y';
if (scale != 1.f) {
ix = isamax_(n, &work[1], &c__1);
if (scale < (r__1 = work[ix], dabs(r__1)) * smlnum || scale ==
0.f) {
goto L20;
}
srscl_(n, &scale, &work[1], &c__1);
}
goto L10;
}
/* Compute the estimate of the reciprocal condition number. */
if (ainvnm != 0.f) {
*rcond = 1.f / ainvnm / *anorm;
}
L20:
return 0;
/* End of SGECON */
} /* sgecon_ */
/* Subroutine */ int stpcon_(char *norm, char *uplo, char *diag, integer *n,
real *ap, real *rcond, real *work, integer *iwork, integer *info,
ftnlen norm_len, ftnlen uplo_len, ftnlen diag_len)
{
/* System generated locals */
integer i__1;
real r__1;
/* Local variables */
static integer ix, kase, kase1;
static real scale;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
static real anorm;
extern /* Subroutine */ int srscl_(integer *, real *, real *, integer *);
static logical upper;
static real xnorm;
extern doublereal slamch_(char *, ftnlen);
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), slacon_(
integer *, real *, real *, integer *, real *, integer *);
extern integer isamax_(integer *, real *, integer *);
static real ainvnm;
static logical onenrm;
extern doublereal slantp_(char *, char *, char *, integer *, real *, real
*, ftnlen, ftnlen, ftnlen);
static char normin[1];
extern /* Subroutine */ int slatps_(char *, char *, char *, char *,
integer *, real *, real *, real *, real *, integer *, ftnlen,
ftnlen, ftnlen, ftnlen);
static real smlnum;
static logical nounit;
/* -- LAPACK routine (version 3.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* March 31, 1993 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* STPCON estimates the reciprocal of the condition number of a packed */
/* triangular matrix A, in either the 1-norm or the infinity-norm. */
/* The norm of A is computed and an estimate is obtained for */
/* norm(inv(A)), then the reciprocal of the condition number is */
/* computed as */
/* RCOND = 1 / ( norm(A) * norm(inv(A)) ). */
/* Arguments */
/* ========= */
/* NORM (input) CHARACTER*1 */
/* Specifies whether the 1-norm condition number or the */
/* infinity-norm condition number is required: */
/* = '1' or 'O': 1-norm; */
/* = 'I': Infinity-norm. */
/* UPLO (input) CHARACTER*1 */
/* = 'U': A is upper triangular; */
/* = 'L': A is lower triangular. */
/* DIAG (input) CHARACTER*1 */
/* = 'N': A is non-unit triangular; */
/* = 'U': A is unit triangular. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* AP (input) REAL array, dimension (N*(N+1)/2) */
/* The upper or lower triangular matrix A, packed columnwise in */
/* a linear array. The j-th column of A is stored in the array */
/* AP as follows: */
/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
/* If DIAG = 'U', the diagonal elements of A are not referenced */
/* and are assumed to be 1. */
/* RCOND (output) REAL */
/* The reciprocal of the condition number of the matrix A, */
/* computed as RCOND = 1/(norm(A) * norm(inv(A))). */
/* 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 */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--iwork;
--work;
--ap;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U", (ftnlen)1, (ftnlen)1);
onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O", (ftnlen)1, (
ftnlen)1);
nounit = lsame_(diag, "N", (ftnlen)1, (ftnlen)1);
if (! onenrm && ! lsame_(norm, "I", (ftnlen)1, (ftnlen)1)) {
*info = -1;
} else if (! upper && ! lsame_(uplo, "L", (ftnlen)1, (ftnlen)1)) {
*info = -2;
} else if (! nounit && ! lsame_(diag, "U", (ftnlen)1, (ftnlen)1)) {
*info = -3;
} else if (*n < 0) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("STPCON", &i__1, (ftnlen)6);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
*rcond = 1.f;
return 0;
}
*rcond = 0.f;
smlnum = slamch_("Safe minimum", (ftnlen)12) * (real) max(1,*n);
/* Compute the norm of the triangular matrix A. */
anorm = slantp_(norm, uplo, diag, n, &ap[1], &work[1], (ftnlen)1, (ftnlen)
1, (ftnlen)1);
/* Continue only if ANORM > 0. */
if (anorm > 0.f) {
/* Estimate the norm of the inverse of A. */
ainvnm = 0.f;
*(unsigned char *)normin = 'N';
if (onenrm) {
kase1 = 1;
} else {
kase1 = 2;
}
kase = 0;
L10:
slacon_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase);
if (kase != 0) {
if (kase == kase1) {
/* Multiply by inv(A). */
slatps_(uplo, "No transpose", diag, normin, n, &ap[1], &work[
1], &scale, &work[(*n << 1) + 1], info, (ftnlen)1, (
ftnlen)12, (ftnlen)1, (ftnlen)1);
} else {
/* Multiply by inv(A'). */
slatps_(uplo, "Transpose", diag, normin, n, &ap[1], &work[1],
&scale, &work[(*n << 1) + 1], info, (ftnlen)1, (
ftnlen)9, (ftnlen)1, (ftnlen)1);
}
*(unsigned char *)normin = 'Y';
/* Multiply by 1/SCALE if doing so will not cause overflow. */
if (scale != 1.f) {
ix = isamax_(n, &work[1], &c__1);
xnorm = (r__1 = work[ix], dabs(r__1));
if (scale < xnorm * smlnum || scale == 0.f) {
goto L20;
}
srscl_(n, &scale, &work[1], &c__1);
}
goto L10;
}
/* Compute the estimate of the reciprocal condition number. */
if (ainvnm != 0.f) {
*rcond = 1.f / anorm / ainvnm;
}
}
L20:
return 0;
/* End of STPCON */
} /* stpcon_ */
/* Subroutine */ int strcon_(char *norm, char *uplo, char *diag, integer *n,
real *a, integer *lda, real *rcond, 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
March 31, 1993
Purpose
=======
STRCON estimates the reciprocal of the condition number of a
triangular matrix A, in either the 1-norm or the infinity-norm.
The norm of A is computed and an estimate is obtained for
norm(inv(A)), then the reciprocal of the condition number is
computed as
RCOND = 1 / ( norm(A) * norm(inv(A)) ).
Arguments
=========
NORM (input) CHARACTER*1
Specifies whether the 1-norm condition number or the
infinity-norm condition number is required:
= '1' or 'O': 1-norm;
= 'I': Infinity-norm.
UPLO (input) CHARACTER*1
= 'U': A is upper triangular;
= 'L': A is lower triangular.
DIAG (input) CHARACTER*1
= 'N': A is non-unit triangular;
= 'U': A is unit triangular.
N (input) INTEGER
The order of the matrix A. N >= 0.
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).
RCOND (output) REAL
The reciprocal of the condition number of the matrix A,
computed as RCOND = 1/(norm(A) * norm(inv(A))).
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;
/* System generated locals */
integer a_dim1, a_offset, i__1;
real r__1;
/* Local variables */
static integer kase, kase1;
static real scale;
extern logical lsame_(char *, char *);
static real anorm;
extern /* Subroutine */ int srscl_(integer *, real *, real *, integer *);
static logical upper;
static real xnorm;
static integer ix;
extern doublereal slamch_(char *);
extern /* Subroutine */ int xerbla_(char *, integer *), slacon_(
integer *, real *, real *, integer *, real *, integer *);
extern integer isamax_(integer *, real *, integer *);
static real ainvnm;
static logical onenrm;
static char normin[1];
extern doublereal slantr_(char *, char *, char *, integer *, integer *,
real *, integer *, real *);
extern /* Subroutine */ int slatrs_(char *, char *, char *, char *,
integer *, real *, integer *, real *, real *, real *, integer *);
static real smlnum;
static logical nounit;
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--work;
--iwork;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O");
nounit = lsame_(diag, "N");
if (! onenrm && ! lsame_(norm, "I")) {
*info = -1;
} else if (! upper && ! lsame_(uplo, "L")) {
*info = -2;
} else if (! nounit && ! lsame_(diag, "U")) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*lda < max(1,*n)) {
*info = -6;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("STRCON", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
*rcond = 1.f;
return 0;
}
*rcond = 0.f;
smlnum = slamch_("Safe minimum") * (real) max(1,*n);
/* Compute the norm of the triangular matrix A. */
anorm = slantr_(norm, uplo, diag, n, n, &a[a_offset], lda, &work[1]);
/* Continue only if ANORM > 0. */
if (anorm > 0.f) {
/* Estimate the norm of the inverse of A. */
ainvnm = 0.f;
*(unsigned char *)normin = 'N';
if (onenrm) {
kase1 = 1;
} else {
kase1 = 2;
}
kase = 0;
L10:
slacon_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase);
if (kase != 0) {
if (kase == kase1) {
/* Multiply by inv(A). */
slatrs_(uplo, "No transpose", diag, normin, n, &a[a_offset],
lda, &work[1], &scale, &work[(*n << 1) + 1], info);
} else {
/* Multiply by inv(A'). */
slatrs_(uplo, "Transpose", diag, normin, n, &a[a_offset], lda,
&work[1], &scale, &work[(*n << 1) + 1], info);
}
*(unsigned char *)normin = 'Y';
/* Multiply by 1/SCALE if doing so will not cause overflow. */
if (scale != 1.f) {
ix = isamax_(n, &work[1], &c__1);
xnorm = (r__1 = work[ix], dabs(r__1));
if (scale < xnorm * smlnum || scale == 0.f) {
goto L20;
}
srscl_(n, &scale, &work[1], &c__1);
}
goto L10;
}
/* Compute the estimate of the reciprocal condition number. */
if (ainvnm != 0.f) {
*rcond = 1.f / anorm / ainvnm;
}
}
L20:
return 0;
/* End of STRCON */
} /* strcon_ */
/* Subroutine */
int sgecon_(char *norm, integer *n, real *a, integer *lda, real *anorm, real *rcond, real *work, integer *iwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1;
real r__1;
/* Local variables */
real sl;
integer ix;
real su;
integer kase, kase1;
real scale;
extern logical lsame_(char *, char *);
integer isave[3];
extern /* Subroutine */
int srscl_(integer *, real *, real *, integer *), slacn2_(integer *, real *, real *, integer *, real *, integer *, integer *);
extern real slamch_(char *);
extern /* Subroutine */
int xerbla_(char *, integer *);
extern integer isamax_(integer *, real *, integer *);
real ainvnm;
logical onenrm;
char normin[1];
extern /* Subroutine */
int slatrs_(char *, char *, char *, char *, integer *, real *, integer *, real *, real *, real *, integer *);
real smlnum;
/* -- LAPACK computational routine (version 3.4.0) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* November 2011 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. 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;
--work;
--iwork;
/* Function Body */
*info = 0;
onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O");
if (! onenrm && ! lsame_(norm, "I"))
{
*info = -1;
}
else if (*n < 0)
{
*info = -2;
}
else if (*lda < max(1,*n))
{
*info = -4;
}
else if (*anorm < 0.f)
{
*info = -5;
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("SGECON", &i__1);
return 0;
}
/* Quick return if possible */
*rcond = 0.f;
if (*n == 0)
{
*rcond = 1.f;
return 0;
}
else if (*anorm == 0.f)
{
return 0;
}
smlnum = slamch_("Safe minimum");
/* Estimate the norm of inv(A). */
ainvnm = 0.f;
*(unsigned char *)normin = 'N';
if (onenrm)
{
kase1 = 1;
}
else
{
kase1 = 2;
}
kase = 0;
L10:
slacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave);
if (kase != 0)
{
if (kase == kase1)
{
/* Multiply by inv(L). */
slatrs_("Lower", "No transpose", "Unit", normin, n, &a[a_offset], lda, &work[1], &sl, &work[(*n << 1) + 1], info);
/* Multiply by inv(U). */
slatrs_("Upper", "No transpose", "Non-unit", normin, n, &a[ a_offset], lda, &work[1], &su, &work[*n * 3 + 1], info);
}
else
{
/* Multiply by inv(U**T). */
slatrs_("Upper", "Transpose", "Non-unit", normin, n, &a[a_offset], lda, &work[1], &su, &work[*n * 3 + 1], info);
/* Multiply by inv(L**T). */
slatrs_("Lower", "Transpose", "Unit", normin, n, &a[a_offset], lda, &work[1], &sl, &work[(*n << 1) + 1], info);
}
/* Divide X by 1/(SL*SU) if doing so will not cause overflow. */
scale = sl * su;
*(unsigned char *)normin = 'Y';
if (scale != 1.f)
{
ix = isamax_(n, &work[1], &c__1);
if (scale < (r__1 = work[ix], f2c_abs(r__1)) * smlnum || scale == 0.f)
{
goto L20;
}
srscl_(n, &scale, &work[1], &c__1);
}
goto L10;
}
/* Compute the estimate of the reciprocal condition number. */
if (ainvnm != 0.f)
{
*rcond = 1.f / ainvnm / *anorm;
}
L20:
return 0;
/* End of SGECON */
}
/* Subroutine */ int spbcon_(char *uplo, integer *n, integer *kd, real *ab,
integer *ldab, real *anorm, real *rcond, 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
=======
SPBCON estimates the reciprocal of the condition number (in the
1-norm) of a real symmetric positive definite band matrix using the
Cholesky factorization A = U**T*U or A = L*L**T computed by SPBTRF.
An estimate is obtained for norm(inv(A)), and the reciprocal of the
condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
Arguments
=========
UPLO (input) CHARACTER*1
= 'U': Upper triangular factor stored in AB;
= 'L': Lower triangular factor stored in AB.
N (input) INTEGER
The order of the matrix A. N >= 0.
KD (input) INTEGER
The number of superdiagonals of the matrix A if UPLO = 'U',
or the number of subdiagonals if UPLO = 'L'. KD >= 0.
AB (input) REAL array, dimension (LDAB,N)
The triangular factor U or L from the Cholesky factorization
A = U**T*U or A = L*L**T of the band matrix A, stored in the
first KD+1 rows of the array. The j-th column of U or L is
stored in the j-th column of the array AB as follows:
if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j;
if UPLO ='L', AB(1+i-j,j) = L(i,j) for j<=i<=min(n,j+kd).
LDAB (input) INTEGER
The leading dimension of the array AB. LDAB >= KD+1.
ANORM (input) REAL
The 1-norm (or infinity-norm) of the symmetric band matrix A.
RCOND (output) REAL
The reciprocal of the condition number of the matrix A,
computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
estimate of the 1-norm of inv(A) computed in this routine.
WORK (workspace) 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;
/* System generated locals */
integer ab_dim1, ab_offset, i__1;
real r__1;
/* Local variables */
static integer kase;
static real scale;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int srscl_(integer *, real *, real *, integer *);
static logical upper;
static integer ix;
static real scalel;
extern doublereal slamch_(char *);
static real scaleu;
extern /* Subroutine */ int xerbla_(char *, integer *), slacon_(
integer *, real *, real *, integer *, real *, integer *);
extern integer isamax_(integer *, real *, integer *);
static real ainvnm;
extern /* Subroutine */ int slatbs_(char *, char *, char *, char *,
integer *, integer *, real *, integer *, real *, real *, real *,
integer *);
static char normin[1];
static real smlnum;
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1 * 1;
ab -= ab_offset;
--work;
--iwork;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*kd < 0) {
*info = -3;
} else if (*ldab < *kd + 1) {
*info = -5;
} else if (*anorm < 0.f) {
*info = -6;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SPBCON", &i__1);
return 0;
}
/* Quick return if possible */
*rcond = 0.f;
if (*n == 0) {
*rcond = 1.f;
return 0;
} else if (*anorm == 0.f) {
return 0;
}
smlnum = slamch_("Safe minimum");
/* Estimate the 1-norm of the inverse. */
kase = 0;
*(unsigned char *)normin = 'N';
L10:
slacon_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase);
if (kase != 0) {
if (upper) {
/* Multiply by inv(U'). */
slatbs_("Upper", "Transpose", "Non-unit", normin, n, kd, &ab[
ab_offset], ldab, &work[1], &scalel, &work[(*n << 1) + 1],
info);
*(unsigned char *)normin = 'Y';
/* Multiply by inv(U). */
slatbs_("Upper", "No transpose", "Non-unit", normin, n, kd, &ab[
ab_offset], ldab, &work[1], &scaleu, &work[(*n << 1) + 1],
info);
} else {
/* Multiply by inv(L). */
slatbs_("Lower", "No transpose", "Non-unit", normin, n, kd, &ab[
ab_offset], ldab, &work[1], &scalel, &work[(*n << 1) + 1],
info);
*(unsigned char *)normin = 'Y';
/* Multiply by inv(L'). */
slatbs_("Lower", "Transpose", "Non-unit", normin, n, kd, &ab[
ab_offset], ldab, &work[1], &scaleu, &work[(*n << 1) + 1],
info);
}
/* Multiply by 1/SCALE if doing so will not cause overflow. */
scale = scalel * scaleu;
if (scale != 1.f) {
ix = isamax_(n, &work[1], &c__1);
if (scale < (r__1 = work[ix], dabs(r__1)) * smlnum || scale ==
0.f) {
goto L20;
}
srscl_(n, &scale, &work[1], &c__1);
}
goto L10;
}
/* Compute the estimate of the reciprocal condition number. */
if (ainvnm != 0.f) {
*rcond = 1.f / ainvnm / *anorm;
}
L20:
return 0;
/* End of SPBCON */
} /* spbcon_ */
int spocon_(char *uplo, int *n, float *a, int *lda,
float *anorm, float *rcond, float *work, int *iwork, int *info)
{
/* System generated locals */
int a_dim1, a_offset, i__1;
float r__1;
/* Local variables */
int ix, kase;
float scale;
extern int lsame_(char *, char *);
int isave[3];
extern int srscl_(int *, float *, float *, int *);
int upper;
extern int slacn2_(int *, float *, float *, int *,
float *, int *, int *);
float scalel;
extern double slamch_(char *);
float scaleu;
extern int xerbla_(char *, int *);
extern int isamax_(int *, float *, int *);
float ainvnm;
char normin[1];
extern int slatrs_(char *, char *, char *, char *,
int *, float *, int *, float *, float *, float *, int *);
float smlnum;
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* Modified to call SLACN2 in place of SLACON, 7 Feb 03, SJH. */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SPOCON estimates the reciprocal of the condition number (in the */
/* 1-norm) of a float symmetric positive definite matrix using the */
/* Cholesky factorization A = U**T*U or A = L*L**T computed by SPOTRF. */
/* An estimate is obtained for norm(inv(A)), and the reciprocal of the */
/* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* = 'U': Upper triangle of A is stored; */
/* = 'L': Lower triangle of A is stored. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input) REAL array, dimension (LDA,N) */
/* The triangular factor U or L from the Cholesky factorization */
/* A = U**T*U or A = L*L**T, as computed by SPOTRF. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= MAX(1,N). */
/* ANORM (input) REAL */
/* The 1-norm (or infinity-norm) of the symmetric matrix A. */
/* RCOND (output) REAL */
/* The reciprocal of the condition number of the matrix A, */
/* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an */
/* estimate of the 1-norm of inv(A) computed in this routine. */
/* WORK (workspace) 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 */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. 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;
--work;
--iwork;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < MAX(1,*n)) {
*info = -4;
} else if (*anorm < 0.f) {
*info = -5;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SPOCON", &i__1);
return 0;
}
/* Quick return if possible */
*rcond = 0.f;
if (*n == 0) {
*rcond = 1.f;
return 0;
} else if (*anorm == 0.f) {
return 0;
}
smlnum = slamch_("Safe minimum");
/* Estimate the 1-norm of inv(A). */
kase = 0;
*(unsigned char *)normin = 'N';
L10:
slacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave);
if (kase != 0) {
if (upper) {
/* Multiply by inv(U'). */
slatrs_("Upper", "Transpose", "Non-unit", normin, n, &a[a_offset],
lda, &work[1], &scalel, &work[(*n << 1) + 1], info);
*(unsigned char *)normin = 'Y';
/* Multiply by inv(U). */
slatrs_("Upper", "No transpose", "Non-unit", normin, n, &a[
a_offset], lda, &work[1], &scaleu, &work[(*n << 1) + 1],
info);
} else {
/* Multiply by inv(L). */
slatrs_("Lower", "No transpose", "Non-unit", normin, n, &a[
a_offset], lda, &work[1], &scalel, &work[(*n << 1) + 1],
info);
*(unsigned char *)normin = 'Y';
/* Multiply by inv(L'). */
slatrs_("Lower", "Transpose", "Non-unit", normin, n, &a[a_offset],
lda, &work[1], &scaleu, &work[(*n << 1) + 1], info);
}
/* Multiply by 1/SCALE if doing so will not cause overflow. */
scale = scalel * scaleu;
if (scale != 1.f) {
ix = isamax_(n, &work[1], &c__1);
if (scale < (r__1 = work[ix], ABS(r__1)) * smlnum || scale ==
0.f) {
goto L20;
}
srscl_(n, &scale, &work[1], &c__1);
}
goto L10;
}
/* Compute the estimate of the reciprocal condition number. */
if (ainvnm != 0.f) {
*rcond = 1.f / ainvnm / *anorm;
}
L20:
return 0;
/* End of SPOCON */
} /* spocon_ */
/* Subroutine */ int stpcon_(char *norm, char *uplo, char *diag, integer *n,
real *ap, real *rcond, real *work, integer *iwork, integer *info)
{
/* -- LAPACK routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
March 31, 1993
Purpose
=======
STPCON estimates the reciprocal of the condition number of a packed
triangular matrix A, in either the 1-norm or the infinity-norm.
The norm of A is computed and an estimate is obtained for
norm(inv(A)), then the reciprocal of the condition number is
computed as
RCOND = 1 / ( norm(A) * norm(inv(A)) ).
Arguments
=========
NORM (input) CHARACTER*1
Specifies whether the 1-norm condition number or the
infinity-norm condition number is required:
= '1' or 'O': 1-norm;
= 'I': Infinity-norm.
UPLO (input) CHARACTER*1
= 'U': A is upper triangular;
= 'L': A is lower triangular.
DIAG (input) CHARACTER*1
= 'N': A is non-unit triangular;
= 'U': A is unit triangular.
N (input) INTEGER
The order of the matrix A. N >= 0.
AP (input) REAL array, dimension (N*(N+1)/2)
The upper or lower triangular matrix A, packed columnwise in
a linear array. The j-th column of A is stored in the array
AP as follows:
if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
If DIAG = 'U', the diagonal elements of A are not referenced
and are assumed to be 1.
RCOND (output) REAL
The reciprocal of the condition number of the matrix A,
computed as RCOND = 1/(norm(A) * norm(inv(A))).
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
Function Body */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer i__1;
real r__1;
/* Local variables */
static integer kase, kase1;
static real scale;
extern logical lsame_(char *, char *);
static real anorm;
extern /* Subroutine */ int srscl_(integer *, real *, real *, integer *);
static logical upper;
static real xnorm;
static integer ix;
extern doublereal slamch_(char *);
extern /* Subroutine */ int xerbla_(char *, integer *), slacon_(
integer *, real *, real *, integer *, real *, integer *);
extern integer isamax_(integer *, real *, integer *);
static real ainvnm;
static logical onenrm;
extern doublereal slantp_(char *, char *, char *, integer *, real *, real
*);
static char normin[1];
extern /* Subroutine */ int slatps_(char *, char *, char *, char *,
integer *, real *, real *, real *, real *, integer *);
static real smlnum;
static logical nounit;
#define IWORK(I) iwork[(I)-1]
#define WORK(I) work[(I)-1]
#define AP(I) ap[(I)-1]
*info = 0;
upper = lsame_(uplo, "U");
onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O");
nounit = lsame_(diag, "N");
if (! onenrm && ! lsame_(norm, "I")) {
*info = -1;
} else if (! upper && ! lsame_(uplo, "L")) {
*info = -2;
} else if (! nounit && ! lsame_(diag, "U")) {
*info = -3;
} else if (*n < 0) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("STPCON", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
*rcond = 1.f;
return 0;
}
*rcond = 0.f;
smlnum = slamch_("Safe minimum") * (real) max(1,*n);
/* Compute the norm of the triangular matrix A. */
anorm = slantp_(norm, uplo, diag, n, &AP(1), &WORK(1));
/* Continue only if ANORM > 0. */
if (anorm > 0.f) {
/* Estimate the norm of the inverse of A. */
ainvnm = 0.f;
*(unsigned char *)normin = 'N';
if (onenrm) {
kase1 = 1;
} else {
kase1 = 2;
}
kase = 0;
L10:
slacon_(n, &WORK(*n + 1), &WORK(1), &IWORK(1), &ainvnm, &kase);
if (kase != 0) {
if (kase == kase1) {
/* Multiply by inv(A). */
slatps_(uplo, "No transpose", diag, normin, n, &AP(1), &WORK(
1), &scale, &WORK((*n << 1) + 1), info);
} else {
/* Multiply by inv(A'). */
slatps_(uplo, "Transpose", diag, normin, n, &AP(1), &WORK(1),
&scale, &WORK((*n << 1) + 1), info);
}
*(unsigned char *)normin = 'Y';
/* Multiply by 1/SCALE if doing so will not cause overfl
ow. */
if (scale != 1.f) {
ix = isamax_(n, &WORK(1), &c__1);
xnorm = (r__1 = WORK(ix), dabs(r__1));
if (scale < xnorm * smlnum || scale == 0.f) {
goto L20;
}
srscl_(n, &scale, &WORK(1), &c__1);
}
goto L10;
}
/* Compute the estimate of the reciprocal condition number. */
if (ainvnm != 0.f) {
*rcond = 1.f / anorm / ainvnm;
}
}
L20:
return 0;
/* End of STPCON */
} /* stpcon_ */
/* Subroutine */ int sgelss_(integer *m, integer *n, integer *nrhs, real *a,
integer *lda, real *b, integer *ldb, real *s, real *rcond, integer *
rank, 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
=======
SGELSS computes the minimum norm solution to a real linear least
squares problem:
Minimize 2-norm(| b - A*x |).
using the singular value decomposition (SVD) of A. A is an M-by-N
matrix which may be rank-deficient.
Several right hand side vectors b and solution vectors x can be
handled in a single call; they are stored as the columns of the
M-by-NRHS right hand side matrix B and the N-by-NRHS solution matrix
X.
The effective rank of A is determined by treating as zero those
singular values which are less than RCOND times the largest singular
value.
Arguments
=========
M (input) INTEGER
The number of rows of the matrix A. M >= 0.
N (input) INTEGER
The number of columns of the matrix A. N >= 0.
NRHS (input) INTEGER
The number of right hand sides, i.e., the number of columns
of the matrices B and X. NRHS >= 0.
A (input/output) REAL array, dimension (LDA,N)
On entry, the M-by-N matrix A.
On exit, the first min(m,n) rows of A are overwritten with
its right singular vectors, stored rowwise.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,M).
B (input/output) REAL array, dimension (LDB,NRHS)
On entry, the M-by-NRHS right hand side matrix B.
On exit, B is overwritten by the N-by-NRHS solution
matrix X. If m >= n and RANK = n, the residual
sum-of-squares for the solution in the i-th column is given
by the sum of squares of elements n+1:m in that column.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,max(M,N)).
S (output) REAL array, dimension (min(M,N))
The singular values of A in decreasing order.
The condition number of A in the 2-norm = S(1)/S(min(m,n)).
RCOND (input) REAL
RCOND is used to determine the effective rank of A.
Singular values S(i) <= RCOND*S(1) are treated as zero.
If RCOND < 0, machine precision is used instead.
RANK (output) INTEGER
The effective rank of A, i.e., the number of singular values
which are greater than RCOND*S(1).
WORK (workspace/output) 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 >= 1, and also:
LWORK >= 3*min(M,N) + max( 2*min(M,N), max(M,N), NRHS )
For good performance, LWORK should generally be larger.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value.
> 0: the algorithm for computing the SVD failed to converge;
if INFO = i, i off-diagonal elements of an intermediate
bidiagonal form did not converge to zero.
=====================================================================
Test the input arguments
Parameter adjustments
Function Body */
/* Table of constant values */
static integer c__6 = 6;
static integer c_n1 = -1;
static integer c__1 = 1;
static integer c__0 = 0;
static real c_b74 = 0.f;
static real c_b108 = 1.f;
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4;
real r__1;
/* Local variables */
static real anrm, bnrm;
static integer itau;
static real vdum[1];
static integer i, iascl, ibscl, chunk;
extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
integer *, real *, real *, integer *, real *, integer *, real *,
real *, integer *);
static real sfmin;
static integer minmn, maxmn;
extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *,
real *, integer *, real *, integer *, real *, real *, integer *);
static integer itaup, itauq;
extern /* Subroutine */ int srscl_(integer *, real *, real *, integer *);
static integer mnthr, iwork;
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *);
static integer bl, ie, il;
extern /* Subroutine */ int slabad_(real *, real *);
static integer mm, bdspac;
extern /* Subroutine */ int sgebrd_(integer *, integer *, real *, integer
*, real *, real *, real *, real *, real *, integer *, integer *);
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 *, ftnlen, ftnlen);
static 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 *), slacpy_(char
*, integer *, integer *, real *, integer *, real *, integer *), slaset_(char *, integer *, integer *, real *, real *,
real *, integer *), sbdsqr_(char *, integer *, integer *,
integer *, integer *, real *, real *, real *, integer *, real *,
integer *, real *, integer *, real *, integer *), sorgbr_(
char *, integer *, integer *, integer *, real *, integer *, real *
, real *, integer *, integer *);
static integer ldwork;
extern /* Subroutine */ int sormbr_(char *, char *, char *, integer *,
integer *, integer *, real *, integer *, real *, real *, integer *
, real *, integer *, integer *);
static integer minwrk, maxwrk;
static real smlnum;
extern /* Subroutine */ int sormlq_(char *, char *, integer *, integer *,
integer *, real *, integer *, real *, real *, integer *, real *,
integer *, integer *), sormqr_(char *, char *,
integer *, integer *, integer *, real *, integer *, real *, real *
, integer *, real *, integer *, integer *);
static real eps, thr;
#define S(I) s[(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;
minmn = min(*m,*n);
maxmn = max(*m,*n);
mnthr = ilaenv_(&c__6, "SGELSS", " ", m, n, nrhs, &c_n1, 6L, 1L);
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*nrhs < 0) {
*info = -3;
} else if (*lda < max(1,*m)) {
*info = -5;
} else if (*ldb < max(1,maxmn)) {
*info = -7;
}
/* Compute workspace
(Note: Comments in the code beginning "Workspace:" describe the
minimal amount of workspace needed at that point in the code,
as well as the preferred amount for good performance.
NB refers to the optimal block size for the immediately
following subroutine, as returned by ILAENV.) */
minwrk = 1;
if (*info == 0 && *lwork >= 1) {
maxwrk = 0;
mm = *m;
if (*m >= *n && *m >= mnthr) {
/* Path 1a - overdetermined, with many more rows than co
lumns */
mm = *n;
/* Computing MAX */
i__1 = maxwrk, i__2 = *n + *n * ilaenv_(&c__1, "SGEQRF", " ", m,
n, &c_n1, &c_n1, 6L, 1L);
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *n + *nrhs * ilaenv_(&c__1, "SORMQR", "LT",
m, nrhs, n, &c_n1, 6L, 2L);
maxwrk = max(i__1,i__2);
}
if (*m >= *n) {
/* Path 1 - overdetermined or exactly determined
Compute workspace neede for SBDSQR
Computing MAX */
i__1 = 1, i__2 = *n * 5 - 4;
bdspac = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *n * 3 + (mm + *n) * ilaenv_(&c__1, "SGEBRD"
, " ", &mm, n, &c_n1, &c_n1, 6L, 1L);
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *n * 3 + *nrhs * ilaenv_(&c__1, "SORMBR",
"QLT", &mm, nrhs, n, &c_n1, 6L, 3L);
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *n * 3 + (*n - 1) * ilaenv_(&c__1, "SORGBR",
"P", n, n, n, &c_n1, 6L, 1L);
maxwrk = max(i__1,i__2);
maxwrk = max(maxwrk,bdspac);
/* Computing MAX */
i__1 = maxwrk, i__2 = *n * *nrhs;
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = *n * 3 + mm, i__2 = *n * 3 + *nrhs, i__1 = max(i__1,i__2);
minwrk = max(i__1,bdspac);
maxwrk = max(minwrk,maxwrk);
}
if (*n > *m) {
/* Compute workspace neede for SBDSQR
Computing MAX */
i__1 = 1, i__2 = *m * 5 - 4;
bdspac = max(i__1,i__2);
/* Computing MAX */
i__1 = *m * 3 + *nrhs, i__2 = *m * 3 + *n, i__1 = max(i__1,i__2);
minwrk = max(i__1,bdspac);
if (*n >= mnthr) {
/* Path 2a - underdetermined, with many more colu
mns
than rows */
maxwrk = *m + *m * ilaenv_(&c__1, "SGELQF", " ", m, n, &c_n1,
&c_n1, 6L, 1L);
/* Computing MAX */
i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + (*m << 1) *
ilaenv_(&c__1, "SGEBRD", " ", m, m, &c_n1, &c_n1, 6L,
1L);
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + *nrhs * ilaenv_(&
c__1, "SORMBR", "QLT", m, nrhs, m, &c_n1, 6L, 3L);
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + (*m - 1) *
ilaenv_(&c__1, "SORGBR", "P", m, m, m, &c_n1, 6L, 1L);
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *m * *m + *m + bdspac;
maxwrk = max(i__1,i__2);
if (*nrhs > 1) {
/* Computing MAX */
i__1 = maxwrk, i__2 = *m * *m + *m + *m * *nrhs;
maxwrk = max(i__1,i__2);
} else {
/* Computing MAX */
i__1 = maxwrk, i__2 = *m * *m + (*m << 1);
maxwrk = max(i__1,i__2);
}
/* Computing MAX */
i__1 = maxwrk, i__2 = *m + *nrhs * ilaenv_(&c__1, "SORMLQ",
"LT", n, nrhs, m, &c_n1, 6L, 2L);
maxwrk = max(i__1,i__2);
} else {
/* Path 2 - underdetermined */
maxwrk = *m * 3 + (*n + *m) * ilaenv_(&c__1, "SGEBRD", " ", m,
n, &c_n1, &c_n1, 6L, 1L);
/* Computing MAX */
i__1 = maxwrk, i__2 = *m * 3 + *nrhs * ilaenv_(&c__1, "SORMBR"
, "QLT", m, nrhs, m, &c_n1, 6L, 3L);
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *m * 3 + *m * ilaenv_(&c__1, "SORGBR",
"P", m, n, m, &c_n1, 6L, 1L);
maxwrk = max(i__1,i__2);
maxwrk = max(maxwrk,bdspac);
/* Computing MAX */
i__1 = maxwrk, i__2 = *n * *nrhs;
maxwrk = max(i__1,i__2);
}
}
maxwrk = max(minwrk,maxwrk);
WORK(1) = (real) maxwrk;
}
minwrk = max(minwrk,1);
if (*lwork < minwrk) {
*info = -12;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SGELSS", &i__1);
return 0;
}
/* Quick return if possible */
if (*m == 0 || *n == 0) {
*rank = 0;
return 0;
}
/* Get machine parameters */
eps = slamch_("P");
sfmin = slamch_("S");
smlnum = sfmin / eps;
bignum = 1.f / smlnum;
slabad_(&smlnum, &bignum);
/* Scale A if max element outside range [SMLNUM,BIGNUM] */
anrm = slange_("M", m, n, &A(1,1), lda, &WORK(1));
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(1,1), 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(1,1), lda,
info);
iascl = 2;
} else if (anrm == 0.f) {
/* VISMatrix all zero. Return zero solution. */
i__1 = max(*m,*n);
slaset_("F", &i__1, nrhs, &c_b74, &c_b74, &B(1,1), ldb);
slaset_("F", &minmn, &c__1, &c_b74, &c_b74, &S(1), &c__1);
*rank = 0;
goto L70;
}
/* Scale B if max element outside range [SMLNUM,BIGNUM] */
bnrm = slange_("M", m, nrhs, &B(1,1), ldb, &WORK(1));
ibscl = 0;
if (bnrm > 0.f && bnrm < smlnum) {
/* Scale matrix norm up to SMLNUM */
slascl_("G", &c__0, &c__0, &bnrm, &smlnum, m, nrhs, &B(1,1), ldb,
info);
ibscl = 1;
} else if (bnrm > bignum) {
/* Scale matrix norm down to BIGNUM */
slascl_("G", &c__0, &c__0, &bnrm, &bignum, m, nrhs, &B(1,1), ldb,
info);
ibscl = 2;
}
/* Overdetermined case */
if (*m >= *n) {
/* Path 1 - overdetermined or exactly determined */
mm = *m;
if (*m >= mnthr) {
/* Path 1a - overdetermined, with many more rows than co
lumns */
mm = *n;
itau = 1;
iwork = itau + *n;
/* Compute A=Q*R
(Workspace: need 2*N, prefer N+N*NB) */
i__1 = *lwork - iwork + 1;
sgeqrf_(m, n, &A(1,1), lda, &WORK(itau), &WORK(iwork), &i__1,
info);
/* Multiply B by transpose(Q)
(Workspace: need N+NRHS, prefer N+NRHS*NB) */
i__1 = *lwork - iwork + 1;
sormqr_("L", "T", m, nrhs, n, &A(1,1), lda, &WORK(itau), &B(1,1), ldb, &WORK(iwork), &i__1, info);
/* Zero out below R */
if (*n > 1) {
i__1 = *n - 1;
i__2 = *n - 1;
slaset_("L", &i__1, &i__2, &c_b74, &c_b74, &A(2,1),
lda);
}
}
ie = 1;
itauq = ie + *n;
itaup = itauq + *n;
iwork = itaup + *n;
/* Bidiagonalize R in A
(Workspace: need 3*N+MM, prefer 3*N+(MM+N)*NB) */
i__1 = *lwork - iwork + 1;
sgebrd_(&mm, n, &A(1,1), lda, &S(1), &WORK(ie), &WORK(itauq), &
WORK(itaup), &WORK(iwork), &i__1, info);
/* Multiply B by transpose of left bidiagonalizing vectors of R
(Workspace: need 3*N+NRHS, prefer 3*N+NRHS*NB) */
i__1 = *lwork - iwork + 1;
sormbr_("Q", "L", "T", &mm, nrhs, n, &A(1,1), lda, &WORK(itauq),
&B(1,1), ldb, &WORK(iwork), &i__1, info);
/* Generate right bidiagonalizing vectors of R in A
(Workspace: need 4*N-1, prefer 3*N+(N-1)*NB) */
i__1 = *lwork - iwork + 1;
sorgbr_("P", n, n, n, &A(1,1), lda, &WORK(itaup), &WORK(iwork), &
i__1, info);
iwork = ie + *n;
/* Perform bidiagonal QR iteration
multiply B by transpose of left singular vectors
compute right singular vectors in A
(Workspace: need BDSPAC) */
sbdsqr_("U", n, n, &c__0, nrhs, &S(1), &WORK(ie), &A(1,1), lda,
vdum, &c__1, &B(1,1), ldb, &WORK(iwork), info);
if (*info != 0) {
goto L70;
}
/* Multiply B by reciprocals of singular values
Computing MAX */
r__1 = *rcond * S(1);
thr = dmax(r__1,sfmin);
if (*rcond < 0.f) {
/* Computing MAX */
r__1 = eps * S(1);
thr = dmax(r__1,sfmin);
}
*rank = 0;
i__1 = *n;
for (i = 1; i <= *n; ++i) {
if (S(i) > thr) {
srscl_(nrhs, &S(i), &B(i,1), ldb);
++(*rank);
} else {
slaset_("F", &c__1, nrhs, &c_b74, &c_b74, &B(i,1), ldb);
}
/* L10: */
}
/* Multiply B by right singular vectors
(Workspace: need N, prefer N*NRHS) */
if (*lwork >= *ldb * *nrhs && *nrhs > 1) {
sgemm_("T", "N", n, nrhs, n, &c_b108, &A(1,1), lda, &B(1,1), ldb, &c_b74, &WORK(1), ldb);
slacpy_("G", n, nrhs, &WORK(1), ldb, &B(1,1), ldb);
} else if (*nrhs > 1) {
chunk = *lwork / *n;
i__1 = *nrhs;
i__2 = chunk;
for (i = 1; chunk < 0 ? i >= *nrhs : i <= *nrhs; i += chunk) {
/* Computing MIN */
i__3 = *nrhs - i + 1;
bl = min(i__3,chunk);
sgemm_("T", "N", n, &bl, n, &c_b108, &A(1,1), lda, &B(1,1), ldb, &c_b74, &WORK(1), n);
slacpy_("G", n, &bl, &WORK(1), n, &B(1,1), ldb);
/* L20: */
}
} else {
sgemv_("T", n, n, &c_b108, &A(1,1), lda, &B(1,1), &c__1,
&c_b74, &WORK(1), &c__1);
scopy_(n, &WORK(1), &c__1, &B(1,1), &c__1);
}
} else /* if(complicated condition) */ {
/* Computing MAX */
i__2 = *m, i__1 = (*m << 1) - 4, i__2 = max(i__2,i__1), i__2 = max(
i__2,*nrhs), i__1 = *n - *m * 3;
if (*n >= mnthr && *lwork >= (*m << 2) + *m * *m + max(i__2,i__1)) {
/* Path 2a - underdetermined, with many more columns than r
ows
and sufficient workspace for an efficient algorithm */
ldwork = *m;
/* Computing MAX
Computing MAX */
i__3 = *m, i__4 = (*m << 1) - 4, i__3 = max(i__3,i__4), i__3 =
max(i__3,*nrhs), i__4 = *n - *m * 3;
i__2 = (*m << 2) + *m * *lda + max(i__3,i__4), i__1 = *m * *lda +
*m + *m * *nrhs;
if (*lwork >= max(i__2,i__1)) {
ldwork = *lda;
}
itau = 1;
iwork = *m + 1;
/* Compute A=L*Q
(Workspace: need 2*M, prefer M+M*NB) */
i__2 = *lwork - iwork + 1;
sgelqf_(m, n, &A(1,1), lda, &WORK(itau), &WORK(iwork), &i__2,
info);
il = iwork;
/* Copy L to WORK(IL), zeroing out above it */
slacpy_("L", m, m, &A(1,1), lda, &WORK(il), &ldwork);
i__2 = *m - 1;
i__1 = *m - 1;
slaset_("U", &i__2, &i__1, &c_b74, &c_b74, &WORK(il + ldwork), &
ldwork);
ie = il + ldwork * *m;
itauq = ie + *m;
itaup = itauq + *m;
iwork = itaup + *m;
/* Bidiagonalize L in WORK(IL)
(Workspace: need M*M+5*M, prefer M*M+4*M+2*M*NB) */
i__2 = *lwork - iwork + 1;
sgebrd_(m, m, &WORK(il), &ldwork, &S(1), &WORK(ie), &WORK(itauq),
&WORK(itaup), &WORK(iwork), &i__2, info);
/* Multiply B by transpose of left bidiagonalizing vectors
of L
(Workspace: need M*M+4*M+NRHS, prefer M*M+4*M+NRHS*NB)
*/
i__2 = *lwork - iwork + 1;
sormbr_("Q", "L", "T", m, nrhs, m, &WORK(il), &ldwork, &WORK(
itauq), &B(1,1), ldb, &WORK(iwork), &i__2, info);
/* Generate right bidiagonalizing vectors of R in WORK(IL)
(Workspace: need M*M+5*M-1, prefer M*M+4*M+(M-1)*NB) */
i__2 = *lwork - iwork + 1;
sorgbr_("P", m, m, m, &WORK(il), &ldwork, &WORK(itaup), &WORK(
iwork), &i__2, info);
iwork = ie + *m;
/* Perform bidiagonal QR iteration,
computing right singular vectors of L in WORK(IL) and
multiplying B by transpose of left singular vectors
(Workspace: need M*M+M+BDSPAC) */
sbdsqr_("U", m, m, &c__0, nrhs, &S(1), &WORK(ie), &WORK(il), &
ldwork, &A(1,1), lda, &B(1,1), ldb, &WORK(iwork)
, info);
if (*info != 0) {
goto L70;
}
/* Multiply B by reciprocals of singular values
Computing MAX */
r__1 = *rcond * S(1);
thr = dmax(r__1,sfmin);
if (*rcond < 0.f) {
/* Computing MAX */
r__1 = eps * S(1);
thr = dmax(r__1,sfmin);
}
*rank = 0;
i__2 = *m;
for (i = 1; i <= *m; ++i) {
if (S(i) > thr) {
srscl_(nrhs, &S(i), &B(i,1), ldb);
++(*rank);
} else {
slaset_("F", &c__1, nrhs, &c_b74, &c_b74, &B(i,1),
ldb);
}
/* L30: */
}
iwork = ie;
/* Multiply B by right singular vectors of L in WORK(IL)
(Workspace: need M*M+2*M, prefer M*M+M+M*NRHS) */
if (*lwork >= *ldb * *nrhs + iwork - 1 && *nrhs > 1) {
sgemm_("T", "N", m, nrhs, m, &c_b108, &WORK(il), &ldwork, &B(1,1), ldb, &c_b74, &WORK(iwork), ldb);
slacpy_("G", m, nrhs, &WORK(iwork), ldb, &B(1,1), ldb);
} else if (*nrhs > 1) {
chunk = (*lwork - iwork + 1) / *m;
i__2 = *nrhs;
i__1 = chunk;
for (i = 1; chunk < 0 ? i >= *nrhs : i <= *nrhs; i += chunk) {
/* Computing MIN */
i__3 = *nrhs - i + 1;
bl = min(i__3,chunk);
sgemm_("T", "N", m, &bl, m, &c_b108, &WORK(il), &ldwork, &
B(1,i), ldb, &c_b74, &WORK(iwork), n);
slacpy_("G", m, &bl, &WORK(iwork), n, &B(1,1), ldb);
/* L40: */
}
} else {
sgemv_("T", m, m, &c_b108, &WORK(il), &ldwork, &B(1,1),
&c__1, &c_b74, &WORK(iwork), &c__1);
scopy_(m, &WORK(iwork), &c__1, &B(1,1), &c__1);
}
/* Zero out below first M rows of B */
i__1 = *n - *m;
slaset_("F", &i__1, nrhs, &c_b74, &c_b74, &B(*m+1,1),
ldb);
iwork = itau + *m;
/* Multiply transpose(Q) by B
(Workspace: need M+NRHS, prefer M+NRHS*NB) */
i__1 = *lwork - iwork + 1;
sormlq_("L", "T", n, nrhs, m, &A(1,1), lda, &WORK(itau), &B(1,1), ldb, &WORK(iwork), &i__1, info);
} else {
/* Path 2 - remaining underdetermined cases */
ie = 1;
itauq = ie + *m;
itaup = itauq + *m;
iwork = itaup + *m;
/* Bidiagonalize A
(Workspace: need 3*M+N, prefer 3*M+(M+N)*NB) */
i__1 = *lwork - iwork + 1;
sgebrd_(m, n, &A(1,1), lda, &S(1), &WORK(ie), &WORK(itauq), &
WORK(itaup), &WORK(iwork), &i__1, info);
/* Multiply B by transpose of left bidiagonalizing vectors
(Workspace: need 3*M+NRHS, prefer 3*M+NRHS*NB) */
i__1 = *lwork - iwork + 1;
sormbr_("Q", "L", "T", m, nrhs, n, &A(1,1), lda, &WORK(itauq)
, &B(1,1), ldb, &WORK(iwork), &i__1, info);
/* Generate right bidiagonalizing vectors in A
(Workspace: need 4*M, prefer 3*M+M*NB) */
i__1 = *lwork - iwork + 1;
sorgbr_("P", m, n, m, &A(1,1), lda, &WORK(itaup), &WORK(
iwork), &i__1, info);
iwork = ie + *m;
/* Perform bidiagonal QR iteration,
computing right singular vectors of A in A and
multiplying B by transpose of left singular vectors
(Workspace: need BDSPAC) */
sbdsqr_("L", m, n, &c__0, nrhs, &S(1), &WORK(ie), &A(1,1),
lda, vdum, &c__1, &B(1,1), ldb, &WORK(iwork), info);
if (*info != 0) {
goto L70;
}
/* Multiply B by reciprocals of singular values
Computing MAX */
r__1 = *rcond * S(1);
thr = dmax(r__1,sfmin);
if (*rcond < 0.f) {
/* Computing MAX */
r__1 = eps * S(1);
thr = dmax(r__1,sfmin);
}
*rank = 0;
i__1 = *m;
for (i = 1; i <= *m; ++i) {
if (S(i) > thr) {
srscl_(nrhs, &S(i), &B(i,1), ldb);
++(*rank);
} else {
slaset_("F", &c__1, nrhs, &c_b74, &c_b74, &B(i,1),
ldb);
}
/* L50: */
}
/* Multiply B by right singular vectors of A
(Workspace: need N, prefer N*NRHS) */
if (*lwork >= *ldb * *nrhs && *nrhs > 1) {
sgemm_("T", "N", n, nrhs, m, &c_b108, &A(1,1), lda, &B(1,1), ldb, &c_b74, &WORK(1), ldb);
slacpy_("F", n, nrhs, &WORK(1), ldb, &B(1,1), ldb);
} else if (*nrhs > 1) {
chunk = *lwork / *n;
i__1 = *nrhs;
i__2 = chunk;
for (i = 1; chunk < 0 ? i >= *nrhs : i <= *nrhs; i += chunk) {
/* Computing MIN */
i__3 = *nrhs - i + 1;
bl = min(i__3,chunk);
sgemm_("T", "N", n, &bl, m, &c_b108, &A(1,1), lda, &
B(1,i), ldb, &c_b74, &WORK(1), n);
slacpy_("F", n, &bl, &WORK(1), n, &B(1,i), ldb);
/* L60: */
}
} else {
sgemv_("T", m, n, &c_b108, &A(1,1), lda, &B(1,1), &
c__1, &c_b74, &WORK(1), &c__1);
scopy_(n, &WORK(1), &c__1, &B(1,1), &c__1);
}
}
}
/* Undo scaling */
if (iascl == 1) {
slascl_("G", &c__0, &c__0, &anrm, &smlnum, n, nrhs, &B(1,1), ldb,
info);
slascl_("G", &c__0, &c__0, &smlnum, &anrm, &minmn, &c__1, &S(1), &
minmn, info);
} else if (iascl == 2) {
slascl_("G", &c__0, &c__0, &anrm, &bignum, n, nrhs, &B(1,1), ldb,
info);
slascl_("G", &c__0, &c__0, &bignum, &anrm, &minmn, &c__1, &S(1), &
minmn, info);
}
if (ibscl == 1) {
slascl_("G", &c__0, &c__0, &smlnum, &bnrm, n, nrhs, &B(1,1), ldb,
info);
} else if (ibscl == 2) {
slascl_("G", &c__0, &c__0, &bignum, &bnrm, n, nrhs, &B(1,1), ldb,
info);
}
L70:
WORK(1) = (real) maxwrk;
return 0;
/* End of SGELSS */
} /* sgelss_ */
/* Subroutine */ int stbcon_(char *norm, char *uplo, char *diag, integer *n,
integer *kd, real *ab, integer *ldab, real *rcond, real *work,
integer *iwork, integer *info)
{
/* System generated locals */
integer ab_dim1, ab_offset, i__1;
real r__1;
/* Local variables */
integer ix, kase, kase1;
real scale;
extern logical lsame_(char *, char *);
integer isave[3];
real anorm;
extern /* Subroutine */ int srscl_(integer *, real *, real *, integer *);
logical upper;
real xnorm;
extern /* Subroutine */ int slacn2_(integer *, real *, real *, integer *,
real *, integer *, integer *);
extern doublereal slamch_(char *);
extern /* Subroutine */ int xerbla_(char *, integer *);
extern integer isamax_(integer *, real *, integer *);
extern doublereal slantb_(char *, char *, char *, integer *, integer *,
real *, integer *, real *);
real ainvnm;
extern /* Subroutine */ int slatbs_(char *, char *, char *, char *,
integer *, integer *, real *, integer *, real *, real *, real *,
integer *);
logical onenrm;
char normin[1];
real smlnum;
logical nounit;
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* Modified to call SLACN2 in place of SLACON, 7 Feb 03, SJH. */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* STBCON estimates the reciprocal of the condition number of a */
/* triangular band matrix A, in either the 1-norm or the infinity-norm. */
/* The norm of A is computed and an estimate is obtained for */
/* norm(inv(A)), then the reciprocal of the condition number is */
/* computed as */
/* RCOND = 1 / ( norm(A) * norm(inv(A)) ). */
/* Arguments */
/* ========= */
/* NORM (input) CHARACTER*1 */
/* Specifies whether the 1-norm condition number or the */
/* infinity-norm condition number is required: */
/* = '1' or 'O': 1-norm; */
/* = 'I': Infinity-norm. */
/* UPLO (input) CHARACTER*1 */
/* = 'U': A is upper triangular; */
/* = 'L': A is lower triangular. */
/* DIAG (input) CHARACTER*1 */
/* = 'N': A is non-unit triangular; */
/* = 'U': A is unit triangular. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* KD (input) INTEGER */
/* The number of superdiagonals or subdiagonals of the */
/* triangular band matrix A. KD >= 0. */
/* AB (input) REAL array, dimension (LDAB,N) */
/* The upper or lower triangular band matrix A, stored in the */
/* first kd+1 rows of the array. The j-th column of A is stored */
/* in the j-th column of the array AB as follows: */
/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
/* If DIAG = 'U', the diagonal elements of A are not referenced */
/* and are assumed to be 1. */
/* LDAB (input) INTEGER */
/* The leading dimension of the array AB. LDAB >= KD+1. */
/* RCOND (output) REAL */
/* The reciprocal of the condition number of the matrix A, */
/* computed as RCOND = 1/(norm(A) * norm(inv(A))). */
/* 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 */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1;
ab -= ab_offset;
--work;
--iwork;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O");
nounit = lsame_(diag, "N");
if (! onenrm && ! lsame_(norm, "I")) {
*info = -1;
} else if (! upper && ! lsame_(uplo, "L")) {
*info = -2;
} else if (! nounit && ! lsame_(diag, "U")) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*kd < 0) {
*info = -5;
} else if (*ldab < *kd + 1) {
*info = -7;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("STBCON", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
*rcond = 1.f;
return 0;
}
*rcond = 0.f;
smlnum = slamch_("Safe minimum") * (real) max(1,*n);
/* Compute the norm of the triangular matrix A. */
anorm = slantb_(norm, uplo, diag, n, kd, &ab[ab_offset], ldab, &work[1]);
/* Continue only if ANORM > 0. */
if (anorm > 0.f) {
/* Estimate the norm of the inverse of A. */
ainvnm = 0.f;
*(unsigned char *)normin = 'N';
if (onenrm) {
kase1 = 1;
} else {
kase1 = 2;
}
kase = 0;
L10:
slacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave);
if (kase != 0) {
if (kase == kase1) {
/* Multiply by inv(A). */
slatbs_(uplo, "No transpose", diag, normin, n, kd, &ab[
ab_offset], ldab, &work[1], &scale, &work[(*n << 1) +
1], info)
;
} else {
/* Multiply by inv(A'). */
slatbs_(uplo, "Transpose", diag, normin, n, kd, &ab[ab_offset]
, ldab, &work[1], &scale, &work[(*n << 1) + 1], info);
}
*(unsigned char *)normin = 'Y';
/* Multiply by 1/SCALE if doing so will not cause overflow. */
if (scale != 1.f) {
ix = isamax_(n, &work[1], &c__1);
xnorm = (r__1 = work[ix], dabs(r__1));
if (scale < xnorm * smlnum || scale == 0.f) {
goto L20;
}
srscl_(n, &scale, &work[1], &c__1);
}
goto L10;
}
/* Compute the estimate of the reciprocal condition number. */
if (ainvnm != 0.f) {
*rcond = 1.f / anorm / ainvnm;
}
}
L20:
return 0;
/* End of STBCON */
} /* stbcon_ */
/* Subroutine */
int strcon_(char *norm, char *uplo, char *diag, integer *n, real *a, integer *lda, real *rcond, real *work, integer *iwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1;
real r__1;
/* Local variables */
integer ix, kase, kase1;
real scale;
extern logical lsame_(char *, char *);
integer isave[3];
real anorm;
extern /* Subroutine */
int srscl_(integer *, real *, real *, integer *);
logical upper;
real xnorm;
extern /* Subroutine */
int slacn2_(integer *, real *, real *, integer *, real *, integer *, integer *);
extern real slamch_(char *);
extern /* Subroutine */
int xerbla_(char *, integer *);
extern integer isamax_(integer *, real *, integer *);
real ainvnm;
logical onenrm;
char normin[1];
extern real slantr_(char *, char *, char *, integer *, integer *, real *, integer *, real *);
extern /* Subroutine */
int slatrs_(char *, char *, char *, char *, integer *, real *, integer *, real *, real *, real *, integer *);
real smlnum;
logical nounit;
/* -- LAPACK computational routine (version 3.4.0) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* November 2011 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. 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;
--work;
--iwork;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O");
nounit = lsame_(diag, "N");
if (! onenrm && ! lsame_(norm, "I"))
{
*info = -1;
}
else if (! upper && ! lsame_(uplo, "L"))
{
*info = -2;
}
else if (! nounit && ! lsame_(diag, "U"))
{
*info = -3;
}
else if (*n < 0)
{
*info = -4;
}
else if (*lda < max(1,*n))
{
*info = -6;
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("STRCON", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0)
{
*rcond = 1.f;
return 0;
}
*rcond = 0.f;
smlnum = slamch_("Safe minimum") * (real) max(1,*n);
/* Compute the norm of the triangular matrix A. */
anorm = slantr_(norm, uplo, diag, n, n, &a[a_offset], lda, &work[1]);
/* Continue only if ANORM > 0. */
if (anorm > 0.f)
{
/* Estimate the norm of the inverse of A. */
ainvnm = 0.f;
*(unsigned char *)normin = 'N';
if (onenrm)
{
kase1 = 1;
}
else
{
kase1 = 2;
}
kase = 0;
L10:
slacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave);
if (kase != 0)
{
if (kase == kase1)
{
/* Multiply by inv(A). */
slatrs_(uplo, "No transpose", diag, normin, n, &a[a_offset], lda, &work[1], &scale, &work[(*n << 1) + 1], info);
}
else
{
/* Multiply by inv(A**T). */
slatrs_(uplo, "Transpose", diag, normin, n, &a[a_offset], lda, &work[1], &scale, &work[(*n << 1) + 1], info);
}
*(unsigned char *)normin = 'Y';
/* Multiply by 1/SCALE if doing so will not cause overflow. */
if (scale != 1.f)
{
ix = isamax_(n, &work[1], &c__1);
xnorm = (r__1 = work[ix], f2c_abs(r__1));
if (scale < xnorm * smlnum || scale == 0.f)
{
goto L20;
}
srscl_(n, &scale, &work[1], &c__1);
}
goto L10;
}
/* Compute the estimate of the reciprocal condition number. */
if (ainvnm != 0.f)
{
*rcond = 1.f / anorm / ainvnm;
}
}
L20:
return 0;
/* End of STRCON */
}
/* Subroutine */ int spocon_(char *uplo, integer *n, real *a, integer *lda,
real *anorm, real *rcond, real *work, integer *iwork, integer *info)
{
/* -- LAPACK routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
March 31, 1993
Purpose
=======
SPOCON estimates the reciprocal of the condition number (in the
1-norm) of a real symmetric positive definite matrix using the
Cholesky factorization A = U**T*U or A = L*L**T computed by SPOTRF.
An estimate is obtained for norm(inv(A)), and the reciprocal of the
condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
Arguments
=========
UPLO (input) CHARACTER*1
= 'U': Upper triangle of A is stored;
= 'L': Lower triangle of A is stored.
N (input) INTEGER
The order of the matrix A. N >= 0.
A (input) REAL array, dimension (LDA,N)
The triangular factor U or L from the Cholesky factorization
A = U**T*U or A = L*L**T, as computed by SPOTRF.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
ANORM (input) REAL
The 1-norm (or infinity-norm) of the symmetric matrix A.
RCOND (output) REAL
The reciprocal of the condition number of the matrix A,
computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
estimate of the 1-norm of inv(A) computed in this routine.
WORK (workspace) 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
Function Body */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer a_dim1, a_offset, i__1;
real r__1;
/* Local variables */
static integer kase;
static real scale;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int srscl_(integer *, real *, real *, integer *);
static logical upper;
static integer ix;
static real scalel;
extern doublereal slamch_(char *);
static real scaleu;
extern /* Subroutine */ int xerbla_(char *, integer *), slacon_(
integer *, real *, real *, integer *, real *, integer *);
extern integer isamax_(integer *, real *, integer *);
static real ainvnm;
static char normin[1];
extern /* Subroutine */ int slatrs_(char *, char *, char *, char *,
integer *, real *, integer *, real *, real *, real *, integer *);
static real smlnum;
#define WORK(I) work[(I)-1]
#define IWORK(I) iwork[(I)-1]
#define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)]
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*n)) {
*info = -4;
} else if (*anorm < 0.f) {
*info = -5;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SPOCON", &i__1);
return 0;
}
/* Quick return if possible */
*rcond = 0.f;
if (*n == 0) {
*rcond = 1.f;
return 0;
} else if (*anorm == 0.f) {
return 0;
}
smlnum = slamch_("Safe minimum");
/* Estimate the 1-norm of inv(A). */
kase = 0;
*(unsigned char *)normin = 'N';
L10:
slacon_(n, &WORK(*n + 1), &WORK(1), &IWORK(1), &ainvnm, &kase);
if (kase != 0) {
if (upper) {
/* Multiply by inv(U'). */
slatrs_("Upper", "Transpose", "Non-unit", normin, n, &A(1,1),
lda, &WORK(1), &scalel, &WORK((*n << 1) + 1), info);
*(unsigned char *)normin = 'Y';
/* Multiply by inv(U). */
slatrs_("Upper", "No transpose", "Non-unit", normin, n, &A(1,1), lda, &WORK(1), &scaleu, &WORK((*n << 1) + 1),
info);
} else {
/* Multiply by inv(L). */
slatrs_("Lower", "No transpose", "Non-unit", normin, n, &A(1,1), lda, &WORK(1), &scalel, &WORK((*n << 1) + 1),
info);
*(unsigned char *)normin = 'Y';
/* Multiply by inv(L'). */
slatrs_("Lower", "Transpose", "Non-unit", normin, n, &A(1,1),
lda, &WORK(1), &scaleu, &WORK((*n << 1) + 1), info);
}
/* Multiply by 1/SCALE if doing so will not cause overflow. */
scale = scalel * scaleu;
if (scale != 1.f) {
ix = isamax_(n, &WORK(1), &c__1);
if (scale < (r__1 = WORK(ix), dabs(r__1)) * smlnum || scale ==
0.f) {
goto L20;
}
srscl_(n, &scale, &WORK(1), &c__1);
}
goto L10;
}
/* Compute the estimate of the reciprocal condition number. */
if (ainvnm != 0.f) {
*rcond = 1.f / ainvnm / *anorm;
}
L20:
return 0;
/* End of SPOCON */
} /* spocon_ */