/* Subroutine */ int dgbsvx_(char *fact, char *trans, integer *n, integer *kl,
integer *ku, integer *nrhs, doublereal *ab, integer *ldab,
doublereal *afb, integer *ldafb, integer *ipiv, char *equed,
doublereal *r__, doublereal *c__, doublereal *b, integer *ldb,
doublereal *x, integer *ldx, doublereal *rcond, doublereal *ferr,
doublereal *berr, doublereal *work, integer *iwork, integer *info)
{
/* System generated locals */
integer ab_dim1, ab_offset, afb_dim1, afb_offset, b_dim1, b_offset,
x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5;
doublereal d__1, d__2, d__3;
/* Local variables */
integer i__, j, j1, j2;
doublereal amax;
char norm[1];
doublereal rcmin, rcmax, anorm;
logical equil;
doublereal colcnd;
logical nofact;
doublereal bignum;
integer infequ;
logical colequ;
doublereal rowcnd;
logical notran;
doublereal smlnum;
logical rowequ;
doublereal rpvgrw;
/* -- LAPACK driver routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* DGBSVX uses the LU factorization to compute the solution to a real */
/* system of linear equations A * X = B, A**T * X = B, or A**H * X = B, */
/* where A is a band matrix of order N with KL subdiagonals and KU */
/* superdiagonals, and X and B are N-by-NRHS matrices. */
/* Error bounds on the solution and a condition estimate are also */
/* provided. */
/* Description */
/* =========== */
/* The following steps are performed by this subroutine: */
/* 1. If FACT = 'E', real scaling factors are computed to equilibrate */
/* the system: */
/* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B */
/* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B */
/* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B */
/* Whether or not the system will be equilibrated depends on the */
/* scaling of the matrix A, but if equilibration is used, A is */
/* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N') */
/* or diag(C)*B (if TRANS = 'T' or 'C'). */
/* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor the */
/* matrix A (after equilibration if FACT = 'E') as */
/* A = L * U, */
/* where L is a product of permutation and unit lower triangular */
/* matrices with KL subdiagonals, and U is upper triangular with */
/* KL+KU superdiagonals. */
/* 3. If some U(i,i)=0, so that U is exactly singular, then the routine */
/* returns with INFO = i. Otherwise, the factored form of A is used */
/* to estimate the condition number of the matrix A. If the */
/* reciprocal of the condition number is less than machine precision, */
/* INFO = N+1 is returned as a warning, but the routine still goes on */
/* to solve for X and compute error bounds as described below. */
/* 4. The system of equations is solved for X using the factored form */
/* of A. */
/* 5. Iterative refinement is applied to improve the computed solution */
/* matrix and calculate error bounds and backward error estimates */
/* for it. */
/* 6. If equilibration was used, the matrix X is premultiplied by */
/* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so */
/* that it solves the original system before equilibration. */
/* Arguments */
/* ========= */
/* FACT (input) CHARACTER*1 */
/* Specifies whether or not the factored form of the matrix A is */
/* supplied on entry, and if not, whether the matrix A should be */
/* equilibrated before it is factored. */
/* = 'F': On entry, AFB and IPIV contain the factored form of */
/* A. If EQUED is not 'N', the matrix A has been */
/* equilibrated with scaling factors given by R and C. */
/* AB, AFB, and IPIV are not modified. */
/* = 'N': The matrix A will be copied to AFB and factored. */
/* = 'E': The matrix A will be equilibrated if necessary, then */
/* copied to AFB and factored. */
/* TRANS (input) CHARACTER*1 */
/* Specifies the form of the system of equations. */
/* = 'N': A * X = B (No transpose) */
/* = 'T': A**T * X = B (Transpose) */
/* = 'C': A**H * X = B (Transpose) */
/* N (input) INTEGER */
/* The number of linear equations, i.e., the order of the */
/* matrix A. N >= 0. */
/* KL (input) INTEGER */
/* The number of subdiagonals within the band of A. KL >= 0. */
/* KU (input) INTEGER */
/* The number of superdiagonals within the band of A. KU >= 0. */
/* NRHS (input) INTEGER */
/* The number of right hand sides, i.e., the number of columns */
/* of the matrices B and X. NRHS >= 0. */
/* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N) */
/* On entry, the matrix A in band storage, in rows 1 to KL+KU+1. */
/* The j-th column of A is stored in the j-th column of the */
/* array AB as follows: */
/* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl) */
/* If FACT = 'F' and EQUED is not 'N', then A must have been */
/* equilibrated by the scaling factors in R and/or C. AB is not */
/* modified if FACT = 'F' or 'N', or if FACT = 'E' and */
/* EQUED = 'N' on exit. */
/* On exit, if EQUED .ne. 'N', A is scaled as follows: */
/* EQUED = 'R': A := diag(R) * A */
/* EQUED = 'C': A := A * diag(C) */
/* EQUED = 'B': A := diag(R) * A * diag(C). */
/* LDAB (input) INTEGER */
/* The leading dimension of the array AB. LDAB >= KL+KU+1. */
/* AFB (input or output) DOUBLE PRECISION array, dimension (LDAFB,N) */
/* If FACT = 'F', then AFB is an input argument and on entry */
/* contains details of the LU factorization of the band matrix */
/* A, as computed by DGBTRF. U is stored as an upper triangular */
/* band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, */
/* and the multipliers used during the factorization are stored */
/* in rows KL+KU+2 to 2*KL+KU+1. If EQUED .ne. 'N', then AFB is */
/* the factored form of the equilibrated matrix A. */
/* If FACT = 'N', then AFB is an output argument and on exit */
/* returns details of the LU factorization of A. */
/* If FACT = 'E', then AFB is an output argument and on exit */
/* returns details of the LU factorization of the equilibrated */
/* matrix A (see the description of AB for the form of the */
/* equilibrated matrix). */
/* LDAFB (input) INTEGER */
/* The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1. */
/* IPIV (input or output) INTEGER array, dimension (N) */
/* If FACT = 'F', then IPIV is an input argument and on entry */
/* contains the pivot indices from the factorization A = L*U */
/* as computed by DGBTRF; row i of the matrix was interchanged */
/* with row IPIV(i). */
/* If FACT = 'N', then IPIV is an output argument and on exit */
/* contains the pivot indices from the factorization A = L*U */
/* of the original matrix A. */
/* If FACT = 'E', then IPIV is an output argument and on exit */
/* contains the pivot indices from the factorization A = L*U */
/* of the equilibrated matrix A. */
/* EQUED (input or output) CHARACTER*1 */
/* Specifies the form of equilibration that was done. */
/* = 'N': No equilibration (always true if FACT = 'N'). */
/* = 'R': Row equilibration, i.e., A has been premultiplied by */
/* diag(R). */
/* = 'C': Column equilibration, i.e., A has been postmultiplied */
/* by diag(C). */
/* = 'B': Both row and column equilibration, i.e., A has been */
/* replaced by diag(R) * A * diag(C). */
/* EQUED is an input argument if FACT = 'F'; otherwise, it is an */
/* output argument. */
/* R (input or output) DOUBLE PRECISION array, dimension (N) */
/* The row scale factors for A. If EQUED = 'R' or 'B', A is */
/* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R */
/* is not accessed. R is an input argument if FACT = 'F'; */
/* otherwise, R is an output argument. If FACT = 'F' and */
/* EQUED = 'R' or 'B', each element of R must be positive. */
/* C (input or output) DOUBLE PRECISION array, dimension (N) */
/* The column scale factors for A. If EQUED = 'C' or 'B', A is */
/* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C */
/* is not accessed. C is an input argument if FACT = 'F'; */
/* otherwise, C is an output argument. If FACT = 'F' and */
/* EQUED = 'C' or 'B', each element of C must be positive. */
/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
/* On entry, the right hand side matrix B. */
/* On exit, */
/* if EQUED = 'N', B is not modified; */
/* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by */
/* diag(R)*B; */
/* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is */
/* overwritten by diag(C)*B. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS) */
/* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X */
/* to the original system of equations. Note that A and B are */
/* modified on exit if EQUED .ne. 'N', and the solution to the */
/* equilibrated system is inv(diag(C))*X if TRANS = 'N' and */
/* EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or 'C' */
/* and EQUED = 'R' or 'B'. */
/* LDX (input) INTEGER */
/* The leading dimension of the array X. LDX >= max(1,N). */
/* RCOND (output) DOUBLE PRECISION */
/* The estimate of the reciprocal condition number of the matrix */
/* A after equilibration (if done). If RCOND is less than the */
/* machine precision (in particular, if RCOND = 0), the matrix */
/* is singular to working precision. This condition is */
/* indicated by a return code of INFO > 0. */
/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */
/* The estimated forward error bound for each solution vector */
/* X(j) (the j-th column of the solution matrix X). */
/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
/* is an estimated upper bound for the magnitude of the largest */
/* element in (X(j) - XTRUE) divided by the magnitude of the */
/* largest element in X(j). The estimate is as reliable as */
/* the estimate for RCOND, and is almost always a slight */
/* overestimate of the true error. */
/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */
/* The componentwise relative backward error of each solution */
/* vector X(j) (i.e., the smallest relative change in */
/* any element of A or B that makes X(j) an exact solution). */
/* WORK (workspace/output) DOUBLE PRECISION array, dimension (3*N) */
/* On exit, WORK(1) contains the reciprocal pivot growth */
/* factor norm(A)/norm(U). The "max absolute element" norm is */
/* used. If WORK(1) is much less than 1, then the stability */
/* of the LU factorization of the (equilibrated) matrix A */
/* could be poor. This also means that the solution X, condition */
/* estimator RCOND, and forward error bound FERR could be */
/* unreliable. If factorization fails with 0<INFO<=N, then */
/* WORK(1) contains the reciprocal pivot growth factor for the */
/* leading INFO columns of A. */
/* IWORK (workspace) INTEGER array, dimension (N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, and i is */
/* <= N: U(i,i) is exactly zero. The factorization */
/* has been completed, but the factor U is exactly */
/* singular, so the solution and error bounds */
/* could not be computed. RCOND = 0 is returned. */
/* = N+1: U is nonsingular, but RCOND is less than machine */
/* precision, meaning that the matrix is singular */
/* to working precision. Nevertheless, the */
/* solution and error bounds are computed because */
/* there are a number of situations where the */
/* computed solution can be more accurate than the */
/* value of RCOND would suggest. */
/* ===================================================================== */
/* Parameter adjustments */
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1;
ab -= ab_offset;
afb_dim1 = *ldafb;
afb_offset = 1 + afb_dim1;
afb -= afb_offset;
--ipiv;
--r__;
--c__;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
--ferr;
--berr;
--work;
--iwork;
/* Function Body */
*info = 0;
nofact = lsame_(fact, "N");
equil = lsame_(fact, "E");
notran = lsame_(trans, "N");
if (nofact || equil) {
*(unsigned char *)equed = 'N';
rowequ = FALSE_;
colequ = FALSE_;
} else {
rowequ = lsame_(equed, "R") || lsame_(equed,
"B");
colequ = lsame_(equed, "C") || lsame_(equed,
"B");
smlnum = dlamch_("Safe minimum");
bignum = 1. / smlnum;
}
/* Test the input parameters. */
if (! nofact && ! equil && ! lsame_(fact, "F")) {
*info = -1;
} else if (! notran && ! lsame_(trans, "T") && !
lsame_(trans, "C")) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*kl < 0) {
*info = -4;
} else if (*ku < 0) {
*info = -5;
} else if (*nrhs < 0) {
*info = -6;
} else if (*ldab < *kl + *ku + 1) {
*info = -8;
} else if (*ldafb < (*kl << 1) + *ku + 1) {
*info = -10;
} else if (lsame_(fact, "F") && ! (rowequ || colequ
|| lsame_(equed, "N"))) {
*info = -12;
} else {
if (rowequ) {
rcmin = bignum;
rcmax = 0.;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
d__1 = rcmin, d__2 = r__[j];
rcmin = min(d__1,d__2);
/* Computing MAX */
d__1 = rcmax, d__2 = r__[j];
rcmax = max(d__1,d__2);
}
if (rcmin <= 0.) {
*info = -13;
} else if (*n > 0) {
rowcnd = max(rcmin,smlnum) / min(rcmax,bignum);
} else {
rowcnd = 1.;
}
}
if (colequ && *info == 0) {
rcmin = bignum;
rcmax = 0.;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
d__1 = rcmin, d__2 = c__[j];
rcmin = min(d__1,d__2);
/* Computing MAX */
d__1 = rcmax, d__2 = c__[j];
rcmax = max(d__1,d__2);
}
if (rcmin <= 0.) {
*info = -14;
} else if (*n > 0) {
colcnd = max(rcmin,smlnum) / min(rcmax,bignum);
} else {
colcnd = 1.;
}
}
if (*info == 0) {
if (*ldb < max(1,*n)) {
*info = -16;
} else if (*ldx < max(1,*n)) {
*info = -18;
}
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DGBSVX", &i__1);
return 0;
}
if (equil) {
/* Compute row and column scalings to equilibrate the matrix A. */
dgbequ_(n, n, kl, ku, &ab[ab_offset], ldab, &r__[1], &c__[1], &rowcnd,
&colcnd, &amax, &infequ);
if (infequ == 0) {
/* Equilibrate the matrix. */
dlaqgb_(n, n, kl, ku, &ab[ab_offset], ldab, &r__[1], &c__[1], &
rowcnd, &colcnd, &amax, equed);
rowequ = lsame_(equed, "R") || lsame_(equed,
"B");
colequ = lsame_(equed, "C") || lsame_(equed,
"B");
}
}
/* Scale the right hand side. */
if (notran) {
if (rowequ) {
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
b[i__ + j * b_dim1] = r__[i__] * b[i__ + j * b_dim1];
}
}
}
} else if (colequ) {
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
b[i__ + j * b_dim1] = c__[i__] * b[i__ + j * b_dim1];
}
}
}
if (nofact || equil) {
/* Compute the LU factorization of the band matrix A. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = j - *ku;
j1 = max(i__2,1);
/* Computing MIN */
i__2 = j + *kl;
j2 = min(i__2,*n);
i__2 = j2 - j1 + 1;
dcopy_(&i__2, &ab[*ku + 1 - j + j1 + j * ab_dim1], &c__1, &afb[*
kl + *ku + 1 - j + j1 + j * afb_dim1], &c__1);
}
dgbtrf_(n, n, kl, ku, &afb[afb_offset], ldafb, &ipiv[1], info);
/* Return if INFO is non-zero. */
if (*info > 0) {
/* Compute the reciprocal pivot growth factor of the */
/* leading rank-deficient INFO columns of A. */
anorm = 0.;
i__1 = *info;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = *ku + 2 - j;
/* Computing MIN */
i__4 = *n + *ku + 1 - j, i__5 = *kl + *ku + 1;
i__3 = min(i__4,i__5);
for (i__ = max(i__2,1); i__ <= i__3; ++i__) {
/* Computing MAX */
d__2 = anorm, d__3 = (d__1 = ab[i__ + j * ab_dim1], abs(
d__1));
anorm = max(d__2,d__3);
}
}
/* Computing MIN */
i__3 = *info - 1, i__2 = *kl + *ku;
i__1 = min(i__3,i__2);
/* Computing MAX */
i__4 = 1, i__5 = *kl + *ku + 2 - *info;
rpvgrw = dlantb_("M", "U", "N", info, &i__1, &afb[max(i__4, i__5)
+ afb_dim1], ldafb, &work[1]);
if (rpvgrw == 0.) {
rpvgrw = 1.;
} else {
rpvgrw = anorm / rpvgrw;
}
work[1] = rpvgrw;
*rcond = 0.;
return 0;
}
}
/* Compute the norm of the matrix A and the */
/* reciprocal pivot growth factor RPVGRW. */
if (notran) {
*(unsigned char *)norm = '1';
} else {
*(unsigned char *)norm = 'I';
}
anorm = dlangb_(norm, n, kl, ku, &ab[ab_offset], ldab, &work[1]);
i__1 = *kl + *ku;
rpvgrw = dlantb_("M", "U", "N", n, &i__1, &afb[afb_offset], ldafb, &work[
1]);
if (rpvgrw == 0.) {
rpvgrw = 1.;
} else {
rpvgrw = dlangb_("M", n, kl, ku, &ab[ab_offset], ldab, &work[1]) / rpvgrw;
}
/* Compute the reciprocal of the condition number of A. */
dgbcon_(norm, n, kl, ku, &afb[afb_offset], ldafb, &ipiv[1], &anorm, rcond,
&work[1], &iwork[1], info);
/* Compute the solution matrix X. */
dlacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
dgbtrs_(trans, n, kl, ku, nrhs, &afb[afb_offset], ldafb, &ipiv[1], &x[
x_offset], ldx, info);
/* Use iterative refinement to improve the computed solution and */
/* compute error bounds and backward error estimates for it. */
dgbrfs_(trans, n, kl, ku, nrhs, &ab[ab_offset], ldab, &afb[afb_offset],
ldafb, &ipiv[1], &b[b_offset], ldb, &x[x_offset], ldx, &ferr[1], &
berr[1], &work[1], &iwork[1], info);
/* Transform the solution matrix X to a solution of the original */
/* system. */
if (notran) {
if (colequ) {
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
i__3 = *n;
for (i__ = 1; i__ <= i__3; ++i__) {
x[i__ + j * x_dim1] = c__[i__] * x[i__ + j * x_dim1];
}
}
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
ferr[j] /= colcnd;
}
}
} else if (rowequ) {
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
i__3 = *n;
for (i__ = 1; i__ <= i__3; ++i__) {
x[i__ + j * x_dim1] = r__[i__] * x[i__ + j * x_dim1];
}
}
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
ferr[j] /= rowcnd;
}
}
/* Set INFO = N+1 if the matrix is singular to working precision. */
if (*rcond < dlamch_("Epsilon")) {
*info = *n + 1;
}
work[1] = rpvgrw;
return 0;
/* End of DGBSVX */
} /* dgbsvx_ */
/* Subroutine */ int dgbrfsx_(char *trans, char *equed, integer *n, integer *
kl, integer *ku, integer *nrhs, doublereal *ab, integer *ldab,
doublereal *afb, integer *ldafb, integer *ipiv, doublereal *r__,
doublereal *c__, doublereal *b, integer *ldb, doublereal *x, integer *
ldx, doublereal *rcond, doublereal *berr, integer *n_err_bnds__,
doublereal *err_bnds_norm__, doublereal *err_bnds_comp__, integer *
nparams, doublereal *params, doublereal *work, integer *iwork,
integer *info)
{
/* System generated locals */
integer ab_dim1, ab_offset, afb_dim1, afb_offset, b_dim1, b_offset,
x_dim1, x_offset, err_bnds_norm_dim1, err_bnds_norm_offset,
err_bnds_comp_dim1, err_bnds_comp_offset, i__1;
doublereal d__1, d__2;
/* Local variables */
doublereal illrcond_thresh__, unstable_thresh__, err_lbnd__;
integer ref_type__;
integer j;
doublereal rcond_tmp__;
integer prec_type__, trans_type__;
doublereal cwise_wrong__;
char norm[1];
logical ignore_cwise__;
doublereal anorm;
logical colequ, notran, rowequ;
integer ithresh, n_norms__;
doublereal rthresh;
/* -- LAPACK routine (version 3.2.1) -- */
/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
/* -- Jason Riedy of Univ. of California Berkeley. -- */
/* -- April 2009 -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley and NAG Ltd. -- */
/* Purpose */
/* ======= */
/* DGBRFSX improves the computed solution to a system of linear */
/* equations and provides error bounds and backward error estimates */
/* for the solution. In addition to normwise error bound, the code */
/* provides maximum componentwise error bound if possible. See */
/* comments for ERR_BNDS_NORM and ERR_BNDS_COMP for details of the */
/* error bounds. */
/* The original system of linear equations may have been equilibrated */
/* before calling this routine, as described by arguments EQUED, R */
/* and C below. In this case, the solution and error bounds returned */
/* are for the original unequilibrated system. */
/* Arguments */
/* ========= */
/* Some optional parameters are bundled in the PARAMS array. These */
/* settings determine how refinement is performed, but often the */
/* defaults are acceptable. If the defaults are acceptable, users */
/* can pass NPARAMS = 0 which prevents the source code from accessing */
/* the PARAMS argument. */
/* TRANS (input) CHARACTER*1 */
/* Specifies the form of the system of equations: */
/* = 'N': A * X = B (No transpose) */
/* = 'T': A**T * X = B (Transpose) */
/* = 'C': A**H * X = B (Conjugate transpose = Transpose) */
/* EQUED (input) CHARACTER*1 */
/* Specifies the form of equilibration that was done to A */
/* before calling this routine. This is needed to compute */
/* the solution and error bounds correctly. */
/* = 'N': No equilibration */
/* = 'R': Row equilibration, i.e., A has been premultiplied by */
/* diag(R). */
/* = 'C': Column equilibration, i.e., A has been postmultiplied */
/* by diag(C). */
/* = 'B': Both row and column equilibration, i.e., A has been */
/* replaced by diag(R) * A * diag(C). */
/* The right hand side B has been changed accordingly. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* KL (input) INTEGER */
/* The number of subdiagonals within the band of A. KL >= 0. */
/* KU (input) INTEGER */
/* The number of superdiagonals within the band of A. KU >= 0. */
/* NRHS (input) INTEGER */
/* The number of right hand sides, i.e., the number of columns */
/* of the matrices B and X. NRHS >= 0. */
/* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) */
/* The original band matrix A, stored in rows 1 to KL+KU+1. */
/* The j-th column of A is stored in the j-th column of the */
/* array AB as follows: */
/* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl). */
/* LDAB (input) INTEGER */
/* The leading dimension of the array AB. LDAB >= KL+KU+1. */
/* AFB (input) DOUBLE PRECISION array, dimension (LDAFB,N) */
/* Details of the LU factorization of the band matrix A, as */
/* computed by DGBTRF. U is stored as an upper triangular band */
/* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and */
/* the multipliers used during the factorization are stored in */
/* rows KL+KU+2 to 2*KL+KU+1. */
/* LDAFB (input) INTEGER */
/* The leading dimension of the array AFB. LDAFB >= 2*KL*KU+1. */
/* IPIV (input) INTEGER array, dimension (N) */
/* The pivot indices from DGETRF; for 1<=i<=N, row i of the */
/* matrix was interchanged with row IPIV(i). */
/* R (input or output) DOUBLE PRECISION array, dimension (N) */
/* The row scale factors for A. If EQUED = 'R' or 'B', A is */
/* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R */
/* is not accessed. R is an input argument if FACT = 'F'; */
/* otherwise, R is an output argument. If FACT = 'F' and */
/* EQUED = 'R' or 'B', each element of R must be positive. */
/* If R is output, each element of R is a power of the radix. */
/* If R is input, each element of R should be a power of the radix */
/* to ensure a reliable solution and error estimates. Scaling by */
/* powers of the radix does not cause rounding errors unless the */
/* result underflows or overflows. Rounding errors during scaling */
/* lead to refining with a matrix that is not equivalent to the */
/* input matrix, producing error estimates that may not be */
/* reliable. */
/* C (input or output) DOUBLE PRECISION array, dimension (N) */
/* The column scale factors for A. If EQUED = 'C' or 'B', A is */
/* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C */
/* is not accessed. C is an input argument if FACT = 'F'; */
/* otherwise, C is an output argument. If FACT = 'F' and */
/* EQUED = 'C' or 'B', each element of C must be positive. */
/* If C is output, each element of C is a power of the radix. */
/* If C is input, each element of C should be a power of the radix */
/* to ensure a reliable solution and error estimates. Scaling by */
/* powers of the radix does not cause rounding errors unless the */
/* result underflows or overflows. Rounding errors during scaling */
/* lead to refining with a matrix that is not equivalent to the */
/* input matrix, producing error estimates that may not be */
/* reliable. */
/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */
/* The right hand side matrix B. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS) */
/* On entry, the solution matrix X, as computed by DGETRS. */
/* On exit, the improved solution matrix X. */
/* LDX (input) INTEGER */
/* The leading dimension of the array X. LDX >= max(1,N). */
/* RCOND (output) DOUBLE PRECISION */
/* Reciprocal scaled condition number. This is an estimate of the */
/* reciprocal Skeel condition number of the matrix A after */
/* equilibration (if done). If this is less than the machine */
/* precision (in particular, if it is zero), the matrix is singular */
/* to working precision. Note that the error may still be small even */
/* if this number is very small and the matrix appears ill- */
/* conditioned. */
/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */
/* Componentwise relative backward error. This is the */
/* componentwise relative backward error of each solution vector X(j) */
/* (i.e., the smallest relative change in any element of A or B that */
/* makes X(j) an exact solution). */
/* N_ERR_BNDS (input) INTEGER */
/* Number of error bounds to return for each right hand side */
/* and each type (normwise or componentwise). See ERR_BNDS_NORM and */
/* ERR_BNDS_COMP below. */
/* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) */
/* For each right-hand side, this array contains information about */
/* various error bounds and condition numbers corresponding to the */
/* normwise relative error, which is defined as follows: */
/* Normwise relative error in the ith solution vector: */
/* max_j (abs(XTRUE(j,i) - X(j,i))) */
/* ------------------------------ */
/* max_j abs(X(j,i)) */
/* The array is indexed by the type of error information as described */
/* below. There currently are up to three pieces of information */
/* returned. */
/* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */
/* right-hand side. */
/* The second index in ERR_BNDS_NORM(:,err) contains the following */
/* three fields: */
/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
/* reciprocal condition number is less than the threshold */
/* sqrt(n) * dlamch('Epsilon'). */
/* err = 2 "Guaranteed" error bound: The estimated forward error, */
/* almost certainly within a factor of 10 of the true error */
/* so long as the next entry is greater than the threshold */
/* sqrt(n) * dlamch('Epsilon'). This error bound should only */
/* be trusted if the previous boolean is true. */
/* err = 3 Reciprocal condition number: Estimated normwise */
/* reciprocal condition number. Compared with the threshold */
/* sqrt(n) * dlamch('Epsilon') to determine if the error */
/* estimate is "guaranteed". These reciprocal condition */
/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
/* appropriately scaled matrix Z. */
/* Let Z = S*A, where S scales each row by a power of the */
/* radix so all absolute row sums of Z are approximately 1. */
/* See Lapack Working Note 165 for further details and extra */
/* cautions. */
/* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) */
/* For each right-hand side, this array contains information about */
/* various error bounds and condition numbers corresponding to the */
/* componentwise relative error, which is defined as follows: */
/* Componentwise relative error in the ith solution vector: */
/* abs(XTRUE(j,i) - X(j,i)) */
/* max_j ---------------------- */
/* abs(X(j,i)) */
/* The array is indexed by the right-hand side i (on which the */
/* componentwise relative error depends), and the type of error */
/* information as described below. There currently are up to three */
/* pieces of information returned for each right-hand side. If */
/* componentwise accuracy is not requested (PARAMS(3) = 0.0), then */
/* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most */
/* the first (:,N_ERR_BNDS) entries are returned. */
/* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */
/* right-hand side. */
/* The second index in ERR_BNDS_COMP(:,err) contains the following */
/* three fields: */
/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
/* reciprocal condition number is less than the threshold */
/* sqrt(n) * dlamch('Epsilon'). */
/* err = 2 "Guaranteed" error bound: The estimated forward error, */
/* almost certainly within a factor of 10 of the true error */
/* so long as the next entry is greater than the threshold */
/* sqrt(n) * dlamch('Epsilon'). This error bound should only */
/* be trusted if the previous boolean is true. */
/* err = 3 Reciprocal condition number: Estimated componentwise */
/* reciprocal condition number. Compared with the threshold */
/* sqrt(n) * dlamch('Epsilon') to determine if the error */
/* estimate is "guaranteed". These reciprocal condition */
/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
/* appropriately scaled matrix Z. */
/* Let Z = S*(A*diag(x)), where x is the solution for the */
/* current right-hand side and S scales each row of */
/* A*diag(x) by a power of the radix so all absolute row */
/* sums of Z are approximately 1. */
/* See Lapack Working Note 165 for further details and extra */
/* cautions. */
/* NPARAMS (input) INTEGER */
/* Specifies the number of parameters set in PARAMS. If .LE. 0, the */
/* PARAMS array is never referenced and default values are used. */
/* PARAMS (input / output) DOUBLE PRECISION array, dimension NPARAMS */
/* Specifies algorithm parameters. If an entry is .LT. 0.0, then */
/* that entry will be filled with default value used for that */
/* parameter. Only positions up to NPARAMS are accessed; defaults */
/* are used for higher-numbered parameters. */
/* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative */
/* refinement or not. */
/* Default: 1.0D+0 */
/* = 0.0 : No refinement is performed, and no error bounds are */
/* computed. */
/* = 1.0 : Use the double-precision refinement algorithm, */
/* possibly with doubled-single computations if the */
/* compilation environment does not support DOUBLE */
/* PRECISION. */
/* (other values are reserved for future use) */
/* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual */
/* computations allowed for refinement. */
/* Default: 10 */
/* Aggressive: Set to 100 to permit convergence using approximate */
/* factorizations or factorizations other than LU. If */
/* the factorization uses a technique other than */
/* Gaussian elimination, the guarantees in */
/* err_bnds_norm and err_bnds_comp may no longer be */
/* trustworthy. */
/* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code */
/* will attempt to find a solution with small componentwise */
/* relative error in the double-precision algorithm. Positive */
/* is true, 0.0 is false. */
/* Default: 1.0 (attempt componentwise convergence) */
/* WORK (workspace) DOUBLE PRECISION array, dimension (4*N) */
/* IWORK (workspace) INTEGER array, dimension (N) */
/* INFO (output) INTEGER */
/* = 0: Successful exit. The solution to every right-hand side is */
/* guaranteed. */
/* < 0: If INFO = -i, the i-th argument had an illegal value */
/* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization */
/* has been completed, but the factor U is exactly singular, so */
/* the solution and error bounds could not be computed. RCOND = 0 */
/* is returned. */
/* = N+J: The solution corresponding to the Jth right-hand side is */
/* not guaranteed. The solutions corresponding to other right- */
/* hand sides K with K > J may not be guaranteed as well, but */
/* only the first such right-hand side is reported. If a small */
/* componentwise error is not requested (PARAMS(3) = 0.0) then */
/* the Jth right-hand side is the first with a normwise error */
/* bound that is not guaranteed (the smallest J such */
/* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) */
/* the Jth right-hand side is the first with either a normwise or */
/* componentwise error bound that is not guaranteed (the smallest */
/* J such that either ERR_BNDS_NORM(J,1) = 0.0 or */
/* ERR_BNDS_COMP(J,1) = 0.0). See the definition of */
/* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information */
/* about all of the right-hand sides check ERR_BNDS_NORM or */
/* ERR_BNDS_COMP. */
/* ================================================================== */
/* Check the input parameters. */
/* Parameter adjustments */
err_bnds_comp_dim1 = *nrhs;
err_bnds_comp_offset = 1 + err_bnds_comp_dim1;
err_bnds_comp__ -= err_bnds_comp_offset;
err_bnds_norm_dim1 = *nrhs;
err_bnds_norm_offset = 1 + err_bnds_norm_dim1;
err_bnds_norm__ -= err_bnds_norm_offset;
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1;
ab -= ab_offset;
afb_dim1 = *ldafb;
afb_offset = 1 + afb_dim1;
afb -= afb_offset;
--ipiv;
--r__;
--c__;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
--berr;
--params;
--work;
--iwork;
/* Function Body */
*info = 0;
trans_type__ = ilatrans_(trans);
ref_type__ = 1;
if (*nparams >= 1) {
if (params[1] < 0.) {
params[1] = 1.;
} else {
ref_type__ = (integer) params[1];
}
}
/* Set default parameters. */
illrcond_thresh__ = (doublereal) (*n) * dlamch_("Epsilon");
ithresh = 10;
rthresh = .5;
unstable_thresh__ = .25;
ignore_cwise__ = FALSE_;
if (*nparams >= 2) {
if (params[2] < 0.) {
params[2] = (doublereal) ithresh;
} else {
ithresh = (integer) params[2];
}
}
if (*nparams >= 3) {
if (params[3] < 0.) {
if (ignore_cwise__) {
params[3] = 0.;
} else {
params[3] = 1.;
}
} else {
ignore_cwise__ = params[3] == 0.;
}
}
if (ref_type__ == 0 || *n_err_bnds__ == 0) {
n_norms__ = 0;
} else if (ignore_cwise__) {
n_norms__ = 1;
} else {
n_norms__ = 2;
}
notran = lsame_(trans, "N");
rowequ = lsame_(equed, "R") || lsame_(equed, "B");
colequ = lsame_(equed, "C") || lsame_(equed, "B");
/* Test input parameters. */
if (trans_type__ == -1) {
*info = -1;
} else if (! rowequ && ! colequ && ! lsame_(equed, "N")) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*kl < 0) {
*info = -4;
} else if (*ku < 0) {
*info = -5;
} else if (*nrhs < 0) {
*info = -6;
} else if (*ldab < *kl + *ku + 1) {
*info = -8;
} else if (*ldafb < (*kl << 1) + *ku + 1) {
*info = -10;
} else if (*ldb < max(1,*n)) {
*info = -13;
} else if (*ldx < max(1,*n)) {
*info = -15;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DGBRFSX", &i__1);
return 0;
}
/* Quick return if possible. */
if (*n == 0 || *nrhs == 0) {
*rcond = 1.;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
berr[j] = 0.;
if (*n_err_bnds__ >= 1) {
err_bnds_norm__[j + err_bnds_norm_dim1] = 1.;
err_bnds_comp__[j + err_bnds_comp_dim1] = 1.;
} else if (*n_err_bnds__ >= 2) {
err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 0.;
err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 0.;
} else if (*n_err_bnds__ >= 3) {
err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = 1.;
err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = 1.;
}
}
return 0;
}
/* Default to failure. */
*rcond = 0.;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
berr[j] = 1.;
if (*n_err_bnds__ >= 1) {
err_bnds_norm__[j + err_bnds_norm_dim1] = 1.;
err_bnds_comp__[j + err_bnds_comp_dim1] = 1.;
} else if (*n_err_bnds__ >= 2) {
err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.;
err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.;
} else if (*n_err_bnds__ >= 3) {
err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = 0.;
err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = 0.;
}
}
/* Compute the norm of A and the reciprocal of the condition */
/* number of A. */
if (notran) {
*(unsigned char *)norm = 'I';
} else {
*(unsigned char *)norm = '1';
}
anorm = dlangb_(norm, n, kl, ku, &ab[ab_offset], ldab, &work[1]);
dgbcon_(norm, n, kl, ku, &afb[afb_offset], ldafb, &ipiv[1], &anorm, rcond,
&work[1], &iwork[1], info);
/* Perform refinement on each right-hand side */
if (ref_type__ != 0) {
prec_type__ = ilaprec_("E");
if (notran) {
dla_gbrfsx_extended__(&prec_type__, &trans_type__, n, kl, ku,
nrhs, &ab[ab_offset], ldab, &afb[afb_offset], ldafb, &
ipiv[1], &colequ, &c__[1], &b[b_offset], ldb, &x[x_offset]
, ldx, &berr[1], &n_norms__, &err_bnds_norm__[
err_bnds_norm_offset], &err_bnds_comp__[
err_bnds_comp_offset], &work[*n + 1], &work[1], &work[(*n
<< 1) + 1], &work[1], rcond, &ithresh, &rthresh, &
unstable_thresh__, &ignore_cwise__, info);
} else {
dla_gbrfsx_extended__(&prec_type__, &trans_type__, n, kl, ku,
nrhs, &ab[ab_offset], ldab, &afb[afb_offset], ldafb, &
ipiv[1], &rowequ, &r__[1], &b[b_offset], ldb, &x[x_offset]
, ldx, &berr[1], &n_norms__, &err_bnds_norm__[
err_bnds_norm_offset], &err_bnds_comp__[
err_bnds_comp_offset], &work[*n + 1], &work[1], &work[(*n
<< 1) + 1], &work[1], rcond, &ithresh, &rthresh, &
unstable_thresh__, &ignore_cwise__, info);
}
}
/* Computing MAX */
d__1 = 10., d__2 = sqrt((doublereal) (*n));
err_lbnd__ = max(d__1,d__2) * dlamch_("Epsilon");
if (*n_err_bnds__ >= 1 && n_norms__ >= 1) {
/* Compute scaled normwise condition number cond(A*C). */
if (colequ && notran) {
rcond_tmp__ = dla_gbrcond__(trans, n, kl, ku, &ab[ab_offset],
ldab, &afb[afb_offset], ldafb, &ipiv[1], &c_n1, &c__[1],
info, &work[1], &iwork[1], (ftnlen)1);
} else if (rowequ && ! notran) {
rcond_tmp__ = dla_gbrcond__(trans, n, kl, ku, &ab[ab_offset],
ldab, &afb[afb_offset], ldafb, &ipiv[1], &c_n1, &r__[1],
info, &work[1], &iwork[1], (ftnlen)1);
} else {
rcond_tmp__ = dla_gbrcond__(trans, n, kl, ku, &ab[ab_offset],
ldab, &afb[afb_offset], ldafb, &ipiv[1], &c__0, &r__[1],
info, &work[1], &iwork[1], (ftnlen)1);
}
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
/* Cap the error at 1.0. */
if (*n_err_bnds__ >= 2 && err_bnds_norm__[j + (err_bnds_norm_dim1
<< 1)] > 1.) {
err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.;
}
/* Threshold the error (see LAWN). */
if (rcond_tmp__ < illrcond_thresh__) {
err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.;
err_bnds_norm__[j + err_bnds_norm_dim1] = 0.;
if (*info <= *n) {
*info = *n + j;
}
} else if (err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] <
err_lbnd__) {
err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = err_lbnd__;
err_bnds_norm__[j + err_bnds_norm_dim1] = 1.;
}
/* Save the condition number. */
if (*n_err_bnds__ >= 3) {
err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = rcond_tmp__;
}
}
}
if (*n_err_bnds__ >= 1 && n_norms__ >= 2) {
/* Compute componentwise condition number cond(A*diag(Y(:,J))) for */
/* each right-hand side using the current solution as an estimate of */
/* the true solution. If the componentwise error estimate is too */
/* large, then the solution is a lousy estimate of truth and the */
/* estimated RCOND may be too optimistic. To avoid misleading users, */
/* the inverse condition number is set to 0.0 when the estimated */
/* cwise error is at least CWISE_WRONG. */
cwise_wrong__ = sqrt(dlamch_("Epsilon"));
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
if (err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] <
cwise_wrong__) {
rcond_tmp__ = dla_gbrcond__(trans, n, kl, ku, &ab[ab_offset],
ldab, &afb[afb_offset], ldafb, &ipiv[1], &c__1, &x[j *
x_dim1 + 1], info, &work[1], &iwork[1], (ftnlen)1);
} else {
rcond_tmp__ = 0.;
}
/* Cap the error at 1.0. */
if (*n_err_bnds__ >= 2 && err_bnds_comp__[j + (err_bnds_comp_dim1
<< 1)] > 1.) {
err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.;
}
/* Threshold the error (see LAWN). */
if (rcond_tmp__ < illrcond_thresh__) {
err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.;
err_bnds_comp__[j + err_bnds_comp_dim1] = 0.;
if (params[3] == 1. && *info < *n + j) {
*info = *n + j;
}
} else if (err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] <
err_lbnd__) {
err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = err_lbnd__;
err_bnds_comp__[j + err_bnds_comp_dim1] = 1.;
}
/* Save the condition number. */
if (*n_err_bnds__ >= 3) {
err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = rcond_tmp__;
}
}
}
return 0;
/* End of DGBRFSX */
} /* dgbrfsx_ */
/* Subroutine */ int dlatmr_(integer *m, integer *n, char *dist, integer *
iseed, char *sym, doublereal *d__, integer *mode, doublereal *cond,
doublereal *dmax__, char *rsign, char *grade, doublereal *dl, integer
*model, doublereal *condl, doublereal *dr, integer *moder, doublereal
*condr, char *pivtng, integer *ipivot, integer *kl, integer *ku,
doublereal *sparse, doublereal *anorm, char *pack, doublereal *a,
integer *lda, integer *iwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
doublereal d__1, d__2, d__3;
/* Local variables */
static integer isub, jsub;
static doublereal temp;
static integer isym, i__, j, k;
static doublereal alpha;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
static integer ipack;
extern logical lsame_(char *, char *);
static doublereal tempa[1];
static integer iisub, idist, jjsub, mnmin;
static logical dzero;
static integer mnsub;
static doublereal onorm;
static integer mxsub, npvts;
extern /* Subroutine */ int dlatm1_(integer *, doublereal *, integer *,
integer *, integer *, doublereal *, integer *, integer *);
extern doublereal dlatm2_(integer *, integer *, integer *, integer *,
integer *, integer *, integer *, integer *, doublereal *, integer
*, doublereal *, doublereal *, integer *, integer *, doublereal *)
, dlatm3_(integer *, integer *, integer *, integer *, integer *,
integer *, integer *, integer *, integer *, integer *, doublereal
*, integer *, doublereal *, doublereal *, integer *, integer *,
doublereal *), dlangb_(char *, integer *, integer *, integer *,
doublereal *, integer *, doublereal *), dlange_(char *,
integer *, integer *, doublereal *, integer *, doublereal *);
static integer igrade;
extern doublereal dlansb_(char *, char *, integer *, integer *,
doublereal *, integer *, doublereal *);
static logical fulbnd;
extern /* Subroutine */ int xerbla_(char *, integer *);
static logical badpvt;
extern doublereal dlansp_(char *, char *, integer *, doublereal *,
doublereal *), dlansy_(char *, char *, integer *,
doublereal *, integer *, doublereal *);
static integer irsign, ipvtng, kll, kuu;
#define a_ref(a_1,a_2) a[(a_2)*a_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
=======
DLATMR generates random matrices of various types for testing
LAPACK programs.
DLATMR operates by applying the following sequence of
operations:
Generate a matrix A with random entries of distribution DIST
which is symmetric if SYM='S', and nonsymmetric
if SYM='N'.
Set the diagonal to D, where D may be input or
computed according to MODE, COND, DMAX and RSIGN
as described below.
Grade the matrix, if desired, from the left and/or right
as specified by GRADE. The inputs DL, MODEL, CONDL, DR,
MODER and CONDR also determine the grading as described
below.
Permute, if desired, the rows and/or columns as specified by
PIVTNG and IPIVOT.
Set random entries to zero, if desired, to get a random sparse
matrix as specified by SPARSE.
Make A a band matrix, if desired, by zeroing out the matrix
outside a band of lower bandwidth KL and upper bandwidth KU.
Scale A, if desired, to have maximum entry ANORM.
Pack the matrix if desired. Options specified by PACK are:
no packing
zero out upper half (if symmetric)
zero out lower half (if symmetric)
store the upper half columnwise (if symmetric or
square upper triangular)
store the lower half columnwise (if symmetric or
square lower triangular)
same as upper half rowwise if symmetric
store the lower triangle in banded format (if symmetric)
store the upper triangle in banded format (if symmetric)
store the entire matrix in banded format
Note: If two calls to DLATMR differ only in the PACK parameter,
they will generate mathematically equivalent matrices.
If two calls to DLATMR both have full bandwidth (KL = M-1
and KU = N-1), and differ only in the PIVTNG and PACK
parameters, then the matrices generated will differ only
in the order of the rows and/or columns, and otherwise
contain the same data. This consistency cannot be and
is not maintained with less than full bandwidth.
Arguments
=========
M - INTEGER
Number of rows of A. Not modified.
N - INTEGER
Number of columns of A. Not modified.
DIST - CHARACTER*1
On entry, DIST specifies the type of distribution to be used
to generate a random matrix .
'U' => UNIFORM( 0, 1 ) ( 'U' for uniform )
'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric )
'N' => NORMAL( 0, 1 ) ( 'N' for normal )
Not modified.
ISEED - INTEGER array, dimension (4)
On entry ISEED specifies the seed of the random number
generator. They should lie between 0 and 4095 inclusive,
and ISEED(4) should be odd. The random number generator
uses a linear congruential sequence limited to small
integers, and so should produce machine independent
random numbers. The values of ISEED are changed on
exit, and can be used in the next call to DLATMR
to continue the same random number sequence.
Changed on exit.
SYM - CHARACTER*1
If SYM='S' or 'H', generated matrix is symmetric.
If SYM='N', generated matrix is nonsymmetric.
Not modified.
D - DOUBLE PRECISION array, dimension (min(M,N))
On entry this array specifies the diagonal entries
of the diagonal of A. D may either be specified
on entry, or set according to MODE and COND as described
below. May be changed on exit if MODE is nonzero.
MODE - INTEGER
On entry describes how D is to be used:
MODE = 0 means use D as input
MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND
MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND
MODE = 3 sets D(I)=COND**(-(I-1)/(N-1))
MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND)
MODE = 5 sets D to random numbers in the range
( 1/COND , 1 ) such that their logarithms
are uniformly distributed.
MODE = 6 set D to random numbers from same distribution
as the rest of the matrix.
MODE < 0 has the same meaning as ABS(MODE), except that
the order of the elements of D is reversed.
Thus if MODE is positive, D has entries ranging from
1 to 1/COND, if negative, from 1/COND to 1,
Not modified.
COND - DOUBLE PRECISION
On entry, used as described under MODE above.
If used, it must be >= 1. Not modified.
DMAX - DOUBLE PRECISION
If MODE neither -6, 0 nor 6, the diagonal is scaled by
DMAX / max(abs(D(i))), so that maximum absolute entry
of diagonal is abs(DMAX). If DMAX is negative (or zero),
diagonal will be scaled by a negative number (or zero).
RSIGN - CHARACTER*1
If MODE neither -6, 0 nor 6, specifies sign of diagonal
as follows:
'T' => diagonal entries are multiplied by 1 or -1
with probability .5
'F' => diagonal unchanged
Not modified.
GRADE - CHARACTER*1
Specifies grading of matrix as follows:
'N' => no grading
'L' => matrix premultiplied by diag( DL )
(only if matrix nonsymmetric)
'R' => matrix postmultiplied by diag( DR )
(only if matrix nonsymmetric)
'B' => matrix premultiplied by diag( DL ) and
postmultiplied by diag( DR )
(only if matrix nonsymmetric)
'S' or 'H' => matrix premultiplied by diag( DL ) and
postmultiplied by diag( DL )
('S' for symmetric, or 'H' for Hermitian)
'E' => matrix premultiplied by diag( DL ) and
postmultiplied by inv( diag( DL ) )
( 'E' for eigenvalue invariance)
(only if matrix nonsymmetric)
Note: if GRADE='E', then M must equal N.
Not modified.
DL - DOUBLE PRECISION array, dimension (M)
If MODEL=0, then on entry this array specifies the diagonal
entries of a diagonal matrix used as described under GRADE
above. If MODEL is not zero, then DL will be set according
to MODEL and CONDL, analogous to the way D is set according
to MODE and COND (except there is no DMAX parameter for DL).
If GRADE='E', then DL cannot have zero entries.
Not referenced if GRADE = 'N' or 'R'. Changed on exit.
MODEL - INTEGER
This specifies how the diagonal array DL is to be computed,
just as MODE specifies how D is to be computed.
Not modified.
CONDL - DOUBLE PRECISION
When MODEL is not zero, this specifies the condition number
of the computed DL. Not modified.
DR - DOUBLE PRECISION array, dimension (N)
If MODER=0, then on entry this array specifies the diagonal
entries of a diagonal matrix used as described under GRADE
above. If MODER is not zero, then DR will be set according
to MODER and CONDR, analogous to the way D is set according
to MODE and COND (except there is no DMAX parameter for DR).
Not referenced if GRADE = 'N', 'L', 'H', 'S' or 'E'.
Changed on exit.
MODER - INTEGER
This specifies how the diagonal array DR is to be computed,
just as MODE specifies how D is to be computed.
Not modified.
CONDR - DOUBLE PRECISION
When MODER is not zero, this specifies the condition number
of the computed DR. Not modified.
PIVTNG - CHARACTER*1
On entry specifies pivoting permutations as follows:
'N' or ' ' => none.
'L' => left or row pivoting (matrix must be nonsymmetric).
'R' => right or column pivoting (matrix must be
nonsymmetric).
'B' or 'F' => both or full pivoting, i.e., on both sides.
In this case, M must equal N
If two calls to DLATMR both have full bandwidth (KL = M-1
and KU = N-1), and differ only in the PIVTNG and PACK
parameters, then the matrices generated will differ only
in the order of the rows and/or columns, and otherwise
contain the same data. This consistency cannot be
maintained with less than full bandwidth.
IPIVOT - INTEGER array, dimension (N or M)
This array specifies the permutation used. After the
basic matrix is generated, the rows, columns, or both
are permuted. If, say, row pivoting is selected, DLATMR
starts with the *last* row and interchanges the M-th and
IPIVOT(M)-th rows, then moves to the next-to-last row,
interchanging the (M-1)-th and the IPIVOT(M-1)-th rows,
and so on. In terms of "2-cycles", the permutation is
(1 IPIVOT(1)) (2 IPIVOT(2)) ... (M IPIVOT(M))
where the rightmost cycle is applied first. This is the
*inverse* of the effect of pivoting in LINPACK. The idea
is that factoring (with pivoting) an identity matrix
which has been inverse-pivoted in this way should
result in a pivot vector identical to IPIVOT.
Not referenced if PIVTNG = 'N'. Not modified.
SPARSE - DOUBLE PRECISION
On entry specifies the sparsity of the matrix if a sparse
matrix is to be generated. SPARSE should lie between
0 and 1. To generate a sparse matrix, for each matrix entry
a uniform ( 0, 1 ) random number x is generated and
compared to SPARSE; if x is larger the matrix entry
is unchanged and if x is smaller the entry is set
to zero. Thus on the average a fraction SPARSE of the
entries will be set to zero.
Not modified.
KL - INTEGER
On entry specifies the lower bandwidth of the matrix. For
example, KL=0 implies upper triangular, KL=1 implies upper
Hessenberg, and KL at least M-1 implies the matrix is not
banded. Must equal KU if matrix is symmetric.
Not modified.
KU - INTEGER
On entry specifies the upper bandwidth of the matrix. For
example, KU=0 implies lower triangular, KU=1 implies lower
Hessenberg, and KU at least N-1 implies the matrix is not
banded. Must equal KL if matrix is symmetric.
Not modified.
ANORM - DOUBLE PRECISION
On entry specifies maximum entry of output matrix
(output matrix will by multiplied by a constant so that
its largest absolute entry equal ANORM)
if ANORM is nonnegative. If ANORM is negative no scaling
is done. Not modified.
PACK - CHARACTER*1
On entry specifies packing of matrix as follows:
'N' => no packing
'U' => zero out all subdiagonal entries (if symmetric)
'L' => zero out all superdiagonal entries (if symmetric)
'C' => store the upper triangle columnwise
(only if matrix symmetric or square upper triangular)
'R' => store the lower triangle columnwise
(only if matrix symmetric or square lower triangular)
(same as upper half rowwise if symmetric)
'B' => store the lower triangle in band storage scheme
(only if matrix symmetric)
'Q' => store the upper triangle in band storage scheme
(only if matrix symmetric)
'Z' => store the entire matrix in band storage scheme
(pivoting can be provided for by using this
option to store A in the trailing rows of
the allocated storage)
Using these options, the various LAPACK packed and banded
storage schemes can be obtained:
GB - use 'Z'
PB, SB or TB - use 'B' or 'Q'
PP, SP or TP - use 'C' or 'R'
If two calls to DLATMR differ only in the PACK parameter,
they will generate mathematically equivalent matrices.
Not modified.
A - DOUBLE PRECISION array, dimension (LDA,N)
On exit A is the desired test matrix. Only those
entries of A which are significant on output
will be referenced (even if A is in packed or band
storage format). The 'unoccupied corners' of A in
band format will be zeroed out.
LDA - INTEGER
on entry LDA specifies the first dimension of A as
declared in the calling program.
If PACK='N', 'U' or 'L', LDA must be at least max ( 1, M ).
If PACK='C' or 'R', LDA must be at least 1.
If PACK='B', or 'Q', LDA must be MIN ( KU+1, N )
If PACK='Z', LDA must be at least KUU+KLL+1, where
KUU = MIN ( KU, N-1 ) and KLL = MIN ( KL, N-1 )
Not modified.
IWORK - INTEGER array, dimension ( N or M)
Workspace. Not referenced if PIVTNG = 'N'. Changed on exit.
INFO - INTEGER
Error parameter on exit:
0 => normal return
-1 => M negative or unequal to N and SYM='S' or 'H'
-2 => N negative
-3 => DIST illegal string
-5 => SYM illegal string
-7 => MODE not in range -6 to 6
-8 => COND less than 1.0, and MODE neither -6, 0 nor 6
-10 => MODE neither -6, 0 nor 6 and RSIGN illegal string
-11 => GRADE illegal string, or GRADE='E' and
M not equal to N, or GRADE='L', 'R', 'B' or 'E' and
SYM = 'S' or 'H'
-12 => GRADE = 'E' and DL contains zero
-13 => MODEL not in range -6 to 6 and GRADE= 'L', 'B', 'H',
'S' or 'E'
-14 => CONDL less than 1.0, GRADE='L', 'B', 'H', 'S' or 'E',
and MODEL neither -6, 0 nor 6
-16 => MODER not in range -6 to 6 and GRADE= 'R' or 'B'
-17 => CONDR less than 1.0, GRADE='R' or 'B', and
MODER neither -6, 0 nor 6
-18 => PIVTNG illegal string, or PIVTNG='B' or 'F' and
M not equal to N, or PIVTNG='L' or 'R' and SYM='S'
or 'H'
-19 => IPIVOT contains out of range number and
PIVTNG not equal to 'N'
-20 => KL negative
-21 => KU negative, or SYM='S' or 'H' and KU not equal to KL
-22 => SPARSE not in range 0. to 1.
-24 => PACK illegal string, or PACK='U', 'L', 'B' or 'Q'
and SYM='N', or PACK='C' and SYM='N' and either KL
not equal to 0 or N not equal to M, or PACK='R' and
SYM='N', and either KU not equal to 0 or N not equal
to M
-26 => LDA too small
1 => Error return from DLATM1 (computing D)
2 => Cannot scale diagonal to DMAX (max. entry is 0)
3 => Error return from DLATM1 (computing DL)
4 => Error return from DLATM1 (computing DR)
5 => ANORM is positive, but matrix constructed prior to
attempting to scale it to have norm ANORM, is zero
=====================================================================
1) Decode and Test the input parameters.
Initialize flags & seed.
Parameter adjustments */
--iseed;
--d__;
--dl;
--dr;
--ipivot;
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--iwork;
/* Function Body */
*info = 0;
/* Quick return if possible */
if (*m == 0 || *n == 0) {
return 0;
}
/* Decode DIST */
if (lsame_(dist, "U")) {
idist = 1;
} else if (lsame_(dist, "S")) {
idist = 2;
} else if (lsame_(dist, "N")) {
idist = 3;
} else {
idist = -1;
}
/* Decode SYM */
if (lsame_(sym, "S")) {
isym = 0;
} else if (lsame_(sym, "N")) {
isym = 1;
} else if (lsame_(sym, "H")) {
isym = 0;
} else {
isym = -1;
}
/* Decode RSIGN */
if (lsame_(rsign, "F")) {
irsign = 0;
} else if (lsame_(rsign, "T")) {
irsign = 1;
} else {
irsign = -1;
}
/* Decode PIVTNG */
if (lsame_(pivtng, "N")) {
ipvtng = 0;
} else if (lsame_(pivtng, " ")) {
ipvtng = 0;
} else if (lsame_(pivtng, "L")) {
ipvtng = 1;
npvts = *m;
} else if (lsame_(pivtng, "R")) {
ipvtng = 2;
npvts = *n;
} else if (lsame_(pivtng, "B")) {
ipvtng = 3;
npvts = min(*n,*m);
} else if (lsame_(pivtng, "F")) {
ipvtng = 3;
npvts = min(*n,*m);
} else {
ipvtng = -1;
}
/* Decode GRADE */
if (lsame_(grade, "N")) {
igrade = 0;
} else if (lsame_(grade, "L")) {
igrade = 1;
} else if (lsame_(grade, "R")) {
igrade = 2;
} else if (lsame_(grade, "B")) {
igrade = 3;
} else if (lsame_(grade, "E")) {
igrade = 4;
} else if (lsame_(grade, "H") || lsame_(grade,
"S")) {
igrade = 5;
} else {
igrade = -1;
}
/* Decode PACK */
if (lsame_(pack, "N")) {
ipack = 0;
} else if (lsame_(pack, "U")) {
ipack = 1;
} else if (lsame_(pack, "L")) {
ipack = 2;
} else if (lsame_(pack, "C")) {
ipack = 3;
} else if (lsame_(pack, "R")) {
ipack = 4;
} else if (lsame_(pack, "B")) {
ipack = 5;
} else if (lsame_(pack, "Q")) {
ipack = 6;
} else if (lsame_(pack, "Z")) {
ipack = 7;
} else {
ipack = -1;
}
/* Set certain internal parameters */
mnmin = min(*m,*n);
/* Computing MIN */
i__1 = *kl, i__2 = *m - 1;
kll = min(i__1,i__2);
/* Computing MIN */
i__1 = *ku, i__2 = *n - 1;
kuu = min(i__1,i__2);
/* If inv(DL) is used, check to see if DL has a zero entry. */
dzero = FALSE_;
if (igrade == 4 && *model == 0) {
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
if (dl[i__] == 0.) {
dzero = TRUE_;
}
/* L10: */
}
}
/* Check values in IPIVOT */
badpvt = FALSE_;
if (ipvtng > 0) {
i__1 = npvts;
for (j = 1; j <= i__1; ++j) {
if (ipivot[j] <= 0 || ipivot[j] > npvts) {
badpvt = TRUE_;
}
/* L20: */
}
}
/* Set INFO if an error */
if (*m < 0) {
*info = -1;
} else if (*m != *n && isym == 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (idist == -1) {
*info = -3;
} else if (isym == -1) {
*info = -5;
} else if (*mode < -6 || *mode > 6) {
*info = -7;
} else if (*mode != -6 && *mode != 0 && *mode != 6 && *cond < 1.) {
*info = -8;
} else if (*mode != -6 && *mode != 0 && *mode != 6 && irsign == -1) {
*info = -10;
} else if (igrade == -1 || igrade == 4 && *m != *n || igrade >= 1 &&
igrade <= 4 && isym == 0) {
*info = -11;
} else if (igrade == 4 && dzero) {
*info = -12;
} else if ((igrade == 1 || igrade == 3 || igrade == 4 || igrade == 5) && (
*model < -6 || *model > 6)) {
*info = -13;
} else if ((igrade == 1 || igrade == 3 || igrade == 4 || igrade == 5) && (
*model != -6 && *model != 0 && *model != 6) && *condl < 1.) {
*info = -14;
} else if ((igrade == 2 || igrade == 3) && (*moder < -6 || *moder > 6)) {
*info = -16;
} else if ((igrade == 2 || igrade == 3) && (*moder != -6 && *moder != 0 &&
*moder != 6) && *condr < 1.) {
*info = -17;
} else if (ipvtng == -1 || ipvtng == 3 && *m != *n || (ipvtng == 1 ||
ipvtng == 2) && isym == 0) {
*info = -18;
} else if (ipvtng != 0 && badpvt) {
*info = -19;
} else if (*kl < 0) {
*info = -20;
} else if (*ku < 0 || isym == 0 && *kl != *ku) {
*info = -21;
} else if (*sparse < 0. || *sparse > 1.) {
*info = -22;
} else if (ipack == -1 || (ipack == 1 || ipack == 2 || ipack == 5 ||
ipack == 6) && isym == 1 || ipack == 3 && isym == 1 && (*kl != 0
|| *m != *n) || ipack == 4 && isym == 1 && (*ku != 0 || *m != *n))
{
*info = -24;
} else if ((ipack == 0 || ipack == 1 || ipack == 2) && *lda < max(1,*m) ||
(ipack == 3 || ipack == 4) && *lda < 1 || (ipack == 5 || ipack ==
6) && *lda < kuu + 1 || ipack == 7 && *lda < kll + kuu + 1) {
*info = -26;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DLATMR", &i__1);
return 0;
}
/* Decide if we can pivot consistently */
fulbnd = FALSE_;
if (kuu == *n - 1 && kll == *m - 1) {
fulbnd = TRUE_;
}
/* Initialize random number generator */
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__] = (i__1 = iseed[i__], abs(i__1)) % 4096;
/* L30: */
}
iseed[4] = (iseed[4] / 2 << 1) + 1;
/* 2) Set up D, DL, and DR, if indicated.
Compute D according to COND and MODE */
dlatm1_(mode, cond, &irsign, &idist, &iseed[1], &d__[1], &mnmin, info);
if (*info != 0) {
*info = 1;
return 0;
}
if (*mode != 0 && *mode != -6 && *mode != 6) {
/* Scale by DMAX */
temp = abs(d__[1]);
i__1 = mnmin;
for (i__ = 2; i__ <= i__1; ++i__) {
/* Computing MAX */
d__2 = temp, d__3 = (d__1 = d__[i__], abs(d__1));
temp = max(d__2,d__3);
/* L40: */
}
if (temp == 0. && *dmax__ != 0.) {
*info = 2;
return 0;
}
if (temp != 0.) {
alpha = *dmax__ / temp;
} else {
alpha = 1.;
}
i__1 = mnmin;
for (i__ = 1; i__ <= i__1; ++i__) {
d__[i__] = alpha * d__[i__];
/* L50: */
}
}
/* Compute DL if grading set */
if (igrade == 1 || igrade == 3 || igrade == 4 || igrade == 5) {
dlatm1_(model, condl, &c__0, &idist, &iseed[1], &dl[1], m, info);
if (*info != 0) {
*info = 3;
return 0;
}
}
/* Compute DR if grading set */
if (igrade == 2 || igrade == 3) {
dlatm1_(moder, condr, &c__0, &idist, &iseed[1], &dr[1], n, info);
if (*info != 0) {
*info = 4;
return 0;
}
}
/* 3) Generate IWORK if pivoting */
if (ipvtng > 0) {
i__1 = npvts;
for (i__ = 1; i__ <= i__1; ++i__) {
iwork[i__] = i__;
/* L60: */
}
if (fulbnd) {
i__1 = npvts;
for (i__ = 1; i__ <= i__1; ++i__) {
k = ipivot[i__];
j = iwork[i__];
iwork[i__] = iwork[k];
iwork[k] = j;
/* L70: */
}
} else {
for (i__ = npvts; i__ >= 1; --i__) {
k = ipivot[i__];
j = iwork[i__];
iwork[i__] = iwork[k];
iwork[k] = j;
/* L80: */
}
}
}
/* 4) Generate matrices for each kind of PACKing
Always sweep matrix columnwise (if symmetric, upper
half only) so that matrix generated does not depend
on PACK */
if (fulbnd) {
/* Use DLATM3 so matrices generated with differing PIVOTing only
differ only in the order of their rows and/or columns. */
if (ipack == 0) {
if (isym == 0) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
for (i__ = 1; i__ <= i__2; ++i__) {
temp = dlatm3_(m, n, &i__, &j, &isub, &jsub, kl, ku, &
idist, &iseed[1], &d__[1], &igrade, &dl[1], &
dr[1], &ipvtng, &iwork[1], sparse);
a_ref(isub, jsub) = temp;
a_ref(jsub, isub) = temp;
/* L90: */
}
/* L100: */
}
} else if (isym == 1) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
temp = dlatm3_(m, n, &i__, &j, &isub, &jsub, kl, ku, &
idist, &iseed[1], &d__[1], &igrade, &dl[1], &
dr[1], &ipvtng, &iwork[1], sparse);
a_ref(isub, jsub) = temp;
/* L110: */
}
/* L120: */
}
}
} else if (ipack == 1) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
for (i__ = 1; i__ <= i__2; ++i__) {
temp = dlatm3_(m, n, &i__, &j, &isub, &jsub, kl, ku, &
idist, &iseed[1], &d__[1], &igrade, &dl[1], &dr[1]
, &ipvtng, &iwork[1], sparse);
mnsub = min(isub,jsub);
mxsub = max(isub,jsub);
a_ref(mnsub, mxsub) = temp;
if (mnsub != mxsub) {
a_ref(mxsub, mnsub) = 0.;
}
/* L130: */
}
/* L140: */
}
} else if (ipack == 2) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
for (i__ = 1; i__ <= i__2; ++i__) {
temp = dlatm3_(m, n, &i__, &j, &isub, &jsub, kl, ku, &
idist, &iseed[1], &d__[1], &igrade, &dl[1], &dr[1]
, &ipvtng, &iwork[1], sparse);
mnsub = min(isub,jsub);
mxsub = max(isub,jsub);
a_ref(mxsub, mnsub) = temp;
if (mnsub != mxsub) {
a_ref(mnsub, mxsub) = 0.;
}
/* L150: */
}
/* L160: */
}
} else if (ipack == 3) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
for (i__ = 1; i__ <= i__2; ++i__) {
temp = dlatm3_(m, n, &i__, &j, &isub, &jsub, kl, ku, &
idist, &iseed[1], &d__[1], &igrade, &dl[1], &dr[1]
, &ipvtng, &iwork[1], sparse);
/* Compute K = location of (ISUB,JSUB) entry in packed
array */
mnsub = min(isub,jsub);
mxsub = max(isub,jsub);
k = mxsub * (mxsub - 1) / 2 + mnsub;
/* Convert K to (IISUB,JJSUB) location */
jjsub = (k - 1) / *lda + 1;
iisub = k - *lda * (jjsub - 1);
a_ref(iisub, jjsub) = temp;
/* L170: */
}
/* L180: */
}
} else if (ipack == 4) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
for (i__ = 1; i__ <= i__2; ++i__) {
temp = dlatm3_(m, n, &i__, &j, &isub, &jsub, kl, ku, &
idist, &iseed[1], &d__[1], &igrade, &dl[1], &dr[1]
, &ipvtng, &iwork[1], sparse);
/* Compute K = location of (I,J) entry in packed array */
mnsub = min(isub,jsub);
mxsub = max(isub,jsub);
if (mnsub == 1) {
k = mxsub;
} else {
k = *n * (*n + 1) / 2 - (*n - mnsub + 1) * (*n -
mnsub + 2) / 2 + mxsub - mnsub + 1;
}
/* Convert K to (IISUB,JJSUB) location */
jjsub = (k - 1) / *lda + 1;
iisub = k - *lda * (jjsub - 1);
a_ref(iisub, jjsub) = temp;
/* L190: */
}
/* L200: */
}
} else if (ipack == 5) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
for (i__ = j - kuu; i__ <= i__2; ++i__) {
if (i__ < 1) {
a_ref(j - i__ + 1, i__ + *n) = 0.;
} else {
temp = dlatm3_(m, n, &i__, &j, &isub, &jsub, kl, ku, &
idist, &iseed[1], &d__[1], &igrade, &dl[1], &
dr[1], &ipvtng, &iwork[1], sparse);
mnsub = min(isub,jsub);
mxsub = max(isub,jsub);
a_ref(mxsub - mnsub + 1, mnsub) = temp;
}
/* L210: */
}
/* L220: */
}
} else if (ipack == 6) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
for (i__ = j - kuu; i__ <= i__2; ++i__) {
temp = dlatm3_(m, n, &i__, &j, &isub, &jsub, kl, ku, &
idist, &iseed[1], &d__[1], &igrade, &dl[1], &dr[1]
, &ipvtng, &iwork[1], sparse);
mnsub = min(isub,jsub);
mxsub = max(isub,jsub);
a_ref(mnsub - mxsub + kuu + 1, mxsub) = temp;
/* L230: */
}
/* L240: */
}
} else if (ipack == 7) {
if (isym == 0) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
for (i__ = j - kuu; i__ <= i__2; ++i__) {
temp = dlatm3_(m, n, &i__, &j, &isub, &jsub, kl, ku, &
idist, &iseed[1], &d__[1], &igrade, &dl[1], &
dr[1], &ipvtng, &iwork[1], sparse);
mnsub = min(isub,jsub);
mxsub = max(isub,jsub);
a_ref(mnsub - mxsub + kuu + 1, mxsub) = temp;
if (i__ < 1) {
a_ref(j - i__ + 1 + kuu, i__ + *n) = 0.;
}
if (i__ >= 1 && mnsub != mxsub) {
a_ref(mxsub - mnsub + 1 + kuu, mnsub) = temp;
}
/* L250: */
}
/* L260: */
}
} else if (isym == 1) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j + kll;
for (i__ = j - kuu; i__ <= i__2; ++i__) {
temp = dlatm3_(m, n, &i__, &j, &isub, &jsub, kl, ku, &
idist, &iseed[1], &d__[1], &igrade, &dl[1], &
dr[1], &ipvtng, &iwork[1], sparse);
a_ref(isub - jsub + kuu + 1, jsub) = temp;
/* L270: */
}
/* L280: */
}
}
}
} else {
/* Use DLATM2 */
if (ipack == 0) {
if (isym == 0) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
for (i__ = 1; i__ <= i__2; ++i__) {
a_ref(i__, j) = dlatm2_(m, n, &i__, &j, kl, ku, &
idist, &iseed[1], &d__[1], &igrade, &dl[1], &
dr[1], &ipvtng, &iwork[1], sparse);
a_ref(j, i__) = a_ref(i__, j);
/* L290: */
}
/* L300: */
}
} else if (isym == 1) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
a_ref(i__, j) = dlatm2_(m, n, &i__, &j, kl, ku, &
idist, &iseed[1], &d__[1], &igrade, &dl[1], &
dr[1], &ipvtng, &iwork[1], sparse);
/* L310: */
}
/* L320: */
}
}
} else if (ipack == 1) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
for (i__ = 1; i__ <= i__2; ++i__) {
a_ref(i__, j) = dlatm2_(m, n, &i__, &j, kl, ku, &idist, &
iseed[1], &d__[1], &igrade, &dl[1], &dr[1], &
ipvtng, &iwork[1], sparse);
if (i__ != j) {
a_ref(j, i__) = 0.;
}
/* L330: */
}
/* L340: */
}
} else if (ipack == 2) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
for (i__ = 1; i__ <= i__2; ++i__) {
a_ref(j, i__) = dlatm2_(m, n, &i__, &j, kl, ku, &idist, &
iseed[1], &d__[1], &igrade, &dl[1], &dr[1], &
ipvtng, &iwork[1], sparse);
if (i__ != j) {
a_ref(i__, j) = 0.;
}
/* L350: */
}
/* L360: */
}
} else if (ipack == 3) {
isub = 0;
jsub = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
for (i__ = 1; i__ <= i__2; ++i__) {
++isub;
if (isub > *lda) {
isub = 1;
++jsub;
}
a_ref(isub, jsub) = dlatm2_(m, n, &i__, &j, kl, ku, &
idist, &iseed[1], &d__[1], &igrade, &dl[1], &dr[1]
, &ipvtng, &iwork[1], sparse);
/* L370: */
}
/* L380: */
}
} else if (ipack == 4) {
if (isym == 0) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Compute K = location of (I,J) entry in packed array */
if (i__ == 1) {
k = j;
} else {
k = *n * (*n + 1) / 2 - (*n - i__ + 1) * (*n -
i__ + 2) / 2 + j - i__ + 1;
}
/* Convert K to (ISUB,JSUB) location */
jsub = (k - 1) / *lda + 1;
isub = k - *lda * (jsub - 1);
a_ref(isub, jsub) = dlatm2_(m, n, &i__, &j, kl, ku, &
idist, &iseed[1], &d__[1], &igrade, &dl[1], &
dr[1], &ipvtng, &iwork[1], sparse);
/* L390: */
}
/* L400: */
}
} else {
isub = 0;
jsub = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = j; i__ <= i__2; ++i__) {
++isub;
if (isub > *lda) {
isub = 1;
++jsub;
}
a_ref(isub, jsub) = dlatm2_(m, n, &i__, &j, kl, ku, &
idist, &iseed[1], &d__[1], &igrade, &dl[1], &
dr[1], &ipvtng, &iwork[1], sparse);
/* L410: */
}
/* L420: */
}
}
} else if (ipack == 5) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
for (i__ = j - kuu; i__ <= i__2; ++i__) {
if (i__ < 1) {
a_ref(j - i__ + 1, i__ + *n) = 0.;
} else {
a_ref(j - i__ + 1, i__) = dlatm2_(m, n, &i__, &j, kl,
ku, &idist, &iseed[1], &d__[1], &igrade, &dl[
1], &dr[1], &ipvtng, &iwork[1], sparse);
}
/* L430: */
}
/* L440: */
}
} else if (ipack == 6) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
for (i__ = j - kuu; i__ <= i__2; ++i__) {
a_ref(i__ - j + kuu + 1, j) = dlatm2_(m, n, &i__, &j, kl,
ku, &idist, &iseed[1], &d__[1], &igrade, &dl[1], &
dr[1], &ipvtng, &iwork[1], sparse);
/* L450: */
}
/* L460: */
}
} else if (ipack == 7) {
if (isym == 0) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
for (i__ = j - kuu; i__ <= i__2; ++i__) {
a_ref(i__ - j + kuu + 1, j) = dlatm2_(m, n, &i__, &j,
kl, ku, &idist, &iseed[1], &d__[1], &igrade, &
dl[1], &dr[1], &ipvtng, &iwork[1], sparse);
if (i__ < 1) {
a_ref(j - i__ + 1 + kuu, i__ + *n) = 0.;
}
if (i__ >= 1 && i__ != j) {
a_ref(j - i__ + 1 + kuu, i__) = a_ref(i__ - j +
kuu + 1, j);
}
/* L470: */
}
/* L480: */
}
} else if (isym == 1) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j + kll;
for (i__ = j - kuu; i__ <= i__2; ++i__) {
a_ref(i__ - j + kuu + 1, j) = dlatm2_(m, n, &i__, &j,
kl, ku, &idist, &iseed[1], &d__[1], &igrade, &
dl[1], &dr[1], &ipvtng, &iwork[1], sparse);
/* L490: */
}
/* L500: */
}
}
}
}
/* 5) Scaling the norm */
if (ipack == 0) {
onorm = dlange_("M", m, n, &a[a_offset], lda, tempa);
} else if (ipack == 1) {
onorm = dlansy_("M", "U", n, &a[a_offset], lda, tempa);
} else if (ipack == 2) {
onorm = dlansy_("M", "L", n, &a[a_offset], lda, tempa);
} else if (ipack == 3) {
onorm = dlansp_("M", "U", n, &a[a_offset], tempa);
} else if (ipack == 4) {
onorm = dlansp_("M", "L", n, &a[a_offset], tempa);
} else if (ipack == 5) {
onorm = dlansb_("M", "L", n, &kll, &a[a_offset], lda, tempa);
} else if (ipack == 6) {
onorm = dlansb_("M", "U", n, &kuu, &a[a_offset], lda, tempa);
} else if (ipack == 7) {
onorm = dlangb_("M", n, &kll, &kuu, &a[a_offset], lda, tempa);
}
if (*anorm >= 0.) {
if (*anorm > 0. && onorm == 0.) {
/* Desired scaling impossible */
*info = 5;
return 0;
} else if (*anorm > 1. && onorm < 1. || *anorm < 1. && onorm > 1.) {
/* Scale carefully to avoid over / underflow */
if (ipack <= 2) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
d__1 = 1. / onorm;
dscal_(m, &d__1, &a_ref(1, j), &c__1);
dscal_(m, anorm, &a_ref(1, j), &c__1);
/* L510: */
}
} else if (ipack == 3 || ipack == 4) {
i__1 = *n * (*n + 1) / 2;
d__1 = 1. / onorm;
dscal_(&i__1, &d__1, &a[a_offset], &c__1);
i__1 = *n * (*n + 1) / 2;
dscal_(&i__1, anorm, &a[a_offset], &c__1);
} else if (ipack >= 5) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = kll + kuu + 1;
d__1 = 1. / onorm;
dscal_(&i__2, &d__1, &a_ref(1, j), &c__1);
i__2 = kll + kuu + 1;
dscal_(&i__2, anorm, &a_ref(1, j), &c__1);
/* L520: */
}
}
} else {
/* Scale straightforwardly */
if (ipack <= 2) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
d__1 = *anorm / onorm;
dscal_(m, &d__1, &a_ref(1, j), &c__1);
/* L530: */
}
} else if (ipack == 3 || ipack == 4) {
i__1 = *n * (*n + 1) / 2;
d__1 = *anorm / onorm;
dscal_(&i__1, &d__1, &a[a_offset], &c__1);
} else if (ipack >= 5) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = kll + kuu + 1;
d__1 = *anorm / onorm;
dscal_(&i__2, &d__1, &a_ref(1, j), &c__1);
/* L540: */
}
}
}
}
/* End of DLATMR */
return 0;
} /* dlatmr_ */