/* DECK ISDCGN */
integer isdcgn_(integer *n, doublereal *b, doublereal *x, integer *nelt,
integer *ia, integer *ja, doublereal *a, integer *isym, U_fp matvec,
S_fp mttvec, S_fp msolve, integer *itol, doublereal *tol, integer *
itmax, integer *iter, doublereal *err, integer *ierr, integer *iunit,
doublereal *r__, doublereal *z__, doublereal *p, doublereal *atp,
doublereal *atz, doublereal *dz, doublereal *atdz, doublereal *rwork,
integer *iwork, doublereal *ak, doublereal *bk, doublereal *bnrm,
doublereal *solnrm)
{
/* Format strings */
static char fmt_1000[] = "(\002 PCG Applied to the Normal Equations for"
" \002,\002N, ITOL = \002,i5,i5,/\002 ITER\002,\002 Error Estim"
"ate\002,\002 Alpha\002,\002 Beta\002)";
static char fmt_1010[] = "(1x,i4,1x,d16.7,1x,d16.7,1x,d16.7)";
/* System generated locals */
integer ret_val, i__1;
/* Local variables */
static integer i__;
extern doublereal dnrm2_(integer *, doublereal *, integer *), d1mach_(
integer *);
/* Fortran I/O blocks */
static cilist io___2 = { 0, 0, 0, fmt_1000, 0 };
static cilist io___3 = { 0, 0, 0, fmt_1010, 0 };
static cilist io___4 = { 0, 0, 0, fmt_1010, 0 };
/* ***BEGIN PROLOGUE ISDCGN */
/* ***SUBSIDIARY */
/* ***PURPOSE Preconditioned CG on Normal Equations Stop Test. */
/* This routine calculates the stop test for the Conjugate */
/* Gradient iteration scheme applied to the normal equations. */
/* It returns a non-zero if the error estimate (the type of */
/* which is determined by ITOL) is less than the user */
/* specified tolerance TOL. */
/* ***LIBRARY SLATEC (SLAP) */
/* ***CATEGORY D2A4, D2B4 */
/* ***TYPE DOUBLE PRECISION (ISSCGN-S, ISDCGN-D) */
/* ***KEYWORDS ITERATIVE PRECONDITION, NON-SYMMETRIC LINEAR SYSTEM, */
/* NORMAL EQUATIONS, SLAP, SPARSE */
/* ***AUTHOR Greenbaum, Anne, (Courant Institute) */
/* Seager, Mark K., (LLNL) */
/* Lawrence Livermore National Laboratory */
/* PO BOX 808, L-60 */
/* Livermore, CA 94550 (510) 423-3141 */
/* [email protected] */
/* ***DESCRIPTION */
/* *Usage: */
/* INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX, ITER */
/* INTEGER IERR, IUNIT, IWORK(USER DEFINED) */
/* DOUBLE PRECISION B(N), X(N), A(N), TOL, ERR, R(N), Z(N), P(N) */
/* DOUBLE PRECISION ATP(N), ATZ(N), DZ(N), ATDZ(N) */
/* DOUBLE PRECISION RWORK(USER DEFINED), AK, BK, BNRM, SOLNRM */
/* EXTERNAL MATVEC, MTTVEC, MSOLVE */
/* IF( ISTPCGN(N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MTTVEC, */
/* $ MSOLVE, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, Z, P, */
/* $ ATP, ATZ, DZ, ATDZ, RWORK, IWORK, AK, BK, BNRM, SOLNRM) */
/* $ .NE. 0 ) THEN ITERATION DONE */
/* *Arguments: */
/* N :IN Integer */
/* Order of the Matrix. */
/* B :IN Double Precision B(N). */
/* Right-hand side vector. */
/* X :IN Double Precision X(N). */
/* The current approximate solution vector. */
/* NELT :IN Integer. */
/* Number of Non-Zeros stored in A. */
/* IA :IN Integer IA(NELT). */
/* JA :IN Integer JA(NELT). */
/* A :IN Double Precision A(NELT). */
/* These arrays contain the matrix data structure for A. */
/* It could take any form. See "Description" in the */
/* DCGN routine. */
/* ISYM :IN Integer. */
/* Flag to indicate symmetric storage format. */
/* If ISYM=0, all non-zero entries of the matrix are stored. */
/* If ISYM=1, the matrix is symmetric, and only the upper */
/* or lower triangle of the matrix is stored. */
/* MATVEC :EXT External. */
/* Name of a routine which performs the matrix vector multiply */
/* Y = A*X given A and X. The name of the MATVEC routine must */
/* be declared external in the calling program. The calling */
/* sequence to MATVEC is: */
/* CALL MATVEC( N, X, Y, NELT, IA, JA, A, ISYM ) */
/* Where N is the number of unknowns, Y is the product A*X */
/* upon return X is an input vector, NELT is the number of */
/* non-zeros in the SLAP-Column IA, JA, A storage for the matrix */
/* A. ISYM is a flag which, if non-zero, denotes that A is */
/* symmetric and only the lower or upper triangle is stored. */
/* MTTVEC :EXT External. */
/* Name of a routine which performs the matrix transpose vector */
/* multiply y = A'*X given A and X (where ' denotes transpose). */
/* The name of the MTTVEC routine must be declared external in */
/* the calling program. The calling sequence to MTTVEC is the */
/* same as that for MATVEC, viz.: */
/* CALL MTTVEC( N, X, Y, NELT, IA, JA, A, ISYM ) */
/* Where N is the number of unknowns, Y is the product A'*X */
/* upon return X is an input vector, NELT is the number of */
/* non-zeros in the SLAP-Column IA, JA, A storage for the matrix */
/* A. ISYM is a flag which, if non-zero, denotes that A is */
/* symmetric and only the lower or upper triangle is stored. */
/* MSOLVE :EXT External. */
/* Name of a routine which solves a linear system MZ = R for */
/* Z given R with the preconditioning matrix M (M is supplied via */
/* RWORK and IWORK arrays). The name of the MSOLVE routine must */
/* be declared external in the calling program. The calling */
/* sequence to MSOLVE is: */
/* CALL MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) */
/* Where N is the number of unknowns, R is the right-hand side */
/* vector and Z is the solution upon return. NELT, IA, JA, A and */
/* ISYM are defined as above. RWORK is a double precision array */
/* that can be used to pass necessary preconditioning information */
/* and/or workspace to MSOLVE. IWORK is an integer work array */
/* for the same purpose as RWORK. */
/* ITOL :IN Integer. */
/* Flag to indicate type of convergence criterion. */
/* If ITOL=1, iteration stops when the 2-norm of the residual */
/* divided by the 2-norm of the right-hand side is less than TOL. */
/* If ITOL=2, iteration stops when the 2-norm of M-inv times the */
/* residual divided by the 2-norm of M-inv times the right hand */
/* side is less than TOL, where M-inv is the inverse of the */
/* diagonal of A. */
/* ITOL=11 is often useful for checking and comparing different */
/* routines. For this case, the user must supply the "exact" */
/* solution or a very accurate approximation (one with an error */
/* much less than TOL) through a common block, */
/* COMMON /DSLBLK/ SOLN( ) */
/* If ITOL=11, iteration stops when the 2-norm of the difference */
/* between the iterative approximation and the user-supplied */
/* solution divided by the 2-norm of the user-supplied solution */
/* is less than TOL. Note that this requires the user to set up */
/* the "COMMON /DSLBLK/ SOLN(LENGTH)" in the calling routine. */
/* The routine with this declaration should be loaded before the */
/* stop test so that the correct length is used by the loader. */
/* This procedure is not standard Fortran and may not work */
/* correctly on your system (although it has worked on every */
/* system the authors have tried). If ITOL is not 11 then this */
/* common block is indeed standard Fortran. */
/* TOL :IN Double Precision. */
/* Convergence criterion, as described above. */
/* ITMAX :IN Integer. */
/* Maximum number of iterations. */
/* ITER :IN Integer. */
/* Current iteration count. (Must be zero on first call.) */
/* ERR :OUT Double Precision. */
/* Error estimate of error in the X(N) approximate solution, as */
/* defined by ITOL. */
/* IERR :OUT Integer. */
/* Error flag. IERR is set to 3 if ITOL is not one of the */
/* acceptable values, see above. */
/* IUNIT :IN Integer. */
/* Unit number on which to write the error at each iteration, */
/* if this is desired for monitoring convergence. If unit */
/* number is 0, no writing will occur. */
/* R :IN Double Precision R(N). */
/* The residual R = B-AX. */
/* Z :WORK Double Precision Z(N). */
/* Double Precision array used for workspace. */
/* P :IN Double Precision P(N). */
/* The conjugate direction vector. */
/* ATP :IN Double Precision ATP(N). */
/* A-transpose times the conjugate direction vector. */
/* ATZ :IN Double Precision ATZ(N). */
/* A-transpose times the pseudo-residual. */
/* DZ :IN Double Precision DZ(N). */
/* Workspace used to hold temporary vector(s). */
/* ATDZ :WORK Double Precision ATDZ(N). */
/* Workspace. */
/* RWORK :WORK Double Precision RWORK(USER DEFINED). */
/* Double Precision array that can be used by MSOLVE. */
/* IWORK :WORK Integer IWORK(USER DEFINED). */
/* Integer array that can be used by MSOLVE. */
/* AK :IN Double Precision. */
/* BK :IN Double Precision. */
/* Current conjugate gradient parameters alpha and beta. */
/* BNRM :INOUT Double Precision. */
/* Norm of the right hand side. Type of norm depends on ITOL. */
/* Calculated only on the first call. */
/* SOLNRM :INOUT Double Precision. */
/* 2-Norm of the true solution, SOLN. Only computed and used */
/* if ITOL = 11. */
/* *Function Return Values: */
/* 0 : Error estimate (determined by ITOL) is *NOT* less than the */
/* specified tolerance, TOL. The iteration must continue. */
/* 1 : Error estimate (determined by ITOL) is less than the */
/* specified tolerance, TOL. The iteration can be considered */
/* complete. */
/* *Cautions: */
/* This routine will attempt to write to the Fortran logical output */
/* unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that */
/* this logical unit is attached to a file or terminal before calling */
/* this routine with a non-zero value for IUNIT. This routine does */
/* not check for the validity of a non-zero IUNIT unit number. */
/* ***SEE ALSO DCGN */
/* ***ROUTINES CALLED D1MACH, DNRM2 */
/* ***COMMON BLOCKS DSLBLK */
/* ***REVISION HISTORY (YYMMDD) */
/* 890404 DATE WRITTEN */
/* 890404 Previous REVISION DATE */
/* 890915 Made changes requested at July 1989 CML Meeting. (MKS) */
/* 890922 Numerous changes to prologue to make closer to SLATEC */
/* standard. (FNF) */
/* 890929 Numerous changes to reduce SP/DP differences. (FNF) */
/* 891003 Removed C***REFER TO line, per MKS. */
/* 910411 Prologue converted to Version 4.0 format. (BAB) */
/* 910502 Removed MATVEC, MTTVEC and MSOLVE from ROUTINES CALLED */
/* list. (FNF) */
/* 910506 Made subsidiary to DCGN. (FNF) */
/* 920407 COMMON BLOCK renamed DSLBLK. (WRB) */
/* 920511 Added complete declaration section. (WRB) */
/* 920930 Corrected to not print AK,BK when ITER=0. (FNF) */
/* 921026 Changed 1.0E10 to D1MACH(2) and corrected D to E in */
/* output format. (FNF) */
/* 921113 Corrected C***CATEGORY line. (FNF) */
/* ***END PROLOGUE ISDCGN */
/* .. Scalar Arguments .. */
/* .. Array Arguments .. */
/* .. Subroutine Arguments .. */
/* .. Arrays in Common .. */
/* .. Local Scalars .. */
/* .. External Functions .. */
/* .. Common blocks .. */
/* ***FIRST EXECUTABLE STATEMENT ISDCGN */
/* Parameter adjustments */
--atdz;
--dz;
--atz;
--atp;
--p;
--z__;
--r__;
--a;
--x;
--b;
--ja;
--ia;
--rwork;
--iwork;
/* Function Body */
ret_val = 0;
if (*itol == 1) {
/* err = ||Residual||/||RightHandSide|| (2-Norms). */
if (*iter == 0) {
*bnrm = dnrm2_(n, &b[1], &c__1);
}
*err = dnrm2_(n, &r__[1], &c__1) / *bnrm;
} else if (*itol == 2) {
/* -1 -1 */
/* err = ||M Residual||/||M RightHandSide|| (2-Norms). */
if (*iter == 0) {
(*msolve)(n, &b[1], &dz[1], nelt, &ia[1], &ja[1], &a[1], isym, &
rwork[1], &iwork[1]);
(*mttvec)(n, &dz[1], &atdz[1], nelt, &ia[1], &ja[1], &a[1], isym);
*bnrm = dnrm2_(n, &atdz[1], &c__1);
}
*err = dnrm2_(n, &atz[1], &c__1) / *bnrm;
} else if (*itol == 11) {
/* err = ||x-TrueSolution||/||TrueSolution|| (2-Norms). */
if (*iter == 0) {
*solnrm = dnrm2_(n, dslblk_1.soln, &c__1);
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
dz[i__] = x[i__] - dslblk_1.soln[i__ - 1];
/* L10: */
}
*err = dnrm2_(n, &dz[1], &c__1) / *solnrm;
} else {
/* If we get here ITOL is not one of the acceptable values. */
*err = d1mach_(&c__2);
*ierr = 3;
}
if (*iunit != 0) {
if (*iter == 0) {
io___2.ciunit = *iunit;
s_wsfe(&io___2);
do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&(*itol), (ftnlen)sizeof(integer));
e_wsfe();
io___3.ciunit = *iunit;
s_wsfe(&io___3);
do_fio(&c__1, (char *)&(*iter), (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&(*err), (ftnlen)sizeof(doublereal));
e_wsfe();
} else {
io___4.ciunit = *iunit;
s_wsfe(&io___4);
do_fio(&c__1, (char *)&(*iter), (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&(*err), (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&(*ak), (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&(*bk), (ftnlen)sizeof(doublereal));
e_wsfe();
}
}
if (*err <= *tol) {
ret_val = 1;
}
return ret_val;
/* ------------- LAST LINE OF ISDCGN FOLLOWS ---------------------------- */
} /* isdcgn_ */
/* Subroutine */ int ddrvsp_(logical *dotype, integer *nn, integer *nval,
integer *nrhs, doublereal *thresh, logical *tsterr, integer *nmax,
doublereal *a, doublereal *afac, doublereal *ainv, doublereal *b,
doublereal *x, doublereal *xact, doublereal *work, doublereal *rwork,
integer *iwork, integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
static char facts[1*2] = "F" "N";
/* Format strings */
static char fmt_9999[] = "(1x,a6,\002, UPLO='\002,a1,\002', N =\002,i5"
",\002, type \002,i2,\002, test \002,i2,\002, ratio =\002,g12.5)";
static char fmt_9998[] = "(1x,a6,\002, FACT='\002,a1,\002', UPLO='\002,a"
"1,\002', N =\002,i5,\002, type \002,i2,\002, test \002,i2,\002, "
"ratio =\002,g12.5)";
/* System generated locals */
address a__1[2];
integer i__1, i__2, i__3, i__4, i__5[2];
char ch__1[2];
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
/* Local variables */
integer i__, j, k, n, i1, i2, k1, in, kl, ku, nt, lda, npp;
char fact[1];
integer ioff, mode, imat, info;
char path[3], dist[1], uplo[1], type__[1];
integer nrun, ifact;
extern /* Subroutine */ int dget04_(integer *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, doublereal *);
integer nfail, iseed[4];
extern doublereal dget06_(doublereal *, doublereal *);
doublereal rcond;
integer nimat;
extern /* Subroutine */ int dppt02_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *), dspt01_(char *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *);
doublereal anorm;
extern /* Subroutine */ int dppt05_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *), dcopy_(integer *, doublereal *, integer *, doublereal *,
integer *);
integer iuplo, izero, nerrs, lwork;
extern /* Subroutine */ int dspsv_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, integer *);
logical zerot;
char xtype[1];
extern /* Subroutine */ int dlatb4_(char *, integer *, integer *, integer
*, char *, integer *, integer *, doublereal *, integer *,
doublereal *, char *), aladhd_(integer *,
char *), alaerh_(char *, char *, integer *, integer *,
char *, integer *, integer *, integer *, integer *, integer *,
integer *, integer *, integer *, integer *);
doublereal rcondc;
char packit[1];
extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *),
dlarhs_(char *, char *, char *, char *, integer *, integer *,
integer *, integer *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, integer *, integer *,
integer *), dlaset_(char *,
integer *, integer *, doublereal *, doublereal *, doublereal *,
integer *);
extern doublereal dlansp_(char *, char *, integer *, doublereal *,
doublereal *);
extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
*, integer *);
doublereal cndnum;
extern /* Subroutine */ int dlatms_(integer *, integer *, char *, integer
*, char *, doublereal *, integer *, doublereal *, doublereal *,
integer *, integer *, char *, doublereal *, integer *, doublereal
*, integer *);
doublereal ainvnm;
extern /* Subroutine */ int dsptrf_(char *, integer *, doublereal *,
integer *, integer *), dsptri_(char *, integer *,
doublereal *, integer *, doublereal *, integer *),
derrvx_(char *, integer *);
doublereal result[6];
extern /* Subroutine */ int dspsvx_(char *, char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *,
doublereal *, integer *, integer *);
/* Fortran I/O blocks */
static cilist io___41 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___44 = { 0, 0, 0, fmt_9998, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DDRVSP tests the driver routines DSPSV and -SVX. */
/* Arguments */
/* ========= */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* The matrix types to be used for testing. Matrices of type j */
/* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = */
/* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. */
/* NN (input) INTEGER */
/* The number of values of N contained in the vector NVAL. */
/* NVAL (input) INTEGER array, dimension (NN) */
/* The values of the matrix dimension N. */
/* NRHS (input) INTEGER */
/* The number of right hand side vectors to be generated for */
/* each linear system. */
/* THRESH (input) DOUBLE PRECISION */
/* The threshold value for the test ratios. A result is */
/* included in the output file if RESULT >= THRESH. To have */
/* every test ratio printed, use THRESH = 0. */
/* TSTERR (input) LOGICAL */
/* Flag that indicates whether error exits are to be tested. */
/* NMAX (input) INTEGER */
/* The maximum value permitted for N, used in dimensioning the */
/* work arrays. */
/* A (workspace) DOUBLE PRECISION array, dimension */
/* (NMAX*(NMAX+1)/2) */
/* AFAC (workspace) DOUBLE PRECISION array, dimension */
/* (NMAX*(NMAX+1)/2) */
/* AINV (workspace) DOUBLE PRECISION array, dimension */
/* (NMAX*(NMAX+1)/2) */
/* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
/* X (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
/* XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
/* WORK (workspace) DOUBLE PRECISION array, dimension */
/* (NMAX*max(2,NRHS)) */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (NMAX+2*NRHS) */
/* IWORK (workspace) INTEGER array, dimension (2*NMAX) */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--iwork;
--rwork;
--work;
--xact;
--x;
--b;
--ainv;
--afac;
--a;
--nval;
--dotype;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* Initialize constants and the random number seed. */
s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
s_copy(path + 1, "SP", (ftnlen)2, (ftnlen)2);
nrun = 0;
nfail = 0;
nerrs = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
}
/* Computing MAX */
i__1 = *nmax << 1, i__2 = *nmax * *nrhs;
lwork = max(i__1,i__2);
/* Test the error exits */
if (*tsterr) {
derrvx_(path, nout);
}
infoc_1.infot = 0;
/* Do for each value of N in NVAL */
i__1 = *nn;
for (in = 1; in <= i__1; ++in) {
n = nval[in];
lda = max(n,1);
npp = n * (n + 1) / 2;
*(unsigned char *)xtype = 'N';
nimat = 10;
if (n <= 0) {
nimat = 1;
}
i__2 = nimat;
for (imat = 1; imat <= i__2; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (! dotype[imat]) {
goto L170;
}
/* Skip types 3, 4, 5, or 6 if the matrix size is too small. */
zerot = imat >= 3 && imat <= 6;
if (zerot && n < imat - 2) {
goto L170;
}
/* Do first for UPLO = 'U', then for UPLO = 'L' */
for (iuplo = 1; iuplo <= 2; ++iuplo) {
if (iuplo == 1) {
*(unsigned char *)uplo = 'U';
*(unsigned char *)packit = 'C';
} else {
*(unsigned char *)uplo = 'L';
*(unsigned char *)packit = 'R';
}
/* Set up parameters with DLATB4 and generate a test matrix */
/* with DLATMS. */
dlatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode,
&cndnum, dist);
s_copy(srnamc_1.srnamt, "DLATMS", (ftnlen)6, (ftnlen)6);
dlatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
cndnum, &anorm, &kl, &ku, packit, &a[1], &lda, &work[
1], &info);
/* Check error code from DLATMS. */
if (info != 0) {
alaerh_(path, "DLATMS", &info, &c__0, uplo, &n, &n, &c_n1,
&c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
goto L160;
}
/* For types 3-6, zero one or more rows and columns of the */
/* matrix to test that INFO is returned correctly. */
if (zerot) {
if (imat == 3) {
izero = 1;
} else if (imat == 4) {
izero = n;
} else {
izero = n / 2 + 1;
}
if (imat < 6) {
/* Set row and column IZERO to zero. */
if (iuplo == 1) {
ioff = (izero - 1) * izero / 2;
i__3 = izero - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
a[ioff + i__] = 0.;
/* L20: */
}
ioff += izero;
i__3 = n;
for (i__ = izero; i__ <= i__3; ++i__) {
a[ioff] = 0.;
ioff += i__;
/* L30: */
}
} else {
ioff = izero;
i__3 = izero - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
a[ioff] = 0.;
ioff = ioff + n - i__;
/* L40: */
}
ioff -= izero;
i__3 = n;
for (i__ = izero; i__ <= i__3; ++i__) {
a[ioff + i__] = 0.;
/* L50: */
}
}
} else {
ioff = 0;
if (iuplo == 1) {
/* Set the first IZERO rows and columns to zero. */
i__3 = n;
for (j = 1; j <= i__3; ++j) {
i2 = min(j,izero);
i__4 = i2;
for (i__ = 1; i__ <= i__4; ++i__) {
a[ioff + i__] = 0.;
/* L60: */
}
ioff += j;
/* L70: */
}
} else {
/* Set the last IZERO rows and columns to zero. */
i__3 = n;
for (j = 1; j <= i__3; ++j) {
i1 = max(j,izero);
i__4 = n;
for (i__ = i1; i__ <= i__4; ++i__) {
a[ioff + i__] = 0.;
/* L80: */
}
ioff = ioff + n - j;
/* L90: */
}
}
}
} else {
izero = 0;
}
for (ifact = 1; ifact <= 2; ++ifact) {
/* Do first for FACT = 'F', then for other values. */
*(unsigned char *)fact = *(unsigned char *)&facts[ifact -
1];
/* Compute the condition number for comparison with */
/* the value returned by DSPSVX. */
if (zerot) {
if (ifact == 1) {
goto L150;
}
rcondc = 0.;
} else if (ifact == 1) {
/* Compute the 1-norm of A. */
anorm = dlansp_("1", uplo, &n, &a[1], &rwork[1]);
/* Factor the matrix A. */
dcopy_(&npp, &a[1], &c__1, &afac[1], &c__1);
dsptrf_(uplo, &n, &afac[1], &iwork[1], &info);
/* Compute inv(A) and take its norm. */
dcopy_(&npp, &afac[1], &c__1, &ainv[1], &c__1);
dsptri_(uplo, &n, &ainv[1], &iwork[1], &work[1], &
info);
ainvnm = dlansp_("1", uplo, &n, &ainv[1], &rwork[1]);
/* Compute the 1-norm condition number of A. */
if (anorm <= 0. || ainvnm <= 0.) {
rcondc = 1.;
} else {
rcondc = 1. / anorm / ainvnm;
}
}
/* Form an exact solution and set the right hand side. */
s_copy(srnamc_1.srnamt, "DLARHS", (ftnlen)6, (ftnlen)6);
dlarhs_(path, xtype, uplo, " ", &n, &n, &kl, &ku, nrhs, &
a[1], &lda, &xact[1], &lda, &b[1], &lda, iseed, &
info);
*(unsigned char *)xtype = 'C';
/* --- Test DSPSV --- */
if (ifact == 2) {
dcopy_(&npp, &a[1], &c__1, &afac[1], &c__1);
dlacpy_("Full", &n, nrhs, &b[1], &lda, &x[1], &lda);
/* Factor the matrix and solve the system using DSPSV. */
s_copy(srnamc_1.srnamt, "DSPSV ", (ftnlen)6, (ftnlen)
6);
dspsv_(uplo, &n, nrhs, &afac[1], &iwork[1], &x[1], &
lda, &info);
/* Adjust the expected value of INFO to account for */
/* pivoting. */
k = izero;
if (k > 0) {
L100:
if (iwork[k] < 0) {
if (iwork[k] != -k) {
k = -iwork[k];
goto L100;
}
} else if (iwork[k] != k) {
k = iwork[k];
goto L100;
}
}
/* Check error code from DSPSV . */
if (info != k) {
alaerh_(path, "DSPSV ", &info, &k, uplo, &n, &n, &
c_n1, &c_n1, nrhs, &imat, &nfail, &nerrs,
nout);
goto L120;
} else if (info != 0) {
goto L120;
}
/* Reconstruct matrix from factors and compute */
/* residual. */
dspt01_(uplo, &n, &a[1], &afac[1], &iwork[1], &ainv[1]
, &lda, &rwork[1], result);
/* Compute residual of the computed solution. */
dlacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &lda);
dppt02_(uplo, &n, nrhs, &a[1], &x[1], &lda, &work[1],
&lda, &rwork[1], &result[1]);
/* Check solution from generated exact solution. */
dget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[2]);
nt = 3;
/* Print information about the tests that did not pass */
/* the threshold. */
i__3 = nt;
for (k = 1; k <= i__3; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
io___41.ciunit = *nout;
s_wsfe(&io___41);
do_fio(&c__1, "DSPSV ", (ftnlen)6);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
sizeof(doublereal));
e_wsfe();
++nfail;
}
/* L110: */
}
nrun += nt;
L120:
;
}
/* --- Test DSPSVX --- */
if (ifact == 2 && npp > 0) {
dlaset_("Full", &npp, &c__1, &c_b59, &c_b59, &afac[1],
&npp);
}
dlaset_("Full", &n, nrhs, &c_b59, &c_b59, &x[1], &lda);
/* Solve the system and compute the condition number and */
/* error bounds using DSPSVX. */
s_copy(srnamc_1.srnamt, "DSPSVX", (ftnlen)6, (ftnlen)6);
dspsvx_(fact, uplo, &n, nrhs, &a[1], &afac[1], &iwork[1],
&b[1], &lda, &x[1], &lda, &rcond, &rwork[1], &
rwork[*nrhs + 1], &work[1], &iwork[n + 1], &info);
/* Adjust the expected value of INFO to account for */
/* pivoting. */
k = izero;
if (k > 0) {
L130:
if (iwork[k] < 0) {
if (iwork[k] != -k) {
k = -iwork[k];
goto L130;
}
} else if (iwork[k] != k) {
k = iwork[k];
goto L130;
}
}
/* Check the error code from DSPSVX. */
if (info != k) {
/* Writing concatenation */
i__5[0] = 1, a__1[0] = fact;
i__5[1] = 1, a__1[1] = uplo;
s_cat(ch__1, a__1, i__5, &c__2, (ftnlen)2);
alaerh_(path, "DSPSVX", &info, &k, ch__1, &n, &n, &
c_n1, &c_n1, nrhs, &imat, &nfail, &nerrs,
nout);
goto L150;
}
if (info == 0) {
if (ifact >= 2) {
/* Reconstruct matrix from factors and compute */
/* residual. */
dspt01_(uplo, &n, &a[1], &afac[1], &iwork[1], &
ainv[1], &lda, &rwork[(*nrhs << 1) + 1],
result);
k1 = 1;
} else {
k1 = 2;
}
/* Compute residual of the computed solution. */
dlacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &lda);
dppt02_(uplo, &n, nrhs, &a[1], &x[1], &lda, &work[1],
&lda, &rwork[(*nrhs << 1) + 1], &result[1]);
/* Check solution from generated exact solution. */
dget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[2]);
/* Check the error bounds from iterative refinement. */
dppt05_(uplo, &n, nrhs, &a[1], &b[1], &lda, &x[1], &
lda, &xact[1], &lda, &rwork[1], &rwork[*nrhs
+ 1], &result[3]);
} else {
k1 = 6;
}
/* Compare RCOND from DSPSVX with the computed value */
/* in RCONDC. */
result[5] = dget06_(&rcond, &rcondc);
/* Print information about the tests that did not pass */
/* the threshold. */
for (k = k1; k <= 6; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
io___44.ciunit = *nout;
s_wsfe(&io___44);
do_fio(&c__1, "DSPSVX", (ftnlen)6);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
sizeof(doublereal));
e_wsfe();
++nfail;
}
/* L140: */
}
nrun = nrun + 7 - k1;
L150:
;
}
L160:
;
}
L170:
;
}
/* L180: */
}
/* Print a summary of the results. */
alasvm_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of DDRVSP */
} /* ddrvsp_ */
/* Subroutine */ int sdrgsx_(integer *nsize, integer *ncmax, real *thresh,
integer *nin, integer *nout, real *a, integer *lda, real *b, real *ai,
real *bi, real *z__, real *q, real *alphar, real *alphai, real *beta,
real *c__, integer *ldc, real *s, real *work, integer *lwork,
integer *iwork, integer *liwork, logical *bwork, integer *info)
{
/* Format strings */
static char fmt_9999[] = "(\002 SDRGSX: \002,a,\002 returned INFO=\002,i"
"6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002)\002)";
static char fmt_9997[] = "(\002 SDRGSX: SGET53 returned INFO=\002,i1,"
"\002 for eigenvalue \002,i6,\002.\002,/9x,\002N=\002,i6,\002, JT"
"YPE=\002,i6,\002)\002)";
static char fmt_9996[] = "(\002 SDRGSX: S not in Schur form at eigenvalu"
"e \002,i6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002"
")\002)";
static char fmt_9995[] = "(/1x,a3,\002 -- Real Expert Generalized Schur "
"form\002,\002 problem driver\002)";
static char fmt_9993[] = "(\002 Matrix types: \002,/\002 1: A is a blo"
"ck diagonal matrix of Jordan blocks \002,\002and B is the identi"
"ty \002,/\002 matrix, \002,/\002 2: A and B are upper tri"
"angular matrices, \002,/\002 3: A and B are as type 2, but eac"
"h second diagonal \002,\002block in A_11 and \002,/\002 eac"
"h third diaongal block in A_22 are 2x2 blocks,\002,/\002 4: A "
"and B are block diagonal matrices, \002,/\002 5: (A,B) has pot"
"entially close or common \002,\002eigenvalues.\002,/)";
static char fmt_9992[] = "(/\002 Tests performed: (S is Schur, T is tri"
"angular, \002,\002Q and Z are \002,a,\002,\002,/19x,\002 a is al"
"pha, b is beta, and \002,a,\002 means \002,a,\002.)\002,/\002 1"
" = | A - Q S Z\002,a,\002 | / ( |A| n ulp ) 2 = | B - Q T "
"Z\002,a,\002 | / ( |B| n ulp )\002,/\002 3 = | I - QQ\002,a,"
"\002 | / ( n ulp ) 4 = | I - ZZ\002,a,\002 | / ( n u"
"lp )\002,/\002 5 = 1/ULP if A is not in \002,\002Schur form "
"S\002,/\002 6 = difference between (alpha,beta)\002,\002 and di"
"agonals of (S,T)\002,/\002 7 = 1/ULP if SDIM is not the correc"
"t number of \002,\002selected eigenvalues\002,/\002 8 = 1/ULP "
"if DIFEST/DIFTRU > 10*THRESH or \002,\002DIFTRU/DIFEST > 10*THRE"
"SH\002,/\002 9 = 1/ULP if DIFEST <> 0 or DIFTRU > ULP*norm(A,B"
") \002,\002when reordering fails\002,/\002 10 = 1/ULP if PLEST/"
"PLTRU > THRESH or \002,\002PLTRU/PLEST > THRESH\002,/\002 ( T"
"est 10 is only for input examples )\002,/)";
static char fmt_9991[] = "(\002 Matrix order=\002,i2,\002, type=\002,i2"
",\002, a=\002,e10.4,\002, order(A_11)=\002,i2,\002, result \002,"
"i2,\002 is \002,0p,f8.2)";
static char fmt_9990[] = "(\002 Matrix order=\002,i2,\002, type=\002,i2"
",\002, a=\002,e10.4,\002, order(A_11)=\002,i2,\002, result \002,"
"i2,\002 is \002,0p,e10.4)";
static char fmt_9998[] = "(\002 SDRGSX: \002,a,\002 returned INFO=\002,i"
"6,\002.\002,/9x,\002N=\002,i6,\002, Input Example #\002,i2,\002"
")\002)";
static char fmt_9994[] = "(\002Input Example\002)";
static char fmt_9989[] = "(\002 Input example #\002,i2,\002, matrix orde"
"r=\002,i4,\002,\002,\002 result \002,i2,\002 is\002,0p,f8.2)";
static char fmt_9988[] = "(\002 Input example #\002,i2,\002, matrix orde"
"r=\002,i4,\002,\002,\002 result \002,i2,\002 is\002,1p,e10.3)";
/* System generated locals */
integer a_dim1, a_offset, ai_dim1, ai_offset, b_dim1, b_offset, bi_dim1,
bi_offset, c_dim1, c_offset, q_dim1, q_offset, z_dim1, z_offset,
i__1, i__2, i__3, i__4;
real r__1, r__2, r__3, r__4, r__5, r__6, r__7, r__8, r__9, r__10;
/* Builtin functions */
double sqrt(doublereal);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_rsle(void);
/* Local variables */
static real temp1, temp2;
static integer i__, j;
static real abnrm;
static integer ifunc, iinfo, linfo;
extern /* Subroutine */ int sget51_(integer *, integer *, real *, integer
*, real *, integer *, real *, integer *, real *, integer *, real *
, real *), sget53_(real *, integer *, real *, integer *, real *,
real *, real *, real *, integer *);
static char sense[1];
static integer nerrs, i1, ntest;
static real pltru;
extern /* Subroutine */ int slakf2_(integer *, integer *, real *, integer
*, real *, real *, real *, real *, integer *), slatm5_(integer *,
integer *, integer *, real *, integer *, real *, integer *, real *
, integer *, real *, integer *, real *, integer *, real *,
integer *, real *, integer *, real *, integer *, real *, integer *
, integer *);
static logical ilabad;
static real thrsh2;
extern /* Subroutine */ int slabad_(real *, real *);
static integer mm, bdspac;
static real pl[2];
extern doublereal slamch_(char *), slange_(char *, integer *,
integer *, real *, integer *, real *);
extern /* Subroutine */ int xerbla_(char *, integer *);
static real difest[2];
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
static real bignum;
extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
*, integer *);
static real weight;
extern /* Subroutine */ int sgesvd_(char *, char *, integer *, integer *,
real *, integer *, real *, real *, integer *, real *, integer *,
real *, integer *, integer *), slacpy_(char *,
integer *, integer *, real *, integer *, real *, integer *);
static real diftru;
extern /* Subroutine */ int slaset_(char *, integer *, integer *, real *,
real *, real *, integer *), sggesx_(char *, char *, char *
, L_fp, char *, integer *, real *, integer *, real *, integer *,
integer *, real *, real *, real *, real *, integer *, real *,
integer *, real *, real *, real *, integer *, integer *, integer *
, logical *, integer *);
static integer minwrk, maxwrk;
static real smlnum;
static integer mn2, nptknt;
static real ulpinv, result[10];
static integer ntestt;
extern logical slctsx_();
static integer prtype, qba, qbb;
static real ulp;
/* Fortran I/O blocks */
static cilist io___22 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___31 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___32 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___35 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___36 = { 0, 0, 0, fmt_9993, 0 };
static cilist io___37 = { 0, 0, 0, fmt_9992, 0 };
static cilist io___39 = { 0, 0, 0, fmt_9991, 0 };
static cilist io___40 = { 0, 0, 0, fmt_9990, 0 };
static cilist io___42 = { 0, 0, 1, 0, 0 };
static cilist io___43 = { 0, 0, 1, 0, 0 };
static cilist io___44 = { 0, 0, 0, 0, 0 };
static cilist io___45 = { 0, 0, 0, 0, 0 };
static cilist io___46 = { 0, 0, 0, 0, 0 };
static cilist io___48 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___49 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___50 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___51 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___52 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___53 = { 0, 0, 0, fmt_9992, 0 };
static cilist io___54 = { 0, 0, 0, fmt_9989, 0 };
static cilist io___55 = { 0, 0, 0, fmt_9988, 0 };
#define ai_ref(a_1,a_2) ai[(a_2)*ai_dim1 + a_1]
#define bi_ref(a_1,a_2) bi[(a_2)*bi_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
October 31, 1999
Purpose
=======
SDRGSX checks the nonsymmetric generalized eigenvalue (Schur form)
problem expert driver SGGESX.
SGGESX factors A and B as Q S Z' and Q T Z', where ' means
transpose, T is upper triangular, S is in generalized Schur form
(block upper triangular, with 1x1 and 2x2 blocks on the diagonal,
the 2x2 blocks corresponding to complex conjugate pairs of
generalized eigenvalues), and Q and Z are orthogonal. It also
computes the generalized eigenvalues (alpha(1),beta(1)), ...,
(alpha(n),beta(n)). Thus, w(j) = alpha(j)/beta(j) is a root of the
characteristic equation
det( A - w(j) B ) = 0
Optionally it also reorders the eigenvalues so that a selected
cluster of eigenvalues appears in the leading diagonal block of the
Schur forms; computes a reciprocal condition number for the average
of the selected eigenvalues; and computes a reciprocal condition
number for the right and left deflating subspaces corresponding to
the selected eigenvalues.
When SDRGSX is called with NSIZE > 0, five (5) types of built-in
matrix pairs are used to test the routine SGGESX.
When SDRGSX is called with NSIZE = 0, it reads in test matrix data
to test SGGESX.
For each matrix pair, the following tests will be performed and
compared with the threshhold THRESH except for the tests (7) and (9):
(1) | A - Q S Z' | / ( |A| n ulp )
(2) | B - Q T Z' | / ( |B| n ulp )
(3) | I - QQ' | / ( n ulp )
(4) | I - ZZ' | / ( n ulp )
(5) if A is in Schur form (i.e. quasi-triangular form)
(6) maximum over j of D(j) where:
if alpha(j) is real:
|alpha(j) - S(j,j)| |beta(j) - T(j,j)|
D(j) = ------------------------ + -----------------------
max(|alpha(j)|,|S(j,j)|) max(|beta(j)|,|T(j,j)|)
if alpha(j) is complex:
| det( s S - w T ) |
D(j) = ---------------------------------------------------
ulp max( s norm(S), |w| norm(T) )*norm( s S - w T )
and S and T are here the 2 x 2 diagonal blocks of S and T
corresponding to the j-th and j+1-th eigenvalues.
(7) if sorting worked and SDIM is the number of eigenvalues
which were selected.
(8) the estimated value DIF does not differ from the true values of
Difu and Difl more than a factor 10*THRESH. If the estimate DIF
equals zero the corresponding true values of Difu and Difl
should be less than EPS*norm(A, B). If the true value of Difu
and Difl equal zero, the estimate DIF should be less than
EPS*norm(A, B).
(9) If INFO = N+3 is returned by SGGESX, the reordering "failed"
and we check that DIF = PL = PR = 0 and that the true value of
Difu and Difl is < EPS*norm(A, B). We count the events when
INFO=N+3.
For read-in test matrices, the above tests are run except that the
exact value for DIF (and PL) is input data. Additionally, there is
one more test run for read-in test matrices:
(10) the estimated value PL does not differ from the true value of
PLTRU more than a factor THRESH. If the estimate PL equals
zero the corresponding true value of PLTRU should be less than
EPS*norm(A, B). If the true value of PLTRU equal zero, the
estimate PL should be less than EPS*norm(A, B).
Note that for the built-in tests, a total of 10*NSIZE*(NSIZE-1)
matrix pairs are generated and tested. NSIZE should be kept small.
SVD (routine SGESVD) is used for computing the true value of DIF_u
and DIF_l when testing the built-in test problems.
Built-in Test Matrices
======================
All built-in test matrices are the 2 by 2 block of triangular
matrices
A = [ A11 A12 ] and B = [ B11 B12 ]
[ A22 ] [ B22 ]
where for different type of A11 and A22 are given as the following.
A12 and B12 are chosen so that the generalized Sylvester equation
A11*R - L*A22 = -A12
B11*R - L*B22 = -B12
have prescribed solution R and L.
Type 1: A11 = J_m(1,-1) and A_22 = J_k(1-a,1).
B11 = I_m, B22 = I_k
where J_k(a,b) is the k-by-k Jordan block with ``a'' on
diagonal and ``b'' on superdiagonal.
Type 2: A11 = (a_ij) = ( 2(.5-sin(i)) ) and
B11 = (b_ij) = ( 2(.5-sin(ij)) ) for i=1,...,m, j=i,...,m
A22 = (a_ij) = ( 2(.5-sin(i+j)) ) and
B22 = (b_ij) = ( 2(.5-sin(ij)) ) for i=m+1,...,k, j=i,...,k
Type 3: A11, A22 and B11, B22 are chosen as for Type 2, but each
second diagonal block in A_11 and each third diagonal block
in A_22 are made as 2 by 2 blocks.
Type 4: A11 = ( 20(.5 - sin(ij)) ) and B22 = ( 2(.5 - sin(i+j)) )
for i=1,...,m, j=1,...,m and
A22 = ( 20(.5 - sin(i+j)) ) and B22 = ( 2(.5 - sin(ij)) )
for i=m+1,...,k, j=m+1,...,k
Type 5: (A,B) and have potentially close or common eigenvalues and
very large departure from block diagonality A_11 is chosen
as the m x m leading submatrix of A_1:
| 1 b |
| -b 1 |
| 1+d b |
| -b 1+d |
A_1 = | d 1 |
| -1 d |
| -d 1 |
| -1 -d |
| 1 |
and A_22 is chosen as the k x k leading submatrix of A_2:
| -1 b |
| -b -1 |
| 1-d b |
| -b 1-d |
A_2 = | d 1+b |
| -1-b d |
| -d 1+b |
| -1+b -d |
| 1-d |
and matrix B are chosen as identity matrices (see SLATM5).
Arguments
=========
NSIZE (input) INTEGER
The maximum size of the matrices to use. NSIZE >= 0.
If NSIZE = 0, no built-in tests matrices are used, but
read-in test matrices are used to test SGGESX.
NCMAX (input) INTEGER
Maximum allowable NMAX for generating Kroneker matrix
in call to SLAKF2
THRESH (input) REAL
A test will count as "failed" if the "error", computed as
described above, exceeds THRESH. Note that the error
is scaled to be O(1), so THRESH should be a reasonably
small multiple of 1, e.g., 10 or 100. In particular,
it should not depend on the precision (single vs. double)
or the size of the matrix. THRESH >= 0.
NIN (input) INTEGER
The FORTRAN unit number for reading in the data file of
problems to solve.
NOUT (input) INTEGER
The FORTRAN unit number for printing out error messages
(e.g., if a routine returns IINFO not equal to 0.)
A (workspace) REAL array, dimension (LDA, NSIZE)
Used to store the matrix whose eigenvalues are to be
computed. On exit, A contains the last matrix actually used.
LDA (input) INTEGER
The leading dimension of A, B, AI, BI, Z and Q,
LDA >= max( 1, NSIZE ). For the read-in test,
LDA >= max( 1, N ), N is the size of the test matrices.
B (workspace) REAL array, dimension (LDA, NSIZE)
Used to store the matrix whose eigenvalues are to be
computed. On exit, B contains the last matrix actually used.
AI (workspace) REAL array, dimension (LDA, NSIZE)
Copy of A, modified by SGGESX.
BI (workspace) REAL array, dimension (LDA, NSIZE)
Copy of B, modified by SGGESX.
Z (workspace) REAL array, dimension (LDA, NSIZE)
Z holds the left Schur vectors computed by SGGESX.
Q (workspace) REAL array, dimension (LDA, NSIZE)
Q holds the right Schur vectors computed by SGGESX.
ALPHAR (workspace) REAL array, dimension (NSIZE)
ALPHAI (workspace) REAL array, dimension (NSIZE)
BETA (workspace) REAL array, dimension (NSIZE)
On exit, (ALPHAR + ALPHAI*i)/BETA are the eigenvalues.
C (workspace) REAL array, dimension (LDC, LDC)
Store the matrix generated by subroutine SLAKF2, this is the
matrix formed by Kronecker products used for estimating
DIF.
LDC (input) INTEGER
The leading dimension of C. LDC >= max(1, LDA*LDA/2 ).
S (workspace) REAL array, dimension (LDC)
Singular values of C
WORK (workspace) REAL array, dimension (LWORK)
LWORK (input) INTEGER
The dimension of the array WORK.
LWORK >= MAX( 5*NSIZE*NSIZE/2 - 2, 10*(NSIZE+1) )
IWORK (workspace) INTEGER array, dimension (LIWORK)
LIWORK (input) INTEGER
The dimension of the array IWORK. LIWORK >= NSIZE + 6.
BWORK (workspace) LOGICAL array, dimension (LDA)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value.
> 0: A routine returned an error code.
=====================================================================
Check for errors
Parameter adjustments */
q_dim1 = *lda;
q_offset = 1 + q_dim1 * 1;
q -= q_offset;
z_dim1 = *lda;
z_offset = 1 + z_dim1 * 1;
z__ -= z_offset;
bi_dim1 = *lda;
bi_offset = 1 + bi_dim1 * 1;
bi -= bi_offset;
ai_dim1 = *lda;
ai_offset = 1 + ai_dim1 * 1;
ai -= ai_offset;
b_dim1 = *lda;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--alphar;
--alphai;
--beta;
c_dim1 = *ldc;
c_offset = 1 + c_dim1 * 1;
c__ -= c_offset;
--s;
--work;
--iwork;
--bwork;
/* Function Body */
if (*nsize < 0) {
*info = -1;
} else if (*thresh < 0.f) {
*info = -2;
} else if (*nin <= 0) {
*info = -3;
} else if (*nout <= 0) {
*info = -4;
} else if (*lda < 1 || *lda < *nsize) {
*info = -6;
} else if (*ldc < 1 || *ldc < *nsize * *nsize / 2) {
*info = -17;
} else if (*liwork < *nsize + 6) {
*info = -21;
}
/* Compute workspace
(Note: Comments in the code beginning "Workspace:" describe the
minimal amount of workspace needed at that point in the code,
as well as the preferred amount for good performance.
NB refers to the optimal block size for the immediately
following subroutine, as returned by ILAENV.) */
minwrk = 1;
if (*info == 0 && *lwork >= 1) {
/* MINWRK = MAX( 10*( NSIZE+1 ), 5*NSIZE*NSIZE / 2-2 )
Computing MAX */
i__1 = (*nsize + 1) * 10, i__2 = *nsize * 5 * *nsize / 2;
minwrk = max(i__1,i__2);
/* workspace for sggesx */
maxwrk = (*nsize + 1) * 9 + *nsize * ilaenv_(&c__1, "SGEQRF", " ",
nsize, &c__1, nsize, &c__0, (ftnlen)6, (ftnlen)1);
/* Computing MAX */
i__1 = maxwrk, i__2 = (*nsize + 1) * 9 + *nsize * ilaenv_(&c__1,
"SORGQR", " ", nsize, &c__1, nsize, &c_n1, (ftnlen)6, (ftnlen)
1);
maxwrk = max(i__1,i__2);
/* workspace for sgesvd */
bdspac = *nsize * 5 * *nsize / 2;
/* Computing MAX */
i__3 = *nsize * *nsize / 2;
i__4 = *nsize * *nsize / 2;
i__1 = maxwrk, i__2 = *nsize * 3 * *nsize / 2 + *nsize * *nsize *
ilaenv_(&c__1, "SGEBRD", " ", &i__3, &i__4, &c_n1, &c_n1, (
ftnlen)6, (ftnlen)1);
maxwrk = max(i__1,i__2);
maxwrk = max(maxwrk,bdspac);
maxwrk = max(maxwrk,minwrk);
work[1] = (real) maxwrk;
}
if (*lwork < minwrk) {
*info = -19;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SDRGSX", &i__1);
return 0;
}
/* Important constants */
ulp = slamch_("P");
ulpinv = 1.f / ulp;
smlnum = slamch_("S") / ulp;
bignum = 1.f / smlnum;
slabad_(&smlnum, &bignum);
thrsh2 = *thresh * 10.f;
ntestt = 0;
nerrs = 0;
/* Go to the tests for read-in matrix pairs */
ifunc = 0;
if (*nsize == 0) {
goto L70;
}
/* Test the built-in matrix pairs.
Loop over different functions (IFUNC) of SGGESX, types (PRTYPE)
of test matrices, different size (M+N) */
prtype = 0;
qba = 3;
qbb = 4;
weight = sqrt(ulp);
for (ifunc = 0; ifunc <= 3; ++ifunc) {
for (prtype = 1; prtype <= 5; ++prtype) {
i__1 = *nsize - 1;
for (mn_1.m = 1; mn_1.m <= i__1; ++mn_1.m) {
i__2 = *nsize - mn_1.m;
for (mn_1.n = 1; mn_1.n <= i__2; ++mn_1.n) {
weight = 1.f / weight;
mn_1.mplusn = mn_1.m + mn_1.n;
/* Generate test matrices */
mn_1.fs = TRUE_;
mn_1.k = 0;
slaset_("Full", &mn_1.mplusn, &mn_1.mplusn, &c_b26, &
c_b26, &ai[ai_offset], lda);
slaset_("Full", &mn_1.mplusn, &mn_1.mplusn, &c_b26, &
c_b26, &bi[bi_offset], lda);
slatm5_(&prtype, &mn_1.m, &mn_1.n, &ai[ai_offset], lda, &
ai_ref(mn_1.m + 1, mn_1.m + 1), lda, &ai_ref(1,
mn_1.m + 1), lda, &bi[bi_offset], lda, &bi_ref(
mn_1.m + 1, mn_1.m + 1), lda, &bi_ref(1, mn_1.m +
1), lda, &q[q_offset], lda, &z__[z_offset], lda, &
weight, &qba, &qbb);
/* Compute the Schur factorization and swapping the
m-by-m (1,1)-blocks with n-by-n (2,2)-blocks.
Swapping is accomplished via the function SLCTSX
which is supplied below. */
if (ifunc == 0) {
*(unsigned char *)sense = 'N';
} else if (ifunc == 1) {
*(unsigned char *)sense = 'E';
} else if (ifunc == 2) {
*(unsigned char *)sense = 'V';
} else if (ifunc == 3) {
*(unsigned char *)sense = 'B';
}
slacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &ai[ai_offset]
, lda, &a[a_offset], lda);
slacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &bi[bi_offset]
, lda, &b[b_offset], lda);
sggesx_("V", "V", "S", (L_fp)slctsx_, sense, &mn_1.mplusn,
&ai[ai_offset], lda, &bi[bi_offset], lda, &mm, &
alphar[1], &alphai[1], &beta[1], &q[q_offset],
lda, &z__[z_offset], lda, pl, difest, &work[1],
lwork, &iwork[1], liwork, &bwork[1], &linfo);
if (linfo != 0 && linfo != mn_1.mplusn + 2) {
result[0] = ulpinv;
io___22.ciunit = *nout;
s_wsfe(&io___22);
do_fio(&c__1, "SGGESX", (ftnlen)6);
do_fio(&c__1, (char *)&linfo, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&prtype, (ftnlen)sizeof(integer)
);
e_wsfe();
*info = linfo;
goto L30;
}
/* Compute the norm(A, B) */
slacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &ai[ai_offset]
, lda, &work[1], &mn_1.mplusn);
slacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &bi[bi_offset]
, lda, &work[mn_1.mplusn * mn_1.mplusn + 1], &
mn_1.mplusn);
i__3 = mn_1.mplusn << 1;
abnrm = slange_("Fro", &mn_1.mplusn, &i__3, &work[1], &
mn_1.mplusn, &work[1]);
/* Do tests (1) to (4) */
sget51_(&c__1, &mn_1.mplusn, &a[a_offset], lda, &ai[
ai_offset], lda, &q[q_offset], lda, &z__[z_offset]
, lda, &work[1], result);
sget51_(&c__1, &mn_1.mplusn, &b[b_offset], lda, &bi[
bi_offset], lda, &q[q_offset], lda, &z__[z_offset]
, lda, &work[1], &result[1]);
sget51_(&c__3, &mn_1.mplusn, &b[b_offset], lda, &bi[
bi_offset], lda, &q[q_offset], lda, &q[q_offset],
lda, &work[1], &result[2]);
sget51_(&c__3, &mn_1.mplusn, &b[b_offset], lda, &bi[
bi_offset], lda, &z__[z_offset], lda, &z__[
z_offset], lda, &work[1], &result[3]);
ntest = 4;
/* Do tests (5) and (6): check Schur form of A and
compare eigenvalues with diagonals. */
temp1 = 0.f;
result[4] = 0.f;
result[5] = 0.f;
i__3 = mn_1.mplusn;
for (j = 1; j <= i__3; ++j) {
ilabad = FALSE_;
if (alphai[j] == 0.f) {
/* Computing MAX */
r__7 = smlnum, r__8 = (r__2 = alphar[j], dabs(
r__2)), r__7 = max(r__7,r__8), r__8 = (
r__3 = ai_ref(j, j), dabs(r__3));
/* Computing MAX */
r__9 = smlnum, r__10 = (r__5 = beta[j], dabs(r__5)
), r__9 = max(r__9,r__10), r__10 = (r__6 =
bi_ref(j, j), dabs(r__6));
temp2 = ((r__1 = alphar[j] - ai_ref(j, j), dabs(
r__1)) / dmax(r__7,r__8) + (r__4 = beta[j]
- bi_ref(j, j), dabs(r__4)) / dmax(r__9,
r__10)) / ulp;
if (j < mn_1.mplusn) {
if (ai_ref(j + 1, j) != 0.f) {
ilabad = TRUE_;
result[4] = ulpinv;
}
}
if (j > 1) {
if (ai_ref(j, j - 1) != 0.f) {
ilabad = TRUE_;
result[4] = ulpinv;
}
}
} else {
if (alphai[j] > 0.f) {
i1 = j;
} else {
i1 = j - 1;
}
if (i1 <= 0 || i1 >= mn_1.mplusn) {
ilabad = TRUE_;
} else if (i1 < mn_1.mplusn - 1) {
if (ai_ref(i1 + 2, i1 + 1) != 0.f) {
ilabad = TRUE_;
result[4] = ulpinv;
}
} else if (i1 > 1) {
if (ai_ref(i1, i1 - 1) != 0.f) {
ilabad = TRUE_;
result[4] = ulpinv;
}
}
if (! ilabad) {
sget53_(&ai_ref(i1, i1), lda, &bi_ref(i1, i1),
lda, &beta[j], &alphar[j], &alphai[j]
, &temp2, &iinfo);
if (iinfo >= 3) {
io___31.ciunit = *nout;
s_wsfe(&io___31);
do_fio(&c__1, (char *)&iinfo, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&mn_1.mplusn, (
ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&prtype, (ftnlen)
sizeof(integer));
e_wsfe();
*info = abs(iinfo);
}
} else {
temp2 = ulpinv;
}
}
temp1 = dmax(temp1,temp2);
if (ilabad) {
io___32.ciunit = *nout;
s_wsfe(&io___32);
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&prtype, (ftnlen)sizeof(
integer));
e_wsfe();
}
/* L10: */
}
result[5] = temp1;
ntest += 2;
/* Test (7) (if sorting worked) */
result[6] = 0.f;
if (linfo == mn_1.mplusn + 3) {
result[6] = ulpinv;
} else if (mm != mn_1.n) {
result[6] = ulpinv;
}
++ntest;
/* Test (8): compare the estimated value DIF and its
value. first, compute the exact DIF. */
result[7] = 0.f;
mn2 = mm * (mn_1.mplusn - mm) << 1;
if (ifunc >= 2 && mn2 <= *ncmax * *ncmax) {
/* Note: for either following two causes, there are
almost same number of test cases fail the test. */
i__3 = mn_1.mplusn - mm;
slakf2_(&mm, &i__3, &ai[ai_offset], lda, &ai_ref(mm +
1, mm + 1), &bi[bi_offset], &bi_ref(mm + 1,
mm + 1), &c__[c_offset], ldc);
i__3 = *lwork - 2;
sgesvd_("N", "N", &mn2, &mn2, &c__[c_offset], ldc, &s[
1], &work[1], &c__1, &work[2], &c__1, &work[3]
, &i__3, info);
diftru = s[mn2];
if (difest[1] == 0.f) {
if (diftru > abnrm * ulp) {
result[7] = ulpinv;
}
} else if (diftru == 0.f) {
if (difest[1] > abnrm * ulp) {
result[7] = ulpinv;
}
} else if (diftru > thrsh2 * difest[1] || diftru *
thrsh2 < difest[1]) {
/* Computing MAX */
r__1 = diftru / difest[1], r__2 = difest[1] /
diftru;
result[7] = dmax(r__1,r__2);
}
++ntest;
}
/* Test (9) */
result[8] = 0.f;
if (linfo == mn_1.mplusn + 2) {
if (diftru > abnrm * ulp) {
result[8] = ulpinv;
}
if (ifunc > 1 && difest[1] != 0.f) {
result[8] = ulpinv;
}
if (ifunc == 1 && pl[0] != 0.f) {
result[8] = ulpinv;
}
++ntest;
}
ntestt += ntest;
/* Print out tests which fail. */
for (j = 1; j <= 9; ++j) {
if (result[j - 1] >= *thresh) {
/* If this is the first test to fail,
print a header to the data file. */
if (nerrs == 0) {
io___35.ciunit = *nout;
s_wsfe(&io___35);
do_fio(&c__1, "SGX", (ftnlen)3);
e_wsfe();
/* Matrix types */
io___36.ciunit = *nout;
s_wsfe(&io___36);
e_wsfe();
/* Tests performed */
io___37.ciunit = *nout;
s_wsfe(&io___37);
do_fio(&c__1, "orthogonal", (ftnlen)10);
do_fio(&c__1, "'", (ftnlen)1);
do_fio(&c__1, "transpose", (ftnlen)9);
for (i__ = 1; i__ <= 4; ++i__) {
do_fio(&c__1, "'", (ftnlen)1);
}
e_wsfe();
}
++nerrs;
if (result[j - 1] < 1e4f) {
io___39.ciunit = *nout;
s_wsfe(&io___39);
do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&prtype, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&weight, (ftnlen)sizeof(
real));
do_fio(&c__1, (char *)&mn_1.m, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[j - 1], (ftnlen)
sizeof(real));
e_wsfe();
} else {
io___40.ciunit = *nout;
s_wsfe(&io___40);
do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&prtype, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&weight, (ftnlen)sizeof(
real));
do_fio(&c__1, (char *)&mn_1.m, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[j - 1], (ftnlen)
sizeof(real));
e_wsfe();
}
}
/* L20: */
}
L30:
;
}
/* L40: */
}
/* L50: */
}
/* L60: */
}
goto L150;
L70:
/* Read in data from file to check accuracy of condition estimation
Read input data until N=0 */
nptknt = 0;
L80:
io___42.ciunit = *nin;
i__1 = s_rsle(&io___42);
if (i__1 != 0) {
goto L140;
}
i__1 = do_lio(&c__3, &c__1, (char *)&mn_1.mplusn, (ftnlen)sizeof(integer))
;
if (i__1 != 0) {
goto L140;
}
i__1 = e_rsle();
if (i__1 != 0) {
goto L140;
}
if (mn_1.mplusn == 0) {
goto L140;
}
io___43.ciunit = *nin;
i__1 = s_rsle(&io___43);
if (i__1 != 0) {
goto L140;
}
i__1 = do_lio(&c__3, &c__1, (char *)&mn_1.n, (ftnlen)sizeof(integer));
if (i__1 != 0) {
goto L140;
}
i__1 = e_rsle();
if (i__1 != 0) {
goto L140;
}
i__1 = mn_1.mplusn;
for (i__ = 1; i__ <= i__1; ++i__) {
io___44.ciunit = *nin;
s_rsle(&io___44);
i__2 = mn_1.mplusn;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__4, &c__1, (char *)&ai_ref(i__, j), (ftnlen)sizeof(real)
);
}
e_rsle();
/* L90: */
}
i__1 = mn_1.mplusn;
for (i__ = 1; i__ <= i__1; ++i__) {
io___45.ciunit = *nin;
s_rsle(&io___45);
i__2 = mn_1.mplusn;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__4, &c__1, (char *)&bi_ref(i__, j), (ftnlen)sizeof(real)
);
}
e_rsle();
/* L100: */
}
io___46.ciunit = *nin;
s_rsle(&io___46);
do_lio(&c__4, &c__1, (char *)&pltru, (ftnlen)sizeof(real));
do_lio(&c__4, &c__1, (char *)&diftru, (ftnlen)sizeof(real));
e_rsle();
++nptknt;
mn_1.fs = TRUE_;
mn_1.k = 0;
mn_1.m = mn_1.mplusn - mn_1.n;
slacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &ai[ai_offset], lda, &a[
a_offset], lda);
slacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &bi[bi_offset], lda, &b[
b_offset], lda);
/* Compute the Schur factorization while swaping the
m-by-m (1,1)-blocks with n-by-n (2,2)-blocks. */
sggesx_("V", "V", "S", (L_fp)slctsx_, "B", &mn_1.mplusn, &ai[ai_offset],
lda, &bi[bi_offset], lda, &mm, &alphar[1], &alphai[1], &beta[1], &
q[q_offset], lda, &z__[z_offset], lda, pl, difest, &work[1],
lwork, &iwork[1], liwork, &bwork[1], &linfo);
if (linfo != 0 && linfo != mn_1.mplusn + 2) {
result[0] = ulpinv;
io___48.ciunit = *nout;
s_wsfe(&io___48);
do_fio(&c__1, "SGGESX", (ftnlen)6);
do_fio(&c__1, (char *)&linfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
e_wsfe();
goto L130;
}
/* Compute the norm(A, B)
(should this be norm of (A,B) or (AI,BI)?) */
slacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &ai[ai_offset], lda, &work[1],
&mn_1.mplusn);
slacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &bi[bi_offset], lda, &work[
mn_1.mplusn * mn_1.mplusn + 1], &mn_1.mplusn);
i__1 = mn_1.mplusn << 1;
abnrm = slange_("Fro", &mn_1.mplusn, &i__1, &work[1], &mn_1.mplusn, &work[
1]);
/* Do tests (1) to (4) */
sget51_(&c__1, &mn_1.mplusn, &a[a_offset], lda, &ai[ai_offset], lda, &q[
q_offset], lda, &z__[z_offset], lda, &work[1], result);
sget51_(&c__1, &mn_1.mplusn, &b[b_offset], lda, &bi[bi_offset], lda, &q[
q_offset], lda, &z__[z_offset], lda, &work[1], &result[1]);
sget51_(&c__3, &mn_1.mplusn, &b[b_offset], lda, &bi[bi_offset], lda, &q[
q_offset], lda, &q[q_offset], lda, &work[1], &result[2]);
sget51_(&c__3, &mn_1.mplusn, &b[b_offset], lda, &bi[bi_offset], lda, &z__[
z_offset], lda, &z__[z_offset], lda, &work[1], &result[3]);
/* Do tests (5) and (6): check Schur form of A and compare
eigenvalues with diagonals. */
ntest = 6;
temp1 = 0.f;
result[4] = 0.f;
result[5] = 0.f;
i__1 = mn_1.mplusn;
for (j = 1; j <= i__1; ++j) {
ilabad = FALSE_;
if (alphai[j] == 0.f) {
/* Computing MAX */
r__7 = smlnum, r__8 = (r__2 = alphar[j], dabs(r__2)), r__7 = max(
r__7,r__8), r__8 = (r__3 = ai_ref(j, j), dabs(r__3));
/* Computing MAX */
r__9 = smlnum, r__10 = (r__5 = beta[j], dabs(r__5)), r__9 = max(
r__9,r__10), r__10 = (r__6 = bi_ref(j, j), dabs(r__6));
temp2 = ((r__1 = alphar[j] - ai_ref(j, j), dabs(r__1)) / dmax(
r__7,r__8) + (r__4 = beta[j] - bi_ref(j, j), dabs(r__4)) /
dmax(r__9,r__10)) / ulp;
if (j < mn_1.mplusn) {
if (ai_ref(j + 1, j) != 0.f) {
ilabad = TRUE_;
result[4] = ulpinv;
}
}
if (j > 1) {
if (ai_ref(j, j - 1) != 0.f) {
ilabad = TRUE_;
result[4] = ulpinv;
}
}
} else {
if (alphai[j] > 0.f) {
i1 = j;
} else {
i1 = j - 1;
}
if (i1 <= 0 || i1 >= mn_1.mplusn) {
ilabad = TRUE_;
} else if (i1 < mn_1.mplusn - 1) {
if (ai_ref(i1 + 2, i1 + 1) != 0.f) {
ilabad = TRUE_;
result[4] = ulpinv;
}
} else if (i1 > 1) {
if (ai_ref(i1, i1 - 1) != 0.f) {
ilabad = TRUE_;
result[4] = ulpinv;
}
}
if (! ilabad) {
sget53_(&ai_ref(i1, i1), lda, &bi_ref(i1, i1), lda, &beta[j],
&alphar[j], &alphai[j], &temp2, &iinfo);
if (iinfo >= 3) {
io___49.ciunit = *nout;
s_wsfe(&io___49);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
}
} else {
temp2 = ulpinv;
}
}
temp1 = dmax(temp1,temp2);
if (ilabad) {
io___50.ciunit = *nout;
s_wsfe(&io___50);
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
e_wsfe();
}
/* L110: */
}
result[5] = temp1;
/* Test (7) (if sorting worked) <--------- need to be checked. */
ntest = 7;
result[6] = 0.f;
if (linfo == mn_1.mplusn + 3) {
result[6] = ulpinv;
}
/* Test (8): compare the estimated value of DIF and its true value. */
ntest = 8;
result[7] = 0.f;
if (difest[1] == 0.f) {
if (diftru > abnrm * ulp) {
result[7] = ulpinv;
}
} else if (diftru == 0.f) {
if (difest[1] > abnrm * ulp) {
result[7] = ulpinv;
}
} else if (diftru > thrsh2 * difest[1] || diftru * thrsh2 < difest[1]) {
/* Computing MAX */
r__1 = diftru / difest[1], r__2 = difest[1] / diftru;
result[7] = dmax(r__1,r__2);
}
/* Test (9) */
ntest = 9;
result[8] = 0.f;
if (linfo == mn_1.mplusn + 2) {
if (diftru > abnrm * ulp) {
result[8] = ulpinv;
}
if (ifunc > 1 && difest[1] != 0.f) {
result[8] = ulpinv;
}
if (ifunc == 1 && pl[0] != 0.f) {
result[8] = ulpinv;
}
}
/* Test (10): compare the estimated value of PL and it true value. */
ntest = 10;
result[9] = 0.f;
if (pl[0] == 0.f) {
if (pltru > abnrm * ulp) {
result[9] = ulpinv;
}
} else if (pltru == 0.f) {
if (pl[0] > abnrm * ulp) {
result[9] = ulpinv;
}
} else if (pltru > *thresh * pl[0] || pltru * *thresh < pl[0]) {
result[9] = ulpinv;
}
ntestt += ntest;
/* Print out tests which fail. */
i__1 = ntest;
for (j = 1; j <= i__1; ++j) {
if (result[j - 1] >= *thresh) {
/* If this is the first test to fail,
print a header to the data file. */
if (nerrs == 0) {
io___51.ciunit = *nout;
s_wsfe(&io___51);
do_fio(&c__1, "SGX", (ftnlen)3);
e_wsfe();
/* Matrix types */
io___52.ciunit = *nout;
s_wsfe(&io___52);
e_wsfe();
/* Tests performed */
io___53.ciunit = *nout;
s_wsfe(&io___53);
do_fio(&c__1, "orthogonal", (ftnlen)10);
do_fio(&c__1, "'", (ftnlen)1);
do_fio(&c__1, "transpose", (ftnlen)9);
for (i__ = 1; i__ <= 4; ++i__) {
do_fio(&c__1, "'", (ftnlen)1);
}
e_wsfe();
}
++nerrs;
if (result[j - 1] < 1e4f) {
io___54.ciunit = *nout;
s_wsfe(&io___54);
do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[j - 1], (ftnlen)sizeof(real));
e_wsfe();
} else {
io___55.ciunit = *nout;
s_wsfe(&io___55);
do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[j - 1], (ftnlen)sizeof(real));
e_wsfe();
}
}
/* L120: */
}
L130:
goto L80;
L140:
L150:
/* Summary */
alasvm_("SGX", nout, &nerrs, &ntestt, &c__0);
work[1] = (real) maxwrk;
return 0;
/* End of SDRGSX */
} /* sdrgsx_ */
/* Subroutine */ int alahdg_(integer *iounit, char *path)
{
/* Format strings */
static char fmt_9991[] = "(/1x,a3,\002: GQR factorization of general mat"
"rices\002)";
static char fmt_9992[] = "(/1x,a3,\002: GRQ factorization of general mat"
"rices\002)";
static char fmt_9993[] = "(/1x,a3,\002: LSE Problem\002)";
static char fmt_9994[] = "(/1x,a3,\002: GLM Problem\002)";
static char fmt_9995[] = "(/1x,a3,\002: Generalized Singular Value Decom"
"position\002)";
static char fmt_9999[] = "(1x,a)";
static char fmt_9950[] = "(3x,i2,\002: A-diagonal matrix B-upper triang"
"ular\002)";
static char fmt_9952[] = "(3x,i2,\002: A-upper triangular B-upper triang"
"ular\002)";
static char fmt_9954[] = "(3x,i2,\002: A-lower triangular B-upper triang"
"ular\002)";
static char fmt_9955[] = "(3x,i2,\002: Random matrices cond(A)=100, cond"
"(B)=10,\002)";
static char fmt_9956[] = "(3x,i2,\002: Random matrices cond(A)= sqrt( 0."
"1/EPS ) \002,\002cond(B)= sqrt( 0.1/EPS )\002)";
static char fmt_9957[] = "(3x,i2,\002: Random matrices cond(A)= 0.1/EPS"
" \002,\002cond(B)= 0.1/EPS\002)";
static char fmt_9961[] = "(3x,i2,\002: Matrix scaled near underflow li"
"mit\002)";
static char fmt_9962[] = "(3x,i2,\002: Matrix scaled near overflow limi"
"t\002)";
static char fmt_9951[] = "(3x,i2,\002: A-diagonal matrix B-lower triang"
"ular\002)";
static char fmt_9953[] = "(3x,i2,\002: A-lower triangular B-diagonal tri"
"angular\002)";
static char fmt_9959[] = "(3x,i2,\002: Random matrices cond(A)= sqrt( 0."
"1/EPS ) \002,\002cond(B)= 0.1/EPS \002)";
static char fmt_9960[] = "(3x,i2,\002: Random matrices cond(A)= 0.1/EPS"
" \002,\002cond(B)= sqrt( 0.1/EPS )\002)";
static char fmt_9930[] = "(3x,i2,\002: norm( R - Q' * A ) / ( min( N, M "
")*norm( A )\002,\002* EPS )\002)";
static char fmt_9931[] = "(3x,i2,\002: norm( T * Z - Q' * B ) / ( min(P"
",N)*norm(B)\002,\002* EPS )\002)";
static char fmt_9932[] = "(3x,i2,\002: norm( I - Q'*Q ) / ( N * EPS "
")\002)";
static char fmt_9933[] = "(3x,i2,\002: norm( I - Z'*Z ) / ( P * EPS "
")\002)";
static char fmt_9934[] = "(3x,i2,\002: norm( R - A * Q' ) / ( min( N,M )"
"*norm(A) * \002,\002EPS )\002)";
static char fmt_9935[] = "(3x,i2,\002: norm( T * Q - Z' * B ) / ( min( "
"P,N ) * nor\002,\002m(B)*EPS )\002)";
static char fmt_9937[] = "(3x,i2,\002: norm( A*x - c ) / ( norm(A)*norm"
"(x) * EPS )\002)";
static char fmt_9938[] = "(3x,i2,\002: norm( B*x - d ) / ( norm(B)*norm"
"(x) * EPS )\002)";
static char fmt_9939[] = "(3x,i2,\002: norm( d - A*x - B*y ) / ( (norm(A"
")+norm(B) )*\002,\002(norm(x)+norm(y))*EPS )\002)";
static char fmt_9940[] = "(3x,i2,\002: norm( U' * A * Q - D1 * R ) / ( m"
"in( M, N )*\002,\002norm( A ) * EPS )\002)";
static char fmt_9941[] = "(3x,i2,\002: norm( V' * B * Q - D2 * R ) / ( m"
"in( P, N )*\002,\002norm( B ) * EPS )\002)";
static char fmt_9942[] = "(3x,i2,\002: norm( I - U'*U ) / ( M * EPS "
")\002)";
static char fmt_9943[] = "(3x,i2,\002: norm( I - V'*V ) / ( P * EPS "
")\002)";
static char fmt_9944[] = "(3x,i2,\002: norm( I - Q'*Q ) / ( N * EPS "
")\002)";
/* Local variables */
char c2[3];
integer itype;
extern logical lsamen_(integer *, char *, char *);
/* Fortran I/O blocks */
static cilist io___3 = { 0, 0, 0, fmt_9991, 0 };
static cilist io___4 = { 0, 0, 0, fmt_9992, 0 };
static cilist io___5 = { 0, 0, 0, fmt_9993, 0 };
static cilist io___6 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___7 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___8 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___9 = { 0, 0, 0, fmt_9950, 0 };
static cilist io___10 = { 0, 0, 0, fmt_9952, 0 };
static cilist io___11 = { 0, 0, 0, fmt_9954, 0 };
static cilist io___12 = { 0, 0, 0, fmt_9955, 0 };
static cilist io___13 = { 0, 0, 0, fmt_9956, 0 };
static cilist io___14 = { 0, 0, 0, fmt_9957, 0 };
static cilist io___15 = { 0, 0, 0, fmt_9961, 0 };
static cilist io___16 = { 0, 0, 0, fmt_9962, 0 };
static cilist io___17 = { 0, 0, 0, fmt_9951, 0 };
static cilist io___18 = { 0, 0, 0, fmt_9953, 0 };
static cilist io___19 = { 0, 0, 0, fmt_9954, 0 };
static cilist io___20 = { 0, 0, 0, fmt_9955, 0 };
static cilist io___21 = { 0, 0, 0, fmt_9956, 0 };
static cilist io___22 = { 0, 0, 0, fmt_9957, 0 };
static cilist io___23 = { 0, 0, 0, fmt_9961, 0 };
static cilist io___24 = { 0, 0, 0, fmt_9962, 0 };
static cilist io___25 = { 0, 0, 0, fmt_9950, 0 };
static cilist io___26 = { 0, 0, 0, fmt_9952, 0 };
static cilist io___27 = { 0, 0, 0, fmt_9954, 0 };
static cilist io___28 = { 0, 0, 0, fmt_9955, 0 };
static cilist io___29 = { 0, 0, 0, fmt_9955, 0 };
static cilist io___30 = { 0, 0, 0, fmt_9955, 0 };
static cilist io___31 = { 0, 0, 0, fmt_9955, 0 };
static cilist io___32 = { 0, 0, 0, fmt_9955, 0 };
static cilist io___33 = { 0, 0, 0, fmt_9951, 0 };
static cilist io___34 = { 0, 0, 0, fmt_9953, 0 };
static cilist io___35 = { 0, 0, 0, fmt_9954, 0 };
static cilist io___36 = { 0, 0, 0, fmt_9955, 0 };
static cilist io___37 = { 0, 0, 0, fmt_9955, 0 };
static cilist io___38 = { 0, 0, 0, fmt_9955, 0 };
static cilist io___39 = { 0, 0, 0, fmt_9955, 0 };
static cilist io___40 = { 0, 0, 0, fmt_9955, 0 };
static cilist io___41 = { 0, 0, 0, fmt_9950, 0 };
static cilist io___42 = { 0, 0, 0, fmt_9952, 0 };
static cilist io___43 = { 0, 0, 0, fmt_9954, 0 };
static cilist io___44 = { 0, 0, 0, fmt_9955, 0 };
static cilist io___45 = { 0, 0, 0, fmt_9956, 0 };
static cilist io___46 = { 0, 0, 0, fmt_9957, 0 };
static cilist io___47 = { 0, 0, 0, fmt_9959, 0 };
static cilist io___48 = { 0, 0, 0, fmt_9960, 0 };
static cilist io___49 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___50 = { 0, 0, 0, fmt_9930, 0 };
static cilist io___51 = { 0, 0, 0, fmt_9931, 0 };
static cilist io___52 = { 0, 0, 0, fmt_9932, 0 };
static cilist io___53 = { 0, 0, 0, fmt_9933, 0 };
static cilist io___54 = { 0, 0, 0, fmt_9934, 0 };
static cilist io___55 = { 0, 0, 0, fmt_9935, 0 };
static cilist io___56 = { 0, 0, 0, fmt_9932, 0 };
static cilist io___57 = { 0, 0, 0, fmt_9933, 0 };
static cilist io___58 = { 0, 0, 0, fmt_9937, 0 };
static cilist io___59 = { 0, 0, 0, fmt_9938, 0 };
static cilist io___60 = { 0, 0, 0, fmt_9939, 0 };
static cilist io___61 = { 0, 0, 0, fmt_9940, 0 };
static cilist io___62 = { 0, 0, 0, fmt_9941, 0 };
static cilist io___63 = { 0, 0, 0, fmt_9942, 0 };
static cilist io___64 = { 0, 0, 0, fmt_9943, 0 };
static cilist io___65 = { 0, 0, 0, fmt_9944, 0 };
/* -- LAPACK test routine (version 3.1.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ALAHDG prints header information for the different test paths. */
/* Arguments */
/* ========= */
/* IOUNIT (input) INTEGER */
/* The unit number to which the header information should be */
/* printed. */
/* PATH (input) CHARACTER*3 */
/* The name of the path for which the header information is to */
/* be printed. Current paths are */
/* GQR: GQR (general matrices) */
/* GRQ: GRQ (general matrices) */
/* LSE: LSE Problem */
/* GLM: GLM Problem */
/* GSV: Generalized Singular Value Decomposition */
/* ===================================================================== */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
if (*iounit <= 0) {
return 0;
}
s_copy(c2, path, (ftnlen)3, (ftnlen)3);
/* First line describing matrices in this path */
if (lsamen_(&c__3, c2, "GQR")) {
itype = 1;
io___3.ciunit = *iounit;
s_wsfe(&io___3);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
} else if (lsamen_(&c__3, c2, "GRQ")) {
itype = 2;
io___4.ciunit = *iounit;
s_wsfe(&io___4);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
} else if (lsamen_(&c__3, c2, "LSE")) {
itype = 3;
io___5.ciunit = *iounit;
s_wsfe(&io___5);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
} else if (lsamen_(&c__3, c2, "GLM")) {
itype = 4;
io___6.ciunit = *iounit;
s_wsfe(&io___6);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
} else if (lsamen_(&c__3, c2, "GSV")) {
itype = 5;
io___7.ciunit = *iounit;
s_wsfe(&io___7);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
}
/* Matrix types */
io___8.ciunit = *iounit;
s_wsfe(&io___8);
do_fio(&c__1, "Matrix types: ", (ftnlen)14);
e_wsfe();
if (itype == 1) {
io___9.ciunit = *iounit;
s_wsfe(&io___9);
do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
e_wsfe();
io___10.ciunit = *iounit;
s_wsfe(&io___10);
do_fio(&c__1, (char *)&c__2, (ftnlen)sizeof(integer));
e_wsfe();
io___11.ciunit = *iounit;
s_wsfe(&io___11);
do_fio(&c__1, (char *)&c__3, (ftnlen)sizeof(integer));
e_wsfe();
io___12.ciunit = *iounit;
s_wsfe(&io___12);
do_fio(&c__1, (char *)&c__4, (ftnlen)sizeof(integer));
e_wsfe();
io___13.ciunit = *iounit;
s_wsfe(&io___13);
do_fio(&c__1, (char *)&c__5, (ftnlen)sizeof(integer));
e_wsfe();
io___14.ciunit = *iounit;
s_wsfe(&io___14);
do_fio(&c__1, (char *)&c__6, (ftnlen)sizeof(integer));
e_wsfe();
io___15.ciunit = *iounit;
s_wsfe(&io___15);
do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
e_wsfe();
io___16.ciunit = *iounit;
s_wsfe(&io___16);
do_fio(&c__1, (char *)&c__8, (ftnlen)sizeof(integer));
e_wsfe();
} else if (itype == 2) {
io___17.ciunit = *iounit;
s_wsfe(&io___17);
do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
e_wsfe();
io___18.ciunit = *iounit;
s_wsfe(&io___18);
do_fio(&c__1, (char *)&c__2, (ftnlen)sizeof(integer));
e_wsfe();
io___19.ciunit = *iounit;
s_wsfe(&io___19);
do_fio(&c__1, (char *)&c__3, (ftnlen)sizeof(integer));
e_wsfe();
io___20.ciunit = *iounit;
s_wsfe(&io___20);
do_fio(&c__1, (char *)&c__4, (ftnlen)sizeof(integer));
e_wsfe();
io___21.ciunit = *iounit;
s_wsfe(&io___21);
do_fio(&c__1, (char *)&c__5, (ftnlen)sizeof(integer));
e_wsfe();
io___22.ciunit = *iounit;
s_wsfe(&io___22);
do_fio(&c__1, (char *)&c__6, (ftnlen)sizeof(integer));
e_wsfe();
io___23.ciunit = *iounit;
s_wsfe(&io___23);
do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
e_wsfe();
io___24.ciunit = *iounit;
s_wsfe(&io___24);
do_fio(&c__1, (char *)&c__8, (ftnlen)sizeof(integer));
e_wsfe();
} else if (itype == 3) {
io___25.ciunit = *iounit;
s_wsfe(&io___25);
do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
e_wsfe();
io___26.ciunit = *iounit;
s_wsfe(&io___26);
do_fio(&c__1, (char *)&c__2, (ftnlen)sizeof(integer));
e_wsfe();
io___27.ciunit = *iounit;
s_wsfe(&io___27);
do_fio(&c__1, (char *)&c__3, (ftnlen)sizeof(integer));
e_wsfe();
io___28.ciunit = *iounit;
s_wsfe(&io___28);
do_fio(&c__1, (char *)&c__4, (ftnlen)sizeof(integer));
e_wsfe();
io___29.ciunit = *iounit;
s_wsfe(&io___29);
do_fio(&c__1, (char *)&c__5, (ftnlen)sizeof(integer));
e_wsfe();
io___30.ciunit = *iounit;
s_wsfe(&io___30);
do_fio(&c__1, (char *)&c__6, (ftnlen)sizeof(integer));
e_wsfe();
io___31.ciunit = *iounit;
s_wsfe(&io___31);
do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
e_wsfe();
io___32.ciunit = *iounit;
s_wsfe(&io___32);
do_fio(&c__1, (char *)&c__8, (ftnlen)sizeof(integer));
e_wsfe();
} else if (itype == 4) {
io___33.ciunit = *iounit;
s_wsfe(&io___33);
do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
e_wsfe();
io___34.ciunit = *iounit;
s_wsfe(&io___34);
do_fio(&c__1, (char *)&c__2, (ftnlen)sizeof(integer));
e_wsfe();
io___35.ciunit = *iounit;
s_wsfe(&io___35);
do_fio(&c__1, (char *)&c__3, (ftnlen)sizeof(integer));
e_wsfe();
io___36.ciunit = *iounit;
s_wsfe(&io___36);
do_fio(&c__1, (char *)&c__4, (ftnlen)sizeof(integer));
e_wsfe();
io___37.ciunit = *iounit;
s_wsfe(&io___37);
do_fio(&c__1, (char *)&c__5, (ftnlen)sizeof(integer));
e_wsfe();
io___38.ciunit = *iounit;
s_wsfe(&io___38);
do_fio(&c__1, (char *)&c__6, (ftnlen)sizeof(integer));
e_wsfe();
io___39.ciunit = *iounit;
s_wsfe(&io___39);
do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
e_wsfe();
io___40.ciunit = *iounit;
s_wsfe(&io___40);
do_fio(&c__1, (char *)&c__8, (ftnlen)sizeof(integer));
e_wsfe();
} else if (itype == 5) {
io___41.ciunit = *iounit;
s_wsfe(&io___41);
do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
e_wsfe();
io___42.ciunit = *iounit;
s_wsfe(&io___42);
do_fio(&c__1, (char *)&c__2, (ftnlen)sizeof(integer));
e_wsfe();
io___43.ciunit = *iounit;
s_wsfe(&io___43);
do_fio(&c__1, (char *)&c__3, (ftnlen)sizeof(integer));
e_wsfe();
io___44.ciunit = *iounit;
s_wsfe(&io___44);
do_fio(&c__1, (char *)&c__4, (ftnlen)sizeof(integer));
e_wsfe();
io___45.ciunit = *iounit;
s_wsfe(&io___45);
do_fio(&c__1, (char *)&c__5, (ftnlen)sizeof(integer));
e_wsfe();
io___46.ciunit = *iounit;
s_wsfe(&io___46);
do_fio(&c__1, (char *)&c__6, (ftnlen)sizeof(integer));
e_wsfe();
io___47.ciunit = *iounit;
s_wsfe(&io___47);
do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
e_wsfe();
io___48.ciunit = *iounit;
s_wsfe(&io___48);
do_fio(&c__1, (char *)&c__8, (ftnlen)sizeof(integer));
e_wsfe();
}
/* Tests performed */
io___49.ciunit = *iounit;
s_wsfe(&io___49);
do_fio(&c__1, "Test ratios: ", (ftnlen)13);
e_wsfe();
if (itype == 1) {
/* GQR decomposition of rectangular matrices */
io___50.ciunit = *iounit;
s_wsfe(&io___50);
do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
e_wsfe();
io___51.ciunit = *iounit;
s_wsfe(&io___51);
do_fio(&c__1, (char *)&c__2, (ftnlen)sizeof(integer));
e_wsfe();
io___52.ciunit = *iounit;
s_wsfe(&io___52);
do_fio(&c__1, (char *)&c__3, (ftnlen)sizeof(integer));
e_wsfe();
io___53.ciunit = *iounit;
s_wsfe(&io___53);
do_fio(&c__1, (char *)&c__4, (ftnlen)sizeof(integer));
e_wsfe();
} else if (itype == 2) {
/* GRQ decomposition of rectangular matrices */
io___54.ciunit = *iounit;
s_wsfe(&io___54);
do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
e_wsfe();
io___55.ciunit = *iounit;
s_wsfe(&io___55);
do_fio(&c__1, (char *)&c__2, (ftnlen)sizeof(integer));
e_wsfe();
io___56.ciunit = *iounit;
s_wsfe(&io___56);
do_fio(&c__1, (char *)&c__3, (ftnlen)sizeof(integer));
e_wsfe();
io___57.ciunit = *iounit;
s_wsfe(&io___57);
do_fio(&c__1, (char *)&c__4, (ftnlen)sizeof(integer));
e_wsfe();
} else if (itype == 3) {
/* LSE Problem */
io___58.ciunit = *iounit;
s_wsfe(&io___58);
do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
e_wsfe();
io___59.ciunit = *iounit;
s_wsfe(&io___59);
do_fio(&c__1, (char *)&c__2, (ftnlen)sizeof(integer));
e_wsfe();
} else if (itype == 4) {
/* GLM Problem */
io___60.ciunit = *iounit;
s_wsfe(&io___60);
do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
e_wsfe();
} else if (itype == 5) {
/* GSVD */
io___61.ciunit = *iounit;
s_wsfe(&io___61);
do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
e_wsfe();
io___62.ciunit = *iounit;
s_wsfe(&io___62);
do_fio(&c__1, (char *)&c__2, (ftnlen)sizeof(integer));
e_wsfe();
io___63.ciunit = *iounit;
s_wsfe(&io___63);
do_fio(&c__1, (char *)&c__3, (ftnlen)sizeof(integer));
e_wsfe();
io___64.ciunit = *iounit;
s_wsfe(&io___64);
do_fio(&c__1, (char *)&c__4, (ftnlen)sizeof(integer));
e_wsfe();
io___65.ciunit = *iounit;
s_wsfe(&io___65);
do_fio(&c__1, (char *)&c__5, (ftnlen)sizeof(integer));
e_wsfe();
}
/* GQR test ratio */
/* GRQ test ratio */
/* LSE test ratio */
/* GLM test ratio */
/* GSVD test ratio */
return 0;
/* End of ALAHDG */
} /* alahdg_ */
/* Subroutine */ int schkbb_(integer *nsizes, integer *mval, integer *nval,
integer *nwdths, integer *kk, integer *ntypes, logical *dotype,
integer *nrhs, integer *iseed, real *thresh, integer *nounit, real *a,
integer *lda, real *ab, integer *ldab, real *bd, real *be, real *q,
integer *ldq, real *p, integer *ldp, real *c__, integer *ldc, real *
cc, real *work, integer *lwork, real *result, integer *info)
{
/* Initialized data */
static integer ktype[15] = { 1,2,4,4,4,4,4,6,6,6,6,6,9,9,9 };
static integer kmagn[15] = { 1,1,1,1,1,2,3,1,1,1,2,3,1,2,3 };
static integer kmode[15] = { 0,0,4,3,1,4,4,4,3,1,4,4,0,0,0 };
/* Format strings */
static char fmt_9999[] = "(\002 SCHKBB: \002,a,\002 returned INFO=\002,i"
"5,\002.\002,/9x,\002M=\002,i5,\002 N=\002,i5,\002 K=\002,i5,\002"
", JTYPE=\002,i5,\002, ISEED=(\002,3(i5,\002,\002),i5,\002)\002)";
static char fmt_9998[] = "(\002 M =\002,i4,\002 N=\002,i4,\002, K=\002,i"
"3,\002, seed=\002,4(i4,\002,\002),\002 type \002,i2,\002, test"
"(\002,i2,\002)=\002,g10.3)";
/* System generated locals */
integer a_dim1, a_offset, ab_dim1, ab_offset, c_dim1, c_offset, cc_dim1,
cc_offset, p_dim1, p_offset, q_dim1, q_offset, i__1, i__2, i__3,
i__4, i__5, i__6, i__7, i__8, i__9;
/* Builtin functions */
double sqrt(doublereal);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
static real cond;
static integer jcol, kmax, mmax, nmax;
static real unfl, ovfl;
static integer i__, j, k, m, n;
static logical badmm, badnn;
static integer imode;
extern /* Subroutine */ int sbdt01_(integer *, integer *, integer *, real
*, integer *, real *, integer *, real *, real *, real *, integer *
, real *, real *), sbdt02_(integer *, integer *, real *, integer *
, real *, integer *, real *, integer *, real *, real *);
static integer iinfo;
static real anorm;
static integer mnmin, mnmax, nmats, jsize;
extern /* Subroutine */ int sort01_(char *, integer *, integer *, real *,
integer *, real *, integer *, real *);
static integer nerrs, itype, jtype, ntest;
extern /* Subroutine */ int slahd2_(integer *, char *);
static logical badnnb;
static integer kl, jr, ku;
extern /* Subroutine */ int sgbbrd_(char *, integer *, integer *, integer
*, integer *, integer *, real *, integer *, real *, real *, real *
, integer *, real *, integer *, real *, integer *, real *,
integer *);
extern doublereal slamch_(char *);
static integer idumma[1];
extern /* Subroutine */ int xerbla_(char *, integer *);
static integer ioldsd[4];
static real amninv;
static integer jwidth;
extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
integer *, real *, integer *), slaset_(char *, integer *,
integer *, real *, real *, real *, integer *), slatmr_(
integer *, integer *, char *, integer *, char *, real *, integer *
, real *, real *, char *, char *, real *, integer *, real *, real
*, integer *, real *, char *, integer *, integer *, integer *,
real *, real *, char *, real *, integer *, integer *, integer *), slatms_(integer *
, integer *, char *, integer *, char *, real *, integer *, real *,
real *, integer *, integer *, char *, real *, integer *, real *,
integer *), slasum_(char *, integer *,
integer *, integer *);
static real rtunfl, rtovfl, ulpinv;
static integer mtypes, ntestt;
static real ulp;
/* Fortran I/O blocks */
static cilist io___41 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___43 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___45 = { 0, 0, 0, fmt_9998, 0 };
#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
#define ab_ref(a_1,a_2) ab[(a_2)*ab_dim1 + a_1]
/* -- LAPACK test routine (release 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
Purpose
=======
SCHKBB tests the reduction of a general real rectangular band
matrix to bidiagonal form.
SGBBRD factors a general band matrix A as Q B P* , where * means
transpose, B is upper bidiagonal, and Q and P are orthogonal;
SGBBRD can also overwrite a given matrix C with Q* C .
For each pair of matrix dimensions (M,N) and each selected matrix
type, an M by N matrix A and an M by NRHS matrix C are generated.
The problem dimensions are as follows
A: M x N
Q: M x M
P: N x N
B: min(M,N) x min(M,N)
C: M x NRHS
For each generated matrix, 4 tests are performed:
(1) | A - Q B PT | / ( |A| max(M,N) ulp ), PT = P'
(2) | I - Q' Q | / ( M ulp )
(3) | I - PT PT' | / ( N ulp )
(4) | Y - Q' C | / ( |Y| max(M,NRHS) ulp ), where Y = Q' C.
The "types" are specified by a logical array DOTYPE( 1:NTYPES );
if DOTYPE(j) is .TRUE., then matrix type "j" will be generated.
Currently, the list of possible types is:
The possible matrix types are
(1) The zero matrix.
(2) The identity matrix.
(3) A diagonal matrix with evenly spaced entries
1, ..., ULP and random signs.
(ULP = (first number larger than 1) - 1 )
(4) A diagonal matrix with geometrically spaced entries
1, ..., ULP and random signs.
(5) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP
and random signs.
(6) Same as (3), but multiplied by SQRT( overflow threshold )
(7) Same as (3), but multiplied by SQRT( underflow threshold )
(8) A matrix of the form U D V, where U and V are orthogonal and
D has evenly spaced entries 1, ..., ULP with random signs
on the diagonal.
(9) A matrix of the form U D V, where U and V are orthogonal and
D has geometrically spaced entries 1, ..., ULP with random
signs on the diagonal.
(10) A matrix of the form U D V, where U and V are orthogonal and
D has "clustered" entries 1, ULP,..., ULP with random
signs on the diagonal.
(11) Same as (8), but multiplied by SQRT( overflow threshold )
(12) Same as (8), but multiplied by SQRT( underflow threshold )
(13) Rectangular matrix with random entries chosen from (-1,1).
(14) Same as (13), but multiplied by SQRT( overflow threshold )
(15) Same as (13), but multiplied by SQRT( underflow threshold )
Arguments
=========
NSIZES (input) INTEGER
The number of values of M and N contained in the vectors
MVAL and NVAL. The matrix sizes are used in pairs (M,N).
If NSIZES is zero, SCHKBB does nothing. NSIZES must be at
least zero.
MVAL (input) INTEGER array, dimension (NSIZES)
The values of the matrix row dimension M.
NVAL (input) INTEGER array, dimension (NSIZES)
The values of the matrix column dimension N.
NWDTHS (input) INTEGER
The number of bandwidths to use. If it is zero,
SCHKBB does nothing. It must be at least zero.
KK (input) INTEGER array, dimension (NWDTHS)
An array containing the bandwidths to be used for the band
matrices. The values must be at least zero.
NTYPES (input) INTEGER
The number of elements in DOTYPE. If it is zero, SCHKBB
does nothing. It must be at least zero. If it is MAXTYP+1
and NSIZES is 1, then an additional type, MAXTYP+1 is
defined, which is to use whatever matrix is in A. This
is only useful if DOTYPE(1:MAXTYP) is .FALSE. and
DOTYPE(MAXTYP+1) is .TRUE. .
DOTYPE (input) LOGICAL array, dimension (NTYPES)
If DOTYPE(j) is .TRUE., then for each size in NN a
matrix of that size and of type j will be generated.
If NTYPES is smaller than the maximum number of types
defined (PARAMETER MAXTYP), then types NTYPES+1 through
MAXTYP will not be generated. If NTYPES is larger
than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES)
will be ignored.
NRHS (input) INTEGER
The number of columns in the "right-hand side" matrix C.
If NRHS = 0, then the operations on the right-hand side will
not be tested. NRHS must be at least 0.
ISEED (input/output) INTEGER array, dimension (4)
On entry ISEED specifies the seed of the random number
generator. The array elements should be between 0 and 4095;
if not they will be reduced mod 4096. Also, ISEED(4) must
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 SCHKBB to continue the same random number
sequence.
THRESH (input) REAL
A test will count as "failed" if the "error", computed as
described above, exceeds THRESH. Note that the error
is scaled to be O(1), so THRESH should be a reasonably
small multiple of 1, e.g., 10 or 100. In particular,
it should not depend on the precision (single vs. double)
or the size of the matrix. It must be at least zero.
NOUNIT (input) INTEGER
The FORTRAN unit number for printing out error messages
(e.g., if a routine returns IINFO not equal to 0.)
A (input/workspace) REAL array, dimension
(LDA, max(NN))
Used to hold the matrix A.
LDA (input) INTEGER
The leading dimension of A. It must be at least 1
and at least max( NN ).
AB (workspace) REAL array, dimension (LDAB, max(NN))
Used to hold A in band storage format.
LDAB (input) INTEGER
The leading dimension of AB. It must be at least 2 (not 1!)
and at least max( KK )+1.
BD (workspace) REAL array, dimension (max(NN))
Used to hold the diagonal of the bidiagonal matrix computed
by SGBBRD.
BE (workspace) REAL array, dimension (max(NN))
Used to hold the off-diagonal of the bidiagonal matrix
computed by SGBBRD.
Q (workspace) REAL array, dimension (LDQ, max(NN))
Used to hold the orthogonal matrix Q computed by SGBBRD.
LDQ (input) INTEGER
The leading dimension of Q. It must be at least 1
and at least max( NN ).
P (workspace) REAL array, dimension (LDP, max(NN))
Used to hold the orthogonal matrix P computed by SGBBRD.
LDP (input) INTEGER
The leading dimension of P. It must be at least 1
and at least max( NN ).
C (workspace) REAL array, dimension (LDC, max(NN))
Used to hold the matrix C updated by SGBBRD.
LDC (input) INTEGER
The leading dimension of U. It must be at least 1
and at least max( NN ).
CC (workspace) REAL array, dimension (LDC, max(NN))
Used to hold a copy of the matrix C.
WORK (workspace) REAL array, dimension (LWORK)
LWORK (input) INTEGER
The number of entries in WORK. This must be at least
max( LDA+1, max(NN)+1 )*max(NN).
RESULT (output) REAL array, dimension (4)
The values computed by the tests described above.
The values are currently limited to 1/ulp, to avoid
overflow.
INFO (output) INTEGER
If 0, then everything ran OK.
-----------------------------------------------------------------------
Some Local Variables and Parameters:
---- ----- --------- --- ----------
ZERO, ONE Real 0 and 1.
MAXTYP The number of types defined.
NTEST The number of tests performed, or which can
be performed so far, for the current matrix.
NTESTT The total number of tests performed so far.
NMAX Largest value in NN.
NMATS The number of matrices generated so far.
NERRS The number of tests which have exceeded THRESH
so far.
COND, IMODE Values to be passed to the matrix generators.
ANORM Norm of A; passed to matrix generators.
OVFL, UNFL Overflow and underflow thresholds.
ULP, ULPINV Finest relative precision and its inverse.
RTOVFL, RTUNFL Square roots of the previous 2 values.
The following four arrays decode JTYPE:
KTYPE(j) The general type (1-10) for type "j".
KMODE(j) The MODE value to be passed to the matrix
generator for type "j".
KMAGN(j) The order of magnitude ( O(1),
O(overflow^(1/2) ), O(underflow^(1/2) )
=====================================================================
Parameter adjustments */
--mval;
--nval;
--kk;
--dotype;
--iseed;
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1 * 1;
ab -= ab_offset;
--bd;
--be;
q_dim1 = *ldq;
q_offset = 1 + q_dim1 * 1;
q -= q_offset;
p_dim1 = *ldp;
p_offset = 1 + p_dim1 * 1;
p -= p_offset;
cc_dim1 = *ldc;
cc_offset = 1 + cc_dim1 * 1;
cc -= cc_offset;
c_dim1 = *ldc;
c_offset = 1 + c_dim1 * 1;
c__ -= c_offset;
--work;
--result;
/* Function Body
Check for errors */
ntestt = 0;
*info = 0;
/* Important constants */
badmm = FALSE_;
badnn = FALSE_;
mmax = 1;
nmax = 1;
mnmax = 1;
i__1 = *nsizes;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = mmax, i__3 = mval[j];
mmax = max(i__2,i__3);
if (mval[j] < 0) {
badmm = TRUE_;
}
/* Computing MAX */
i__2 = nmax, i__3 = nval[j];
nmax = max(i__2,i__3);
if (nval[j] < 0) {
badnn = TRUE_;
}
/* Computing MAX
Computing MIN */
i__4 = mval[j], i__5 = nval[j];
i__2 = mnmax, i__3 = min(i__4,i__5);
mnmax = max(i__2,i__3);
/* L10: */
}
badnnb = FALSE_;
kmax = 0;
i__1 = *nwdths;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = kmax, i__3 = kk[j];
kmax = max(i__2,i__3);
if (kk[j] < 0) {
badnnb = TRUE_;
}
/* L20: */
}
/* Check for errors */
if (*nsizes < 0) {
*info = -1;
} else if (badmm) {
*info = -2;
} else if (badnn) {
*info = -3;
} else if (*nwdths < 0) {
*info = -4;
} else if (badnnb) {
*info = -5;
} else if (*ntypes < 0) {
*info = -6;
} else if (*nrhs < 0) {
*info = -8;
} else if (*lda < nmax) {
*info = -13;
} else if (*ldab < (kmax << 1) + 1) {
*info = -15;
} else if (*ldq < nmax) {
*info = -19;
} else if (*ldp < nmax) {
*info = -21;
} else if (*ldc < nmax) {
*info = -23;
} else if ((max(*lda,nmax) + 1) * nmax > *lwork) {
*info = -26;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SCHKBB", &i__1);
return 0;
}
/* Quick return if possible */
if (*nsizes == 0 || *ntypes == 0 || *nwdths == 0) {
return 0;
}
/* More Important constants */
unfl = slamch_("Safe minimum");
ovfl = 1.f / unfl;
ulp = slamch_("Epsilon") * slamch_("Base");
ulpinv = 1.f / ulp;
rtunfl = sqrt(unfl);
rtovfl = sqrt(ovfl);
/* Loop over sizes, widths, types */
nerrs = 0;
nmats = 0;
i__1 = *nsizes;
for (jsize = 1; jsize <= i__1; ++jsize) {
m = mval[jsize];
n = nval[jsize];
mnmin = min(m,n);
/* Computing MAX */
i__2 = max(1,m);
amninv = 1.f / (real) max(i__2,n);
i__2 = *nwdths;
for (jwidth = 1; jwidth <= i__2; ++jwidth) {
k = kk[jwidth];
if (k >= m && k >= n) {
goto L150;
}
/* Computing MAX
Computing MIN */
i__5 = m - 1;
i__3 = 0, i__4 = min(i__5,k);
kl = max(i__3,i__4);
/* Computing MAX
Computing MIN */
i__5 = n - 1;
i__3 = 0, i__4 = min(i__5,k);
ku = max(i__3,i__4);
if (*nsizes != 1) {
mtypes = min(15,*ntypes);
} else {
mtypes = min(16,*ntypes);
}
i__3 = mtypes;
for (jtype = 1; jtype <= i__3; ++jtype) {
if (! dotype[jtype]) {
goto L140;
}
++nmats;
ntest = 0;
for (j = 1; j <= 4; ++j) {
ioldsd[j - 1] = iseed[j];
/* L30: */
}
/* Compute "A".
Control parameters:
KMAGN KMODE KTYPE
=1 O(1) clustered 1 zero
=2 large clustered 2 identity
=3 small exponential (none)
=4 arithmetic diagonal, (w/ singular values)
=5 random log (none)
=6 random nonhermitian, w/ singular values
=7 (none)
=8 (none)
=9 random nonhermitian */
if (mtypes > 15) {
goto L90;
}
itype = ktype[jtype - 1];
imode = kmode[jtype - 1];
/* Compute norm */
switch (kmagn[jtype - 1]) {
case 1: goto L40;
case 2: goto L50;
case 3: goto L60;
}
L40:
anorm = 1.f;
goto L70;
L50:
anorm = rtovfl * ulp * amninv;
goto L70;
L60:
anorm = rtunfl * max(m,n) * ulpinv;
goto L70;
L70:
slaset_("Full", lda, &n, &c_b18, &c_b18, &a[a_offset], lda);
slaset_("Full", ldab, &n, &c_b18, &c_b18, &ab[ab_offset],
ldab);
iinfo = 0;
cond = ulpinv;
/* Special Matrices -- Identity & Jordan block
Zero */
if (itype == 1) {
iinfo = 0;
} else if (itype == 2) {
/* Identity */
i__4 = n;
for (jcol = 1; jcol <= i__4; ++jcol) {
a_ref(jcol, jcol) = anorm;
/* L80: */
}
} else if (itype == 4) {
/* Diagonal Matrix, singular values specified */
slatms_(&m, &n, "S", &iseed[1], "N", &work[1], &imode, &
cond, &anorm, &c__0, &c__0, "N", &a[a_offset],
lda, &work[m + 1], &iinfo);
} else if (itype == 6) {
/* Nonhermitian, singular values specified */
slatms_(&m, &n, "S", &iseed[1], "N", &work[1], &imode, &
cond, &anorm, &kl, &ku, "N", &a[a_offset], lda, &
work[m + 1], &iinfo);
} else if (itype == 9) {
/* Nonhermitian, random entries */
slatmr_(&m, &n, "S", &iseed[1], "N", &work[1], &c__6, &
c_b35, &c_b35, "T", "N", &work[n + 1], &c__1, &
c_b35, &work[(n << 1) + 1], &c__1, &c_b35, "N",
idumma, &kl, &ku, &c_b18, &anorm, "N", &a[
a_offset], lda, idumma, &iinfo);
} else {
iinfo = 1;
}
/* Generate Right-Hand Side */
slatmr_(&m, nrhs, "S", &iseed[1], "N", &work[1], &c__6, &
c_b35, &c_b35, "T", "N", &work[m + 1], &c__1, &c_b35,
&work[(m << 1) + 1], &c__1, &c_b35, "N", idumma, &m,
nrhs, &c_b18, &c_b35, "NO", &c__[c_offset], ldc,
idumma, &iinfo);
if (iinfo != 0) {
io___41.ciunit = *nounit;
s_wsfe(&io___41);
do_fio(&c__1, "Generator", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
;
e_wsfe();
*info = abs(iinfo);
return 0;
}
L90:
/* Copy A to band storage. */
i__4 = n;
for (j = 1; j <= i__4; ++j) {
/* Computing MAX */
i__5 = 1, i__6 = j - ku;
/* Computing MIN */
i__8 = m, i__9 = j + kl;
i__7 = min(i__8,i__9);
for (i__ = max(i__5,i__6); i__ <= i__7; ++i__) {
ab_ref(ku + 1 + i__ - j, j) = a_ref(i__, j);
/* L100: */
}
/* L110: */
}
/* Copy C */
slacpy_("Full", &m, nrhs, &c__[c_offset], ldc, &cc[cc_offset],
ldc);
/* Call SGBBRD to compute B, Q and P, and to update C. */
sgbbrd_("B", &m, &n, nrhs, &kl, &ku, &ab[ab_offset], ldab, &
bd[1], &be[1], &q[q_offset], ldq, &p[p_offset], ldp, &
cc[cc_offset], ldc, &work[1], &iinfo);
if (iinfo != 0) {
io___43.ciunit = *nounit;
s_wsfe(&io___43);
do_fio(&c__1, "SGBBRD", (ftnlen)6);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
;
e_wsfe();
*info = abs(iinfo);
if (iinfo < 0) {
return 0;
} else {
result[1] = ulpinv;
goto L120;
}
}
/* Test 1: Check the decomposition A := Q * B * P'
2: Check the orthogonality of Q
3: Check the orthogonality of P
4: Check the computation of Q' * C */
sbdt01_(&m, &n, &c_n1, &a[a_offset], lda, &q[q_offset], ldq, &
bd[1], &be[1], &p[p_offset], ldp, &work[1], &result[1]
);
sort01_("Columns", &m, &m, &q[q_offset], ldq, &work[1], lwork,
&result[2]);
sort01_("Rows", &n, &n, &p[p_offset], ldp, &work[1], lwork, &
result[3]);
sbdt02_(&m, nrhs, &c__[c_offset], ldc, &cc[cc_offset], ldc, &
q[q_offset], ldq, &work[1], &result[4]);
/* End of Loop -- Check for RESULT(j) > THRESH */
ntest = 4;
L120:
ntestt += ntest;
/* Print out tests which fail. */
i__4 = ntest;
for (jr = 1; jr <= i__4; ++jr) {
if (result[jr] >= *thresh) {
if (nerrs == 0) {
slahd2_(nounit, "SBB");
}
++nerrs;
io___45.ciunit = *nounit;
s_wsfe(&io___45);
do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof(
real));
e_wsfe();
}
/* L130: */
}
L140:
;
}
L150:
;
}
/* L160: */
}
/* Summary */
slasum_("SBB", nounit, &nerrs, &ntestt);
return 0;
/* End of SCHKBB */
} /* schkbb_ */
/* Subroutine */ int cchkhs_(integer *nsizes, integer *nn, integer *ntypes,
logical *dotype, integer *iseed, real *thresh, integer *nounit,
complex *a, integer *lda, complex *h__, complex *t1, complex *t2,
complex *u, integer *ldu, complex *z__, complex *uz, complex *w1,
complex *w3, complex *evectl, complex *evectr, complex *evecty,
complex *evectx, complex *uu, complex *tau, complex *work, integer *
nwork, real *rwork, integer *iwork, logical *select, real *result,
integer *info)
{
/* Initialized data */
static integer ktype[21] = { 1,2,3,4,4,4,4,4,6,6,6,6,6,6,6,6,6,6,9,9,9 };
static integer kmagn[21] = { 1,1,1,1,1,1,2,3,1,1,1,1,1,1,1,1,2,3,1,2,3 };
static integer kmode[21] = { 0,0,0,4,3,1,4,4,4,3,1,5,4,3,1,5,5,5,4,3,1 };
static integer kconds[21] = { 0,0,0,0,0,0,0,0,1,1,1,1,2,2,2,2,2,2,0,0,0 };
/* Format strings */
static char fmt_9999[] = "(\002 CCHKHS: \002,a,\002 returned INFO=\002,i"
"6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
"(\002,3(i5,\002,\002),i5,\002)\002)";
static char fmt_9998[] = "(\002 CCHKHS: \002,a,\002 Eigenvectors from"
" \002,a,\002 incorrectly \002,\002normalized.\002,/\002 Bits of "
"error=\002,0p,g10.3,\002,\002,9x,\002N=\002,i6,\002, JTYPE=\002,"
"i6,\002, ISEED=(\002,3(i5,\002,\002),i5,\002)\002)";
static char fmt_9997[] = "(\002 CCHKHS: Selected \002,a,\002 Eigenvector"
"s from \002,a,\002 do not match other eigenvectors \002,9x,\002N="
"\002,i6,\002, JTYPE=\002,i6,\002, ISEED=(\002,3(i5,\002,\002),i5,"
"\002)\002)";
/* System generated locals */
integer a_dim1, a_offset, evectl_dim1, evectl_offset, evectr_dim1,
evectr_offset, evectx_dim1, evectx_offset, evecty_dim1,
evecty_offset, h_dim1, h_offset, t1_dim1, t1_offset, t2_dim1,
t2_offset, u_dim1, u_offset, uu_dim1, uu_offset, uz_dim1,
uz_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5, i__6;
real r__1, r__2;
complex q__1;
/* Local variables */
integer i__, j, k, n, n1, jj, in, ihi, ilo;
real ulp, cond;
integer jcol, nmax;
real unfl, ovfl, temp1, temp2;
logical badnn;
extern /* Subroutine */ int cget10_(integer *, integer *, complex *,
integer *, complex *, integer *, complex *, real *, real *),
cget22_(char *, char *, char *, integer *, complex *, integer *,
complex *, integer *, complex *, complex *, real *, real *), cgemm_(char *, char *, integer *,
integer *, integer *, complex *, complex *, integer *, complex *,
integer *, complex *, complex *, integer *);
logical match;
integer imode;
extern /* Subroutine */ int chst01_(integer *, integer *, integer *,
complex *, integer *, complex *, integer *, complex *, integer *,
complex *, integer *, real *, real *);
real dumma[4];
integer iinfo;
real conds, aninv, anorm;
extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
complex *, integer *);
integer nmats, jsize, nerrs, itype, jtype, ntest;
real rtulp;
extern /* Subroutine */ int slabad_(real *, real *), cgehrd_(integer *,
integer *, integer *, complex *, integer *, complex *, complex *,
integer *, integer *), clatme_(integer *, char *, integer *,
complex *, integer *, real *, complex *, char *, char *, char *,
char *, real *, integer *, real *, integer *, integer *, real *,
complex *, integer *, complex *, integer *);
complex cdumma[4];
extern doublereal slamch_(char *);
extern /* Subroutine */ int chsein_(char *, char *, char *, logical *,
integer *, complex *, integer *, complex *, complex *, integer *,
complex *, integer *, integer *, integer *, complex *, real *,
integer *, integer *, integer *), clacpy_(
char *, integer *, integer *, complex *, integer *, complex *,
integer *);
integer idumma[1];
extern /* Subroutine */ int claset_(char *, integer *, integer *, complex
*, complex *, complex *, integer *);
integer ioldsd[4];
extern /* Subroutine */ int xerbla_(char *, integer *), clatmr_(
integer *, integer *, char *, integer *, char *, complex *,
integer *, real *, complex *, char *, char *, complex *, integer *
, real *, complex *, integer *, real *, char *, integer *,
integer *, integer *, real *, real *, char *, complex *, integer *
, integer *, integer *), clatms_(integer *, integer *, char *, integer *, char *,
real *, integer *, real *, real *, integer *, integer *, char *,
complex *, integer *, complex *, integer *), chseqr_(char *, char *, integer *, integer *, integer *,
complex *, integer *, complex *, complex *, integer *, complex *,
integer *, integer *), ctrevc_(char *, char *,
logical *, integer *, complex *, integer *, complex *, integer *,
complex *, integer *, integer *, integer *, complex *, real *,
integer *), cunghr_(integer *, integer *, integer
*, complex *, integer *, complex *, complex *, integer *, integer
*), cunmhr_(char *, char *, integer *, integer *, integer *,
integer *, complex *, integer *, complex *, complex *, integer *,
complex *, integer *, integer *), slafts_(char *,
integer *, integer *, integer *, integer *, real *, integer *,
real *, integer *, integer *), slasum_(char *, integer *,
integer *, integer *);
real rtunfl, rtovfl, rtulpi, ulpinv;
integer mtypes, ntestt;
/* Fortran I/O blocks */
static cilist io___35 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___38 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___40 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___41 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___42 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___47 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___49 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___50 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___54 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___55 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___56 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___57 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___58 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___59 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___60 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___61 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___62 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___63 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___64 = { 0, 0, 0, fmt_9999, 0 };
/* -- LAPACK test routine (version 3.1.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* February 2007 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CCHKHS checks the nonsymmetric eigenvalue problem routines. */
/* CGEHRD factors A as U H U' , where ' means conjugate */
/* transpose, H is hessenberg, and U is unitary. */
/* CUNGHR generates the unitary matrix U. */
/* CUNMHR multiplies a matrix by the unitary matrix U. */
/* CHSEQR factors H as Z T Z' , where Z is unitary and T */
/* is upper triangular. It also computes the eigenvalues, */
/* w(1), ..., w(n); we define a diagonal matrix W whose */
/* (diagonal) entries are the eigenvalues. */
/* CTREVC computes the left eigenvector matrix L and the */
/* right eigenvector matrix R for the matrix T. The */
/* columns of L are the complex conjugates of the left */
/* eigenvectors of T. The columns of R are the right */
/* eigenvectors of T. L is lower triangular, and R is */
/* upper triangular. */
/* CHSEIN computes the left eigenvector matrix Y and the */
/* right eigenvector matrix X for the matrix H. The */
/* columns of Y are the complex conjugates of the left */
/* eigenvectors of H. The columns of X are the right */
/* eigenvectors of H. Y is lower triangular, and X is */
/* upper triangular. */
/* When CCHKHS is called, a number of matrix "sizes" ("n's") and a */
/* number of matrix "types" are specified. For each size ("n") */
/* and each type of matrix, one matrix will be generated and used */
/* to test the nonsymmetric eigenroutines. For each matrix, 14 */
/* tests will be performed: */
/* (1) | A - U H U**H | / ( |A| n ulp ) */
/* (2) | I - UU**H | / ( n ulp ) */
/* (3) | H - Z T Z**H | / ( |H| n ulp ) */
/* (4) | I - ZZ**H | / ( n ulp ) */
/* (5) | A - UZ H (UZ)**H | / ( |A| n ulp ) */
/* (6) | I - UZ (UZ)**H | / ( n ulp ) */
/* (7) | T(Z computed) - T(Z not computed) | / ( |T| ulp ) */
/* (8) | W(Z computed) - W(Z not computed) | / ( |W| ulp ) */
/* (9) | TR - RW | / ( |T| |R| ulp ) */
/* (10) | L**H T - W**H L | / ( |T| |L| ulp ) */
/* (11) | HX - XW | / ( |H| |X| ulp ) */
/* (12) | Y**H H - W**H Y | / ( |H| |Y| ulp ) */
/* (13) | AX - XW | / ( |A| |X| ulp ) */
/* (14) | Y**H A - W**H Y | / ( |A| |Y| ulp ) */
/* The "sizes" are specified by an array NN(1:NSIZES); the value of */
/* each element NN(j) specifies one size. */
/* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); */
/* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. */
/* Currently, the list of possible types is: */
/* (1) The zero matrix. */
/* (2) The identity matrix. */
/* (3) A (transposed) Jordan block, with 1's on the diagonal. */
/* (4) A diagonal matrix with evenly spaced entries */
/* 1, ..., ULP and random complex angles. */
/* (ULP = (first number larger than 1) - 1 ) */
/* (5) A diagonal matrix with geometrically spaced entries */
/* 1, ..., ULP and random complex angles. */
/* (6) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP */
/* and random complex angles. */
/* (7) Same as (4), but multiplied by SQRT( overflow threshold ) */
/* (8) Same as (4), but multiplied by SQRT( underflow threshold ) */
/* (9) A matrix of the form U' T U, where U is unitary and */
/* T has evenly spaced entries 1, ..., ULP with random complex */
/* angles on the diagonal and random O(1) entries in the upper */
/* triangle. */
/* (10) A matrix of the form U' T U, where U is unitary and */
/* T has geometrically spaced entries 1, ..., ULP with random */
/* complex angles on the diagonal and random O(1) entries in */
/* the upper triangle. */
/* (11) A matrix of the form U' T U, where U is unitary and */
/* T has "clustered" entries 1, ULP,..., ULP with random */
/* complex angles on the diagonal and random O(1) entries in */
/* the upper triangle. */
/* (12) A matrix of the form U' T U, where U is unitary and */
/* T has complex eigenvalues randomly chosen from */
/* ULP < |z| < 1 and random O(1) entries in the upper */
/* triangle. */
/* (13) A matrix of the form X' T X, where X has condition */
/* SQRT( ULP ) and T has evenly spaced entries 1, ..., ULP */
/* with random complex angles on the diagonal and random O(1) */
/* entries in the upper triangle. */
/* (14) A matrix of the form X' T X, where X has condition */
/* SQRT( ULP ) and T has geometrically spaced entries */
/* 1, ..., ULP with random complex angles on the diagonal */
/* and random O(1) entries in the upper triangle. */
/* (15) A matrix of the form X' T X, where X has condition */
/* SQRT( ULP ) and T has "clustered" entries 1, ULP,..., ULP */
/* with random complex angles on the diagonal and random O(1) */
/* entries in the upper triangle. */
/* (16) A matrix of the form X' T X, where X has condition */
/* SQRT( ULP ) and T has complex eigenvalues randomly chosen */
/* from ULP < |z| < 1 and random O(1) entries in the upper */
/* triangle. */
/* (17) Same as (16), but multiplied by SQRT( overflow threshold ) */
/* (18) Same as (16), but multiplied by SQRT( underflow threshold ) */
/* (19) Nonsymmetric matrix with random entries chosen from |z| < 1 */
/* (20) Same as (19), but multiplied by SQRT( overflow threshold ) */
/* (21) Same as (19), but multiplied by SQRT( underflow threshold ) */
/* Arguments */
/* ========== */
/* NSIZES - INTEGER */
/* The number of sizes of matrices to use. If it is zero, */
/* CCHKHS does nothing. It must be at least zero. */
/* Not modified. */
/* NN - INTEGER array, dimension (NSIZES) */
/* An array containing the sizes to be used for the matrices. */
/* Zero values will be skipped. The values must be at least */
/* zero. */
/* Not modified. */
/* NTYPES - INTEGER */
/* The number of elements in DOTYPE. If it is zero, CCHKHS */
/* does nothing. It must be at least zero. If it is MAXTYP+1 */
/* and NSIZES is 1, then an additional type, MAXTYP+1 is */
/* defined, which is to use whatever matrix is in A. This */
/* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and */
/* DOTYPE(MAXTYP+1) is .TRUE. . */
/* Not modified. */
/* DOTYPE - LOGICAL array, dimension (NTYPES) */
/* If DOTYPE(j) is .TRUE., then for each size in NN a */
/* matrix of that size and of type j will be generated. */
/* If NTYPES is smaller than the maximum number of types */
/* defined (PARAMETER MAXTYP), then types NTYPES+1 through */
/* MAXTYP will not be generated. If NTYPES is larger */
/* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) */
/* will be ignored. */
/* Not modified. */
/* ISEED - INTEGER array, dimension (4) */
/* On entry ISEED specifies the seed of the random number */
/* generator. The array elements should be between 0 and 4095; */
/* if not they will be reduced mod 4096. Also, ISEED(4) must */
/* 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 CCHKHS to continue the same random number */
/* sequence. */
/* Modified. */
/* THRESH - REAL */
/* A test will count as "failed" if the "error", computed as */
/* described above, exceeds THRESH. Note that the error */
/* is scaled to be O(1), so THRESH should be a reasonably */
/* small multiple of 1, e.g., 10 or 100. In particular, */
/* it should not depend on the precision (single vs. double) */
/* or the size of the matrix. It must be at least zero. */
/* Not modified. */
/* NOUNIT - INTEGER */
/* The FORTRAN unit number for printing out error messages */
/* (e.g., if a routine returns IINFO not equal to 0.) */
/* Not modified. */
/* A - COMPLEX array, dimension (LDA,max(NN)) */
/* Used to hold the matrix whose eigenvalues are to be */
/* computed. On exit, A contains the last matrix actually */
/* used. */
/* Modified. */
/* LDA - INTEGER */
/* The leading dimension of A, H, T1 and T2. It must be at */
/* least 1 and at least max( NN ). */
/* Not modified. */
/* H - COMPLEX array, dimension (LDA,max(NN)) */
/* The upper hessenberg matrix computed by CGEHRD. On exit, */
/* H contains the Hessenberg form of the matrix in A. */
/* Modified. */
/* T1 - COMPLEX array, dimension (LDA,max(NN)) */
/* The Schur (="quasi-triangular") matrix computed by CHSEQR */
/* if Z is computed. On exit, T1 contains the Schur form of */
/* the matrix in A. */
/* Modified. */
/* T2 - COMPLEX array, dimension (LDA,max(NN)) */
/* The Schur matrix computed by CHSEQR when Z is not computed. */
/* This should be identical to T1. */
/* Modified. */
/* LDU - INTEGER */
/* The leading dimension of U, Z, UZ and UU. It must be at */
/* least 1 and at least max( NN ). */
/* Not modified. */
/* U - COMPLEX array, dimension (LDU,max(NN)) */
/* The unitary matrix computed by CGEHRD. */
/* Modified. */
/* Z - COMPLEX array, dimension (LDU,max(NN)) */
/* The unitary matrix computed by CHSEQR. */
/* Modified. */
/* UZ - COMPLEX array, dimension (LDU,max(NN)) */
/* The product of U times Z. */
/* Modified. */
/* W1 - COMPLEX array, dimension (max(NN)) */
/* The eigenvalues of A, as computed by a full Schur */
/* decomposition H = Z T Z'. On exit, W1 contains the */
/* eigenvalues of the matrix in A. */
/* Modified. */
/* W3 - COMPLEX array, dimension (max(NN)) */
/* The eigenvalues of A, as computed by a partial Schur */
/* decomposition (Z not computed, T only computed as much */
/* as is necessary for determining eigenvalues). On exit, */
/* W3 contains the eigenvalues of the matrix in A, possibly */
/* perturbed by CHSEIN. */
/* Modified. */
/* EVECTL - COMPLEX array, dimension (LDU,max(NN)) */
/* The conjugate transpose of the (upper triangular) left */
/* eigenvector matrix for the matrix in T1. */
/* Modified. */
/* EVECTR - COMPLEX array, dimension (LDU,max(NN)) */
/* The (upper triangular) right eigenvector matrix for the */
/* matrix in T1. */
/* Modified. */
/* EVECTY - COMPLEX array, dimension (LDU,max(NN)) */
/* The conjugate transpose of the left eigenvector matrix */
/* for the matrix in H. */
/* Modified. */
/* EVECTX - COMPLEX array, dimension (LDU,max(NN)) */
/* The right eigenvector matrix for the matrix in H. */
/* Modified. */
/* UU - COMPLEX array, dimension (LDU,max(NN)) */
/* Details of the unitary matrix computed by CGEHRD. */
/* Modified. */
/* TAU - COMPLEX array, dimension (max(NN)) */
/* Further details of the unitary matrix computed by CGEHRD. */
/* Modified. */
/* WORK - COMPLEX array, dimension (NWORK) */
/* Workspace. */
/* Modified. */
/* NWORK - INTEGER */
/* The number of entries in WORK. NWORK >= 4*NN(j)*NN(j) + 2. */
/* RWORK - REAL array, dimension (max(NN)) */
/* Workspace. Could be equivalenced to IWORK, but not SELECT. */
/* Modified. */
/* IWORK - INTEGER array, dimension (max(NN)) */
/* Workspace. */
/* Modified. */
/* SELECT - LOGICAL array, dimension (max(NN)) */
/* Workspace. Could be equivalenced to IWORK, but not RWORK. */
/* Modified. */
/* RESULT - REAL array, dimension (14) */
/* The values computed by the fourteen tests described above. */
/* The values are currently limited to 1/ulp, to avoid */
/* overflow. */
/* Modified. */
/* INFO - INTEGER */
/* If 0, then everything ran OK. */
/* -1: NSIZES < 0 */
/* -2: Some NN(j) < 0 */
/* -3: NTYPES < 0 */
/* -6: THRESH < 0 */
/* -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ). */
/* -14: LDU < 1 or LDU < NMAX. */
/* -26: NWORK too small. */
/* If CLATMR, CLATMS, or CLATME returns an error code, the */
/* absolute value of it is returned. */
/* If 1, then CHSEQR could not find all the shifts. */
/* If 2, then the EISPACK code (for small blocks) failed. */
/* If >2, then 30*N iterations were not enough to find an */
/* eigenvalue or to decompose the problem. */
/* Modified. */
/* ----------------------------------------------------------------------- */
/* Some Local Variables and Parameters: */
/* ---- ----- --------- --- ---------- */
/* ZERO, ONE Real 0 and 1. */
/* MAXTYP The number of types defined. */
/* MTEST The number of tests defined: care must be taken */
/* that (1) the size of RESULT, (2) the number of */
/* tests actually performed, and (3) MTEST agree. */
/* NTEST The number of tests performed on this matrix */
/* so far. This should be less than MTEST, and */
/* equal to it by the last test. It will be less */
/* if any of the routines being tested indicates */
/* that it could not compute the matrices that */
/* would be tested. */
/* NMAX Largest value in NN. */
/* NMATS The number of matrices generated so far. */
/* NERRS The number of tests which have exceeded THRESH */
/* so far (computed by SLAFTS). */
/* COND, CONDS, */
/* IMODE Values to be passed to the matrix generators. */
/* ANORM Norm of A; passed to matrix generators. */
/* OVFL, UNFL Overflow and underflow thresholds. */
/* ULP, ULPINV Finest relative precision and its inverse. */
/* RTOVFL, RTUNFL, */
/* RTULP, RTULPI Square roots of the previous 4 values. */
/* The following four arrays decode JTYPE: */
/* KTYPE(j) The general type (1-10) for type "j". */
/* KMODE(j) The MODE value to be passed to the matrix */
/* generator for type "j". */
/* KMAGN(j) The order of magnitude ( O(1), */
/* O(overflow^(1/2) ), O(underflow^(1/2) ) */
/* KCONDS(j) Selects whether CONDS is to be 1 or */
/* 1/sqrt(ulp). (0 means irrelevant.) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--nn;
--dotype;
--iseed;
t2_dim1 = *lda;
t2_offset = 1 + t2_dim1;
t2 -= t2_offset;
t1_dim1 = *lda;
t1_offset = 1 + t1_dim1;
t1 -= t1_offset;
h_dim1 = *lda;
h_offset = 1 + h_dim1;
h__ -= h_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
uu_dim1 = *ldu;
uu_offset = 1 + uu_dim1;
uu -= uu_offset;
evectx_dim1 = *ldu;
evectx_offset = 1 + evectx_dim1;
evectx -= evectx_offset;
evecty_dim1 = *ldu;
evecty_offset = 1 + evecty_dim1;
evecty -= evecty_offset;
evectr_dim1 = *ldu;
evectr_offset = 1 + evectr_dim1;
evectr -= evectr_offset;
evectl_dim1 = *ldu;
evectl_offset = 1 + evectl_dim1;
evectl -= evectl_offset;
uz_dim1 = *ldu;
uz_offset = 1 + uz_dim1;
uz -= uz_offset;
z_dim1 = *ldu;
z_offset = 1 + z_dim1;
z__ -= z_offset;
u_dim1 = *ldu;
u_offset = 1 + u_dim1;
u -= u_offset;
--w1;
--w3;
--tau;
--work;
--rwork;
--iwork;
--select;
--result;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* Check for errors */
ntestt = 0;
*info = 0;
badnn = FALSE_;
nmax = 0;
i__1 = *nsizes;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = nmax, i__3 = nn[j];
nmax = max(i__2,i__3);
if (nn[j] < 0) {
badnn = TRUE_;
}
/* L10: */
}
/* Check for errors */
if (*nsizes < 0) {
*info = -1;
} else if (badnn) {
*info = -2;
} else if (*ntypes < 0) {
*info = -3;
} else if (*thresh < 0.f) {
*info = -6;
} else if (*lda <= 1 || *lda < nmax) {
*info = -9;
} else if (*ldu <= 1 || *ldu < nmax) {
*info = -14;
} else if ((nmax << 2) * nmax + 2 > *nwork) {
*info = -26;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CCHKHS", &i__1);
return 0;
}
/* Quick return if possible */
if (*nsizes == 0 || *ntypes == 0) {
return 0;
}
/* More important constants */
unfl = slamch_("Safe minimum");
ovfl = slamch_("Overflow");
slabad_(&unfl, &ovfl);
ulp = slamch_("Epsilon") * slamch_("Base");
ulpinv = 1.f / ulp;
rtunfl = sqrt(unfl);
rtovfl = sqrt(ovfl);
rtulp = sqrt(ulp);
rtulpi = 1.f / rtulp;
/* Loop over sizes, types */
nerrs = 0;
nmats = 0;
i__1 = *nsizes;
for (jsize = 1; jsize <= i__1; ++jsize) {
n = nn[jsize];
n1 = max(1,n);
aninv = 1.f / (real) n1;
if (*nsizes != 1) {
mtypes = min(21,*ntypes);
} else {
mtypes = min(22,*ntypes);
}
i__2 = mtypes;
for (jtype = 1; jtype <= i__2; ++jtype) {
if (! dotype[jtype]) {
goto L250;
}
++nmats;
ntest = 0;
/* Save ISEED in case of an error. */
for (j = 1; j <= 4; ++j) {
ioldsd[j - 1] = iseed[j];
/* L20: */
}
/* Initialize RESULT */
for (j = 1; j <= 14; ++j) {
result[j] = 0.f;
/* L30: */
}
/* Compute "A" */
/* Control parameters: */
/* KMAGN KCONDS KMODE KTYPE */
/* =1 O(1) 1 clustered 1 zero */
/* =2 large large clustered 2 identity */
/* =3 small exponential Jordan */
/* =4 arithmetic diagonal, (w/ eigenvalues) */
/* =5 random log hermitian, w/ eigenvalues */
/* =6 random general, w/ eigenvalues */
/* =7 random diagonal */
/* =8 random hermitian */
/* =9 random general */
/* =10 random triangular */
if (mtypes > 21) {
goto L100;
}
itype = ktype[jtype - 1];
imode = kmode[jtype - 1];
/* Compute norm */
switch (kmagn[jtype - 1]) {
case 1: goto L40;
case 2: goto L50;
case 3: goto L60;
}
L40:
anorm = 1.f;
goto L70;
L50:
anorm = rtovfl * ulp * aninv;
goto L70;
L60:
anorm = rtunfl * n * ulpinv;
goto L70;
L70:
claset_("Full", lda, &n, &c_b1, &c_b1, &a[a_offset], lda);
iinfo = 0;
cond = ulpinv;
/* Special Matrices */
if (itype == 1) {
/* Zero */
iinfo = 0;
} else if (itype == 2) {
/* Identity */
i__3 = n;
for (jcol = 1; jcol <= i__3; ++jcol) {
i__4 = jcol + jcol * a_dim1;
a[i__4].r = anorm, a[i__4].i = 0.f;
/* L80: */
}
} else if (itype == 3) {
/* Jordan Block */
i__3 = n;
for (jcol = 1; jcol <= i__3; ++jcol) {
i__4 = jcol + jcol * a_dim1;
a[i__4].r = anorm, a[i__4].i = 0.f;
if (jcol > 1) {
i__4 = jcol + (jcol - 1) * a_dim1;
a[i__4].r = 1.f, a[i__4].i = 0.f;
}
/* L90: */
}
} else if (itype == 4) {
/* Diagonal Matrix, [Eigen]values Specified */
clatmr_(&n, &n, "D", &iseed[1], "N", &work[1], &imode, &cond,
&c_b2, "T", "N", &work[n + 1], &c__1, &c_b27, &work[(
n << 1) + 1], &c__1, &c_b27, "N", idumma, &c__0, &
c__0, &c_b33, &anorm, "NO", &a[a_offset], lda, &iwork[
1], &iinfo);
} else if (itype == 5) {
/* Hermitian, eigenvalues specified */
clatms_(&n, &n, "D", &iseed[1], "H", &rwork[1], &imode, &cond,
&anorm, &n, &n, "N", &a[a_offset], lda, &work[1], &
iinfo);
} else if (itype == 6) {
/* General, eigenvalues specified */
if (kconds[jtype - 1] == 1) {
conds = 1.f;
} else if (kconds[jtype - 1] == 2) {
conds = rtulpi;
} else {
conds = 0.f;
}
clatme_(&n, "D", &iseed[1], &work[1], &imode, &cond, &c_b2,
" ", "T", "T", "T", &rwork[1], &c__4, &conds, &n, &n,
&anorm, &a[a_offset], lda, &work[n + 1], &iinfo);
} else if (itype == 7) {
/* Diagonal, random eigenvalues */
clatmr_(&n, &n, "D", &iseed[1], "N", &work[1], &c__6, &c_b27,
&c_b2, "T", "N", &work[n + 1], &c__1, &c_b27, &work[(
n << 1) + 1], &c__1, &c_b27, "N", idumma, &c__0, &
c__0, &c_b33, &anorm, "NO", &a[a_offset], lda, &iwork[
1], &iinfo);
} else if (itype == 8) {
/* Hermitian, random eigenvalues */
clatmr_(&n, &n, "D", &iseed[1], "H", &work[1], &c__6, &c_b27,
&c_b2, "T", "N", &work[n + 1], &c__1, &c_b27, &work[(
n << 1) + 1], &c__1, &c_b27, "N", idumma, &n, &n, &
c_b33, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
iinfo);
} else if (itype == 9) {
/* General, random eigenvalues */
clatmr_(&n, &n, "D", &iseed[1], "N", &work[1], &c__6, &c_b27,
&c_b2, "T", "N", &work[n + 1], &c__1, &c_b27, &work[(
n << 1) + 1], &c__1, &c_b27, "N", idumma, &n, &n, &
c_b33, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
iinfo);
} else if (itype == 10) {
/* Triangular, random eigenvalues */
clatmr_(&n, &n, "D", &iseed[1], "N", &work[1], &c__6, &c_b27,
&c_b2, "T", "N", &work[n + 1], &c__1, &c_b27, &work[(
n << 1) + 1], &c__1, &c_b27, "N", idumma, &n, &c__0, &
c_b33, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
iinfo);
} else {
iinfo = 1;
}
if (iinfo != 0) {
io___35.ciunit = *nounit;
s_wsfe(&io___35);
do_fio(&c__1, "Generator", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
return 0;
}
L100:
/* Call CGEHRD to compute H and U, do tests. */
clacpy_(" ", &n, &n, &a[a_offset], lda, &h__[h_offset], lda);
ntest = 1;
ilo = 1;
ihi = n;
i__3 = *nwork - n;
cgehrd_(&n, &ilo, &ihi, &h__[h_offset], lda, &work[1], &work[n +
1], &i__3, &iinfo);
if (iinfo != 0) {
result[1] = ulpinv;
io___38.ciunit = *nounit;
s_wsfe(&io___38);
do_fio(&c__1, "CGEHRD", (ftnlen)6);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
goto L240;
}
i__3 = n - 1;
for (j = 1; j <= i__3; ++j) {
i__4 = j + 1 + j * uu_dim1;
uu[i__4].r = 0.f, uu[i__4].i = 0.f;
i__4 = n;
for (i__ = j + 2; i__ <= i__4; ++i__) {
i__5 = i__ + j * u_dim1;
i__6 = i__ + j * h_dim1;
u[i__5].r = h__[i__6].r, u[i__5].i = h__[i__6].i;
i__5 = i__ + j * uu_dim1;
i__6 = i__ + j * h_dim1;
uu[i__5].r = h__[i__6].r, uu[i__5].i = h__[i__6].i;
i__5 = i__ + j * h_dim1;
h__[i__5].r = 0.f, h__[i__5].i = 0.f;
/* L110: */
}
/* L120: */
}
i__3 = n - 1;
ccopy_(&i__3, &work[1], &c__1, &tau[1], &c__1);
i__3 = *nwork - n;
cunghr_(&n, &ilo, &ihi, &u[u_offset], ldu, &work[1], &work[n + 1],
&i__3, &iinfo);
ntest = 2;
chst01_(&n, &ilo, &ihi, &a[a_offset], lda, &h__[h_offset], lda, &
u[u_offset], ldu, &work[1], nwork, &rwork[1], &result[1]);
/* Call CHSEQR to compute T1, T2 and Z, do tests. */
/* Eigenvalues only (W3) */
clacpy_(" ", &n, &n, &h__[h_offset], lda, &t2[t2_offset], lda);
ntest = 3;
result[3] = ulpinv;
chseqr_("E", "N", &n, &ilo, &ihi, &t2[t2_offset], lda, &w3[1], &
uz[uz_offset], ldu, &work[1], nwork, &iinfo);
if (iinfo != 0) {
io___40.ciunit = *nounit;
s_wsfe(&io___40);
do_fio(&c__1, "CHSEQR(E)", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
if (iinfo <= n + 2) {
*info = abs(iinfo);
goto L240;
}
}
/* Eigenvalues (W1) and Full Schur Form (T2) */
clacpy_(" ", &n, &n, &h__[h_offset], lda, &t2[t2_offset], lda);
chseqr_("S", "N", &n, &ilo, &ihi, &t2[t2_offset], lda, &w1[1], &
uz[uz_offset], ldu, &work[1], nwork, &iinfo);
if (iinfo != 0 && iinfo <= n + 2) {
io___41.ciunit = *nounit;
s_wsfe(&io___41);
do_fio(&c__1, "CHSEQR(S)", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
goto L240;
}
/* Eigenvalues (W1), Schur Form (T1), and Schur Vectors (UZ) */
clacpy_(" ", &n, &n, &h__[h_offset], lda, &t1[t1_offset], lda);
clacpy_(" ", &n, &n, &u[u_offset], ldu, &uz[uz_offset], ldu);
chseqr_("S", "V", &n, &ilo, &ihi, &t1[t1_offset], lda, &w1[1], &
uz[uz_offset], ldu, &work[1], nwork, &iinfo);
if (iinfo != 0 && iinfo <= n + 2) {
io___42.ciunit = *nounit;
s_wsfe(&io___42);
do_fio(&c__1, "CHSEQR(V)", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
goto L240;
}
/* Compute Z = U' UZ */
cgemm_("C", "N", &n, &n, &n, &c_b2, &u[u_offset], ldu, &uz[
uz_offset], ldu, &c_b1, &z__[z_offset], ldu);
ntest = 8;
/* Do Tests 3: | H - Z T Z' | / ( |H| n ulp ) */
/* and 4: | I - Z Z' | / ( n ulp ) */
chst01_(&n, &ilo, &ihi, &h__[h_offset], lda, &t1[t1_offset], lda,
&z__[z_offset], ldu, &work[1], nwork, &rwork[1], &result[
3]);
/* Do Tests 5: | A - UZ T (UZ)' | / ( |A| n ulp ) */
/* and 6: | I - UZ (UZ)' | / ( n ulp ) */
chst01_(&n, &ilo, &ihi, &a[a_offset], lda, &t1[t1_offset], lda, &
uz[uz_offset], ldu, &work[1], nwork, &rwork[1], &result[5]
);
/* Do Test 7: | T2 - T1 | / ( |T| n ulp ) */
cget10_(&n, &n, &t2[t2_offset], lda, &t1[t1_offset], lda, &work[1]
, &rwork[1], &result[7]);
/* Do Test 8: | W3 - W1 | / ( max(|W1|,|W3|) ulp ) */
temp1 = 0.f;
temp2 = 0.f;
i__3 = n;
for (j = 1; j <= i__3; ++j) {
/* Computing MAX */
r__1 = temp1, r__2 = c_abs(&w1[j]), r__1 = max(r__1,r__2),
r__2 = c_abs(&w3[j]);
temp1 = dmax(r__1,r__2);
/* Computing MAX */
i__4 = j;
i__5 = j;
q__1.r = w1[i__4].r - w3[i__5].r, q__1.i = w1[i__4].i - w3[
i__5].i;
r__1 = temp2, r__2 = c_abs(&q__1);
temp2 = dmax(r__1,r__2);
/* L130: */
}
/* Computing MAX */
r__1 = unfl, r__2 = ulp * dmax(temp1,temp2);
result[8] = temp2 / dmax(r__1,r__2);
/* Compute the Left and Right Eigenvectors of T */
/* Compute the Right eigenvector Matrix: */
ntest = 9;
result[9] = ulpinv;
/* Select every other eigenvector */
i__3 = n;
for (j = 1; j <= i__3; ++j) {
select[j] = FALSE_;
/* L140: */
}
i__3 = n;
for (j = 1; j <= i__3; j += 2) {
select[j] = TRUE_;
/* L150: */
}
ctrevc_("Right", "All", &select[1], &n, &t1[t1_offset], lda,
cdumma, ldu, &evectr[evectr_offset], ldu, &n, &in, &work[
1], &rwork[1], &iinfo);
if (iinfo != 0) {
io___47.ciunit = *nounit;
s_wsfe(&io___47);
do_fio(&c__1, "CTREVC(R,A)", (ftnlen)11);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
goto L240;
}
/* Test 9: | TR - RW | / ( |T| |R| ulp ) */
cget22_("N", "N", "N", &n, &t1[t1_offset], lda, &evectr[
evectr_offset], ldu, &w1[1], &work[1], &rwork[1], dumma);
result[9] = dumma[0];
if (dumma[1] > *thresh) {
io___49.ciunit = *nounit;
s_wsfe(&io___49);
do_fio(&c__1, "Right", (ftnlen)5);
do_fio(&c__1, "CTREVC", (ftnlen)6);
do_fio(&c__1, (char *)&dumma[1], (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
}
/* Compute selected right eigenvectors and confirm that */
/* they agree with previous right eigenvectors */
ctrevc_("Right", "Some", &select[1], &n, &t1[t1_offset], lda,
cdumma, ldu, &evectl[evectl_offset], ldu, &n, &in, &work[
1], &rwork[1], &iinfo);
if (iinfo != 0) {
io___50.ciunit = *nounit;
s_wsfe(&io___50);
do_fio(&c__1, "CTREVC(R,S)", (ftnlen)11);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
goto L240;
}
k = 1;
match = TRUE_;
i__3 = n;
for (j = 1; j <= i__3; ++j) {
if (select[j]) {
i__4 = n;
for (jj = 1; jj <= i__4; ++jj) {
i__5 = jj + j * evectr_dim1;
i__6 = jj + k * evectl_dim1;
if (evectr[i__5].r != evectl[i__6].r || evectr[i__5]
.i != evectl[i__6].i) {
match = FALSE_;
goto L180;
}
/* L160: */
}
++k;
}
/* L170: */
}
L180:
if (! match) {
io___54.ciunit = *nounit;
s_wsfe(&io___54);
do_fio(&c__1, "Right", (ftnlen)5);
do_fio(&c__1, "CTREVC", (ftnlen)6);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
}
/* Compute the Left eigenvector Matrix: */
ntest = 10;
result[10] = ulpinv;
ctrevc_("Left", "All", &select[1], &n, &t1[t1_offset], lda, &
evectl[evectl_offset], ldu, cdumma, ldu, &n, &in, &work[1]
, &rwork[1], &iinfo);
if (iinfo != 0) {
io___55.ciunit = *nounit;
s_wsfe(&io___55);
do_fio(&c__1, "CTREVC(L,A)", (ftnlen)11);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
goto L240;
}
/* Test 10: | LT - WL | / ( |T| |L| ulp ) */
cget22_("C", "N", "C", &n, &t1[t1_offset], lda, &evectl[
evectl_offset], ldu, &w1[1], &work[1], &rwork[1], &dumma[
2]);
result[10] = dumma[2];
if (dumma[3] > *thresh) {
io___56.ciunit = *nounit;
s_wsfe(&io___56);
do_fio(&c__1, "Left", (ftnlen)4);
do_fio(&c__1, "CTREVC", (ftnlen)6);
do_fio(&c__1, (char *)&dumma[3], (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
}
/* Compute selected left eigenvectors and confirm that */
/* they agree with previous left eigenvectors */
ctrevc_("Left", "Some", &select[1], &n, &t1[t1_offset], lda, &
evectr[evectr_offset], ldu, cdumma, ldu, &n, &in, &work[1]
, &rwork[1], &iinfo);
if (iinfo != 0) {
io___57.ciunit = *nounit;
s_wsfe(&io___57);
do_fio(&c__1, "CTREVC(L,S)", (ftnlen)11);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
goto L240;
}
k = 1;
match = TRUE_;
i__3 = n;
for (j = 1; j <= i__3; ++j) {
if (select[j]) {
i__4 = n;
for (jj = 1; jj <= i__4; ++jj) {
i__5 = jj + j * evectl_dim1;
i__6 = jj + k * evectr_dim1;
if (evectl[i__5].r != evectr[i__6].r || evectl[i__5]
.i != evectr[i__6].i) {
match = FALSE_;
goto L210;
}
/* L190: */
}
++k;
}
/* L200: */
}
L210:
if (! match) {
io___58.ciunit = *nounit;
s_wsfe(&io___58);
do_fio(&c__1, "Left", (ftnlen)4);
do_fio(&c__1, "CTREVC", (ftnlen)6);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
}
/* Call CHSEIN for Right eigenvectors of H, do test 11 */
ntest = 11;
result[11] = ulpinv;
i__3 = n;
for (j = 1; j <= i__3; ++j) {
select[j] = TRUE_;
/* L220: */
}
chsein_("Right", "Qr", "Ninitv", &select[1], &n, &h__[h_offset],
lda, &w3[1], cdumma, ldu, &evectx[evectx_offset], ldu, &
n1, &in, &work[1], &rwork[1], &iwork[1], &iwork[1], &
iinfo);
if (iinfo != 0) {
io___59.ciunit = *nounit;
s_wsfe(&io___59);
do_fio(&c__1, "CHSEIN(R)", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
if (iinfo < 0) {
goto L240;
}
} else {
/* Test 11: | HX - XW | / ( |H| |X| ulp ) */
/* (from inverse iteration) */
cget22_("N", "N", "N", &n, &h__[h_offset], lda, &evectx[
evectx_offset], ldu, &w3[1], &work[1], &rwork[1],
dumma);
if (dumma[0] < ulpinv) {
result[11] = dumma[0] * aninv;
}
if (dumma[1] > *thresh) {
io___60.ciunit = *nounit;
s_wsfe(&io___60);
do_fio(&c__1, "Right", (ftnlen)5);
do_fio(&c__1, "CHSEIN", (ftnlen)6);
do_fio(&c__1, (char *)&dumma[1], (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
;
e_wsfe();
}
}
/* Call CHSEIN for Left eigenvectors of H, do test 12 */
ntest = 12;
result[12] = ulpinv;
i__3 = n;
for (j = 1; j <= i__3; ++j) {
select[j] = TRUE_;
/* L230: */
}
chsein_("Left", "Qr", "Ninitv", &select[1], &n, &h__[h_offset],
lda, &w3[1], &evecty[evecty_offset], ldu, cdumma, ldu, &
n1, &in, &work[1], &rwork[1], &iwork[1], &iwork[1], &
iinfo);
if (iinfo != 0) {
io___61.ciunit = *nounit;
s_wsfe(&io___61);
do_fio(&c__1, "CHSEIN(L)", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
if (iinfo < 0) {
goto L240;
}
} else {
/* Test 12: | YH - WY | / ( |H| |Y| ulp ) */
/* (from inverse iteration) */
cget22_("C", "N", "C", &n, &h__[h_offset], lda, &evecty[
evecty_offset], ldu, &w3[1], &work[1], &rwork[1], &
dumma[2]);
if (dumma[2] < ulpinv) {
result[12] = dumma[2] * aninv;
}
if (dumma[3] > *thresh) {
io___62.ciunit = *nounit;
s_wsfe(&io___62);
do_fio(&c__1, "Left", (ftnlen)4);
do_fio(&c__1, "CHSEIN", (ftnlen)6);
do_fio(&c__1, (char *)&dumma[3], (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
;
e_wsfe();
}
}
/* Call CUNMHR for Right eigenvectors of A, do test 13 */
ntest = 13;
result[13] = ulpinv;
cunmhr_("Left", "No transpose", &n, &n, &ilo, &ihi, &uu[uu_offset]
, ldu, &tau[1], &evectx[evectx_offset], ldu, &work[1],
nwork, &iinfo);
if (iinfo != 0) {
io___63.ciunit = *nounit;
s_wsfe(&io___63);
do_fio(&c__1, "CUNMHR(L)", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
if (iinfo < 0) {
goto L240;
}
} else {
/* Test 13: | AX - XW | / ( |A| |X| ulp ) */
/* (from inverse iteration) */
cget22_("N", "N", "N", &n, &a[a_offset], lda, &evectx[
evectx_offset], ldu, &w3[1], &work[1], &rwork[1],
dumma);
if (dumma[0] < ulpinv) {
result[13] = dumma[0] * aninv;
}
}
/* Call CUNMHR for Left eigenvectors of A, do test 14 */
ntest = 14;
result[14] = ulpinv;
cunmhr_("Left", "No transpose", &n, &n, &ilo, &ihi, &uu[uu_offset]
, ldu, &tau[1], &evecty[evecty_offset], ldu, &work[1],
nwork, &iinfo);
if (iinfo != 0) {
io___64.ciunit = *nounit;
s_wsfe(&io___64);
do_fio(&c__1, "CUNMHR(L)", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
if (iinfo < 0) {
goto L240;
}
} else {
/* Test 14: | YA - WY | / ( |A| |Y| ulp ) */
/* (from inverse iteration) */
cget22_("C", "N", "C", &n, &a[a_offset], lda, &evecty[
evecty_offset], ldu, &w3[1], &work[1], &rwork[1], &
dumma[2]);
if (dumma[2] < ulpinv) {
result[14] = dumma[2] * aninv;
}
}
/* End of Loop -- Check for RESULT(j) > THRESH */
L240:
ntestt += ntest;
slafts_("CHS", &n, &n, &jtype, &ntest, &result[1], ioldsd, thresh,
nounit, &nerrs);
L250:
;
}
/* L260: */
}
/* Summary */
slasum_("CHS", nounit, &nerrs, &ntestt);
return 0;
/* End of CCHKHS */
} /* cchkhs_ */
/* Subroutine */ int ddrvrf2_(integer *nout, integer *nn, integer *nval,
doublereal *a, integer *lda, doublereal *arf, doublereal *ap,
doublereal *asav)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
static char uplos[1*2] = "U" "L";
static char forms[1*2] = "N" "T";
/* Format strings */
static char fmt_9999[] = "(1x,\002 *** Error(s) while testing the RFP co"
"nvertion\002,\002 routines ***\002)";
static char fmt_9998[] = "(1x,\002 Error in RFP,convertion routines "
"N=\002,i5,\002 UPLO='\002,a1,\002', FORM ='\002,a1,\002'\002)";
static char fmt_9997[] = "(1x,\002All tests for the RFP convertion routi"
"nes passed (\002,i5,\002 tests run)\002)";
static char fmt_9996[] = "(1x,\002RFP convertion routines:\002,i5,\002 o"
"ut of \002,i5,\002 error message recorded\002)";
/* System generated locals */
integer a_dim1, a_offset, asav_dim1, asav_offset, i__1, i__2, i__3;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsle(cilist *), e_wsle(void), s_wsfe(cilist *), e_wsfe(void),
do_fio(integer *, char *, ftnlen);
/* Local variables */
integer i__, j, n;
logical ok1, ok2;
integer iin, info;
char uplo[1];
integer nrun, iseed[4];
char cform[1];
integer iform;
logical lower;
integer iuplo, nerrs;
extern doublereal dlarnd_(integer *, integer *);
extern /* Subroutine */ int dtfttp_(char *, char *, integer *, doublereal
*, doublereal *, integer *), dtpttf_(char *, char
*, integer *, doublereal *, doublereal *, integer *), dtfttr_(char *, char *, integer *, doublereal *,
doublereal *, integer *, integer *), dtrttf_(char
*, char *, integer *, doublereal *, integer *, doublereal *,
integer *), dtrttp_(char *, integer *, doublereal
*, integer *, doublereal *, integer *), dtpttr_(char *,
integer *, doublereal *, doublereal *, integer *, integer *);
/* Fortran I/O blocks */
static cilist io___19 = { 0, 0, 0, 0, 0 };
static cilist io___20 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___21 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___22 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___23 = { 0, 0, 0, fmt_9996, 0 };
/* -- LAPACK test routine (version 3.2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2008 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DDRVRF2 tests the LAPACK RFP convertion routines. */
/* Arguments */
/* ========= */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* NN (input) INTEGER */
/* The number of values of N contained in the vector NVAL. */
/* NVAL (input) INTEGER array, dimension (NN) */
/* The values of the matrix dimension N. */
/* A (workspace) DOUBLE PRECISION array, dimension (LDA,NMAX) */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,NMAX). */
/* ARF (workspace) DOUBLE PRECISION array, dimension ((NMAX*(NMAX+1))/2). */
/* AP (workspace) DOUBLE PRECISION array, dimension ((NMAX*(NMAX+1))/2). */
/* A2 (workspace) DOUBLE PRECISION array, dimension (LDA,NMAX) */
/* ===================================================================== */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--nval;
asav_dim1 = *lda;
asav_offset = 1 + asav_dim1;
asav -= asav_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--arf;
--ap;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* Initialize constants and the random number seed. */
nrun = 0;
nerrs = 0;
info = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
}
i__1 = *nn;
for (iin = 1; iin <= i__1; ++iin) {
n = nval[iin];
/* Do first for UPLO = 'U', then for UPLO = 'L' */
for (iuplo = 1; iuplo <= 2; ++iuplo) {
*(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
lower = TRUE_;
if (iuplo == 1) {
lower = FALSE_;
}
/* Do first for CFORM = 'N', then for CFORM = 'T' */
for (iform = 1; iform <= 2; ++iform) {
*(unsigned char *)cform = *(unsigned char *)&forms[iform - 1];
++nrun;
i__2 = n;
for (j = 1; j <= i__2; ++j) {
i__3 = n;
for (i__ = 1; i__ <= i__3; ++i__) {
a[i__ + j * a_dim1] = dlarnd_(&c__2, iseed);
}
}
s_copy(srnamc_1.srnamt, "DTRTTF", (ftnlen)32, (ftnlen)6);
dtrttf_(cform, uplo, &n, &a[a_offset], lda, &arf[1], &info);
s_copy(srnamc_1.srnamt, "DTFTTP", (ftnlen)32, (ftnlen)6);
dtfttp_(cform, uplo, &n, &arf[1], &ap[1], &info);
s_copy(srnamc_1.srnamt, "DTPTTR", (ftnlen)32, (ftnlen)6);
dtpttr_(uplo, &n, &ap[1], &asav[asav_offset], lda, &info);
ok1 = TRUE_;
if (lower) {
i__2 = n;
for (j = 1; j <= i__2; ++j) {
i__3 = n;
for (i__ = j; i__ <= i__3; ++i__) {
if (a[i__ + j * a_dim1] != asav[i__ + j *
asav_dim1]) {
ok1 = FALSE_;
}
}
}
} else {
i__2 = n;
for (j = 1; j <= i__2; ++j) {
i__3 = j;
for (i__ = 1; i__ <= i__3; ++i__) {
if (a[i__ + j * a_dim1] != asav[i__ + j *
asav_dim1]) {
ok1 = FALSE_;
}
}
}
}
++nrun;
s_copy(srnamc_1.srnamt, "DTRTTP", (ftnlen)32, (ftnlen)6);
dtrttp_(uplo, &n, &a[a_offset], lda, &ap[1], &info)
;
s_copy(srnamc_1.srnamt, "DTPTTF", (ftnlen)32, (ftnlen)6);
dtpttf_(cform, uplo, &n, &ap[1], &arf[1], &info);
s_copy(srnamc_1.srnamt, "DTFTTR", (ftnlen)32, (ftnlen)6);
dtfttr_(cform, uplo, &n, &arf[1], &asav[asav_offset], lda, &
info);
ok2 = TRUE_;
if (lower) {
i__2 = n;
for (j = 1; j <= i__2; ++j) {
i__3 = n;
for (i__ = j; i__ <= i__3; ++i__) {
if (a[i__ + j * a_dim1] != asav[i__ + j *
asav_dim1]) {
ok2 = FALSE_;
}
}
}
} else {
i__2 = n;
for (j = 1; j <= i__2; ++j) {
i__3 = j;
for (i__ = 1; i__ <= i__3; ++i__) {
if (a[i__ + j * a_dim1] != asav[i__ + j *
asav_dim1]) {
ok2 = FALSE_;
}
}
}
}
if (! ok1 || ! ok2) {
if (nerrs == 0) {
io___19.ciunit = *nout;
s_wsle(&io___19);
e_wsle();
io___20.ciunit = *nout;
s_wsfe(&io___20);
e_wsfe();
}
io___21.ciunit = *nout;
s_wsfe(&io___21);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, cform, (ftnlen)1);
e_wsfe();
++nerrs;
}
/* L100: */
}
/* L110: */
}
/* L120: */
}
/* Print a summary of the results. */
if (nerrs == 0) {
io___22.ciunit = *nout;
s_wsfe(&io___22);
do_fio(&c__1, (char *)&nrun, (ftnlen)sizeof(integer));
e_wsfe();
} else {
io___23.ciunit = *nout;
s_wsfe(&io___23);
do_fio(&c__1, (char *)&nerrs, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&nrun, (ftnlen)sizeof(integer));
e_wsfe();
}
return 0;
/* End of DDRVRF2 */
} /* ddrvrf2_ */
/* Subroutine */ int sdrvpb_(logical *dotype, integer *nn, integer *nval,
integer *nrhs, real *thresh, logical *tsterr, integer *nmax, real *a,
real *afac, real *asav, real *b, real *bsav, real *x, real *xact,
real *s, real *work, real *rwork, integer *iwork, integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
static char facts[1*3] = "F" "N" "E";
static char equeds[1*2] = "N" "Y";
/* Format strings */
static char fmt_9999[] = "(1x,a,\002, UPLO='\002,a1,\002', N =\002,i5"
",\002, KD =\002,i5,\002, type \002,i1,\002, test(\002,i1,\002)"
"=\002,g12.5)";
static char fmt_9997[] = "(1x,a,\002( '\002,a1,\002', '\002,a1,\002',"
" \002,i5,\002, \002,i5,\002, ... ), EQUED='\002,a1,\002', type"
" \002,i1,\002, test(\002,i1,\002)=\002,g12.5)";
static char fmt_9998[] = "(1x,a,\002( '\002,a1,\002', '\002,a1,\002',"
" \002,i5,\002, \002,i5,\002, ... ), type \002,i1,\002, test(\002"
",i1,\002)=\002,g12.5)";
/* System generated locals */
address a__1[2];
integer i__1, i__2, i__3, i__4, i__5, i__6, i__7[2];
char ch__1[2];
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
/* Local variables */
integer i__, k, n, i1, i2, k1, kd, nb, in, kl, iw, ku, nt, lda, ikd, nkd,
ldab;
char fact[1];
integer ioff, mode, koff;
real amax;
char path[3];
integer imat, info;
char dist[1], uplo[1], type__[1];
integer nrun, ifact, nfail, iseed[4], nfact, kdval[4];
extern logical lsame_(char *, char *);
char equed[1];
integer nbmin;
real rcond, roldc, scond;
integer nimat;
extern doublereal sget06_(real *, real *);
extern /* Subroutine */ int sget04_(integer *, integer *, real *, integer
*, real *, integer *, real *, real *), spbt01_(char *, integer *,
integer *, real *, integer *, real *, integer *, real *, real *);
real anorm;
extern /* Subroutine */ int spbt02_(char *, integer *, integer *, integer
*, real *, integer *, real *, integer *, real *, integer *, real *
, real *), spbt05_(char *, integer *, integer *, integer *
, real *, integer *, real *, integer *, real *, integer *, real *,
integer *, real *, real *, real *);
logical equil;
integer iuplo, izero, nerrs;
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *), spbsv_(char *, integer *, integer *, integer *, real *
, integer *, real *, integer *, integer *), sswap_(
integer *, real *, integer *, real *, integer *);
logical zerot;
char xtype[1];
extern /* Subroutine */ int slatb4_(char *, integer *, integer *, integer
*, char *, integer *, integer *, real *, integer *, real *, char *
), aladhd_(integer *, char *),
alaerh_(char *, char *, integer *, integer *, char *, integer *,
integer *, integer *, integer *, integer *, integer *, integer *,
integer *, integer *);
logical prefac;
real rcondc;
extern doublereal slange_(char *, integer *, integer *, real *, integer *,
real *);
logical nofact;
char packit[1];
integer iequed;
extern doublereal slansb_(char *, char *, integer *, integer *, real *,
integer *, real *);
real cndnum;
extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
*, integer *), slaqsb_(char *, integer *, integer *, real
*, integer *, real *, real *, real *, char *);
real ainvnm;
extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
integer *, real *, integer *), slarhs_(char *, char *,
char *, char *, integer *, integer *, integer *, integer *,
integer *, real *, integer *, real *, integer *, real *, integer *
, integer *, integer *), slaset_(
char *, integer *, integer *, real *, real *, real *, integer *), spbequ_(char *, integer *, integer *, real *, integer *,
real *, real *, real *, integer *), spbtrf_(char *,
integer *, integer *, real *, integer *, integer *),
xlaenv_(integer *, integer *), slatms_(integer *, integer *, char
*, integer *, char *, real *, integer *, real *, real *, integer *
, integer *, char *, real *, integer *, real *, integer *), spbtrs_(char *, integer *, integer *, integer *,
real *, integer *, real *, integer *, integer *);
real result[6];
extern /* Subroutine */ int spbsvx_(char *, char *, integer *, integer *,
integer *, real *, integer *, real *, integer *, char *, real *,
real *, integer *, real *, integer *, real *, real *, real *,
real *, integer *, integer *), serrvx_(
char *, integer *);
/* Fortran I/O blocks */
static cilist io___57 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___60 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___61 = { 0, 0, 0, fmt_9998, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SDRVPB tests the driver routines SPBSV and -SVX. */
/* Arguments */
/* ========= */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* The matrix types to be used for testing. Matrices of type j */
/* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = */
/* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. */
/* NN (input) INTEGER */
/* The number of values of N contained in the vector NVAL. */
/* NVAL (input) INTEGER array, dimension (NN) */
/* The values of the matrix dimension N. */
/* NRHS (input) INTEGER */
/* The number of right hand side vectors to be generated for */
/* each linear system. */
/* THRESH (input) REAL */
/* The threshold value for the test ratios. A result is */
/* included in the output file if RESULT >= THRESH. To have */
/* every test ratio printed, use THRESH = 0. */
/* TSTERR (input) LOGICAL */
/* Flag that indicates whether error exits are to be tested. */
/* NMAX (input) INTEGER */
/* The maximum value permitted for N, used in dimensioning the */
/* work arrays. */
/* A (workspace) REAL array, dimension (NMAX*NMAX) */
/* AFAC (workspace) REAL array, dimension (NMAX*NMAX) */
/* ASAV (workspace) REAL array, dimension (NMAX*NMAX) */
/* B (workspace) REAL array, dimension (NMAX*NRHS) */
/* BSAV (workspace) REAL array, dimension (NMAX*NRHS) */
/* X (workspace) REAL array, dimension (NMAX*NRHS) */
/* XACT (workspace) REAL array, dimension (NMAX*NRHS) */
/* S (workspace) REAL array, dimension (NMAX) */
/* WORK (workspace) REAL array, dimension */
/* (NMAX*max(3,NRHS)) */
/* RWORK (workspace) REAL array, dimension (NMAX+2*NRHS) */
/* IWORK (workspace) INTEGER array, dimension (NMAX) */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--iwork;
--rwork;
--work;
--s;
--xact;
--x;
--bsav;
--b;
--asav;
--afac;
--a;
--nval;
--dotype;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* Initialize constants and the random number seed. */
s_copy(path, "Single precision", (ftnlen)1, (ftnlen)16);
s_copy(path + 1, "PB", (ftnlen)2, (ftnlen)2);
nrun = 0;
nfail = 0;
nerrs = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
}
/* Test the error exits */
if (*tsterr) {
serrvx_(path, nout);
}
infoc_1.infot = 0;
kdval[0] = 0;
/* Set the block size and minimum block size for testing. */
nb = 1;
nbmin = 2;
xlaenv_(&c__1, &nb);
xlaenv_(&c__2, &nbmin);
/* Do for each value of N in NVAL */
i__1 = *nn;
for (in = 1; in <= i__1; ++in) {
n = nval[in];
lda = max(n,1);
*(unsigned char *)xtype = 'N';
/* Set limits on the number of loop iterations. */
/* Computing MAX */
i__2 = 1, i__3 = min(n,4);
nkd = max(i__2,i__3);
nimat = 8;
if (n == 0) {
nimat = 1;
}
kdval[1] = n + (n + 1) / 4;
kdval[2] = (n * 3 - 1) / 4;
kdval[3] = (n + 1) / 4;
i__2 = nkd;
for (ikd = 1; ikd <= i__2; ++ikd) {
/* Do for KD = 0, (5*N+1)/4, (3N-1)/4, and (N+1)/4. This order */
/* makes it easier to skip redundant values for small values */
/* of N. */
kd = kdval[ikd - 1];
ldab = kd + 1;
/* Do first for UPLO = 'U', then for UPLO = 'L' */
for (iuplo = 1; iuplo <= 2; ++iuplo) {
koff = 1;
if (iuplo == 1) {
*(unsigned char *)uplo = 'U';
*(unsigned char *)packit = 'Q';
/* Computing MAX */
i__3 = 1, i__4 = kd + 2 - n;
koff = max(i__3,i__4);
} else {
*(unsigned char *)uplo = 'L';
*(unsigned char *)packit = 'B';
}
i__3 = nimat;
for (imat = 1; imat <= i__3; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (! dotype[imat]) {
goto L80;
}
/* Skip types 2, 3, or 4 if the matrix size is too small. */
zerot = imat >= 2 && imat <= 4;
if (zerot && n < imat - 1) {
goto L80;
}
if (! zerot || ! dotype[1]) {
/* Set up parameters with SLATB4 and generate a test */
/* matrix with SLATMS. */
slatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm,
&mode, &cndnum, dist);
s_copy(srnamc_1.srnamt, "SLATMS", (ftnlen)32, (ftnlen)
6);
slatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode,
&cndnum, &anorm, &kd, &kd, packit, &a[koff],
&ldab, &work[1], &info);
/* Check error code from SLATMS. */
if (info != 0) {
alaerh_(path, "SLATMS", &info, &c__0, uplo, &n, &
n, &c_n1, &c_n1, &c_n1, &imat, &nfail, &
nerrs, nout);
goto L80;
}
} else if (izero > 0) {
/* Use the same matrix for types 3 and 4 as for type */
/* 2 by copying back the zeroed out column, */
iw = (lda << 1) + 1;
if (iuplo == 1) {
ioff = (izero - 1) * ldab + kd + 1;
i__4 = izero - i1;
scopy_(&i__4, &work[iw], &c__1, &a[ioff - izero +
i1], &c__1);
iw = iw + izero - i1;
i__4 = i2 - izero + 1;
/* Computing MAX */
i__6 = ldab - 1;
i__5 = max(i__6,1);
scopy_(&i__4, &work[iw], &c__1, &a[ioff], &i__5);
} else {
ioff = (i1 - 1) * ldab + 1;
i__4 = izero - i1;
/* Computing MAX */
i__6 = ldab - 1;
i__5 = max(i__6,1);
scopy_(&i__4, &work[iw], &c__1, &a[ioff + izero -
i1], &i__5);
ioff = (izero - 1) * ldab + 1;
iw = iw + izero - i1;
i__4 = i2 - izero + 1;
scopy_(&i__4, &work[iw], &c__1, &a[ioff], &c__1);
}
}
/* For types 2-4, zero one row and column of the matrix */
/* to test that INFO is returned correctly. */
izero = 0;
if (zerot) {
if (imat == 2) {
izero = 1;
} else if (imat == 3) {
izero = n;
} else {
izero = n / 2 + 1;
}
/* Save the zeroed out row and column in WORK(*,3) */
iw = lda << 1;
/* Computing MIN */
i__5 = (kd << 1) + 1;
i__4 = min(i__5,n);
for (i__ = 1; i__ <= i__4; ++i__) {
work[iw + i__] = 0.f;
/* L20: */
}
++iw;
/* Computing MAX */
i__4 = izero - kd;
i1 = max(i__4,1);
/* Computing MIN */
i__4 = izero + kd;
i2 = min(i__4,n);
if (iuplo == 1) {
ioff = (izero - 1) * ldab + kd + 1;
i__4 = izero - i1;
sswap_(&i__4, &a[ioff - izero + i1], &c__1, &work[
iw], &c__1);
iw = iw + izero - i1;
i__4 = i2 - izero + 1;
/* Computing MAX */
i__6 = ldab - 1;
i__5 = max(i__6,1);
sswap_(&i__4, &a[ioff], &i__5, &work[iw], &c__1);
} else {
ioff = (i1 - 1) * ldab + 1;
i__4 = izero - i1;
/* Computing MAX */
i__6 = ldab - 1;
i__5 = max(i__6,1);
sswap_(&i__4, &a[ioff + izero - i1], &i__5, &work[
iw], &c__1);
ioff = (izero - 1) * ldab + 1;
iw = iw + izero - i1;
i__4 = i2 - izero + 1;
sswap_(&i__4, &a[ioff], &c__1, &work[iw], &c__1);
}
}
/* Save a copy of the matrix A in ASAV. */
i__4 = kd + 1;
slacpy_("Full", &i__4, &n, &a[1], &ldab, &asav[1], &ldab);
for (iequed = 1; iequed <= 2; ++iequed) {
*(unsigned char *)equed = *(unsigned char *)&equeds[
iequed - 1];
if (iequed == 1) {
nfact = 3;
} else {
nfact = 1;
}
i__4 = nfact;
for (ifact = 1; ifact <= i__4; ++ifact) {
*(unsigned char *)fact = *(unsigned char *)&facts[
ifact - 1];
prefac = lsame_(fact, "F");
nofact = lsame_(fact, "N");
equil = lsame_(fact, "E");
if (zerot) {
if (prefac) {
goto L60;
}
rcondc = 0.f;
} else if (! lsame_(fact, "N")) {
/* Compute the condition number for comparison */
/* with the value returned by SPBSVX (FACT = */
/* 'N' reuses the condition number from the */
/* previous iteration with FACT = 'F'). */
i__5 = kd + 1;
slacpy_("Full", &i__5, &n, &asav[1], &ldab, &
afac[1], &ldab);
if (equil || iequed > 1) {
/* Compute row and column scale factors to */
/* equilibrate the matrix A. */
spbequ_(uplo, &n, &kd, &afac[1], &ldab, &
s[1], &scond, &amax, &info);
if (info == 0 && n > 0) {
if (iequed > 1) {
scond = 0.f;
}
/* Equilibrate the matrix. */
slaqsb_(uplo, &n, &kd, &afac[1], &
ldab, &s[1], &scond, &amax,
equed);
}
}
/* Save the condition number of the */
/* non-equilibrated system for use in SGET04. */
if (equil) {
roldc = rcondc;
}
/* Compute the 1-norm of A. */
anorm = slansb_("1", uplo, &n, &kd, &afac[1],
&ldab, &rwork[1]);
/* Factor the matrix A. */
spbtrf_(uplo, &n, &kd, &afac[1], &ldab, &info);
/* Form the inverse of A. */
slaset_("Full", &n, &n, &c_b45, &c_b46, &a[1],
&lda);
s_copy(srnamc_1.srnamt, "SPBTRS", (ftnlen)32,
(ftnlen)6);
spbtrs_(uplo, &n, &kd, &n, &afac[1], &ldab, &
a[1], &lda, &info);
/* Compute the 1-norm condition number of A. */
ainvnm = slange_("1", &n, &n, &a[1], &lda, &
rwork[1]);
if (anorm <= 0.f || ainvnm <= 0.f) {
rcondc = 1.f;
} else {
rcondc = 1.f / anorm / ainvnm;
}
}
/* Restore the matrix A. */
i__5 = kd + 1;
slacpy_("Full", &i__5, &n, &asav[1], &ldab, &a[1],
&ldab);
/* Form an exact solution and set the right hand */
/* side. */
s_copy(srnamc_1.srnamt, "SLARHS", (ftnlen)32, (
ftnlen)6);
slarhs_(path, xtype, uplo, " ", &n, &n, &kd, &kd,
nrhs, &a[1], &ldab, &xact[1], &lda, &b[1],
&lda, iseed, &info);
*(unsigned char *)xtype = 'C';
slacpy_("Full", &n, nrhs, &b[1], &lda, &bsav[1], &
lda);
if (nofact) {
/* --- Test SPBSV --- */
/* Compute the L*L' or U'*U factorization of the */
/* matrix and solve the system. */
i__5 = kd + 1;
slacpy_("Full", &i__5, &n, &a[1], &ldab, &
afac[1], &ldab);
slacpy_("Full", &n, nrhs, &b[1], &lda, &x[1],
&lda);
s_copy(srnamc_1.srnamt, "SPBSV ", (ftnlen)32,
(ftnlen)6);
spbsv_(uplo, &n, &kd, nrhs, &afac[1], &ldab, &
x[1], &lda, &info);
/* Check error code from SPBSV . */
if (info != izero) {
alaerh_(path, "SPBSV ", &info, &izero,
uplo, &n, &n, &kd, &kd, nrhs, &
imat, &nfail, &nerrs, nout);
goto L40;
} else if (info != 0) {
goto L40;
}
/* Reconstruct matrix from factors and compute */
/* residual. */
spbt01_(uplo, &n, &kd, &a[1], &ldab, &afac[1],
&ldab, &rwork[1], result);
/* Compute residual of the computed solution. */
slacpy_("Full", &n, nrhs, &b[1], &lda, &work[
1], &lda);
spbt02_(uplo, &n, &kd, nrhs, &a[1], &ldab, &x[
1], &lda, &work[1], &lda, &rwork[1], &
result[1]);
/* Check solution from generated exact solution. */
sget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
&rcondc, &result[2]);
nt = 3;
/* Print information about the tests that did */
/* not pass the threshold. */
i__5 = nt;
for (k = 1; k <= i__5; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
io___57.ciunit = *nout;
s_wsfe(&io___57);
do_fio(&c__1, "SPBSV ", (ftnlen)6);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&kd, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&result[k - 1],
(ftnlen)sizeof(real));
e_wsfe();
++nfail;
}
/* L30: */
}
nrun += nt;
L40:
;
}
/* --- Test SPBSVX --- */
if (! prefac) {
i__5 = kd + 1;
slaset_("Full", &i__5, &n, &c_b45, &c_b45, &
afac[1], &ldab);
}
slaset_("Full", &n, nrhs, &c_b45, &c_b45, &x[1], &
lda);
if (iequed > 1 && n > 0) {
/* Equilibrate the matrix if FACT='F' and */
/* EQUED='Y' */
slaqsb_(uplo, &n, &kd, &a[1], &ldab, &s[1], &
scond, &amax, equed);
}
/* Solve the system and compute the condition */
/* number and error bounds using SPBSVX. */
s_copy(srnamc_1.srnamt, "SPBSVX", (ftnlen)32, (
ftnlen)6);
spbsvx_(fact, uplo, &n, &kd, nrhs, &a[1], &ldab, &
afac[1], &ldab, equed, &s[1], &b[1], &lda,
&x[1], &lda, &rcond, &rwork[1], &rwork[*
nrhs + 1], &work[1], &iwork[1], &info);
/* Check the error code from SPBSVX. */
if (info != izero) {
/* Writing concatenation */
i__7[0] = 1, a__1[0] = fact;
i__7[1] = 1, a__1[1] = uplo;
s_cat(ch__1, a__1, i__7, &c__2, (ftnlen)2);
alaerh_(path, "SPBSVX", &info, &izero, ch__1,
&n, &n, &kd, &kd, nrhs, &imat, &nfail,
&nerrs, nout);
goto L60;
}
if (info == 0) {
if (! prefac) {
/* Reconstruct matrix from factors and */
/* compute residual. */
spbt01_(uplo, &n, &kd, &a[1], &ldab, &
afac[1], &ldab, &rwork[(*nrhs <<
1) + 1], result);
k1 = 1;
} else {
k1 = 2;
}
/* Compute residual of the computed solution. */
slacpy_("Full", &n, nrhs, &bsav[1], &lda, &
work[1], &lda);
spbt02_(uplo, &n, &kd, nrhs, &asav[1], &ldab,
&x[1], &lda, &work[1], &lda, &rwork[(*
nrhs << 1) + 1], &result[1]);
/* Check solution from generated exact solution. */
if (nofact || prefac && lsame_(equed, "N")) {
sget04_(&n, nrhs, &x[1], &lda, &xact[1], &
lda, &rcondc, &result[2]);
} else {
sget04_(&n, nrhs, &x[1], &lda, &xact[1], &
lda, &roldc, &result[2]);
}
/* Check the error bounds from iterative */
/* refinement. */
spbt05_(uplo, &n, &kd, nrhs, &asav[1], &ldab,
&b[1], &lda, &x[1], &lda, &xact[1], &
lda, &rwork[1], &rwork[*nrhs + 1], &
result[3]);
} else {
k1 = 6;
}
/* Compare RCOND from SPBSVX with the computed */
/* value in RCONDC. */
result[5] = sget06_(&rcond, &rcondc);
/* Print information about the tests that did not */
/* pass the threshold. */
for (k = k1; k <= 6; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
if (prefac) {
io___60.ciunit = *nout;
s_wsfe(&io___60);
do_fio(&c__1, "SPBSVX", (ftnlen)6);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&kd, (ftnlen)
sizeof(integer));
do_fio(&c__1, equed, (ftnlen)1);
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&result[k - 1],
(ftnlen)sizeof(real));
e_wsfe();
} else {
io___61.ciunit = *nout;
s_wsfe(&io___61);
do_fio(&c__1, "SPBSVX", (ftnlen)6);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&kd, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&result[k - 1],
(ftnlen)sizeof(real));
e_wsfe();
}
++nfail;
}
/* L50: */
}
nrun = nrun + 7 - k1;
L60:
;
}
/* L70: */
}
L80:
;
}
/* L90: */
}
/* L100: */
}
/* L110: */
}
/* Print a summary of the results. */
alasvm_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of SDRVPB */
} /* sdrvpb_ */
/* $Procedure WRENCD ( Write encoded d.p. numbers to text file ) */
/* Subroutine */ int wrencd_(integer *unit, integer *n, doublereal *data)
{
/* System generated locals */
address a__1[3];
integer i__1, i__2, i__3, i__4[3];
char ch__1[66];
cilist ci__1;
/* Builtin functions */
integer s_rnge(char *, integer, char *, integer), s_wsfe(cilist *);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
integer do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
char work[64*64];
extern /* Subroutine */ int dp2hx_(doublereal *, char *, integer *,
ftnlen);
integer i__;
extern /* Subroutine */ int chkin_(char *, ftnlen);
integer nitms, itmbeg, length[64];
extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *,
ftnlen), setmsg_(char *, ftnlen);
integer iostat;
extern /* Subroutine */ int errint_(char *, integer *, ftnlen);
extern logical return_(void);
/* $ Abstract */
/* Encode and write d.p. numbers to a text file. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* None. */
/* $ Keywords */
/* CONVERSION */
/* NUMBERS */
/* UTILITY */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* UNIT I Fortran unit number of output text file. */
/* N I Number of d.p. numbers to encode and write. */
/* DATA I List of d.p. numbers to encode and write. */
/* $ Detailed_Input */
/* UNIT The Fortran unit number for a previously opened text */
/* file. All writing will begin at the CURRENT POSITION */
/* in the text file. */
/* N The number of double precision numbers to be encoded */
/* and written to the text file attached to UNIT. */
/* DATA List of double precision numbers to be encoded and */
/* written to the text file attached to UNIT. */
/* $ Detailed_Output */
/* See the Particulars section for a description of the effect of */
/* this routine. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If N, the number of data items, is not positive, the error */
/* SPICE(INVALIDARGUMENT) will be signalled. */
/* 2) If an error occurs while writing to the text file attached */
/* to UNIT, the error SPICE(FILEWRITEFAILED) will be signalled. */
/* 3) If the Fortran logical unit UNIT is not defined, the results */
/* of this routine are unpredictable. */
/* $ Files */
/* See the description of UNIT in the Detailed_Input section. */
/* $ Particulars */
/* This routine will accept a list of one or more double precision */
/* numbers which it will encode into equivalent text strings and */
/* write to the current position in a text file. The current */
/* position in a file is defined to be the text line immediately */
/* following the last text line that was written or read. The */
/* encoded d.p. numbers are written to the output text file as */
/* quoted character strings so that a Fortran list directed read may */
/* be used to read the encoded values, rather than a formatted read */
/* with the format specifier FMT = '(A)'. */
/* This routine is one of a pair of routines which are used to */
/* encode and decode d.p. numbers: */
/* WRENCD -- Encode and write d.p. numbers to a file. */
/* RDENCD -- Read and decode d.p. numbers from a file. */
/* The encoding/decoding of d.p.numbers is performed to provide a */
/* portable means for transferring data values. */
/* Currently the text string produced will be in a base 16 */
/* ``scientific notation.'' This format retains the full precision */
/* available for d.p. numbers on any given computer architecture. */
/* See DP2HX.FOR and HX2DP.FOR for details. */
/* $ Examples */
/* Please note that the output format in the examples is not */
/* intended to be exactly identical with the output format of this */
/* routine in actual use. The output format used in the examples is */
/* intended to aid in the understanding of how this routine works. */
/* It is NOT intended to be a specification of the output format for */
/* this routine. */
/* Let */
/* UNIT be the Fortran logical unit of a previously opened */
/* text file. */
/* N = 100 */
/* DATA(I) = DBLE(I), I = 1,N */
/* Then, the subroutine call */
/* CALL WRENCD( UNIT, N, DATA ) */
/* will write the first 100 integers as encoded d.p. numbers to the */
/* output text file attached to UNIT, beginning at the current */
/* position in the output file, which is marked by an arrow, '-->'. */
/* The resulting output will look something like the following: */
/* -->'1^1' '2^1' '3^1' '4^1' '5^1' '6^1' '7^1' '8^1' '9^1' */
/* 'A^1' 'B^1' 'C^1' 'D^1' 'E^1' 'F^1' '1^2' '11^2' '12^2' */
/* '13^2' '14^2' '15^2' '16^2' '17^2' '18^2' '19^2' '1A^2' */
/* '1B^2' '1C^2' '1D^2' '1E^2' '1F^2' '2^2' '21^2' '22^2' */
/* '23^2' '24^2' '25^2' '26^2' '27^2' '28^2' '29^2' '2A^2' */
/* '2B^2' '2C^2' '2D^2' '2E^2' '2F^2' '3^2' '31^2' '32^2' */
/* '33^2' '34^2' '35^2' '36^2' '37^2' '38^2' '39^2' '3A^2' */
/* '3B^2' '3C^2' '3D^2' '3E^2' '3F^2' '4^2' */
/* '41^2' '42^2' '43^2' '44^2' '45^2' '46^2' '47^2' '48^2' */
/* '49^2' '4A^2' '4B^2' '4C^2' '4D^2' '4E^2' '4F^2' '5^2' */
/* '51^2' '52^2' '53^2' '54^2' '55^2' '56^2' '57^2' '58^2' */
/* '59^2' '5A^2' '5B^2' '5C^2' '5D^2' '5E^2' '5F^2' '6^2' */
/* '61^2' '62^2' '63^2' '64^2' */
/* --> */
/* At this point, the arrow marks the position of the file pointer */
/* immediately after the call to WRENCD. */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* K.R. Gehringer (JPL) */
/* $ Version */
/* - SPICELIB Version 1.2.0, 09-SEP-1993 (KRG) */
/* The list directed write was changed to a formatted write using */
/* the specifier FMT='(A)'. This was done in order to prevent a */
/* space from appearing as the first character on each line of the */
/* file for certian computer platforms. */
/* - SPICELIB Version 1.1.0, 21-JUN-1993 (KRG) */
/* This routine was modified to avoid the creation of long output */
/* lines on some of the supported systems, such as the NeXT with */
/* Absoft Fortran 3.2. */
/* A disclaimer was added to the $ Examples section concerning */
/* the output format used. The disclaimer simply states that the */
/* output format used in the example is not necessarily the */
/* output format actually used by the routine. */
/* - SPICELIB Version 1.0.0, 20-OCT-1992 (KRG) */
/* -& */
/* $ Index_Entries */
/* encode and write d.p. numbers to a text file */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 1.2.0, 09-SEP-1993 (KRG) */
/* The list directed write was changed to a formatted write using */
/* the specifier FMT='(A)'. This was done in order to prevent a */
/* space from appearing as the first character on each line of the */
/* file for certian computer platforms. */
/* - SPICELIB Version 1.1.0, 21-JUN-1993 (KRG) */
/* This routine was modified to avoid the creation of long output */
/* lines on some of the supported systems, such as the NeXT with */
/* Absoft Fortran 3.2. */
/* On some of the supported computers this routine would produce */
/* very long (greater than 1000 characters) output lines due to */
/* the implicit DO loop used in the WRITE statment: */
/* WRITE (UNIT,IOSTAT=IOSTAT,FMT=*) */
/* . ( QUOTE//WORK(I)(1:LENGTH(I))//QUOTE//' ', I=1,NITMS ) */
/* This problem was fixed by removing the implicit DO loop from */
/* the WRITE statement and placing an equivalent DO loop around */
/* the WRITE statemtent: */
/* DO I = 1, NITMS */
/* WRITE (UNIT,IOSTAT=IOSTAT,FMT=*) */
/* . QUOTE//WORK(I)(1:LENGTH(I))//QUOTE */
/* END DO */
/* The net effect of this will be that only a single datum will */
/* be written on each line of output. */
/* A disclaimer was added to the $ Examples section concerning */
/* the output format used. The disclaimer simply states that the */
/* output format used in the example is not necessarily the */
/* output format actually used by the routine. */
/* - SPICELIB Version 1.0.0, 20-OCT-1992 (KRG) */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* Local variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("WRENCD", (ftnlen)6);
}
/* Check to see if the number of data items is less than or equal */
/* to zero. If it is, signal an error. */
if (*n < 1) {
setmsg_("The number of data items to be written was not positive: #.",
(ftnlen)59);
errint_("#", n, (ftnlen)1);
sigerr_("SPICE(INVALIDARGUMENT)", (ftnlen)22);
chkout_("WRENCD", (ftnlen)6);
return 0;
}
/* Initialize the beginning location for the data items to be */
/* encoded. */
itmbeg = 1;
/* Begin encoding the input data items in blocks of size NITMS. */
/* Each time the number of data items NITMS is reached, write */
/* out the encoded items in the workspace. */
while(itmbeg <= *n) {
/* The number of items is either the size of the workspace, or */
/* the number of data items which remain to be processed, which */
/* should always be less than or equal to the size of the */
/* workspace. */
/* Computing MIN */
i__1 = 64, i__2 = *n - itmbeg + 1;
nitms = min(i__1,i__2);
/* Encode each of the numbers into an equivalent character string. */
i__1 = nitms;
for (i__ = 1; i__ <= i__1; ++i__) {
dp2hx_(&data[itmbeg + i__ - 2], work + (((i__2 = i__ - 1) < 64 &&
0 <= i__2 ? i__2 : s_rnge("work", i__2, "wrencd_", (
ftnlen)324)) << 6), &length[(i__3 = i__ - 1) < 64 && 0 <=
i__3 ? i__3 : s_rnge("length", i__3, "wrencd_", (ftnlen)
324)], (ftnlen)64);
}
/* Write out the current workspace, placing single quotes around */
/* each of the character strings so that they may be read using */
/* Fortran list directed read statements rather than the format */
/* specifier FMT = '(A)'. */
i__1 = nitms;
for (i__ = 1; i__ <= i__1; ++i__) {
ci__1.cierr = 1;
ci__1.ciunit = *unit;
ci__1.cifmt = "(A)";
iostat = s_wsfe(&ci__1);
if (iostat != 0) {
goto L100001;
}
/* Writing concatenation */
i__4[0] = 1, a__1[0] = "'";
i__4[1] = length[(i__3 = i__ - 1) < 64 && 0 <= i__3 ? i__3 :
s_rnge("length", i__3, "wrencd_", (ftnlen)335)], a__1[1] =
work + (((i__2 = i__ - 1) < 64 && 0 <= i__2 ? i__2 :
s_rnge("work", i__2, "wrencd_", (ftnlen)335)) << 6);
i__4[2] = 1, a__1[2] = "'";
s_cat(ch__1, a__1, i__4, &c__3, (ftnlen)66);
iostat = do_fio(&c__1, ch__1, length[(i__3 = i__ - 1) < 64 && 0 <=
i__3 ? i__3 : s_rnge("length", i__3, "wrencd_", (ftnlen)
335)] + 2);
if (iostat != 0) {
goto L100001;
}
iostat = e_wsfe();
L100001:
/* Check to see if we got a write error, IOSTAT .NE. 0. */
if (iostat != 0) {
setmsg_("Error writing to logical unit #, IOSTAT = #.", (
ftnlen)44);
errint_("#", unit, (ftnlen)1);
errint_("#", &iostat, (ftnlen)1);
sigerr_("SPICE(FILEWRITEFAILED)", (ftnlen)22);
chkout_("WRENCD", (ftnlen)6);
return 0;
}
}
/* Position the data item pointer at the next location to begin */
/* encoding the items in the array DATA, and continue processing */
/* the data items until done. */
itmbeg += nitms;
}
chkout_("WRENCD", (ftnlen)6);
return 0;
} /* wrencd_ */
/* Subroutine */ int zchkgl_(integer *nin, integer *nout)
{
/* Format strings */
static char fmt_9999[] = "(\002 .. test output of ZGGBAL .. \002)";
static char fmt_9998[] = "(\002 ratio of largest test error "
" = \002,d12.3)";
static char fmt_9997[] = "(\002 example number where info is not zero "
" = \002,i4)";
static char fmt_9996[] = "(\002 example number where ILO or IHI is wrong"
" = \002,i4)";
static char fmt_9995[] = "(\002 example number having largest error "
" = \002,i4)";
static char fmt_9994[] = "(\002 number of examples where info is not 0 "
" = \002,i4)";
static char fmt_9993[] = "(\002 total number of examples tested "
" = \002,i4)";
/* System generated locals */
integer i__1, i__2, i__3, i__4;
doublereal d__1, d__2, d__3;
doublecomplex z__1;
/* Builtin functions */
integer s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_rsle(void);
double z_abs(doublecomplex *);
integer s_wsfe(cilist *), e_wsfe(void), do_fio(integer *, char *, ftnlen);
/* Local variables */
doublecomplex a[400] /* was [20][20] */, b[400] /* was [20][
20] */;
integer i__, j, n;
doublecomplex ain[400] /* was [20][20] */, bin[400] /* was [20][
20] */;
integer ihi, ilo;
doublereal eps;
integer knt, info, lmax[3];
doublereal rmax, vmax, work[120];
integer ihiin, ninfo, iloin;
doublereal anorm, bnorm;
extern doublereal dlamch_(char *);
doublereal lscale[20];
extern /* Subroutine */ int zggbal_(char *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *, integer *, integer *,
doublereal *, doublereal *, doublereal *, integer *);
doublereal rscale[20];
extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
integer *, doublereal *);
doublereal lsclin[20], rsclin[20];
/* Fortran I/O blocks */
static cilist io___6 = { 0, 0, 0, 0, 0 };
static cilist io___9 = { 0, 0, 0, 0, 0 };
static cilist io___12 = { 0, 0, 0, 0, 0 };
static cilist io___14 = { 0, 0, 0, 0, 0 };
static cilist io___17 = { 0, 0, 0, 0, 0 };
static cilist io___19 = { 0, 0, 0, 0, 0 };
static cilist io___21 = { 0, 0, 0, 0, 0 };
static cilist io___23 = { 0, 0, 0, 0, 0 };
static cilist io___34 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___35 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___36 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___37 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___38 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___39 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___40 = { 0, 0, 0, fmt_9993, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZCHKGL tests ZGGBAL, a routine for balancing a matrix pair (A, B). */
/* Arguments */
/* ========= */
/* NIN (input) INTEGER */
/* The logical unit number for input. NIN > 0. */
/* NOUT (input) INTEGER */
/* The logical unit number for output. NOUT > 0. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
lmax[0] = 0;
lmax[1] = 0;
lmax[2] = 0;
ninfo = 0;
knt = 0;
rmax = 0.;
eps = dlamch_("Precision");
L10:
io___6.ciunit = *nin;
s_rsle(&io___6);
do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
e_rsle();
if (n == 0) {
goto L90;
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___9.ciunit = *nin;
s_rsle(&io___9);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__7, &c__1, (char *)&a[i__ + j * 20 - 21], (ftnlen)
sizeof(doublecomplex));
}
e_rsle();
/* L20: */
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___12.ciunit = *nin;
s_rsle(&io___12);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__7, &c__1, (char *)&b[i__ + j * 20 - 21], (ftnlen)
sizeof(doublecomplex));
}
e_rsle();
/* L30: */
}
io___14.ciunit = *nin;
s_rsle(&io___14);
do_lio(&c__3, &c__1, (char *)&iloin, (ftnlen)sizeof(integer));
do_lio(&c__3, &c__1, (char *)&ihiin, (ftnlen)sizeof(integer));
e_rsle();
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___17.ciunit = *nin;
s_rsle(&io___17);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__7, &c__1, (char *)&ain[i__ + j * 20 - 21], (ftnlen)
sizeof(doublecomplex));
}
e_rsle();
/* L40: */
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___19.ciunit = *nin;
s_rsle(&io___19);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__7, &c__1, (char *)&bin[i__ + j * 20 - 21], (ftnlen)
sizeof(doublecomplex));
}
e_rsle();
/* L50: */
}
io___21.ciunit = *nin;
s_rsle(&io___21);
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
do_lio(&c__5, &c__1, (char *)&lsclin[i__ - 1], (ftnlen)sizeof(
doublereal));
}
e_rsle();
io___23.ciunit = *nin;
s_rsle(&io___23);
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
do_lio(&c__5, &c__1, (char *)&rsclin[i__ - 1], (ftnlen)sizeof(
doublereal));
}
e_rsle();
anorm = zlange_("M", &n, &n, a, &c__20, work);
bnorm = zlange_("M", &n, &n, b, &c__20, work);
++knt;
zggbal_("B", &n, a, &c__20, b, &c__20, &ilo, &ihi, lscale, rscale, work, &
info);
if (info != 0) {
++ninfo;
lmax[0] = knt;
}
if (ilo != iloin || ihi != ihiin) {
++ninfo;
lmax[1] = knt;
}
vmax = 0.;
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = n;
for (j = 1; j <= i__2; ++j) {
/* Computing MAX */
i__3 = i__ + j * 20 - 21;
i__4 = i__ + j * 20 - 21;
z__1.r = a[i__3].r - ain[i__4].r, z__1.i = a[i__3].i - ain[i__4]
.i;
d__1 = vmax, d__2 = z_abs(&z__1);
vmax = max(d__1,d__2);
/* Computing MAX */
i__3 = i__ + j * 20 - 21;
i__4 = i__ + j * 20 - 21;
z__1.r = b[i__3].r - bin[i__4].r, z__1.i = b[i__3].i - bin[i__4]
.i;
d__1 = vmax, d__2 = z_abs(&z__1);
vmax = max(d__1,d__2);
/* L60: */
}
/* L70: */
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
d__2 = vmax, d__3 = (d__1 = lscale[i__ - 1] - lsclin[i__ - 1], abs(
d__1));
vmax = max(d__2,d__3);
/* Computing MAX */
d__2 = vmax, d__3 = (d__1 = rscale[i__ - 1] - rsclin[i__ - 1], abs(
d__1));
vmax = max(d__2,d__3);
/* L80: */
}
vmax /= eps * max(anorm,bnorm);
if (vmax > rmax) {
lmax[2] = knt;
rmax = vmax;
}
goto L10;
L90:
io___34.ciunit = *nout;
s_wsfe(&io___34);
e_wsfe();
io___35.ciunit = *nout;
s_wsfe(&io___35);
do_fio(&c__1, (char *)&rmax, (ftnlen)sizeof(doublereal));
e_wsfe();
io___36.ciunit = *nout;
s_wsfe(&io___36);
do_fio(&c__1, (char *)&lmax[0], (ftnlen)sizeof(integer));
e_wsfe();
io___37.ciunit = *nout;
s_wsfe(&io___37);
do_fio(&c__1, (char *)&lmax[1], (ftnlen)sizeof(integer));
e_wsfe();
io___38.ciunit = *nout;
s_wsfe(&io___38);
do_fio(&c__1, (char *)&lmax[2], (ftnlen)sizeof(integer));
e_wsfe();
io___39.ciunit = *nout;
s_wsfe(&io___39);
do_fio(&c__1, (char *)&ninfo, (ftnlen)sizeof(integer));
e_wsfe();
io___40.ciunit = *nout;
s_wsfe(&io___40);
do_fio(&c__1, (char *)&knt, (ftnlen)sizeof(integer));
e_wsfe();
return 0;
/* End of ZCHKGL */
} /* zchkgl_ */
/* Subroutine */ int zdrvev_(integer *nsizes, integer *nn, integer *ntypes,
logical *dotype, integer *iseed, doublereal *thresh, integer *nounit,
doublecomplex *a, integer *lda, doublecomplex *h__, doublecomplex *w,
doublecomplex *w1, doublecomplex *vl, integer *ldvl, doublecomplex *
vr, integer *ldvr, doublecomplex *lre, integer *ldlre, doublereal *
result, doublecomplex *work, integer *nwork, doublereal *rwork,
integer *iwork, integer *info)
{
/* Initialized data */
static integer ktype[21] = { 1,2,3,4,4,4,4,4,6,6,6,6,6,6,6,6,6,6,9,9,9 };
static integer kmagn[21] = { 1,1,1,1,1,1,2,3,1,1,1,1,1,1,1,1,2,3,1,2,3 };
static integer kmode[21] = { 0,0,0,4,3,1,4,4,4,3,1,5,4,3,1,5,5,5,4,3,1 };
static integer kconds[21] = { 0,0,0,0,0,0,0,0,1,1,1,1,2,2,2,2,2,2,0,0,0 };
/* Format strings */
static char fmt_9993[] = "(\002 ZDRVEV: \002,a,\002 returned INFO=\002,i"
"6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
"(\002,3(i5,\002,\002),i5,\002)\002)";
static char fmt_9999[] = "(/1x,a3,\002 -- Complex Eigenvalue-Eigenvect"
"or \002,\002Decomposition Driver\002,/\002 Matrix types (see ZDR"
"VEV for details): \002)";
static char fmt_9998[] = "(/\002 Special Matrices:\002,/\002 1=Zero mat"
"rix. \002,\002 \002,\002 5=Diagonal: geom"
"etr. spaced entries.\002,/\002 2=Identity matrix. "
" \002,\002 6=Diagona\002,\002l: clustered entries.\002,"
"/\002 3=Transposed Jordan block. \002,\002 \002,\002 "
" 7=Diagonal: large, evenly spaced.\002,/\002 \002,\0024=Diagona"
"l: evenly spaced entries. \002,\002 8=Diagonal: s\002,\002ma"
"ll, evenly spaced.\002)";
static char fmt_9997[] = "(\002 Dense, Non-Symmetric Matrices:\002,/\002"
" 9=Well-cond., ev\002,\002enly spaced eigenvals.\002,\002 14=Il"
"l-cond., geomet. spaced e\002,\002igenals.\002,/\002 10=Well-con"
"d., geom. spaced eigenvals. \002,\002 15=Ill-conditioned, cluste"
"red e.vals.\002,/\002 11=Well-cond\002,\002itioned, clustered e."
"vals. \002,\002 16=Ill-cond., random comp\002,\002lex \002,a6,"
"/\002 12=Well-cond., random complex \002,a6,\002 \002,\002 17="
"Ill-cond., large rand. complx \002,a4,/\002 13=Ill-condi\002,"
"\002tioned, evenly spaced. \002,\002 18=Ill-cond., small ran"
"d.\002,\002 complx \002,a4)";
static char fmt_9996[] = "(\002 19=Matrix with random O(1) entries. "
" \002,\002 21=Matrix \002,\002with small random entries.\002,"
"/\002 20=Matrix with large ran\002,\002dom entries. \002,/)";
static char fmt_9995[] = "(\002 Tests performed with test threshold ="
"\002,f8.2,//\002 1 = | A VR - VR W | / ( n |A| ulp ) \002,/\002 "
"2 = | conj-trans(A) VL - VL conj-trans(W) | /\002,\002 ( n |A| u"
"lp ) \002,/\002 3 = | |VR(i)| - 1 | / ulp \002,/\002 4 = | |VL(i"
")| - 1 | / ulp \002,/\002 5 = 0 if W same no matter if VR or VL "
"computed,\002,\002 1/ulp otherwise\002,/\002 6 = 0 if VR same no"
" matter if VL computed,\002,\002 1/ulp otherwise\002,/\002 7 = "
"0 if VL same no matter if VR computed,\002,\002 1/ulp otherwis"
"e\002,/)";
static char fmt_9994[] = "(\002 N=\002,i5,\002, IWK=\002,i2,\002, seed"
"=\002,4(i4,\002,\002),\002 type \002,i2,\002, test(\002,i2,\002)="
"\002,g10.3)";
/* System generated locals */
integer a_dim1, a_offset, h_dim1, h_offset, lre_dim1, lre_offset, vl_dim1,
vl_offset, vr_dim1, vr_offset, i__1, i__2, i__3, i__4, i__5,
i__6;
doublereal d__1, d__2, d__3, d__4, d__5;
doublecomplex z__1;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
double sqrt(doublereal);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
double z_abs(doublecomplex *), d_imag(doublecomplex *);
/* Local variables */
integer j, n, jj;
doublecomplex dum[1];
doublereal res[2];
integer iwk;
doublereal ulp, vmx, cond;
integer jcol;
char path[3];
integer nmax;
doublereal unfl, ovfl, tnrm, vrmx, vtst;
logical badnn;
integer nfail, imode, iinfo;
doublereal conds, anorm;
extern /* Subroutine */ int zget22_(char *, char *, char *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, doublecomplex *, doublereal *, doublereal *), zgeev_(char *, char *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *, integer *, doublecomplex *, integer *,
doublereal *, integer *);
integer jsize, nerrs, itype, jtype, ntest;
doublereal rtulp;
extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
extern doublereal dznrm2_(integer *, doublecomplex *, integer *), dlamch_(
char *);
integer idumma[1];
extern /* Subroutine */ int xerbla_(char *, integer *);
integer ioldsd[4];
extern /* Subroutine */ int dlasum_(char *, integer *, integer *, integer
*), zlatme_(integer *, char *, integer *, doublecomplex *,
integer *, doublereal *, doublecomplex *, char *, char *, char *,
char *, doublereal *, integer *, doublereal *, integer *,
integer *, doublereal *, doublecomplex *, integer *,
doublecomplex *, integer *), zlacpy_(char *, integer *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *);
integer ntestf;
extern /* Subroutine */ int zlaset_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *), zlatmr_(integer *, integer *, char *, integer *, char *,
doublecomplex *, integer *, doublereal *, doublecomplex *, char *,
char *, doublecomplex *, integer *, doublereal *, doublecomplex *
, integer *, doublereal *, char *, integer *, integer *, integer *
, doublereal *, doublereal *, char *, doublecomplex *, integer *,
integer *, integer *), zlatms_(integer *, integer *, char *, integer *, char *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
integer *, char *, doublecomplex *, integer *, doublecomplex *,
integer *);
doublereal ulpinv;
integer nnwork, mtypes, ntestt;
doublereal rtulpi;
/* Fortran I/O blocks */
static cilist io___31 = { 0, 0, 0, fmt_9993, 0 };
static cilist io___34 = { 0, 0, 0, fmt_9993, 0 };
static cilist io___42 = { 0, 0, 0, fmt_9993, 0 };
static cilist io___43 = { 0, 0, 0, fmt_9993, 0 };
static cilist io___44 = { 0, 0, 0, fmt_9993, 0 };
static cilist io___47 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___48 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___49 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___50 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___51 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___52 = { 0, 0, 0, fmt_9994, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZDRVEV checks the nonsymmetric eigenvalue problem driver ZGEEV. */
/* When ZDRVEV is called, a number of matrix "sizes" ("n's") and a */
/* number of matrix "types" are specified. For each size ("n") */
/* and each type of matrix, one matrix will be generated and used */
/* to test the nonsymmetric eigenroutines. For each matrix, 7 */
/* tests will be performed: */
/* (1) | A * VR - VR * W | / ( n |A| ulp ) */
/* Here VR is the matrix of unit right eigenvectors. */
/* W is a diagonal matrix with diagonal entries W(j). */
/* (2) | A**H * VL - VL * W**H | / ( n |A| ulp ) */
/* Here VL is the matrix of unit left eigenvectors, A**H is the */
/* conjugate-transpose of A, and W is as above. */
/* (3) | |VR(i)| - 1 | / ulp and whether largest component real */
/* VR(i) denotes the i-th column of VR. */
/* (4) | |VL(i)| - 1 | / ulp and whether largest component real */
/* VL(i) denotes the i-th column of VL. */
/* (5) W(full) = W(partial) */
/* W(full) denotes the eigenvalues computed when both VR and VL */
/* are also computed, and W(partial) denotes the eigenvalues */
/* computed when only W, only W and VR, or only W and VL are */
/* computed. */
/* (6) VR(full) = VR(partial) */
/* VR(full) denotes the right eigenvectors computed when both VR */
/* and VL are computed, and VR(partial) denotes the result */
/* when only VR is computed. */
/* (7) VL(full) = VL(partial) */
/* VL(full) denotes the left eigenvectors computed when both VR */
/* and VL are also computed, and VL(partial) denotes the result */
/* when only VL is computed. */
/* The "sizes" are specified by an array NN(1:NSIZES); the value of */
/* each element NN(j) specifies one size. */
/* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); */
/* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. */
/* Currently, the list of possible types is: */
/* (1) The zero matrix. */
/* (2) The identity matrix. */
/* (3) A (transposed) Jordan block, with 1's on the diagonal. */
/* (4) A diagonal matrix with evenly spaced entries */
/* 1, ..., ULP and random complex angles. */
/* (ULP = (first number larger than 1) - 1 ) */
/* (5) A diagonal matrix with geometrically spaced entries */
/* 1, ..., ULP and random complex angles. */
/* (6) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP */
/* and random complex angles. */
/* (7) Same as (4), but multiplied by a constant near */
/* the overflow threshold */
/* (8) Same as (4), but multiplied by a constant near */
/* the underflow threshold */
/* (9) A matrix of the form U' T U, where U is unitary and */
/* T has evenly spaced entries 1, ..., ULP with random complex */
/* angles on the diagonal and random O(1) entries in the upper */
/* triangle. */
/* (10) A matrix of the form U' T U, where U is unitary and */
/* T has geometrically spaced entries 1, ..., ULP with random */
/* complex angles on the diagonal and random O(1) entries in */
/* the upper triangle. */
/* (11) A matrix of the form U' T U, where U is unitary and */
/* T has "clustered" entries 1, ULP,..., ULP with random */
/* complex angles on the diagonal and random O(1) entries in */
/* the upper triangle. */
/* (12) A matrix of the form U' T U, where U is unitary and */
/* T has complex eigenvalues randomly chosen from */
/* ULP < |z| < 1 and random O(1) entries in the upper */
/* triangle. */
/* (13) A matrix of the form X' T X, where X has condition */
/* SQRT( ULP ) and T has evenly spaced entries 1, ..., ULP */
/* with random complex angles on the diagonal and random O(1) */
/* entries in the upper triangle. */
/* (14) A matrix of the form X' T X, where X has condition */
/* SQRT( ULP ) and T has geometrically spaced entries */
/* 1, ..., ULP with random complex angles on the diagonal */
/* and random O(1) entries in the upper triangle. */
/* (15) A matrix of the form X' T X, where X has condition */
/* SQRT( ULP ) and T has "clustered" entries 1, ULP,..., ULP */
/* with random complex angles on the diagonal and random O(1) */
/* entries in the upper triangle. */
/* (16) A matrix of the form X' T X, where X has condition */
/* SQRT( ULP ) and T has complex eigenvalues randomly chosen */
/* from ULP < |z| < 1 and random O(1) entries in the upper */
/* triangle. */
/* (17) Same as (16), but multiplied by a constant */
/* near the overflow threshold */
/* (18) Same as (16), but multiplied by a constant */
/* near the underflow threshold */
/* (19) Nonsymmetric matrix with random entries chosen from |z| < 1 */
/* If N is at least 4, all entries in first two rows and last */
/* row, and first column and last two columns are zero. */
/* (20) Same as (19), but multiplied by a constant */
/* near the overflow threshold */
/* (21) Same as (19), but multiplied by a constant */
/* near the underflow threshold */
/* Arguments */
/* ========== */
/* NSIZES (input) INTEGER */
/* The number of sizes of matrices to use. If it is zero, */
/* ZDRVEV does nothing. It must be at least zero. */
/* NN (input) INTEGER array, dimension (NSIZES) */
/* An array containing the sizes to be used for the matrices. */
/* Zero values will be skipped. The values must be at least */
/* zero. */
/* NTYPES (input) INTEGER */
/* The number of elements in DOTYPE. If it is zero, ZDRVEV */
/* does nothing. It must be at least zero. If it is MAXTYP+1 */
/* and NSIZES is 1, then an additional type, MAXTYP+1 is */
/* defined, which is to use whatever matrix is in A. This */
/* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and */
/* DOTYPE(MAXTYP+1) is .TRUE. . */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* If DOTYPE(j) is .TRUE., then for each size in NN a */
/* matrix of that size and of type j will be generated. */
/* If NTYPES is smaller than the maximum number of types */
/* defined (PARAMETER MAXTYP), then types NTYPES+1 through */
/* MAXTYP will not be generated. If NTYPES is larger */
/* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) */
/* will be ignored. */
/* ISEED (input/output) INTEGER array, dimension (4) */
/* On entry ISEED specifies the seed of the random number */
/* generator. The array elements should be between 0 and 4095; */
/* if not they will be reduced mod 4096. Also, ISEED(4) must */
/* 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 ZDRVEV to continue the same random number */
/* sequence. */
/* THRESH (input) DOUBLE PRECISION */
/* A test will count as "failed" if the "error", computed as */
/* described above, exceeds THRESH. Note that the error */
/* is scaled to be O(1), so THRESH should be a reasonably */
/* small multiple of 1, e.g., 10 or 100. In particular, */
/* it should not depend on the precision (single vs. double) */
/* or the size of the matrix. It must be at least zero. */
/* NOUNIT (input) INTEGER */
/* The FORTRAN unit number for printing out error messages */
/* (e.g., if a routine returns INFO not equal to 0.) */
/* A (workspace) COMPLEX*16 array, dimension (LDA, max(NN)) */
/* Used to hold the matrix whose eigenvalues are to be */
/* computed. On exit, A contains the last matrix actually used. */
/* LDA (input) INTEGER */
/* The leading dimension of A, and H. LDA must be at */
/* least 1 and at least max(NN). */
/* H (workspace) COMPLEX*16 array, dimension (LDA, max(NN)) */
/* Another copy of the test matrix A, modified by ZGEEV. */
/* W (workspace) COMPLEX*16 array, dimension (max(NN)) */
/* The eigenvalues of A. On exit, W are the eigenvalues of */
/* the matrix in A. */
/* W1 (workspace) COMPLEX*16 array, dimension (max(NN)) */
/* Like W, this array contains the eigenvalues of A, */
/* but those computed when ZGEEV only computes a partial */
/* eigendecomposition, i.e. not the eigenvalues and left */
/* and right eigenvectors. */
/* VL (workspace) COMPLEX*16 array, dimension (LDVL, max(NN)) */
/* VL holds the computed left eigenvectors. */
/* LDVL (input) INTEGER */
/* Leading dimension of VL. Must be at least max(1,max(NN)). */
/* VR (workspace) COMPLEX*16 array, dimension (LDVR, max(NN)) */
/* VR holds the computed right eigenvectors. */
/* LDVR (input) INTEGER */
/* Leading dimension of VR. Must be at least max(1,max(NN)). */
/* LRE (workspace) COMPLEX*16 array, dimension (LDLRE, max(NN)) */
/* LRE holds the computed right or left eigenvectors. */
/* LDLRE (input) INTEGER */
/* Leading dimension of LRE. Must be at least max(1,max(NN)). */
/* RESULT (output) DOUBLE PRECISION array, dimension (7) */
/* The values computed by the seven tests described above. */
/* The values are currently limited to 1/ulp, to avoid */
/* overflow. */
/* WORK (workspace) COMPLEX*16 array, dimension (NWORK) */
/* NWORK (input) INTEGER */
/* The number of entries in WORK. This must be at least */
/* 5*NN(j)+2*NN(j)**2 for all j. */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (2*max(NN)) */
/* IWORK (workspace) INTEGER array, dimension (max(NN)) */
/* INFO (output) INTEGER */
/* If 0, then everything ran OK. */
/* -1: NSIZES < 0 */
/* -2: Some NN(j) < 0 */
/* -3: NTYPES < 0 */
/* -6: THRESH < 0 */
/* -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ). */
/* -14: LDVL < 1 or LDVL < NMAX, where NMAX is max( NN(j) ). */
/* -16: LDVR < 1 or LDVR < NMAX, where NMAX is max( NN(j) ). */
/* -18: LDLRE < 1 or LDLRE < NMAX, where NMAX is max( NN(j) ). */
/* -21: NWORK too small. */
/* If ZLATMR, CLATMS, CLATME or ZGEEV returns an error code, */
/* the absolute value of it is returned. */
/* ----------------------------------------------------------------------- */
/* Some Local Variables and Parameters: */
/* ---- ----- --------- --- ---------- */
/* ZERO, ONE Real 0 and 1. */
/* MAXTYP The number of types defined. */
/* NMAX Largest value in NN. */
/* NERRS The number of tests which have exceeded THRESH */
/* COND, CONDS, */
/* IMODE Values to be passed to the matrix generators. */
/* ANORM Norm of A; passed to matrix generators. */
/* OVFL, UNFL Overflow and underflow thresholds. */
/* ULP, ULPINV Finest relative precision and its inverse. */
/* RTULP, RTULPI Square roots of the previous 4 values. */
/* The following four arrays decode JTYPE: */
/* KTYPE(j) The general type (1-10) for type "j". */
/* KMODE(j) The MODE value to be passed to the matrix */
/* generator for type "j". */
/* KMAGN(j) The order of magnitude ( O(1), */
/* O(overflow^(1/2) ), O(underflow^(1/2) ) */
/* KCONDS(j) Selectw whether CONDS is to be 1 or */
/* 1/sqrt(ulp). (0 means irrelevant.) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--nn;
--dotype;
--iseed;
h_dim1 = *lda;
h_offset = 1 + h_dim1;
h__ -= h_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--w;
--w1;
vl_dim1 = *ldvl;
vl_offset = 1 + vl_dim1;
vl -= vl_offset;
vr_dim1 = *ldvr;
vr_offset = 1 + vr_dim1;
vr -= vr_offset;
lre_dim1 = *ldlre;
lre_offset = 1 + lre_dim1;
lre -= lre_offset;
--result;
--work;
--rwork;
--iwork;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17);
s_copy(path + 1, "EV", (ftnlen)2, (ftnlen)2);
/* Check for errors */
ntestt = 0;
ntestf = 0;
*info = 0;
/* Important constants */
badnn = FALSE_;
nmax = 0;
i__1 = *nsizes;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = nmax, i__3 = nn[j];
nmax = max(i__2,i__3);
if (nn[j] < 0) {
badnn = TRUE_;
}
/* L10: */
}
/* Check for errors */
if (*nsizes < 0) {
*info = -1;
} else if (badnn) {
*info = -2;
} else if (*ntypes < 0) {
*info = -3;
} else if (*thresh < 0.) {
*info = -6;
} else if (*nounit <= 0) {
*info = -7;
} else if (*lda < 1 || *lda < nmax) {
*info = -9;
} else if (*ldvl < 1 || *ldvl < nmax) {
*info = -14;
} else if (*ldvr < 1 || *ldvr < nmax) {
*info = -16;
} else if (*ldlre < 1 || *ldlre < nmax) {
*info = -28;
} else /* if(complicated condition) */ {
/* Computing 2nd power */
i__1 = nmax;
if (nmax * 5 + (i__1 * i__1 << 1) > *nwork) {
*info = -21;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZDRVEV", &i__1);
return 0;
}
/* Quick return if nothing to do */
if (*nsizes == 0 || *ntypes == 0) {
return 0;
}
/* More Important constants */
unfl = dlamch_("Safe minimum");
ovfl = 1. / unfl;
dlabad_(&unfl, &ovfl);
ulp = dlamch_("Precision");
ulpinv = 1. / ulp;
rtulp = sqrt(ulp);
rtulpi = 1. / rtulp;
/* Loop over sizes, types */
nerrs = 0;
i__1 = *nsizes;
for (jsize = 1; jsize <= i__1; ++jsize) {
n = nn[jsize];
if (*nsizes != 1) {
mtypes = min(21,*ntypes);
} else {
mtypes = min(22,*ntypes);
}
i__2 = mtypes;
for (jtype = 1; jtype <= i__2; ++jtype) {
if (! dotype[jtype]) {
goto L260;
}
/* Save ISEED in case of an error. */
for (j = 1; j <= 4; ++j) {
ioldsd[j - 1] = iseed[j];
/* L20: */
}
/* Compute "A" */
/* Control parameters: */
/* KMAGN KCONDS KMODE KTYPE */
/* =1 O(1) 1 clustered 1 zero */
/* =2 large large clustered 2 identity */
/* =3 small exponential Jordan */
/* =4 arithmetic diagonal, (w/ eigenvalues) */
/* =5 random log symmetric, w/ eigenvalues */
/* =6 random general, w/ eigenvalues */
/* =7 random diagonal */
/* =8 random symmetric */
/* =9 random general */
/* =10 random triangular */
if (mtypes > 21) {
goto L90;
}
itype = ktype[jtype - 1];
imode = kmode[jtype - 1];
/* Compute norm */
switch (kmagn[jtype - 1]) {
case 1: goto L30;
case 2: goto L40;
case 3: goto L50;
}
L30:
anorm = 1.;
goto L60;
L40:
anorm = ovfl * ulp;
goto L60;
L50:
anorm = unfl * ulpinv;
goto L60;
L60:
zlaset_("Full", lda, &n, &c_b1, &c_b1, &a[a_offset], lda);
iinfo = 0;
cond = ulpinv;
/* Special Matrices -- Identity & Jordan block */
/* Zero */
if (itype == 1) {
iinfo = 0;
} else if (itype == 2) {
/* Identity */
i__3 = n;
for (jcol = 1; jcol <= i__3; ++jcol) {
i__4 = jcol + jcol * a_dim1;
z__1.r = anorm, z__1.i = 0.;
a[i__4].r = z__1.r, a[i__4].i = z__1.i;
/* L70: */
}
} else if (itype == 3) {
/* Jordan Block */
i__3 = n;
for (jcol = 1; jcol <= i__3; ++jcol) {
i__4 = jcol + jcol * a_dim1;
z__1.r = anorm, z__1.i = 0.;
a[i__4].r = z__1.r, a[i__4].i = z__1.i;
if (jcol > 1) {
i__4 = jcol + (jcol - 1) * a_dim1;
a[i__4].r = 1., a[i__4].i = 0.;
}
/* L80: */
}
} else if (itype == 4) {
/* Diagonal Matrix, [Eigen]values Specified */
zlatms_(&n, &n, "S", &iseed[1], "H", &rwork[1], &imode, &cond,
&anorm, &c__0, &c__0, "N", &a[a_offset], lda, &work[
n + 1], &iinfo);
} else if (itype == 5) {
/* Hermitian, eigenvalues specified */
zlatms_(&n, &n, "S", &iseed[1], "H", &rwork[1], &imode, &cond,
&anorm, &n, &n, "N", &a[a_offset], lda, &work[n + 1],
&iinfo);
} else if (itype == 6) {
/* General, eigenvalues specified */
if (kconds[jtype - 1] == 1) {
conds = 1.;
} else if (kconds[jtype - 1] == 2) {
conds = rtulpi;
} else {
conds = 0.;
}
zlatme_(&n, "D", &iseed[1], &work[1], &imode, &cond, &c_b2,
" ", "T", "T", "T", &rwork[1], &c__4, &conds, &n, &n,
&anorm, &a[a_offset], lda, &work[(n << 1) + 1], &
iinfo);
} else if (itype == 7) {
/* Diagonal, random eigenvalues */
zlatmr_(&n, &n, "D", &iseed[1], "N", &work[1], &c__6, &c_b38,
&c_b2, "T", "N", &work[n + 1], &c__1, &c_b38, &work[(
n << 1) + 1], &c__1, &c_b38, "N", idumma, &c__0, &
c__0, &c_b48, &anorm, "NO", &a[a_offset], lda, &iwork[
1], &iinfo);
} else if (itype == 8) {
/* Symmetric, random eigenvalues */
zlatmr_(&n, &n, "D", &iseed[1], "H", &work[1], &c__6, &c_b38,
&c_b2, "T", "N", &work[n + 1], &c__1, &c_b38, &work[(
n << 1) + 1], &c__1, &c_b38, "N", idumma, &n, &n, &
c_b48, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
iinfo);
} else if (itype == 9) {
/* General, random eigenvalues */
zlatmr_(&n, &n, "D", &iseed[1], "N", &work[1], &c__6, &c_b38,
&c_b2, "T", "N", &work[n + 1], &c__1, &c_b38, &work[(
n << 1) + 1], &c__1, &c_b38, "N", idumma, &n, &n, &
c_b48, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
iinfo);
if (n >= 4) {
zlaset_("Full", &c__2, &n, &c_b1, &c_b1, &a[a_offset],
lda);
i__3 = n - 3;
zlaset_("Full", &i__3, &c__1, &c_b1, &c_b1, &a[a_dim1 + 3]
, lda);
i__3 = n - 3;
zlaset_("Full", &i__3, &c__2, &c_b1, &c_b1, &a[(n - 1) *
a_dim1 + 3], lda);
zlaset_("Full", &c__1, &n, &c_b1, &c_b1, &a[n + a_dim1],
lda);
}
} else if (itype == 10) {
/* Triangular, random eigenvalues */
zlatmr_(&n, &n, "D", &iseed[1], "N", &work[1], &c__6, &c_b38,
&c_b2, "T", "N", &work[n + 1], &c__1, &c_b38, &work[(
n << 1) + 1], &c__1, &c_b38, "N", idumma, &n, &c__0, &
c_b48, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
iinfo);
} else {
iinfo = 1;
}
if (iinfo != 0) {
io___31.ciunit = *nounit;
s_wsfe(&io___31);
do_fio(&c__1, "Generator", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
return 0;
}
L90:
/* Test for minimal and generous workspace */
for (iwk = 1; iwk <= 2; ++iwk) {
if (iwk == 1) {
nnwork = n << 1;
} else {
/* Computing 2nd power */
i__3 = n;
nnwork = n * 5 + (i__3 * i__3 << 1);
}
nnwork = max(nnwork,1);
/* Initialize RESULT */
for (j = 1; j <= 7; ++j) {
result[j] = -1.;
/* L100: */
}
/* Compute eigenvalues and eigenvectors, and test them */
zlacpy_("F", &n, &n, &a[a_offset], lda, &h__[h_offset], lda);
zgeev_("V", "V", &n, &h__[h_offset], lda, &w[1], &vl[
vl_offset], ldvl, &vr[vr_offset], ldvr, &work[1], &
nnwork, &rwork[1], &iinfo);
if (iinfo != 0) {
result[1] = ulpinv;
io___34.ciunit = *nounit;
s_wsfe(&io___34);
do_fio(&c__1, "ZGEEV1", (ftnlen)6);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
;
e_wsfe();
*info = abs(iinfo);
goto L220;
}
/* Do Test (1) */
zget22_("N", "N", "N", &n, &a[a_offset], lda, &vr[vr_offset],
ldvr, &w[1], &work[1], &rwork[1], res);
result[1] = res[0];
/* Do Test (2) */
zget22_("C", "N", "C", &n, &a[a_offset], lda, &vl[vl_offset],
ldvl, &w[1], &work[1], &rwork[1], res);
result[2] = res[0];
/* Do Test (3) */
i__3 = n;
for (j = 1; j <= i__3; ++j) {
tnrm = dznrm2_(&n, &vr[j * vr_dim1 + 1], &c__1);
/* Computing MAX */
/* Computing MIN */
d__4 = ulpinv, d__5 = (d__1 = tnrm - 1., abs(d__1)) / ulp;
d__2 = result[3], d__3 = min(d__4,d__5);
result[3] = max(d__2,d__3);
vmx = 0.;
vrmx = 0.;
i__4 = n;
for (jj = 1; jj <= i__4; ++jj) {
vtst = z_abs(&vr[jj + j * vr_dim1]);
if (vtst > vmx) {
vmx = vtst;
}
i__5 = jj + j * vr_dim1;
if (d_imag(&vr[jj + j * vr_dim1]) == 0. && (d__1 = vr[
i__5].r, abs(d__1)) > vrmx) {
i__6 = jj + j * vr_dim1;
vrmx = (d__2 = vr[i__6].r, abs(d__2));
}
/* L110: */
}
if (vrmx / vmx < 1. - ulp * 2.) {
result[3] = ulpinv;
}
/* L120: */
}
/* Do Test (4) */
i__3 = n;
for (j = 1; j <= i__3; ++j) {
tnrm = dznrm2_(&n, &vl[j * vl_dim1 + 1], &c__1);
/* Computing MAX */
/* Computing MIN */
d__4 = ulpinv, d__5 = (d__1 = tnrm - 1., abs(d__1)) / ulp;
d__2 = result[4], d__3 = min(d__4,d__5);
result[4] = max(d__2,d__3);
vmx = 0.;
vrmx = 0.;
i__4 = n;
for (jj = 1; jj <= i__4; ++jj) {
vtst = z_abs(&vl[jj + j * vl_dim1]);
if (vtst > vmx) {
vmx = vtst;
}
i__5 = jj + j * vl_dim1;
if (d_imag(&vl[jj + j * vl_dim1]) == 0. && (d__1 = vl[
i__5].r, abs(d__1)) > vrmx) {
i__6 = jj + j * vl_dim1;
vrmx = (d__2 = vl[i__6].r, abs(d__2));
}
/* L130: */
}
if (vrmx / vmx < 1. - ulp * 2.) {
result[4] = ulpinv;
}
/* L140: */
}
/* Compute eigenvalues only, and test them */
zlacpy_("F", &n, &n, &a[a_offset], lda, &h__[h_offset], lda);
zgeev_("N", "N", &n, &h__[h_offset], lda, &w1[1], dum, &c__1,
dum, &c__1, &work[1], &nnwork, &rwork[1], &iinfo);
if (iinfo != 0) {
result[1] = ulpinv;
io___42.ciunit = *nounit;
s_wsfe(&io___42);
do_fio(&c__1, "ZGEEV2", (ftnlen)6);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
;
e_wsfe();
*info = abs(iinfo);
goto L220;
}
/* Do Test (5) */
i__3 = n;
for (j = 1; j <= i__3; ++j) {
i__4 = j;
i__5 = j;
if (w[i__4].r != w1[i__5].r || w[i__4].i != w1[i__5].i) {
result[5] = ulpinv;
}
/* L150: */
}
/* Compute eigenvalues and right eigenvectors, and test them */
zlacpy_("F", &n, &n, &a[a_offset], lda, &h__[h_offset], lda);
zgeev_("N", "V", &n, &h__[h_offset], lda, &w1[1], dum, &c__1,
&lre[lre_offset], ldlre, &work[1], &nnwork, &rwork[1],
&iinfo);
if (iinfo != 0) {
result[1] = ulpinv;
io___43.ciunit = *nounit;
s_wsfe(&io___43);
do_fio(&c__1, "ZGEEV3", (ftnlen)6);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
;
e_wsfe();
*info = abs(iinfo);
goto L220;
}
/* Do Test (5) again */
i__3 = n;
for (j = 1; j <= i__3; ++j) {
i__4 = j;
i__5 = j;
if (w[i__4].r != w1[i__5].r || w[i__4].i != w1[i__5].i) {
result[5] = ulpinv;
}
/* L160: */
}
/* Do Test (6) */
i__3 = n;
for (j = 1; j <= i__3; ++j) {
i__4 = n;
for (jj = 1; jj <= i__4; ++jj) {
i__5 = j + jj * vr_dim1;
i__6 = j + jj * lre_dim1;
if (vr[i__5].r != lre[i__6].r || vr[i__5].i != lre[
i__6].i) {
result[6] = ulpinv;
}
/* L170: */
}
/* L180: */
}
/* Compute eigenvalues and left eigenvectors, and test them */
zlacpy_("F", &n, &n, &a[a_offset], lda, &h__[h_offset], lda);
zgeev_("V", "N", &n, &h__[h_offset], lda, &w1[1], &lre[
lre_offset], ldlre, dum, &c__1, &work[1], &nnwork, &
rwork[1], &iinfo);
if (iinfo != 0) {
result[1] = ulpinv;
io___44.ciunit = *nounit;
s_wsfe(&io___44);
do_fio(&c__1, "ZGEEV4", (ftnlen)6);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
;
e_wsfe();
*info = abs(iinfo);
goto L220;
}
/* Do Test (5) again */
i__3 = n;
for (j = 1; j <= i__3; ++j) {
i__4 = j;
i__5 = j;
if (w[i__4].r != w1[i__5].r || w[i__4].i != w1[i__5].i) {
result[5] = ulpinv;
}
/* L190: */
}
/* Do Test (7) */
i__3 = n;
for (j = 1; j <= i__3; ++j) {
i__4 = n;
for (jj = 1; jj <= i__4; ++jj) {
i__5 = j + jj * vl_dim1;
i__6 = j + jj * lre_dim1;
if (vl[i__5].r != lre[i__6].r || vl[i__5].i != lre[
i__6].i) {
result[7] = ulpinv;
}
/* L200: */
}
/* L210: */
}
/* End of Loop -- Check for RESULT(j) > THRESH */
L220:
ntest = 0;
nfail = 0;
for (j = 1; j <= 7; ++j) {
if (result[j] >= 0.) {
++ntest;
}
if (result[j] >= *thresh) {
++nfail;
}
/* L230: */
}
if (nfail > 0) {
++ntestf;
}
if (ntestf == 1) {
io___47.ciunit = *nounit;
s_wsfe(&io___47);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
io___48.ciunit = *nounit;
s_wsfe(&io___48);
e_wsfe();
io___49.ciunit = *nounit;
s_wsfe(&io___49);
e_wsfe();
io___50.ciunit = *nounit;
s_wsfe(&io___50);
e_wsfe();
io___51.ciunit = *nounit;
s_wsfe(&io___51);
do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(
doublereal));
e_wsfe();
ntestf = 2;
}
for (j = 1; j <= 7; ++j) {
if (result[j] >= *thresh) {
io___52.ciunit = *nounit;
s_wsfe(&io___52);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&iwk, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[j], (ftnlen)sizeof(
doublereal));
e_wsfe();
}
/* L240: */
}
nerrs += nfail;
ntestt += ntest;
/* L250: */
}
L260:
;
}
/* L270: */
}
/* Summary */
dlasum_(path, nounit, &nerrs, &ntestt);
return 0;
/* End of ZDRVEV */
} /* zdrvev_ */
/* Subroutine */ int dchkpo_(logical *dotype, integer *nn, integer *nval,
integer *nnb, integer *nbval, integer *nns, integer *nsval,
doublereal *thresh, logical *tsterr, integer *nmax, doublereal *a,
doublereal *afac, doublereal *ainv, doublereal *b, doublereal *x,
doublereal *xact, doublereal *work, doublereal *rwork, integer *iwork,
integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
static char uplos[1*2] = "U" "L";
/* Format strings */
static char fmt_9999[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002, "
"NB =\002,i4,\002, type \002,i2,\002, test \002,i2,\002, ratio "
"=\002,g12.5)";
static char fmt_9998[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002, "
"NRHS=\002,i3,\002, type \002,i2,\002, test(\002,i2,\002) =\002,g"
"12.5)";
static char fmt_9997[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002"
",\002,10x,\002 type \002,i2,\002, test(\002,i2,\002) =\002,g12.5)"
;
/* System generated locals */
integer i__1, i__2, i__3, i__4;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
integer i__, k, n, nb, in, kl, ku, lda, inb, ioff, mode, imat, info;
char path[3], dist[1];
integer irhs, nrhs;
char uplo[1], type__[1];
integer nrun;
extern /* Subroutine */ int alahd_(integer *, char *), dget04_(
integer *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *);
integer nfail, iseed[4];
extern doublereal dget06_(doublereal *, doublereal *);
doublereal rcond;
extern /* Subroutine */ int dpot01_(char *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, doublereal *);
integer nimat;
extern /* Subroutine */ int dpot02_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *), dpot03_(char *,
integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *), dpot05_(char *, integer *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *);
doublereal anorm;
integer iuplo, izero, nerrs;
logical zerot;
char xtype[1];
extern /* Subroutine */ int dlatb4_(char *, integer *, integer *, integer
*, char *, integer *, integer *, doublereal *, integer *,
doublereal *, char *), alaerh_(char *,
char *, integer *, integer *, char *, integer *, integer *,
integer *, integer *, integer *, integer *, integer *, integer *,
integer *);
doublereal rcondc;
extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *),
dlarhs_(char *, char *, char *, char *, integer *, integer *,
integer *, integer *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, integer *, integer *,
integer *), alasum_(char *,
integer *, integer *, integer *, integer *);
doublereal cndnum;
extern /* Subroutine */ int dlatms_(integer *, integer *, char *, integer
*, char *, doublereal *, integer *, doublereal *, doublereal *,
integer *, integer *, char *, doublereal *, integer *, doublereal
*, integer *), dpocon_(char *, integer *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *,
integer *, integer *);
extern doublereal dlansy_(char *, char *, integer *, doublereal *,
integer *, doublereal *);
extern /* Subroutine */ int derrpo_(char *, integer *), dporfs_(
char *, integer *, integer *, doublereal *, integer *, doublereal
*, integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, doublereal *, integer *, integer *), dpotrf_(char *, integer *, doublereal *, integer *,
integer *), xlaenv_(integer *, integer *), dpotri_(char *,
integer *, doublereal *, integer *, integer *), dpotrs_(
char *, integer *, integer *, doublereal *, integer *, doublereal
*, integer *, integer *);
doublereal result[8];
/* Fortran I/O blocks */
static cilist io___33 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___36 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___38 = { 0, 0, 0, fmt_9997, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DCHKPO tests DPOTRF, -TRI, -TRS, -RFS, and -CON */
/* Arguments */
/* ========= */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* The matrix types to be used for testing. Matrices of type j */
/* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = */
/* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. */
/* NN (input) INTEGER */
/* The number of values of N contained in the vector NVAL. */
/* NVAL (input) INTEGER array, dimension (NN) */
/* The values of the matrix dimension N. */
/* NNB (input) INTEGER */
/* The number of values of NB contained in the vector NBVAL. */
/* NBVAL (input) INTEGER array, dimension (NBVAL) */
/* The values of the blocksize NB. */
/* NNS (input) INTEGER */
/* The number of values of NRHS contained in the vector NSVAL. */
/* NSVAL (input) INTEGER array, dimension (NNS) */
/* The values of the number of right hand sides NRHS. */
/* THRESH (input) DOUBLE PRECISION */
/* The threshold value for the test ratios. A result is */
/* included in the output file if RESULT >= THRESH. To have */
/* every test ratio printed, use THRESH = 0. */
/* TSTERR (input) LOGICAL */
/* Flag that indicates whether error exits are to be tested. */
/* NMAX (input) INTEGER */
/* The maximum value permitted for N, used in dimensioning the */
/* work arrays. */
/* A (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
/* AFAC (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
/* AINV (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
/* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) */
/* where NSMAX is the largest entry in NSVAL. */
/* X (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) */
/* XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) */
/* WORK (workspace) DOUBLE PRECISION array, dimension */
/* (NMAX*max(3,NSMAX)) */
/* RWORK (workspace) DOUBLE PRECISION array, dimension */
/* (max(NMAX,2*NSMAX)) */
/* IWORK (workspace) INTEGER array, dimension (NMAX) */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--iwork;
--rwork;
--work;
--xact;
--x;
--b;
--ainv;
--afac;
--a;
--nsval;
--nbval;
--nval;
--dotype;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* Initialize constants and the random number seed. */
s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
s_copy(path + 1, "PO", (ftnlen)2, (ftnlen)2);
nrun = 0;
nfail = 0;
nerrs = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
}
/* Test the error exits */
if (*tsterr) {
derrpo_(path, nout);
}
infoc_1.infot = 0;
xlaenv_(&c__2, &c__2);
/* Do for each value of N in NVAL */
i__1 = *nn;
for (in = 1; in <= i__1; ++in) {
n = nval[in];
lda = max(n,1);
*(unsigned char *)xtype = 'N';
nimat = 9;
if (n <= 0) {
nimat = 1;
}
izero = 0;
i__2 = nimat;
for (imat = 1; imat <= i__2; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (! dotype[imat]) {
goto L110;
}
/* Skip types 3, 4, or 5 if the matrix size is too small. */
zerot = imat >= 3 && imat <= 5;
if (zerot && n < imat - 2) {
goto L110;
}
/* Do first for UPLO = 'U', then for UPLO = 'L' */
for (iuplo = 1; iuplo <= 2; ++iuplo) {
*(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
/* Set up parameters with DLATB4 and generate a test matrix */
/* with DLATMS. */
dlatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode,
&cndnum, dist);
s_copy(srnamc_1.srnamt, "DLATMS", (ftnlen)32, (ftnlen)6);
dlatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
cndnum, &anorm, &kl, &ku, uplo, &a[1], &lda, &work[1],
&info);
/* Check error code from DLATMS. */
if (info != 0) {
alaerh_(path, "DLATMS", &info, &c__0, uplo, &n, &n, &c_n1,
&c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
goto L100;
}
/* For types 3-5, zero one row and column of the matrix to */
/* test that INFO is returned correctly. */
if (zerot) {
if (imat == 3) {
izero = 1;
} else if (imat == 4) {
izero = n;
} else {
izero = n / 2 + 1;
}
ioff = (izero - 1) * lda;
/* Set row and column IZERO of A to 0. */
if (iuplo == 1) {
i__3 = izero - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
a[ioff + i__] = 0.;
/* L20: */
}
ioff += izero;
i__3 = n;
for (i__ = izero; i__ <= i__3; ++i__) {
a[ioff] = 0.;
ioff += lda;
/* L30: */
}
} else {
ioff = izero;
i__3 = izero - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
a[ioff] = 0.;
ioff += lda;
/* L40: */
}
ioff -= izero;
i__3 = n;
for (i__ = izero; i__ <= i__3; ++i__) {
a[ioff + i__] = 0.;
/* L50: */
}
}
} else {
izero = 0;
}
/* Do for each value of NB in NBVAL */
i__3 = *nnb;
for (inb = 1; inb <= i__3; ++inb) {
nb = nbval[inb];
xlaenv_(&c__1, &nb);
/* Compute the L*L' or U'*U factorization of the matrix. */
dlacpy_(uplo, &n, &n, &a[1], &lda, &afac[1], &lda);
s_copy(srnamc_1.srnamt, "DPOTRF", (ftnlen)32, (ftnlen)6);
dpotrf_(uplo, &n, &afac[1], &lda, &info);
/* Check error code from DPOTRF. */
if (info != izero) {
alaerh_(path, "DPOTRF", &info, &izero, uplo, &n, &n, &
c_n1, &c_n1, &nb, &imat, &nfail, &nerrs, nout);
goto L90;
}
/* Skip the tests if INFO is not 0. */
if (info != 0) {
goto L90;
}
/* + TEST 1 */
/* Reconstruct matrix from factors and compute residual. */
dlacpy_(uplo, &n, &n, &afac[1], &lda, &ainv[1], &lda);
dpot01_(uplo, &n, &a[1], &lda, &ainv[1], &lda, &rwork[1],
result);
/* + TEST 2 */
/* Form the inverse and compute the residual. */
dlacpy_(uplo, &n, &n, &afac[1], &lda, &ainv[1], &lda);
s_copy(srnamc_1.srnamt, "DPOTRI", (ftnlen)32, (ftnlen)6);
dpotri_(uplo, &n, &ainv[1], &lda, &info);
/* Check error code from DPOTRI. */
if (info != 0) {
alaerh_(path, "DPOTRI", &info, &c__0, uplo, &n, &n, &
c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
nout);
}
dpot03_(uplo, &n, &a[1], &lda, &ainv[1], &lda, &work[1], &
lda, &rwork[1], &rcondc, &result[1]);
/* Print information about the tests that did not pass */
/* the threshold. */
for (k = 1; k <= 2; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___33.ciunit = *nout;
s_wsfe(&io___33);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(integer)
);
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
sizeof(doublereal));
e_wsfe();
++nfail;
}
/* L60: */
}
nrun += 2;
/* Skip the rest of the tests unless this is the first */
/* blocksize. */
if (inb != 1) {
goto L90;
}
i__4 = *nns;
for (irhs = 1; irhs <= i__4; ++irhs) {
nrhs = nsval[irhs];
/* + TEST 3 */
/* Solve and compute residual for A * X = B . */
s_copy(srnamc_1.srnamt, "DLARHS", (ftnlen)32, (ftnlen)
6);
dlarhs_(path, xtype, uplo, " ", &n, &n, &kl, &ku, &
nrhs, &a[1], &lda, &xact[1], &lda, &b[1], &
lda, iseed, &info);
dlacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &lda);
s_copy(srnamc_1.srnamt, "DPOTRS", (ftnlen)32, (ftnlen)
6);
dpotrs_(uplo, &n, &nrhs, &afac[1], &lda, &x[1], &lda,
&info);
/* Check error code from DPOTRS. */
if (info != 0) {
alaerh_(path, "DPOTRS", &info, &c__0, uplo, &n, &
n, &c_n1, &c_n1, &nrhs, &imat, &nfail, &
nerrs, nout);
}
dlacpy_("Full", &n, &nrhs, &b[1], &lda, &work[1], &
lda);
dpot02_(uplo, &n, &nrhs, &a[1], &lda, &x[1], &lda, &
work[1], &lda, &rwork[1], &result[2]);
/* + TEST 4 */
/* Check solution from generated exact solution. */
dget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[3]);
/* + TESTS 5, 6, and 7 */
/* Use iterative refinement to improve the solution. */
s_copy(srnamc_1.srnamt, "DPORFS", (ftnlen)32, (ftnlen)
6);
dporfs_(uplo, &n, &nrhs, &a[1], &lda, &afac[1], &lda,
&b[1], &lda, &x[1], &lda, &rwork[1], &rwork[
nrhs + 1], &work[1], &iwork[1], &info);
/* Check error code from DPORFS. */
if (info != 0) {
alaerh_(path, "DPORFS", &info, &c__0, uplo, &n, &
n, &c_n1, &c_n1, &nrhs, &imat, &nfail, &
nerrs, nout);
}
dget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[4]);
dpot05_(uplo, &n, &nrhs, &a[1], &lda, &b[1], &lda, &x[
1], &lda, &xact[1], &lda, &rwork[1], &rwork[
nrhs + 1], &result[5]);
/* Print information about the tests that did not pass */
/* the threshold. */
for (k = 3; k <= 7; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___36.ciunit = *nout;
s_wsfe(&io___36);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&nrhs, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
sizeof(doublereal));
e_wsfe();
++nfail;
}
/* L70: */
}
nrun += 5;
/* L80: */
}
/* + TEST 8 */
/* Get an estimate of RCOND = 1/CNDNUM. */
anorm = dlansy_("1", uplo, &n, &a[1], &lda, &rwork[1]);
s_copy(srnamc_1.srnamt, "DPOCON", (ftnlen)32, (ftnlen)6);
dpocon_(uplo, &n, &afac[1], &lda, &anorm, &rcond, &work[1]
, &iwork[1], &info);
/* Check error code from DPOCON. */
if (info != 0) {
alaerh_(path, "DPOCON", &info, &c__0, uplo, &n, &n, &
c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
nout);
}
result[7] = dget06_(&rcond, &rcondc);
/* Print the test ratio if it is .GE. THRESH. */
if (result[7] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___38.ciunit = *nout;
s_wsfe(&io___38);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__8, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[7], (ftnlen)sizeof(
doublereal));
e_wsfe();
++nfail;
}
++nrun;
L90:
;
}
L100:
;
}
L110:
;
}
/* L120: */
}
/* Print a summary of the results. */
alasum_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of DCHKPO */
} /* dchkpo_ */
/* Subroutine */ int ctimtr_(char *line, integer *nn, integer *nval, integer *
nns, integer *nsval, integer *nnb, integer *nbval, integer *nlda,
integer *ldaval, real *timmin, complex *a, complex *b, real *reslts,
integer *ldr1, integer *ldr2, integer *ldr3, integer *nout, ftnlen
line_len)
{
/* Initialized data */
static char subnam[6*2] = "CTRTRI" "CTRTRS";
static char uplos[1*2] = "U" "L";
/* Format strings */
static char fmt_9999[] = "(1x,a6,\002 timing run not attempted\002,/)";
static char fmt_9998[] = "(/\002 *** Speed of \002,a6,\002 in megaflops "
"***\002)";
static char fmt_9997[] = "(5x,\002line \002,i2,\002 with LDA = \002,i5)";
static char fmt_9996[] = "(5x,a6,\002 with UPLO = '\002,a1,\002'\002,/)";
/* System generated locals */
integer reslts_dim1, reslts_dim2, reslts_dim3, reslts_offset, i__1, i__2,
i__3;
/* Builtin functions
Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
s_wsle(cilist *), e_wsle(void);
/* Local variables */
static integer ilda, info;
static char path[3];
static real time;
static integer isub, nrhs;
static char uplo[1];
static integer i__, n;
static char cname[6];
extern logical lsame_(char *, char *);
extern doublereal sopla_(char *, integer *, integer *, integer *, integer
*, integer *);
static integer iuplo, i3;
static real s1, s2;
static integer ic, nb, in;
extern /* Subroutine */ int atimck_(integer *, char *, integer *, integer
*, integer *, integer *, integer *, integer *, ftnlen);
extern doublereal second_(void);
extern /* Subroutine */ int ctimmg_(integer *, integer *, integer *,
complex *, integer *, integer *, integer *), atimin_(char *, char
*, integer *, char *, logical *, integer *, integer *, ftnlen,
ftnlen, ftnlen), xlaenv_(integer *, integer *);
extern doublereal smflop_(real *, real *, integer *);
static real untime;
static logical timsub[2];
extern /* Subroutine */ int sprtbl_(char *, char *, integer *, integer *,
integer *, integer *, integer *, real *, integer *, integer *,
integer *, ftnlen, ftnlen), ctrtri_(char *, char *, integer *,
complex *, integer *, integer *), ctrtrs_(char *,
char *, char *, integer *, integer *, complex *, integer *,
complex *, integer *, integer *);
static integer lda, ldb, icl, inb, mat;
static real ops;
/* Fortran I/O blocks */
static cilist io___7 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___29 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___30 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___31 = { 0, 0, 0, 0, 0 };
static cilist io___32 = { 0, 0, 0, fmt_9996, 0 };
#define subnam_ref(a_0,a_1) &subnam[(a_1)*6 + a_0 - 6]
#define reslts_ref(a_1,a_2,a_3,a_4) reslts[(((a_4)*reslts_dim3 + (a_3))*\
reslts_dim2 + (a_2))*reslts_dim1 + a_1]
/* -- LAPACK timing routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
March 31, 1993
Purpose
=======
CTIMTR times CTRTRI and -TRS.
Arguments
=========
LINE (input) CHARACTER*80
The input line that requested this routine. The first six
characters contain either the name of a subroutine or a
generic path name. The remaining characters may be used to
specify the individual routines to be timed. See ATIMIN for
a full description of the format of the input line.
NN (input) INTEGER
The number of values of N contained in the vector NVAL.
NVAL (input) INTEGER array, dimension (NN)
The values of the matrix size N.
NNS (input) INTEGER
The number of values of NRHS contained in the vector NSVAL.
NSVAL (input) INTEGER array, dimension (NNS)
The values of the number of right hand sides NRHS.
NNB (input) INTEGER
The number of values of NB contained in the vector NBVAL.
NBVAL (input) INTEGER array, dimension (NNB)
The values of the blocksize NB.
NLDA (input) INTEGER
The number of values of LDA contained in the vector LDAVAL.
LDAVAL (input) INTEGER array, dimension (NLDA)
The values of the leading dimension of the array A.
TIMMIN (input) REAL
The minimum time a subroutine will be timed.
A (workspace) COMPLEX array, dimension (LDAMAX*NMAX)
where LDAMAX and NMAX are the maximum values permitted
for LDA and N.
B (workspace) COMPLEX array, dimension (LDAMAX*NMAX)
RESLTS (output) REAL array, dimension
(LDR1,LDR2,LDR3,NSUBS)
The timing results for each subroutine over the relevant
values of N, NB, and LDA.
LDR1 (input) INTEGER
The first dimension of RESLTS. LDR1 >= max(1,NNB).
LDR2 (input) INTEGER
The second dimension of RESLTS. LDR2 >= max(1,NN).
LDR3 (input) INTEGER
The third dimension of RESLTS. LDR3 >= max(1,2*NLDA).
NOUT (input) INTEGER
The unit number for output.
=====================================================================
Parameter adjustments */
--nval;
--nsval;
--nbval;
--ldaval;
--a;
--b;
reslts_dim1 = *ldr1;
reslts_dim2 = *ldr2;
reslts_dim3 = *ldr3;
reslts_offset = 1 + reslts_dim1 * (1 + reslts_dim2 * (1 + reslts_dim3 * 1)
);
reslts -= reslts_offset;
/* Function Body
Extract the timing request from the input line. */
s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17);
s_copy(path + 1, "TR", (ftnlen)2, (ftnlen)2);
atimin_(path, line, &c__2, subnam, timsub, nout, &info, (ftnlen)3, (
ftnlen)80, (ftnlen)6);
if (info != 0) {
goto L130;
}
/* Check that N <= LDA for the input values. */
s_copy(cname, line, (ftnlen)6, (ftnlen)6);
atimck_(&c__2, cname, nn, &nval[1], nlda, &ldaval[1], nout, &info, (
ftnlen)6);
if (info > 0) {
io___7.ciunit = *nout;
s_wsfe(&io___7);
do_fio(&c__1, cname, (ftnlen)6);
e_wsfe();
goto L130;
}
/* Do first for UPLO = 'U', then for UPLO = 'L' */
for (iuplo = 1; iuplo <= 2; ++iuplo) {
*(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
if (lsame_(uplo, "U")) {
mat = 11;
} else {
mat = -11;
}
/* Do for each value of N: */
i__1 = *nn;
for (in = 1; in <= i__1; ++in) {
n = nval[in];
/* Do for each value of LDA: */
i__2 = *nlda;
for (ilda = 1; ilda <= i__2; ++ilda) {
lda = ldaval[ilda];
i3 = (iuplo - 1) * *nlda + ilda;
/* Do for each value of NB in NBVAL. Only the blocked
routines are timed in this loop since the other routines
are independent of NB. */
if (timsub[0]) {
i__3 = *nnb;
for (inb = 1; inb <= i__3; ++inb) {
nb = nbval[inb];
xlaenv_(&c__1, &nb);
/* Time CTRTRI */
ctimmg_(&mat, &n, &n, &a[1], &lda, &c__0, &c__0);
ic = 0;
s1 = second_();
L10:
ctrtri_(uplo, "Non-unit", &n, &a[1], &lda, &info);
s2 = second_();
time = s2 - s1;
++ic;
if (time < *timmin) {
ctimmg_(&mat, &n, &n, &a[1], &lda, &c__0, &c__0);
goto L10;
}
/* Subtract the time used in CTIMMG. */
icl = 1;
s1 = second_();
L20:
s2 = second_();
untime = s2 - s1;
++icl;
if (icl <= ic) {
ctimmg_(&mat, &n, &n, &a[1], &lda, &c__0, &c__0);
goto L20;
}
time = (time - untime) / (real) ic;
ops = sopla_("CTRTRI", &n, &n, &c__0, &c__0, &nb);
reslts_ref(inb, in, i3, 1) = smflop_(&ops, &time, &
info);
/* L30: */
}
} else {
/* Generate a triangular matrix A. */
ctimmg_(&mat, &n, &n, &a[1], &lda, &c__0, &c__0);
}
/* Time CTRTRS */
if (timsub[1]) {
i__3 = *nns;
for (i__ = 1; i__ <= i__3; ++i__) {
nrhs = nsval[i__];
ldb = lda;
ctimmg_(&c__0, &n, &nrhs, &b[1], &ldb, &c__0, &c__0);
ic = 0;
s1 = second_();
L40:
ctrtrs_(uplo, "No transpose", "Non-unit", &n, &nrhs, &
a[1], &lda, &b[1], &ldb, &info);
s2 = second_();
time = s2 - s1;
++ic;
if (time < *timmin) {
ctimmg_(&c__0, &n, &nrhs, &b[1], &ldb, &c__0, &
c__0);
goto L40;
}
/* Subtract the time used in CTIMMG. */
icl = 1;
s1 = second_();
L50:
s2 = second_();
untime = s2 - s1;
++icl;
if (icl <= ic) {
ctimmg_(&c__0, &n, &nrhs, &b[1], &ldb, &c__0, &
c__0);
goto L50;
}
time = (time - untime) / (real) ic;
ops = sopla_("CTRTRS", &n, &nrhs, &c__0, &c__0, &c__0);
reslts_ref(i__, in, i3, 2) = smflop_(&ops, &time, &
info);
/* L60: */
}
}
/* L70: */
}
/* L80: */
}
/* L90: */
}
/* Print a table of results. */
for (isub = 1; isub <= 2; ++isub) {
if (! timsub[isub - 1]) {
goto L120;
}
io___29.ciunit = *nout;
s_wsfe(&io___29);
do_fio(&c__1, subnam_ref(0, isub), (ftnlen)6);
e_wsfe();
if (*nlda > 1) {
i__1 = *nlda;
for (i__ = 1; i__ <= i__1; ++i__) {
io___30.ciunit = *nout;
s_wsfe(&io___30);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&ldaval[i__], (ftnlen)sizeof(integer));
e_wsfe();
/* L100: */
}
}
io___31.ciunit = *nout;
s_wsle(&io___31);
e_wsle();
for (iuplo = 1; iuplo <= 2; ++iuplo) {
io___32.ciunit = *nout;
s_wsfe(&io___32);
do_fio(&c__1, subnam_ref(0, isub), (ftnlen)6);
do_fio(&c__1, uplos + (iuplo - 1), (ftnlen)1);
e_wsfe();
i3 = (iuplo - 1) * *nlda + 1;
if (isub == 1) {
sprtbl_("NB", "N", nnb, &nbval[1], nn, &nval[1], nlda, &
reslts_ref(1, 1, i3, 1), ldr1, ldr2, nout, (ftnlen)2,
(ftnlen)1);
} else if (isub == 2) {
sprtbl_("NRHS", "N", nns, &nsval[1], nn, &nval[1], nlda, &
reslts_ref(1, 1, i3, 2), ldr1, ldr2, nout, (ftnlen)4,
(ftnlen)1);
}
/* L110: */
}
L120:
;
}
L130:
return 0;
/* End of CTIMTR */
} /* ctimtr_ */
/* Subroutine */ int psvout_(integer *comm, integer *lout, integer *n, real *
sx, integer *idigit, char *ifmt, ftnlen ifmt_len)
{
/* Format strings */
static char fmt_9999[] = "(/1x,a,/1x,a)";
static char fmt_9998[] = "(1x,i4,\002 - \002,i4,\002:\002,1p,10e12.3)";
static char fmt_9997[] = "(1x,i4,\002 - \002,i4,\002:\002,1x,1p,8e14.5)";
static char fmt_9996[] = "(1x,i4,\002 - \002,i4,\002:\002,1x,1p,6e18.9)";
static char fmt_9995[] = "(1x,i4,\002 - \002,i4,\002:\002,1x,1p,5e24.13)";
static char fmt_9994[] = "(1x,\002 \002)";
/* System generated locals */
integer i__1, i__2, i__3;
/* Builtin functions */
integer i_len(char *, ftnlen), s_wsfe(cilist *), do_fio(integer *, char *,
ftnlen), e_wsfe(void);
/* Local variables */
static integer i__, k1, k2, lll;
static char line[80];
static integer ierr, myid;
extern /* Subroutine */ int mpi_comm_rank__(integer *, integer *, integer
*);
static integer ndigit;
/* Fortran I/O blocks */
static cilist io___6 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___10 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___11 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___12 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___13 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___14 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___15 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___16 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___17 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___18 = { 0, 0, 0, fmt_9994, 0 };
/* ... */
/* .. MPI VARIABLES AND FUNCTIONS .. */
/* .. Variable Declaration .. */
/* /+ */
/* * */
/* * (C) 1993 by Argonne National Laboratory and Mississipi State University. */
/* * All rights reserved. See COPYRIGHT in top-level directory. */
/* +/ */
/* /+ user include file for MPI programs, with no dependencies +/ */
/* /+ return codes +/ */
/* We handle datatypes by putting the variables that hold them into */
/* common. This way, a Fortran program can directly use the various */
/* datatypes and can even give them to C programs. */
/* MPI_BOTTOM needs to be a known address; here we put it at the */
/* beginning of the common block. The point-to-point and collective */
/* routines know about MPI_BOTTOM, but MPI_TYPE_STRUCT as yet does not. */
/* The types MPI_INTEGER1,2,4 and MPI_REAL4,8 are OPTIONAL. */
/* Their values are zero if they are not available. Note that */
/* using these reduces the portability of code (though may enhance */
/* portability between Crays and other systems) */
/* All other MPI routines are subroutines */
/* The attribute copy/delete functions are symbols that can be passed */
/* to MPI routines */
/* ... SPECIFICATIONS FOR ARGUMENTS */
/* ... */
/* ... SPECIFICATIONS FOR LOCAL VARIABLES */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* ... */
/* ... FIRST EXECUTABLE STATEMENT */
/* Determine processor configuration */
/* Parameter adjustments */
--sx;
/* Function Body */
mpi_comm_rank__(comm, &myid, &ierr);
/* .. Only Processor 0 will write to file LOUT .. */
if (myid == 0) {
/* Computing MIN */
i__1 = i_len(ifmt, ifmt_len);
lll = min(i__1,80);
i__1 = lll;
for (i__ = 1; i__ <= i__1; ++i__) {
*(unsigned char *)&line[i__ - 1] = '-';
/* L10: */
}
for (i__ = lll + 1; i__ <= 80; ++i__) {
*(unsigned char *)&line[i__ - 1] = ' ';
/* L20: */
}
io___6.ciunit = *lout;
s_wsfe(&io___6);
do_fio(&c__1, ifmt, ifmt_len);
do_fio(&c__1, line, lll);
e_wsfe();
if (*n <= 0) {
return 0;
}
ndigit = *idigit;
if (*idigit == 0) {
ndigit = 4;
}
/* ======================================================================= */
/* CODE FOR OUTPUT USING 72 COLUMNS FORMAT */
/* ======================================================================= */
if (*idigit < 0) {
ndigit = -(*idigit);
if (ndigit <= 4) {
i__1 = *n;
for (k1 = 1; k1 <= i__1; k1 += 5) {
/* Computing MIN */
i__2 = *n, i__3 = k1 + 4;
k2 = min(i__2,i__3);
io___10.ciunit = *lout;
s_wsfe(&io___10);
do_fio(&c__1, (char *)&k1, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&k2, (ftnlen)sizeof(integer));
i__2 = k2;
for (i__ = k1; i__ <= i__2; ++i__) {
do_fio(&c__1, (char *)&sx[i__], (ftnlen)sizeof(real));
}
e_wsfe();
/* L30: */
}
} else if (ndigit <= 6) {
i__1 = *n;
for (k1 = 1; k1 <= i__1; k1 += 4) {
/* Computing MIN */
i__2 = *n, i__3 = k1 + 3;
k2 = min(i__2,i__3);
io___11.ciunit = *lout;
s_wsfe(&io___11);
do_fio(&c__1, (char *)&k1, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&k2, (ftnlen)sizeof(integer));
i__2 = k2;
for (i__ = k1; i__ <= i__2; ++i__) {
do_fio(&c__1, (char *)&sx[i__], (ftnlen)sizeof(real));
}
e_wsfe();
/* L40: */
}
} else if (ndigit <= 10) {
i__1 = *n;
for (k1 = 1; k1 <= i__1; k1 += 3) {
/* Computing MIN */
i__2 = *n, i__3 = k1 + 2;
k2 = min(i__2,i__3);
io___12.ciunit = *lout;
s_wsfe(&io___12);
do_fio(&c__1, (char *)&k1, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&k2, (ftnlen)sizeof(integer));
i__2 = k2;
for (i__ = k1; i__ <= i__2; ++i__) {
do_fio(&c__1, (char *)&sx[i__], (ftnlen)sizeof(real));
}
e_wsfe();
/* L50: */
}
} else {
i__1 = *n;
for (k1 = 1; k1 <= i__1; k1 += 2) {
/* Computing MIN */
i__2 = *n, i__3 = k1 + 1;
k2 = min(i__2,i__3);
io___13.ciunit = *lout;
s_wsfe(&io___13);
do_fio(&c__1, (char *)&k1, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&k2, (ftnlen)sizeof(integer));
i__2 = k2;
for (i__ = k1; i__ <= i__2; ++i__) {
do_fio(&c__1, (char *)&sx[i__], (ftnlen)sizeof(real));
}
e_wsfe();
/* L60: */
}
}
/* ======================================================================= */
/* CODE FOR OUTPUT USING 132 COLUMNS FORMAT */
/* ======================================================================= */
} else {
if (ndigit <= 4) {
i__1 = *n;
for (k1 = 1; k1 <= i__1; k1 += 10) {
/* Computing MIN */
i__2 = *n, i__3 = k1 + 9;
k2 = min(i__2,i__3);
io___14.ciunit = *lout;
s_wsfe(&io___14);
do_fio(&c__1, (char *)&k1, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&k2, (ftnlen)sizeof(integer));
i__2 = k2;
for (i__ = k1; i__ <= i__2; ++i__) {
do_fio(&c__1, (char *)&sx[i__], (ftnlen)sizeof(real));
}
e_wsfe();
/* L70: */
}
} else if (ndigit <= 6) {
i__1 = *n;
for (k1 = 1; k1 <= i__1; k1 += 8) {
/* Computing MIN */
i__2 = *n, i__3 = k1 + 7;
k2 = min(i__2,i__3);
io___15.ciunit = *lout;
s_wsfe(&io___15);
do_fio(&c__1, (char *)&k1, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&k2, (ftnlen)sizeof(integer));
i__2 = k2;
for (i__ = k1; i__ <= i__2; ++i__) {
do_fio(&c__1, (char *)&sx[i__], (ftnlen)sizeof(real));
}
e_wsfe();
/* L80: */
}
} else if (ndigit <= 10) {
i__1 = *n;
for (k1 = 1; k1 <= i__1; k1 += 6) {
/* Computing MIN */
i__2 = *n, i__3 = k1 + 5;
k2 = min(i__2,i__3);
io___16.ciunit = *lout;
s_wsfe(&io___16);
do_fio(&c__1, (char *)&k1, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&k2, (ftnlen)sizeof(integer));
i__2 = k2;
for (i__ = k1; i__ <= i__2; ++i__) {
do_fio(&c__1, (char *)&sx[i__], (ftnlen)sizeof(real));
}
e_wsfe();
/* L90: */
}
} else {
i__1 = *n;
for (k1 = 1; k1 <= i__1; k1 += 5) {
/* Computing MIN */
i__2 = *n, i__3 = k1 + 4;
k2 = min(i__2,i__3);
io___17.ciunit = *lout;
s_wsfe(&io___17);
do_fio(&c__1, (char *)&k1, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&k2, (ftnlen)sizeof(integer));
i__2 = k2;
for (i__ = k1; i__ <= i__2; ++i__) {
do_fio(&c__1, (char *)&sx[i__], (ftnlen)sizeof(real));
}
e_wsfe();
/* L100: */
}
}
}
io___18.ciunit = *lout;
s_wsfe(&io___18);
e_wsfe();
}
return 0;
} /* psvout_ */
/* Main program */ int MAIN__(void)
{
/* Format strings */
static char fmt_9994[] = "(/\002 Tests of the DOUBLE PRECISION LAPACK RF"
"P routines \002,/\002 LAPACK VERSION \002,i1,\002.\002,i1,\002"
".\002,i1,//\002 The following parameter values will be used:\002)"
;
static char fmt_9996[] = "(\002 !! Invalid input value: \002,a4,\002="
"\002,i6,\002; must be >=\002,i6)";
static char fmt_9995[] = "(\002 !! Invalid input value: \002,a4,\002="
"\002,i6,\002; must be <=\002,i6)";
static char fmt_9993[] = "(4x,a4,\002: \002,10i6,/11x,10i6)";
static char fmt_9992[] = "(/\002 Routines pass computational tests if te"
"st ratio is \002,\002less than\002,f8.2,/)";
static char fmt_9999[] = "(/\002 Execution not attempted due to input er"
"rors\002)";
static char fmt_9991[] = "(\002 Relative machine \002,a,\002 is taken to"
" be\002,d16.6)";
static char fmt_9998[] = "(/\002 End of tests\002)";
static char fmt_9997[] = "(\002 Total time used = \002,f12.2,\002 seco"
"nds\002,/)";
/* System generated locals */
integer i__1;
doublereal d__1;
cllist cl__1;
/* Builtin functions */
integer s_rsle(cilist *), e_rsle(void), s_wsfe(cilist *), do_fio(integer *
, char *, ftnlen), e_wsfe(void), do_lio(integer *, integer *,
char *, ftnlen);
/* Subroutine */ int s_stop(char *, ftnlen);
integer s_wsle(cilist *), e_wsle(void), f_clos(cllist *);
/* Local variables */
doublereal workafac[2500] /* was [50][50] */, workasav[2500] /*
was [50][50] */, workbsav[800] /* was [50][16] */, workainv[
2500] /* was [50][50] */, workxact[800] /* was [50][
16] */;
integer i__;
doublereal s1, s2;
integer nn, vers_patch__, vers_major__, vers_minor__;
doublereal workarfinv[1275], eps;
integer nns, nnt, nval[12];
doublereal d_temp_dpot02__[800] /* was [50][16] */, d_temp_dpot03__[
2500] /* was [50][50] */, d_work_dpot01__[50],
d_work_dpot02__[50], d_work_dpot03__[50];
logical fatal;
integer nsval[12], ntval[9];
doublereal worka[2500] /* was [50][50] */, workb[800] /* was [50][
16] */, workx[800] /* was [50][16] */, d_work_dlatms__[150],
d_work_dlansy__[50];
extern doublereal dlamch_(char *), dsecnd_(void);
extern /* Subroutine */ int ilaver_(integer *, integer *, integer *);
doublereal thresh, workap[1275];
logical tsterr;
extern /* Subroutine */ int ddrvrf1_(integer *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, doublereal *)
, ddrvrf2_(integer *, integer *, integer *, doublereal *, integer
*, doublereal *, doublereal *, doublereal *), ddrvrf3_(integer *,
integer *, integer *, doublereal *, doublereal *, integer *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *), ddrvrf4_(integer *, integer *,
integer *, doublereal *, doublereal *, doublereal *, integer *,
doublereal *, doublereal *, integer *, doublereal *), derrrfp_(
integer *), ddrvrfp_(integer *, integer *, integer *, integer *,
integer *, integer *, integer *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *);
doublereal workarf[1275];
/* Fortran I/O blocks */
static cilist io___3 = { 0, 5, 0, 0, 0 };
static cilist io___7 = { 0, 6, 0, fmt_9994, 0 };
static cilist io___8 = { 0, 5, 0, 0, 0 };
static cilist io___10 = { 0, 6, 0, fmt_9996, 0 };
static cilist io___11 = { 0, 6, 0, fmt_9995, 0 };
static cilist io___12 = { 0, 5, 0, 0, 0 };
static cilist io___15 = { 0, 6, 0, fmt_9996, 0 };
static cilist io___16 = { 0, 6, 0, fmt_9995, 0 };
static cilist io___17 = { 0, 6, 0, fmt_9993, 0 };
static cilist io___18 = { 0, 5, 0, 0, 0 };
static cilist io___20 = { 0, 6, 0, fmt_9996, 0 };
static cilist io___21 = { 0, 6, 0, fmt_9995, 0 };
static cilist io___22 = { 0, 5, 0, 0, 0 };
static cilist io___24 = { 0, 6, 0, fmt_9996, 0 };
static cilist io___25 = { 0, 6, 0, fmt_9995, 0 };
static cilist io___26 = { 0, 6, 0, fmt_9993, 0 };
static cilist io___27 = { 0, 5, 0, 0, 0 };
static cilist io___29 = { 0, 6, 0, fmt_9996, 0 };
static cilist io___30 = { 0, 6, 0, fmt_9995, 0 };
static cilist io___31 = { 0, 5, 0, 0, 0 };
static cilist io___33 = { 0, 6, 0, fmt_9996, 0 };
static cilist io___34 = { 0, 6, 0, fmt_9995, 0 };
static cilist io___35 = { 0, 6, 0, fmt_9993, 0 };
static cilist io___36 = { 0, 5, 0, 0, 0 };
static cilist io___38 = { 0, 6, 0, fmt_9992, 0 };
static cilist io___39 = { 0, 5, 0, 0, 0 };
static cilist io___41 = { 0, 6, 0, fmt_9999, 0 };
static cilist io___42 = { 0, 6, 0, fmt_9999, 0 };
static cilist io___44 = { 0, 6, 0, fmt_9991, 0 };
static cilist io___45 = { 0, 6, 0, fmt_9991, 0 };
static cilist io___46 = { 0, 6, 0, fmt_9991, 0 };
static cilist io___47 = { 0, 6, 0, 0, 0 };
static cilist io___67 = { 0, 6, 0, fmt_9998, 0 };
static cilist io___68 = { 0, 6, 0, fmt_9997, 0 };
/* -- LAPACK test routine (version 3.2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2008 */
/* Purpose */
/* ======= */
/* DCHKRFP is the main test program for the DOUBLE PRECISION linear */
/* equation routines with RFP storage format */
/* Internal Parameters */
/* =================== */
/* MAXIN INTEGER */
/* The number of different values that can be used for each of */
/* M, N, or NB */
/* MAXRHS INTEGER */
/* The maximum number of right hand sides */
/* NTYPES INTEGER */
/* NMAX INTEGER */
/* The maximum allowable value for N. */
/* NIN INTEGER */
/* The unit number for input */
/* NOUT INTEGER */
/* The unit number for output */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Executable Statements .. */
s1 = dsecnd_();
fatal = FALSE_;
/* Read a dummy line. */
s_rsle(&io___3);
e_rsle();
/* Report LAPACK version tag (e.g. LAPACK-3.2.0) */
ilaver_(&vers_major__, &vers_minor__, &vers_patch__);
s_wsfe(&io___7);
do_fio(&c__1, (char *)&vers_major__, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&vers_minor__, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&vers_patch__, (ftnlen)sizeof(integer));
e_wsfe();
/* Read the values of N */
s_rsle(&io___8);
do_lio(&c__3, &c__1, (char *)&nn, (ftnlen)sizeof(integer));
e_rsle();
if (nn < 1) {
s_wsfe(&io___10);
do_fio(&c__1, " NN ", (ftnlen)4);
do_fio(&c__1, (char *)&nn, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
e_wsfe();
nn = 0;
fatal = TRUE_;
} else if (nn > 12) {
s_wsfe(&io___11);
do_fio(&c__1, " NN ", (ftnlen)4);
do_fio(&c__1, (char *)&nn, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__12, (ftnlen)sizeof(integer));
e_wsfe();
nn = 0;
fatal = TRUE_;
}
s_rsle(&io___12);
i__1 = nn;
for (i__ = 1; i__ <= i__1; ++i__) {
do_lio(&c__3, &c__1, (char *)&nval[i__ - 1], (ftnlen)sizeof(integer));
}
e_rsle();
i__1 = nn;
for (i__ = 1; i__ <= i__1; ++i__) {
if (nval[i__ - 1] < 0) {
s_wsfe(&io___15);
do_fio(&c__1, " M ", (ftnlen)4);
do_fio(&c__1, (char *)&nval[i__ - 1], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
e_wsfe();
fatal = TRUE_;
} else if (nval[i__ - 1] > 50) {
s_wsfe(&io___16);
do_fio(&c__1, " M ", (ftnlen)4);
do_fio(&c__1, (char *)&nval[i__ - 1], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__50, (ftnlen)sizeof(integer));
e_wsfe();
fatal = TRUE_;
}
/* L10: */
}
if (nn > 0) {
s_wsfe(&io___17);
do_fio(&c__1, "N ", (ftnlen)4);
i__1 = nn;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&nval[i__ - 1], (ftnlen)sizeof(integer));
}
e_wsfe();
}
/* Read the values of NRHS */
s_rsle(&io___18);
do_lio(&c__3, &c__1, (char *)&nns, (ftnlen)sizeof(integer));
e_rsle();
if (nns < 1) {
s_wsfe(&io___20);
do_fio(&c__1, " NNS", (ftnlen)4);
do_fio(&c__1, (char *)&nns, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
e_wsfe();
nns = 0;
fatal = TRUE_;
} else if (nns > 12) {
s_wsfe(&io___21);
do_fio(&c__1, " NNS", (ftnlen)4);
do_fio(&c__1, (char *)&nns, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__12, (ftnlen)sizeof(integer));
e_wsfe();
nns = 0;
fatal = TRUE_;
}
s_rsle(&io___22);
i__1 = nns;
for (i__ = 1; i__ <= i__1; ++i__) {
do_lio(&c__3, &c__1, (char *)&nsval[i__ - 1], (ftnlen)sizeof(integer))
;
}
e_rsle();
i__1 = nns;
for (i__ = 1; i__ <= i__1; ++i__) {
if (nsval[i__ - 1] < 0) {
s_wsfe(&io___24);
do_fio(&c__1, "NRHS", (ftnlen)4);
do_fio(&c__1, (char *)&nsval[i__ - 1], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
e_wsfe();
fatal = TRUE_;
} else if (nsval[i__ - 1] > 16) {
s_wsfe(&io___25);
do_fio(&c__1, "NRHS", (ftnlen)4);
do_fio(&c__1, (char *)&nsval[i__ - 1], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__16, (ftnlen)sizeof(integer));
e_wsfe();
fatal = TRUE_;
}
/* L30: */
}
if (nns > 0) {
s_wsfe(&io___26);
do_fio(&c__1, "NRHS", (ftnlen)4);
i__1 = nns;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&nsval[i__ - 1], (ftnlen)sizeof(integer));
}
e_wsfe();
}
/* Read the matrix types */
s_rsle(&io___27);
do_lio(&c__3, &c__1, (char *)&nnt, (ftnlen)sizeof(integer));
e_rsle();
if (nnt < 1) {
s_wsfe(&io___29);
do_fio(&c__1, " NMA", (ftnlen)4);
do_fio(&c__1, (char *)&nnt, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
e_wsfe();
nnt = 0;
fatal = TRUE_;
} else if (nnt > 9) {
s_wsfe(&io___30);
do_fio(&c__1, " NMA", (ftnlen)4);
do_fio(&c__1, (char *)&nnt, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__9, (ftnlen)sizeof(integer));
e_wsfe();
nnt = 0;
fatal = TRUE_;
}
s_rsle(&io___31);
i__1 = nnt;
for (i__ = 1; i__ <= i__1; ++i__) {
do_lio(&c__3, &c__1, (char *)&ntval[i__ - 1], (ftnlen)sizeof(integer))
;
}
e_rsle();
i__1 = nnt;
for (i__ = 1; i__ <= i__1; ++i__) {
if (ntval[i__ - 1] < 0) {
s_wsfe(&io___33);
do_fio(&c__1, "TYPE", (ftnlen)4);
do_fio(&c__1, (char *)&ntval[i__ - 1], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
e_wsfe();
fatal = TRUE_;
} else if (ntval[i__ - 1] > 9) {
s_wsfe(&io___34);
do_fio(&c__1, "TYPE", (ftnlen)4);
do_fio(&c__1, (char *)&ntval[i__ - 1], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__9, (ftnlen)sizeof(integer));
e_wsfe();
fatal = TRUE_;
}
/* L320: */
}
if (nnt > 0) {
s_wsfe(&io___35);
do_fio(&c__1, "TYPE", (ftnlen)4);
i__1 = nnt;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&ntval[i__ - 1], (ftnlen)sizeof(integer));
}
e_wsfe();
}
/* Read the threshold value for the test ratios. */
s_rsle(&io___36);
do_lio(&c__5, &c__1, (char *)&thresh, (ftnlen)sizeof(doublereal));
e_rsle();
s_wsfe(&io___38);
do_fio(&c__1, (char *)&thresh, (ftnlen)sizeof(doublereal));
e_wsfe();
/* Read the flag that indicates whether to test the error exits. */
s_rsle(&io___39);
do_lio(&c__8, &c__1, (char *)&tsterr, (ftnlen)sizeof(logical));
e_rsle();
if (fatal) {
s_wsfe(&io___41);
e_wsfe();
s_stop("", (ftnlen)0);
}
if (fatal) {
s_wsfe(&io___42);
e_wsfe();
s_stop("", (ftnlen)0);
}
/* Calculate and print the machine dependent constants. */
eps = dlamch_("Underflow threshold");
s_wsfe(&io___44);
do_fio(&c__1, "underflow", (ftnlen)9);
do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(doublereal));
e_wsfe();
eps = dlamch_("Overflow threshold");
s_wsfe(&io___45);
do_fio(&c__1, "overflow ", (ftnlen)9);
do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(doublereal));
e_wsfe();
eps = dlamch_("Epsilon");
s_wsfe(&io___46);
do_fio(&c__1, "precision", (ftnlen)9);
do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(doublereal));
e_wsfe();
s_wsle(&io___47);
e_wsle();
/* Test the error exit of: */
if (tsterr) {
derrrfp_(&c__6);
}
/* Test the routines: dpftrf, dpftri, dpftrs (as in DDRVPO). */
/* This also tests the routines: dtfsm, dtftri, dtfttr, dtrttf. */
ddrvrfp_(&c__6, &nn, nval, &nns, nsval, &nnt, ntval, &thresh, worka,
workasav, workafac, workainv, workb, workbsav, workxact, workx,
workarf, workarfinv, d_work_dlatms__, d_work_dpot01__,
d_temp_dpot02__, d_temp_dpot03__, d_work_dlansy__,
d_work_dpot02__, d_work_dpot03__);
/* Test the routine: dlansf */
ddrvrf1_(&c__6, &nn, nval, &thresh, worka, &c__50, workarf,
d_work_dlansy__);
/* Test the convertion routines: */
/* dtfttp, dtpttf, dtfttr, dtrttf, dtrttp and dtpttr. */
ddrvrf2_(&c__6, &nn, nval, worka, &c__50, workarf, workap, workasav);
/* Test the routine: dtfsm */
ddrvrf3_(&c__6, &nn, nval, &thresh, worka, &c__50, workarf, workainv,
workafac, d_work_dlansy__, d_work_dpot03__, d_work_dpot01__);
/* Test the routine: dsfrk */
ddrvrf4_(&c__6, &nn, nval, &thresh, worka, workafac, &c__50, workarf,
workainv, &c__50, d_work_dlansy__);
cl__1.cerr = 0;
cl__1.cunit = 5;
cl__1.csta = 0;
f_clos(&cl__1);
s2 = dsecnd_();
s_wsfe(&io___67);
e_wsfe();
s_wsfe(&io___68);
d__1 = s2 - s1;
do_fio(&c__1, (char *)&d__1, (ftnlen)sizeof(doublereal));
e_wsfe();
/* End of DCHKRFP */
return 0;
} /* MAIN__ */
/* DECK XERSVE */
/* Subroutine */ int xersve_(char *librar, char *subrou, char *messg, integer
*kflag, integer *nerr, integer *level, integer *icount, ftnlen
librar_len, ftnlen subrou_len, ftnlen messg_len)
{
/* Initialized data */
static integer kountx = 0;
static integer nmsg = 0;
/* Format strings */
static char fmt_9000[] = "(\0020 ERROR MESSAGE SUMMARY\002/\002"
" LIBRARY SUBROUTINE MESSAGE START NERR\002,\002 "
" LEVEL COUNT\002)";
static char fmt_9010[] = "(1x,a,3x,a,3x,a,3i10)";
static char fmt_9020[] = "(\0020OTHER ERRORS NOT INDIVIDUALLY TABULATED "
"= \002,i10)";
static char fmt_9030[] = "(1x)";
/* System generated locals */
integer i__1, i__2;
/* Builtin functions */
integer s_wsfe(cilist *), e_wsfe(void), do_fio(integer *, char *, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Local variables */
integer i__;
char lib[8], mes[20], sub[8];
integer lun[5], iunit, kunit, nunit;
static integer kount[10];
extern integer i1mach_(integer *);
static char libtab[8*10], mestab[20*10];
static integer nertab[10], levtab[10];
static char subtab[8*10];
extern /* Subroutine */ int xgetua_(integer *, integer *);
/* Fortran I/O blocks */
static cilist io___7 = { 0, 0, 0, fmt_9000, 0 };
static cilist io___9 = { 0, 0, 0, fmt_9010, 0 };
static cilist io___16 = { 0, 0, 0, fmt_9020, 0 };
static cilist io___17 = { 0, 0, 0, fmt_9030, 0 };
/* ***BEGIN PROLOGUE XERSVE */
/* ***SUBSIDIARY */
/* ***PURPOSE Record that an error has occurred. */
/* ***LIBRARY SLATEC (XERROR) */
/* ***CATEGORY R3 */
/* ***TYPE ALL (XERSVE-A) */
/* ***KEYWORDS ERROR, XERROR */
/* ***AUTHOR Jones, R. E., (SNLA) */
/* ***DESCRIPTION */
/* *Usage: */
/* INTEGER KFLAG, NERR, LEVEL, ICOUNT */
/* CHARACTER * (len) LIBRAR, SUBROU, MESSG */
/* CALL XERSVE (LIBRAR, SUBROU, MESSG, KFLAG, NERR, LEVEL, ICOUNT) */
/* *Arguments: */
/* LIBRAR :IN is the library that the message is from. */
/* SUBROU :IN is the subroutine that the message is from. */
/* MESSG :IN is the message to be saved. */
/* KFLAG :IN indicates the action to be performed. */
/* when KFLAG > 0, the message in MESSG is saved. */
/* when KFLAG=0 the tables will be dumped and */
/* cleared. */
/* when KFLAG < 0, the tables will be dumped and */
/* not cleared. */
/* NERR :IN is the error number. */
/* LEVEL :IN is the error severity. */
/* ICOUNT :OUT the number of times this message has been seen, */
/* or zero if the table has overflowed and does not */
/* contain this message specifically. When KFLAG=0, */
/* ICOUNT will not be altered. */
/* *Description: */
/* Record that this error occurred and possibly dump and clear the */
/* tables. */
/* ***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC */
/* Error-handling Package, SAND82-0800, Sandia */
/* Laboratories, 1982. */
/* ***ROUTINES CALLED I1MACH, XGETUA */
/* ***REVISION HISTORY (YYMMDD) */
/* 800319 DATE WRITTEN */
/* 861211 REVISION DATE from Version 3.2 */
/* 891214 Prologue converted to Version 4.0 format. (BAB) */
/* 900413 Routine modified to remove reference to KFLAG. (WRB) */
/* 900510 Changed to add LIBRARY NAME and SUBROUTINE to calling */
/* sequence, use IF-THEN-ELSE, make number of saved entries */
/* easily changeable, changed routine name from XERSAV to */
/* XERSVE. (RWC) */
/* 910626 Added LIBTAB and SUBTAB to SAVE statement. (BKS) */
/* 920501 Reformatted the REFERENCES section. (WRB) */
/* ***END PROLOGUE XERSVE */
/* ***FIRST EXECUTABLE STATEMENT XERSVE */
if (*kflag <= 0) {
/* Dump the table. */
if (nmsg == 0) {
return 0;
}
/* Print to each unit. */
xgetua_(lun, &nunit);
i__1 = nunit;
for (kunit = 1; kunit <= i__1; ++kunit) {
iunit = lun[kunit - 1];
if (iunit == 0) {
iunit = i1mach_(&c__4);
}
/* Print the table header. */
io___7.ciunit = iunit;
s_wsfe(&io___7);
e_wsfe();
/* Print body of table. */
i__2 = nmsg;
for (i__ = 1; i__ <= i__2; ++i__) {
io___9.ciunit = iunit;
s_wsfe(&io___9);
do_fio(&c__1, libtab + ((i__ - 1) << 3), (ftnlen)8);
do_fio(&c__1, subtab + ((i__ - 1) << 3), (ftnlen)8);
do_fio(&c__1, mestab + (i__ - 1) * 20, (ftnlen)20);
do_fio(&c__1, (char *)&nertab[i__ - 1], (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&levtab[i__ - 1], (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&kount[i__ - 1], (ftnlen)sizeof(integer)
);
e_wsfe();
/* L10: */
}
/* Print number of other errors. */
if (kountx != 0) {
io___16.ciunit = iunit;
s_wsfe(&io___16);
do_fio(&c__1, (char *)&kountx, (ftnlen)sizeof(integer));
e_wsfe();
}
io___17.ciunit = iunit;
s_wsfe(&io___17);
e_wsfe();
/* L20: */
}
/* Clear the error tables. */
if (*kflag == 0) {
nmsg = 0;
kountx = 0;
}
} else {
/* PROCESS A MESSAGE... */
/* SEARCH FOR THIS MESSG, OR ELSE AN EMPTY SLOT FOR THIS MESSG, */
/* OR ELSE DETERMINE THAT THE ERROR TABLE IS FULL. */
s_copy(lib, librar, (ftnlen)8, librar_len);
s_copy(sub, subrou, (ftnlen)8, subrou_len);
s_copy(mes, messg, (ftnlen)20, messg_len);
i__1 = nmsg;
for (i__ = 1; i__ <= i__1; ++i__) {
if (s_cmp(lib, libtab + ((i__ - 1) << 3), (ftnlen)8, (ftnlen)8) ==
0 && s_cmp(sub, subtab + ((i__ - 1) << 3), (ftnlen)8, (
ftnlen)8) == 0 && s_cmp(mes, mestab + (i__ - 1) * 20, (
ftnlen)20, (ftnlen)20) == 0 && *nerr == nertab[i__ - 1] &&
*level == levtab[i__ - 1]) {
++kount[i__ - 1];
*icount = kount[i__ - 1];
return 0;
}
/* L30: */
}
if (nmsg < 10) {
/* Empty slot found for new message. */
++nmsg;
s_copy(libtab + ((i__ - 1) << 3), lib, (ftnlen)8, (ftnlen)8);
s_copy(subtab + ((i__ - 1) << 3), sub, (ftnlen)8, (ftnlen)8);
s_copy(mestab + (i__ - 1) * 20, mes, (ftnlen)20, (ftnlen)20);
nertab[i__ - 1] = *nerr;
levtab[i__ - 1] = *level;
kount[i__ - 1] = 1;
*icount = 1;
} else {
/* Table is full. */
++kountx;
*icount = 0;
}
}
return 0;
/* Formats. */
} /* xersve_ */
/* DECK XERMSG */
/* Subroutine */ int xermsg_(char *librar, char *subrou, char *messg, integer
*nerr, integer *level, ftnlen librar_len, ftnlen subrou_len, ftnlen
messg_len)
{
/* System generated locals */
address a__1[2];
integer i__1, i__2, i__3[2];
char ch__1[87];
icilist ici__1;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer i_len(char *, ftnlen), s_wsfi(icilist *), do_fio(integer *, char *
, ftnlen), e_wsfi(void);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
/* Local variables */
integer i__, lerr;
char temp[72];
extern /* Subroutine */ int fdump_(void);
char xlibr[8];
integer ltemp, kount;
char xsubr[8];
extern integer j4save_(integer *, integer *, logical *);
integer llevel, maxmes;
char lfirst[20];
extern /* Subroutine */ int xercnt_(char *, char *, char *, integer *,
integer *, integer *, ftnlen, ftnlen, ftnlen);
integer lkntrl, kdummy;
extern /* Subroutine */ int xerhlt_(char *, ftnlen);
integer mkntrl;
extern /* Subroutine */ int xersve_(char *, char *, char *, integer *,
integer *, integer *, integer *, ftnlen, ftnlen, ftnlen), xerprn_(
char *, integer *, char *, integer *, ftnlen, ftnlen);
/* ***BEGIN PROLOGUE XERMSG */
/* ***PURPOSE Process error messages for SLATEC and other libraries. */
/* ***LIBRARY SLATEC (XERROR) */
/* ***CATEGORY R3C */
/* ***TYPE ALL (XERMSG-A) */
/* ***KEYWORDS ERROR MESSAGE, XERROR */
/* ***AUTHOR Fong, Kirby, (NMFECC at LLNL) */
/* ***DESCRIPTION */
/* XERMSG processes a diagnostic message in a manner determined by the */
/* value of LEVEL and the current value of the library error control */
/* flag, KONTRL. See subroutine XSETF for details. */
/* LIBRAR A character constant (or character variable) with the name */
/* of the library. This will be 'SLATEC' for the SLATEC */
/* Common Math Library. The error handling package is */
/* general enough to be used by many libraries */
/* simultaneously, so it is desirable for the routine that */
/* detects and reports an error to identify the library name */
/* as well as the routine name. */
/* SUBROU A character constant (or character variable) with the name */
/* of the routine that detected the error. Usually it is the */
/* name of the routine that is calling XERMSG. There are */
/* some instances where a user callable library routine calls */
/* lower level subsidiary routines where the error is */
/* detected. In such cases it may be more informative to */
/* supply the name of the routine the user called rather than */
/* the name of the subsidiary routine that detected the */
/* error. */
/* MESSG A character constant (or character variable) with the text */
/* of the error or warning message. In the example below, */
/* the message is a character constant that contains a */
/* generic message. */
/* CALL XERMSG ('SLATEC', 'MMPY', */
/* *'THE ORDER OF THE MATRIX EXCEEDS THE ROW DIMENSION', */
/* *3, 1) */
/* It is possible (and is sometimes desirable) to generate a */
/* specific message--e.g., one that contains actual numeric */
/* values. Specific numeric values can be converted into */
/* character strings using formatted WRITE statements into */
/* character variables. This is called standard Fortran */
/* internal file I/O and is exemplified in the first three */
/* lines of the following example. You can also catenate */
/* substrings of characters to construct the error message. */
/* Here is an example showing the use of both writing to */
/* an internal file and catenating character strings. */
/* CHARACTER*5 CHARN, CHARL */
/* WRITE (CHARN,10) N */
/* WRITE (CHARL,10) LDA */
/* 10 FORMAT(I5) */
/* CALL XERMSG ('SLATEC', 'MMPY', 'THE ORDER'//CHARN// */
/* * ' OF THE MATRIX EXCEEDS ITS ROW DIMENSION OF'// */
/* * CHARL, 3, 1) */
/* There are two subtleties worth mentioning. One is that */
/* the // for character catenation is used to construct the */
/* error message so that no single character constant is */
/* continued to the next line. This avoids confusion as to */
/* whether there are trailing blanks at the end of the line. */
/* The second is that by catenating the parts of the message */
/* as an actual argument rather than encoding the entire */
/* message into one large character variable, we avoid */
/* having to know how long the message will be in order to */
/* declare an adequate length for that large character */
/* variable. XERMSG calls XERPRN to print the message using */
/* multiple lines if necessary. If the message is very long, */
/* XERPRN will break it into pieces of 72 characters (as */
/* requested by XERMSG) for printing on multiple lines. */
/* Also, XERMSG asks XERPRN to prefix each line with ' * ' */
/* so that the total line length could be 76 characters. */
/* Note also that XERPRN scans the error message backwards */
/* to ignore trailing blanks. Another feature is that */
/* the substring '$$' is treated as a new line sentinel */
/* by XERPRN. If you want to construct a multiline */
/* message without having to count out multiples of 72 */
/* characters, just use '$$' as a separator. '$$' */
/* obviously must occur within 72 characters of the */
/* start of each line to have its intended effect since */
/* XERPRN is asked to wrap around at 72 characters in */
/* addition to looking for '$$'. */
/* NERR An integer value that is chosen by the library routine's */
/* author. It must be in the range -99 to 999 (three */
/* printable digits). Each distinct error should have its */
/* own error number. These error numbers should be described */
/* in the machine readable documentation for the routine. */
/* The error numbers need be unique only within each routine, */
/* so it is reasonable for each routine to start enumerating */
/* errors from 1 and proceeding to the next integer. */
/* LEVEL An integer value in the range 0 to 2 that indicates the */
/* level (severity) of the error. Their meanings are */
/* -1 A warning message. This is used if it is not clear */
/* that there really is an error, but the user's attention */
/* may be needed. An attempt is made to only print this */
/* message once. */
/* 0 A warning message. This is used if it is not clear */
/* that there really is an error, but the user's attention */
/* may be needed. */
/* 1 A recoverable error. This is used even if the error is */
/* so serious that the routine cannot return any useful */
/* answer. If the user has told the error package to */
/* return after recoverable errors, then XERMSG will */
/* return to the Library routine which can then return to */
/* the user's routine. The user may also permit the error */
/* package to terminate the program upon encountering a */
/* recoverable error. */
/* 2 A fatal error. XERMSG will not return to its caller */
/* after it receives a fatal error. This level should */
/* hardly ever be used; it is much better to allow the */
/* user a chance to recover. An example of one of the few */
/* cases in which it is permissible to declare a level 2 */
/* error is a reverse communication Library routine that */
/* is likely to be called repeatedly until it integrates */
/* across some interval. If there is a serious error in */
/* the input such that another step cannot be taken and */
/* the Library routine is called again without the input */
/* error having been corrected by the caller, the Library */
/* routine will probably be called forever with improper */
/* input. In this case, it is reasonable to declare the */
/* error to be fatal. */
/* Each of the arguments to XERMSG is input; none will be modified by */
/* XERMSG. A routine may make multiple calls to XERMSG with warning */
/* level messages; however, after a call to XERMSG with a recoverable */
/* error, the routine should return to the user. Do not try to call */
/* XERMSG with a second recoverable error after the first recoverable */
/* error because the error package saves the error number. The user */
/* can retrieve this error number by calling another entry point in */
/* the error handling package and then clear the error number when */
/* recovering from the error. Calling XERMSG in succession causes the */
/* old error number to be overwritten by the latest error number. */
/* This is considered harmless for error numbers associated with */
/* warning messages but must not be done for error numbers of serious */
/* errors. After a call to XERMSG with a recoverable error, the user */
/* must be given a chance to call NUMXER or XERCLR to retrieve or */
/* clear the error number. */
/* ***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC */
/* Error-handling Package, SAND82-0800, Sandia */
/* Laboratories, 1982. */
/* ***ROUTINES CALLED FDUMP, J4SAVE, XERCNT, XERHLT, XERPRN, XERSVE */
/* ***REVISION HISTORY (YYMMDD) */
/* 880101 DATE WRITTEN */
/* 880621 REVISED AS DIRECTED AT SLATEC CML MEETING OF FEBRUARY 1988. */
/* THERE ARE TWO BASIC CHANGES. */
/* 1. A NEW ROUTINE, XERPRN, IS USED INSTEAD OF XERPRT TO */
/* PRINT MESSAGES. THIS ROUTINE WILL BREAK LONG MESSAGES */
/* INTO PIECES FOR PRINTING ON MULTIPLE LINES. '$$' IS */
/* ACCEPTED AS A NEW LINE SENTINEL. A PREFIX CAN BE */
/* ADDED TO EACH LINE TO BE PRINTED. XERMSG USES EITHER */
/* ' ***' OR ' * ' AND LONG MESSAGES ARE BROKEN EVERY */
/* 72 CHARACTERS (AT MOST) SO THAT THE MAXIMUM LINE */
/* LENGTH OUTPUT CAN NOW BE AS GREAT AS 76. */
/* 2. THE TEXT OF ALL MESSAGES IS NOW IN UPPER CASE SINCE THE */
/* FORTRAN STANDARD DOCUMENT DOES NOT ADMIT THE EXISTENCE */
/* OF LOWER CASE. */
/* 880708 REVISED AFTER THE SLATEC CML MEETING OF JUNE 29 AND 30. */
/* THE PRINCIPAL CHANGES ARE */
/* 1. CLARIFY COMMENTS IN THE PROLOGUES */
/* 2. RENAME XRPRNT TO XERPRN */
/* 3. REWORK HANDLING OF '$$' IN XERPRN TO HANDLE BLANK LINES */
/* SIMILAR TO THE WAY FORMAT STATEMENTS HANDLE THE / */
/* CHARACTER FOR NEW RECORDS. */
/* 890706 REVISED WITH THE HELP OF FRED FRITSCH AND REG CLEMENS TO */
/* CLEAN UP THE CODING. */
/* 890721 REVISED TO USE NEW FEATURE IN XERPRN TO COUNT CHARACTERS IN */
/* PREFIX. */
/* 891013 REVISED TO CORRECT COMMENTS. */
/* 891214 Prologue converted to Version 4.0 format. (WRB) */
/* 900510 Changed test on NERR to be -9999999 < NERR < 99999999, but */
/* NERR .ne. 0, and on LEVEL to be -2 < LEVEL < 3. Added */
/* LEVEL=-1 logic, changed calls to XERSAV to XERSVE, and */
/* XERCTL to XERCNT. (RWC) */
/* 920501 Reformatted the REFERENCES section. (WRB) */
/* ***END PROLOGUE XERMSG */
/* ***FIRST EXECUTABLE STATEMENT XERMSG */
lkntrl = j4save_(&c__2, &c__0, &c_false);
maxmes = j4save_(&c__4, &c__0, &c_false);
/* LKNTRL IS A LOCAL COPY OF THE CONTROL FLAG KONTRL. */
/* MAXMES IS THE MAXIMUM NUMBER OF TIMES ANY PARTICULAR MESSAGE */
/* SHOULD BE PRINTED. */
/* WE PRINT A FATAL ERROR MESSAGE AND TERMINATE FOR AN ERROR IN */
/* CALLING XERMSG. THE ERROR NUMBER SHOULD BE POSITIVE, */
/* AND THE LEVEL SHOULD BE BETWEEN 0 AND 2. */
if (*nerr < -9999999 || *nerr > 99999999 || *nerr == 0 || *level < -1 || *
level > 2) {
xerprn_(" ***", &c_n1, "FATAL ERROR IN...$$ XERMSG -- INVALID ERROR "
"NUMBER OR LEVEL$$ JOB ABORT DUE TO FATAL ERROR.", &c__72, (
ftnlen)4, (ftnlen)91);
xersve_(" ", " ", " ", &c__0, &c__0, &c__0, &kdummy, (ftnlen)1, (
ftnlen)1, (ftnlen)1);
xerhlt_(" ***XERMSG -- INVALID INPUT", (ftnlen)27);
return 0;
}
/* RECORD THE MESSAGE. */
i__ = j4save_(&c__1, nerr, &c_true);
xersve_(librar, subrou, messg, &c__1, nerr, level, &kount, librar_len,
subrou_len, messg_len);
/* HANDLE PRINT-ONCE WARNING MESSAGES. */
if (*level == -1 && kount > 1) {
return 0;
}
/* ALLOW TEMPORARY USER OVERRIDE OF THE CONTROL FLAG. */
s_copy(xlibr, librar, (ftnlen)8, librar_len);
s_copy(xsubr, subrou, (ftnlen)8, subrou_len);
s_copy(lfirst, messg, (ftnlen)20, messg_len);
lerr = *nerr;
llevel = *level;
xercnt_(xlibr, xsubr, lfirst, &lerr, &llevel, &lkntrl, (ftnlen)8, (ftnlen)
8, (ftnlen)20);
/* Computing MAX */
i__1 = -2, i__2 = min(2,lkntrl);
lkntrl = max(i__1,i__2);
mkntrl = abs(lkntrl);
/* SKIP PRINTING IF THE CONTROL FLAG VALUE AS RESET IN XERCNT IS */
/* ZERO AND THE ERROR IS NOT FATAL. */
if (*level < 2 && lkntrl == 0) {
goto L30;
}
if (*level == 0 && kount > maxmes) {
goto L30;
}
if (*level == 1 && kount > maxmes && mkntrl == 1) {
goto L30;
}
if (*level == 2 && kount > max(1,maxmes)) {
goto L30;
}
/* ANNOUNCE THE NAMES OF THE LIBRARY AND SUBROUTINE BY BUILDING A */
/* MESSAGE IN CHARACTER VARIABLE TEMP (NOT EXCEEDING 66 CHARACTERS) */
/* AND SENDING IT OUT VIA XERPRN. PRINT ONLY IF CONTROL FLAG */
/* IS NOT ZERO. */
if (lkntrl != 0) {
s_copy(temp, "MESSAGE FROM ROUTINE ", (ftnlen)21, (ftnlen)21);
/* Computing MIN */
i__1 = i_len(subrou, subrou_len);
i__ = min(i__1,16);
s_copy(temp + 21, subrou, i__, i__);
i__1 = i__ + 21;
s_copy(temp + i__1, " IN LIBRARY ", i__ + 33 - i__1, (ftnlen)12);
ltemp = i__ + 33;
/* Computing MIN */
i__1 = i_len(librar, librar_len);
i__ = min(i__1,16);
i__1 = ltemp;
s_copy(temp + i__1, librar, ltemp + i__ - i__1, i__);
i__1 = ltemp + i__;
s_copy(temp + i__1, ".", ltemp + i__ + 1 - i__1, (ftnlen)1);
ltemp = ltemp + i__ + 1;
xerprn_(" ***", &c_n1, temp, &c__72, (ftnlen)4, ltemp);
}
/* IF LKNTRL IS POSITIVE, PRINT AN INTRODUCTORY LINE BEFORE */
/* PRINTING THE MESSAGE. THE INTRODUCTORY LINE TELLS THE CHOICE */
/* FROM EACH OF THE FOLLOWING THREE OPTIONS. */
/* 1. LEVEL OF THE MESSAGE */
/* 'INFORMATIVE MESSAGE' */
/* 'POTENTIALLY RECOVERABLE ERROR' */
/* 'FATAL ERROR' */
/* 2. WHETHER CONTROL FLAG WILL ALLOW PROGRAM TO CONTINUE */
/* 'PROG CONTINUES' */
/* 'PROG ABORTED' */
/* 3. WHETHER OR NOT A TRACEBACK WAS REQUESTED. (THE TRACEBACK */
/* MAY NOT BE IMPLEMENTED AT SOME SITES, SO THIS ONLY TELLS */
/* WHAT WAS REQUESTED, NOT WHAT WAS DELIVERED.) */
/* 'TRACEBACK REQUESTED' */
/* 'TRACEBACK NOT REQUESTED' */
/* NOTICE THAT THE LINE INCLUDING FOUR PREFIX CHARACTERS WILL NOT */
/* EXCEED 74 CHARACTERS. */
/* WE SKIP THE NEXT BLOCK IF THE INTRODUCTORY LINE IS NOT NEEDED. */
if (lkntrl > 0) {
/* THE FIRST PART OF THE MESSAGE TELLS ABOUT THE LEVEL. */
if (*level <= 0) {
s_copy(temp, "INFORMATIVE MESSAGE,", (ftnlen)20, (ftnlen)20);
ltemp = 20;
} else if (*level == 1) {
s_copy(temp, "POTENTIALLY RECOVERABLE ERROR,", (ftnlen)30, (
ftnlen)30);
ltemp = 30;
} else {
s_copy(temp, "FATAL ERROR,", (ftnlen)12, (ftnlen)12);
ltemp = 12;
}
/* THEN WHETHER THE PROGRAM WILL CONTINUE. */
if ((mkntrl == 2 && *level >= 1) || (mkntrl == 1 && *level == 2)) {
i__1 = ltemp;
s_copy(temp + i__1, " PROG ABORTED,", ltemp + 14 - i__1, (ftnlen)
14);
ltemp += 14;
} else {
i__1 = ltemp;
s_copy(temp + i__1, " PROG CONTINUES,", ltemp + 16 - i__1, (
ftnlen)16);
ltemp += 16;
}
/* FINALLY TELL WHETHER THERE SHOULD BE A TRACEBACK. */
if (lkntrl > 0) {
i__1 = ltemp;
s_copy(temp + i__1, " TRACEBACK REQUESTED", ltemp + 20 - i__1, (
ftnlen)20);
ltemp += 20;
} else {
i__1 = ltemp;
s_copy(temp + i__1, " TRACEBACK NOT REQUESTED", ltemp + 24 - i__1,
(ftnlen)24);
ltemp += 24;
}
xerprn_(" ***", &c_n1, temp, &c__72, (ftnlen)4, ltemp);
}
/* NOW SEND OUT THE MESSAGE. */
xerprn_(" * ", &c_n1, messg, &c__72, (ftnlen)4, messg_len);
/* IF LKNTRL IS POSITIVE, WRITE THE ERROR NUMBER AND REQUEST A */
/* TRACEBACK. */
if (lkntrl > 0) {
ici__1.icierr = 0;
ici__1.icirnum = 1;
ici__1.icirlen = 72;
ici__1.iciunit = temp;
ici__1.icifmt = "('ERROR NUMBER = ', I8)";
s_wsfi(&ici__1);
do_fio(&c__1, (char *)&(*nerr), (ftnlen)sizeof(integer));
e_wsfi();
for (i__ = 16; i__ <= 22; ++i__) {
if (*(unsigned char *)&temp[i__ - 1] != ' ') {
goto L20;
}
/* L10: */
}
L20:
/* Writing concatenation */
i__3[0] = 15, a__1[0] = temp;
i__3[1] = 23 - (i__ - 1), a__1[1] = temp + (i__ - 1);
s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)87);
xerprn_(" * ", &c_n1, ch__1, &c__72, (ftnlen)4, 23 - (i__ - 1) + 15);
fdump_();
}
/* IF LKNTRL IS NOT ZERO, PRINT A BLANK LINE AND AN END OF MESSAGE. */
if (lkntrl != 0) {
xerprn_(" * ", &c_n1, " ", &c__72, (ftnlen)4, (ftnlen)1);
xerprn_(" ***", &c_n1, "END OF MESSAGE", &c__72, (ftnlen)4, (ftnlen)
14);
xerprn_(" ", &c__0, " ", &c__72, (ftnlen)4, (ftnlen)1);
}
/* IF THE ERROR IS NOT FATAL OR THE ERROR IS RECOVERABLE AND THE */
/* CONTROL FLAG IS SET FOR RECOVERY, THEN RETURN. */
L30:
if ((*level <= 0) || (*level == 1 && mkntrl <= 1)) {
return 0;
}
/* THE PROGRAM WILL BE STOPPED DUE TO AN UNRECOVERED ERROR OR A */
/* FATAL ERROR. PRINT THE REASON FOR THE ABORT AND THE ERROR */
/* SUMMARY IF THE CONTROL FLAG AND THE MAXIMUM ERROR COUNT PERMIT. */
if (lkntrl > 0 && kount < max(1,maxmes)) {
if (*level == 1) {
xerprn_(" ***", &c_n1, "JOB ABORT DUE TO UNRECOVERED ERROR.", &
c__72, (ftnlen)4, (ftnlen)35);
} else {
xerprn_(" ***", &c_n1, "JOB ABORT DUE TO FATAL ERROR.", &c__72, (
ftnlen)4, (ftnlen)29);
}
xersve_(" ", " ", " ", &c_n1, &c__0, &c__0, &kdummy, (ftnlen)1, (
ftnlen)1, (ftnlen)1);
xerhlt_(" ", (ftnlen)1);
} else {
xerhlt_(messg, messg_len);
}
return 0;
} /* xermsg_ */
/*< subroutine SVDRS (A, MDA, M1, N1, B, MDB, NB, S, WORK) >*/
/* Subroutine */ int svdrs_(doublereal *a, integer *mda, integer *m1, integer
*n1, doublereal *b, integer *mdb, integer *nb, doublereal *s,
doublereal *work)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, work_dim1, work_offset, i__1,
i__2, i__3, i__4;
cilist ci__1;
/* Builtin functions */
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
integer i__, j, k, l, m, n;
doublereal t;
extern /* Subroutine */ int h12_(integer *, integer *, integer *, integer
*, doublereal *, integer *, doublereal *, doublereal *, integer *,
integer *, integer *);
integer ns, np1, nsp1;
extern /* Subroutine */ int qrbd_(integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *);
integer ipass;
/*< integer I, IPASS, J, K, L, M, MDA, MDB, M1 >*/
/*< integer N, NB, N1, NP1, NS, NSP1 >*/
/* double precision A(MDA,N1),B(MDB,NB), S(N1) */
/*< double precision A(MDA, *),B(MDB, *), S( *) >*/
/*< double precision ONE, T, WORK(N1,2), ZERO >*/
/*< parameter(ONE = 1.0d0, ZERO = 0.0d0) >*/
/* -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* BEGIN.. SPECIAL FOR ZERO ROWS AND COLS. */
/* PACK THE NONZERO COLS TO THE LEFT */
/*< N=N1 >*/
#line 131 "svdrs.f"
/* Parameter adjustments */
#line 131 "svdrs.f"
a_dim1 = *mda;
#line 131 "svdrs.f"
a_offset = 1 + a_dim1;
#line 131 "svdrs.f"
a -= a_offset;
#line 131 "svdrs.f"
work_dim1 = *n1;
#line 131 "svdrs.f"
work_offset = 1 + work_dim1;
#line 131 "svdrs.f"
work -= work_offset;
#line 131 "svdrs.f"
b_dim1 = *mdb;
#line 131 "svdrs.f"
b_offset = 1 + b_dim1;
#line 131 "svdrs.f"
b -= b_offset;
#line 131 "svdrs.f"
--s;
#line 131 "svdrs.f"
#line 131 "svdrs.f"
/* Function Body */
#line 131 "svdrs.f"
n = *n1;
/*< IF (N.LE.0.OR.M1.LE.0) RETURN >*/
#line 132 "svdrs.f"
if (n <= 0 || *m1 <= 0) {
#line 132 "svdrs.f"
return 0;
#line 132 "svdrs.f"
}
/*< J=N >*/
#line 133 "svdrs.f"
j = n;
/*< 10 CONTINUE >*/
#line 134 "svdrs.f"
L10:
/*< DO 20 I=1,M1 >*/
#line 135 "svdrs.f"
i__1 = *m1;
#line 135 "svdrs.f"
for (i__ = 1; i__ <= i__1; ++i__) {
/*< IF (A(I,J) .ne. ZERO) go to 50 >*/
#line 136 "svdrs.f"
if (a[i__ + j * a_dim1] != 0.) {
#line 136 "svdrs.f"
goto L50;
#line 136 "svdrs.f"
}
/*< 20 CONTINUE >*/
#line 137 "svdrs.f"
/* L20: */
#line 137 "svdrs.f"
}
/* COL J IS ZERO. EXCHANGE IT WITH COL N. */
/*< IF (J .ne. N) then >*/
#line 141 "svdrs.f"
if (j != n) {
/*< DO 30 I=1,M1 >*/
#line 142 "svdrs.f"
i__1 = *m1;
#line 142 "svdrs.f"
for (i__ = 1; i__ <= i__1; ++i__) {
/*< 30 A(I,J)=A(I,N) >*/
#line 143 "svdrs.f"
/* L30: */
#line 143 "svdrs.f"
a[i__ + j * a_dim1] = a[i__ + n * a_dim1];
#line 143 "svdrs.f"
}
/*< endif >*/
#line 144 "svdrs.f"
}
/*< A(1,N)=J >*/
#line 145 "svdrs.f"
a[n * a_dim1 + 1] = (doublereal) j;
/*< N=N-1 >*/
#line 146 "svdrs.f"
--n;
/*< 50 CONTINUE >*/
#line 147 "svdrs.f"
L50:
/*< J=J-1 >*/
#line 148 "svdrs.f"
--j;
/*< IF (J.GE.1) GO TO 10 >*/
#line 149 "svdrs.f"
if (j >= 1) {
#line 149 "svdrs.f"
goto L10;
#line 149 "svdrs.f"
}
/* IF N=0 THEN A IS ENTIRELY ZERO AND SVD */
/* COMPUTATION CAN BE SKIPPED */
/*< NS=0 >*/
#line 152 "svdrs.f"
ns = 0;
/*< IF (N.EQ.0) GO TO 240 >*/
#line 153 "svdrs.f"
if (n == 0) {
#line 153 "svdrs.f"
goto L240;
#line 153 "svdrs.f"
}
/* PACK NONZERO ROWS TO THE TOP */
/* QUIT PACKING IF FIND N NONZERO ROWS */
/*< I=1 >*/
#line 156 "svdrs.f"
i__ = 1;
/*< M=M1 >*/
#line 157 "svdrs.f"
m = *m1;
/*< 60 IF (I.GT.N.OR.I.GE.M) GO TO 150 >*/
#line 158 "svdrs.f"
L60:
#line 158 "svdrs.f"
if (i__ > n || i__ >= m) {
#line 158 "svdrs.f"
goto L150;
#line 158 "svdrs.f"
}
/*< IF (A(I,I)) 90,70,90 >*/
#line 159 "svdrs.f"
if (a[i__ + i__ * a_dim1] != 0.) {
#line 159 "svdrs.f"
goto L90;
#line 159 "svdrs.f"
} else {
#line 159 "svdrs.f"
goto L70;
#line 159 "svdrs.f"
}
/*< 70 DO 80 J=1,N >*/
#line 160 "svdrs.f"
L70:
#line 160 "svdrs.f"
i__1 = n;
#line 160 "svdrs.f"
for (j = 1; j <= i__1; ++j) {
/*< IF (A(I,J)) 90,80,90 >*/
#line 161 "svdrs.f"
if (a[i__ + j * a_dim1] != 0.) {
#line 161 "svdrs.f"
goto L90;
#line 161 "svdrs.f"
} else {
#line 161 "svdrs.f"
goto L80;
#line 161 "svdrs.f"
}
/*< 80 CONTINUE >*/
#line 162 "svdrs.f"
L80:
#line 162 "svdrs.f"
;
#line 162 "svdrs.f"
}
/*< GO TO 100 >*/
#line 163 "svdrs.f"
goto L100;
/*< 90 I=I+1 >*/
#line 164 "svdrs.f"
L90:
#line 164 "svdrs.f"
++i__;
/*< GO TO 60 >*/
#line 165 "svdrs.f"
goto L60;
/* ROW I IS ZERO */
/* EXCHANGE ROWS I AND M */
/*< 100 IF(NB.LE.0) GO TO 115 >*/
#line 168 "svdrs.f"
L100:
#line 168 "svdrs.f"
if (*nb <= 0) {
#line 168 "svdrs.f"
goto L115;
#line 168 "svdrs.f"
}
/*< DO 110 J=1,NB >*/
#line 169 "svdrs.f"
i__1 = *nb;
#line 169 "svdrs.f"
for (j = 1; j <= i__1; ++j) {
/*< T=B(I,J) >*/
#line 170 "svdrs.f"
t = b[i__ + j * b_dim1];
/*< B(I,J)=B(M,J) >*/
#line 171 "svdrs.f"
b[i__ + j * b_dim1] = b[m + j * b_dim1];
/*< 110 B(M,J)=T >*/
#line 172 "svdrs.f"
/* L110: */
#line 172 "svdrs.f"
b[m + j * b_dim1] = t;
#line 172 "svdrs.f"
}
/*< 115 DO 120 J=1,N >*/
#line 173 "svdrs.f"
L115:
#line 173 "svdrs.f"
i__1 = n;
#line 173 "svdrs.f"
for (j = 1; j <= i__1; ++j) {
/*< 120 A(I,J)=A(M,J) >*/
#line 174 "svdrs.f"
/* L120: */
#line 174 "svdrs.f"
a[i__ + j * a_dim1] = a[m + j * a_dim1];
#line 174 "svdrs.f"
}
/*< IF (M.GT.N) GO TO 140 >*/
#line 175 "svdrs.f"
if (m > n) {
#line 175 "svdrs.f"
goto L140;
#line 175 "svdrs.f"
}
/*< DO 130 J=1,N >*/
#line 176 "svdrs.f"
i__1 = n;
#line 176 "svdrs.f"
for (j = 1; j <= i__1; ++j) {
/*< 130 A(M,J)=ZERO >*/
#line 177 "svdrs.f"
/* L130: */
#line 177 "svdrs.f"
a[m + j * a_dim1] = 0.;
#line 177 "svdrs.f"
}
/*< 140 CONTINUE >*/
#line 178 "svdrs.f"
L140:
/* EXCHANGE IS FINISHED */
/*< M=M-1 >*/
#line 180 "svdrs.f"
--m;
/*< GO TO 60 >*/
#line 181 "svdrs.f"
goto L60;
/*< 150 CONTINUE >*/
#line 183 "svdrs.f"
L150:
/* END.. SPECIAL FOR ZERO ROWS AND COLUMNS */
/* BEGIN.. SVD ALGORITHM */
/* METHOD.. */
/* (1) REDUCE THE MATRIX TO UPPER BIDIAGONAL FORM WITH */
/* HOUSEHOLDER TRANSFORMATIONS. */
/* H(N)...H(1)AQ(1)...Q(N-2) = (D**T,0)**T */
/* WHERE D IS UPPER BIDIAGONAL. */
/* (2) APPLY H(N)...H(1) TO B. HERE H(N)...H(1)*B REPLACES B */
/* IN STORAGE. */
/* (3) THE MATRIX PRODUCT W= Q(1)...Q(N-2) OVERWRITES THE FIRST */
/* N ROWS OF A IN STORAGE. */
/* (4) AN SVD FOR D IS COMPUTED. HERE K ROTATIONS RI AND PI ARE */
/* COMPUTED SO THAT */
/* RK...R1*D*P1**(T)...PK**(T) = DIAG(S1,...,SM) */
/* TO WORKING ACCURACY. THE SI ARE NONNEGATIVE AND NONINCREASING. */
/* HERE RK...R1*B OVERWRITES B IN STORAGE WHILE */
/* A*P1**(T)...PK**(T) OVERWRITES A IN STORAGE. */
/* (5) IT FOLLOWS THAT,WITH THE PROPER DEFINITIONS, */
/* U**(T)*B OVERWRITES B, WHILE V OVERWRITES THE FIRST N ROW AND */
/* COLUMNS OF A. */
/*< L=min(M,N) >*/
#line 209 "svdrs.f"
l = min(m,n);
/* THE FOLLOWING LOOP REDUCES A TO UPPER BIDIAGONAL AND */
/* ALSO APPLIES THE PREMULTIPLYING TRANSFORMATIONS TO B. */
/*< DO 170 J=1,L >*/
#line 213 "svdrs.f"
i__1 = l;
#line 213 "svdrs.f"
for (j = 1; j <= i__1; ++j) {
/*< IF (J.GE.M) GO TO 160 >*/
#line 214 "svdrs.f"
if (j >= m) {
#line 214 "svdrs.f"
goto L160;
#line 214 "svdrs.f"
}
/*< CALL H12 (1,J,J+1,M,A(1,J),1,T,A(1,J+1),1,MDA,N-J) >*/
#line 215 "svdrs.f"
i__2 = j + 1;
#line 215 "svdrs.f"
i__3 = n - j;
#line 215 "svdrs.f"
h12_(&c__1, &j, &i__2, &m, &a[j * a_dim1 + 1], &c__1, &t, &a[(j + 1) *
a_dim1 + 1], &c__1, mda, &i__3);
/*< CALL H12 (2,J,J+1,M,A(1,J),1,T,B,1,MDB,NB) >*/
#line 216 "svdrs.f"
i__2 = j + 1;
#line 216 "svdrs.f"
h12_(&c__2, &j, &i__2, &m, &a[j * a_dim1 + 1], &c__1, &t, &b[b_offset]
, &c__1, mdb, nb);
/*< 160 IF (J.GE.N-1) GO TO 170 >*/
#line 217 "svdrs.f"
L160:
#line 217 "svdrs.f"
if (j >= n - 1) {
#line 217 "svdrs.f"
goto L170;
#line 217 "svdrs.f"
}
/*< CALL H12 (1,J+1,J+2,N,A(J,1),MDA,work(J,2),A(J+1,1),MDA,1,M-J) >*/
#line 218 "svdrs.f"
i__2 = j + 1;
#line 218 "svdrs.f"
i__3 = j + 2;
#line 218 "svdrs.f"
i__4 = m - j;
#line 218 "svdrs.f"
h12_(&c__1, &i__2, &i__3, &n, &a[j + a_dim1], mda, &work[j + (
work_dim1 << 1)], &a[j + 1 + a_dim1], mda, &c__1, &i__4);
/*< 170 CONTINUE >*/
#line 219 "svdrs.f"
L170:
#line 219 "svdrs.f"
;
#line 219 "svdrs.f"
}
/* COPY THE BIDIAGONAL MATRIX INTO S() and WORK() FOR QRBD. */
/* 1986 Jan 8. C. L. Lawson. Changed N to L in following 2 statements. */
/*< IF (L.EQ.1) GO TO 190 >*/
#line 223 "svdrs.f"
if (l == 1) {
#line 223 "svdrs.f"
goto L190;
#line 223 "svdrs.f"
}
/*< DO 180 J=2,L >*/
#line 224 "svdrs.f"
i__1 = l;
#line 224 "svdrs.f"
for (j = 2; j <= i__1; ++j) {
/*< S(J)=A(J,J) >*/
#line 225 "svdrs.f"
s[j] = a[j + j * a_dim1];
/*< 180 WORK(J,1)=A(J-1,J) >*/
#line 226 "svdrs.f"
/* L180: */
#line 226 "svdrs.f"
work[j + work_dim1] = a[j - 1 + j * a_dim1];
#line 226 "svdrs.f"
}
/*< 190 S(1)=A(1,1) >*/
#line 227 "svdrs.f"
L190:
#line 227 "svdrs.f"
s[1] = a[a_dim1 + 1];
/*< NS=N >*/
#line 229 "svdrs.f"
ns = n;
/*< IF (M.GE.N) GO TO 200 >*/
#line 230 "svdrs.f"
if (m >= n) {
#line 230 "svdrs.f"
goto L200;
#line 230 "svdrs.f"
}
/*< NS=M+1 >*/
#line 231 "svdrs.f"
ns = m + 1;
/*< S(NS)=ZERO >*/
#line 232 "svdrs.f"
s[ns] = 0.;
/*< WORK(NS,1)=A(M,M+1) >*/
#line 233 "svdrs.f"
work[ns + work_dim1] = a[m + (m + 1) * a_dim1];
/*< 200 CONTINUE >*/
#line 234 "svdrs.f"
L200:
/* CONSTRUCT THE EXPLICIT N BY N PRODUCT MATRIX, W=Q1*Q2*...*QL*I */
/* IN THE ARRAY A(). */
/*< DO 230 K=1,N >*/
#line 239 "svdrs.f"
i__1 = n;
#line 239 "svdrs.f"
for (k = 1; k <= i__1; ++k) {
/*< I=N+1-K >*/
#line 240 "svdrs.f"
i__ = n + 1 - k;
/*< IF (I .GT. min(M,N-2)) GO TO 210 >*/
/* Computing MIN */
#line 241 "svdrs.f"
i__2 = m, i__3 = n - 2;
#line 241 "svdrs.f"
if (i__ > min(i__2,i__3)) {
#line 241 "svdrs.f"
goto L210;
#line 241 "svdrs.f"
}
/*< CALL H12 (2,I+1,I+2,N,A(I,1),MDA,WORK(I,2),A(1,I+1),1,MDA,N-I) >*/
#line 242 "svdrs.f"
i__2 = i__ + 1;
#line 242 "svdrs.f"
i__3 = i__ + 2;
#line 242 "svdrs.f"
i__4 = n - i__;
#line 242 "svdrs.f"
h12_(&c__2, &i__2, &i__3, &n, &a[i__ + a_dim1], mda, &work[i__ + (
work_dim1 << 1)], &a[(i__ + 1) * a_dim1 + 1], &c__1, mda, &
i__4);
/*< 210 DO 220 J=1,N >*/
#line 243 "svdrs.f"
L210:
#line 243 "svdrs.f"
i__2 = n;
#line 243 "svdrs.f"
for (j = 1; j <= i__2; ++j) {
/*< 220 A(I,J)=ZERO >*/
#line 244 "svdrs.f"
/* L220: */
#line 244 "svdrs.f"
a[i__ + j * a_dim1] = 0.;
#line 244 "svdrs.f"
}
/*< 230 A(I,I)=ONE >*/
#line 245 "svdrs.f"
/* L230: */
#line 245 "svdrs.f"
a[i__ + i__ * a_dim1] = 1.;
#line 245 "svdrs.f"
}
/* COMPUTE THE SVD OF THE BIDIAGONAL MATRIX */
/*< CALL QRBD (IPASS,S(1),WORK(1,1),NS,A,MDA,N,B,MDB,NB) >*/
#line 249 "svdrs.f"
qrbd_(&ipass, &s[1], &work[work_dim1 + 1], &ns, &a[a_offset], mda, &n, &b[
b_offset], mdb, nb);
/*< if(IPASS .eq. 2) then >*/
#line 251 "svdrs.f"
if (ipass == 2) {
/*< >*/
#line 252 "svdrs.f"
ci__1.cierr = 0;
#line 252 "svdrs.f"
ci__1.ciunit = 6;
#line 252 "svdrs.f"
ci__1.cifmt = "(/a)";
#line 252 "svdrs.f"
s_wsfe(&ci__1);
#line 252 "svdrs.f"
do_fio(&c__1, " FULL ACCURACY NOT ATTAINED IN BIDIAGONAL SVD", (
ftnlen)45);
#line 252 "svdrs.f"
e_wsfe();
/*< endif >*/
#line 254 "svdrs.f"
}
/*< 240 CONTINUE >*/
#line 256 "svdrs.f"
L240:
/*< IF (NS.GE.N) GO TO 260 >*/
#line 257 "svdrs.f"
if (ns >= n) {
#line 257 "svdrs.f"
goto L260;
#line 257 "svdrs.f"
}
/*< NSP1=NS+1 >*/
#line 258 "svdrs.f"
nsp1 = ns + 1;
/*< DO 250 J=NSP1,N >*/
#line 259 "svdrs.f"
i__1 = n;
#line 259 "svdrs.f"
for (j = nsp1; j <= i__1; ++j) {
/*< 250 S(J)=ZERO >*/
#line 260 "svdrs.f"
/* L250: */
#line 260 "svdrs.f"
s[j] = 0.;
#line 260 "svdrs.f"
}
/*< 260 CONTINUE >*/
#line 261 "svdrs.f"
L260:
/*< IF (N.EQ.N1) RETURN >*/
#line 262 "svdrs.f"
if (n == *n1) {
#line 262 "svdrs.f"
return 0;
#line 262 "svdrs.f"
}
/*< NP1=N+1 >*/
#line 263 "svdrs.f"
np1 = n + 1;
/* MOVE RECORD OF PERMUTATIONS */
/* AND STORE ZEROS */
/*< DO 280 J=NP1,N1 >*/
#line 266 "svdrs.f"
i__1 = *n1;
#line 266 "svdrs.f"
for (j = np1; j <= i__1; ++j) {
/*< S(J)=A(1,J) >*/
#line 267 "svdrs.f"
s[j] = a[j * a_dim1 + 1];
/*< DO 270 I=1,N >*/
#line 268 "svdrs.f"
i__2 = n;
#line 268 "svdrs.f"
for (i__ = 1; i__ <= i__2; ++i__) {
/*< 270 A(I,J)=ZERO >*/
#line 269 "svdrs.f"
/* L270: */
#line 269 "svdrs.f"
a[i__ + j * a_dim1] = 0.;
#line 269 "svdrs.f"
}
/*< 280 CONTINUE >*/
#line 270 "svdrs.f"
/* L280: */
#line 270 "svdrs.f"
}
/* PERMUTE ROWS AND SET ZERO SINGULAR VALUES. */
/*< DO 300 K=NP1,N1 >*/
#line 272 "svdrs.f"
i__1 = *n1;
#line 272 "svdrs.f"
for (k = np1; k <= i__1; ++k) {
/*< I=S(K) >*/
#line 273 "svdrs.f"
i__ = (integer) s[k];
/*< S(K)=ZERO >*/
#line 274 "svdrs.f"
s[k] = 0.;
/*< DO 290 J=1,N1 >*/
#line 275 "svdrs.f"
i__2 = *n1;
#line 275 "svdrs.f"
for (j = 1; j <= i__2; ++j) {
/*< A(K,J)=A(I,J) >*/
#line 276 "svdrs.f"
a[k + j * a_dim1] = a[i__ + j * a_dim1];
/*< 290 A(I,J)=ZERO >*/
#line 277 "svdrs.f"
/* L290: */
#line 277 "svdrs.f"
a[i__ + j * a_dim1] = 0.;
#line 277 "svdrs.f"
}
/*< A(I,K)=ONE >*/
#line 278 "svdrs.f"
a[i__ + k * a_dim1] = 1.;
/*< 300 CONTINUE >*/
#line 279 "svdrs.f"
/* L300: */
#line 279 "svdrs.f"
}
/* END.. SPECIAL FOR ZERO ROWS AND COLUMNS */
/*< RETURN >*/
#line 281 "svdrs.f"
return 0;
/*< END >*/
} /* svdrs_ */
/* Main program */ int MAIN__(void)
{
/* Format strings */
static char fmt_9999[] = "(\002 Time for 1,000,000 DAXPY ops = \002,g10"
".3,\002 seconds\002)";
static char fmt_9998[] = "(\002 DAXPY performance rate = \002,g10"
".3,\002 mflops \002)";
static char fmt_9994[] = "(\002 *** Error: Time for operations was zer"
"o\002)";
static char fmt_9997[] = "(\002 Including DSECND, time = \002,g10"
".3,\002 seconds\002)";
static char fmt_9996[] = "(\002 Average time for DSECND = \002,g10"
".3,\002 milliseconds\002)";
static char fmt_9995[] = "(\002 Equivalent floating point ops = \002,g10"
".3,\002 ops\002)";
/* System generated locals */
doublereal d__1;
/* Builtin functions */
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
integer i__, j;
doublereal x[100], y[100], t1, t2, avg, alpha;
extern /* Subroutine */ int mysub_(integer *, doublereal *, doublereal *);
extern doublereal dsecnd_(void);
doublereal tnosec;
/* Fortran I/O blocks */
static cilist io___8 = { 0, 6, 0, fmt_9999, 0 };
static cilist io___9 = { 0, 6, 0, fmt_9998, 0 };
static cilist io___10 = { 0, 6, 0, fmt_9994, 0 };
static cilist io___12 = { 0, 6, 0, fmt_9997, 0 };
static cilist io___14 = { 0, 6, 0, fmt_9996, 0 };
static cilist io___15 = { 0, 6, 0, fmt_9995, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Initialize X and Y */
for (i__ = 1; i__ <= 100; ++i__) {
x[i__ - 1] = 1. / (doublereal) i__;
y[i__ - 1] = (doublereal) (100 - i__) / 100.;
/* L10: */
}
alpha = .315;
/* Time 1,000,000 DAXPY operations */
t1 = dsecnd_();
for (j = 1; j <= 5000; ++j) {
for (i__ = 1; i__ <= 100; ++i__) {
y[i__ - 1] += alpha * x[i__ - 1];
/* L20: */
}
alpha = -alpha;
/* L30: */
}
t2 = dsecnd_();
s_wsfe(&io___8);
d__1 = t2 - t1;
do_fio(&c__1, (char *)&d__1, (ftnlen)sizeof(doublereal));
e_wsfe();
if (t2 - t1 > 0.) {
s_wsfe(&io___9);
d__1 = 1. / (t2 - t1);
do_fio(&c__1, (char *)&d__1, (ftnlen)sizeof(doublereal));
e_wsfe();
} else {
s_wsfe(&io___10);
e_wsfe();
}
tnosec = t2 - t1;
/* Time 1,000,000 DAXPY operations with DSECND in the outer loop */
t1 = dsecnd_();
for (j = 1; j <= 5000; ++j) {
for (i__ = 1; i__ <= 100; ++i__) {
y[i__ - 1] += alpha * x[i__ - 1];
/* L40: */
}
alpha = -alpha;
t2 = dsecnd_();
/* L50: */
}
/* Compute the time in milliseconds used by an average call */
/* to DSECND. */
s_wsfe(&io___12);
d__1 = t2 - t1;
do_fio(&c__1, (char *)&d__1, (ftnlen)sizeof(doublereal));
e_wsfe();
avg = (t2 - t1 - tnosec) * 1e3 / 5e3;
s_wsfe(&io___14);
do_fio(&c__1, (char *)&avg, (ftnlen)sizeof(doublereal));
e_wsfe();
/* Compute the equivalent number of floating point operations used */
/* by an average call to DSECND. */
if (tnosec > 0.) {
s_wsfe(&io___15);
d__1 = avg * 1e3 / tnosec;
do_fio(&c__1, (char *)&d__1, (ftnlen)sizeof(doublereal));
e_wsfe();
}
mysub_(&c__100, x, y);
return 0;
} /* MAIN__ */
/* DECK DP1VLU */
/* Subroutine */ int dp1vlu_(integer *l, integer *nder, doublereal *x,
doublereal *yfit, doublereal *yp, doublereal *a)
{
/* System generated locals */
address a__1[5];
integer i__1, i__2, i__3[5];
char ch__1[150];
icilist ici__1;
/* Builtin functions */
integer s_wsfi(icilist *), do_fio(integer *, char *, ftnlen), e_wsfi(void)
;
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
/* Local variables */
integer i__, n, k1, k2, k3, k4;
doublereal cc;
integer ic, kc, in, k1i, lm1, lp1;
doublereal dif;
integer k3p1, k4p1, ndo;
doublereal val;
integer ilo, iup, ndp1, inp1, k3pn, k4pn, nord;
char xern1[8], xern2[8];
integer maxord;
extern /* Subroutine */ int xermsg_(char *, char *, char *, integer *,
integer *, ftnlen, ftnlen, ftnlen);
/* ***BEGIN PROLOGUE DP1VLU */
/* ***PURPOSE Use the coefficients generated by DPOLFT to evaluate the */
/* polynomial fit of degree L, along with the first NDER of */
/* its derivatives, at a specified point. */
/* ***LIBRARY SLATEC */
/* ***CATEGORY K6 */
/* ***TYPE DOUBLE PRECISION (PVALUE-S, DP1VLU-D) */
/* ***KEYWORDS CURVE FITTING, LEAST SQUARES, POLYNOMIAL APPROXIMATION */
/* ***AUTHOR Shampine, L. F., (SNLA) */
/* Davenport, S. M., (SNLA) */
/* ***DESCRIPTION */
/* Abstract */
/* The subroutine DP1VLU uses the coefficients generated by DPOLFT */
/* to evaluate the polynomial fit of degree L , along with the first */
/* NDER of its derivatives, at a specified point. Computationally */
/* stable recurrence relations are used to perform this task. */
/* The parameters for DP1VLU are */
/* Input -- ALL TYPE REAL variables are DOUBLE PRECISION */
/* L - the degree of polynomial to be evaluated. L may be */
/* any non-negative integer which is less than or equal */
/* to NDEG , the highest degree polynomial provided */
/* by DPOLFT . */
/* NDER - the number of derivatives to be evaluated. NDER */
/* may be 0 or any positive value. If NDER is less */
/* than 0, it will be treated as 0. */
/* X - the argument at which the polynomial and its */
/* derivatives are to be evaluated. */
/* A - work and output array containing values from last */
/* call to DPOLFT . */
/* Output -- ALL TYPE REAL variables are DOUBLE PRECISION */
/* YFIT - value of the fitting polynomial of degree L at X */
/* YP - array containing the first through NDER derivatives */
/* of the polynomial of degree L . YP must be */
/* dimensioned at least NDER in the calling program. */
/* ***REFERENCES L. F. Shampine, S. M. Davenport and R. E. Huddleston, */
/* Curve fitting by polynomials in one variable, Report */
/* SLA-74-0270, Sandia Laboratories, June 1974. */
/* ***ROUTINES CALLED XERMSG */
/* ***REVISION HISTORY (YYMMDD) */
/* 740601 DATE WRITTEN */
/* 890531 Changed all specific intrinsics to generic. (WRB) */
/* 890911 Removed unnecessary intrinsics. (WRB) */
/* 891006 Cosmetic changes to prologue. (WRB) */
/* 891006 REVISION DATE from Version 3.2 */
/* 891214 Prologue converted to Version 4.0 format. (BAB) */
/* 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) */
/* 900510 Convert XERRWV calls to XERMSG calls. (RWC) */
/* 920501 Reformatted the REFERENCES section. (WRB) */
/* ***END PROLOGUE DP1VLU */
/* ***FIRST EXECUTABLE STATEMENT DP1VLU */
/* Parameter adjustments */
--a;
--yp;
/* Function Body */
if (*l < 0) {
goto L12;
}
ndo = max(*nder,0);
ndo = min(ndo,*l);
maxord = (integer) (a[1] + .5);
k1 = maxord + 1;
k2 = k1 + maxord;
k3 = k2 + maxord + 2;
nord = (integer) (a[k3] + .5);
if (*l > nord) {
goto L11;
}
k4 = k3 + *l + 1;
if (*nder < 1) {
goto L2;
}
i__1 = *nder;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L1: */
yp[i__] = 0.;
}
L2:
if (*l >= 2) {
goto L4;
}
if (*l == 1) {
goto L3;
}
/* L IS 0 */
val = a[k2 + 1];
goto L10;
/* L IS 1 */
L3:
cc = a[k2 + 2];
val = a[k2 + 1] + (*x - a[2]) * cc;
if (*nder >= 1) {
yp[1] = cc;
}
goto L10;
/* L IS GREATER THAN 1 */
L4:
ndp1 = ndo + 1;
k3p1 = k3 + 1;
k4p1 = k4 + 1;
lp1 = *l + 1;
lm1 = *l - 1;
ilo = k3 + 3;
iup = k4 + ndp1;
i__1 = iup;
for (i__ = ilo; i__ <= i__1; ++i__) {
/* L5: */
a[i__] = 0.;
}
dif = *x - a[lp1];
kc = k2 + lp1;
a[k4p1] = a[kc];
a[k3p1] = a[kc - 1] + dif * a[k4p1];
a[k3 + 2] = a[k4p1];
/* EVALUATE RECURRENCE RELATIONS FOR FUNCTION VALUE AND DERIVATIVES */
i__1 = lm1;
for (i__ = 1; i__ <= i__1; ++i__) {
in = *l - i__;
inp1 = in + 1;
k1i = k1 + inp1;
ic = k2 + in;
dif = *x - a[inp1];
val = a[ic] + dif * a[k3p1] - a[k1i] * a[k4p1];
if (ndo <= 0) {
goto L8;
}
i__2 = ndo;
for (n = 1; n <= i__2; ++n) {
k3pn = k3p1 + n;
k4pn = k4p1 + n;
/* L6: */
yp[n] = dif * a[k3pn] + n * a[k3pn - 1] - a[k1i] * a[k4pn];
}
/* SAVE VALUES NEEDED FOR NEXT EVALUATION OF RECURRENCE RELATIONS */
i__2 = ndo;
for (n = 1; n <= i__2; ++n) {
k3pn = k3p1 + n;
k4pn = k4p1 + n;
a[k4pn] = a[k3pn];
/* L7: */
a[k3pn] = yp[n];
}
L8:
a[k4p1] = a[k3p1];
/* L9: */
a[k3p1] = val;
}
/* NORMAL RETURN OR ABORT DUE TO ERROR */
L10:
*yfit = val;
return 0;
L11:
ici__1.icierr = 0;
ici__1.icirnum = 1;
ici__1.icirlen = 8;
ici__1.iciunit = xern1;
ici__1.icifmt = "(I8)";
s_wsfi(&ici__1);
do_fio(&c__1, (char *)&(*l), (ftnlen)sizeof(integer));
e_wsfi();
ici__1.icierr = 0;
ici__1.icirnum = 1;
ici__1.icirlen = 8;
ici__1.iciunit = xern2;
ici__1.icifmt = "(I8)";
s_wsfi(&ici__1);
do_fio(&c__1, (char *)&nord, (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__3[0] = 40, a__1[0] = "THE ORDER OF POLYNOMIAL EVALUATION, L = ";
i__3[1] = 8, a__1[1] = xern1;
i__3[2] = 49, a__1[2] = " REQUESTED EXCEEDS THE HIGHEST ORDER FIT, NORD "
"= ";
i__3[3] = 8, a__1[3] = xern2;
i__3[4] = 45, a__1[4] = ", COMPUTED BY DPOLFT -- EXECUTION TERMINATED.";
s_cat(ch__1, a__1, i__3, &c__5, (ftnlen)150);
xermsg_("SLATEC", "DP1VLU", ch__1, &c__8, &c__2, (ftnlen)6, (ftnlen)6, (
ftnlen)150);
return 0;
L12:
xermsg_("SLATEC", "DP1VLU", "INVALID INPUT PARAMETER. ORDER OF POLYNOMI"
"AL EVALUATION REQUESTED IS NEGATIVE.", &c__2, &c__2, (ftnlen)6, (
ftnlen)6, (ftnlen)79);
return 0;
} /* dp1vlu_ */
/* Subroutine */ int dchkqr_(logical *dotype, integer *nm, integer *mval,
integer *nn, integer *nval, integer *nnb, integer *nbval, integer *
nxval, integer *nrhs, doublereal *thresh, logical *tsterr, integer *
nmax, doublereal *a, doublereal *af, doublereal *aq, doublereal *ar,
doublereal *ac, doublereal *b, doublereal *x, doublereal *xact,
doublereal *tau, doublereal *work, doublereal *rwork, integer *iwork,
integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
/* Format strings */
static char fmt_9999[] = "(\002 M=\002,i5,\002, N=\002,i5,\002, K=\002,i"
"5,\002, NB=\002,i4,\002, NX=\002,i5,\002, type \002,i2,\002, tes"
"t(\002,i2,\002)=\002,g12.5)";
/* System generated locals */
integer i__1, i__2, i__3, i__4, i__5;
/* Local variables */
integer i__, k, m, n, nb, ik, im, in, kl, nk, ku, nt, nx, lda, inb, mode,
imat, info;
char path[3];
integer kval[4];
char dist[1], type__[1];
integer nrun;
integer nfail, iseed[4];
doublereal anorm;
integer minmn;
integer nerrs, lwork;
doublereal cndnum;
doublereal result[8];
/* Fortran I/O blocks */
static cilist io___33 = { 0, 0, 0, fmt_9999, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DCHKQR tests DGEQRF, DORGQR and DORMQR. */
/* Arguments */
/* ========= */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* The matrix types to be used for testing. Matrices of type j */
/* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = */
/* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. */
/* NM (input) INTEGER */
/* The number of values of M contained in the vector MVAL. */
/* MVAL (input) INTEGER array, dimension (NM) */
/* The values of the matrix row dimension M. */
/* NN (input) INTEGER */
/* The number of values of N contained in the vector NVAL. */
/* NVAL (input) INTEGER array, dimension (NN) */
/* The values of the matrix column dimension N. */
/* NNB (input) INTEGER */
/* The number of values of NB and NX contained in the */
/* vectors NBVAL and NXVAL. The blocking parameters are used */
/* in pairs (NB,NX). */
/* NBVAL (input) INTEGER array, dimension (NNB) */
/* The values of the blocksize NB. */
/* NXVAL (input) INTEGER array, dimension (NNB) */
/* The values of the crossover point NX. */
/* NRHS (input) INTEGER */
/* The number of right hand side vectors to be generated for */
/* each linear system. */
/* THRESH (input) DOUBLE PRECISION */
/* The threshold value for the test ratios. A result is */
/* included in the output file if RESULT >= THRESH. To have */
/* every test ratio printed, use THRESH = 0. */
/* TSTERR (input) LOGICAL */
/* Flag that indicates whether error exits are to be tested. */
/* NMAX (input) INTEGER */
/* The maximum value permitted for M or N, used in dimensioning */
/* the work arrays. */
/* A (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
/* AF (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
/* AQ (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
/* AR (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
/* AC (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
/* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
/* X (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
/* XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
/* TAU (workspace) DOUBLE PRECISION array, dimension (NMAX) */
/* WORK (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (NMAX) */
/* IWORK (workspace) INTEGER array, dimension (NMAX) */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--iwork;
--rwork;
--work;
--tau;
--xact;
--x;
--b;
--ac;
--ar;
--aq;
--af;
--a;
--nxval;
--nbval;
--nval;
--mval;
--dotype;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* Initialize constants and the random number seed. */
s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
s_copy(path + 1, "QR", (ftnlen)2, (ftnlen)2);
nrun = 0;
nfail = 0;
nerrs = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
}
/* Test the error exits */
if (*tsterr) {
derrqr_(path, nout);
}
infoc_1.infot = 0;
xlaenv_(&c__2, &c__2);
lda = *nmax;
lwork = *nmax * max(*nmax,*nrhs);
/* Do for each value of M in MVAL. */
i__1 = *nm;
for (im = 1; im <= i__1; ++im) {
m = mval[im];
/* Do for each value of N in NVAL. */
i__2 = *nn;
for (in = 1; in <= i__2; ++in) {
n = nval[in];
minmn = min(m,n);
for (imat = 1; imat <= 8; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (! dotype[imat]) {
goto L50;
}
/* Set up parameters with DLATB4 and generate a test matrix */
/* with DLATMS. */
dlatb4_(path, &imat, &m, &n, type__, &kl, &ku, &anorm, &mode,
&cndnum, dist);
s_copy(srnamc_1.srnamt, "DLATMS", (ftnlen)32, (ftnlen)6);
dlatms_(&m, &n, dist, iseed, type__, &rwork[1], &mode, &
cndnum, &anorm, &kl, &ku, "No packing", &a[1], &lda, &
work[1], &info);
/* Check error code from DLATMS. */
if (info != 0) {
alaerh_(path, "DLATMS", &info, &c__0, " ", &m, &n, &c_n1,
&c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
goto L50;
}
/* Set some values for K: the first value must be MINMN, */
/* corresponding to the call of DQRT01; other values are */
/* used in the calls of DQRT02, and must not exceed MINMN. */
kval[0] = minmn;
kval[1] = 0;
kval[2] = 1;
kval[3] = minmn / 2;
if (minmn == 0) {
nk = 1;
} else if (minmn == 1) {
nk = 2;
} else if (minmn <= 3) {
nk = 3;
} else {
nk = 4;
}
/* Do for each value of K in KVAL */
i__3 = nk;
for (ik = 1; ik <= i__3; ++ik) {
k = kval[ik - 1];
/* Do for each pair of values (NB,NX) in NBVAL and NXVAL. */
i__4 = *nnb;
for (inb = 1; inb <= i__4; ++inb) {
nb = nbval[inb];
xlaenv_(&c__1, &nb);
nx = nxval[inb];
xlaenv_(&c__3, &nx);
for (i__ = 1; i__ <= 8; ++i__) {
result[i__ - 1] = 0.;
}
nt = 2;
if (ik == 1) {
/* Test DGEQRF */
dqrt01_(&m, &n, &a[1], &af[1], &aq[1], &ar[1], &
lda, &tau[1], &work[1], &lwork, &rwork[1],
result);
if (! dgennd_(&m, &n, &af[1], &lda)) {
result[7] = *thresh * 2;
}
++nt;
} else if (m >= n) {
/* Test DORGQR, using factorization */
/* returned by DQRT01 */
dqrt02_(&m, &n, &k, &a[1], &af[1], &aq[1], &ar[1],
&lda, &tau[1], &work[1], &lwork, &rwork[
1], result);
}
if (m >= k) {
/* Test DORMQR, using factorization returned */
/* by DQRT01 */
dqrt03_(&m, &n, &k, &af[1], &ac[1], &ar[1], &aq[1]
, &lda, &tau[1], &work[1], &lwork, &rwork[
1], &result[2]);
nt += 4;
/* If M>=N and K=N, call DGEQRS to solve a system */
/* with NRHS right hand sides and compute the */
/* residual. */
if (k == n && inb == 1) {
/* Generate a solution and set the right */
/* hand side. */
s_copy(srnamc_1.srnamt, "DLARHS", (ftnlen)32,
(ftnlen)6);
dlarhs_(path, "New", "Full", "No transpose", &
m, &n, &c__0, &c__0, nrhs, &a[1], &
lda, &xact[1], &lda, &b[1], &lda,
iseed, &info);
dlacpy_("Full", &m, nrhs, &b[1], &lda, &x[1],
&lda);
s_copy(srnamc_1.srnamt, "DGEQRS", (ftnlen)32,
(ftnlen)6);
dgeqrs_(&m, &n, nrhs, &af[1], &lda, &tau[1], &
x[1], &lda, &work[1], &lwork, &info);
/* Check error code from DGEQRS. */
if (info != 0) {
alaerh_(path, "DGEQRS", &info, &c__0,
" ", &m, &n, nrhs, &c_n1, &nb, &
imat, &nfail, &nerrs, nout);
}
dget02_("No transpose", &m, &n, nrhs, &a[1], &
lda, &x[1], &lda, &b[1], &lda, &rwork[
1], &result[6]);
++nt;
}
}
/* Print information about the tests that did not */
/* pass the threshold. */
i__5 = nt;
for (i__ = 1; i__ <= i__5; ++i__) {
if (result[i__ - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___33.ciunit = *nout;
s_wsfe(&io___33);
do_fio(&c__1, (char *)&m, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&nx, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[i__ - 1], (
ftnlen)sizeof(doublereal));
e_wsfe();
++nfail;
}
/* L20: */
}
nrun += nt;
/* L30: */
}
/* L40: */
}
L50:
;
}
/* L60: */
}
/* L70: */
}
/* Print a summary of the results. */
alasum_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of DCHKQR */
} /* dchkqr_ */
/* Subroutine */ int dchkge_(logical *dotype, integer *nm, integer *mval,
integer *nn, integer *nval, integer *nnb, integer *nbval, integer *
nns, integer *nsval, doublereal *thresh, logical *tsterr, integer *
nmax, doublereal *a, doublereal *afac, doublereal *ainv, doublereal *
b, doublereal *x, doublereal *xact, doublereal *work, doublereal *
rwork, integer *iwork, integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
static char transs[1*3] = "N" "T" "C";
/* Format strings */
static char fmt_9999[] = "(\002 M = \002,i5,\002, N =\002,i5,\002, NB "
"=\002,i4,\002, type \002,i2,\002, test(\002,i2,\002) =\002,g12.5)"
;
static char fmt_9998[] = "(\002 TRANS='\002,a1,\002', N =\002,i5,\002, N"
"RHS=\002,i3,\002, type \002,i2,\002, test(\002,i2,\002) =\002,g1"
"2.5)";
static char fmt_9997[] = "(\002 NORM ='\002,a1,\002', N =\002,i5,\002"
",\002,10x,\002 type \002,i2,\002, test(\002,i2,\002) =\002,g12.5)"
;
/* System generated locals */
integer i__1, i__2, i__3, i__4, i__5;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
integer i__, k, m, n, nb, im, in, kl, ku, nt, lda, inb, ioff, mode, imat,
info;
char path[3], dist[1];
integer irhs, nrhs;
char norm[1], type__[1];
integer nrun;
extern /* Subroutine */ int alahd_(integer *, char *), dget01_(
integer *, integer *, doublereal *, integer *, doublereal *,
integer *, integer *, doublereal *, doublereal *), dget02_(char *,
integer *, integer *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *), dget03_(integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *, doublereal *), dget04_(integer *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *);
integer nfail, iseed[4];
extern doublereal dget06_(doublereal *, doublereal *);
extern /* Subroutine */ int dget07_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, logical *,
doublereal *, doublereal *);
doublereal rcond;
integer nimat;
doublereal anorm;
integer itran;
char trans[1];
integer izero, nerrs;
doublereal dummy;
integer lwork;
logical zerot;
char xtype[1];
extern /* Subroutine */ int dlatb4_(char *, integer *, integer *, integer
*, char *, integer *, integer *, doublereal *, integer *,
doublereal *, char *);
extern doublereal dlange_(char *, integer *, integer *, doublereal *,
integer *, doublereal *);
extern /* Subroutine */ int alaerh_(char *, char *, integer *, integer *,
char *, integer *, integer *, integer *, integer *, integer *,
integer *, integer *, integer *, integer *), dgecon_(char *, integer *, doublereal *, integer *,
doublereal *, doublereal *, doublereal *, integer *, integer *);
doublereal rcondc;
extern /* Subroutine */ int derrge_(char *, integer *), dgerfs_(
char *, integer *, integer *, doublereal *, integer *, doublereal
*, integer *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *, doublereal *, integer *,
integer *), dgetrf_(integer *, integer *, doublereal *,
integer *, integer *, integer *), dlacpy_(char *, integer *,
integer *, doublereal *, integer *, doublereal *, integer *), dlarhs_(char *, char *, char *, char *, integer *,
integer *, integer *, integer *, integer *, doublereal *, integer
*, doublereal *, integer *, doublereal *, integer *, integer *,
integer *);
doublereal rcondi;
extern /* Subroutine */ int dgetri_(integer *, doublereal *, integer *,
integer *, doublereal *, integer *, integer *), dlaset_(char *,
integer *, integer *, doublereal *, doublereal *, doublereal *,
integer *), alasum_(char *, integer *, integer *, integer
*, integer *);
doublereal cndnum, anormi, rcondo;
extern /* Subroutine */ int dlatms_(integer *, integer *, char *, integer
*, char *, doublereal *, integer *, doublereal *, doublereal *,
integer *, integer *, char *, doublereal *, integer *, doublereal
*, integer *);
doublereal ainvnm;
extern /* Subroutine */ int dgetrs_(char *, integer *, integer *,
doublereal *, integer *, integer *, doublereal *, integer *,
integer *);
logical trfcon;
doublereal anormo;
extern /* Subroutine */ int xlaenv_(integer *, integer *);
doublereal result[8];
/* Fortran I/O blocks */
static cilist io___41 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___46 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___50 = { 0, 0, 0, fmt_9997, 0 };
/* -- LAPACK test routine (version 3.1.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* January 2007 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DCHKGE tests DGETRF, -TRI, -TRS, -RFS, and -CON. */
/* Arguments */
/* ========= */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* The matrix types to be used for testing. Matrices of type j */
/* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = */
/* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. */
/* NM (input) INTEGER */
/* The number of values of M contained in the vector MVAL. */
/* MVAL (input) INTEGER array, dimension (NM) */
/* The values of the matrix row dimension M. */
/* NN (input) INTEGER */
/* The number of values of N contained in the vector NVAL. */
/* NVAL (input) INTEGER array, dimension (NN) */
/* The values of the matrix column dimension N. */
/* NNB (input) INTEGER */
/* The number of values of NB contained in the vector NBVAL. */
/* NBVAL (input) INTEGER array, dimension (NBVAL) */
/* The values of the blocksize NB. */
/* NNS (input) INTEGER */
/* The number of values of NRHS contained in the vector NSVAL. */
/* NSVAL (input) INTEGER array, dimension (NNS) */
/* The values of the number of right hand sides NRHS. */
/* THRESH (input) DOUBLE PRECISION */
/* The threshold value for the test ratios. A result is */
/* included in the output file if RESULT >= THRESH. To have */
/* every test ratio printed, use THRESH = 0. */
/* TSTERR (input) LOGICAL */
/* Flag that indicates whether error exits are to be tested. */
/* NMAX (input) INTEGER */
/* The maximum value permitted for M or N, used in dimensioning */
/* the work arrays. */
/* A (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
/* AFAC (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
/* AINV (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
/* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) */
/* where NSMAX is the largest entry in NSVAL. */
/* X (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) */
/* XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) */
/* WORK (workspace) DOUBLE PRECISION array, dimension */
/* (NMAX*max(3,NSMAX)) */
/* RWORK (workspace) DOUBLE PRECISION array, dimension */
/* (max(2*NMAX,2*NSMAX+NWORK)) */
/* IWORK (workspace) INTEGER array, dimension (2*NMAX) */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--iwork;
--rwork;
--work;
--xact;
--x;
--b;
--ainv;
--afac;
--a;
--nsval;
--nbval;
--nval;
--mval;
--dotype;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* Initialize constants and the random number seed. */
s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
s_copy(path + 1, "GE", (ftnlen)2, (ftnlen)2);
nrun = 0;
nfail = 0;
nerrs = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
}
/* Test the error exits */
xlaenv_(&c__1, &c__1);
if (*tsterr) {
derrge_(path, nout);
}
infoc_1.infot = 0;
xlaenv_(&c__2, &c__2);
/* Do for each value of M in MVAL */
i__1 = *nm;
for (im = 1; im <= i__1; ++im) {
m = mval[im];
lda = max(1,m);
/* Do for each value of N in NVAL */
i__2 = *nn;
for (in = 1; in <= i__2; ++in) {
n = nval[in];
*(unsigned char *)xtype = 'N';
nimat = 11;
if (m <= 0 || n <= 0) {
nimat = 1;
}
i__3 = nimat;
for (imat = 1; imat <= i__3; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (! dotype[imat]) {
goto L100;
}
/* Skip types 5, 6, or 7 if the matrix size is too small. */
zerot = imat >= 5 && imat <= 7;
if (zerot && n < imat - 4) {
goto L100;
}
/* Set up parameters with DLATB4 and generate a test matrix */
/* with DLATMS. */
dlatb4_(path, &imat, &m, &n, type__, &kl, &ku, &anorm, &mode,
&cndnum, dist);
s_copy(srnamc_1.srnamt, "DLATMS", (ftnlen)32, (ftnlen)6);
dlatms_(&m, &n, dist, iseed, type__, &rwork[1], &mode, &
cndnum, &anorm, &kl, &ku, "No packing", &a[1], &lda, &
work[1], &info);
/* Check error code from DLATMS. */
if (info != 0) {
alaerh_(path, "DLATMS", &info, &c__0, " ", &m, &n, &c_n1,
&c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
goto L100;
}
/* For types 5-7, zero one or more columns of the matrix to */
/* test that INFO is returned correctly. */
if (zerot) {
if (imat == 5) {
izero = 1;
} else if (imat == 6) {
izero = min(m,n);
} else {
izero = min(m,n) / 2 + 1;
}
ioff = (izero - 1) * lda;
if (imat < 7) {
i__4 = m;
for (i__ = 1; i__ <= i__4; ++i__) {
a[ioff + i__] = 0.;
/* L20: */
}
} else {
i__4 = n - izero + 1;
dlaset_("Full", &m, &i__4, &c_b23, &c_b23, &a[ioff +
1], &lda);
}
} else {
izero = 0;
}
/* These lines, if used in place of the calls in the DO 60 */
/* loop, cause the code to bomb on a Sun SPARCstation. */
/* ANORMO = DLANGE( 'O', M, N, A, LDA, RWORK ) */
/* ANORMI = DLANGE( 'I', M, N, A, LDA, RWORK ) */
/* Do for each blocksize in NBVAL */
i__4 = *nnb;
for (inb = 1; inb <= i__4; ++inb) {
nb = nbval[inb];
xlaenv_(&c__1, &nb);
/* Compute the LU factorization of the matrix. */
dlacpy_("Full", &m, &n, &a[1], &lda, &afac[1], &lda);
s_copy(srnamc_1.srnamt, "DGETRF", (ftnlen)32, (ftnlen)6);
dgetrf_(&m, &n, &afac[1], &lda, &iwork[1], &info);
/* Check error code from DGETRF. */
if (info != izero) {
alaerh_(path, "DGETRF", &info, &izero, " ", &m, &n, &
c_n1, &c_n1, &nb, &imat, &nfail, &nerrs, nout);
}
trfcon = FALSE_;
/* + TEST 1 */
/* Reconstruct matrix from factors and compute residual. */
dlacpy_("Full", &m, &n, &afac[1], &lda, &ainv[1], &lda);
dget01_(&m, &n, &a[1], &lda, &ainv[1], &lda, &iwork[1], &
rwork[1], result);
nt = 1;
/* + TEST 2 */
/* Form the inverse if the factorization was successful */
/* and compute the residual. */
if (m == n && info == 0) {
dlacpy_("Full", &n, &n, &afac[1], &lda, &ainv[1], &
lda);
s_copy(srnamc_1.srnamt, "DGETRI", (ftnlen)32, (ftnlen)
6);
nrhs = nsval[1];
lwork = *nmax * max(3,nrhs);
dgetri_(&n, &ainv[1], &lda, &iwork[1], &work[1], &
lwork, &info);
/* Check error code from DGETRI. */
if (info != 0) {
alaerh_(path, "DGETRI", &info, &c__0, " ", &n, &n,
&c_n1, &c_n1, &nb, &imat, &nfail, &nerrs,
nout);
}
/* Compute the residual for the matrix times its */
/* inverse. Also compute the 1-norm condition number */
/* of A. */
dget03_(&n, &a[1], &lda, &ainv[1], &lda, &work[1], &
lda, &rwork[1], &rcondo, &result[1]);
anormo = dlange_("O", &m, &n, &a[1], &lda, &rwork[1]);
/* Compute the infinity-norm condition number of A. */
anormi = dlange_("I", &m, &n, &a[1], &lda, &rwork[1]);
ainvnm = dlange_("I", &n, &n, &ainv[1], &lda, &rwork[
1]);
if (anormi <= 0. || ainvnm <= 0.) {
rcondi = 1.;
} else {
rcondi = 1. / anormi / ainvnm;
}
nt = 2;
} else {
/* Do only the condition estimate if INFO > 0. */
trfcon = TRUE_;
anormo = dlange_("O", &m, &n, &a[1], &lda, &rwork[1]);
anormi = dlange_("I", &m, &n, &a[1], &lda, &rwork[1]);
rcondo = 0.;
rcondi = 0.;
}
/* Print information about the tests so far that did not */
/* pass the threshold. */
i__5 = nt;
for (k = 1; k <= i__5; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___41.ciunit = *nout;
s_wsfe(&io___41);
do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(integer)
);
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
sizeof(doublereal));
e_wsfe();
++nfail;
}
/* L30: */
}
nrun += nt;
/* Skip the remaining tests if this is not the first */
/* block size or if M .ne. N. Skip the solve tests if */
/* the matrix is singular. */
if (inb > 1 || m != n) {
goto L90;
}
if (trfcon) {
goto L70;
}
i__5 = *nns;
for (irhs = 1; irhs <= i__5; ++irhs) {
nrhs = nsval[irhs];
*(unsigned char *)xtype = 'N';
for (itran = 1; itran <= 3; ++itran) {
*(unsigned char *)trans = *(unsigned char *)&
transs[itran - 1];
if (itran == 1) {
rcondc = rcondo;
} else {
rcondc = rcondi;
}
/* + TEST 3 */
/* Solve and compute residual for A * X = B. */
s_copy(srnamc_1.srnamt, "DLARHS", (ftnlen)32, (
ftnlen)6);
dlarhs_(path, xtype, " ", trans, &n, &n, &kl, &ku,
&nrhs, &a[1], &lda, &xact[1], &lda, &b[1]
, &lda, iseed, &info);
*(unsigned char *)xtype = 'C';
dlacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &
lda);
s_copy(srnamc_1.srnamt, "DGETRS", (ftnlen)32, (
ftnlen)6);
dgetrs_(trans, &n, &nrhs, &afac[1], &lda, &iwork[
1], &x[1], &lda, &info);
/* Check error code from DGETRS. */
if (info != 0) {
alaerh_(path, "DGETRS", &info, &c__0, trans, &
n, &n, &c_n1, &c_n1, &nrhs, &imat, &
nfail, &nerrs, nout);
}
dlacpy_("Full", &n, &nrhs, &b[1], &lda, &work[1],
&lda);
dget02_(trans, &n, &n, &nrhs, &a[1], &lda, &x[1],
&lda, &work[1], &lda, &rwork[1], &result[
2]);
/* + TEST 4 */
/* Check solution from generated exact solution. */
dget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[3]);
/* + TESTS 5, 6, and 7 */
/* Use iterative refinement to improve the */
/* solution. */
s_copy(srnamc_1.srnamt, "DGERFS", (ftnlen)32, (
ftnlen)6);
dgerfs_(trans, &n, &nrhs, &a[1], &lda, &afac[1], &
lda, &iwork[1], &b[1], &lda, &x[1], &lda,
&rwork[1], &rwork[nrhs + 1], &work[1], &
iwork[n + 1], &info);
/* Check error code from DGERFS. */
if (info != 0) {
alaerh_(path, "DGERFS", &info, &c__0, trans, &
n, &n, &c_n1, &c_n1, &nrhs, &imat, &
nfail, &nerrs, nout);
}
dget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[4]);
dget07_(trans, &n, &nrhs, &a[1], &lda, &b[1], &
lda, &x[1], &lda, &xact[1], &lda, &rwork[
1], &c_true, &rwork[nrhs + 1], &result[5]);
/* Print information about the tests that did not */
/* pass the threshold. */
for (k = 3; k <= 7; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___46.ciunit = *nout;
s_wsfe(&io___46);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&nrhs, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[k - 1], (
ftnlen)sizeof(doublereal));
e_wsfe();
++nfail;
}
/* L40: */
}
nrun += 5;
/* L50: */
}
/* L60: */
}
/* + TEST 8 */
/* Get an estimate of RCOND = 1/CNDNUM. */
L70:
for (itran = 1; itran <= 2; ++itran) {
if (itran == 1) {
anorm = anormo;
rcondc = rcondo;
*(unsigned char *)norm = 'O';
} else {
anorm = anormi;
rcondc = rcondi;
*(unsigned char *)norm = 'I';
}
s_copy(srnamc_1.srnamt, "DGECON", (ftnlen)32, (ftnlen)
6);
dgecon_(norm, &n, &afac[1], &lda, &anorm, &rcond, &
work[1], &iwork[n + 1], &info);
/* Check error code from DGECON. */
if (info != 0) {
alaerh_(path, "DGECON", &info, &c__0, norm, &n, &
n, &c_n1, &c_n1, &c_n1, &imat, &nfail, &
nerrs, nout);
}
/* This line is needed on a Sun SPARCstation. */
dummy = rcond;
result[7] = dget06_(&rcond, &rcondc);
/* Print information about the tests that did not pass */
/* the threshold. */
if (result[7] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___50.ciunit = *nout;
s_wsfe(&io___50);
do_fio(&c__1, norm, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&c__8, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[7], (ftnlen)sizeof(
doublereal));
e_wsfe();
++nfail;
}
++nrun;
/* L80: */
}
L90:
;
}
L100:
;
}
/* L110: */
}
/* L120: */
}
/* Print a summary of the results. */
alasum_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of DCHKGE */
} /* dchkge_ */
/* Subroutine */ int sdrvsx_(integer *nsizes, integer *nn, integer *ntypes,
logical *dotype, integer *iseed, real *thresh, integer *niunit,
integer *nounit, real *a, integer *lda, real *h__, real *ht, real *wr,
real *wi, real *wrt, real *wit, real *wrtmp, real *witmp, real *vs,
integer *ldvs, real *vs1, real *result, real *work, integer *lwork,
integer *iwork, logical *bwork, integer *info)
{
/* Initialized data */
static integer ktype[21] = { 1,2,3,4,4,4,4,4,6,6,6,6,6,6,6,6,6,6,9,9,9 };
static integer kmagn[21] = { 1,1,1,1,1,1,2,3,1,1,1,1,1,1,1,1,2,3,1,2,3 };
static integer kmode[21] = { 0,0,0,4,3,1,4,4,4,3,1,5,4,3,1,5,5,5,4,3,1 };
static integer kconds[21] = { 0,0,0,0,0,0,0,0,1,1,1,1,2,2,2,2,2,2,0,0,0 };
/* Format strings */
static char fmt_9991[] = "(\002 SDRVSX: \002,a,\002 returned INFO=\002,i"
"6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
"(\002,3(i5,\002,\002),i5,\002)\002)";
static char fmt_9999[] = "(/1x,a3,\002 -- Real Schur Form Decomposition "
"Expert \002,\002Driver\002,/\002 Matrix types (see SDRVSX for de"
"tails):\002)";
static char fmt_9998[] = "(/\002 Special Matrices:\002,/\002 1=Zero mat"
"rix. \002,\002 \002,\002 5=Diagonal: geom"
"etr. spaced entries.\002,/\002 2=Identity matrix. "
" \002,\002 6=Diagona\002,\002l: clustered entries.\002,"
"/\002 3=Transposed Jordan block. \002,\002 \002,\002 "
" 7=Diagonal: large, evenly spaced.\002,/\002 \002,\0024=Diagona"
"l: evenly spaced entries. \002,\002 8=Diagonal: s\002,\002ma"
"ll, evenly spaced.\002)";
static char fmt_9997[] = "(\002 Dense, Non-Symmetric Matrices:\002,/\002"
" 9=Well-cond., ev\002,\002enly spaced eigenvals.\002,\002 14=Il"
"l-cond., geomet. spaced e\002,\002igenals.\002,/\002 10=Well-con"
"d., geom. spaced eigenvals. \002,\002 15=Ill-conditioned, cluste"
"red e.vals.\002,/\002 11=Well-cond\002,\002itioned, clustered e."
"vals. \002,\002 16=Ill-cond., random comp\002,\002lex \002,/\002"
" 12=Well-cond., random complex \002,\002 \002,\002 17=Il"
"l-cond., large rand. complx \002,/\002 13=Ill-condi\002,\002tion"
"ed, evenly spaced. \002,\002 18=Ill-cond., small rand.\002"
",\002 complx \002)";
static char fmt_9996[] = "(\002 19=Matrix with random O(1) entries. "
" \002,\002 21=Matrix \002,\002with small random entries.\002,"
"/\002 20=Matrix with large ran\002,\002dom entries. \002,/)";
static char fmt_9995[] = "(\002 Tests performed with test threshold ="
"\002,f8.2,/\002 ( A denotes A on input and T denotes A on output)"
"\002,//\002 1 = 0 if T in Schur form (no sort), \002,\002 1/ulp"
" otherwise\002,/\002 2 = | A - VS T transpose(VS) | / ( n |A| ul"
"p ) (no sort)\002,/\002 3 = | I - VS transpose(VS) | / ( n ulp )"
" (no sort) \002,/\002 4 = 0 if WR+sqrt(-1)*WI are eigenvalues of"
" T (no sort),\002,\002 1/ulp otherwise\002,/\002 5 = 0 if T sam"
"e no matter if VS computed (no sort),\002,\002 1/ulp otherwis"
"e\002,/\002 6 = 0 if WR, WI same no matter if VS computed (no so"
"rt)\002,\002, 1/ulp otherwise\002)";
static char fmt_9994[] = "(\002 7 = 0 if T in Schur form (sort), \002"
",\002 1/ulp otherwise\002,/\002 8 = | A - VS T transpose(VS) | "
"/ ( n |A| ulp ) (sort)\002,/\002 9 = | I - VS transpose(VS) | / "
"( n ulp ) (sort) \002,/\002 10 = 0 if WR+sqrt(-1)*WI are eigenva"
"lues of T (sort),\002,\002 1/ulp otherwise\002,/\002 11 = 0 if "
"T same no matter what else computed (sort),\002,\002 1/ulp othe"
"rwise\002,/\002 12 = 0 if WR, WI same no matter what else comput"
"ed \002,\002(sort), 1/ulp otherwise\002,/\002 13 = 0 if sorting "
"succesful, 1/ulp otherwise\002,/\002 14 = 0 if RCONDE same no ma"
"tter what else computed,\002,\002 1/ulp otherwise\002,/\002 15 ="
" 0 if RCONDv same no matter what else computed,\002,\002 1/ulp o"
"therwise\002,/\002 16 = | RCONDE - RCONDE(precomputed) | / cond("
"RCONDE),\002,/\002 17 = | RCONDV - RCONDV(precomputed) | / cond("
"RCONDV),\002)";
static char fmt_9993[] = "(\002 N=\002,i5,\002, IWK=\002,i2,\002, seed"
"=\002,4(i4,\002,\002),\002 type \002,i2,\002, test(\002,i2,\002)="
"\002,g10.3)";
static char fmt_9992[] = "(\002 N=\002,i5,\002, input example =\002,i3"
",\002, test(\002,i2,\002)=\002,g10.3)";
/* System generated locals */
integer a_dim1, a_offset, h_dim1, h_offset, ht_dim1, ht_offset, vs_dim1,
vs_offset, vs1_dim1, vs1_offset, i__1, i__2, i__3, i__4;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
double sqrt(doublereal);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_rsle(void);
/* Local variables */
integer i__, j, n, iwk;
real ulp, cond;
integer jcol;
char path[3];
integer nmax;
real unfl, ovfl;
logical badnn;
integer nfail, imode, iinfo;
real conds;
extern /* Subroutine */ int sget24_(logical *, integer *, real *, integer
*, integer *, integer *, real *, integer *, real *, real *, real *
, real *, real *, real *, real *, real *, real *, integer *, real
*, real *, real *, integer *, integer *, real *, real *, integer *
, integer *, logical *, integer *);
real anorm;
integer islct[20], nslct, jsize, nerrs, itype, jtype, ntest;
real rtulp;
extern /* Subroutine */ int slabad_(real *, real *);
real rcdein;
char adumma[1*1];
extern doublereal slamch_(char *);
integer idumma[1], ioldsd[4];
extern /* Subroutine */ int xerbla_(char *, integer *);
real rcdvin;
extern /* Subroutine */ int slatme_(integer *, char *, integer *, real *,
integer *, real *, real *, char *, char *, char *, char *, real *,
integer *, real *, integer *, integer *, real *, real *, integer
*, real *, integer *),
slaset_(char *, integer *, integer *, real *, real *, real *,
integer *), slatmr_(integer *, integer *, char *, integer
*, char *, real *, integer *, real *, real *, char *, char *,
real *, integer *, real *, real *, integer *, real *, char *,
integer *, integer *, integer *, real *, real *, char *, real *,
integer *, integer *, integer *);
integer ntestf;
extern /* Subroutine */ int slasum_(char *, integer *, integer *, integer
*), slatms_(integer *, integer *, char *, integer *, char
*, real *, integer *, real *, real *, integer *, integer *, char *
, real *, integer *, real *, integer *);
real ulpinv;
integer nnwork;
real rtulpi;
integer mtypes, ntestt;
/* Fortran I/O blocks */
static cilist io___32 = { 0, 0, 0, fmt_9991, 0 };
static cilist io___41 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___42 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___43 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___44 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___45 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___46 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___47 = { 0, 0, 0, fmt_9993, 0 };
static cilist io___48 = { 0, 0, 1, 0, 0 };
static cilist io___49 = { 0, 0, 0, 0, 0 };
static cilist io___51 = { 0, 0, 0, 0, 0 };
static cilist io___52 = { 0, 0, 0, 0, 0 };
static cilist io___53 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___54 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___55 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___56 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___57 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___58 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___59 = { 0, 0, 0, fmt_9992, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SDRVSX checks the nonsymmetric eigenvalue (Schur form) problem */
/* expert driver SGEESX. */
/* SDRVSX uses both test matrices generated randomly depending on */
/* data supplied in the calling sequence, as well as on data */
/* read from an input file and including precomputed condition */
/* numbers to which it compares the ones it computes. */
/* When SDRVSX is called, a number of matrix "sizes" ("n's") and a */
/* number of matrix "types" are specified. For each size ("n") */
/* and each type of matrix, one matrix will be generated and used */
/* to test the nonsymmetric eigenroutines. For each matrix, 15 */
/* tests will be performed: */
/* (1) 0 if T is in Schur form, 1/ulp otherwise */
/* (no sorting of eigenvalues) */
/* (2) | A - VS T VS' | / ( n |A| ulp ) */
/* Here VS is the matrix of Schur eigenvectors, and T is in Schur */
/* form (no sorting of eigenvalues). */
/* (3) | I - VS VS' | / ( n ulp ) (no sorting of eigenvalues). */
/* (4) 0 if WR+sqrt(-1)*WI are eigenvalues of T */
/* 1/ulp otherwise */
/* (no sorting of eigenvalues) */
/* (5) 0 if T(with VS) = T(without VS), */
/* 1/ulp otherwise */
/* (no sorting of eigenvalues) */
/* (6) 0 if eigenvalues(with VS) = eigenvalues(without VS), */
/* 1/ulp otherwise */
/* (no sorting of eigenvalues) */
/* (7) 0 if T is in Schur form, 1/ulp otherwise */
/* (with sorting of eigenvalues) */
/* (8) | A - VS T VS' | / ( n |A| ulp ) */
/* Here VS is the matrix of Schur eigenvectors, and T is in Schur */
/* form (with sorting of eigenvalues). */
/* (9) | I - VS VS' | / ( n ulp ) (with sorting of eigenvalues). */
/* (10) 0 if WR+sqrt(-1)*WI are eigenvalues of T */
/* 1/ulp otherwise */
/* If workspace sufficient, also compare WR, WI with and */
/* without reciprocal condition numbers */
/* (with sorting of eigenvalues) */
/* (11) 0 if T(with VS) = T(without VS), */
/* 1/ulp otherwise */
/* If workspace sufficient, also compare T with and without */
/* reciprocal condition numbers */
/* (with sorting of eigenvalues) */
/* (12) 0 if eigenvalues(with VS) = eigenvalues(without VS), */
/* 1/ulp otherwise */
/* If workspace sufficient, also compare VS with and without */
/* reciprocal condition numbers */
/* (with sorting of eigenvalues) */
/* (13) if sorting worked and SDIM is the number of */
/* eigenvalues which were SELECTed */
/* If workspace sufficient, also compare SDIM with and */
/* without reciprocal condition numbers */
/* (14) if RCONDE the same no matter if VS and/or RCONDV computed */
/* (15) if RCONDV the same no matter if VS and/or RCONDE computed */
/* The "sizes" are specified by an array NN(1:NSIZES); the value of */
/* each element NN(j) specifies one size. */
/* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); */
/* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. */
/* Currently, the list of possible types is: */
/* (1) The zero matrix. */
/* (2) The identity matrix. */
/* (3) A (transposed) Jordan block, with 1's on the diagonal. */
/* (4) A diagonal matrix with evenly spaced entries */
/* 1, ..., ULP and random signs. */
/* (ULP = (first number larger than 1) - 1 ) */
/* (5) A diagonal matrix with geometrically spaced entries */
/* 1, ..., ULP and random signs. */
/* (6) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP */
/* and random signs. */
/* (7) Same as (4), but multiplied by a constant near */
/* the overflow threshold */
/* (8) Same as (4), but multiplied by a constant near */
/* the underflow threshold */
/* (9) A matrix of the form U' T U, where U is orthogonal and */
/* T has evenly spaced entries 1, ..., ULP with random signs */
/* on the diagonal and random O(1) entries in the upper */
/* triangle. */
/* (10) A matrix of the form U' T U, where U is orthogonal and */
/* T has geometrically spaced entries 1, ..., ULP with random */
/* signs on the diagonal and random O(1) entries in the upper */
/* triangle. */
/* (11) A matrix of the form U' T U, where U is orthogonal and */
/* T has "clustered" entries 1, ULP,..., ULP with random */
/* signs on the diagonal and random O(1) entries in the upper */
/* triangle. */
/* (12) A matrix of the form U' T U, where U is orthogonal and */
/* T has real or complex conjugate paired eigenvalues randomly */
/* chosen from ( ULP, 1 ) and random O(1) entries in the upper */
/* triangle. */
/* (13) A matrix of the form X' T X, where X has condition */
/* SQRT( ULP ) and T has evenly spaced entries 1, ..., ULP */
/* with random signs on the diagonal and random O(1) entries */
/* in the upper triangle. */
/* (14) A matrix of the form X' T X, where X has condition */
/* SQRT( ULP ) and T has geometrically spaced entries */
/* 1, ..., ULP with random signs on the diagonal and random */
/* O(1) entries in the upper triangle. */
/* (15) A matrix of the form X' T X, where X has condition */
/* SQRT( ULP ) and T has "clustered" entries 1, ULP,..., ULP */
/* with random signs on the diagonal and random O(1) entries */
/* in the upper triangle. */
/* (16) A matrix of the form X' T X, where X has condition */
/* SQRT( ULP ) and T has real or complex conjugate paired */
/* eigenvalues randomly chosen from ( ULP, 1 ) and random */
/* O(1) entries in the upper triangle. */
/* (17) Same as (16), but multiplied by a constant */
/* near the overflow threshold */
/* (18) Same as (16), but multiplied by a constant */
/* near the underflow threshold */
/* (19) Nonsymmetric matrix with random entries chosen from (-1,1). */
/* If N is at least 4, all entries in first two rows and last */
/* row, and first column and last two columns are zero. */
/* (20) Same as (19), but multiplied by a constant */
/* near the overflow threshold */
/* (21) Same as (19), but multiplied by a constant */
/* near the underflow threshold */
/* In addition, an input file will be read from logical unit number */
/* NIUNIT. The file contains matrices along with precomputed */
/* eigenvalues and reciprocal condition numbers for the eigenvalue */
/* average and right invariant subspace. For these matrices, in */
/* addition to tests (1) to (15) we will compute the following two */
/* tests: */
/* (16) |RCONDE - RCDEIN| / cond(RCONDE) */
/* RCONDE is the reciprocal average eigenvalue condition number */
/* computed by SGEESX and RCDEIN (the precomputed true value) */
/* is supplied as input. cond(RCONDE) is the condition number */
/* of RCONDE, and takes errors in computing RCONDE into account, */
/* so that the resulting quantity should be O(ULP). cond(RCONDE) */
/* is essentially given by norm(A)/RCONDV. */
/* (17) |RCONDV - RCDVIN| / cond(RCONDV) */
/* RCONDV is the reciprocal right invariant subspace condition */
/* number computed by SGEESX and RCDVIN (the precomputed true */
/* value) is supplied as input. cond(RCONDV) is the condition */
/* number of RCONDV, and takes errors in computing RCONDV into */
/* account, so that the resulting quantity should be O(ULP). */
/* cond(RCONDV) is essentially given by norm(A)/RCONDE. */
/* Arguments */
/* ========= */
/* NSIZES (input) INTEGER */
/* The number of sizes of matrices to use. NSIZES must be at */
/* least zero. If it is zero, no randomly generated matrices */
/* are tested, but any test matrices read from NIUNIT will be */
/* tested. */
/* NN (input) INTEGER array, dimension (NSIZES) */
/* An array containing the sizes to be used for the matrices. */
/* Zero values will be skipped. The values must be at least */
/* zero. */
/* NTYPES (input) INTEGER */
/* The number of elements in DOTYPE. NTYPES must be at least */
/* zero. If it is zero, no randomly generated test matrices */
/* are tested, but and test matrices read from NIUNIT will be */
/* tested. If it is MAXTYP+1 and NSIZES is 1, then an */
/* additional type, MAXTYP+1 is defined, which is to use */
/* whatever matrix is in A. This is only useful if */
/* DOTYPE(1:MAXTYP) is .FALSE. and DOTYPE(MAXTYP+1) is .TRUE. . */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* If DOTYPE(j) is .TRUE., then for each size in NN a */
/* matrix of that size and of type j will be generated. */
/* If NTYPES is smaller than the maximum number of types */
/* defined (PARAMETER MAXTYP), then types NTYPES+1 through */
/* MAXTYP will not be generated. If NTYPES is larger */
/* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) */
/* will be ignored. */
/* ISEED (input/output) INTEGER array, dimension (4) */
/* On entry ISEED specifies the seed of the random number */
/* generator. The array elements should be between 0 and 4095; */
/* if not they will be reduced mod 4096. Also, ISEED(4) must */
/* 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 SDRVSX to continue the same random number */
/* sequence. */
/* THRESH (input) REAL */
/* A test will count as "failed" if the "error", computed as */
/* described above, exceeds THRESH. Note that the error */
/* is scaled to be O(1), so THRESH should be a reasonably */
/* small multiple of 1, e.g., 10 or 100. In particular, */
/* it should not depend on the precision (single vs. double) */
/* or the size of the matrix. It must be at least zero. */
/* NIUNIT (input) INTEGER */
/* The FORTRAN unit number for reading in the data file of */
/* problems to solve. */
/* NOUNIT (input) INTEGER */
/* The FORTRAN unit number for printing out error messages */
/* (e.g., if a routine returns INFO not equal to 0.) */
/* A (workspace) REAL array, dimension (LDA, max(NN)) */
/* Used to hold the matrix whose eigenvalues are to be */
/* computed. On exit, A contains the last matrix actually used. */
/* LDA (input) INTEGER */
/* The leading dimension of A, and H. LDA must be at */
/* least 1 and at least max( NN ). */
/* H (workspace) REAL array, dimension (LDA, max(NN)) */
/* Another copy of the test matrix A, modified by SGEESX. */
/* HT (workspace) REAL array, dimension (LDA, max(NN)) */
/* Yet another copy of the test matrix A, modified by SGEESX. */
/* WR (workspace) REAL array, dimension (max(NN)) */
/* WI (workspace) REAL array, dimension (max(NN)) */
/* The real and imaginary parts of the eigenvalues of A. */
/* On exit, WR + WI*i are the eigenvalues of the matrix in A. */
/* WRT (workspace) REAL array, dimension (max(NN)) */
/* WIT (workspace) REAL array, dimension (max(NN)) */
/* Like WR, WI, these arrays contain the eigenvalues of A, */
/* but those computed when SGEESX only computes a partial */
/* eigendecomposition, i.e. not Schur vectors */
/* WRTMP (workspace) REAL array, dimension (max(NN)) */
/* WITMP (workspace) REAL array, dimension (max(NN)) */
/* More temporary storage for eigenvalues. */
/* VS (workspace) REAL array, dimension (LDVS, max(NN)) */
/* VS holds the computed Schur vectors. */
/* LDVS (input) INTEGER */
/* Leading dimension of VS. Must be at least max(1,max(NN)). */
/* VS1 (workspace) REAL array, dimension (LDVS, max(NN)) */
/* VS1 holds another copy of the computed Schur vectors. */
/* RESULT (output) REAL array, dimension (17) */
/* The values computed by the 17 tests described above. */
/* The values are currently limited to 1/ulp, to avoid overflow. */
/* WORK (workspace) REAL array, dimension (LWORK) */
/* LWORK (input) INTEGER */
/* The number of entries in WORK. This must be at least */
/* max(3*NN(j),2*NN(j)**2) for all j. */
/* IWORK (workspace) INTEGER array, dimension (max(NN)*max(NN)) */
/* INFO (output) INTEGER */
/* If 0, successful exit. */
/* <0, input parameter -INFO is incorrect */
/* >0, SLATMR, SLATMS, SLATME or SGET24 returned an error */
/* code and INFO is its absolute value */
/* ----------------------------------------------------------------------- */
/* Some Local Variables and Parameters: */
/* ---- ----- --------- --- ---------- */
/* ZERO, ONE Real 0 and 1. */
/* MAXTYP The number of types defined. */
/* NMAX Largest value in NN. */
/* NERRS The number of tests which have exceeded THRESH */
/* COND, CONDS, */
/* IMODE Values to be passed to the matrix generators. */
/* ANORM Norm of A; passed to matrix generators. */
/* OVFL, UNFL Overflow and underflow thresholds. */
/* ULP, ULPINV Finest relative precision and its inverse. */
/* RTULP, RTULPI Square roots of the previous 4 values. */
/* The following four arrays decode JTYPE: */
/* KTYPE(j) The general type (1-10) for type "j". */
/* KMODE(j) The MODE value to be passed to the matrix */
/* generator for type "j". */
/* KMAGN(j) The order of magnitude ( O(1), */
/* O(overflow^(1/2) ), O(underflow^(1/2) ) */
/* KCONDS(j) Selectw whether CONDS is to be 1 or */
/* 1/sqrt(ulp). (0 means irrelevant.) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. Arrays in Common .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--nn;
--dotype;
--iseed;
ht_dim1 = *lda;
ht_offset = 1 + ht_dim1;
ht -= ht_offset;
h_dim1 = *lda;
h_offset = 1 + h_dim1;
h__ -= h_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--wr;
--wi;
--wrt;
--wit;
--wrtmp;
--witmp;
vs1_dim1 = *ldvs;
vs1_offset = 1 + vs1_dim1;
vs1 -= vs1_offset;
vs_dim1 = *ldvs;
vs_offset = 1 + vs_dim1;
vs -= vs_offset;
--result;
--work;
--iwork;
--bwork;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
s_copy(path, "Single precision", (ftnlen)1, (ftnlen)16);
s_copy(path + 1, "SX", (ftnlen)2, (ftnlen)2);
/* Check for errors */
ntestt = 0;
ntestf = 0;
*info = 0;
/* Important constants */
badnn = FALSE_;
/* 12 is the largest dimension in the input file of precomputed */
/* problems */
nmax = 12;
i__1 = *nsizes;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = nmax, i__3 = nn[j];
nmax = max(i__2,i__3);
if (nn[j] < 0) {
badnn = TRUE_;
}
/* L10: */
}
/* Check for errors */
if (*nsizes < 0) {
*info = -1;
} else if (badnn) {
*info = -2;
} else if (*ntypes < 0) {
*info = -3;
} else if (*thresh < 0.f) {
*info = -6;
} else if (*niunit <= 0) {
*info = -7;
} else if (*nounit <= 0) {
*info = -8;
} else if (*lda < 1 || *lda < nmax) {
*info = -10;
} else if (*ldvs < 1 || *ldvs < nmax) {
*info = -20;
} else /* if(complicated condition) */ {
/* Computing MAX */
/* Computing 2nd power */
i__3 = nmax;
i__1 = nmax * 3, i__2 = i__3 * i__3 << 1;
if (max(i__1,i__2) > *lwork) {
*info = -24;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SDRVSX", &i__1);
return 0;
}
/* If nothing to do check on NIUNIT */
if (*nsizes == 0 || *ntypes == 0) {
goto L150;
}
/* More Important constants */
unfl = slamch_("Safe minimum");
ovfl = 1.f / unfl;
slabad_(&unfl, &ovfl);
ulp = slamch_("Precision");
ulpinv = 1.f / ulp;
rtulp = sqrt(ulp);
rtulpi = 1.f / rtulp;
/* Loop over sizes, types */
nerrs = 0;
i__1 = *nsizes;
for (jsize = 1; jsize <= i__1; ++jsize) {
n = nn[jsize];
if (*nsizes != 1) {
mtypes = min(21,*ntypes);
} else {
mtypes = min(22,*ntypes);
}
i__2 = mtypes;
for (jtype = 1; jtype <= i__2; ++jtype) {
if (! dotype[jtype]) {
goto L130;
}
/* Save ISEED in case of an error. */
for (j = 1; j <= 4; ++j) {
ioldsd[j - 1] = iseed[j];
/* L20: */
}
/* Compute "A" */
/* Control parameters: */
/* KMAGN KCONDS KMODE KTYPE */
/* =1 O(1) 1 clustered 1 zero */
/* =2 large large clustered 2 identity */
/* =3 small exponential Jordan */
/* =4 arithmetic diagonal, (w/ eigenvalues) */
/* =5 random log symmetric, w/ eigenvalues */
/* =6 random general, w/ eigenvalues */
/* =7 random diagonal */
/* =8 random symmetric */
/* =9 random general */
/* =10 random triangular */
if (mtypes > 21) {
goto L90;
}
itype = ktype[jtype - 1];
imode = kmode[jtype - 1];
/* Compute norm */
switch (kmagn[jtype - 1]) {
case 1: goto L30;
case 2: goto L40;
case 3: goto L50;
}
L30:
anorm = 1.f;
goto L60;
L40:
anorm = ovfl * ulp;
goto L60;
L50:
anorm = unfl * ulpinv;
goto L60;
L60:
slaset_("Full", lda, &n, &c_b18, &c_b18, &a[a_offset], lda);
iinfo = 0;
cond = ulpinv;
/* Special Matrices -- Identity & Jordan block */
/* Zero */
if (itype == 1) {
iinfo = 0;
} else if (itype == 2) {
/* Identity */
i__3 = n;
for (jcol = 1; jcol <= i__3; ++jcol) {
a[jcol + jcol * a_dim1] = anorm;
/* L70: */
}
} else if (itype == 3) {
/* Jordan Block */
i__3 = n;
for (jcol = 1; jcol <= i__3; ++jcol) {
a[jcol + jcol * a_dim1] = anorm;
if (jcol > 1) {
a[jcol + (jcol - 1) * a_dim1] = 1.f;
}
/* L80: */
}
} else if (itype == 4) {
/* Diagonal Matrix, [Eigen]values Specified */
slatms_(&n, &n, "S", &iseed[1], "S", &work[1], &imode, &cond,
&anorm, &c__0, &c__0, "N", &a[a_offset], lda, &work[n
+ 1], &iinfo);
} else if (itype == 5) {
/* Symmetric, eigenvalues specified */
slatms_(&n, &n, "S", &iseed[1], "S", &work[1], &imode, &cond,
&anorm, &n, &n, "N", &a[a_offset], lda, &work[n + 1],
&iinfo);
} else if (itype == 6) {
/* General, eigenvalues specified */
if (kconds[jtype - 1] == 1) {
conds = 1.f;
} else if (kconds[jtype - 1] == 2) {
conds = rtulpi;
} else {
conds = 0.f;
}
*(unsigned char *)&adumma[0] = ' ';
slatme_(&n, "S", &iseed[1], &work[1], &imode, &cond, &c_b32,
adumma, "T", "T", "T", &work[n + 1], &c__4, &conds, &
n, &n, &anorm, &a[a_offset], lda, &work[(n << 1) + 1],
&iinfo);
} else if (itype == 7) {
/* Diagonal, random eigenvalues */
slatmr_(&n, &n, "S", &iseed[1], "S", &work[1], &c__6, &c_b32,
&c_b32, "T", "N", &work[n + 1], &c__1, &c_b32, &work[(
n << 1) + 1], &c__1, &c_b32, "N", idumma, &c__0, &
c__0, &c_b18, &anorm, "NO", &a[a_offset], lda, &iwork[
1], &iinfo);
} else if (itype == 8) {
/* Symmetric, random eigenvalues */
slatmr_(&n, &n, "S", &iseed[1], "S", &work[1], &c__6, &c_b32,
&c_b32, "T", "N", &work[n + 1], &c__1, &c_b32, &work[(
n << 1) + 1], &c__1, &c_b32, "N", idumma, &n, &n, &
c_b18, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
iinfo);
} else if (itype == 9) {
/* General, random eigenvalues */
slatmr_(&n, &n, "S", &iseed[1], "N", &work[1], &c__6, &c_b32,
&c_b32, "T", "N", &work[n + 1], &c__1, &c_b32, &work[(
n << 1) + 1], &c__1, &c_b32, "N", idumma, &n, &n, &
c_b18, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
iinfo);
if (n >= 4) {
slaset_("Full", &c__2, &n, &c_b18, &c_b18, &a[a_offset],
lda);
i__3 = n - 3;
slaset_("Full", &i__3, &c__1, &c_b18, &c_b18, &a[a_dim1 +
3], lda);
i__3 = n - 3;
slaset_("Full", &i__3, &c__2, &c_b18, &c_b18, &a[(n - 1) *
a_dim1 + 3], lda);
slaset_("Full", &c__1, &n, &c_b18, &c_b18, &a[n + a_dim1],
lda);
}
} else if (itype == 10) {
/* Triangular, random eigenvalues */
slatmr_(&n, &n, "S", &iseed[1], "N", &work[1], &c__6, &c_b32,
&c_b32, "T", "N", &work[n + 1], &c__1, &c_b32, &work[(
n << 1) + 1], &c__1, &c_b32, "N", idumma, &n, &c__0, &
c_b18, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
iinfo);
} else {
iinfo = 1;
}
if (iinfo != 0) {
io___32.ciunit = *nounit;
s_wsfe(&io___32);
do_fio(&c__1, "Generator", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
return 0;
}
L90:
/* Test for minimal and generous workspace */
for (iwk = 1; iwk <= 2; ++iwk) {
if (iwk == 1) {
nnwork = n * 3;
} else {
/* Computing MAX */
i__3 = n * 3, i__4 = (n << 1) * n;
nnwork = max(i__3,i__4);
}
nnwork = max(nnwork,1);
sget24_(&c_false, &jtype, thresh, ioldsd, nounit, &n, &a[
a_offset], lda, &h__[h_offset], &ht[ht_offset], &wr[1]
, &wi[1], &wrt[1], &wit[1], &wrtmp[1], &witmp[1], &vs[
vs_offset], ldvs, &vs1[vs1_offset], &rcdein, &rcdvin,
&nslct, islct, &result[1], &work[1], &nnwork, &iwork[
1], &bwork[1], info);
/* Check for RESULT(j) > THRESH */
ntest = 0;
nfail = 0;
for (j = 1; j <= 15; ++j) {
if (result[j] >= 0.f) {
++ntest;
}
if (result[j] >= *thresh) {
++nfail;
}
/* L100: */
}
if (nfail > 0) {
++ntestf;
}
if (ntestf == 1) {
io___41.ciunit = *nounit;
s_wsfe(&io___41);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
io___42.ciunit = *nounit;
s_wsfe(&io___42);
e_wsfe();
io___43.ciunit = *nounit;
s_wsfe(&io___43);
e_wsfe();
io___44.ciunit = *nounit;
s_wsfe(&io___44);
e_wsfe();
io___45.ciunit = *nounit;
s_wsfe(&io___45);
do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(real));
e_wsfe();
io___46.ciunit = *nounit;
s_wsfe(&io___46);
e_wsfe();
ntestf = 2;
}
for (j = 1; j <= 15; ++j) {
if (result[j] >= *thresh) {
io___47.ciunit = *nounit;
s_wsfe(&io___47);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&iwk, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[j], (ftnlen)sizeof(real)
);
e_wsfe();
}
/* L110: */
}
nerrs += nfail;
ntestt += ntest;
/* L120: */
}
L130:
;
}
/* L140: */
}
L150:
/* Read in data from file to check accuracy of condition estimation */
/* Read input data until N=0 */
jtype = 0;
L160:
io___48.ciunit = *niunit;
i__1 = s_rsle(&io___48);
if (i__1 != 0) {
goto L200;
}
i__1 = do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
if (i__1 != 0) {
goto L200;
}
i__1 = do_lio(&c__3, &c__1, (char *)&nslct, (ftnlen)sizeof(integer));
if (i__1 != 0) {
goto L200;
}
i__1 = e_rsle();
if (i__1 != 0) {
goto L200;
}
if (n == 0) {
goto L200;
}
++jtype;
iseed[1] = jtype;
if (nslct > 0) {
io___49.ciunit = *niunit;
s_rsle(&io___49);
i__1 = nslct;
for (i__ = 1; i__ <= i__1; ++i__) {
do_lio(&c__3, &c__1, (char *)&islct[i__ - 1], (ftnlen)sizeof(
integer));
}
e_rsle();
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___51.ciunit = *niunit;
s_rsle(&io___51);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__4, &c__1, (char *)&a[i__ + j * a_dim1], (ftnlen)sizeof(
real));
}
e_rsle();
/* L170: */
}
io___52.ciunit = *niunit;
s_rsle(&io___52);
do_lio(&c__4, &c__1, (char *)&rcdein, (ftnlen)sizeof(real));
do_lio(&c__4, &c__1, (char *)&rcdvin, (ftnlen)sizeof(real));
e_rsle();
sget24_(&c_true, &c__22, thresh, &iseed[1], nounit, &n, &a[a_offset], lda,
&h__[h_offset], &ht[ht_offset], &wr[1], &wi[1], &wrt[1], &wit[1],
&wrtmp[1], &witmp[1], &vs[vs_offset], ldvs, &vs1[vs1_offset], &
rcdein, &rcdvin, &nslct, islct, &result[1], &work[1], lwork, &
iwork[1], &bwork[1], info);
/* Check for RESULT(j) > THRESH */
ntest = 0;
nfail = 0;
for (j = 1; j <= 17; ++j) {
if (result[j] >= 0.f) {
++ntest;
}
if (result[j] >= *thresh) {
++nfail;
}
/* L180: */
}
if (nfail > 0) {
++ntestf;
}
if (ntestf == 1) {
io___53.ciunit = *nounit;
s_wsfe(&io___53);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
io___54.ciunit = *nounit;
s_wsfe(&io___54);
e_wsfe();
io___55.ciunit = *nounit;
s_wsfe(&io___55);
e_wsfe();
io___56.ciunit = *nounit;
s_wsfe(&io___56);
e_wsfe();
io___57.ciunit = *nounit;
s_wsfe(&io___57);
do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(real));
e_wsfe();
io___58.ciunit = *nounit;
s_wsfe(&io___58);
e_wsfe();
ntestf = 2;
}
for (j = 1; j <= 17; ++j) {
if (result[j] >= *thresh) {
io___59.ciunit = *nounit;
s_wsfe(&io___59);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[j], (ftnlen)sizeof(real));
e_wsfe();
}
/* L190: */
}
nerrs += nfail;
ntestt += ntest;
goto L160;
L200:
/* Summary */
slasum_(path, nounit, &nerrs, &ntestt);
return 0;
/* End of SDRVSX */
} /* sdrvsx_ */
/* Subroutine */ int dverk_(integer *n, S_fp fcn, doublereal *x, doublereal *
y, doublereal *xend, doublereal *tol, integer *ind, doublereal *c__,
integer *nw, doublereal *w)
{
/* Format strings */
static char fmt_505[] = "(///\0020\002,\002computation stopped in dverk "
"with the following values - \002/\0020\002,\002ind =\002,i4,5x"
",\002tol =\002,1pd13.6,5x,\002x =\002,1pd22.15/\002 "
"\002,\002n =\002,i4,5x,\002hmin =\002,1pd13.6,5x,\002xend "
" =\002,1pd22.15/\002 \002,\002nw =\002,i4,5x,\002hmax =\002,1pd"
"13.6,5x,\002prev xend =\002,1pd22.15/\0020\002,14x,\002no of suc"
"cessful steps =\002,0pf8.0/\002 \002,14x,\002no of successive"
" failures =\002,0pf8.0/\002 \002,14x,\002no of function evals "
" =\002,0pf8.0/\0020\002,\002the components of y are\002//(\002 "
"\002,1pd24.15))";
/* System generated locals */
integer w_dim1, w_offset, i__1;
doublereal d__1, d__2, d__3, d__4, d__5, d__6;
/* Builtin functions */
double pow_dd(doublereal *, doublereal *), d_sign(doublereal *,
doublereal *);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Subroutine */ int s_stop(char *, ftnlen);
/* Local variables */
static integer k;
static doublereal temp;
/* Fortran I/O blocks */
static cilist io___3 = { 0, 6, 0, fmt_505, 0 };
/* *********************************************************************** */
/* * */
/* note added 11/14/85. * */
/* * */
/* if you discover any errors in this subroutine, please contact * */
/* * */
/* kenneth r. jackson * */
/* department of computer science * */
/* university of toronto * */
/* toronto, ontario, * */
/* canada m5s 1a4 * */
/* * */
/* phone: 416-978-7075 * */
/* * */
/* electronic mail: * */
/* uucp: {cornell,decvax,ihnp4,linus,uw-beaver}!utcsri!krj * */
/* csnet: krj@toronto * */
/* arpa: krj.toronto@csnet-relay * */
/* bitnet: krj%[email protected] * */
/* * */
/* dverk is written in fortran 66. * */
/* * */
/* the constants dwarf and rreb -- c(10) and c(11), respectively -- are * */
/* set for a vax in double precision. they should be reset, as * */
/* described below, if this program is run on another machine. * */
/* * */
/* the c array is declared in this subroutine to have one element only, * */
/* although more elements are referenced in this subroutine. this * */
/* causes some compilers to issue warning messages. there is, though, * */
/* no error provided c is declared sufficiently large in the calling * */
/* program, as described below. * */
/* * */
/* the following external statement for fcn was added to avoid a * */
/* warning message from the unix f77 compiler. the original dverk * */
/* comments and code follow it. * */
/* * */
/* *********************************************************************** */
/* *********************************************************************** */
/* * */
/* purpose - this is a runge-kutta subroutine based on verner's * */
/* fifth and sixth order pair of formulas for finding approximations to * */
/* the solution of a system of first order ordinary differential * */
/* equations with initial conditions. it attempts to keep the global * */
/* error proportional to a tolerance specified by the user. (the * */
/* proportionality depends on the kind of error control that is used, * */
/* as well as the differential equation and the range of integration.) * */
/* * */
/* various options are available to the user, including different * */
/* kinds of error control, restrictions on step sizes, and interrupts * */
/* which permit the user to examine the state of the calculation (and * */
/* perhaps make modifications) during intermediate stages. * */
/* * */
/* the program is efficient for non-stiff systems. however, a good * */
/* variable-order-adams method will probably be more efficient if the * */
/* function evaluations are very costly. such a method would also be * */
/* more suitable if one wanted to obtain a large number of intermediate * */
/* solution values by interpolation, as might be the case for example * */
/* with graphical output. * */
/* * */
/* hull-enright-jackson 1/10/76 * */
/* * */
/* *********************************************************************** */
/* * */
/* use - the user must specify each of the following * */
/* * */
/* n number of equations * */
/* * */
/* fcn name of subroutine for evaluating functions - the subroutine * */
/* itself must also be provided by the user - it should be of * */
/* the following form * */
/* subroutine fcn(n, x, y, yprime) * */
/* integer n * */
/* double precision x, y(n), yprime(n) * */
/* *** etc *** * */
/* and it should evaluate yprime, given n, x and y * */
/* * */
/* x independent variable - initial value supplied by user * */
/* * */
/* y dependent variable - initial values of components y(1), y(2), * */
/* ..., y(n) supplied by user * */
/* * */
/* xend value of x to which integration is to be carried out - it may * */
/* be less than the initial value of x * */
/* * */
/* tol tolerance - the subroutine attempts to control a norm of the * */
/* local error in such a way that the global error is * */
/* proportional to tol. in some problems there will be enough * */
/* damping of errors, as well as some cancellation, so that * */
/* the global error will be less than tol. alternatively, the * */
/* control can be viewed as attempting to provide a * */
/* calculated value of y at xend which is the exact solution * */
/* to the problem y' = f(x,y) + e(x) where the norm of e(x) * */
/* is proportional to tol. (the norm is a max norm with * */
/* weights that depend on the error control strategy chosen * */
/* by the user. the default weight for the k-th component is * */
/* 1/max(1,abs(y(k))), which therefore provides a mixture of * */
/* absolute and relative error control.) * */
/* * */
/* ind indicator - on initial entry ind must be set equal to either * */
/* 1 or 2. if the user does not wish to use any options, he * */
/* should set ind to 1 - all that remains for the user to do * */
/* then is to declare c and w, and to specify nw. the user * */
/* may also select various options on initial entry by * */
/* setting ind = 2 and initializing the first 9 components of * */
/* c as described in the next section. he may also re-enter * */
/* the subroutine with ind = 3 as mentioned again below. in * */
/* any event, the subroutine returns with ind equal to * */
/* 3 after a normal return * */
/* 4, 5, or 6 after an interrupt (see options c(8), c(9)) * */
/* -1, -2, or -3 after an error condition (see below) * */
/* * */
/* c communications vector - the dimension must be greater than or * */
/* equal to 24, unless option c(1) = 4 or 5 is used, in which * */
/* case the dimension must be greater than or equal to n+30 * */
/* * */
/* nw first dimension of workspace w - must be greater than or * */
/* equal to n * */
/* * */
/* w workspace matrix - first dimension must be nw and second must * */
/* be greater than or equal to 9 * */
/* * */
/* the subroutine will normally return with ind = 3, having * */
/* replaced the initial values of x and y with, respectively, the value * */
/* of xend and an approximation to y at xend. the subroutine can be * */
/* called repeatedly with new values of xend without having to change * */
/* any other argument. however, changes in tol, or any of the options * */
/* described below, may also be made on such a re-entry if desired. * */
/* * */
/* three error returns are also possible, in which case x and y * */
/* will be the most recently accepted values - * */
/* with ind = -3 the subroutine was unable to satisfy the error * */
/* requirement with a particular step-size that is less than or * */
/* equal to hmin, which may mean that tol is too small * */
/* with ind = -2 the value of hmin is greater than hmax, which * */
/* probably means that the requested tol (which is used in the * */
/* calculation of hmin) is too small * */
/* with ind = -1 the allowed maximum number of fcn evaluations has * */
/* been exceeded, but this can only occur if option c(7), as * */
/* described in the next section, has been used * */
/* * */
/* there are several circumstances that will cause the calculations * */
/* to be terminated, along with output of information that will help * */
/* the user determine the cause of the trouble. these circumstances * */
/* involve entry with illegal or inconsistent values of the arguments, * */
/* such as attempting a normal re-entry without first changing the * */
/* value of xend, or attempting to re-enter with ind less than zero. * */
/* * */
/* *********************************************************************** */
/* * */
/* options - if the subroutine is entered with ind = 1, the first 9 * */
/* components of the communications vector are initialized to zero, and * */
/* the subroutine uses only default values for each option. if the * */
/* subroutine is entered with ind = 2, the user must specify each of * */
/* these 9 components - normally he would first set them all to zero, * */
/* and then make non-zero those that correspond to the particular * */
/* options he wishes to select. in any event, options may be changed on * */
/* re-entry to the subroutine - but if the user changes any of the * */
/* options, or tol, in the course of a calculation he should be careful * */
/* about how such changes affect the subroutine - it may be better to * */
/* restart with ind = 1 or 2. (components 10 to 24 of c are used by the * */
/* program - the information is available to the user, but should not * */
/* normally be changed by him.) * */
/* * */
/* c(1) error control indicator - the norm of the local error is the * */
/* max norm of the weighted error estimate vector, the * */
/* weights being determined according to the value of c(1) - * */
/* if c(1)=1 the weights are 1 (absolute error control) * */
/* if c(1)=2 the weights are 1/abs(y(k)) (relative error * */
/* control) * */
/* if c(1)=3 the weights are 1/max(abs(c(2)),abs(y(k))) * */
/* (relative error control, unless abs(y(k)) is less * */
/* than the floor value, abs(c(2)) ) * */
/* if c(1)=4 the weights are 1/max(abs(c(k+30)),abs(y(k))) * */
/* (here individual floor values are used) * */
/* if c(1)=5 the weights are 1/abs(c(k+30)) * */
/* for all other values of c(1), including c(1) = 0, the * */
/* default values of the weights are taken to be * */
/* 1/max(1,abs(y(k))), as mentioned earlier * */
/* (in the two cases c(1) = 4 or 5 the user must declare the * */
/* dimension of c to be at least n+30 and must initialize the * */
/* components c(31), c(32), ..., c(n+30).) * */
/* * */
/* c(2) floor value - used when the indicator c(1) has the value 3 * */
/* * */
/* c(3) hmin specification - if not zero, the subroutine chooses hmin * */
/* to be abs(c(3)) - otherwise it uses the default value * */
/* 10*max(dwarf,rreb*max(weighted norm y/tol,abs(x))), * */
/* where dwarf is a very small positive machine number and * */
/* rreb is the relative roundoff error bound * */
/* * */
/* c(4) hstart specification - if not zero, the subroutine will use * */
/* an initial hmag equal to abs(c(4)), except of course for * */
/* the restrictions imposed by hmin and hmax - otherwise it * */
/* uses the default value of hmax*(tol)**(1/6) * */
/* * */
/* c(5) scale specification - this is intended to be a measure of the * */
/* scale of the problem - larger values of scale tend to make * */
/* the method more reliable, first by possibly restricting * */
/* hmax (as described below) and second, by tightening the * */
/* acceptance requirement - if c(5) is zero, a default value * */
/* of 1 is used. for linear homogeneous problems with * */
/* constant coefficients, an appropriate value for scale is a * */
/* norm of the associated matrix. for other problems, an * */
/* approximation to an average value of a norm of the * */
/* jacobian along the trajectory may be appropriate * */
/* * */
/* c(6) hmax specification - four cases are possible * */
/* if c(6).ne.0 and c(5).ne.0, hmax is taken to be * */
/* min(abs(c(6)),2/abs(c(5))) * */
/* if c(6).ne.0 and c(5).eq.0, hmax is taken to be abs(c(6)) * */
/* if c(6).eq.0 and c(5).ne.0, hmax is taken to be * */
/* 2/abs(c(5)) * */
/* if c(6).eq.0 and c(5).eq.0, hmax is given a default value * */
/* of 2 * */
/* * */
/* c(7) maximum number of function evaluations - if not zero, an * */
/* error return with ind = -1 will be caused when the number * */
/* of function evaluations exceeds abs(c(7)) * */
/* * */
/* c(8) interrupt number 1 - if not zero, the subroutine will * */
/* interrupt the calculations after it has chosen its * */
/* preliminary value of hmag, and just before choosing htrial * */
/* and xtrial in preparation for taking a step (htrial may * */
/* differ from hmag in sign, and may require adjustment if * */
/* xend is near) - the subroutine returns with ind = 4, and * */
/* will resume calculation at the point of interruption if * */
/* re-entered with ind = 4 * */
/* * */
/* c(9) interrupt number 2 - if not zero, the subroutine will * */
/* interrupt the calculations immediately after it has * */
/* decided whether or not to accept the result of the most * */
/* recent trial step, with ind = 5 if it plans to accept, or * */
/* ind = 6 if it plans to reject - y(*) is the previously * */
/* accepted result, while w(*,9) is the newly computed trial * */
/* value, and w(*,2) is the unweighted error estimate vector. * */
/* the subroutine will resume calculations at the point of * */
/* interruption on re-entry with ind = 5 or 6. (the user may * */
/* change ind in this case if he wishes, for example to force * */
/* acceptance of a step that would otherwise be rejected, or * */
/* vice versa. he can also restart with ind = 1 or 2.) * */
/* * */
/* *********************************************************************** */
/* * */
/* summary of the components of the communications vector * */
/* * */
/* prescribed at the option determined by the program * */
/* of the user * */
/* * */
/* c(10) rreb(rel roundoff err bnd) * */
/* c(1) error control indicator c(11) dwarf (very small mach no) * */
/* c(2) floor value c(12) weighted norm y * */
/* c(3) hmin specification c(13) hmin * */
/* c(4) hstart specification c(14) hmag * */
/* c(5) scale specification c(15) scale * */
/* c(6) hmax specification c(16) hmax * */
/* c(7) max no of fcn evals c(17) xtrial * */
/* c(8) interrupt no 1 c(18) htrial * */
/* c(9) interrupt no 2 c(19) est * */
/* c(20) previous xend * */
/* c(21) flag for xend * */
/* c(22) no of successful steps * */
/* c(23) no of successive failures * */
/* c(24) no of fcn evals * */
/* * */
/* if c(1) = 4 or 5, c(31), c(32), ... c(n+30) are floor values * */
/* * */
/* *********************************************************************** */
/* * */
/* an overview of the program * */
/* * */
/* begin initialization, parameter checking, interrupt re-entries * */
/* ......abort if ind out of range 1 to 6 * */
/* . cases - initial entry, normal re-entry, interrupt re-entries * */
/* . case 1 - initial entry (ind .eq. 1 or 2) * */
/* v........abort if n.gt.nw or tol.le.0 * */
/* . if initial entry without options (ind .eq. 1) * */
/* . set c(1) to c(9) equal to zero * */
/* . else initial entry with options (ind .eq. 2) * */
/* . make c(1) to c(9) non-negative * */
/* . make floor values non-negative if they are to be used * */
/* . end if * */
/* . initialize rreb, dwarf, prev xend, flag, counts * */
/* . case 2 - normal re-entry (ind .eq. 3) * */
/* .........abort if xend reached, and either x changed or xend not * */
/* . re-initialize flag * */
/* . case 3 - re-entry following an interrupt (ind .eq. 4 to 6) * */
/* v transfer control to the appropriate re-entry point....... * */
/* . end cases . * */
/* . end initialization, etc. . * */
/* . v * */
/* . loop through the following 4 stages, once for each trial step . * */
/* . stage 1 - prepare . * */
/* ***********error return (with ind=-1) if no of fcn evals too great . * */
/* . calc slope (adding 1 to no of fcn evals) if ind .ne. 6 . * */
/* . calc hmin, scale, hmax . * */
/* ***********error return (with ind=-2) if hmin .gt. hmax . * */
/* . calc preliminary hmag . * */
/* ***********interrupt no 1 (with ind=4) if requested.......re-entry.v * */
/* . calc hmag, xtrial and htrial . * */
/* . end stage 1 . * */
/* v stage 2 - calc ytrial (adding 7 to no of fcn evals) . * */
/* . stage 3 - calc the error estimate . * */
/* . stage 4 - make decisions . * */
/* . set ind=5 if step acceptable, else set ind=6 . * */
/* ***********interrupt no 2 if requested....................re-entry.v * */
/* . if step accepted (ind .eq. 5) * */
/* . update x, y from xtrial, ytrial * */
/* . add 1 to no of successful steps * */
/* . set no of successive failures to zero * */
/* **************return(with ind=3, xend saved, flag set) if x .eq. xend * */
/* . else step not accepted (ind .eq. 6) * */
/* . add 1 to no of successive failures * */
/* **************error return (with ind=-3) if hmag .le. hmin * */
/* . end if * */
/* . end stage 4 * */
/* . end loop * */
/* . * */
/* begin abort action * */
/* output appropriate message about stopping the calculations, * */
/* along with values of ind, n, nw, tol, hmin, hmax, x, xend, * */
/* previous xend, no of successful steps, no of successive * */
/* failures, no of fcn evals, and the components of y * */
/* stop * */
/* end abort action * */
/* * */
/* *********************************************************************** */
/* ****************************************************************** */
/* * begin initialization, parameter checking, interrupt re-entries * */
/* ****************************************************************** */
/* ......abort if ind out of range 1 to 6 */
/* Parameter adjustments */
--y;
--c__;
w_dim1 = *nw;
w_offset = 1 + w_dim1;
w -= w_offset;
/* Function Body */
if (*ind < 1 || *ind > 6) {
goto L500;
}
/* cases - initial entry, normal re-entry, interrupt re-entries */
switch (*ind) {
case 1: goto L5;
case 2: goto L5;
case 3: goto L45;
case 4: goto L1111;
case 5: goto L2222;
case 6: goto L2222;
}
/* case 1 - initial entry (ind .eq. 1 or 2) */
/* .........abort if n.gt.nw or tol.le.0 */
L5:
if (*n > *nw || *tol <= 0.) {
goto L500;
}
if (*ind == 2) {
goto L15;
}
/* initial entry without options (ind .eq. 1) */
/* set c(1) to c(9) equal to 0 */
for (k = 1; k <= 9; ++k) {
c__[k] = 0.;
/* L10: */
}
goto L35;
L15:
/* initial entry with options (ind .eq. 2) */
/* make c(1) to c(9) non-negative */
for (k = 1; k <= 9; ++k) {
c__[k] = (d__1 = c__[k], abs(d__1));
/* L20: */
}
/* make floor values non-negative if they are to be used */
if (c__[1] != 4. && c__[1] != 5.) {
goto L30;
}
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
c__[k + 30] = (d__1 = c__[k + 30], abs(d__1));
/* L25: */
}
L30:
L35:
/* initialize rreb, dwarf, prev xend, flag, counts */
c__[10] = 1.3877787807814457e-17;
c__[11] = 1e-35;
/* set previous xend initially to initial value of x */
c__[20] = *x;
for (k = 21; k <= 24; ++k) {
c__[k] = 0.;
/* L40: */
}
goto L50;
/* case 2 - normal re-entry (ind .eq. 3) */
/* .........abort if xend reached, and either x changed or xend not */
L45:
if (c__[21] != 0. && (*x != c__[20] || *xend == c__[20])) {
goto L500;
}
/* re-initialize flag */
c__[21] = 0.;
goto L50;
/* case 3 - re-entry following an interrupt (ind .eq. 4 to 6) */
/* transfer control to the appropriate re-entry point.......... */
/* this has already been handled by the computed go to . */
/* end cases v */
L50:
/* end initialization, etc. */
/* ****************************************************************** */
/* * loop through the following 4 stages, once for each trial step * */
/* * until the occurrence of one of the following * */
/* * (a) the normal return (with ind .eq. 3) on reaching xend in * */
/* * stage 4 * */
/* * (b) an error return (with ind .lt. 0) in stage 1 or stage 4 * */
/* * (c) an interrupt return (with ind .eq. 4, 5 or 6), if * */
/* * requested, in stage 1 or stage 4 * */
/* ****************************************************************** */
L99999:
/* *************************************************************** */
/* * stage 1 - prepare - do calculations of hmin, hmax, etc., * */
/* * and some parameter checking, and end up with suitable * */
/* * values of hmag, xtrial and htrial in preparation for taking * */
/* * an integration step. * */
/* *************************************************************** */
/* ***********error return (with ind=-1) if no of fcn evals too great */
if (c__[7] == 0. || c__[24] < c__[7]) {
goto L100;
}
*ind = -1;
return 0;
L100:
/* calculate slope (adding 1 to no of fcn evals) if ind .ne. 6 */
if (*ind == 6) {
goto L105;
}
(*fcn)(n, x, &y[1], &w[w_dim1 + 1]);
c__[24] += 1.;
L105:
/* calculate hmin - use default unless value prescribed */
c__[13] = c__[3];
if (c__[3] != 0.) {
goto L165;
}
/* calculate default value of hmin */
/* first calculate weighted norm y - c(12) - as specified */
/* by the error control indicator c(1) */
temp = 0.;
if (c__[1] != 1.) {
goto L115;
}
/* absolute error control - weights are 1 */
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
/* Computing MAX */
d__2 = temp, d__3 = (d__1 = y[k], abs(d__1));
temp = max(d__2,d__3);
/* L110: */
}
c__[12] = temp;
goto L160;
L115:
if (c__[1] != 2.) {
goto L120;
}
/* relative error control - weights are 1/dabs(y(k)) so */
/* weighted norm y is 1 */
c__[12] = 1.;
goto L160;
L120:
if (c__[1] != 3.) {
goto L130;
}
/* weights are 1/max(c(2),abs(y(k))) */
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
/* Computing MAX */
d__2 = temp, d__3 = (d__1 = y[k], abs(d__1)) / c__[2];
temp = max(d__2,d__3);
/* L125: */
}
c__[12] = min(temp,1.);
goto L160;
L130:
if (c__[1] != 4.) {
goto L140;
}
/* weights are 1/max(c(k+30),abs(y(k))) */
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
/* Computing MAX */
d__2 = temp, d__3 = (d__1 = y[k], abs(d__1)) / c__[k + 30];
temp = max(d__2,d__3);
/* L135: */
}
c__[12] = min(temp,1.);
goto L160;
L140:
if (c__[1] != 5.) {
goto L150;
}
/* weights are 1/c(k+30) */
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
/* Computing MAX */
d__2 = temp, d__3 = (d__1 = y[k], abs(d__1)) / c__[k + 30];
temp = max(d__2,d__3);
/* L145: */
}
c__[12] = temp;
goto L160;
L150:
/* default case - weights are 1/max(1,abs(y(k))) */
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
/* Computing MAX */
d__2 = temp, d__3 = (d__1 = y[k], abs(d__1));
temp = max(d__2,d__3);
/* L155: */
}
c__[12] = min(temp,1.);
L160:
/* Computing MAX */
/* Computing MAX */
d__3 = c__[12] / *tol, d__4 = abs(*x);
d__1 = c__[11], d__2 = c__[10] * max(d__3,d__4);
c__[13] = max(d__1,d__2) * 10.;
L165:
/* calculate scale - use default unless value prescribed */
c__[15] = c__[5];
if (c__[5] == 0.) {
c__[15] = 1.;
}
/* calculate hmax - consider 4 cases */
/* case 1 both hmax and scale prescribed */
if (c__[6] != 0. && c__[5] != 0.) {
/* Computing MIN */
d__1 = c__[6], d__2 = 2. / c__[5];
c__[16] = min(d__1,d__2);
}
/* case 2 - hmax prescribed, but scale not */
if (c__[6] != 0. && c__[5] == 0.) {
c__[16] = c__[6];
}
/* case 3 - hmax not prescribed, but scale is */
if (c__[6] == 0. && c__[5] != 0.) {
c__[16] = 2. / c__[5];
}
/* case 4 - neither hmax nor scale is provided */
if (c__[6] == 0. && c__[5] == 0.) {
c__[16] = 2.;
}
/* ***********error return (with ind=-2) if hmin .gt. hmax */
if (c__[13] <= c__[16]) {
goto L170;
}
*ind = -2;
return 0;
L170:
/* calculate preliminary hmag - consider 3 cases */
if (*ind > 2) {
goto L175;
}
/* case 1 - initial entry - use prescribed value of hstart, if */
/* any, else default */
c__[14] = c__[4];
if (c__[4] == 0.) {
c__[14] = c__[16] * pow_dd(tol, &c_b32);
}
goto L185;
L175:
if (c__[23] > 1.) {
goto L180;
}
/* case 2 - after a successful step, or at most one failure, */
/* use min(2, .9*(tol/est)**(1/6))*hmag, but avoid possible */
/* overflow. then avoid reduction by more than half. */
temp = c__[14] * 2.;
if (*tol < c__[19] * 120.42729108217097) {
d__1 = *tol / c__[19];
temp = pow_dd(&d__1, &c_b32) * .9 * c__[14];
}
/* Computing MAX */
d__1 = temp, d__2 = c__[14] * .5;
c__[14] = max(d__1,d__2);
goto L185;
L180:
/* case 3 - after two or more successive failures */
c__[14] *= .5;
L185:
/* check against hmax */
c__[14] = min(c__[14],c__[16]);
/* check against hmin */
c__[14] = max(c__[14],c__[13]);
/* ***********interrupt no 1 (with ind=4) if requested */
if (c__[8] == 0.) {
goto L1111;
}
*ind = 4;
return 0;
/* resume here on re-entry with ind .eq. 4 ........re-entry.. */
L1111:
/* calculate hmag, xtrial - depending on preliminary hmag, xend */
if (c__[14] >= (d__1 = *xend - *x, abs(d__1))) {
goto L190;
}
/* do not step more than half way to xend */
/* Computing MIN */
d__2 = c__[14], d__3 = (d__1 = *xend - *x, abs(d__1)) * .5;
c__[14] = min(d__2,d__3);
d__1 = *xend - *x;
c__[17] = *x + d_sign(&c__[14], &d__1);
goto L195;
L190:
/* hit xend exactly */
c__[14] = (d__1 = *xend - *x, abs(d__1));
c__[17] = *xend;
L195:
/* calculate htrial */
c__[18] = c__[17] - *x;
/* end stage 1 */
/* *************************************************************** */
/* * stage 2 - calculate ytrial (adding 7 to no of fcn evals). * */
/* * w(*,2), ... w(*,8) hold intermediate results needed in * */
/* * stage 3. w(*,9) is temporary storage until finally it holds * */
/* * ytrial. * */
/* *************************************************************** */
temp = c__[18] / 1.39816908e12;
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
w[k + w_dim1 * 9] = y[k] + temp * w[k + w_dim1] * 2.3302818e11;
/* L200: */
}
d__1 = *x + c__[18] / 6.;
(*fcn)(n, &d__1, &w[w_dim1 * 9 + 1], &w[(w_dim1 << 1) + 1]);
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
w[k + w_dim1 * 9] = y[k] + temp * (w[k + w_dim1] * 74569017600. + w[k
+ (w_dim1 << 1)] * 298276070400.);
/* L205: */
}
d__1 = *x + c__[18] * .26666666666666666;
(*fcn)(n, &d__1, &w[w_dim1 * 9 + 1], &w[w_dim1 * 3 + 1]);
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
w[k + w_dim1 * 9] = y[k] + temp * (w[k + w_dim1] * 1.1651409e12 - w[k
+ (w_dim1 << 1)] * 3.72845088e12 + w[k + w_dim1 * 3] *
3.4954227e12);
/* L210: */
}
d__1 = *x + c__[18] * .66666666666666663;
(*fcn)(n, &d__1, &w[w_dim1 * 9 + 1], &w[(w_dim1 << 2) + 1]);
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
w[k + w_dim1 * 9] = y[k] + temp * (-w[k + w_dim1] * 3604654659375. +
w[k + (w_dim1 << 1)] * 1.28165499e13 - w[k + w_dim1 * 3] *
9284716546875. + w[k + (w_dim1 << 2)] * 1237962206250.);
/* L215: */
}
d__1 = *x + c__[18] * .83333333333333337;
(*fcn)(n, &d__1, &w[w_dim1 * 9 + 1], &w[w_dim1 * 5 + 1]);
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
w[k + w_dim1 * 9] = y[k] + temp * (w[k + w_dim1] * 3.355605792e12 - w[
k + (w_dim1 << 1)] * 1.118535264e13 + w[k + w_dim1 * 3] *
9.17262885e12 - w[k + (w_dim1 << 2)] * 4.2721833e11 + w[k +
w_dim1 * 5] * 4.82505408e11);
/* L220: */
}
d__1 = *x + c__[18];
(*fcn)(n, &d__1, &w[w_dim1 * 9 + 1], &w[w_dim1 * 6 + 1]);
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
w[k + w_dim1 * 9] = y[k] + temp * (-w[k + w_dim1] * 770204740536. + w[
k + (w_dim1 << 1)] * 2311639545600. - w[k + w_dim1 * 3] *
1.322092233e12 - w[k + (w_dim1 << 2)] * 453006781920. + w[k +
w_dim1 * 5] * 326875481856.);
/* L225: */
}
d__1 = *x + c__[18] / 15.;
(*fcn)(n, &d__1, &w[w_dim1 * 9 + 1], &w[w_dim1 * 7 + 1]);
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
w[k + w_dim1 * 9] = y[k] + temp * (w[k + w_dim1] * 2.845924389e12 - w[
k + (w_dim1 << 1)] * 9.754668e12 + w[k + w_dim1 * 3] *
7.897110375e12 - w[k + (w_dim1 << 2)] * 1.9208266e11 + w[k +
w_dim1 * 5] * 4.00298976e11 + w[k + w_dim1 * 7] * 2.01586e11);
/* L230: */
}
d__1 = *x + c__[18];
(*fcn)(n, &d__1, &w[w_dim1 * 9 + 1], &w[(w_dim1 << 3) + 1]);
/* calculate ytrial, the extrapolated approximation and store */
/* in w(*,9) */
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
w[k + w_dim1 * 9] = y[k] + temp * (w[k + w_dim1] * 1.04862681e11 + w[
k + w_dim1 * 3] * 5.4518625e11 + w[k + (w_dim1 << 2)] *
4.46637345e11 + w[k + w_dim1 * 5] * 1.88806464e11 + w[k +
w_dim1 * 7] * 1.5076875e10 + w[k + (w_dim1 << 3)] *
9.7599465e10);
/* L235: */
}
/* add 7 to the no of fcn evals */
c__[24] += 7.;
/* end stage 2 */
/* *************************************************************** */
/* * stage 3 - calculate the error estimate est. first calculate * */
/* * the unweighted absolute error estimate vector (per unit * */
/* * step) for the unextrapolated approximation and store it in * */
/* * w(*,2). then calculate the weighted max norm of w(*,2) as * */
/* * specified by the error control indicator c(1). finally, * */
/* * modify this result to produce est, the error estimate (per * */
/* * unit step) for the extrapolated approximation ytrial. * */
/* *************************************************************** */
/* calculate the unweighted absolute error estimate vector */
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
w[k + (w_dim1 << 1)] = (w[k + w_dim1] * 8738556750. + w[k + w_dim1 *
3] * 9735468750. - w[k + (w_dim1 << 2)] * 9709507500. + w[k +
w_dim1 * 5] * 8.582112e9 + w[k + w_dim1 * 6] * 9.532971e10 -
w[k + w_dim1 * 7] * 1.5076875e10 - w[k + (w_dim1 << 3)] *
9.7599465e10) / 1.39816908e12;
/* L300: */
}
/* calculate the weighted max norm of w(*,2) as specified by */
/* the error control indicator c(1) */
temp = 0.;
if (c__[1] != 1.) {
goto L310;
}
/* absolute error control */
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
/* Computing MAX */
d__2 = temp, d__3 = (d__1 = w[k + (w_dim1 << 1)], abs(d__1));
temp = max(d__2,d__3);
/* L305: */
}
goto L360;
L310:
if (c__[1] != 2.) {
goto L320;
}
/* relative error control */
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
/* Computing MAX */
d__2 = temp, d__3 = (d__1 = w[k + (w_dim1 << 1)] / y[k], abs(d__1));
temp = max(d__2,d__3);
/* L315: */
}
goto L360;
L320:
if (c__[1] != 3.) {
goto L330;
}
/* weights are 1/max(c(2),abs(y(k))) */
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
/* Computing MAX */
/* Computing MAX */
d__5 = c__[2], d__6 = (d__2 = y[k], abs(d__2));
d__3 = temp, d__4 = (d__1 = w[k + (w_dim1 << 1)], abs(d__1)) / max(
d__5,d__6);
temp = max(d__3,d__4);
/* L325: */
}
goto L360;
L330:
if (c__[1] != 4.) {
goto L340;
}
/* weights are 1/max(c(k+30),abs(y(k))) */
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
/* Computing MAX */
/* Computing MAX */
d__5 = c__[k + 30], d__6 = (d__2 = y[k], abs(d__2));
d__3 = temp, d__4 = (d__1 = w[k + (w_dim1 << 1)], abs(d__1)) / max(
d__5,d__6);
temp = max(d__3,d__4);
/* L335: */
}
goto L360;
L340:
if (c__[1] != 5.) {
goto L350;
}
/* weights are 1/c(k+30) */
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
/* Computing MAX */
d__2 = temp, d__3 = (d__1 = w[k + (w_dim1 << 1)] / c__[k + 30], abs(
d__1));
temp = max(d__2,d__3);
/* L345: */
}
goto L360;
L350:
/* default case - weights are 1/max(1,abs(y(k))) */
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
/* Computing MAX */
/* Computing MAX */
d__5 = 1., d__6 = (d__2 = y[k], abs(d__2));
d__3 = temp, d__4 = (d__1 = w[k + (w_dim1 << 1)], abs(d__1)) / max(
d__5,d__6);
temp = max(d__3,d__4);
/* L355: */
}
L360:
/* calculate est - (the weighted max norm of w(*,2))*hmag*scale */
/* - est is intended to be a measure of the error per unit */
/* step in ytrial */
c__[19] = temp * c__[14] * c__[15];
/* end stage 3 */
/* *************************************************************** */
/* * stage 4 - make decisions. * */
/* *************************************************************** */
/* set ind=5 if step acceptable, else set ind=6 */
*ind = 5;
if (c__[19] > *tol) {
*ind = 6;
}
/* ***********interrupt no 2 if requested */
if (c__[9] == 0.) {
goto L2222;
}
return 0;
/* resume here on re-entry with ind .eq. 5 or 6 ...re-entry.. */
L2222:
if (*ind == 6) {
goto L410;
}
/* step accepted (ind .eq. 5), so update x, y from xtrial, */
/* ytrial, add 1 to the no of successful steps, and set */
/* the no of successive failures to zero */
*x = c__[17];
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
y[k] = w[k + w_dim1 * 9];
/* L400: */
}
c__[22] += 1.;
c__[23] = 0.;
/* **************return(with ind=3, xend saved, flag set) if x .eq. xend */
if (*x != *xend) {
goto L405;
}
*ind = 3;
c__[20] = *xend;
c__[21] = 1.;
return 0;
L405:
goto L420;
L410:
/* step not accepted (ind .eq. 6), so add 1 to the no of */
/* successive failures */
c__[23] += 1.;
/* **************error return (with ind=-3) if hmag .le. hmin */
if (c__[14] > c__[13]) {
goto L415;
}
*ind = -3;
return 0;
L415:
L420:
/* end stage 4 */
goto L99999;
/* end loop */
/* begin abort action */
L500:
s_wsfe(&io___3);
do_fio(&c__1, (char *)&(*ind), (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&(*tol), (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&(*x), (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__[13], (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&(*xend), (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&(*nw), (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__[16], (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&c__[20], (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&c__[22], (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&c__[23], (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&c__[24], (ftnlen)sizeof(doublereal));
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
do_fio(&c__1, (char *)&y[k], (ftnlen)sizeof(doublereal));
}
e_wsfe();
s_stop("", (ftnlen)0);
/* end abort action */
return 0;
} /* dverk_ */
/* Subroutine */ int zchktr_(logical *dotype, integer *nn, integer *nval,
integer *nnb, integer *nbval, integer *nns, integer *nsval,
doublereal *thresh, logical *tsterr, integer *nmax, doublecomplex *a,
doublecomplex *ainv, doublecomplex *b, doublecomplex *x,
doublecomplex *xact, doublecomplex *work, doublereal *rwork, integer *
nout)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
static char uplos[1*2] = "U" "L";
static char transs[1*3] = "N" "T" "C";
/* Format strings */
static char fmt_9999[] = "(\002 UPLO='\002,a1,\002', DIAG='\002,a1,\002'"
", N=\002,i5,\002, NB=\002,i4,\002, type \002,i2,\002, test(\002,"
"i2,\002)= \002,g12.5)";
static char fmt_9998[] = "(\002 UPLO='\002,a1,\002', TRANS='\002,a1,\002"
"', DIAG='\002,a1,\002', N=\002,i5,\002, NB=\002,i4,\002, type"
" \002,i2,\002, test(\002,i2,\002)= \002,g12"
".5)";
static char fmt_9997[] = "(\002 NORM='\002,a1,\002', UPLO ='\002,a1,\002"
"', N=\002,i5,\002,\002,11x,\002 type \002,i2,\002, test(\002,i2"
",\002)=\002,g12.5)";
static char fmt_9996[] = "(1x,a,\002( '\002,a1,\002', '\002,a1,\002', "
"'\002,a1,\002', '\002,a1,\002',\002,i5,\002, ... ), type \002,i2,"
"\002, test(\002,i2,\002)=\002,g12.5)";
/* System generated locals */
address a__1[2], a__2[3], a__3[4];
integer i__1, i__2, i__3[2], i__4, i__5[3], i__6[4];
char ch__1[2], ch__2[3], ch__3[4];
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen), s_cat(char *,
char **, integer *, integer *, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
integer i__, k, n, nb, in, lda, inb;
char diag[1];
integer imat, info;
char path[3];
integer irhs, nrhs;
char norm[1], uplo[1];
integer nrun;
extern /* Subroutine */ int alahd_(integer *, char *);
integer idiag;
doublereal scale;
integer nfail, iseed[4];
extern logical lsame_(char *, char *);
doublereal rcond, anorm;
integer itran;
extern /* Subroutine */ int zget04_(integer *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *, doublereal *, doublereal *
);
char trans[1];
integer iuplo, nerrs;
doublereal dummy;
extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *), ztrt01_(char *, char *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublereal *, doublereal *, doublereal *),
ztrt02_(char *, char *, char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublereal *,
doublereal *), ztrt03_(char *, char *,
char *, integer *, integer *, doublecomplex *, integer *,
doublereal *, doublereal *, doublereal *, doublecomplex *,
integer *, doublecomplex *, integer *, doublecomplex *,
doublereal *);
char xtype[1];
extern /* Subroutine */ int ztrt05_(char *, char *, char *, integer *,
integer *, doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublereal *, doublereal *, doublereal *),
ztrt06_(doublereal *, doublereal *, char *, char *, integer *,
doublecomplex *, integer *, doublereal *, doublereal *), alaerh_(char *, char *, integer *, integer *, char *,
integer *, integer *, integer *, integer *, integer *, integer *,
integer *, integer *, integer *);
doublereal rcondc, rcondi;
extern /* Subroutine */ int alasum_(char *, integer *, integer *, integer
*, integer *);
doublereal rcondo, ainvnm;
extern /* Subroutine */ int xlaenv_(integer *, integer *), zlacpy_(char *,
integer *, integer *, doublecomplex *, integer *, doublecomplex *
, integer *), zlarhs_(char *, char *, char *, char *,
integer *, integer *, integer *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, integer *, integer *);
extern doublereal zlantr_(char *, char *, char *, integer *, integer *,
doublecomplex *, integer *, doublereal *);
doublereal result[9];
extern /* Subroutine */ int zlatrs_(char *, char *, char *, char *,
integer *, doublecomplex *, integer *, doublecomplex *,
doublereal *, doublereal *, integer *), zlattr_(integer *, char *, char *, char *, integer *,
integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, doublereal *, integer *),
ztrcon_(char *, char *, char *, integer *, doublecomplex *,
integer *, doublereal *, doublecomplex *, doublereal *, integer *), zerrtr_(char *, integer *),
ztrrfs_(char *, char *, char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublereal *, doublereal *,
doublecomplex *, doublereal *, integer *),
ztrtri_(char *, char *, integer *, doublecomplex *, integer *,
integer *), ztrtrs_(char *, char *, char *,
integer *, integer *, doublecomplex *, integer *, doublecomplex *,
integer *, integer *);
/* Fortran I/O blocks */
static cilist io___27 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___36 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___38 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___40 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___41 = { 0, 0, 0, fmt_9996, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZCHKTR tests ZTRTRI, -TRS, -RFS, and -CON, and ZLATRS */
/* Arguments */
/* ========= */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* The matrix types to be used for testing. Matrices of type j */
/* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = */
/* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. */
/* NN (input) INTEGER */
/* The number of values of N contained in the vector NVAL. */
/* NVAL (input) INTEGER array, dimension (NN) */
/* The values of the matrix column dimension N. */
/* NNB (input) INTEGER */
/* The number of values of NB contained in the vector NBVAL. */
/* NBVAL (input) INTEGER array, dimension (NNB) */
/* The values of the blocksize NB. */
/* NNS (input) INTEGER */
/* The number of values of NRHS contained in the vector NSVAL. */
/* NSVAL (input) INTEGER array, dimension (NNS) */
/* The values of the number of right hand sides NRHS. */
/* THRESH (input) DOUBLE PRECISION */
/* The threshold value for the test ratios. A result is */
/* included in the output file if RESULT >= THRESH. To have */
/* every test ratio printed, use THRESH = 0. */
/* TSTERR (input) LOGICAL */
/* Flag that indicates whether error exits are to be tested. */
/* NMAX (input) INTEGER */
/* The leading dimension of the work arrays. */
/* NMAX >= the maximum value of N in NVAL. */
/* A (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
/* AINV (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
/* B (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) */
/* where NSMAX is the largest entry in NSVAL. */
/* X (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) */
/* XACT (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) */
/* WORK (workspace) COMPLEX*16 array, dimension */
/* (NMAX*max(3,NSMAX)) */
/* RWORK (workspace) DOUBLE PRECISION array, dimension */
/* (max(NMAX,2*NSMAX)) */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--rwork;
--work;
--xact;
--x;
--b;
--ainv;
--a;
--nsval;
--nbval;
--nval;
--dotype;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* Initialize constants and the random number seed. */
s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17);
s_copy(path + 1, "TR", (ftnlen)2, (ftnlen)2);
nrun = 0;
nfail = 0;
nerrs = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
}
/* Test the error exits */
if (*tsterr) {
zerrtr_(path, nout);
}
infoc_1.infot = 0;
i__1 = *nn;
for (in = 1; in <= i__1; ++in) {
/* Do for each value of N in NVAL */
n = nval[in];
lda = max(1,n);
*(unsigned char *)xtype = 'N';
for (imat = 1; imat <= 10; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (! dotype[imat]) {
goto L80;
}
for (iuplo = 1; iuplo <= 2; ++iuplo) {
/* Do first for UPLO = 'U', then for UPLO = 'L' */
*(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
/* Call ZLATTR to generate a triangular test matrix. */
s_copy(srnamc_1.srnamt, "ZLATTR", (ftnlen)32, (ftnlen)6);
zlattr_(&imat, uplo, "No transpose", diag, iseed, &n, &a[1], &
lda, &x[1], &work[1], &rwork[1], &info);
/* Set IDIAG = 1 for non-unit matrices, 2 for unit. */
if (lsame_(diag, "N")) {
idiag = 1;
} else {
idiag = 2;
}
i__2 = *nnb;
for (inb = 1; inb <= i__2; ++inb) {
/* Do for each blocksize in NBVAL */
nb = nbval[inb];
xlaenv_(&c__1, &nb);
/* + TEST 1 */
/* Form the inverse of A. */
zlacpy_(uplo, &n, &n, &a[1], &lda, &ainv[1], &lda);
s_copy(srnamc_1.srnamt, "ZTRTRI", (ftnlen)32, (ftnlen)6);
ztrtri_(uplo, diag, &n, &ainv[1], &lda, &info);
/* Check error code from ZTRTRI. */
if (info != 0) {
/* Writing concatenation */
i__3[0] = 1, a__1[0] = uplo;
i__3[1] = 1, a__1[1] = diag;
s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
alaerh_(path, "ZTRTRI", &info, &c__0, ch__1, &n, &n, &
c_n1, &c_n1, &nb, &imat, &nfail, &nerrs, nout);
}
/* Compute the infinity-norm condition number of A. */
anorm = zlantr_("I", uplo, diag, &n, &n, &a[1], &lda, &
rwork[1]);
ainvnm = zlantr_("I", uplo, diag, &n, &n, &ainv[1], &lda,
&rwork[1]);
if (anorm <= 0. || ainvnm <= 0.) {
rcondi = 1.;
} else {
rcondi = 1. / anorm / ainvnm;
}
/* Compute the residual for the triangular matrix times */
/* its inverse. Also compute the 1-norm condition number */
/* of A. */
ztrt01_(uplo, diag, &n, &a[1], &lda, &ainv[1], &lda, &
rcondo, &rwork[1], result);
/* Print the test ratio if it is .GE. THRESH. */
if (result[0] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___27.ciunit = *nout;
s_wsfe(&io___27);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, diag, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[0], (ftnlen)sizeof(
doublereal));
e_wsfe();
++nfail;
}
++nrun;
/* Skip remaining tests if not the first block size. */
if (inb != 1) {
goto L60;
}
i__4 = *nns;
for (irhs = 1; irhs <= i__4; ++irhs) {
nrhs = nsval[irhs];
*(unsigned char *)xtype = 'N';
for (itran = 1; itran <= 3; ++itran) {
/* Do for op(A) = A, A**T, or A**H. */
*(unsigned char *)trans = *(unsigned char *)&
transs[itran - 1];
if (itran == 1) {
*(unsigned char *)norm = 'O';
rcondc = rcondo;
} else {
*(unsigned char *)norm = 'I';
rcondc = rcondi;
}
/* + TEST 2 */
/* Solve and compute residual for op(A)*x = b. */
s_copy(srnamc_1.srnamt, "ZLARHS", (ftnlen)32, (
ftnlen)6);
zlarhs_(path, xtype, uplo, trans, &n, &n, &c__0, &
idiag, &nrhs, &a[1], &lda, &xact[1], &lda,
&b[1], &lda, iseed, &info);
*(unsigned char *)xtype = 'C';
zlacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &
lda);
s_copy(srnamc_1.srnamt, "ZTRTRS", (ftnlen)32, (
ftnlen)6);
ztrtrs_(uplo, trans, diag, &n, &nrhs, &a[1], &lda,
&x[1], &lda, &info);
/* Check error code from ZTRTRS. */
if (info != 0) {
/* Writing concatenation */
i__5[0] = 1, a__2[0] = uplo;
i__5[1] = 1, a__2[1] = trans;
i__5[2] = 1, a__2[2] = diag;
s_cat(ch__2, a__2, i__5, &c__3, (ftnlen)3);
alaerh_(path, "ZTRTRS", &info, &c__0, ch__2, &
n, &n, &c_n1, &c_n1, &nrhs, &imat, &
nfail, &nerrs, nout);
}
/* This line is needed on a Sun SPARCstation. */
if (n > 0) {
dummy = a[1].r;
}
ztrt02_(uplo, trans, diag, &n, &nrhs, &a[1], &lda,
&x[1], &lda, &b[1], &lda, &work[1], &
rwork[1], &result[1]);
/* + TEST 3 */
/* Check solution from generated exact solution. */
zget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[2]);
/* + TESTS 4, 5, and 6 */
/* Use iterative refinement to improve the solution */
/* and compute error bounds. */
s_copy(srnamc_1.srnamt, "ZTRRFS", (ftnlen)32, (
ftnlen)6);
ztrrfs_(uplo, trans, diag, &n, &nrhs, &a[1], &lda,
&b[1], &lda, &x[1], &lda, &rwork[1], &
rwork[nrhs + 1], &work[1], &rwork[(nrhs <<
1) + 1], &info);
/* Check error code from ZTRRFS. */
if (info != 0) {
/* Writing concatenation */
i__5[0] = 1, a__2[0] = uplo;
i__5[1] = 1, a__2[1] = trans;
i__5[2] = 1, a__2[2] = diag;
s_cat(ch__2, a__2, i__5, &c__3, (ftnlen)3);
alaerh_(path, "ZTRRFS", &info, &c__0, ch__2, &
n, &n, &c_n1, &c_n1, &nrhs, &imat, &
nfail, &nerrs, nout);
}
zget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[3]);
ztrt05_(uplo, trans, diag, &n, &nrhs, &a[1], &lda,
&b[1], &lda, &x[1], &lda, &xact[1], &lda,
&rwork[1], &rwork[nrhs + 1], &result[4]);
/* Print information about the tests that did not */
/* pass the threshold. */
for (k = 2; k <= 6; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___36.ciunit = *nout;
s_wsfe(&io___36);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, diag, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&nrhs, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[k - 1], (
ftnlen)sizeof(doublereal));
e_wsfe();
++nfail;
}
/* L20: */
}
nrun += 5;
/* L30: */
}
/* L40: */
}
/* + TEST 7 */
/* Get an estimate of RCOND = 1/CNDNUM. */
for (itran = 1; itran <= 2; ++itran) {
if (itran == 1) {
*(unsigned char *)norm = 'O';
rcondc = rcondo;
} else {
*(unsigned char *)norm = 'I';
rcondc = rcondi;
}
s_copy(srnamc_1.srnamt, "ZTRCON", (ftnlen)32, (ftnlen)
6);
ztrcon_(norm, uplo, diag, &n, &a[1], &lda, &rcond, &
work[1], &rwork[1], &info);
/* Check error code from ZTRCON. */
if (info != 0) {
/* Writing concatenation */
i__5[0] = 1, a__2[0] = norm;
i__5[1] = 1, a__2[1] = uplo;
i__5[2] = 1, a__2[2] = diag;
s_cat(ch__2, a__2, i__5, &c__3, (ftnlen)3);
alaerh_(path, "ZTRCON", &info, &c__0, ch__2, &n, &
n, &c_n1, &c_n1, &c_n1, &imat, &nfail, &
nerrs, nout);
}
ztrt06_(&rcond, &rcondc, uplo, diag, &n, &a[1], &lda,
&rwork[1], &result[6]);
/* Print the test ratio if it is .GE. THRESH. */
if (result[6] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___38.ciunit = *nout;
s_wsfe(&io___38);
do_fio(&c__1, norm, (ftnlen)1);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[6], (ftnlen)sizeof(
doublereal));
e_wsfe();
++nfail;
}
++nrun;
/* L50: */
}
L60:
;
}
/* L70: */
}
L80:
;
}
/* Use pathological test matrices to test ZLATRS. */
for (imat = 11; imat <= 18; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (! dotype[imat]) {
goto L110;
}
for (iuplo = 1; iuplo <= 2; ++iuplo) {
/* Do first for UPLO = 'U', then for UPLO = 'L' */
*(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
for (itran = 1; itran <= 3; ++itran) {
/* Do for op(A) = A, A**T, and A**H. */
*(unsigned char *)trans = *(unsigned char *)&transs[itran
- 1];
/* Call ZLATTR to generate a triangular test matrix. */
s_copy(srnamc_1.srnamt, "ZLATTR", (ftnlen)32, (ftnlen)6);
zlattr_(&imat, uplo, trans, diag, iseed, &n, &a[1], &lda,
&x[1], &work[1], &rwork[1], &info);
/* + TEST 8 */
/* Solve the system op(A)*x = b. */
s_copy(srnamc_1.srnamt, "ZLATRS", (ftnlen)32, (ftnlen)6);
zcopy_(&n, &x[1], &c__1, &b[1], &c__1);
zlatrs_(uplo, trans, diag, "N", &n, &a[1], &lda, &b[1], &
scale, &rwork[1], &info);
/* Check error code from ZLATRS. */
if (info != 0) {
/* Writing concatenation */
i__6[0] = 1, a__3[0] = uplo;
i__6[1] = 1, a__3[1] = trans;
i__6[2] = 1, a__3[2] = diag;
i__6[3] = 1, a__3[3] = "N";
s_cat(ch__3, a__3, i__6, &c__4, (ftnlen)4);
alaerh_(path, "ZLATRS", &info, &c__0, ch__3, &n, &n, &
c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
nout);
}
ztrt03_(uplo, trans, diag, &n, &c__1, &a[1], &lda, &scale,
&rwork[1], &c_b99, &b[1], &lda, &x[1], &lda, &
work[1], &result[7]);
/* + TEST 9 */
/* Solve op(A)*X = b again with NORMIN = 'Y'. */
zcopy_(&n, &x[1], &c__1, &b[n + 1], &c__1);
zlatrs_(uplo, trans, diag, "Y", &n, &a[1], &lda, &b[n + 1]
, &scale, &rwork[1], &info);
/* Check error code from ZLATRS. */
if (info != 0) {
/* Writing concatenation */
i__6[0] = 1, a__3[0] = uplo;
i__6[1] = 1, a__3[1] = trans;
i__6[2] = 1, a__3[2] = diag;
i__6[3] = 1, a__3[3] = "Y";
s_cat(ch__3, a__3, i__6, &c__4, (ftnlen)4);
alaerh_(path, "ZLATRS", &info, &c__0, ch__3, &n, &n, &
c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
nout);
}
ztrt03_(uplo, trans, diag, &n, &c__1, &a[1], &lda, &scale,
&rwork[1], &c_b99, &b[n + 1], &lda, &x[1], &lda,
&work[1], &result[8]);
/* Print information about the tests that did not pass */
/* the threshold. */
if (result[7] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___40.ciunit = *nout;
s_wsfe(&io___40);
do_fio(&c__1, "ZLATRS", (ftnlen)6);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, diag, (ftnlen)1);
do_fio(&c__1, "N", (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__8, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[7], (ftnlen)sizeof(
doublereal));
e_wsfe();
++nfail;
}
if (result[8] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___41.ciunit = *nout;
s_wsfe(&io___41);
do_fio(&c__1, "ZLATRS", (ftnlen)6);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, diag, (ftnlen)1);
do_fio(&c__1, "Y", (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__9, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[8], (ftnlen)sizeof(
doublereal));
e_wsfe();
++nfail;
}
nrun += 2;
/* L90: */
}
/* L100: */
}
L110:
;
}
/* L120: */
}
/* Print a summary of the results. */
alasum_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of ZCHKTR */
} /* zchktr_ */
/* Subroutine */ int zchkgk_(integer *nin, integer *nout)
{
/* Format strings */
static char fmt_9999[] = "(1x,\002.. test output of ZGGBAK .. \002)";
static char fmt_9998[] = "(\002 value of largest test error "
" =\002,d12.3)";
static char fmt_9997[] = "(\002 example number where ZGGBAL info is not "
"0 =\002,i4)";
static char fmt_9996[] = "(\002 example number where ZGGBAK(L) info is n"
"ot 0 =\002,i4)";
static char fmt_9995[] = "(\002 example number where ZGGBAK(R) info is n"
"ot 0 =\002,i4)";
static char fmt_9994[] = "(\002 example number having largest error "
" =\002,i4)";
static char fmt_9992[] = "(\002 number of examples where info is not 0 "
" =\002,i4)";
static char fmt_9991[] = "(\002 total number of examples tested "
" =\002,i4)";
/* System generated locals */
integer i__1, i__2, i__3, i__4;
doublereal d__1, d__2, d__3, d__4;
doublecomplex z__1, z__2;
/* Builtin functions */
integer s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_rsle(void);
double d_imag(doublecomplex *);
integer s_wsfe(cilist *), e_wsfe(void), do_fio(integer *, char *, ftnlen);
/* Local variables */
static integer info, lmax[4];
static doublereal rmax, vmax;
static doublecomplex work[2500] /* was [50][50] */, a[2500] /*
was [50][50] */, b[2500] /* was [50][50] */, e[2500] /*
was [50][50] */, f[2500] /* was [50][50] */;
static integer i__, j, m, n, ninfo;
static doublereal anorm, bnorm;
extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *);
static doublereal rwork[300];
static doublecomplex af[2500] /* was [50][50] */, bf[2500] /*
was [50][50] */;
extern doublereal dlamch_(char *);
static doublecomplex vl[2500] /* was [50][50] */;
static doublereal lscale[50];
extern /* Subroutine */ int zggbak_(char *, char *, integer *, integer *,
integer *, doublereal *, doublereal *, integer *, doublecomplex *,
integer *, integer *), zggbal_(char *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *, integer *
, integer *, doublereal *, doublereal *, doublereal *, integer *);
static doublecomplex vr[2500] /* was [50][50] */;
static doublereal rscale[50];
extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
integer *, doublereal *);
extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
static integer ihi, ilo;
static doublereal eps;
static doublecomplex vlf[2500] /* was [50][50] */;
static integer knt;
static doublecomplex vrf[2500] /* was [50][50] */;
/* Fortran I/O blocks */
static cilist io___6 = { 0, 0, 0, 0, 0 };
static cilist io___10 = { 0, 0, 0, 0, 0 };
static cilist io___13 = { 0, 0, 0, 0, 0 };
static cilist io___15 = { 0, 0, 0, 0, 0 };
static cilist io___17 = { 0, 0, 0, 0, 0 };
static cilist io___35 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___36 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___37 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___38 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___39 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___40 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___41 = { 0, 0, 0, fmt_9992, 0 };
static cilist io___42 = { 0, 0, 0, fmt_9991, 0 };
#define a_subscr(a_1,a_2) (a_2)*50 + a_1 - 51
#define a_ref(a_1,a_2) a[a_subscr(a_1,a_2)]
#define b_subscr(a_1,a_2) (a_2)*50 + a_1 - 51
#define b_ref(a_1,a_2) b[b_subscr(a_1,a_2)]
#define e_subscr(a_1,a_2) (a_2)*50 + a_1 - 51
#define e_ref(a_1,a_2) e[e_subscr(a_1,a_2)]
#define f_subscr(a_1,a_2) (a_2)*50 + a_1 - 51
#define f_ref(a_1,a_2) f[f_subscr(a_1,a_2)]
#define vl_subscr(a_1,a_2) (a_2)*50 + a_1 - 51
#define vl_ref(a_1,a_2) vl[vl_subscr(a_1,a_2)]
#define vr_subscr(a_1,a_2) (a_2)*50 + a_1 - 51
#define vr_ref(a_1,a_2) vr[vr_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
September 30, 1994
Purpose
=======
ZCHKGK tests ZGGBAK, a routine for backward balancing of
a matrix pair (A, B).
Arguments
=========
NIN (input) INTEGER
The logical unit number for input. NIN > 0.
NOUT (input) INTEGER
The logical unit number for output. NOUT > 0.
===================================================================== */
lmax[0] = 0;
lmax[1] = 0;
lmax[2] = 0;
lmax[3] = 0;
ninfo = 0;
knt = 0;
rmax = 0.;
eps = dlamch_("Precision");
L10:
io___6.ciunit = *nin;
s_rsle(&io___6);
do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
do_lio(&c__3, &c__1, (char *)&m, (ftnlen)sizeof(integer));
e_rsle();
if (n == 0) {
goto L100;
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___10.ciunit = *nin;
s_rsle(&io___10);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__7, &c__1, (char *)&a_ref(i__, j), (ftnlen)sizeof(
doublecomplex));
}
e_rsle();
/* L20: */
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___13.ciunit = *nin;
s_rsle(&io___13);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__7, &c__1, (char *)&b_ref(i__, j), (ftnlen)sizeof(
doublecomplex));
}
e_rsle();
/* L30: */
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___15.ciunit = *nin;
s_rsle(&io___15);
i__2 = m;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__7, &c__1, (char *)&vl_ref(i__, j), (ftnlen)sizeof(
doublecomplex));
}
e_rsle();
/* L40: */
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___17.ciunit = *nin;
s_rsle(&io___17);
i__2 = m;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__7, &c__1, (char *)&vr_ref(i__, j), (ftnlen)sizeof(
doublecomplex));
}
e_rsle();
/* L50: */
}
++knt;
anorm = zlange_("M", &n, &n, a, &c__50, rwork);
bnorm = zlange_("M", &n, &n, b, &c__50, rwork);
zlacpy_("FULL", &n, &n, a, &c__50, af, &c__50);
zlacpy_("FULL", &n, &n, b, &c__50, bf, &c__50);
zggbal_("B", &n, a, &c__50, b, &c__50, &ilo, &ihi, lscale, rscale, rwork,
&info);
if (info != 0) {
++ninfo;
lmax[0] = knt;
}
zlacpy_("FULL", &n, &m, vl, &c__50, vlf, &c__50);
zlacpy_("FULL", &n, &m, vr, &c__50, vrf, &c__50);
zggbak_("B", "L", &n, &ilo, &ihi, lscale, rscale, &m, vl, &c__50, &info);
if (info != 0) {
++ninfo;
lmax[1] = knt;
}
zggbak_("B", "R", &n, &ilo, &ihi, lscale, rscale, &m, vr, &c__50, &info);
if (info != 0) {
++ninfo;
lmax[2] = knt;
}
/* Test of ZGGBAK
Check tilde(VL)'*A*tilde(VR) - VL'*tilde(A)*VR
where tilde(A) denotes the transformed matrix. */
zgemm_("N", "N", &n, &m, &n, &c_b2, af, &c__50, vr, &c__50, &c_b1, work, &
c__50);
zgemm_("C", "N", &m, &m, &n, &c_b2, vl, &c__50, work, &c__50, &c_b1, e, &
c__50);
zgemm_("N", "N", &n, &m, &n, &c_b2, a, &c__50, vrf, &c__50, &c_b1, work, &
c__50);
zgemm_("C", "N", &m, &m, &n, &c_b2, vlf, &c__50, work, &c__50, &c_b1, f, &
c__50);
vmax = 0.;
i__1 = m;
for (j = 1; j <= i__1; ++j) {
i__2 = m;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = e_subscr(i__, j);
i__4 = f_subscr(i__, j);
z__2.r = e[i__3].r - f[i__4].r, z__2.i = e[i__3].i - f[i__4].i;
z__1.r = z__2.r, z__1.i = z__2.i;
/* Computing MAX */
d__3 = vmax, d__4 = (d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&
z__1), abs(d__2));
vmax = max(d__3,d__4);
/* L60: */
}
/* L70: */
}
vmax /= eps * max(anorm,bnorm);
if (vmax > rmax) {
lmax[3] = knt;
rmax = vmax;
}
/* Check tilde(VL)'*B*tilde(VR) - VL'*tilde(B)*VR */
zgemm_("N", "N", &n, &m, &n, &c_b2, bf, &c__50, vr, &c__50, &c_b1, work, &
c__50);
zgemm_("C", "N", &m, &m, &n, &c_b2, vl, &c__50, work, &c__50, &c_b1, e, &
c__50);
zgemm_("n", "n", &n, &m, &n, &c_b2, b, &c__50, vrf, &c__50, &c_b1, work, &
c__50);
zgemm_("C", "N", &m, &m, &n, &c_b2, vlf, &c__50, work, &c__50, &c_b1, f, &
c__50);
vmax = 0.;
i__1 = m;
for (j = 1; j <= i__1; ++j) {
i__2 = m;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = e_subscr(i__, j);
i__4 = f_subscr(i__, j);
z__2.r = e[i__3].r - f[i__4].r, z__2.i = e[i__3].i - f[i__4].i;
z__1.r = z__2.r, z__1.i = z__2.i;
/* Computing MAX */
d__3 = vmax, d__4 = (d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&
z__1), abs(d__2));
vmax = max(d__3,d__4);
/* L80: */
}
/* L90: */
}
vmax /= eps * max(anorm,bnorm);
if (vmax > rmax) {
lmax[3] = knt;
rmax = vmax;
}
goto L10;
L100:
io___35.ciunit = *nout;
s_wsfe(&io___35);
e_wsfe();
io___36.ciunit = *nout;
s_wsfe(&io___36);
do_fio(&c__1, (char *)&rmax, (ftnlen)sizeof(doublereal));
e_wsfe();
io___37.ciunit = *nout;
s_wsfe(&io___37);
do_fio(&c__1, (char *)&lmax[0], (ftnlen)sizeof(integer));
e_wsfe();
io___38.ciunit = *nout;
s_wsfe(&io___38);
do_fio(&c__1, (char *)&lmax[1], (ftnlen)sizeof(integer));
e_wsfe();
io___39.ciunit = *nout;
s_wsfe(&io___39);
do_fio(&c__1, (char *)&lmax[2], (ftnlen)sizeof(integer));
e_wsfe();
io___40.ciunit = *nout;
s_wsfe(&io___40);
do_fio(&c__1, (char *)&lmax[3], (ftnlen)sizeof(integer));
e_wsfe();
io___41.ciunit = *nout;
s_wsfe(&io___41);
do_fio(&c__1, (char *)&ninfo, (ftnlen)sizeof(integer));
e_wsfe();
io___42.ciunit = *nout;
s_wsfe(&io___42);
do_fio(&c__1, (char *)&knt, (ftnlen)sizeof(integer));
e_wsfe();
return 0;
/* End of ZCHKGK */
} /* zchkgk_ */
/* Subroutine */ int search_(doublereal *xparam, doublereal *alpha,
doublereal *sig, integer *nvar, doublereal *gmin, logical *okf,
doublereal *funct)
{
/* Initialized data */
static integer icalcn = 0;
/* System generated locals */
integer i__1;
doublereal d__1, d__2;
/* Builtin functions */
integer i_indx(char *, char *, ftnlen, ftnlen);
double d_sign(doublereal *, doublereal *);
integer s_wsfe(cilist *), e_wsfe(void), do_fio(integer *, char *, ftnlen);
double sqrt(doublereal);
/* Local variables */
static doublereal g;
static integer i__;
static doublereal ga, gb, ta, tb;
extern doublereal dot_(doublereal *, doublereal *, integer *);
static doublereal sum, grad[360], gref[360], xref[360], gtot;
static logical nopr;
static doublereal tiny, xmin1[360];
static logical debug;
static doublereal gminn;
static integer looks, itrys;
extern /* Subroutine */ int compfg_(doublereal *, logical *, doublereal *,
logical *, doublereal *, logical *);
static doublereal tolerg, gstore;
/* Fortran I/O blocks */
static cilist io___12 = { 0, 6, 0, "(' SEARCH DIRECTION VECTOR')", 0 };
static cilist io___13 = { 0, 6, 0, "(6F12.6)", 0 };
static cilist io___14 = { 0, 6, 0, "(' INITIAL GRADIENT VECTOR')", 0 };
static cilist io___15 = { 0, 6, 0, "(6F12.6)", 0 };
static cilist io___17 = { 0, 6, 0, "(' GRADIENT AT START OF SEARCH:',F16"
".6)", 0 };
static cilist io___27 = { 0, 6, 0, "(' LOOKS',I3,' ALPHA =',F12.6,' GRAD"
"IENT',F12.3, ' G =',F16.6)", 0 };
static cilist io___28 = { 0, 6, 0, "(' AT EXIT FROM SEARCH')", 0 };
static cilist io___29 = { 0, 6, 0, "(' XPARAM',6F12.6)", 0 };
static cilist io___30 = { 0, 6, 0, "(' GNEXT1',6F12.6)", 0 };
static cilist io___31 = { 0, 6, 0, "(' GMIN1 ',6F12.6)", 0 };
static cilist io___32 = { 0, 6, 0, "(' AMIN, ANEXT,GMIN',4F12.6)", 0 };
/* COMDECK SIZES */
/* *********************************************************************** */
/* THIS FILE CONTAINS ALL THE ARRAY SIZES FOR USE IN MOPAC. */
/* THERE ARE ONLY 5 PARAMETERS THAT THE PROGRAMMER NEED SET: */
/* MAXHEV = MAXIMUM NUMBER OF HEAVY ATOMS (HEAVY: NON-HYDROGEN ATOMS) */
/* MAXLIT = MAXIMUM NUMBER OF HYDROGEN ATOMS. */
/* MAXTIM = DEFAULT TIME FOR A JOB. (SECONDS) */
/* MAXDMP = DEFAULT TIME FOR AUTOMATIC RESTART FILE GENERATION (SECS) */
/* ISYBYL = 1 IF MOPAC IS TO BE USED IN THE SYBYL PACKAGE, =0 OTHERWISE */
/* SEE ALSO NMECI, NPULAY AND MESP AT THE END OF THIS FILE */
/* *********************************************************************** */
/* THE FOLLOWING CODE DOES NOT NEED TO BE ALTERED BY THE PROGRAMMER */
/* *********************************************************************** */
/* ALL OTHER PARAMETERS ARE DERIVED FUNCTIONS OF THESE TWO PARAMETERS */
/* NAME DEFINITION */
/* NUMATM MAXIMUM NUMBER OF ATOMS ALLOWED. */
/* MAXORB MAXIMUM NUMBER OF ORBITALS ALLOWED. */
/* MAXPAR MAXIMUM NUMBER OF PARAMETERS FOR OPTIMISATION. */
/* N2ELEC MAXIMUM NUMBER OF TWO ELECTRON INTEGRALS ALLOWED. */
/* MPACK AREA OF LOWER HALF TRIANGLE OF DENSITY MATRIX. */
/* MORB2 SQUARE OF THE MAXIMUM NUMBER OF ORBITALS ALLOWED. */
/* MAXHES AREA OF HESSIAN MATRIX */
/* MAXALL LARGER THAN MAXORB OR MAXPAR. */
/* *********************************************************************** */
/* *********************************************************************** */
/* DECK MOPAC */
/* *********************************************************************** */
/* SEARCH PERFORMS A LINE SEARCH FOR POWSQ. IT MINIMIZES THE NORM OF */
/* THE GRADIENT VECTOR IN THE DIRECTION SIG. */
/* ON INPUT XPARAM = CURRENT POINT IN NVAR DIMENSIONAL SPACE. */
/* ALPHA = STEP SIZE (IN FACT ALPHA IS CALCULATED IN SEARCH). */
/* SIG = SEARCH DIRECTION VECTOR. */
/* NVAR = NUMBER OF PARAMETERS IN SIG (& XPARAM) */
/* ON OUTPUT XPARAM = PARAMETERS OF MINIMUM. */
/* ALPHA = DISTANCE TO MINIMUM. */
/* GMIN = GRADIENT NORM AT MINIMUM. */
/* OKF = FUNCTION WAS IMPROVED. */
/* *********************************************************************** */
/* Parameter adjustments */
--sig;
--xparam;
/* Function Body */
if (icalcn != numcal_1.numcal) {
icalcn = numcal_1.numcal;
/* TOLG = CRITERION FOR EXIT BY RELATIVE CHANGE IN GRADIENT. */
debug = i_indx(keywrd_1.keywrd, "LINMIN", (ftnlen)241, (ftnlen)6) !=
0;
nopr = ! debug;
looks = 0;
*okf = TRUE_;
tiny = .1;
tolerg = .02;
g = 100.;
*alpha = .1;
}
i__1 = *nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
gref[i__ - 1] = sigma2_1.gmin1[i__ - 1];
sigma2_1.gnext1[i__ - 1] = sigma2_1.gmin1[i__ - 1];
xmin1[i__ - 1] = xparam[i__];
/* L10: */
xref[i__ - 1] = xparam[i__];
}
if (abs(*alpha) > .2f) {
*alpha = d_sign(&c_b4, alpha);
}
if (debug) {
s_wsfe(&io___12);
e_wsfe();
s_wsfe(&io___13);
i__1 = *nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&sig[i__], (ftnlen)sizeof(doublereal));
}
e_wsfe();
s_wsfe(&io___14);
e_wsfe();
s_wsfe(&io___15);
i__1 = *nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&sigma2_1.gmin1[i__ - 1], (ftnlen)sizeof(
doublereal));
}
e_wsfe();
}
gb = dot_(sigma2_1.gmin1, gref, nvar);
if (debug) {
s_wsfe(&io___17);
d__1 = sqrt(gb);
do_fio(&c__1, (char *)&d__1, (ftnlen)sizeof(doublereal));
e_wsfe();
}
gstore = gb;
sigma1_1.amin = 0.;
gminn = 1e9;
ta = 0.;
ga = gb;
gb = 1e9;
itrys = 0;
goto L30;
L20:
sum = ga / (ga - gb);
++itrys;
if (abs(sum) > 3.) {
sum = d_sign(&c_b17, &sum);
}
*alpha = (tb - ta) * sum + ta;
/* XPARAM IS THE GEOMETRY OF THE PREDICTED MINIMUM ALONG THE LINE */
L30:
i__1 = *nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L40: */
xparam[i__] = xref[i__ - 1] + *alpha * sig[i__];
}
/* CALCULATE GRADIENT NORM AND GRADIENTS AT THE PREDICTED MINIMUM */
if (itrys == 1) {
i__1 = *nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L50: */
grad[i__ - 1] = 0.;
}
}
compfg_(&xparam[1], &c_true, funct, &c_true, grad, &c_true);
++looks;
/* G IS THE PROJECTION OF THE GRADIENT ALONG SIG. */
g = dot_(gref, grad, nvar);
gtot = sqrt(dot_(grad, grad, nvar));
if (! nopr) {
s_wsfe(&io___27);
do_fio(&c__1, (char *)&looks, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&(*alpha), (ftnlen)sizeof(doublereal));
d__1 = sqrt(dot_(grad, grad, nvar));
do_fio(&c__1, (char *)&d__1, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&g, (ftnlen)sizeof(doublereal));
e_wsfe();
}
if (gtot < gminn) {
gminn = gtot;
if ((d__1 = sigma1_1.amin - *alpha, abs(d__1)) > .01) {
/* WE CAN MOVE ANEXT TO A POINT NEAR, BUT NOT TOO NEAR, AMIN, SO THAT THE */
/* SECOND DERIVATIVESWILLBEREALISTIC(D2E/DX2=(GNEXT1-GMIN1)/(ANEXT-AMIN)) */
sigma1_1.anext = sigma1_1.amin;
i__1 = *nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L60: */
sigma2_1.gnext1[i__ - 1] = sigma2_1.gmin1[i__ - 1];
}
}
sigma1_1.amin = *alpha;
i__1 = *nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
if (gminn < *gmin) {
xmin1[i__ - 1] = xparam[i__];
}
/* L70: */
sigma2_1.gmin1[i__ - 1] = grad[i__ - 1];
}
if (*gmin > gminn) {
*gmin = gminn;
}
}
if (itrys > 8) {
goto L80;
}
if ((d__1 = g / gstore, abs(d__1)) < tiny || abs(g) < tolerg) {
goto L80;
}
/* Computing MAX */
d__1 = abs(ga), d__2 = abs(gb);
if (abs(g) < max(d__1,d__2) || ga * gb > 0. && g * ga < 0.) {
/* G IS AN IMPROVEMENT ON GA OR GB. */
if (abs(gb) < abs(ga)) {
ta = *alpha;
ga = g;
goto L20;
} else {
tb = *alpha;
gb = g;
goto L20;
}
} else {
/* # WRITE(6,'(//10X,'' FAILED IN SEARCH, SEARCH CONTINUING'')') */
goto L80;
}
L80:
gminn = sqrt(dot_(sigma2_1.gmin1, sigma2_1.gmin1, nvar));
i__1 = *nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L90: */
xparam[i__] = xmin1[i__ - 1];
}
if (debug) {
s_wsfe(&io___28);
e_wsfe();
s_wsfe(&io___29);
i__1 = *nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&xparam[i__], (ftnlen)sizeof(doublereal));
}
e_wsfe();
s_wsfe(&io___30);
i__1 = *nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&sigma2_1.gnext1[i__ - 1], (ftnlen)sizeof(
doublereal));
}
e_wsfe();
s_wsfe(&io___31);
i__1 = *nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&sigma2_1.gmin1[i__ - 1], (ftnlen)sizeof(
doublereal));
}
e_wsfe();
s_wsfe(&io___32);
do_fio(&c__1, (char *)&sigma1_1.amin, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&sigma1_1.anext, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&(*gmin), (ftnlen)sizeof(doublereal));
e_wsfe();
}
if (gminn > *gmin) {
i__1 = *nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L100: */
xparam[i__] = xref[i__ - 1];
}
}
return 0;
} /* search_ */
/* Subroutine */ int donest_(integer *iounit, doublereal *d__, doublereal *e,
doublereal *w1, doublereal *w2, integer *ind, integer *nt, doublereal
*eigmin, doublereal *eigmax, doublereal *cond)
{
/* Format strings */
static char fmt_15[] = "(/,\002 WARNING IN DONEST: SRATQR RETURNED IERR "
"= \002,i5,/)";
static char fmt_50[] = "(4x,\002 MIN, MAX EIGENVALUES = \002,d12.5,\002 "
"AND \002,d12.5,/,4x,\002 CONDITION NUMBER = \002,d12.5,/)";
/* System generated locals */
integer i__1;
doublereal d__1, d__2;
/* Builtin functions */
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
static integer i__;
static doublereal eps1;
static integer ierr;
static logical type__;
extern /* Subroutine */ int sratqr_(integer *, doublereal *, doublereal *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, logical *, integer *, integer *);
/* Fortran I/O blocks */
static cilist io___5 = { 0, 0, 0, fmt_15, 0 };
static cilist io___6 = { 0, 0, 0, fmt_15, 0 };
static cilist io___7 = { 0, 0, 0, fmt_50, 0 };
/* ***BEGIN PROLOGUE DONEST */
/* ***REFER TO DPPCG,DPCGCA */
/* ***ROUTINES CALLED SRATQR */
/* ***REVISION DATE 860901 (YYMMDD) */
/* ***END PROLOGUE DONEST */
/* THIS SUBROUTINE COMPUTES THE SMALLEST AND LARGEST EIGENVALUES OF */
/* A SYMMETRIC POSITIVE DEFINITE TRIDIAGONAL MATRIX OF ORDER NT. THE */
/* DIAGONAL IS STORED IN THE ARRAY D AND THE SUB-DIAG IS STORED IN */
/* THE LAST NT-1 POSITIONS OF THE ARRAY E. EIGMIN AND EIGMAX ARE */
/* UPDATED WITH EACH CALL TO DONEST. ONCE THESE ARE DETERMINED, AN */
/* ESTIMATE FOR THE CONDITION NUMBER IS COMPUTED. THE ARRAYS D AND */
/* E ARE UNALTERED. TWO DBLE WORK ARRAYS (W1, W2) AND ONE INTEGER */
/* WORK ARRAY (IND) MUST BE PASSED. */
/* *** DECLARATIONS *** */
/* ***FIRST EXECUTABLE STATEMENT DONEST */
/* Parameter adjustments */
--ind;
--w2;
--w1;
--e;
--d__;
/* Function Body */
/* L1: */
/* *** FIND SMALLEST EIGENVALUE *** */
eps1 = 0.;
type__ = TRUE_;
i__1 = *nt;
for (i__ = 2; i__ <= i__1; ++i__) {
/* Computing 2nd power */
d__1 = e[i__];
w1[i__] = d__1 * d__1;
/* L10: */
}
sratqr_(nt, &eps1, &d__[1], &e[1], &w1[1], &c__1, &w2[1], &ind[1], &w1[1],
&type__, &c__1, &ierr);
if (ierr != 0) {
io___5.ciunit = *iounit;
s_wsfe(&io___5);
do_fio(&c__1, (char *)&ierr, (ftnlen)sizeof(integer));
e_wsfe();
} else {
*eigmin = min(*eigmin,w2[1]);
}
/* *** FIND LARGEST EIGENVALUE *** */
eps1 = 0.;
type__ = FALSE_;
i__1 = *nt;
for (i__ = 2; i__ <= i__1; ++i__) {
/* Computing 2nd power */
d__1 = e[i__];
w1[i__] = d__1 * d__1;
/* L20: */
}
sratqr_(nt, &eps1, &d__[1], &e[1], &w1[1], &c__1, &w2[1], &ind[1], &w1[1],
&type__, &c__1, &ierr);
if (ierr != 0) {
io___6.ciunit = *iounit;
s_wsfe(&io___6);
do_fio(&c__1, (char *)&ierr, (ftnlen)sizeof(integer));
e_wsfe();
} else {
*eigmax = max(*eigmax,w2[1]);
}
/* *** UPDATE CONDITION NUMBER ESTIMATE *** */
/* Computing MAX */
d__1 = 1., d__2 = *eigmax / *eigmin, d__1 = max(d__1,d__2);
*cond = max(d__1,*cond);
if (*iounit > 0) {
io___7.ciunit = *iounit;
s_wsfe(&io___7);
do_fio(&c__1, (char *)&(*eigmin), (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&(*eigmax), (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&(*cond), (ftnlen)sizeof(doublereal));
e_wsfe();
}
return 0;
} /* donest_ */
/* Subroutine */ int cdrvpp_(logical *dotype, integer *nn, integer *nval,
integer *nrhs, real *thresh, logical *tsterr, integer *nmax, complex *
a, complex *afac, complex *asav, complex *b, complex *bsav, complex *
x, complex *xact, real *s, complex *work, real *rwork, integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
static char uplos[1*2] = "U" "L";
static char facts[1*3] = "F" "N" "E";
static char packs[1*2] = "C" "R";
static char equeds[1*2] = "N" "Y";
/* Format strings */
static char fmt_9999[] = "(1x,a6,\002, UPLO='\002,a1,\002', N =\002,i5"
",\002, type \002,i1,\002, test(\002,i1,\002)=\002,g12.5)";
static char fmt_9997[] = "(1x,a6,\002, FACT='\002,a1,\002', UPLO='\002,a"
"1,\002', N=\002,i5,\002, EQUED='\002,a1,\002', type \002,i1,\002"
", test(\002,i1,\002)=\002,g12.5)";
static char fmt_9998[] = "(1x,a6,\002, FACT='\002,a1,\002', UPLO='\002,a"
"1,\002', N=\002,i5,\002, type \002,i1,\002, test(\002,i1,\002)"
"=\002,g12.5)";
/* System generated locals */
address a__1[2];
integer i__1, i__2, i__3, i__4, i__5[2];
char ch__1[2];
/* Builtin functions
Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
/* Local variables */
static char fact[1];
static integer ioff, mode;
static real amax;
static char path[3];
static integer imat, info;
static char dist[1], uplo[1], type__[1];
static integer nrun, i__, k, n, ifact;
extern /* Subroutine */ int cget04_(integer *, integer *, complex *,
integer *, complex *, integer *, real *, real *);
static integer nfail, iseed[4], nfact;
extern logical lsame_(char *, char *);
static char equed[1];
static real roldc, rcond, scond;
extern /* Subroutine */ int cppt01_(char *, integer *, complex *, complex
*, real *, real *);
static integer nimat;
extern doublereal sget06_(real *, real *);
extern /* Subroutine */ int cppt02_(char *, integer *, integer *, complex
*, complex *, integer *, complex *, integer *, real *, real *), cppt05_(char *, integer *, integer *, complex *, complex
*, integer *, complex *, integer *, complex *, integer *, real *,
real *, real *);
static real anorm;
extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
complex *, integer *);
static logical equil;
static integer iuplo, izero, nerrs;
extern /* Subroutine */ int cppsv_(char *, integer *, integer *, complex *
, complex *, integer *, integer *);
static integer k1;
static logical zerot;
static char xtype[1];
extern /* Subroutine */ int clatb4_(char *, integer *, integer *, integer
*, char *, integer *, integer *, real *, integer *, real *, char *
), aladhd_(integer *, char *);
static integer in, kl;
extern /* Subroutine */ int alaerh_(char *, char *, integer *, integer *,
char *, integer *, integer *, integer *, integer *, integer *,
integer *, integer *, integer *, integer *), claipd_(integer *, complex *, integer *, integer *);
static logical prefac;
static integer ku, nt;
extern doublereal clanhp_(char *, char *, integer *, complex *, real *);
static real rcondc;
extern /* Subroutine */ int claqhp_(char *, integer *, complex *, real *,
real *, real *, char *);
static logical nofact;
static char packit[1];
static integer iequed;
extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
*, integer *, complex *, integer *), clarhs_(char *, char
*, char *, char *, integer *, integer *, integer *, integer *,
integer *, complex *, integer *, complex *, integer *, complex *,
integer *, integer *, integer *),
claset_(char *, integer *, integer *, complex *, complex *,
complex *, integer *), alasvm_(char *, integer *, integer
*, integer *, integer *);
static real cndnum;
extern /* Subroutine */ int clatms_(integer *, integer *, char *, integer
*, char *, real *, integer *, real *, real *, integer *, integer *
, char *, complex *, integer *, complex *, integer *);
static real ainvnm;
extern /* Subroutine */ int cppequ_(char *, integer *, complex *, real *,
real *, real *, integer *), cpptrf_(char *, integer *,
complex *, integer *), cpptri_(char *, integer *, complex
*, integer *), cerrvx_(char *, integer *);
static real result[6];
extern /* Subroutine */ int cppsvx_(char *, char *, integer *, integer *,
complex *, complex *, char *, real *, complex *, integer *,
complex *, integer *, real *, real *, real *, complex *, real *,
integer *);
static integer lda, npp;
/* Fortran I/O blocks */
static cilist io___49 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___52 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___53 = { 0, 0, 0, fmt_9998, 0 };
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
Purpose
=======
CDRVPP tests the driver routines CPPSV and -SVX.
Arguments
=========
DOTYPE (input) LOGICAL array, dimension (NTYPES)
The matrix types to be used for testing. Matrices of type j
(for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
.TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
NN (input) INTEGER
The number of values of N contained in the vector NVAL.
NVAL (input) INTEGER array, dimension (NN)
The values of the matrix dimension N.
NRHS (input) INTEGER
The number of right hand side vectors to be generated for
each linear system.
THRESH (input) REAL
The threshold value for the test ratios. A result is
included in the output file if RESULT >= THRESH. To have
every test ratio printed, use THRESH = 0.
TSTERR (input) LOGICAL
Flag that indicates whether error exits are to be tested.
NMAX (input) INTEGER
The maximum value permitted for N, used in dimensioning the
work arrays.
A (workspace) COMPLEX array, dimension (NMAX*(NMAX+1)/2)
AFAC (workspace) COMPLEX array, dimension (NMAX*(NMAX+1)/2)
ASAV (workspace) COMPLEX array, dimension (NMAX*(NMAX+1)/2)
B (workspace) COMPLEX array, dimension (NMAX*NRHS)
BSAV (workspace) COMPLEX array, dimension (NMAX*NRHS)
X (workspace) COMPLEX array, dimension (NMAX*NRHS)
XACT (workspace) COMPLEX array, dimension (NMAX*NRHS)
S (workspace) REAL array, dimension (NMAX)
WORK (workspace) COMPLEX array, dimension
(NMAX*max(3,NRHS))
RWORK (workspace) REAL array, dimension (NMAX+2*NRHS)
NOUT (input) INTEGER
The unit number for output.
=====================================================================
Parameter adjustments */
--rwork;
--work;
--s;
--xact;
--x;
--bsav;
--b;
--asav;
--afac;
--a;
--nval;
--dotype;
/* Function Body
Initialize constants and the random number seed. */
s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17);
s_copy(path + 1, "PP", (ftnlen)2, (ftnlen)2);
nrun = 0;
nfail = 0;
nerrs = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
}
/* Test the error exits */
if (*tsterr) {
cerrvx_(path, nout);
}
infoc_1.infot = 0;
/* Do for each value of N in NVAL */
i__1 = *nn;
for (in = 1; in <= i__1; ++in) {
n = nval[in];
lda = max(n,1);
npp = n * (n + 1) / 2;
*(unsigned char *)xtype = 'N';
nimat = 9;
if (n <= 0) {
nimat = 1;
}
i__2 = nimat;
for (imat = 1; imat <= i__2; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (! dotype[imat]) {
goto L130;
}
/* Skip types 3, 4, or 5 if the matrix size is too small. */
zerot = imat >= 3 && imat <= 5;
if (zerot && n < imat - 2) {
goto L130;
}
/* Do first for UPLO = 'U', then for UPLO = 'L' */
for (iuplo = 1; iuplo <= 2; ++iuplo) {
*(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
*(unsigned char *)packit = *(unsigned char *)&packs[iuplo - 1]
;
/* Set up parameters with CLATB4 and generate a test matrix
with CLATMS. */
clatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode,
&cndnum, dist);
rcondc = 1.f / cndnum;
s_copy(srnamc_1.srnamt, "CLATMS", (ftnlen)6, (ftnlen)6);
clatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
cndnum, &anorm, &kl, &ku, packit, &a[1], &lda, &work[
1], &info);
/* Check error code from CLATMS. */
if (info != 0) {
alaerh_(path, "CLATMS", &info, &c__0, uplo, &n, &n, &c_n1,
&c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
goto L120;
}
/* For types 3-5, zero one row and column of the matrix to
test that INFO is returned correctly. */
if (zerot) {
if (imat == 3) {
izero = 1;
} else if (imat == 4) {
izero = n;
} else {
izero = n / 2 + 1;
}
/* Set row and column IZERO of A to 0. */
if (iuplo == 1) {
ioff = (izero - 1) * izero / 2;
i__3 = izero - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = ioff + i__;
a[i__4].r = 0.f, a[i__4].i = 0.f;
/* L20: */
}
ioff += izero;
i__3 = n;
for (i__ = izero; i__ <= i__3; ++i__) {
i__4 = ioff;
a[i__4].r = 0.f, a[i__4].i = 0.f;
ioff += i__;
/* L30: */
}
} else {
ioff = izero;
i__3 = izero - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = ioff;
a[i__4].r = 0.f, a[i__4].i = 0.f;
ioff = ioff + n - i__;
/* L40: */
}
ioff -= izero;
i__3 = n;
for (i__ = izero; i__ <= i__3; ++i__) {
i__4 = ioff + i__;
a[i__4].r = 0.f, a[i__4].i = 0.f;
/* L50: */
}
}
} else {
izero = 0;
}
/* Set the imaginary part of the diagonals. */
if (iuplo == 1) {
claipd_(&n, &a[1], &c__2, &c__1);
} else {
claipd_(&n, &a[1], &n, &c_n1);
}
/* Save a copy of the matrix A in ASAV. */
ccopy_(&npp, &a[1], &c__1, &asav[1], &c__1);
for (iequed = 1; iequed <= 2; ++iequed) {
*(unsigned char *)equed = *(unsigned char *)&equeds[
iequed - 1];
if (iequed == 1) {
nfact = 3;
} else {
nfact = 1;
}
i__3 = nfact;
for (ifact = 1; ifact <= i__3; ++ifact) {
*(unsigned char *)fact = *(unsigned char *)&facts[
ifact - 1];
prefac = lsame_(fact, "F");
nofact = lsame_(fact, "N");
equil = lsame_(fact, "E");
if (zerot) {
if (prefac) {
goto L100;
}
rcondc = 0.f;
} else if (! lsame_(fact, "N"))
{
/* Compute the condition number for comparison with
the value returned by CPPSVX (FACT = 'N' reuses
the condition number from the previous iteration
with FACT = 'F'). */
ccopy_(&npp, &asav[1], &c__1, &afac[1], &c__1);
if (equil || iequed > 1) {
/* Compute row and column scale factors to
equilibrate the matrix A. */
cppequ_(uplo, &n, &afac[1], &s[1], &scond, &
amax, &info);
if (info == 0 && n > 0) {
if (iequed > 1) {
scond = 0.f;
}
/* Equilibrate the matrix. */
claqhp_(uplo, &n, &afac[1], &s[1], &scond,
&amax, equed);
}
}
/* Save the condition number of the
non-equilibrated system for use in CGET04. */
if (equil) {
roldc = rcondc;
}
/* Compute the 1-norm of A. */
anorm = clanhp_("1", uplo, &n, &afac[1], &rwork[1]
);
/* Factor the matrix A. */
cpptrf_(uplo, &n, &afac[1], &info);
/* Form the inverse of A. */
ccopy_(&npp, &afac[1], &c__1, &a[1], &c__1);
cpptri_(uplo, &n, &a[1], &info);
/* Compute the 1-norm condition number of A. */
ainvnm = clanhp_("1", uplo, &n, &a[1], &rwork[1]);
if (anorm <= 0.f || ainvnm <= 0.f) {
rcondc = 1.f;
} else {
rcondc = 1.f / anorm / ainvnm;
}
}
/* Restore the matrix A. */
ccopy_(&npp, &asav[1], &c__1, &a[1], &c__1);
/* Form an exact solution and set the right hand side. */
s_copy(srnamc_1.srnamt, "CLARHS", (ftnlen)6, (ftnlen)
6);
clarhs_(path, xtype, uplo, " ", &n, &n, &kl, &ku,
nrhs, &a[1], &lda, &xact[1], &lda, &b[1], &
lda, iseed, &info);
*(unsigned char *)xtype = 'C';
clacpy_("Full", &n, nrhs, &b[1], &lda, &bsav[1], &lda);
if (nofact) {
/* --- Test CPPSV ---
Compute the L*L' or U'*U factorization of the
matrix and solve the system. */
ccopy_(&npp, &a[1], &c__1, &afac[1], &c__1);
clacpy_("Full", &n, nrhs, &b[1], &lda, &x[1], &
lda);
s_copy(srnamc_1.srnamt, "CPPSV ", (ftnlen)6, (
ftnlen)6);
cppsv_(uplo, &n, nrhs, &afac[1], &x[1], &lda, &
info);
/* Check error code from CPPSV . */
if (info != izero) {
alaerh_(path, "CPPSV ", &info, &izero, uplo, &
n, &n, &c_n1, &c_n1, nrhs, &imat, &
nfail, &nerrs, nout);
goto L70;
} else if (info != 0) {
goto L70;
}
/* Reconstruct matrix from factors and compute
residual. */
cppt01_(uplo, &n, &a[1], &afac[1], &rwork[1],
result);
/* Compute residual of the computed solution. */
clacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &
lda);
cppt02_(uplo, &n, nrhs, &a[1], &x[1], &lda, &work[
1], &lda, &rwork[1], &result[1]);
/* Check solution from generated exact solution. */
cget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[2]);
nt = 3;
/* Print information about the tests that did not
pass the threshold. */
i__4 = nt;
for (k = 1; k <= i__4; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
io___49.ciunit = *nout;
s_wsfe(&io___49);
do_fio(&c__1, "CPPSV ", (ftnlen)6);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[k - 1], (
ftnlen)sizeof(real));
e_wsfe();
++nfail;
}
/* L60: */
}
nrun += nt;
L70:
;
}
/* --- Test CPPSVX --- */
if (! prefac && npp > 0) {
claset_("Full", &npp, &c__1, &c_b63, &c_b63, &
afac[1], &npp);
}
claset_("Full", &n, nrhs, &c_b63, &c_b63, &x[1], &lda);
if (iequed > 1 && n > 0) {
/* Equilibrate the matrix if FACT='F' and
EQUED='Y'. */
claqhp_(uplo, &n, &a[1], &s[1], &scond, &amax,
equed);
}
/* Solve the system and compute the condition number
and error bounds using CPPSVX. */
s_copy(srnamc_1.srnamt, "CPPSVX", (ftnlen)6, (ftnlen)
6);
cppsvx_(fact, uplo, &n, nrhs, &a[1], &afac[1], equed,
&s[1], &b[1], &lda, &x[1], &lda, &rcond, &
rwork[1], &rwork[*nrhs + 1], &work[1], &rwork[
(*nrhs << 1) + 1], &info);
/* Check the error code from CPPSVX. */
if (info != izero) {
/* Writing concatenation */
i__5[0] = 1, a__1[0] = fact;
i__5[1] = 1, a__1[1] = uplo;
s_cat(ch__1, a__1, i__5, &c__2, (ftnlen)2);
alaerh_(path, "CPPSVX", &info, &izero, ch__1, &n,
&n, &c_n1, &c_n1, nrhs, &imat, &nfail, &
nerrs, nout);
goto L90;
}
if (info == 0) {
if (! prefac) {
/* Reconstruct matrix from factors and compute
residual. */
cppt01_(uplo, &n, &a[1], &afac[1], &rwork[(*
nrhs << 1) + 1], result);
k1 = 1;
} else {
k1 = 2;
}
/* Compute residual of the computed solution. */
clacpy_("Full", &n, nrhs, &bsav[1], &lda, &work[1]
, &lda);
cppt02_(uplo, &n, nrhs, &asav[1], &x[1], &lda, &
work[1], &lda, &rwork[(*nrhs << 1) + 1], &
result[1]);
/* Check solution from generated exact solution. */
if (nofact || prefac && lsame_(equed, "N")) {
cget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
&rcondc, &result[2]);
} else {
cget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
&roldc, &result[2]);
}
/* Check the error bounds from iterative
refinement. */
cppt05_(uplo, &n, nrhs, &asav[1], &b[1], &lda, &x[
1], &lda, &xact[1], &lda, &rwork[1], &
rwork[*nrhs + 1], &result[3]);
} else {
k1 = 6;
}
/* Compare RCOND from CPPSVX with the computed value
in RCONDC. */
result[5] = sget06_(&rcond, &rcondc);
/* Print information about the tests that did not pass
the threshold. */
for (k = k1; k <= 6; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
if (prefac) {
io___52.ciunit = *nout;
s_wsfe(&io___52);
do_fio(&c__1, "CPPSVX", (ftnlen)6);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, equed, (ftnlen)1);
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[k - 1], (
ftnlen)sizeof(real));
e_wsfe();
} else {
io___53.ciunit = *nout;
s_wsfe(&io___53);
do_fio(&c__1, "CPPSVX", (ftnlen)6);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[k - 1], (
ftnlen)sizeof(real));
e_wsfe();
}
++nfail;
}
/* L80: */
}
nrun = nrun + 7 - k1;
L90:
L100:
;
}
/* L110: */
}
L120:
;
}
L130:
;
}
/* L140: */
}
/* Print a summary of the results. */
alasvm_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of CDRVPP */
} /* cdrvpp_ */
/* Subroutine */ int cchkbd_(integer *nsizes, integer *mval, integer *nval,
integer *ntypes, logical *dotype, integer *nrhs, integer *iseed, real
*thresh, complex *a, integer *lda, real *bd, real *be, real *s1, real
*s2, complex *x, integer *ldx, complex *y, complex *z__, complex *q,
integer *ldq, complex *pt, integer *ldpt, complex *u, complex *vt,
complex *work, integer *lwork, real *rwork, integer *nout, integer *
info)
{
/* Initialized data */
static integer ktype[16] = { 1,2,4,4,4,4,4,6,6,6,6,6,9,9,9,10 };
static integer kmagn[16] = { 1,1,1,1,1,2,3,1,1,1,2,3,1,2,3,0 };
static integer kmode[16] = { 0,0,4,3,1,4,4,4,3,1,4,4,0,0,0,0 };
/* Format strings */
static char fmt_9998[] = "(\002 CCHKBD: \002,a,\002 returned INFO=\002,i"
"6,\002.\002,/9x,\002M=\002,i6,\002, N=\002,i6,\002, JTYPE=\002,i"
"6,\002, ISEED=(\002,3(i5,\002,\002),i5,\002)\002)";
static char fmt_9999[] = "(\002 M=\002,i5,\002, N=\002,i5,\002, type "
"\002,i2,\002, seed=\002,4(i4,\002,\002),\002 test(\002,i2,\002)"
"=\002,g11.4)";
/* System generated locals */
integer a_dim1, a_offset, pt_dim1, pt_offset, q_dim1, q_offset, u_dim1,
u_offset, vt_dim1, vt_offset, x_dim1, x_offset, y_dim1, y_offset,
z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7;
real r__1, r__2, r__3, r__4, r__5, r__6, r__7;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
double log(doublereal), sqrt(doublereal), exp(doublereal);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
integer i__, j, m, n, mq;
real ulp, cond;
integer jcol;
char path[3];
integer mmax, nmax;
real unfl, ovfl;
char uplo[1];
real temp1, temp2;
extern /* Subroutine */ int cbdt01_(integer *, integer *, integer *,
complex *, integer *, complex *, integer *, real *, real *,
complex *, integer *, complex *, real *, real *), cbdt02_(integer
*, integer *, complex *, integer *, complex *, integer *, complex
*, integer *, complex *, real *, real *), cbdt03_(char *, integer
*, integer *, real *, real *, complex *, integer *, real *,
complex *, integer *, complex *, real *);
logical badmm, badnn;
extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
integer *, complex *, complex *, integer *, complex *, integer *,
complex *, complex *, integer *);
integer nfail, imode;
real dumma[1];
integer iinfo;
extern /* Subroutine */ int cunt01_(char *, integer *, integer *, complex
*, integer *, complex *, integer *, real *, real *);
real anorm;
integer mnmin, mnmax, jsize, itype, jtype, iwork[1], ntest;
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *), slahd2_(integer *, char *);
integer log2ui;
logical bidiag;
extern /* Subroutine */ int cgebrd_(integer *, integer *, complex *,
integer *, real *, real *, complex *, complex *, complex *,
integer *, integer *), slabad_(real *, real *);
extern doublereal slamch_(char *);
extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
*, integer *, complex *, integer *), claset_(char *,
integer *, integer *, complex *, complex *, complex *, integer *), xerbla_(char *, integer *);
integer ioldsd[4];
extern /* Subroutine */ int cbdsqr_(char *, integer *, integer *, integer
*, integer *, real *, real *, complex *, integer *, complex *,
integer *, complex *, integer *, real *, integer *),
cungbr_(char *, integer *, integer *, integer *, complex *,
integer *, complex *, complex *, integer *, integer *),
alasum_(char *, integer *, integer *, integer *, integer *);
extern doublereal slarnd_(integer *, integer *);
extern /* Subroutine */ int clatmr_(integer *, integer *, char *, integer
*, char *, complex *, integer *, real *, complex *, char *, char *
, complex *, integer *, real *, complex *, integer *, real *,
char *, integer *, integer *, integer *, real *, real *, char *,
complex *, integer *, integer *, integer *), clatms_(integer *, integer *,
char *, integer *, char *, real *, integer *, real *, real *,
integer *, integer *, char *, complex *, integer *, complex *,
integer *);
real amninv;
extern /* Subroutine */ int ssvdch_(integer *, real *, real *, real *,
real *, integer *);
integer minwrk;
real rtunfl, rtovfl, ulpinv, result[14];
integer mtypes;
/* Fortran I/O blocks */
static cilist io___40 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___41 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___43 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___44 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___45 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___46 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___50 = { 0, 0, 0, fmt_9999, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CCHKBD checks the singular value decomposition (SVD) routines. */
/* CGEBRD reduces a complex general m by n matrix A to real upper or */
/* lower bidiagonal form by an orthogonal transformation: Q' * A * P = B */
/* (or A = Q * B * P'). The matrix B is upper bidiagonal if m >= n */
/* and lower bidiagonal if m < n. */
/* CUNGBR generates the orthogonal matrices Q and P' from CGEBRD. */
/* Note that Q and P are not necessarily square. */
/* CBDSQR computes the singular value decomposition of the bidiagonal */
/* matrix B as B = U S V'. It is called three times to compute */
/* 1) B = U S1 V', where S1 is the diagonal matrix of singular */
/* values and the columns of the matrices U and V are the left */
/* and right singular vectors, respectively, of B. */
/* 2) Same as 1), but the singular values are stored in S2 and the */
/* singular vectors are not computed. */
/* 3) A = (UQ) S (P'V'), the SVD of the original matrix A. */
/* In addition, CBDSQR has an option to apply the left orthogonal matrix */
/* U to a matrix X, useful in least squares applications. */
/* For each pair of matrix dimensions (M,N) and each selected matrix */
/* type, an M by N matrix A and an M by NRHS matrix X are generated. */
/* The problem dimensions are as follows */
/* A: M x N */
/* Q: M x min(M,N) (but M x M if NRHS > 0) */
/* P: min(M,N) x N */
/* B: min(M,N) x min(M,N) */
/* U, V: min(M,N) x min(M,N) */
/* S1, S2 diagonal, order min(M,N) */
/* X: M x NRHS */
/* For each generated matrix, 14 tests are performed: */
/* Test CGEBRD and CUNGBR */
/* (1) | A - Q B PT | / ( |A| max(M,N) ulp ), PT = P' */
/* (2) | I - Q' Q | / ( M ulp ) */
/* (3) | I - PT PT' | / ( N ulp ) */
/* Test CBDSQR on bidiagonal matrix B */
/* (4) | B - U S1 VT | / ( |B| min(M,N) ulp ), VT = V' */
/* (5) | Y - U Z | / ( |Y| max(min(M,N),k) ulp ), where Y = Q' X */
/* and Z = U' Y. */
/* (6) | I - U' U | / ( min(M,N) ulp ) */
/* (7) | I - VT VT' | / ( min(M,N) ulp ) */
/* (8) S1 contains min(M,N) nonnegative values in decreasing order. */
/* (Return 0 if true, 1/ULP if false.) */
/* (9) 0 if the true singular values of B are within THRESH of */
/* those in S1. 2*THRESH if they are not. (Tested using */
/* SSVDCH) */
/* (10) | S1 - S2 | / ( |S1| ulp ), where S2 is computed without */
/* computing U and V. */
/* Test CBDSQR on matrix A */
/* (11) | A - (QU) S (VT PT) | / ( |A| max(M,N) ulp ) */
/* (12) | X - (QU) Z | / ( |X| max(M,k) ulp ) */
/* (13) | I - (QU)'(QU) | / ( M ulp ) */
/* (14) | I - (VT PT) (PT'VT') | / ( N ulp ) */
/* The possible matrix types are */
/* (1) The zero matrix. */
/* (2) The identity matrix. */
/* (3) A diagonal matrix with evenly spaced entries */
/* 1, ..., ULP and random signs. */
/* (ULP = (first number larger than 1) - 1 ) */
/* (4) A diagonal matrix with geometrically spaced entries */
/* 1, ..., ULP and random signs. */
/* (5) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP */
/* and random signs. */
/* (6) Same as (3), but multiplied by SQRT( overflow threshold ) */
/* (7) Same as (3), but multiplied by SQRT( underflow threshold ) */
/* (8) A matrix of the form U D V, where U and V are orthogonal and */
/* D has evenly spaced entries 1, ..., ULP with random signs */
/* on the diagonal. */
/* (9) A matrix of the form U D V, where U and V are orthogonal and */
/* D has geometrically spaced entries 1, ..., ULP with random */
/* signs on the diagonal. */
/* (10) A matrix of the form U D V, where U and V are orthogonal and */
/* D has "clustered" entries 1, ULP,..., ULP with random */
/* signs on the diagonal. */
/* (11) Same as (8), but multiplied by SQRT( overflow threshold ) */
/* (12) Same as (8), but multiplied by SQRT( underflow threshold ) */
/* (13) Rectangular matrix with random entries chosen from (-1,1). */
/* (14) Same as (13), but multiplied by SQRT( overflow threshold ) */
/* (15) Same as (13), but multiplied by SQRT( underflow threshold ) */
/* Special case: */
/* (16) A bidiagonal matrix with random entries chosen from a */
/* logarithmic distribution on [ulp^2,ulp^(-2)] (I.e., each */
/* entry is e^x, where x is chosen uniformly on */
/* [ 2 log(ulp), -2 log(ulp) ] .) For *this* type: */
/* (a) CGEBRD is not called to reduce it to bidiagonal form. */
/* (b) the bidiagonal is min(M,N) x min(M,N); if M<N, the */
/* matrix will be lower bidiagonal, otherwise upper. */
/* (c) only tests 5--8 and 14 are performed. */
/* A subset of the full set of matrix types may be selected through */
/* the logical array DOTYPE. */
/* Arguments */
/* ========== */
/* NSIZES (input) INTEGER */
/* The number of values of M and N contained in the vectors */
/* MVAL and NVAL. The matrix sizes are used in pairs (M,N). */
/* MVAL (input) INTEGER array, dimension (NM) */
/* The values of the matrix row dimension M. */
/* NVAL (input) INTEGER array, dimension (NM) */
/* The values of the matrix column dimension N. */
/* NTYPES (input) INTEGER */
/* The number of elements in DOTYPE. If it is zero, CCHKBD */
/* does nothing. It must be at least zero. If it is MAXTYP+1 */
/* and NSIZES is 1, then an additional type, MAXTYP+1 is */
/* defined, which is to use whatever matrices are in A and B. */
/* This is only useful if DOTYPE(1:MAXTYP) is .FALSE. and */
/* DOTYPE(MAXTYP+1) is .TRUE. . */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* If DOTYPE(j) is .TRUE., then for each size (m,n), a matrix */
/* of type j will be generated. If NTYPES is smaller than the */
/* maximum number of types defined (PARAMETER MAXTYP), then */
/* types NTYPES+1 through MAXTYP will not be generated. If */
/* NTYPES is larger than MAXTYP, DOTYPE(MAXTYP+1) through */
/* DOTYPE(NTYPES) will be ignored. */
/* NRHS (input) INTEGER */
/* The number of columns in the "right-hand side" matrices X, Y, */
/* and Z, used in testing CBDSQR. If NRHS = 0, then the */
/* operations on the right-hand side will not be tested. */
/* NRHS must be at least 0. */
/* ISEED (input/output) INTEGER array, dimension (4) */
/* On entry ISEED specifies the seed of the random number */
/* generator. The array elements should be between 0 and 4095; */
/* if not they will be reduced mod 4096. Also, ISEED(4) must */
/* be odd. The values of ISEED are changed on exit, and can be */
/* used in the next call to CCHKBD to continue the same random */
/* number sequence. */
/* THRESH (input) REAL */
/* The threshold value for the test ratios. A result is */
/* included in the output file if RESULT >= THRESH. To have */
/* every test ratio printed, use THRESH = 0. Note that the */
/* expected value of the test ratios is O(1), so THRESH should */
/* be a reasonably small multiple of 1, e.g., 10 or 100. */
/* A (workspace) COMPLEX array, dimension (LDA,NMAX) */
/* where NMAX is the maximum value of N in NVAL. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,MMAX), */
/* where MMAX is the maximum value of M in MVAL. */
/* BD (workspace) REAL array, dimension */
/* (max(min(MVAL(j),NVAL(j)))) */
/* BE (workspace) REAL array, dimension */
/* (max(min(MVAL(j),NVAL(j)))) */
/* S1 (workspace) REAL array, dimension */
/* (max(min(MVAL(j),NVAL(j)))) */
/* S2 (workspace) REAL array, dimension */
/* (max(min(MVAL(j),NVAL(j)))) */
/* X (workspace) COMPLEX array, dimension (LDX,NRHS) */
/* LDX (input) INTEGER */
/* The leading dimension of the arrays X, Y, and Z. */
/* LDX >= max(1,MMAX). */
/* Y (workspace) COMPLEX array, dimension (LDX,NRHS) */
/* Z (workspace) COMPLEX array, dimension (LDX,NRHS) */
/* Q (workspace) COMPLEX array, dimension (LDQ,MMAX) */
/* LDQ (input) INTEGER */
/* The leading dimension of the array Q. LDQ >= max(1,MMAX). */
/* PT (workspace) COMPLEX array, dimension (LDPT,NMAX) */
/* LDPT (input) INTEGER */
/* The leading dimension of the arrays PT, U, and V. */
/* LDPT >= max(1, max(min(MVAL(j),NVAL(j)))). */
/* U (workspace) COMPLEX array, dimension */
/* (LDPT,max(min(MVAL(j),NVAL(j)))) */
/* V (workspace) COMPLEX array, dimension */
/* (LDPT,max(min(MVAL(j),NVAL(j)))) */
/* WORK (workspace) COMPLEX array, dimension (LWORK) */
/* LWORK (input) INTEGER */
/* The number of entries in WORK. This must be at least */
/* 3(M+N) and M(M + max(M,N,k) + 1) + N*min(M,N) for all */
/* pairs (M,N)=(MM(j),NN(j)) */
/* RWORK (workspace) REAL array, dimension */
/* (5*max(min(M,N))) */
/* NOUT (input) INTEGER */
/* The FORTRAN unit number for printing out error messages */
/* (e.g., if a routine returns IINFO not equal to 0.) */
/* INFO (output) INTEGER */
/* If 0, then everything ran OK. */
/* -1: NSIZES < 0 */
/* -2: Some MM(j) < 0 */
/* -3: Some NN(j) < 0 */
/* -4: NTYPES < 0 */
/* -6: NRHS < 0 */
/* -8: THRESH < 0 */
/* -11: LDA < 1 or LDA < MMAX, where MMAX is max( MM(j) ). */
/* -17: LDB < 1 or LDB < MMAX. */
/* -21: LDQ < 1 or LDQ < MMAX. */
/* -23: LDP < 1 or LDP < MNMAX. */
/* -27: LWORK too small. */
/* If CLATMR, CLATMS, CGEBRD, CUNGBR, or CBDSQR, */
/* returns an error code, the */
/* absolute value of it is returned. */
/* ----------------------------------------------------------------------- */
/* Some Local Variables and Parameters: */
/* ---- ----- --------- --- ---------- */
/* ZERO, ONE Real 0 and 1. */
/* MAXTYP The number of types defined. */
/* NTEST The number of tests performed, or which can */
/* be performed so far, for the current matrix. */
/* MMAX Largest value in NN. */
/* NMAX Largest value in NN. */
/* MNMIN min(MM(j), NN(j)) (the dimension of the bidiagonal */
/* matrix.) */
/* MNMAX The maximum value of MNMIN for j=1,...,NSIZES. */
/* NFAIL The number of tests which have exceeded THRESH */
/* COND, IMODE Values to be passed to the matrix generators. */
/* ANORM Norm of A; passed to matrix generators. */
/* OVFL, UNFL Overflow and underflow thresholds. */
/* RTOVFL, RTUNFL Square roots of the previous 2 values. */
/* ULP, ULPINV Finest relative precision and its inverse. */
/* The following four arrays decode JTYPE: */
/* KTYPE(j) The general type (1-10) for type "j". */
/* KMODE(j) The MODE value to be passed to the matrix */
/* generator for type "j". */
/* KMAGN(j) The order of magnitude ( O(1), */
/* O(overflow^(1/2) ), O(underflow^(1/2) ) */
/* ====================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--mval;
--nval;
--dotype;
--iseed;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--bd;
--be;
--s1;
--s2;
z_dim1 = *ldx;
z_offset = 1 + z_dim1;
z__ -= z_offset;
y_dim1 = *ldx;
y_offset = 1 + y_dim1;
y -= y_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
vt_dim1 = *ldpt;
vt_offset = 1 + vt_dim1;
vt -= vt_offset;
u_dim1 = *ldpt;
u_offset = 1 + u_dim1;
u -= u_offset;
pt_dim1 = *ldpt;
pt_offset = 1 + pt_dim1;
pt -= pt_offset;
--work;
--rwork;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* Check for errors */
*info = 0;
badmm = FALSE_;
badnn = FALSE_;
mmax = 1;
nmax = 1;
mnmax = 1;
minwrk = 1;
i__1 = *nsizes;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = mmax, i__3 = mval[j];
mmax = max(i__2,i__3);
if (mval[j] < 0) {
badmm = TRUE_;
}
/* Computing MAX */
i__2 = nmax, i__3 = nval[j];
nmax = max(i__2,i__3);
if (nval[j] < 0) {
badnn = TRUE_;
}
/* Computing MAX */
/* Computing MIN */
i__4 = mval[j], i__5 = nval[j];
i__2 = mnmax, i__3 = min(i__4,i__5);
mnmax = max(i__2,i__3);
/* Computing MAX */
/* Computing MAX */
i__4 = mval[j], i__5 = nval[j], i__4 = max(i__4,i__5);
/* Computing MIN */
i__6 = nval[j], i__7 = mval[j];
i__2 = minwrk, i__3 = (mval[j] + nval[j]) * 3, i__2 = max(i__2,i__3),
i__3 = mval[j] * (mval[j] + max(i__4,*nrhs) + 1) + nval[j] *
min(i__6,i__7);
minwrk = max(i__2,i__3);
/* L10: */
}
/* Check for errors */
if (*nsizes < 0) {
*info = -1;
} else if (badmm) {
*info = -2;
} else if (badnn) {
*info = -3;
} else if (*ntypes < 0) {
*info = -4;
} else if (*nrhs < 0) {
*info = -6;
} else if (*lda < mmax) {
*info = -11;
} else if (*ldx < mmax) {
*info = -17;
} else if (*ldq < mmax) {
*info = -21;
} else if (*ldpt < mnmax) {
*info = -23;
} else if (minwrk > *lwork) {
*info = -27;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CCHKBD", &i__1);
return 0;
}
/* Initialize constants */
s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17);
s_copy(path + 1, "BD", (ftnlen)2, (ftnlen)2);
nfail = 0;
ntest = 0;
unfl = slamch_("Safe minimum");
ovfl = slamch_("Overflow");
slabad_(&unfl, &ovfl);
ulp = slamch_("Precision");
ulpinv = 1.f / ulp;
log2ui = (integer) (log(ulpinv) / log(2.f));
rtunfl = sqrt(unfl);
rtovfl = sqrt(ovfl);
infoc_1.infot = 0;
/* Loop over sizes, types */
i__1 = *nsizes;
for (jsize = 1; jsize <= i__1; ++jsize) {
m = mval[jsize];
n = nval[jsize];
mnmin = min(m,n);
/* Computing MAX */
i__2 = max(m,n);
amninv = 1.f / max(i__2,1);
if (*nsizes != 1) {
mtypes = min(16,*ntypes);
} else {
mtypes = min(17,*ntypes);
}
i__2 = mtypes;
for (jtype = 1; jtype <= i__2; ++jtype) {
if (! dotype[jtype]) {
goto L170;
}
for (j = 1; j <= 4; ++j) {
ioldsd[j - 1] = iseed[j];
/* L20: */
}
for (j = 1; j <= 14; ++j) {
result[j - 1] = -1.f;
/* L30: */
}
*(unsigned char *)uplo = ' ';
/* Compute "A" */
/* Control parameters: */
/* KMAGN KMODE KTYPE */
/* =1 O(1) clustered 1 zero */
/* =2 large clustered 2 identity */
/* =3 small exponential (none) */
/* =4 arithmetic diagonal, (w/ eigenvalues) */
/* =5 random symmetric, w/ eigenvalues */
/* =6 nonsymmetric, w/ singular values */
/* =7 random diagonal */
/* =8 random symmetric */
/* =9 random nonsymmetric */
/* =10 random bidiagonal (log. distrib.) */
if (mtypes > 16) {
goto L100;
}
itype = ktype[jtype - 1];
imode = kmode[jtype - 1];
/* Compute norm */
switch (kmagn[jtype - 1]) {
case 1: goto L40;
case 2: goto L50;
case 3: goto L60;
}
L40:
anorm = 1.f;
goto L70;
L50:
anorm = rtovfl * ulp * amninv;
goto L70;
L60:
anorm = rtunfl * max(m,n) * ulpinv;
goto L70;
L70:
claset_("Full", lda, &n, &c_b1, &c_b1, &a[a_offset], lda);
iinfo = 0;
cond = ulpinv;
bidiag = FALSE_;
if (itype == 1) {
/* Zero matrix */
iinfo = 0;
} else if (itype == 2) {
/* Identity */
i__3 = mnmin;
for (jcol = 1; jcol <= i__3; ++jcol) {
i__4 = jcol + jcol * a_dim1;
a[i__4].r = anorm, a[i__4].i = 0.f;
/* L80: */
}
} else if (itype == 4) {
/* Diagonal Matrix, [Eigen]values Specified */
clatms_(&mnmin, &mnmin, "S", &iseed[1], "N", &rwork[1], &
imode, &cond, &anorm, &c__0, &c__0, "N", &a[a_offset],
lda, &work[1], &iinfo);
} else if (itype == 5) {
/* Symmetric, eigenvalues specified */
clatms_(&mnmin, &mnmin, "S", &iseed[1], "S", &rwork[1], &
imode, &cond, &anorm, &m, &n, "N", &a[a_offset], lda,
&work[1], &iinfo);
} else if (itype == 6) {
/* Nonsymmetric, singular values specified */
clatms_(&m, &n, "S", &iseed[1], "N", &rwork[1], &imode, &cond,
&anorm, &m, &n, "N", &a[a_offset], lda, &work[1], &
iinfo);
} else if (itype == 7) {
/* Diagonal, random entries */
clatmr_(&mnmin, &mnmin, "S", &iseed[1], "N", &work[1], &c__6,
&c_b37, &c_b2, "T", "N", &work[mnmin + 1], &c__1, &
c_b37, &work[(mnmin << 1) + 1], &c__1, &c_b37, "N",
iwork, &c__0, &c__0, &c_b47, &anorm, "NO", &a[
a_offset], lda, iwork, &iinfo);
} else if (itype == 8) {
/* Symmetric, random entries */
clatmr_(&mnmin, &mnmin, "S", &iseed[1], "S", &work[1], &c__6,
&c_b37, &c_b2, "T", "N", &work[mnmin + 1], &c__1, &
c_b37, &work[m + mnmin + 1], &c__1, &c_b37, "N",
iwork, &m, &n, &c_b47, &anorm, "NO", &a[a_offset],
lda, iwork, &iinfo);
} else if (itype == 9) {
/* Nonsymmetric, random entries */
clatmr_(&m, &n, "S", &iseed[1], "N", &work[1], &c__6, &c_b37,
&c_b2, "T", "N", &work[mnmin + 1], &c__1, &c_b37, &
work[m + mnmin + 1], &c__1, &c_b37, "N", iwork, &m, &
n, &c_b47, &anorm, "NO", &a[a_offset], lda, iwork, &
iinfo);
} else if (itype == 10) {
/* Bidiagonal, random entries */
temp1 = log(ulp) * -2.f;
i__3 = mnmin;
for (j = 1; j <= i__3; ++j) {
bd[j] = exp(temp1 * slarnd_(&c__2, &iseed[1]));
if (j < mnmin) {
be[j] = exp(temp1 * slarnd_(&c__2, &iseed[1]));
}
/* L90: */
}
iinfo = 0;
bidiag = TRUE_;
if (m >= n) {
*(unsigned char *)uplo = 'U';
} else {
*(unsigned char *)uplo = 'L';
}
} else {
iinfo = 1;
}
if (iinfo == 0) {
/* Generate Right-Hand Side */
if (bidiag) {
clatmr_(&mnmin, nrhs, "S", &iseed[1], "N", &work[1], &
c__6, &c_b37, &c_b2, "T", "N", &work[mnmin + 1], &
c__1, &c_b37, &work[(mnmin << 1) + 1], &c__1, &
c_b37, "N", iwork, &mnmin, nrhs, &c_b47, &c_b37,
"NO", &y[y_offset], ldx, iwork, &iinfo);
} else {
clatmr_(&m, nrhs, "S", &iseed[1], "N", &work[1], &c__6, &
c_b37, &c_b2, "T", "N", &work[m + 1], &c__1, &
c_b37, &work[(m << 1) + 1], &c__1, &c_b37, "N",
iwork, &m, nrhs, &c_b47, &c_b37, "NO", &x[
x_offset], ldx, iwork, &iinfo);
}
}
/* Error Exit */
if (iinfo != 0) {
io___40.ciunit = *nout;
s_wsfe(&io___40);
do_fio(&c__1, "Generator", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
return 0;
}
L100:
/* Call CGEBRD and CUNGBR to compute B, Q, and P, do tests. */
if (! bidiag) {
/* Compute transformations to reduce A to bidiagonal form: */
/* B := Q' * A * P. */
clacpy_(" ", &m, &n, &a[a_offset], lda, &q[q_offset], ldq);
i__3 = *lwork - (mnmin << 1);
cgebrd_(&m, &n, &q[q_offset], ldq, &bd[1], &be[1], &work[1], &
work[mnmin + 1], &work[(mnmin << 1) + 1], &i__3, &
iinfo);
/* Check error code from CGEBRD. */
if (iinfo != 0) {
io___41.ciunit = *nout;
s_wsfe(&io___41);
do_fio(&c__1, "CGEBRD", (ftnlen)6);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
;
e_wsfe();
*info = abs(iinfo);
return 0;
}
clacpy_(" ", &m, &n, &q[q_offset], ldq, &pt[pt_offset], ldpt);
if (m >= n) {
*(unsigned char *)uplo = 'U';
} else {
*(unsigned char *)uplo = 'L';
}
/* Generate Q */
mq = m;
if (*nrhs <= 0) {
mq = mnmin;
}
i__3 = *lwork - (mnmin << 1);
cungbr_("Q", &m, &mq, &n, &q[q_offset], ldq, &work[1], &work[(
mnmin << 1) + 1], &i__3, &iinfo);
/* Check error code from CUNGBR. */
if (iinfo != 0) {
io___43.ciunit = *nout;
s_wsfe(&io___43);
do_fio(&c__1, "CUNGBR(Q)", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
;
e_wsfe();
*info = abs(iinfo);
return 0;
}
/* Generate P' */
i__3 = *lwork - (mnmin << 1);
cungbr_("P", &mnmin, &n, &m, &pt[pt_offset], ldpt, &work[
mnmin + 1], &work[(mnmin << 1) + 1], &i__3, &iinfo);
/* Check error code from CUNGBR. */
if (iinfo != 0) {
io___44.ciunit = *nout;
s_wsfe(&io___44);
do_fio(&c__1, "CUNGBR(P)", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
;
e_wsfe();
*info = abs(iinfo);
return 0;
}
/* Apply Q' to an M by NRHS matrix X: Y := Q' * X. */
cgemm_("Conjugate transpose", "No transpose", &m, nrhs, &m, &
c_b2, &q[q_offset], ldq, &x[x_offset], ldx, &c_b1, &y[
y_offset], ldx);
/* Test 1: Check the decomposition A := Q * B * PT */
/* 2: Check the orthogonality of Q */
/* 3: Check the orthogonality of PT */
cbdt01_(&m, &n, &c__1, &a[a_offset], lda, &q[q_offset], ldq, &
bd[1], &be[1], &pt[pt_offset], ldpt, &work[1], &rwork[
1], result);
cunt01_("Columns", &m, &mq, &q[q_offset], ldq, &work[1],
lwork, &rwork[1], &result[1]);
cunt01_("Rows", &mnmin, &n, &pt[pt_offset], ldpt, &work[1],
lwork, &rwork[1], &result[2]);
}
/* Use CBDSQR to form the SVD of the bidiagonal matrix B: */
/* B := U * S1 * VT, and compute Z = U' * Y. */
scopy_(&mnmin, &bd[1], &c__1, &s1[1], &c__1);
if (mnmin > 0) {
i__3 = mnmin - 1;
scopy_(&i__3, &be[1], &c__1, &rwork[1], &c__1);
}
clacpy_(" ", &m, nrhs, &y[y_offset], ldx, &z__[z_offset], ldx);
claset_("Full", &mnmin, &mnmin, &c_b1, &c_b2, &u[u_offset], ldpt);
claset_("Full", &mnmin, &mnmin, &c_b1, &c_b2, &vt[vt_offset],
ldpt);
cbdsqr_(uplo, &mnmin, &mnmin, &mnmin, nrhs, &s1[1], &rwork[1], &
vt[vt_offset], ldpt, &u[u_offset], ldpt, &z__[z_offset],
ldx, &rwork[mnmin + 1], &iinfo);
/* Check error code from CBDSQR. */
if (iinfo != 0) {
io___45.ciunit = *nout;
s_wsfe(&io___45);
do_fio(&c__1, "CBDSQR(vects)", (ftnlen)13);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
if (iinfo < 0) {
return 0;
} else {
result[3] = ulpinv;
goto L150;
}
}
/* Use CBDSQR to compute only the singular values of the */
/* bidiagonal matrix B; U, VT, and Z should not be modified. */
scopy_(&mnmin, &bd[1], &c__1, &s2[1], &c__1);
if (mnmin > 0) {
i__3 = mnmin - 1;
scopy_(&i__3, &be[1], &c__1, &rwork[1], &c__1);
}
cbdsqr_(uplo, &mnmin, &c__0, &c__0, &c__0, &s2[1], &rwork[1], &vt[
vt_offset], ldpt, &u[u_offset], ldpt, &z__[z_offset], ldx,
&rwork[mnmin + 1], &iinfo);
/* Check error code from CBDSQR. */
if (iinfo != 0) {
io___46.ciunit = *nout;
s_wsfe(&io___46);
do_fio(&c__1, "CBDSQR(values)", (ftnlen)14);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
if (iinfo < 0) {
return 0;
} else {
result[8] = ulpinv;
goto L150;
}
}
/* Test 4: Check the decomposition B := U * S1 * VT */
/* 5: Check the computation Z := U' * Y */
/* 6: Check the orthogonality of U */
/* 7: Check the orthogonality of VT */
cbdt03_(uplo, &mnmin, &c__1, &bd[1], &be[1], &u[u_offset], ldpt, &
s1[1], &vt[vt_offset], ldpt, &work[1], &result[3]);
cbdt02_(&mnmin, nrhs, &y[y_offset], ldx, &z__[z_offset], ldx, &u[
u_offset], ldpt, &work[1], &rwork[1], &result[4]);
cunt01_("Columns", &mnmin, &mnmin, &u[u_offset], ldpt, &work[1],
lwork, &rwork[1], &result[5]);
cunt01_("Rows", &mnmin, &mnmin, &vt[vt_offset], ldpt, &work[1],
lwork, &rwork[1], &result[6]);
/* Test 8: Check that the singular values are sorted in */
/* non-increasing order and are non-negative */
result[7] = 0.f;
i__3 = mnmin - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
if (s1[i__] < s1[i__ + 1]) {
result[7] = ulpinv;
}
if (s1[i__] < 0.f) {
result[7] = ulpinv;
}
/* L110: */
}
if (mnmin >= 1) {
if (s1[mnmin] < 0.f) {
result[7] = ulpinv;
}
}
/* Test 9: Compare CBDSQR with and without singular vectors */
temp2 = 0.f;
i__3 = mnmin;
for (j = 1; j <= i__3; ++j) {
/* Computing MAX */
/* Computing MAX */
r__6 = (r__1 = s1[j], dabs(r__1)), r__7 = (r__2 = s2[j], dabs(
r__2));
r__4 = sqrt(unfl) * dmax(s1[1],1.f), r__5 = ulp * dmax(r__6,
r__7);
temp1 = (r__3 = s1[j] - s2[j], dabs(r__3)) / dmax(r__4,r__5);
temp2 = dmax(temp1,temp2);
/* L120: */
}
result[8] = temp2;
/* Test 10: Sturm sequence test of singular values */
/* Go up by factors of two until it succeeds */
temp1 = *thresh * (.5f - ulp);
i__3 = log2ui;
for (j = 0; j <= i__3; ++j) {
ssvdch_(&mnmin, &bd[1], &be[1], &s1[1], &temp1, &iinfo);
if (iinfo == 0) {
goto L140;
}
temp1 *= 2.f;
/* L130: */
}
L140:
result[9] = temp1;
/* Use CBDSQR to form the decomposition A := (QU) S (VT PT) */
/* from the bidiagonal form A := Q B PT. */
if (! bidiag) {
scopy_(&mnmin, &bd[1], &c__1, &s2[1], &c__1);
if (mnmin > 0) {
i__3 = mnmin - 1;
scopy_(&i__3, &be[1], &c__1, &rwork[1], &c__1);
}
cbdsqr_(uplo, &mnmin, &n, &m, nrhs, &s2[1], &rwork[1], &pt[
pt_offset], ldpt, &q[q_offset], ldq, &y[y_offset],
ldx, &rwork[mnmin + 1], &iinfo);
/* Test 11: Check the decomposition A := Q*U * S2 * VT*PT */
/* 12: Check the computation Z := U' * Q' * X */
/* 13: Check the orthogonality of Q*U */
/* 14: Check the orthogonality of VT*PT */
cbdt01_(&m, &n, &c__0, &a[a_offset], lda, &q[q_offset], ldq, &
s2[1], dumma, &pt[pt_offset], ldpt, &work[1], &rwork[
1], &result[10]);
cbdt02_(&m, nrhs, &x[x_offset], ldx, &y[y_offset], ldx, &q[
q_offset], ldq, &work[1], &rwork[1], &result[11]);
cunt01_("Columns", &m, &mq, &q[q_offset], ldq, &work[1],
lwork, &rwork[1], &result[12]);
cunt01_("Rows", &mnmin, &n, &pt[pt_offset], ldpt, &work[1],
lwork, &rwork[1], &result[13]);
}
/* End of Loop -- Check for RESULT(j) > THRESH */
L150:
for (j = 1; j <= 14; ++j) {
if (result[j - 1] >= *thresh) {
if (nfail == 0) {
slahd2_(nout, path);
}
io___50.ciunit = *nout;
s_wsfe(&io___50);
do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[j - 1], (ftnlen)sizeof(real)
);
e_wsfe();
++nfail;
}
/* L160: */
}
if (! bidiag) {
ntest += 14;
} else {
ntest += 5;
}
L170:
;
}
/* L180: */
}
/* Summary */
alasum_(path, nout, &nfail, &ntest, &c__0);
return 0;
/* End of CCHKBD */
} /* cchkbd_ */
