本文整理汇总了C++中slabad_函数的典型用法代码示例。如果您正苦于以下问题：C++ slabad_函数的具体用法？C++ slabad_怎么用？C++ slabad_使用的例子？那么恭喜您, 这里精选的函数代码示例或许可以为您提供帮助。
在下文中一共展示了slabad_函数的15个代码示例，这些例子默认根据受欢迎程度排序。您可以为喜欢或者感觉有用的代码点赞，您的评价将有助于系统推荐出更棒的C++代码示例。
示例1: slamch_
//.........这里部分代码省略.........
/* generator. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Save statement .. */
/* .. */
/* .. Data statements .. */
/* .. */
/* .. Executable Statements .. */
/* Set some constants for use in the subroutine. */
if (first) {
first = FALSE_;
eps = slamch_("Precision");
badc2 = .1f / eps;
badc1 = sqrt(badc2);
small = slamch_("Safe minimum");
large = 1.f / small;
/* If it looks like we're on a Cray, take the square root of */
/* SMALL and LARGE to avoid overflow and underflow problems. */
slabad_(&small, &large);
small = small / eps * .25f;
large = 1.f / small;
}
s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
/* Set some parameters we don't plan to change. */
*(unsigned char *)dist = 'S';
*mode = 3;
/* xQR, xLQ, xQL, xRQ: Set parameters to generate a general */
/* M x N matrix. */
if (lsamen_(&c__2, c2, "QR") || lsamen_(&c__2, c2,
"LQ") || lsamen_(&c__2, c2, "QL") || lsamen_(&c__2, c2, "RQ")) {
/* Set TYPE, the type of matrix to be generated. */
*(unsigned char *)type__ = 'N';
/* Set the lower and upper bandwidths. */
if (*imat == 1) {
*kl = 0;
*ku = 0;
} else if (*imat == 2) {
*kl = 0;
/* Computing MAX */
i__1 = *n - 1;
*ku = max(i__1,0);
} else if (*imat == 3) {示例2: types
//.........这里部分代码省略.........
real r__1, r__2, r__3, r__4, r__5, r__6, r__7, r__8, r__9, r__10;
/* Builtin functions */
double r_sign(real *, real *);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
integer j, n, i1, n1, jc, nb, in, jr, ns, nbz;
real ulp;
integer iadd, nmax;
real temp1, temp2;
logical badnn;
real dumma[4];
integer iinfo;
real rmagn[4];
extern /* Subroutine */ int sgegs_(char *, char *, integer *, real *,
integer *, real *, integer *, real *, real *, real *, real *,
integer *, real *, integer *, real *, integer *, integer *), sget51_(integer *, integer *, real *, integer *,
real *, integer *, real *, integer *, real *, integer *, real *,
real *), sget52_(logical *, integer *, real *, integer *, real *,
integer *, real *, integer *, real *, real *, real *, real *,
real *), sgegv_(char *, char *, integer *, real *, integer *,
real *, integer *, real *, real *, real *, real *, integer *,
real *, integer *, real *, integer *, integer *),
sget53_(real *, integer *, real *, integer *, real *, real *,
real *, real *, integer *);
integer nmats, jsize, nerrs, jtype, ntest;
extern /* Subroutine */ int slatm4_(integer *, integer *, integer *,
integer *, integer *, real *, real *, real *, integer *, integer *
, real *, integer *);
logical ilabad;
extern /* Subroutine */ int sorm2r_(char *, char *, integer *, integer *,
integer *, real *, integer *, real *, real *, integer *, real *,
integer *), slabad_(real *, real *);
extern doublereal slamch_(char *);
real safmin;
integer ioldsd[4];
real safmax;
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
extern /* Subroutine */ int slarfg_(integer *, real *, real *, integer *,
real *);
extern doublereal slarnd_(integer *, integer *);
extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
*, integer *), xerbla_(char *, integer *),
slacpy_(char *, integer *, integer *, real *, integer *, real *,
integer *), slaset_(char *, integer *, integer *, real *,
real *, real *, integer *);
real ulpinv;
integer lwkopt, mtypes, ntestt;
/* Fortran I/O blocks */
static cilist io___42 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___43 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___47 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___48 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___49 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___51 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___52 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___53 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___54 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___55 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___56 = { 0, 0, 0, fmt_9993, 0 };
static cilist io___57 = { 0, 0, 0, fmt_9992, 0 };
static cilist io___58 = { 0, 0, 0, fmt_9991, 0 };
static cilist io___59 = { 0, 0, 0, fmt_9990, 0 };示例3: types
//.........这里部分代码省略.........
",\002, seed=\002,4(i4,\002,\002),\002 result \002,i2,\002 is\002"
",1p,e10.3)";
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, qe_dim1,
qe_offset, s_dim1, s_offset, t_dim1, t_offset, z_dim1, z_offset,
i__1, i__2, i__3, i__4, i__5, i__6, i__7;
real r__1, r__2;
complex q__1, q__2, q__3;
/* Builtin functions */
double r_sign(real *, real *), c_abs(complex *);
void r_cnjg(complex *, complex *);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
static integer iadd, ierr, nmax, i__, j, n;
static logical badnn;
extern /* Subroutine */ int cget52_(logical *, integer *, complex *,
integer *, complex *, integer *, complex *, integer *, complex *,
complex *, complex *, real *, real *), cggev_(char *, char *,
integer *, complex *, integer *, complex *, integer *, complex *,
complex *, complex *, integer *, complex *, integer *, complex *,
integer *, real *, integer *);
static real rmagn[4];
static complex ctemp;
static integer nmats, jsize, nerrs, jtype, n1;
extern /* Subroutine */ int clatm4_(integer *, integer *, integer *,
integer *, logical *, real *, real *, real *, integer *, integer *
, complex *, integer *), cunm2r_(char *, char *, integer *,
integer *, integer *, complex *, integer *, complex *, complex *,
integer *, complex *, integer *);
static integer jc, nb, in;
extern /* Subroutine */ int slabad_(real *, real *);
static integer jr;
extern /* Subroutine */ int clarfg_(integer *, complex *, complex *,
integer *, complex *);
extern /* Complex */ VOID clarnd_(complex *, integer *, integer *);
extern doublereal slamch_(char *);
extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
*, integer *, complex *, integer *), claset_(char *,
integer *, integer *, complex *, complex *, complex *, integer *);
static real safmin, safmax;
static integer ioldsd[4];
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
*, integer *), xerbla_(char *, integer *);
static integer minwrk, maxwrk;
static real ulpinv;
static integer mtypes, ntestt;
static real ulp;
/* Fortran I/O blocks */
static cilist io___40 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___42 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___43 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___44 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___45 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___46 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___47 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___48 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___49 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___50 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___51 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___52 = { 0, 0, 0, fmt_9993, 0 };示例4: form
//.........这里部分代码省略.........
be caused due to scaling.
=N+3: reordering failed in CTGSEN.
=====================================================================
Decode the input arguments
Parameter adjustments */
/* Table of constant values */
static complex c_b1 = {0.f,0.f};
static complex c_b2 = {1.f,0.f};
static integer c__1 = 1;
static integer c__0 = 0;
static integer c_n1 = -1;
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, vsl_dim1, vsl_offset,
vsr_dim1, vsr_offset, i__1, i__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
static integer ijob;
static real anrm, bnrm;
static integer ierr, itau, iwrk, i__;
extern logical lsame_(char *, char *);
static integer ileft, icols;
static logical cursl, ilvsl, ilvsr;
static integer irwrk, irows;
extern /* Subroutine */ int cggbak_(char *, char *, integer *, integer *,
integer *, real *, real *, integer *, complex *, integer *,
integer *), cggbal_(char *, integer *, complex *,
integer *, complex *, integer *, integer *, integer *, real *,
real *, real *, integer *), slabad_(real *, real *);
extern doublereal clange_(char *, integer *, integer *, complex *,
integer *, real *);
static real pl;
extern /* Subroutine */ int cgghrd_(char *, char *, integer *, integer *,
integer *, complex *, integer *, complex *, integer *, complex *,
integer *, complex *, integer *, integer *),
clascl_(char *, integer *, integer *, real *, real *, integer *,
integer *, complex *, integer *, integer *);
static real pr;
static logical ilascl, ilbscl;
extern /* Subroutine */ int cgeqrf_(integer *, integer *, complex *,
integer *, complex *, complex *, integer *, integer *), clacpy_(
char *, integer *, integer *, complex *, integer *, complex *,
integer *), claset_(char *, integer *, integer *, complex
*, complex *, complex *, integer *), xerbla_(char *,
integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
extern doublereal slamch_(char *);
static real bignum;
extern /* Subroutine */ int chgeqz_(char *, char *, char *, integer *,
integer *, integer *, complex *, integer *, complex *, integer *,
complex *, complex *, complex *, integer *, complex *, integer *,
complex *, integer *, real *, integer *),
ctgsen_(integer *, logical *, logical *, logical *, integer *,
complex *, integer *, complex *, integer *, complex *, complex *,
complex *, integer *, complex *, integer *, integer *, real *,
real *, real *, complex *, integer *, integer *, integer *,
integer *);
static integer ijobvl, iright, ijobvr;
static logical wantsb;
static integer liwmin;示例5: sqrt12_
//.........这里部分代码省略.........
/* Test that enough workspace is supplied */
/* Computing MAX */
i__1 = *m * *n + (min(*m,*n) << 2) + max(*m,*n), i__2 = *m * *n + (min(*m,
*n) << 1) + (*n << 2);
if (*lwork < max(i__1,i__2)) {
xerbla_("SQRT12", &c__7);
return ret_val;
}
/* Quick return if possible */
mn = min(*m,*n);
if ((real) mn <= 0.f) {
return ret_val;
}
nrmsvl = snrm2_(&mn, &s[1], &c__1);
/* Copy upper triangle of A into work */
slaset_("Full", m, n, &c_b6, &c_b6, &work[1], m);
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = min(j,*m);
for (i__ = 1; i__ <= i__2; ++i__) {
work[(j - 1) * *m + i__] = a[i__ + j * a_dim1];
/* L10: */
}
/* L20: */
}
/* Get machine parameters */
smlnum = slamch_("S") / slamch_("P");
bignum = 1.f / smlnum;
slabad_(&smlnum, &bignum);
/* Scale work if max entry outside range [SMLNUM,BIGNUM] */
anrm = slange_("M", m, n, &work[1], m, dummy);
iscl = 0;
if (anrm > 0.f && anrm < smlnum) {
/* Scale matrix norm up to SMLNUM */
slascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &work[1], m, &info);
iscl = 1;
} else if (anrm > bignum) {
/* Scale matrix norm down to BIGNUM */
slascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &work[1], m, &info);
iscl = 1;
}
if (anrm != 0.f) {
/* Compute SVD of work */
sgebd2_(m, n, &work[1], m, &work[*m * *n + 1], &work[*m * *n + mn + 1]
, &work[*m * *n + (mn << 1) + 1], &work[*m * *n + mn * 3 + 1],
&work[*m * *n + (mn << 2) + 1], &info);
sbdsqr_("Upper", &mn, &c__0, &c__0, &c__0, &work[*m * *n + 1], &work[*
m * *n + mn + 1], dummy, &mn, dummy, &c__1, dummy, &mn, &work[
*m * *n + (mn << 1) + 1], &info);
if (iscl == 1) {
if (anrm > bignum) {
slascl_("G", &c__0, &c__0, &bignum, &anrm, &mn, &c__1, &work[*
m * *n + 1], &mn, &info);
}
if (anrm < smlnum) {
slascl_("G", &c__0, &c__0, &smlnum, &anrm, &mn, &c__1, &work[*
m * *n + 1], &mn, &info);
}
}
} else {
i__1 = mn;
for (i__ = 1; i__ <= i__1; ++i__) {
work[*m * *n + i__] = 0.f;
/* L30: */
}
}
/* Compare s and singular values of work */
saxpy_(&mn, &c_b33, &s[1], &c__1, &work[*m * *n + 1], &c__1);
ret_val = sasum_(&mn, &work[*m * *n + 1], &c__1) / (slamch_("Epsilon") * (real) max(*m,*n));
if (nrmsvl != 0.f) {
ret_val /= nrmsvl;
}
return ret_val;
/* End of SQRT12 */
} /* sqrt12_ */示例6: test
/* Subroutine */ int cchkbd_(integer *nsizes, integer *mval, integer *nval,
integer *ntypes, logical *dotype, integer *nrhs, integer *iseed, real
*thresh, complex *a, integer *lda, real *bd, real *be, real *s1, real
*s2, complex *x, integer *ldx, complex *y, complex *z__, complex *q,
integer *ldq, complex *pt, integer *ldpt, complex *u, complex *vt,
complex *work, integer *lwork, real *rwork, integer *nout, integer *
info)
{
/* Initialized data */
static integer ktype[16] = { 1,2,4,4,4,4,4,6,6,6,6,6,9,9,9,10 };
static integer kmagn[16] = { 1,1,1,1,1,2,3,1,1,1,2,3,1,2,3,0 };
static integer kmode[16] = { 0,0,4,3,1,4,4,4,3,1,4,4,0,0,0,0 };
/* Format strings */
static char fmt_9998[] = "(\002 CCHKBD: \002,a,\002 returned INFO=\002,i"
"6,\002.\002,/9x,\002M=\002,i6,\002, N=\002,i6,\002, JTYPE=\002,i"
"6,\002, ISEED=(\002,3(i5,\002,\002),i5,\002)\002)";
static char fmt_9999[] = "(\002 M=\002,i5,\002, N=\002,i5,\002, type "
"\002,i2,\002, seed=\002,4(i4,\002,\002),\002 test(\002,i2,\002)"
"=\002,g11.4)";
/* System generated locals */
integer a_dim1, a_offset, pt_dim1, pt_offset, q_dim1, q_offset, u_dim1,
u_offset, vt_dim1, vt_offset, x_dim1, x_offset, y_dim1, y_offset,
z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7;
real r__1, r__2, r__3, r__4, r__5, r__6, r__7;
/* Builtin functions
Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
double log(doublereal), sqrt(doublereal), exp(doublereal);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
static real cond;
static integer jcol;
static char path[3];
static integer mmax, nmax;
static real unfl, ovfl;
static char uplo[1];
static real temp1, temp2;
static integer i__, j, m, n;
extern /* Subroutine */ int cbdt01_(integer *, integer *, integer *,
complex *, integer *, complex *, integer *, real *, real *,
complex *, integer *, complex *, real *, real *);
static logical badmm, badnn;
extern /* Subroutine */ int cbdt02_(integer *, integer *, complex *,
integer *, complex *, integer *, complex *, integer *, complex *,
real *, real *), cbdt03_(char *, integer *, integer *, real *,
real *, complex *, integer *, real *, complex *, integer *,
complex *, real *);
static integer nfail, imode;
extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
integer *, complex *, complex *, integer *, complex *, integer *,
complex *, complex *, integer *);
static real dumma[1];
static integer iinfo;
extern /* Subroutine */ int cunt01_(char *, integer *, integer *, complex
*, integer *, complex *, integer *, real *, real *);
static real anorm;
static integer mnmin, mnmax, jsize, itype, jtype, iwork[1], ntest;
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *), slahd2_(integer *, char *);
static integer log2ui;
static logical bidiag;
extern /* Subroutine */ int cgebrd_(integer *, integer *, complex *,
integer *, real *, real *, complex *, complex *, complex *,
integer *, integer *), slabad_(real *, real *);
static integer mq;
extern doublereal slamch_(char *);
extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
*, integer *, complex *, integer *), claset_(char *,
integer *, integer *, complex *, complex *, complex *, integer *), xerbla_(char *, integer *);
static integer ioldsd[4];
extern /* Subroutine */ int cbdsqr_(char *, integer *, integer *, integer
*, integer *, real *, real *, complex *, integer *, complex *,
integer *, complex *, integer *, real *, integer *),
cungbr_(char *, integer *, integer *, integer *, complex *,
integer *, complex *, complex *, integer *, integer *),
alasum_(char *, integer *, integer *, integer *, integer *);
extern doublereal slarnd_(integer *, integer *);
extern /* Subroutine */ int clatmr_(integer *, integer *, char *, integer
*, char *, complex *, integer *, real *, complex *, char *, char *
, complex *, integer *, real *, complex *, integer *, real *,
char *, integer *, integer *, integer *, real *, real *, char *,
complex *, integer *, integer *, integer *), clatms_(integer *, integer *,
char *, integer *, char *, real *, integer *, real *, real *,
integer *, integer *, char *, complex *, integer *, complex *,
integer *);
static real amninv;
extern /* Subroutine */ int ssvdch_(integer *, real *, real *, real *,
real *, integer *);
static integer minwrk;
static real rtunfl, rtovfl, ulpinv, result[14];
static integer mtypes;
static real ulp;
/* Fortran I/O blocks */
static cilist io___40 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___41 = { 0, 0, 0, fmt_9998, 0 };
//.........这里部分代码省略.........
示例7: lsame_
/* Subroutine */ int stbt03_(char *uplo, char *trans, char *diag, integer *n,
integer *kd, integer *nrhs, real *ab, integer *ldab, real *scale,
real *cnorm, real *tscal, real *x, integer *ldx, real *b, integer *
ldb, real *work, real *resid)
{
/* System generated locals */
integer ab_dim1, ab_offset, b_dim1, b_offset, x_dim1, x_offset, i__1;
real r__1, r__2, r__3;
/* Local variables */
static integer j;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
static real xscal;
extern /* Subroutine */ int stbmv_(char *, char *, char *, integer *,
integer *, real *, integer *, real *, integer *), scopy_(integer *, real *, integer *, real *, integer *);
static real tnorm, xnorm;
extern /* Subroutine */ int saxpy_(integer *, real *, real *, integer *,
real *, integer *), slabad_(real *, real *);
static integer ix;
extern doublereal slamch_(char *);
static real bignum;
extern integer isamax_(integer *, real *, integer *);
static real smlnum, eps, err;
#define b_ref(a_1,a_2) b[(a_2)*b_dim1 + a_1]
#define x_ref(a_1,a_2) x[(a_2)*x_dim1 + a_1]
#define ab_ref(a_1,a_2) ab[(a_2)*ab_dim1 + a_1]
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
February 29, 1992
Purpose
=======
STBT03 computes the residual for the solution to a scaled triangular
system of equations A*x = s*b or A'*x = s*b when A is a
triangular band matrix. Here A' is the transpose of A, s is a scalar,
and x and b are N by NRHS matrices. The test ratio is the maximum
over the number of right hand sides of
norm(s*b - op(A)*x) / ( norm(op(A)) * norm(x) * EPS ),
where op(A) denotes A or A' and EPS is the machine epsilon.
Arguments
=========
UPLO (input) CHARACTER*1
Specifies whether the matrix A is upper or lower triangular.
= 'U': Upper triangular
= 'L': Lower triangular
TRANS (input) CHARACTER*1
Specifies the operation applied to A.
= 'N': A *x = b (No transpose)
= 'T': A'*x = b (Transpose)
= 'C': A'*x = b (Conjugate transpose = Transpose)
DIAG (input) CHARACTER*1
Specifies whether or not the matrix A is unit triangular.
= 'N': Non-unit triangular
= 'U': Unit triangular
N (input) INTEGER
The order of the matrix A. N >= 0.
KD (input) INTEGER
The number of superdiagonals or subdiagonals of the
triangular band matrix A. KD >= 0.
NRHS (input) INTEGER
The number of right hand sides, i.e., the number of columns
of the matrices X and B. NRHS >= 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).
LDAB (input) INTEGER
The leading dimension of the array AB. LDAB >= KD+1.
SCALE (input) REAL
The scaling factor s used in solving the triangular system.
CNORM (input) REAL array, dimension (N)
The 1-norms of the columns of A, not counting the diagonal.
TSCAL (input) REAL
The scaling factor used in computing the 1-norms in CNORM.
CNORM actually contains the column norms of TSCAL*A.
X (input) REAL array, dimension (LDX,NRHS)
The computed solution vectors for the system of linear
//.........这里部分代码省略.........
示例8: sqrt
/* Subroutine */ int snaitr_(integer *ido, char *bmat, integer *n, integer *k,
integer *np, integer *nb, real *resid, real *rnorm, real *v, integer
*ldv, real *h__, integer *ldh, integer *ipntr, real *workd, integer *
info, ftnlen bmat_len)
{
/* Initialized data */
static logical first = TRUE_;
/* System generated locals */
integer h_dim1, h_offset, v_dim1, v_offset, i__1, i__2;
real r__1, r__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
static integer i__, j;
static real t0, t1, t2, t3, t4, t5;
static integer jj, ipj, irj, ivj;
static real ulp, tst1;
static integer ierr, iter;
static real unfl, ovfl;
extern doublereal sdot_(integer *, real *, integer *, real *, integer *);
static integer itry;
static real temp1;
static logical orth1, orth2, step3, step4;
extern doublereal snrm2_(integer *, real *, integer *);
static real betaj;
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
static integer infol;
extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *,
real *, integer *, real *, integer *, real *, real *, integer *,
ftnlen);
static real xtemp[2];
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *);
static real wnorm;
extern /* Subroutine */ int saxpy_(integer *, real *, real *, integer *,
real *, integer *), ivout_(integer *, integer *, integer *,
integer *, char *, ftnlen), smout_(integer *, integer *, integer *
, real *, integer *, integer *, char *, ftnlen), svout_(integer *,
integer *, real *, integer *, char *, ftnlen), sgetv0_(integer *,
char *, integer *, logical *, integer *, integer *, real *,
integer *, real *, real *, integer *, real *, integer *, ftnlen);
static real rnorm1;
extern /* Subroutine */ int slabad_(real *, real *);
extern doublereal slamch_(char *, ftnlen);
extern /* Subroutine */ int second_(real *), slascl_(char *, integer *,
integer *, real *, real *, integer *, integer *, real *, integer *
, integer *, ftnlen);
static logical rstart;
static integer msglvl;
static real smlnum;
extern doublereal slanhs_(char *, integer *, real *, integer *, real *,
ftnlen);
/* %----------------------------------------------------% */
/* | Include files for debugging and timing information | */
/* %----------------------------------------------------% */
/* \SCCS Information: @(#) */
/* FILE: debug.h SID: 2.3 DATE OF SID: 11/16/95 RELEASE: 2 */
/* %---------------------------------% */
/* | See debug.doc for documentation | */
/* %---------------------------------% */
/* %------------------% */
/* | Scalar Arguments | */
/* %------------------% */
/* %--------------------------------% */
/* | See stat.doc for documentation | */
/* %--------------------------------% */
/* \SCCS Information: @(#) */
/* FILE: stat.h SID: 2.2 DATE OF SID: 11/16/95 RELEASE: 2 */
/* %-----------------% */
/* | Array Arguments | */
/* %-----------------% */
/* %------------% */
/* | Parameters | */
/* %------------% */
/* %---------------% */
/* | Local Scalars | */
/* %---------------% */
/* %-----------------------% */
/* | Local Array Arguments | */
//.........这里部分代码省略.........
示例9: r_imag
/* Subroutine */ int clahqr_(logical *wantt, logical *wantz, integer *n,
integer *ilo, integer *ihi, complex *h__, integer *ldh, complex *w,
integer *iloz, integer *ihiz, complex *z__, integer *ldz, integer *
info)
{
/* System generated locals */
integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4;
real r__1, r__2, r__3, r__4, r__5, r__6;
complex q__1, q__2, q__3, q__4, q__5, q__6, q__7;
/* Builtin functions */
double r_imag(complex *);
void r_cnjg(complex *, complex *);
double c_abs(complex *);
void c_sqrt(complex *, complex *), pow_ci(complex *, complex *, integer *)
;
/* Local variables */
integer i__, j, k, l, m;
real s;
complex t, u, v[2], x, y;
integer i1, i2;
complex t1;
real t2;
complex v2;
real aa, ab, ba, bb, h10;
complex h11;
real h21;
complex h22, sc;
integer nh, nz;
real sx;
integer jhi;
complex h11s;
integer jlo, its;
real ulp;
complex sum;
real tst;
complex temp;
extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
integer *), ccopy_(integer *, complex *, integer *, complex *,
integer *);
real rtemp;
extern /* Subroutine */ int slabad_(real *, real *), clarfg_(integer *,
complex *, complex *, integer *, complex *);
extern /* Complex */ VOID cladiv_(complex *, complex *, complex *);
extern doublereal slamch_(char *);
real safmin, safmax, smlnum;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CLAHQR is an auxiliary routine called by CHSEQR to update the */
/* eigenvalues and Schur decomposition already computed by CHSEQR, by */
/* dealing with the Hessenberg submatrix in rows and columns ILO to */
/* IHI. */
/* Arguments */
/* ========= */
/* WANTT (input) LOGICAL */
/* = .TRUE. : the full Schur form T is required; */
/* = .FALSE.: only eigenvalues are required. */
/* WANTZ (input) LOGICAL */
/* = .TRUE. : the matrix of Schur vectors Z is required; */
/* = .FALSE.: Schur vectors are not required. */
/* N (input) INTEGER */
/* The order of the matrix H. N >= 0. */
/* ILO (input) INTEGER */
/* IHI (input) INTEGER */
/* It is assumed that H is already upper triangular in rows and */
/* columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless ILO = 1). */
/* CLAHQR works primarily with the Hessenberg submatrix in rows */
/* and columns ILO to IHI, but applies transformations to all of */
/* H if WANTT is .TRUE.. */
/* 1 <= ILO <= max(1,IHI); IHI <= N. */
/* H (input/output) COMPLEX array, dimension (LDH,N) */
/* On entry, the upper Hessenberg matrix H. */
/* On exit, if INFO is zero and if WANTT is .TRUE., then H */
/* is upper triangular in rows and columns ILO:IHI. If INFO */
/* is zero and if WANTT is .FALSE., then the contents of H */
/* are unspecified on exit. The output state of H in case */
/* INF is positive is below under the description of INFO. */
/* LDH (input) INTEGER */
/* The leading dimension of the array H. LDH >= max(1,N). */
//.........这里部分代码省略.........
示例10: r_imag
/* Subroutine */ int claqr2_(logical *wantt, logical *wantz, integer *n,
integer *ktop, integer *kbot, integer *nw, complex *h__, integer *ldh,
integer *iloz, integer *ihiz, complex *z__, integer *ldz, integer *
ns, integer *nd, complex *sh, complex *v, integer *ldv, integer *nh,
complex *t, integer *ldt, integer *nv, complex *wv, integer *ldwv,
complex *work, integer *lwork)
{
/* System generated locals */
integer h_dim1, h_offset, t_dim1, t_offset, v_dim1, v_offset, wv_dim1,
wv_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4;
real r__1, r__2, r__3, r__4, r__5, r__6;
complex q__1, q__2;
/* Builtin functions */
double r_imag(complex *);
void r_cnjg(complex *, complex *);
/* Local variables */
integer i__, j;
complex s;
integer jw;
real foo;
integer kln;
complex tau;
integer knt;
real ulp;
integer lwk1, lwk2;
complex beta;
integer kcol, info, ifst, ilst, ltop, krow;
extern /* Subroutine */ int clarf_(char *, integer *, integer *, complex *
, integer *, complex *, complex *, integer *, complex *),
cgemm_(char *, char *, integer *, integer *, integer *, complex *,
complex *, integer *, complex *, integer *, complex *, complex *,
integer *), ccopy_(integer *, complex *, integer
*, complex *, integer *);
integer infqr, kwtop;
extern /* Subroutine */ int slabad_(real *, real *), cgehrd_(integer *,
integer *, integer *, complex *, integer *, complex *, complex *,
integer *, integer *), clarfg_(integer *, complex *, complex *,
integer *, complex *);
extern doublereal slamch_(char *);
extern /* Subroutine */ int clahqr_(logical *, logical *, integer *,
integer *, integer *, complex *, integer *, complex *, integer *,
integer *, complex *, integer *, integer *), clacpy_(char *,
integer *, integer *, complex *, integer *, complex *, integer *), claset_(char *, integer *, integer *, complex *, complex
*, complex *, integer *);
real safmin, safmax;
extern /* Subroutine */ int ctrexc_(char *, integer *, complex *, integer
*, complex *, integer *, integer *, integer *, integer *),
cunmhr_(char *, char *, integer *, integer *, integer *, integer
*, complex *, integer *, complex *, complex *, integer *, complex
*, integer *, integer *);
real smlnum;
integer lwkopt;
/* -- LAPACK auxiliary routine (version 3.2.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. */
/* -- April 2009 -- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* This subroutine is identical to CLAQR3 except that it avoids */
/* recursion by calling CLAHQR instead of CLAQR4. */
/* ****************************************************************** */
/* Aggressive early deflation: */
/* This subroutine accepts as input an upper Hessenberg matrix */
/* H and performs an unitary similarity transformation */
/* designed to detect and deflate fully converged eigenvalues from */
/* a trailing principal submatrix. On output H has been over- */
/* written by a new Hessenberg matrix that is a perturbation of */
/* an unitary similarity transformation of H. It is to be */
/* hoped that the final version of H has many zero subdiagonal */
/* entries. */
/* ****************************************************************** */
/* WANTT (input) LOGICAL */
/* If .TRUE., then the Hessenberg matrix H is fully updated */
/* so that the triangular Schur factor may be */
/* computed (in cooperation with the calling subroutine). */
/* If .FALSE., then only enough of H is updated to preserve */
/* the eigenvalues. */
/* WANTZ (input) LOGICAL */
/* If .TRUE., then the unitary matrix Z is updated so */
/* so that the unitary Schur factor may be computed */
/* (in cooperation with the calling subroutine). */
/* If .FALSE., then Z is not referenced. */
/* N (input) INTEGER */
/* The order of the matrix H and (if WANTZ is .TRUE.) the */
/* order of the unitary matrix Z. */
/* KTOP (input) INTEGER */
//.........这里部分代码省略.........
示例11: inv
//.........这里部分代码省略.........
Parameter adjustments */
/* Table of constant values */
static complex c_b1 = {0.f,0.f};
static complex c_b2 = {1.f,0.f};
static integer c__1 = 1;
static integer c_n1 = -1;
static integer c__0 = 0;
static integer c__2 = 2;
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4;
real r__1, r__2;
complex q__1;
/* Builtin functions */
double c_abs(complex *);
/* Local variables */
static real anrm, bnrm, smin, smax;
static integer i__, j, iascl, ibscl;
extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
complex *, integer *);
static integer ismin, ismax;
static complex c1, c2;
extern /* Subroutine */ int ctrsm_(char *, char *, char *, char *,
integer *, integer *, complex *, complex *, integer *, complex *,
integer *), claic1_(integer *,
integer *, complex *, real *, complex *, complex *, real *,
complex *, complex *);
static real wsize;
static complex s1, s2;
extern /* Subroutine */ int cgeqp3_(integer *, integer *, complex *,
integer *, integer *, complex *, complex *, integer *, real *,
integer *);
static integer nb;
extern /* Subroutine */ int slabad_(real *, real *);
extern doublereal clange_(char *, integer *, integer *, complex *,
integer *, real *);
static integer mn;
extern /* Subroutine */ int clascl_(char *, integer *, integer *, real *,
real *, integer *, integer *, complex *, integer *, integer *);
extern doublereal slamch_(char *);
extern /* Subroutine */ int claset_(char *, integer *, integer *, complex
*, complex *, complex *, integer *), xerbla_(char *,
integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
static real bignum;
static integer nb1, nb2, nb3, nb4;
extern /* Subroutine */ int cunmqr_(char *, char *, integer *, integer *,
integer *, complex *, integer *, complex *, complex *, integer *,
complex *, integer *, integer *);
static real sminpr, smaxpr, smlnum;
extern /* Subroutine */ int cunmrz_(char *, char *, integer *, integer *,
integer *, integer *, complex *, integer *, complex *, complex *,
integer *, complex *, integer *, integer *);
static integer lwkopt;
static logical lquery;
extern /* Subroutine */ int ctzrzf_(integer *, integer *, complex *,
integer *, complex *, complex *, integer *, integer *);
#define a_subscr(a_1,a_2) (a_2)*a_dim1 + a_1
#define a_ref(a_1,a_2) a[a_subscr(a_1,a_2)]
#define b_subscr(a_1,a_2) (a_2)*b_dim1 + a_1
#define b_ref(a_1,a_2) b[b_subscr(a_1,a_2)]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;示例12: r_imag
/* Subroutine */ int ctrevc_(char *side, char *howmny, logical *select,
integer *n, complex *t, integer *ldt, complex *vl, integer *ldvl,
complex *vr, integer *ldvr, integer *mm, integer *m, complex *work,
real *rwork, integer *info)
{
/* System generated locals */
integer t_dim1, t_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1,
i__2, i__3, i__4, i__5;
real r__1, r__2, r__3;
complex q__1, q__2;
/* Builtin functions */
double r_imag(complex *);
void r_cnjg(complex *, complex *);
/* Local variables */
integer i__, j, k, ii, ki, is;
real ulp;
logical allv;
real unfl, ovfl, smin;
logical over;
real scale;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex *
, complex *, integer *, complex *, integer *, complex *, complex *
, integer *);
real remax;
extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
complex *, integer *);
logical leftv, bothv, somev;
extern /* Subroutine */ int slabad_(real *, real *);
extern integer icamax_(integer *, complex *, integer *);
extern doublereal slamch_(char *);
extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
*), xerbla_(char *, integer *), clatrs_(char *, char *,
char *, char *, integer *, complex *, integer *, complex *, real *
, real *, integer *);
extern doublereal scasum_(integer *, complex *, integer *);
logical rightv;
real smlnum;
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CTREVC computes some or all of the right and/or left eigenvectors of */
/* a complex upper triangular matrix T. */
/* Matrices of this type are produced by the Schur factorization of */
/* a complex general matrix: A = Q*T*Q**H, as computed by CHSEQR. */
/* The right eigenvector x and the left eigenvector y of T corresponding */
/* to an eigenvalue w are defined by: */
/* T*x = w*x, (y**H)*T = w*(y**H) */
/* where y**H denotes the conjugate transpose of the vector y. */
/* The eigenvalues are not input to this routine, but are read directly */
/* from the diagonal of T. */
/* This routine returns the matrices X and/or Y of right and left */
/* eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an */
/* input matrix. If Q is the unitary factor that reduces a matrix A to */
/* Schur form T, then Q*X and Q*Y are the matrices of right and left */
/* eigenvectors of A. */
/* Arguments */
/* ========= */
/* SIDE (input) CHARACTER*1 */
/* = 'R': compute right eigenvectors only; */
/* = 'L': compute left eigenvectors only; */
/* = 'B': compute both right and left eigenvectors. */
/* HOWMNY (input) CHARACTER*1 */
/* = 'A': compute all right and/or left eigenvectors; */
/* = 'B': compute all right and/or left eigenvectors, */
/* backtransformed using the matrices supplied in */
/* VR and/or VL; */
/* = 'S': compute selected right and/or left eigenvectors, */
/* as indicated by the logical array SELECT. */
/* SELECT (input) LOGICAL array, dimension (N) */
/* If HOWMNY = 'S', SELECT specifies the eigenvectors to be */
/* computed. */
/* The eigenvector corresponding to the j-th eigenvalue is */
/* computed if SELECT(j) = .TRUE.. */
/* Not referenced if HOWMNY = 'A' or 'B'. */
/* N (input) INTEGER */
/* The order of the matrix T. N >= 0. */
//.........这里部分代码省略.........
示例13: slabad_
/* Subroutine */ int stbt06_(real *rcond, real *rcondc, char *uplo, char *
diag, integer *n, integer *kd, real *ab, integer *ldab, real *work,
real *rat)
{
/* System generated locals */
integer ab_dim1, ab_offset;
real r__1, r__2;
/* Local variables */
static real rmin, rmax, anorm;
extern /* Subroutine */ int slabad_(real *, real *);
extern doublereal slamch_(char *);
static real bignum;
extern doublereal slantb_(char *, char *, char *, integer *, integer *,
real *, integer *, real *);
static real smlnum, eps;
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
February 29, 1992
Purpose
=======
STBT06 computes a test ratio comparing RCOND (the reciprocal
condition number of a triangular matrix A) and RCONDC, the estimate
computed by STBCON. Information about the triangular matrix A is
used if one estimate is zero and the other is non-zero to decide if
underflow in the estimate is justified.
Arguments
=========
RCOND (input) REAL
The estimate of the reciprocal condition number obtained by
forming the explicit inverse of the matrix A and computing
RCOND = 1/( norm(A) * norm(inv(A)) ).
RCONDC (input) REAL
The estimate of the reciprocal condition number computed by
STBCON.
UPLO (input) CHARACTER
Specifies whether the matrix A is upper or lower triangular.
= 'U': Upper triangular
= 'L': Lower triangular
DIAG (input) CHARACTER
Specifies whether or not the matrix A is unit triangular.
= 'N': Non-unit triangular
= 'U': Unit triangular
N (input) INTEGER
The order of the matrix A. N >= 0.
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).
LDAB (input) INTEGER
The leading dimension of the array AB. LDAB >= KD+1.
WORK (workspace) REAL array, dimension (N)
RAT (output) REAL
The test ratio. If both RCOND and RCONDC are nonzero,
RAT = MAX( RCOND, RCONDC )/MIN( RCOND, RCONDC ) - 1.
If RAT = 0, the two estimates are exactly the same.
=====================================================================
Parameter adjustments */
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1 * 1;
ab -= ab_offset;
--work;
/* Function Body */
eps = slamch_("Epsilon");
rmax = dmax(*rcond,*rcondc);
rmin = dmin(*rcond,*rcondc);
/* Do the easy cases first. */
if (rmin < 0.f) {
/* Invalid value for RCOND or RCONDC, return 1/EPS. */
*rat = 1.f / eps;
//.........这里部分代码省略.........
示例14: sger_
/* Subroutine */ int sgetc2_(integer *n, real *a, integer *lda, integer *ipiv,
integer *jpiv, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
real r__1;
/* Local variables */
static integer i__, j, ip, jp;
static real eps;
static integer ipv, jpv;
extern /* Subroutine */ int sger_(integer *, integer *, real *, real *,
integer *, real *, integer *, real *, integer *);
static real smin, xmax;
extern /* Subroutine */ int sswap_(integer *, real *, integer *, real *,
integer *), slabad_(real *, real *);
extern doublereal slamch_(char *, ftnlen);
static real bignum, smlnum;
/* -- 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 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SGETC2 computes an LU factorization with complete pivoting of the */
/* n-by-n matrix A. The factorization has the form A = P * L * U * Q, */
/* where P and Q are permutation matrices, L is lower triangular with */
/* unit diagonal elements and U is upper triangular. */
/* This is the Level 2 BLAS algorithm. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input/output) REAL array, dimension (LDA, N) */
/* On entry, the n-by-n matrix A to be factored. */
/* On exit, the factors L and U from the factorization */
/* A = P*L*U*Q; the unit diagonal elements of L are not stored. */
/* If U(k, k) appears to be less than SMIN, U(k, k) is given the */
/* value of SMIN, i.e., giving a nonsingular perturbed system. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* IPIV (output) INTEGER array, dimension(N). */
/* The pivot indices; for 1 <= i <= N, row i of the */
/* matrix has been interchanged with row IPIV(i). */
/* JPIV (output) INTEGER array, dimension(N). */
/* The pivot indices; for 1 <= j <= N, column j of the */
/* matrix has been interchanged with column JPIV(j). */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* > 0: if INFO = k, U(k, k) is likely to produce owerflow if */
/* we try to solve for x in Ax = b. So U is perturbed to */
/* avoid the overflow. */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */
/* Umea University, S-901 87 Umea, Sweden. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Set constants to control overflow */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--ipiv;
--jpiv;
//.........这里部分代码省略.........
示例15: cgelsd_
/* Subroutine */
int cgelsd_(integer *m, integer *n, integer *nrhs, complex * a, integer *lda, complex *b, integer *ldb, real *s, real *rcond, integer *rank, complex *work, integer *lwork, real *rwork, integer * iwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4;
/* Builtin functions */
double log(doublereal);
/* Local variables */
integer ie, il, mm;
real eps, anrm, bnrm;
integer itau, nlvl, iascl, ibscl;
real sfmin;
integer minmn, maxmn, itaup, itauq, mnthr, nwork;
extern /* Subroutine */
int cgebrd_(integer *, integer *, complex *, integer *, real *, real *, complex *, complex *, complex *, integer *, integer *), slabad_(real *, real *);
extern real clange_(char *, integer *, integer *, complex *, integer *, real *);
extern /* Subroutine */
int cgelqf_(integer *, integer *, complex *, integer *, complex *, complex *, integer *, integer *), clalsd_( char *, integer *, integer *, integer *, real *, real *, complex * , integer *, real *, integer *, complex *, real *, integer *, integer *), clascl_(char *, integer *, integer *, real *, real *, integer *, integer *, complex *, integer *, integer *), cgeqrf_(integer *, integer *, complex *, integer *, complex *, complex *, integer *, integer *);
extern real slamch_(char *);
extern /* Subroutine */
int clacpy_(char *, integer *, integer *, complex *, integer *, complex *, integer *), claset_(char *, integer *, integer *, complex *, complex *, complex *, integer *), xerbla_(char *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *);
real bignum;
extern /* Subroutine */
int slascl_(char *, integer *, integer *, real *, real *, integer *, integer *, real *, integer *, integer *), cunmbr_(char *, char *, char *, integer *, integer *, integer *, complex *, integer *, complex *, complex *, integer *, complex *, integer *, integer *), slaset_( char *, integer *, integer *, real *, real *, real *, integer *), cunmlq_(char *, char *, integer *, integer *, integer *, complex *, integer *, complex *, complex *, integer *, complex *, integer *, integer *);
integer ldwork;
extern /* Subroutine */
int cunmqr_(char *, char *, integer *, integer *, integer *, complex *, integer *, complex *, complex *, integer *, complex *, integer *, integer *);
integer liwork, minwrk, maxwrk;
real smlnum;
integer lrwork;
logical lquery;
integer nrwork, smlsiz;
/* -- LAPACK driver 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 .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--s;
--work;
--rwork;
--iwork;
/* Function Body */
*info = 0;
minmn = min(*m,*n);
maxmn = max(*m,*n);
lquery = *lwork == -1;
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.) */
if (*info == 0)
{
minwrk = 1;
maxwrk = 1;
//.........这里部分代码省略.........