slapack_lite.c
/*
NOTE: This is generated code. Look in README.python for information on
remaking this file.
*/
#include "sphinxbase/f2c.h"
#ifdef HAVE_CONFIG
#include "config.h"
#else
extern doublereal slamch_(char *);
#define EPSILON slamch_("Epsilon")
#define SAFEMINIMUM slamch_("Safe minimum")
#define PRECISION slamch_("Precision")
#define BASE slamch_("Base")
#endif
extern doublereal slapy2_(real *, real *);
/* Table of constant values */
static integer c__0 = 0;
static real c_b163 = 0.f;
static real c_b164 = 1.f;
static integer c__1 = 1;
static real c_b181 = -1.f;
static integer c_n1 = -1;
integer ieeeck_(integer *ispec, real *zero, real *one)
{
/* System generated locals */
integer ret_val;
/* Local variables */
static real nan1, nan2, nan3, nan4, nan5, nan6, neginf, posinf, negzro,
newzro;
/*
-- LAPACK auxiliary routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1998
Purpose
=======
IEEECK is called from the ILAENV to verify that Infinity and
possibly NaN arithmetic is safe (i.e. will not trap).
Arguments
=========
ISPEC (input) INTEGER
Specifies whether to test just for inifinity arithmetic
or whether to test for infinity and NaN arithmetic.
= 0: Verify infinity arithmetic only.
= 1: Verify infinity and NaN arithmetic.
ZERO (input) REAL
Must contain the value 0.0
This is passed to prevent the compiler from optimizing
away this code.
ONE (input) REAL
Must contain the value 1.0
This is passed to prevent the compiler from optimizing
away this code.
RETURN VALUE: INTEGER
= 0: Arithmetic failed to produce the correct answers
= 1: Arithmetic produced the correct answers
*/
ret_val = 1;
posinf = *one / *zero;
if (posinf <= *one) {
ret_val = 0;
return ret_val;
}
neginf = -(*one) / *zero;
if (neginf >= *zero) {
ret_val = 0;
return ret_val;
}
negzro = *one / (neginf + *one);
if (negzro != *zero) {
ret_val = 0;
return ret_val;
}
neginf = *one / negzro;
if (neginf >= *zero) {
ret_val = 0;
return ret_val;
}
newzro = negzro + *zero;
if (newzro != *zero) {
ret_val = 0;
return ret_val;
}
posinf = *one / newzro;
if (posinf <= *one) {
ret_val = 0;
return ret_val;
}
neginf *= posinf;
if (neginf >= *zero) {
ret_val = 0;
return ret_val;
}
posinf *= posinf;
if (posinf <= *one) {
ret_val = 0;
return ret_val;
}
/* Return if we were only asked to check infinity arithmetic */
if (*ispec == 0) {
return ret_val;
}
nan1 = posinf + neginf;
nan2 = posinf / neginf;
nan3 = posinf / posinf;
nan4 = posinf * *zero;
nan5 = neginf * negzro;
nan6 = nan5 * 0.f;
if (nan1 == nan1) {
ret_val = 0;
return ret_val;
}
if (nan2 == nan2) {
ret_val = 0;
return ret_val;
}
if (nan3 == nan3) {
ret_val = 0;
return ret_val;
}
if (nan4 == nan4) {
ret_val = 0;
return ret_val;
}
if (nan5 == nan5) {
ret_val = 0;
return ret_val;
}
if (nan6 == nan6) {
ret_val = 0;
return ret_val;
}
return ret_val;
} /* ieeeck_ */
integer ilaenv_(integer *ispec, char *name__, char *opts, integer *n1,
integer *n2, integer *n3, integer *n4, ftnlen name_len, ftnlen
opts_len)
{
/* System generated locals */
integer ret_val;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Local variables */
static integer i__;
static char c1[1], c2[2], c3[3], c4[2];
static integer ic, nb, iz, nx;
static logical cname, sname;
static integer nbmin;
extern integer ieeeck_(integer *, real *, real *);
static char subnam[6];
/*
-- LAPACK auxiliary routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
Purpose
=======
ILAENV is called from the LAPACK routines to choose problem-dependent
parameters for the local environment. See ISPEC for a description of
the parameters.
This version provides a set of parameters which should give good,
but not optimal, performance on many of the currently available
computers. Users are encouraged to modify this subroutine to set
the tuning parameters for their particular machine using the option
and problem size information in the arguments.
This routine will not function correctly if it is converted to all
lower case. Converting it to all upper case is allowed.
Arguments
=========
ISPEC (input) INTEGER
Specifies the parameter to be returned as the value of
ILAENV.
= 1: the optimal blocksize; if this value is 1, an unblocked
algorithm will give the best performance.
= 2: the minimum block size for which the block routine
should be used; if the usable block size is less than
this value, an unblocked routine should be used.
= 3: the crossover point (in a block routine, for N less
than this value, an unblocked routine should be used)
= 4: the number of shifts, used in the nonsymmetric
eigenvalue routines
= 5: the minimum column dimension for blocking to be used;
rectangular blocks must have dimension at least k by m,
where k is given by ILAENV(2,...) and m by ILAENV(5,...)
= 6: the crossover point for the SVD (when reducing an m by n
matrix to bidiagonal form, if max(m,n)/min(m,n) exceeds
this value, a QR factorization is used first to reduce
the matrix to a triangular form.)
= 7: the number of processors
= 8: the crossover point for the multishift QR and QZ methods
for nonsymmetric eigenvalue problems.
= 9: maximum size of the subproblems at the bottom of the
computation tree in the divide-and-conquer algorithm
(used by xGELSD and xGESDD)
=10: ieee NaN arithmetic can be trusted not to trap
=11: infinity arithmetic can be trusted not to trap
NAME (input) CHARACTER*(*)
The name of the calling subroutine, in either upper case or
lower case.
OPTS (input) CHARACTER*(*)
The character options to the subroutine NAME, concatenated
into a single character string. For example, UPLO = 'U',
TRANS = 'T', and DIAG = 'N' for a triangular routine would
be specified as OPTS = 'UTN'.
N1 (input) INTEGER
N2 (input) INTEGER
N3 (input) INTEGER
N4 (input) INTEGER
Problem dimensions for the subroutine NAME; these may not all
be required.
(ILAENV) (output) INTEGER
>= 0: the value of the parameter specified by ISPEC
< 0: if ILAENV = -k, the k-th argument had an illegal value.
Further Details
===============
The following conventions have been used when calling ILAENV from the
LAPACK routines:
1) OPTS is a concatenation of all of the character options to
subroutine NAME, in the same order that they appear in the
argument list for NAME, even if they are not used in determining
the value of the parameter specified by ISPEC.
2) The problem dimensions N1, N2, N3, N4 are specified in the order
that they appear in the argument list for NAME. N1 is used
first, N2 second, and so on, and unused problem dimensions are
passed a value of -1.
3) The parameter value returned by ILAENV is checked for validity in
the calling subroutine. For example, ILAENV is used to retrieve
the optimal blocksize for STRTRI as follows:
NB = ILAENV( 1, 'STRTRI', UPLO // DIAG, N, -1, -1, -1 )
IF( NB.LE.1 ) NB = MAX( 1, N )
=====================================================================
*/
switch (*ispec) {
case 1: goto L100;
case 2: goto L100;
case 3: goto L100;
case 4: goto L400;
case 5: goto L500;
case 6: goto L600;
case 7: goto L700;
case 8: goto L800;
case 9: goto L900;
case 10: goto L1000;
case 11: goto L1100;
}
/* Invalid value for ISPEC */
ret_val = -1;
return ret_val;
L100:
/* Convert NAME to upper case if the first character is lower case. */
ret_val = 1;
s_copy(subnam, name__, (ftnlen)6, name_len);
ic = *(unsigned char *)subnam;
iz = 'Z';
if (iz == 90 || iz == 122) {
/* ASCII character set */
if (ic >= 97 && ic <= 122) {
*(unsigned char *)subnam = (char) (ic - 32);
for (i__ = 2; i__ <= 6; ++i__) {
ic = *(unsigned char *)&subnam[i__ - 1];
if (ic >= 97 && ic <= 122) {
*(unsigned char *)&subnam[i__ - 1] = (char) (ic - 32);
}
/* L10: */
}
}
} else if (iz == 233 || iz == 169) {
/* EBCDIC character set */
if (ic >= 129 && ic <= 137 || ic >= 145 && ic <= 153 || ic >= 162 &&
ic <= 169) {
*(unsigned char *)subnam = (char) (ic + 64);
for (i__ = 2; i__ <= 6; ++i__) {
ic = *(unsigned char *)&subnam[i__ - 1];
if (ic >= 129 && ic <= 137 || ic >= 145 && ic <= 153 || ic >=
162 && ic <= 169) {
*(unsigned char *)&subnam[i__ - 1] = (char) (ic + 64);
}
/* L20: */
}
}
} else if (iz == 218 || iz == 250) {
/* Prime machines: ASCII+128 */
if (ic >= 225 && ic <= 250) {
*(unsigned char *)subnam = (char) (ic - 32);
for (i__ = 2; i__ <= 6; ++i__) {
ic = *(unsigned char *)&subnam[i__ - 1];
if (ic >= 225 && ic <= 250) {
*(unsigned char *)&subnam[i__ - 1] = (char) (ic - 32);
}
/* L30: */
}
}
}
*(unsigned char *)c1 = *(unsigned char *)subnam;
sname = *(unsigned char *)c1 == 'S' || *(unsigned char *)c1 == 'D';
cname = *(unsigned char *)c1 == 'C' || *(unsigned char *)c1 == 'Z';
if (! (cname || sname)) {
return ret_val;
}
s_copy(c2, subnam + 1, (ftnlen)2, (ftnlen)2);
s_copy(c3, subnam + 3, (ftnlen)3, (ftnlen)3);
s_copy(c4, c3 + 1, (ftnlen)2, (ftnlen)2);
switch (*ispec) {
case 1: goto L110;
case 2: goto L200;
case 3: goto L300;
}
L110:
/*
ISPEC = 1: block size
In these examples, separate code is provided for setting NB for
real and complex. We assume that NB will take the same value in
single or double precision.
*/
nb = 1;
if (s_cmp(c2, "GE", (ftnlen)2, (ftnlen)2) == 0) {
if (s_cmp(c3, "TRF", (ftnlen)3, (ftnlen)3) == 0) {
if (sname) {
nb = 64;
} else {
nb = 64;
}
} else if (s_cmp(c3, "QRF", (ftnlen)3, (ftnlen)3) == 0 || s_cmp(c3,
"RQF", (ftnlen)3, (ftnlen)3) == 0 || s_cmp(c3, "LQF", (ftnlen)
3, (ftnlen)3) == 0 || s_cmp(c3, "QLF", (ftnlen)3, (ftnlen)3)
== 0) {
if (sname) {
nb = 32;
} else {
nb = 32;
}
} else if (s_cmp(c3, "HRD", (ftnlen)3, (ftnlen)3) == 0) {
if (sname) {
nb = 32;
} else {
nb = 32;
}
} else if (s_cmp(c3, "BRD", (ftnlen)3, (ftnlen)3) == 0) {
if (sname) {
nb = 32;
} else {
nb = 32;
}
} else if (s_cmp(c3, "TRI", (ftnlen)3, (ftnlen)3) == 0) {
if (sname) {
nb = 64;
} else {
nb = 64;
}
}
} else if (s_cmp(c2, "PO", (ftnlen)2, (ftnlen)2) == 0) {
if (s_cmp(c3, "TRF", (ftnlen)3, (ftnlen)3) == 0) {
if (sname) {
nb = 64;
} else {
nb = 64;
}
}
} else if (s_cmp(c2, "SY", (ftnlen)2, (ftnlen)2) == 0) {
if (s_cmp(c3, "TRF", (ftnlen)3, (ftnlen)3) == 0) {
if (sname) {
nb = 64;
} else {
nb = 64;
}
} else if (sname && s_cmp(c3, "TRD", (ftnlen)3, (ftnlen)3) == 0) {
nb = 32;
} else if (sname && s_cmp(c3, "GST", (ftnlen)3, (ftnlen)3) == 0) {
nb = 64;
}
} else if (cname && s_cmp(c2, "HE", (ftnlen)2, (ftnlen)2) == 0) {
if (s_cmp(c3, "TRF", (ftnlen)3, (ftnlen)3) == 0) {
nb = 64;
} else if (s_cmp(c3, "TRD", (ftnlen)3, (ftnlen)3) == 0) {
nb = 32;
} else if (s_cmp(c3, "GST", (ftnlen)3, (ftnlen)3) == 0) {
nb = 64;
}
} else if (sname && s_cmp(c2, "OR", (ftnlen)2, (ftnlen)2) == 0) {
if (*(unsigned char *)c3 == 'G') {
if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ",
(ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, (
ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) ==
0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(
c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
ftnlen)2, (ftnlen)2) == 0) {
nb = 32;
}
} else if (*(unsigned char *)c3 == 'M') {
if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ",
(ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, (
ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) ==
0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(
c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
ftnlen)2, (ftnlen)2) == 0) {
nb = 32;
}
}
} else if (cname && s_cmp(c2, "UN", (ftnlen)2, (ftnlen)2) == 0) {
if (*(unsigned char *)c3 == 'G') {
if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ",
(ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, (
ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) ==
0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(
c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
ftnlen)2, (ftnlen)2) == 0) {
nb = 32;
}
} else if (*(unsigned char *)c3 == 'M') {
if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ",
(ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, (
ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) ==
0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(
c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
ftnlen)2, (ftnlen)2) == 0) {
nb = 32;
}
}
} else if (s_cmp(c2, "GB", (ftnlen)2, (ftnlen)2) == 0) {
if (s_cmp(c3, "TRF", (ftnlen)3, (ftnlen)3) == 0) {
if (sname) {
if (*n4 <= 64) {
nb = 1;
} else {
nb = 32;
}
} else {
if (*n4 <= 64) {
nb = 1;
} else {
nb = 32;
}
}
}
} else if (s_cmp(c2, "PB", (ftnlen)2, (ftnlen)2) == 0) {
if (s_cmp(c3, "TRF", (ftnlen)3, (ftnlen)3) == 0) {
if (sname) {
if (*n2 <= 64) {
nb = 1;
} else {
nb = 32;
}
} else {
if (*n2 <= 64) {
nb = 1;
} else {
nb = 32;
}
}
}
} else if (s_cmp(c2, "TR", (ftnlen)2, (ftnlen)2) == 0) {
if (s_cmp(c3, "TRI", (ftnlen)3, (ftnlen)3) == 0) {
if (sname) {
nb = 64;
} else {
nb = 64;
}
}
} else if (s_cmp(c2, "LA", (ftnlen)2, (ftnlen)2) == 0) {
if (s_cmp(c3, "UUM", (ftnlen)3, (ftnlen)3) == 0) {
if (sname) {
nb = 64;
} else {
nb = 64;
}
}
} else if (sname && s_cmp(c2, "ST", (ftnlen)2, (ftnlen)2) == 0) {
if (s_cmp(c3, "EBZ", (ftnlen)3, (ftnlen)3) == 0) {
nb = 1;
}
}
ret_val = nb;
return ret_val;
L200:
/* ISPEC = 2: minimum block size */
nbmin = 2;
if (s_cmp(c2, "GE", (ftnlen)2, (ftnlen)2) == 0) {
if (s_cmp(c3, "QRF", (ftnlen)3, (ftnlen)3) == 0 || s_cmp(c3, "RQF", (
ftnlen)3, (ftnlen)3) == 0 || s_cmp(c3, "LQF", (ftnlen)3, (
ftnlen)3) == 0 || s_cmp(c3, "QLF", (ftnlen)3, (ftnlen)3) == 0)
{
if (sname) {
nbmin = 2;
} else {
nbmin = 2;
}
} else if (s_cmp(c3, "HRD", (ftnlen)3, (ftnlen)3) == 0) {
if (sname) {
nbmin = 2;
} else {
nbmin = 2;
}
} else if (s_cmp(c3, "BRD", (ftnlen)3, (ftnlen)3) == 0) {
if (sname) {
nbmin = 2;
} else {
nbmin = 2;
}
} else if (s_cmp(c3, "TRI", (ftnlen)3, (ftnlen)3) == 0) {
if (sname) {
nbmin = 2;
} else {
nbmin = 2;
}
}
} else if (s_cmp(c2, "SY", (ftnlen)2, (ftnlen)2) == 0) {
if (s_cmp(c3, "TRF", (ftnlen)3, (ftnlen)3) == 0) {
if (sname) {
nbmin = 8;
} else {
nbmin = 8;
}
} else if (sname && s_cmp(c3, "TRD", (ftnlen)3, (ftnlen)3) == 0) {
nbmin = 2;
}
} else if (cname && s_cmp(c2, "HE", (ftnlen)2, (ftnlen)2) == 0) {
if (s_cmp(c3, "TRD", (ftnlen)3, (ftnlen)3) == 0) {
nbmin = 2;
}
} else if (sname && s_cmp(c2, "OR", (ftnlen)2, (ftnlen)2) == 0) {
if (*(unsigned char *)c3 == 'G') {
if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ",
(ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, (
ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) ==
0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(
c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
ftnlen)2, (ftnlen)2) == 0) {
nbmin = 2;
}
} else if (*(unsigned char *)c3 == 'M') {
if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ",
(ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, (
ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) ==
0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(
c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
ftnlen)2, (ftnlen)2) == 0) {
nbmin = 2;
}
}
} else if (cname && s_cmp(c2, "UN", (ftnlen)2, (ftnlen)2) == 0) {
if (*(unsigned char *)c3 == 'G') {
if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ",
(ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, (
ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) ==
0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(
c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
ftnlen)2, (ftnlen)2) == 0) {
nbmin = 2;
}
} else if (*(unsigned char *)c3 == 'M') {
if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ",
(ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, (
ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) ==
0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(
c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
ftnlen)2, (ftnlen)2) == 0) {
nbmin = 2;
}
}
}
ret_val = nbmin;
return ret_val;
L300:
/* ISPEC = 3: crossover point */
nx = 0;
if (s_cmp(c2, "GE", (ftnlen)2, (ftnlen)2) == 0) {
if (s_cmp(c3, "QRF", (ftnlen)3, (ftnlen)3) == 0 || s_cmp(c3, "RQF", (
ftnlen)3, (ftnlen)3) == 0 || s_cmp(c3, "LQF", (ftnlen)3, (
ftnlen)3) == 0 || s_cmp(c3, "QLF", (ftnlen)3, (ftnlen)3) == 0)
{
if (sname) {
nx = 128;
} else {
nx = 128;
}
} else if (s_cmp(c3, "HRD", (ftnlen)3, (ftnlen)3) == 0) {
if (sname) {
nx = 128;
} else {
nx = 128;
}
} else if (s_cmp(c3, "BRD", (ftnlen)3, (ftnlen)3) == 0) {
if (sname) {
nx = 128;
} else {
nx = 128;
}
}
} else if (s_cmp(c2, "SY", (ftnlen)2, (ftnlen)2) == 0) {
if (sname && s_cmp(c3, "TRD", (ftnlen)3, (ftnlen)3) == 0) {
nx = 32;
}
} else if (cname && s_cmp(c2, "HE", (ftnlen)2, (ftnlen)2) == 0) {
if (s_cmp(c3, "TRD", (ftnlen)3, (ftnlen)3) == 0) {
nx = 32;
}
} else if (sname && s_cmp(c2, "OR", (ftnlen)2, (ftnlen)2) == 0) {
if (*(unsigned char *)c3 == 'G') {
if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ",
(ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, (
ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) ==
0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(
c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
ftnlen)2, (ftnlen)2) == 0) {
nx = 128;
}
}
} else if (cname && s_cmp(c2, "UN", (ftnlen)2, (ftnlen)2) == 0) {
if (*(unsigned char *)c3 == 'G') {
if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ",
(ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, (
ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) ==
0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(
c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
ftnlen)2, (ftnlen)2) == 0) {
nx = 128;
}
}
}
ret_val = nx;
return ret_val;
L400:
/* ISPEC = 4: number of shifts (used by xHSEQR) */
ret_val = 6;
return ret_val;
L500:
/* ISPEC = 5: minimum column dimension (not used) */
ret_val = 2;
return ret_val;
L600:
/* ISPEC = 6: crossover point for SVD (used by xGELSS and xGESVD) */
ret_val = (integer) ((real) min(*n1,*n2) * 1.6f);
return ret_val;
L700:
/* ISPEC = 7: number of processors (not used) */
ret_val = 1;
return ret_val;
L800:
/* ISPEC = 8: crossover point for multishift (used by xHSEQR) */
ret_val = 50;
return ret_val;
L900:
/*
ISPEC = 9: maximum size of the subproblems at the bottom of the
computation tree in the divide-and-conquer algorithm
(used by xGELSD and xGESDD)
*/
ret_val = 25;
return ret_val;
L1000:
/*
ISPEC = 10: ieee NaN arithmetic can be trusted not to trap
ILAENV = 0
*/
ret_val = 1;
if (ret_val == 1) {
ret_val = ieeeck_(&c__0, &c_b163, &c_b164);
}
return ret_val;
L1100:
/*
ISPEC = 11: infinity arithmetic can be trusted not to trap
ILAENV = 0
*/
ret_val = 1;
if (ret_val == 1) {
ret_val = ieeeck_(&c__1, &c_b163, &c_b164);
}
return ret_val;
/* End of ILAENV */
} /* ilaenv_ */
/* Subroutine */ int sposv_(char *uplo, integer *n, integer *nrhs, real *a,
integer *lda, real *b, integer *ldb, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1;
/* Local variables */
extern logical lsame_(char *, char *);
extern /* Subroutine */ int xerbla_(char *, integer *), spotrf_(
char *, integer *, real *, integer *, integer *), spotrs_(
char *, integer *, integer *, real *, integer *, real *, integer *
, integer *);
/*
-- LAPACK driver 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
=======
SPOSV computes the solution to a real system of linear equations
A * X = B,
where A is an N-by-N symmetric positive definite matrix and X and B
are N-by-NRHS matrices.
The Cholesky decomposition is used to factor A as
A = U**T* U, if UPLO = 'U', or
A = L * L**T, if UPLO = 'L',
where U is an upper triangular matrix and L is a lower triangular
matrix. The factored form of A is then used to solve the system of
equations A * X = B.
Arguments
=========
UPLO (input) CHARACTER*1
= 'U': Upper triangle of A is stored;
= 'L': Lower triangle of A is stored.
N (input) INTEGER
The number of linear equations, i.e., the order of the
matrix A. N >= 0.
NRHS (input) INTEGER
The number of right hand sides, i.e., the number of columns
of the matrix B. NRHS >= 0.
A (input/output) REAL array, dimension (LDA,N)
On entry, the symmetric matrix A. If UPLO = 'U', the leading
N-by-N upper triangular part of A contains the upper
triangular part of the matrix A, and the strictly lower
triangular part of A is not referenced. If UPLO = 'L', the
leading N-by-N lower triangular part of A contains the lower
triangular part of the matrix A, and the strictly upper
triangular part of A is not referenced.
On exit, if INFO = 0, the factor U or L from the Cholesky
factorization A = U**T*U or A = L*L**T.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
B (input/output) REAL array, dimension (LDB,NRHS)
On entry, the N-by-NRHS right hand side matrix B.
On exit, if INFO = 0, the N-by-NRHS solution matrix X.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: if INFO = i, the leading minor of order i of A is not
positive definite, so the factorization could not be
completed, and the solution has not been computed.
=====================================================================
Test the input parameters.
*/
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
/* Function Body */
*info = 0;
if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*nrhs < 0) {
*info = -3;
} else if (*lda < max(1,*n)) {
*info = -5;
} else if (*ldb < max(1,*n)) {
*info = -7;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SPOSV ", &i__1);
return 0;
}
/* Compute the Cholesky factorization A = U'*U or A = L*L'. */
spotrf_(uplo, n, &a[a_offset], lda, info);
if (*info == 0) {
/* Solve the system A*X = B, overwriting B with X. */
spotrs_(uplo, n, nrhs, &a[a_offset], lda, &b[b_offset], ldb, info);
}
return 0;
/* End of SPOSV */
} /* sposv_ */
/* Subroutine */ int spotf2_(char *uplo, integer *n, real *a, integer *lda,
integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
real r__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
static integer j;
static real ajj;
extern doublereal sdot_(integer *, real *, integer *, real *, integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *),
sgemv_(char *, integer *, integer *, real *, real *, integer *,
real *, integer *, real *, real *, integer *);
static logical upper;
extern /* Subroutine */ int xerbla_(char *, integer *);
/*
-- 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
=======
SPOTF2 computes the Cholesky factorization of a real symmetric
positive definite matrix A.
The factorization has the form
A = U' * U , if UPLO = 'U', or
A = L * L', if UPLO = 'L',
where U is an upper triangular matrix and L is lower triangular.
This is the unblocked version of the algorithm, calling Level 2 BLAS.
Arguments
=========
UPLO (input) CHARACTER*1
Specifies whether the upper or lower triangular part of the
symmetric matrix A is stored.
= 'U': Upper triangular
= 'L': Lower triangular
N (input) INTEGER
The order of the matrix A. N >= 0.
A (input/output) REAL array, dimension (LDA,N)
On entry, the symmetric matrix A. If UPLO = 'U', the leading
n by n upper triangular part of A contains the upper
triangular part of the matrix A, and the strictly lower
triangular part of A is not referenced. If UPLO = 'L', the
leading n by n lower triangular part of A contains the lower
triangular part of the matrix A, and the strictly upper
triangular part of A is not referenced.
On exit, if INFO = 0, the factor U or L from the Cholesky
factorization A = U'*U or A = L*L'.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -k, the k-th argument had an illegal value
> 0: if INFO = k, the leading minor of order k is not
positive definite, and the factorization could not be
completed.
=====================================================================
Test the input parameters.
*/
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*n)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SPOTF2", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (upper) {
/* Compute the Cholesky factorization A = U'*U. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Compute U(J,J) and test for non-positive-definiteness. */
i__2 = j - 1;
ajj = a[j + j * a_dim1] - sdot_(&i__2, &a[j * a_dim1 + 1], &c__1,
&a[j * a_dim1 + 1], &c__1);
if (ajj <= 0.f) {
a[j + j * a_dim1] = ajj;
goto L30;
}
ajj = sqrt(ajj);
a[j + j * a_dim1] = ajj;
/* Compute elements J+1:N of row J. */
if (j < *n) {
i__2 = j - 1;
i__3 = *n - j;
sgemv_("Transpose", &i__2, &i__3, &c_b181, &a[(j + 1) *
a_dim1 + 1], lda, &a[j * a_dim1 + 1], &c__1, &c_b164,
&a[j + (j + 1) * a_dim1], lda);
i__2 = *n - j;
r__1 = 1.f / ajj;
sscal_(&i__2, &r__1, &a[j + (j + 1) * a_dim1], lda);
}
/* L10: */
}
} else {
/* Compute the Cholesky factorization A = L*L'. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Compute L(J,J) and test for non-positive-definiteness. */
i__2 = j - 1;
ajj = a[j + j * a_dim1] - sdot_(&i__2, &a[j + a_dim1], lda, &a[j
+ a_dim1], lda);
if (ajj <= 0.f) {
a[j + j * a_dim1] = ajj;
goto L30;
}
ajj = sqrt(ajj);
a[j + j * a_dim1] = ajj;
/* Compute elements J+1:N of column J. */
if (j < *n) {
i__2 = *n - j;
i__3 = j - 1;
sgemv_("No transpose", &i__2, &i__3, &c_b181, &a[j + 1 +
a_dim1], lda, &a[j + a_dim1], lda, &c_b164, &a[j + 1
+ j * a_dim1], &c__1);
i__2 = *n - j;
r__1 = 1.f / ajj;
sscal_(&i__2, &r__1, &a[j + 1 + j * a_dim1], &c__1);
}
/* L20: */
}
}
goto L40;
L30:
*info = j;
L40:
return 0;
/* End of SPOTF2 */
} /* spotf2_ */
/* Subroutine */ int spotrf_(char *uplo, integer *n, real *a, integer *lda,
integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
/* Local variables */
static integer j, jb, nb;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
integer *, real *, real *, integer *, real *, integer *, real *,
real *, integer *);
static logical upper;
extern /* Subroutine */ int strsm_(char *, char *, char *, char *,
integer *, integer *, real *, real *, integer *, real *, integer *
), ssyrk_(char *, char *, integer
*, integer *, real *, real *, integer *, real *, real *, integer *
), spotf2_(char *, integer *, real *, integer *,
integer *), xerbla_(char *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
/*
-- 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
=======
SPOTRF computes the Cholesky factorization of a real symmetric
positive definite matrix A.
The factorization has the form
A = U**T * U, if UPLO = 'U', or
A = L * L**T, if UPLO = 'L',
where U is an upper triangular matrix and L is lower triangular.
This is the block version of the algorithm, calling Level 3 BLAS.
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/output) REAL array, dimension (LDA,N)
On entry, the symmetric matrix A. If UPLO = 'U', the leading
N-by-N upper triangular part of A contains the upper
triangular part of the matrix A, and the strictly lower
triangular part of A is not referenced. If UPLO = 'L', the
leading N-by-N lower triangular part of A contains the lower
triangular part of the matrix A, and the strictly upper
triangular part of A is not referenced.
On exit, if INFO = 0, the factor U or L from the Cholesky
factorization A = U**T*U or A = L*L**T.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: if INFO = i, the leading minor of order i is not
positive definite, and the factorization could not be
completed.
=====================================================================
Test the input parameters.
*/
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*n)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SPOTRF", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Determine the block size for this environment. */
nb = ilaenv_(&c__1, "SPOTRF", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)6, (
ftnlen)1);
if (nb <= 1 || nb >= *n) {
/* Use unblocked code. */
spotf2_(uplo, n, &a[a_offset], lda, info);
} else {
/* Use blocked code. */
if (upper) {
/* Compute the Cholesky factorization A = U'*U. */
i__1 = *n;
i__2 = nb;
for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
/*
Update and factorize the current diagonal block and test
for non-positive-definiteness.
Computing MIN
*/
i__3 = nb, i__4 = *n - j + 1;
jb = min(i__3,i__4);
i__3 = j - 1;
ssyrk_("Upper", "Transpose", &jb, &i__3, &c_b181, &a[j *
a_dim1 + 1], lda, &c_b164, &a[j + j * a_dim1], lda);
spotf2_("Upper", &jb, &a[j + j * a_dim1], lda, info);
if (*info != 0) {
goto L30;
}
if (j + jb <= *n) {
/* Compute the current block row. */
i__3 = *n - j - jb + 1;
i__4 = j - 1;
sgemm_("Transpose", "No transpose", &jb, &i__3, &i__4, &
c_b181, &a[j * a_dim1 + 1], lda, &a[(j + jb) *
a_dim1 + 1], lda, &c_b164, &a[j + (j + jb) *
a_dim1], lda);
i__3 = *n - j - jb + 1;
strsm_("Left", "Upper", "Transpose", "Non-unit", &jb, &
i__3, &c_b164, &a[j + j * a_dim1], lda, &a[j + (j
+ jb) * a_dim1], lda);
}
/* L10: */
}
} else {
/* Compute the Cholesky factorization A = L*L'. */
i__2 = *n;
i__1 = nb;
for (j = 1; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
/*
Update and factorize the current diagonal block and test
for non-positive-definiteness.
Computing MIN
*/
i__3 = nb, i__4 = *n - j + 1;
jb = min(i__3,i__4);
i__3 = j - 1;
ssyrk_("Lower", "No transpose", &jb, &i__3, &c_b181, &a[j +
a_dim1], lda, &c_b164, &a[j + j * a_dim1], lda);
spotf2_("Lower", &jb, &a[j + j * a_dim1], lda, info);
if (*info != 0) {
goto L30;
}
if (j + jb <= *n) {
/* Compute the current block column. */
i__3 = *n - j - jb + 1;
i__4 = j - 1;
sgemm_("No transpose", "Transpose", &i__3, &jb, &i__4, &
c_b181, &a[j + jb + a_dim1], lda, &a[j + a_dim1],
lda, &c_b164, &a[j + jb + j * a_dim1], lda);
i__3 = *n - j - jb + 1;
strsm_("Right", "Lower", "Transpose", "Non-unit", &i__3, &
jb, &c_b164, &a[j + j * a_dim1], lda, &a[j + jb +
j * a_dim1], lda);
}
/* L20: */
}
}
}
goto L40;
L30:
*info = *info + j - 1;
L40:
return 0;
/* End of SPOTRF */
} /* spotrf_ */
/* Subroutine */ int spotrs_(char *uplo, integer *n, integer *nrhs, real *a,
integer *lda, real *b, integer *ldb, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1;
/* Local variables */
extern logical lsame_(char *, char *);
static logical upper;
extern /* Subroutine */ int strsm_(char *, char *, char *, char *,
integer *, integer *, real *, real *, integer *, real *, integer *
), xerbla_(char *, integer *);
/*
-- 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
=======
SPOTRS solves a system of linear equations A*X = B with a symmetric
positive definite matrix A using the Cholesky factorization
A = U**T*U or A = L*L**T computed by SPOTRF.
Arguments
=========
UPLO (input) CHARACTER*1
= 'U': Upper triangle of A is stored;
= 'L': Lower triangle of A is stored.
N (input) INTEGER
The order of the matrix A. N >= 0.
NRHS (input) INTEGER
The number of right hand sides, i.e., the number of columns
of the matrix B. NRHS >= 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).
B (input/output) REAL array, dimension (LDB,NRHS)
On entry, the right hand side matrix B.
On exit, the solution matrix X.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
=====================================================================
Test the input parameters.
*/
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*nrhs < 0) {
*info = -3;
} else if (*lda < max(1,*n)) {
*info = -5;
} else if (*ldb < max(1,*n)) {
*info = -7;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SPOTRS", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0 || *nrhs == 0) {
return 0;
}
if (upper) {
/*
Solve A*X = B where A = U'*U.
Solve U'*X = B, overwriting B with X.
*/
strsm_("Left", "Upper", "Transpose", "Non-unit", n, nrhs, &c_b164, &a[
a_offset], lda, &b[b_offset], ldb);
/* Solve U*X = B, overwriting B with X. */
strsm_("Left", "Upper", "No transpose", "Non-unit", n, nrhs, &c_b164,
&a[a_offset], lda, &b[b_offset], ldb);
} else {
/*
Solve A*X = B where A = L*L'.
Solve L*X = B, overwriting B with X.
*/
strsm_("Left", "Lower", "No transpose", "Non-unit", n, nrhs, &c_b164,
&a[a_offset], lda, &b[b_offset], ldb);
/* Solve L'*X = B, overwriting B with X. */
strsm_("Left", "Lower", "Transpose", "Non-unit", n, nrhs, &c_b164, &a[
a_offset], lda, &b[b_offset], ldb);
}
return 0;
/* End of SPOTRS */
} /* spotrs_ */