本文整理汇总了C++中csscal_函数的典型用法代码示例。如果您正苦于以下问题：C++ csscal_函数的具体用法？C++ csscal_怎么用？C++ csscal_使用的例子？那么恭喜您, 这里精选的函数代码示例或许可以为您提供帮助。
在下文中一共展示了csscal_函数的15个代码示例，这些例子默认根据受欢迎程度排序。您可以为喜欢或者感觉有用的代码点赞，您的评价将有助于系统推荐出更棒的C++代码示例。
示例1: f2c_csscal
int
f2c_csscal(integer* N,
real* alpha,
complex* X, integer* incX)
{
csscal_(N, alpha, X, incX);
return 0;
}示例2: lsame_
//.........这里部分代码省略.........
if ((r__1 = e[ll], dabs(r__1)) <= thresh) {
e[ll] = 0.f;
}
/* Update singular vectors if desired */
if (*ncvt > 0) {
i__1 = m - ll + 1;
clasr_("L", "V", "B", &i__1, ncvt, &rwork[nm12 + 1], &rwork[
nm13 + 1], &vt[ll + vt_dim1], ldvt);
}
if (*nru > 0) {
i__1 = m - ll + 1;
clasr_("R", "V", "B", nru, &i__1, &rwork[1], &rwork[*n], &u[
ll * u_dim1 + 1], ldu);
}
if (*ncc > 0) {
i__1 = m - ll + 1;
clasr_("L", "V", "B", &i__1, ncc, &rwork[1], &rwork[*n], &c__[
ll + c_dim1], ldc);
}
}
}
/* QR iteration finished, go back and check convergence */
goto L60;
/* All singular values converged, so make them positive */
L160:
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (d__[i__] < 0.f) {
d__[i__] = -d__[i__];
/* Change sign of singular vectors, if desired */
if (*ncvt > 0) {
csscal_(ncvt, &c_b72, &vt[i__ + vt_dim1], ldvt);
}
}
}
/* Sort the singular values into decreasing order (insertion sort on */
/* singular values, but only one transposition per singular vector) */
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Scan for smallest D(I) */
isub = 1;
smin = d__[1];
i__2 = *n + 1 - i__;
for (j = 2; j <= i__2; ++j) {
if (d__[j] <= smin) {
isub = j;
smin = d__[j];
}
}
if (isub != *n + 1 - i__) {
/* Swap singular values and vectors */
d__[isub] = d__[*n + 1 - i__];
d__[*n + 1 - i__] = smin;
if (*ncvt > 0) {
cswap_(ncvt, &vt[isub + vt_dim1], ldvt, &vt[*n + 1 - i__ +
vt_dim1], ldvt);
}
if (*nru > 0) {
cswap_(nru, &u[isub * u_dim1 + 1], &c__1, &u[(*n + 1 - i__) *
u_dim1 + 1], &c__1);
}
if (*ncc > 0) {
cswap_(ncc, &c__[isub + c_dim1], ldc, &c__[*n + 1 - i__ +
c_dim1], ldc);
}
}
}
goto L220;
/* Maximum number of iterations exceeded, failure to converge */
L200:
*info = 0;
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
if (e[i__] != 0.f) {
++(*info);
}
}
L220:
return 0;
/* End of CBDSQR */
} /* cbdsqr_ */示例3: cgeev_
int cgeev_(char *jobvl, char *jobvr, int *n, complex *a,
int *lda, complex *w, complex *vl, int *ldvl, complex *vr,
int *ldvr, complex *work, int *lwork, float *rwork, int *
info)
{
/* System generated locals */
int a_dim1, a_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1,
i__2, i__3;
float r__1, r__2;
complex q__1, q__2;
/* Builtin functions */
double sqrt(double), r_imag(complex *);
void r_cnjg(complex *, complex *);
/* Local variables */
int i__, k, ihi;
float scl;
int ilo;
float dum[1], eps;
complex tmp;
int ibal;
char side[1];
float anrm;
int ierr, itau, iwrk, nout;
extern int cscal_(int *, complex *, complex *,
int *);
extern int lsame_(char *, char *);
extern double scnrm2_(int *, complex *, int *);
extern int cgebak_(char *, char *, int *, int *,
int *, float *, int *, complex *, int *, int *), cgebal_(char *, int *, complex *, int *,
int *, int *, float *, int *), slabad_(float *,
float *);
int scalea;
extern double clange_(char *, int *, int *, complex *,
int *, float *);
float cscale;
extern int cgehrd_(int *, int *, int *,
complex *, int *, complex *, complex *, int *, int *),
clascl_(char *, int *, int *, float *, float *, int *,
int *, complex *, int *, int *);
extern double slamch_(char *);
extern int csscal_(int *, float *, complex *, int
*), clacpy_(char *, int *, int *, complex *, int *,
complex *, int *), xerbla_(char *, int *);
extern int ilaenv_(int *, char *, char *, int *, int *,
int *, int *);
int select[1];
float bignum;
extern int isamax_(int *, float *, int *);
extern int chseqr_(char *, char *, int *, int *,
int *, complex *, int *, complex *, complex *, int *,
complex *, int *, int *), ctrevc_(char *,
char *, int *, int *, complex *, int *, complex *,
int *, complex *, int *, int *, int *, complex *,
float *, int *), cunghr_(int *, int *,
int *, complex *, int *, complex *, complex *, int *,
int *);
int minwrk, maxwrk;
int wantvl;
float smlnum;
int hswork, irwork;
int lquery, wantvr;
/* -- LAPACK driver routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CGEEV computes for an N-by-N complex nonsymmetric matrix A, the */
/* eigenvalues and, optionally, the left and/or right eigenvectors. */
/* The right eigenvector v(j) of A satisfies */
/* A * v(j) = lambda(j) * v(j) */
/* where lambda(j) is its eigenvalue. */
/* The left eigenvector u(j) of A satisfies */
/* u(j)**H * A = lambda(j) * u(j)**H */
/* where u(j)**H denotes the conjugate transpose of u(j). */
/* The computed eigenvectors are normalized to have Euclidean norm */
/* equal to 1 and largest component float. */
/* Arguments */
/* ========= */
/* JOBVL (input) CHARACTER*1 */
/* = 'N': left eigenvectors of A are not computed; */
/* = 'V': left eigenvectors of are computed. */
/* JOBVR (input) CHARACTER*1 */
/* = 'N': right eigenvectors of A are not computed; */
/* = 'V': right eigenvectors of A are computed. */
//.........这里部分代码省略.........
示例4: sqrt
//.........这里部分代码省略.........
/* Get machine constants. */
safmin = slamch_("Safe minimum");
eps = slamch_("Precision");
smlnum = safmin / eps;
bignum = 1.f / smlnum;
rmin = sqrt(smlnum);
/* Computing MIN */
r__1 = sqrt(bignum), r__2 = 1.f / sqrt(sqrt(safmin));
rmax = dmin(r__1,r__2);
/* Scale matrix to allowable range, if necessary. */
iscale = 0;
abstll = *abstol;
if (valeig) {
vll = *vl;
vuu = *vu;
}
anrm = clansy_("M", uplo, n, &a[a_offset], lda, &rwork[1]);
if (anrm > 0.f && anrm < rmin) {
iscale = 1;
sigma = rmin / anrm;
} else if (anrm > rmax) {
iscale = 1;
sigma = rmax / anrm;
}
if (iscale == 1) {
if (lower) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n - j + 1;
csscal_(&i__2, &sigma, &a[j + j * a_dim1], &c__1);
/* L10: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
csscal_(&j, &sigma, &a[j * a_dim1 + 1], &c__1);
/* L20: */
}
}
if (*abstol > 0.f) {
abstll = *abstol * sigma;
}
if (valeig) {
vll = *vl * sigma;
vuu = *vu * sigma;
}
}
/* Initialize indices into workspaces. Note: The IWORK indices are */
/* used only if SSTERF or CSTEMR fail. */
/* WORK(INDTAU:INDTAU+N-1) stores the complex scalar factors of the */
/* elementary reflectors used in CHETRD. */
indtau = 1;
/* INDWK is the starting offset of the remaining complex workspace, */
/* and LLWORK is the remaining complex workspace size. */
indwk = indtau + *n;
llwork = *lwork - indwk + 1;
/* RWORK(INDRD:INDRD+N-1) stores the real tridiagonal's diagonal */
/* entries. */
indrd = 1;
/* RWORK(INDRE:INDRE+N-1) stores the off-diagonal entries of the */
/* tridiagonal matrix from CHETRD. */
indre = indrd + *n;示例5: cspfa_
/* DECK CSPCO */
/* Subroutine */ int cspco_(complex *ap, integer *n, integer *kpvt, real *
rcond, complex *z__)
{
/* System generated locals */
integer i__1, i__2, i__3, i__4, i__5;
real r__1, r__2, r__3, r__4, r__5, r__6, r__7, r__8;
complex q__1, q__2, q__3;
/* Local variables */
static integer i__, j, k;
static real s;
static complex t;
static integer j1;
static complex ak, bk, ek;
static integer ij, ik, kk, kp, ks, jm1, kps;
static complex akm1, bkm1;
static integer ikm1, km1k, ikp1, info;
extern /* Subroutine */ int cspfa_(complex *, integer *, integer *,
integer *);
static integer km1km1;
static complex denom;
static real anorm;
extern /* Complex */ void cdotu_(complex *, integer *, complex *, integer
*, complex *, integer *);
extern /* Subroutine */ int caxpy_(integer *, complex *, complex *,
integer *, complex *, integer *);
static real ynorm;
extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
*);
extern doublereal scasum_(integer *, complex *, integer *);
/* ***BEGIN PROLOGUE CSPCO */
/* ***PURPOSE Factor a complex symmetric matrix stored in packed form */
/* by elimination with symmetric pivoting and estimate the */
/* condition number of the matrix. */
/* ***LIBRARY SLATEC (LINPACK) */
/* ***CATEGORY D2C1 */
/* ***TYPE COMPLEX (SSPCO-S, DSPCO-D, CHPCO-C, CSPCO-C) */
/* ***KEYWORDS CONDITION NUMBER, LINEAR ALGEBRA, LINPACK, */
/* MATRIX FACTORIZATION, PACKED, SYMMETRIC */
/* ***AUTHOR Moler, C. B., (U. of New Mexico) */
/* ***DESCRIPTION */
/* CSPCO factors a complex symmetric matrix stored in packed */
/* form by elimination with symmetric pivoting and estimates */
/* the condition of the matrix. */
/* If RCOND is not needed, CSPFA is slightly faster. */
/* To solve A*X = B , follow CSPCO by CSPSL. */
/* To compute INVERSE(A)*C , follow CSPCO by CSPSL. */
/* To compute INVERSE(A) , follow CSPCO by CSPDI. */
/* To compute DETERMINANT(A) , follow CSPCO by CSPDI. */
/* On Entry */
/* AP COMPLEX (N*(N+1)/2) */
/* the packed form of a symmetric matrix A . The */
/* columns of the upper triangle are stored sequentially */
/* in a one-dimensional array of length N*(N+1)/2 . */
/* See comments below for details. */
/* N INTEGER */
/* the order of the matrix A . */
/* On Return */
/* AP a block diagonal matrix and the multipliers which */
/* were used to obtain it stored in packed form. */
/* The factorization can be written A = U*D*TRANS(U) */
/* where U is a product of permutation and unit */
/* upper triangular matrices , TRANS(U) is the */
/* transpose of U , and D is block diagonal */
/* with 1 by 1 and 2 by 2 blocks. */
/* KVPT INTEGER(N) */
/* an integer vector of pivot indices. */
/* RCOND REAL */
/* an estimate of the reciprocal condition of A . */
/* For the system A*X = B , relative perturbations */
/* in A and B of size EPSILON may cause */
/* relative perturbations in X of size EPSILON/RCOND . */
/* If RCOND is so small that the logical expression */
/* 1.0 + RCOND .EQ. 1.0 */
/* is true, then A may be singular to working */
/* precision. In particular, RCOND is zero if */
/* exact singularity is detected or the estimate */
/* underflows. */
/* Z COMPLEX(N) */
/* a work vector whose contents are usually unimportant. */
/* If A is close to a singular matrix, then Z is */
/* an approximate null vector in the sense that */
/* NORM(A*Z) = RCOND*NORM(A)*NORM(Z) . */
/* Packed Storage */
/* The following program segment will pack the upper */
/* triangle of a symmetric matrix. */
//.........这里部分代码省略.........
示例6: lsame_
/* Subroutine */ int cggbak_(char *job, char *side, integer *n, integer *ilo,
integer *ihi, real *lscale, real *rscale, integer *m, complex *v,
integer *ldv, integer *info)
{
/* System generated locals */
integer v_dim1, v_offset, i__1;
/* Local variables */
integer i__, k;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int cswap_(integer *, complex *, integer *,
complex *, integer *);
logical leftv;
extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
*), xerbla_(char *, integer *);
logical rightv;
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CGGBAK forms the right or left eigenvectors of a complex generalized */
/* eigenvalue problem A*x = lambda*B*x, by backward transformation on */
/* the computed eigenvectors of the balanced pair of matrices output by */
/* CGGBAL. */
/* Arguments */
/* ========= */
/* JOB (input) CHARACTER*1 */
/* Specifies the type of backward transformation required: */
/* = 'N': do nothing, return immediately; */
/* = 'P': do backward transformation for permutation only; */
/* = 'S': do backward transformation for scaling only; */
/* = 'B': do backward transformations for both permutation and */
/* scaling. */
/* JOB must be the same as the argument JOB supplied to CGGBAL. */
/* SIDE (input) CHARACTER*1 */
/* = 'R': V contains right eigenvectors; */
/* = 'L': V contains left eigenvectors. */
/* N (input) INTEGER */
/* The number of rows of the matrix V. N >= 0. */
/* ILO (input) INTEGER */
/* IHI (input) INTEGER */
/* The integers ILO and IHI determined by CGGBAL. */
/* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. */
/* LSCALE (input) REAL array, dimension (N) */
/* Details of the permutations and/or scaling factors applied */
/* to the left side of A and B, as returned by CGGBAL. */
/* RSCALE (input) REAL array, dimension (N) */
/* Details of the permutations and/or scaling factors applied */
/* to the right side of A and B, as returned by CGGBAL. */
/* M (input) INTEGER */
/* The number of columns of the matrix V. M >= 0. */
/* V (input/output) COMPLEX array, dimension (LDV,M) */
/* On entry, the matrix of right or left eigenvectors to be */
/* transformed, as returned by CTGEVC. */
/* On exit, V is overwritten by the transformed eigenvectors. */
/* LDV (input) INTEGER */
/* The leading dimension of the matrix V. LDV >= max(1,N). */
/* INFO (output) INTEGER */
/* = 0: successful exit. */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* Further Details */
/* =============== */
/* See R.C. Ward, Balancing the generalized eigenvalue problem, */
/* SIAM J. Sci. Stat. Comp. 2 (1981), 141-152. */
/* ===================================================================== */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
//.........这里部分代码省略.........
示例7: cggbal_
int cggbal_(char *job, int *n, complex *a, int *lda,
complex *b, int *ldb, int *ilo, int *ihi, float *lscale,
float *rscale, float *work, int *info)
{
/* System generated locals */
int a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4;
float r__1, r__2, r__3;
/* Builtin functions */
double r_lg10(float *), r_imag(complex *), c_abs(complex *), r_sign(float *,
float *), pow_ri(float *, int *);
/* Local variables */
int i__, j, k, l, m;
float t;
int jc;
float ta, tb, tc;
int ir;
float ew;
int it, nr, ip1, jp1, lm1;
float cab, rab, ewc, cor, sum;
int nrp2, icab, lcab;
float beta, coef;
int irab, lrab;
float basl, cmax;
extern double sdot_(int *, float *, int *, float *, int *);
float coef2, coef5, gamma, alpha;
extern int lsame_(char *, char *);
extern int sscal_(int *, float *, float *, int *);
float sfmin;
extern int cswap_(int *, complex *, int *,
complex *, int *);
float sfmax;
int iflow, kount;
extern int saxpy_(int *, float *, float *, int *,
float *, int *);
float pgamma;
extern int icamax_(int *, complex *, int *);
extern double slamch_(char *);
extern int csscal_(int *, float *, complex *, int
*), xerbla_(char *, int *);
int lsfmin, lsfmax;
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CGGBAL balances a pair of general complex matrices (A,B). This */
/* involves, first, permuting A and B by similarity transformations to */
/* isolate eigenvalues in the first 1 to ILO$-$1 and last IHI+1 to N */
/* elements on the diagonal; and second, applying a diagonal similarity */
/* transformation to rows and columns ILO to IHI to make the rows */
/* and columns as close in norm as possible. Both steps are optional. */
/* Balancing may reduce the 1-norm of the matrices, and improve the */
/* accuracy of the computed eigenvalues and/or eigenvectors in the */
/* generalized eigenvalue problem A*x = lambda*B*x. */
/* Arguments */
/* ========= */
/* JOB (input) CHARACTER*1 */
/* Specifies the operations to be performed on A and B: */
/* = 'N': none: simply set ILO = 1, IHI = N, LSCALE(I) = 1.0 */
/* and RSCALE(I) = 1.0 for i=1,...,N; */
/* = 'P': permute only; */
/* = 'S': scale only; */
/* = 'B': both permute and scale. */
/* N (input) INTEGER */
/* The order of the matrices A and B. N >= 0. */
/* A (input/output) COMPLEX array, dimension (LDA,N) */
/* On entry, the input matrix A. */
/* On exit, A is overwritten by the balanced matrix. */
/* If JOB = 'N', A is not referenced. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= MAX(1,N). */
/* B (input/output) COMPLEX array, dimension (LDB,N) */
/* On entry, the input matrix B. */
/* On exit, B is overwritten by the balanced matrix. */
/* If JOB = 'N', B is not referenced. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= MAX(1,N). */
/* ILO (output) INTEGER */
/* IHI (output) INTEGER */
/* ILO and IHI are set to ints such that on exit */
//.........这里部分代码省略.........
示例8: r_imag
/* Subroutine */ int chseqr_(char *job, char *compz, integer *n, integer *ilo,
integer *ihi, complex *h__, integer *ldh, complex *w, complex *z__,
integer *ldz, complex *work, integer *lwork, integer *info)
{
/* System generated locals */
address a__1[2];
integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4[2],
i__5, i__6;
real r__1, r__2, r__3, r__4;
complex q__1;
char ch__1[2];
/* Builtin functions */
double r_imag(complex *);
void r_cnjg(complex *, complex *);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
/* Local variables */
static integer maxb, ierr;
static real unfl;
static complex temp;
static real ovfl, opst;
static integer i__, j, k, l;
static complex s[225] /* was [15][15] */;
extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
integer *);
static complex v[16];
extern logical lsame_(char *, char *);
extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex *
, complex *, integer *, complex *, integer *, complex *, complex *
, integer *), ccopy_(integer *, complex *, integer *,
complex *, integer *);
static integer itemp;
static real rtemp;
static integer i1, i2;
static logical initz, wantt, wantz;
static real rwork[1];
extern doublereal slapy2_(real *, real *);
static integer ii, nh;
extern /* Subroutine */ int slabad_(real *, real *), clarfg_(integer *,
complex *, complex *, integer *, complex *);
static integer nr, ns;
extern integer icamax_(integer *, complex *, integer *);
static integer nv;
extern doublereal slamch_(char *), clanhs_(char *, integer *,
complex *, integer *, real *);
extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
*), clahqr_(logical *, logical *, integer *, integer *, integer *,
complex *, integer *, complex *, integer *, integer *, complex *,
integer *, integer *), clacpy_(char *, integer *, integer *,
complex *, integer *, complex *, integer *);
static complex vv[16];
extern /* Subroutine */ int claset_(char *, integer *, integer *, complex
*, complex *, complex *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
extern /* Subroutine */ int clarfx_(char *, integer *, integer *, complex
*, complex *, complex *, integer *, complex *), xerbla_(
char *, integer *);
static real smlnum;
static logical lquery;
static integer itn;
static complex tau;
static integer its;
static real ulp, tst1;
#define h___subscr(a_1,a_2) (a_2)*h_dim1 + a_1
#define h___ref(a_1,a_2) h__[h___subscr(a_1,a_2)]
#define s_subscr(a_1,a_2) (a_2)*15 + a_1 - 16
#define s_ref(a_1,a_2) s[s_subscr(a_1,a_2)]
#define z___subscr(a_1,a_2) (a_2)*z_dim1 + a_1
#define z___ref(a_1,a_2) z__[z___subscr(a_1,a_2)]
/* -- LAPACK routine (instrumented to count operations, version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
Common block to return operation count.
Purpose
=======
CHSEQR computes the eigenvalues of a complex upper Hessenberg
matrix H, and, optionally, the matrices T and Z from the Schur
decomposition H = Z T Z**H, where T is an upper triangular matrix
(the Schur form), and Z is the unitary matrix of Schur vectors.
Optionally Z may be postmultiplied into an input unitary matrix Q,
so that this routine can give the Schur factorization of a matrix A
which has been reduced to the Hessenberg form H by the unitary
matrix Q: A = Q*H*Q**H = (QZ)*T*(QZ)**H.
Arguments
=========
JOB (input) CHARACTER*1
= 'E': compute eigenvalues only;
//.........这里部分代码省略.........
示例9: c_abs
/* Subroutine */ int ctbt03_(char *uplo, char *trans, char *diag, integer *n,
integer *kd, integer *nrhs, complex *ab, integer *ldab, real *scale,
real *cnorm, real *tscal, complex *x, integer *ldx, complex *b,
integer *ldb, complex *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;
complex q__1;
/* Builtin functions */
double c_abs(complex *);
/* Local variables */
static integer j;
extern logical lsame_(char *, char *);
static real xscal;
extern /* Subroutine */ int ctbmv_(char *, char *, char *, integer *,
integer *, complex *, integer *, complex *, integer *), ccopy_(integer *, complex *, integer *, complex *
, integer *), caxpy_(integer *, complex *, complex *, integer *,
complex *, integer *);
static real tnorm, xnorm;
static integer ix;
extern integer icamax_(integer *, complex *, integer *);
extern doublereal slamch_(char *);
extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
*);
static real smlnum, eps, err;
#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)]
#define x_subscr(a_1,a_2) (a_2)*x_dim1 + a_1
#define x_ref(a_1,a_2) x[x_subscr(a_1,a_2)]
#define ab_subscr(a_1,a_2) (a_2)*ab_dim1 + a_1
#define ab_ref(a_1,a_2) ab[ab_subscr(a_1,a_2)]
/* -- 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
=======
CTBT03 computes the residual for the solution to a scaled triangular
system of equations A*x = s*b, A**T *x = s*b, or A**H *x = s*b
when A is a triangular band matrix. Here A**T denotes the transpose
of A, A**H denotes the conjugate 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, A**T, or A**H, and EPS is the machine epsilon.
Arguments
=========
UPLO (input) CHARACTER*1
Specifies whether the matrix A is upper or lower triangular.
= 'U': Upper triangular
= 'L': Lower triangular
TRANS (input) CHARACTER*1
Specifies the operation applied to A.
= 'N': A *x = s*b (No transpose)
= 'T': A**T *x = s*b (Transpose)
= 'C': A**H *x = s*b (Conjugate 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) COMPLEX 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)
//.........这里部分代码省略.........
示例10: clarfgp_
/* Subroutine */
int clarfgp_(integer *n, complex *alpha, complex *x, integer *incx, complex *tau)
{
/* System generated locals */
integer i__1, i__2;
real r__1, r__2;
complex q__1, q__2;
/* Builtin functions */
double r_imag(complex *), r_sign(real *, real *), c_abs(complex *);
/* Local variables */
integer j;
complex savealpha;
integer knt;
real beta;
extern /* Subroutine */
int cscal_(integer *, complex *, complex *, integer *);
real alphi, alphr, xnorm;
extern real scnrm2_(integer *, complex *, integer *), slapy2_(real *, real *), slapy3_(real *, real *, real *);
extern /* Complex */
VOID cladiv_(complex *, complex *, complex *);
extern real slamch_(char *);
extern /* Subroutine */
int csscal_(integer *, real *, complex *, integer *);
real bignum, smlnum;
/* -- LAPACK auxiliary routine (version 3.4.2) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* September 2012 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--x;
/* Function Body */
if (*n <= 0)
{
tau->r = 0.f, tau->i = 0.f;
return 0;
}
i__1 = *n - 1;
xnorm = scnrm2_(&i__1, &x[1], incx);
alphr = alpha->r;
alphi = r_imag(alpha);
if (xnorm == 0.f)
{
/* H = [1-alpha/f2c_abs(alpha) 0;
0 I], sign chosen so ALPHA >= 0. */
if (alphi == 0.f)
{
if (alphr >= 0.f)
{
/* When TAU.eq.ZERO, the vector is special-cased to be */
/* all zeros in the application routines. We do not need */
/* to clear it. */
tau->r = 0.f, tau->i = 0.f;
}
else
{
/* However, the application routines rely on explicit */
/* zero checks when TAU.ne.ZERO, and we must clear X. */
tau->r = 2.f, tau->i = 0.f;
i__1 = *n - 1;
for (j = 1;
j <= i__1;
++j)
{
i__2 = (j - 1) * *incx + 1;
x[i__2].r = 0.f;
x[i__2].i = 0.f; // , expr subst
}
q__1.r = -alpha->r;
q__1.i = -alpha->i; // , expr subst
alpha->r = q__1.r, alpha->i = q__1.i;
}
}
else
{
/* Only "reflecting" the diagonal entry to be real and non-negative. */
xnorm = slapy2_(&alphr, &alphi);
r__1 = 1.f - alphr / xnorm;
r__2 = -alphi / xnorm;
q__1.r = r__1;
q__1.i = r__2; // , expr subst
tau->r = q__1.r, tau->i = q__1.i;
i__1 = *n - 1;
for (j = 1;
j <= i__1;
//.........这里部分代码省略.........
示例11: op
//.........这里部分代码省略.........
Decode and Test input parameters
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
i__3, i__4;
real r__1, r__2;
complex q__1, q__2, q__3, q__4;
/* Builtin functions */
double r_imag(complex *);
void r_cnjg(complex *, complex *);
/* Local variables */
static real smin;
static complex suml, sumr;
static integer j, k, l;
extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer
*, complex *, integer *);
extern logical lsame_(char *, char *);
extern /* Complex */ VOID cdotu_(complex *, integer *, complex *, integer
*, complex *, integer *);
static complex a11;
static real db;
extern /* Subroutine */ int slabad_(real *, real *);
extern doublereal clange_(char *, integer *, integer *, complex *,
integer *, real *);
static complex x11;
extern /* Complex */ VOID cladiv_(complex *, complex *, complex *);
static real scaloc;
extern doublereal slamch_(char *);
extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
*), xerbla_(char *, integer *);
static real bignum;
static logical notrna, notrnb;
static real smlnum, da11;
static complex vec;
static real dum[1], eps, sgn;
#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)]
#define c___subscr(a_1,a_2) (a_2)*c_dim1 + a_1
#define c___ref(a_1,a_2) c__[c___subscr(a_1,a_2)]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
c_dim1 = *ldc;
c_offset = 1 + c_dim1 * 1;
c__ -= c_offset;
/* Function Body */
notrna = lsame_(trana, "N");
notrnb = lsame_(tranb, "N");
*info = 0;
if (! notrna && ! lsame_(trana, "T") && ! lsame_(
trana, "C")) {
*info = -1;示例12: UPLO
/* Subroutine */ int chetrs_(char *uplo, integer *n, integer *nrhs, complex *
a, integer *lda, integer *ipiv, complex *b, integer *ldb, 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
=======
CHETRS solves a system of linear equations A*X = B with a complex
Hermitian matrix A using the factorization A = U*D*U**H or
A = L*D*L**H computed by CHETRF.
Arguments
=========
UPLO (input) CHARACTER*1
Specifies whether the details of the factorization are stored
as an upper or lower triangular matrix.
= 'U': Upper triangular, form is A = U*D*U**H;
= 'L': Lower triangular, form is A = L*D*L**H.
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) COMPLEX array, dimension (LDA,N)
The block diagonal matrix D and the multipliers used to
obtain the factor U or L as computed by CHETRF.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
IPIV (input) INTEGER array, dimension (N)
Details of the interchanges and the block structure of D
as determined by CHETRF.
B (input/output) COMPLEX 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
=====================================================================
Parameter adjustments */
/* Table of constant values */
static complex c_b1 = {1.f,0.f};
static integer c__1 = 1;
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
complex q__1, q__2, q__3;
/* Builtin functions */
void c_div(complex *, complex *, complex *), r_cnjg(complex *, complex *);
/* Local variables */
static complex akm1k;
static integer j, k;
static real s;
extern logical lsame_(char *, char *);
static complex denom;
extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex *
, complex *, integer *, complex *, integer *, complex *, complex *
, integer *), cgeru_(integer *, integer *, complex *,
complex *, integer *, complex *, integer *, complex *, integer *),
cswap_(integer *, complex *, integer *, complex *, integer *);
static logical upper;
static complex ak, bk;
static integer kp;
extern /* Subroutine */ int clacgv_(integer *, complex *, integer *),
csscal_(integer *, real *, complex *, integer *), xerbla_(char *,
integer *);
static complex akm1, bkm1;
#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;
a -= a_offset;
--ipiv;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
//.........这里部分代码省略.........
示例13: claein_
int claein_(int *rightv, int *noinit, int *n,
complex *h__, int *ldh, complex *w, complex *v, complex *b,
int *ldb, float *rwork, float *eps3, float *smlnum, int *info)
{
/* System generated locals */
int b_dim1, b_offset, h_dim1, h_offset, i__1, i__2, i__3, i__4, i__5;
float r__1, r__2, r__3, r__4;
complex q__1, q__2;
/* Builtin functions */
double sqrt(double), r_imag(complex *);
/* Local variables */
int i__, j;
complex x, ei, ej;
int its, ierr;
complex temp;
float scale;
char trans[1];
float rtemp, rootn, vnorm;
extern double scnrm2_(int *, complex *, int *);
extern int icamax_(int *, complex *, int *);
extern /* Complex */ VOID cladiv_(complex *, complex *, complex *);
extern int csscal_(int *, float *, complex *, int
*), clatrs_(char *, char *, char *, char *, int *, complex *,
int *, complex *, float *, float *, int *);
extern double scasum_(int *, complex *, int *);
char normin[1];
float nrmsml, growto;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CLAEIN uses inverse iteration to find a right or left eigenvector */
/* corresponding to the eigenvalue W of a complex upper Hessenberg */
/* matrix H. */
/* Arguments */
/* ========= */
/* RIGHTV (input) LOGICAL */
/* = .TRUE. : compute right eigenvector; */
/* = .FALSE.: compute left eigenvector. */
/* NOINIT (input) LOGICAL */
/* = .TRUE. : no initial vector supplied in V */
/* = .FALSE.: initial vector supplied in V. */
/* N (input) INTEGER */
/* The order of the matrix H. N >= 0. */
/* H (input) COMPLEX array, dimension (LDH,N) */
/* The upper Hessenberg matrix H. */
/* LDH (input) INTEGER */
/* The leading dimension of the array H. LDH >= MAX(1,N). */
/* W (input) COMPLEX */
/* The eigenvalue of H whose corresponding right or left */
/* eigenvector is to be computed. */
/* V (input/output) COMPLEX array, dimension (N) */
/* On entry, if NOINIT = .FALSE., V must contain a starting */
/* vector for inverse iteration; otherwise V need not be set. */
/* On exit, V contains the computed eigenvector, normalized so */
/* that the component of largest magnitude has magnitude 1; here */
/* the magnitude of a complex number (x,y) is taken to be */
/* |x| + |y|. */
/* B (workspace) COMPLEX array, dimension (LDB,N) */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= MAX(1,N). */
/* RWORK (workspace) REAL array, dimension (N) */
/* EPS3 (input) REAL */
/* A small machine-dependent value which is used to perturb */
/* close eigenvalues, and to replace zero pivots. */
/* SMLNUM (input) REAL */
/* A machine-dependent value close to the underflow threshold. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* = 1: inverse iteration did not converge; V is set to the */
/* last iterate. */
/* ===================================================================== */
//.........这里部分代码省略.........
示例14: cpbtf2_
/* Subroutine */
int cpbtf2_(char *uplo, integer *n, integer *kd, complex *ab, integer *ldab, integer *info)
{
/* System generated locals */
integer ab_dim1, ab_offset, i__1, i__2, i__3;
real r__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer j, kn;
real ajj;
integer kld;
extern /* Subroutine */
int cher_(char *, integer *, real *, complex *, integer *, complex *, integer *);
extern logical lsame_(char *, char *);
logical upper;
extern /* Subroutine */
int clacgv_(integer *, complex *, integer *), csscal_(integer *, real *, complex *, integer *), xerbla_(char *, integer *);
/* -- LAPACK computational routine (version 3.4.2) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* September 2012 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1;
ab -= ab_offset;
/* 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;
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("CPBTF2", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0)
{
return 0;
}
/* Computing MAX */
i__1 = 1;
i__2 = *ldab - 1; // , expr subst
kld = max(i__1,i__2);
if (upper)
{
/* Compute the Cholesky factorization A = U**H * U. */
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
/* Compute U(J,J) and test for non-positive-definiteness. */
i__2 = *kd + 1 + j * ab_dim1;
ajj = ab[i__2].r;
if (ajj <= 0.f)
{
i__2 = *kd + 1 + j * ab_dim1;
ab[i__2].r = ajj;
ab[i__2].i = 0.f; // , expr subst
goto L30;
}
ajj = sqrt(ajj);
i__2 = *kd + 1 + j * ab_dim1;
ab[i__2].r = ajj;
ab[i__2].i = 0.f; // , expr subst
/* Compute elements J+1:J+KN of row J and update the */
//.........这里部分代码省略.........
示例15: slamch_
//.........这里部分代码省略.........
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick exit if N = 0 */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--cnorm;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--work;
/* Function Body */
if (*n <= 0 || *nrhs <= 0) {
*resid = 0.f;
return 0;
}
eps = slamch_("Epsilon");
smlnum = slamch_("Safe minimum");
/* Compute the norm of the triangular matrix A using the column */
/* norms already computed by CLATRS. */
tnorm = 0.f;
if (lsame_(diag, "N")) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
r__1 = tnorm, r__2 = *tscal * c_abs(&a[j + j * a_dim1]) + cnorm[j]
;
tnorm = dmax(r__1,r__2);
/* L10: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
r__1 = tnorm, r__2 = *tscal + cnorm[j];
tnorm = dmax(r__1,r__2);
/* L20: */
}
}
/* Compute the maximum over the number of right hand sides of */
/* norm(op(A)*x - s*b) / ( norm(op(A)) * norm(x) * EPS ). */
*resid = 0.f;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
ccopy_(n, &x[j * x_dim1 + 1], &c__1, &work[1], &c__1);
ix = icamax_(n, &work[1], &c__1);
/* Computing MAX */
r__1 = 1.f, r__2 = c_abs(&x[ix + j * x_dim1]);
xnorm = dmax(r__1,r__2);
xscal = 1.f / xnorm / (real) (*n);
csscal_(n, &xscal, &work[1], &c__1);
ctrmv_(uplo, trans, diag, n, &a[a_offset], lda, &work[1], &c__1);
r__1 = -(*scale) * xscal;
q__1.r = r__1, q__1.i = 0.f;
caxpy_(n, &q__1, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
ix = icamax_(n, &work[1], &c__1);
err = *tscal * c_abs(&work[ix]);
ix = icamax_(n, &x[j * x_dim1 + 1], &c__1);
xnorm = c_abs(&x[ix + j * x_dim1]);
if (err * smlnum <= xnorm) {
if (xnorm > 0.f) {
err /= xnorm;
}
} else {
if (err > 0.f) {
err = 1.f / eps;
}
}
if (err * smlnum <= tnorm) {
if (tnorm > 0.f) {
err /= tnorm;
}
} else {
if (err > 0.f) {
err = 1.f / eps;
}
}
*resid = dmax(*resid,err);
/* L30: */
}
return 0;
/* End of CTRT03 */
} /* ctrt03_ */