void sgesvd(char jobu, char jobvt, int m, int n, float *sa,
int lda, float *s, float *su, int ldu, float *svt,
int ldvt, int *info)
{
int lwork ;
float *work ;
lwork = MAX(3*MIN(m,n)+MAX(m,n),5*MIN(m,n)-4) * 2 ;
allot ( float *, work, lwork ) ;
sgesvd_ ( &jobu, &jobvt, &m, &n, sa, &lda, s, su, &ldu, svt, &ldvt,
work, &lwork, info );
free(work) ;
}
void THLapack_(gesvd)(char jobu, char jobvt, int m, int n, real *a, int lda, real *s, real *u, int ldu, real *vt, int ldvt, real *work, int lwork, int *info)
{
#ifdef USE_LAPACK
#if defined(TH_REAL_IS_DOUBLE)
dgesvd_( &jobu, &jobvt, &m, &n, a, &lda, s, u, &ldu, vt, &ldvt, work, &lwork, info);
#else
sgesvd_( &jobu, &jobvt, &m, &n, a, &lda, s, u, &ldu, vt, &ldvt, work, &lwork, info);
#endif
#else
THError("gesvd : Lapack library not found in compile time\n");
#endif
}
void THLapack_(gesvd)(char jobu, char jobvt, int m, int n, real *a, int lda, real *s, real *u, int ldu, real *vt, int ldvt, real *work, int lwork, int *info)
{
#ifdef USE_LAPACK
#if defined(TH_REAL_IS_DOUBLE)
extern void dgesvd_(char *jobu, char *jobvt, int *m, int *n, double *a, int *lda, double *s, double *u, int *ldu, double *vt, int *ldvt, double *work, int *lwork, int *info);
dgesvd_( &jobu, &jobvt, &m, &n, a, &lda, s, u, &ldu, vt, &ldvt, work, &lwork, info);
#else
extern void sgesvd_(char *jobu, char *jobvt, int *m, int *n, float *a, int *lda, float *s, float *u, int *ldu, float *vt, int *ldvt, float *work, int *lwork, int *info);
sgesvd_( &jobu, &jobvt, &m, &n, a, &lda, s, u, &ldu, vt, &ldvt, work, &lwork, info);
#endif
#else
THError("gesvd : Lapack library not found in compile time\n");
#endif
}
void pca(Desc desc, int newDimension, float* basis) {
char jobu = 'A', jobvt = 'N';
int M = desc.dimension, N = desc.n;
int l = M>N?N:M;
int info,lwork=5*l;
float* A = new float[M*N];
memcpy(A,desc.data,M*N*sizeof(float));
float* work = new float[lwork];
float* S = new float[l];
float* U = new float[M*M];
sgesvd_(&jobu, &jobvt, &M, &N, A, &M,
S, U, &M, NULL, &N, work, &lwork, &info);
for (int i=0;i<M;i++)
memcpy(basis + i*newDimension, U + i*M,newDimension * sizeof(float));
delete[] work;
delete[] S;
delete[] U;
}
inline void
svd_call( svd_params< float >& p )
{
//std::cout << "calling lapack svd (single precision) " << std::endl;
sgesvd_(
&p.jobu,
&p.jobvt,
&p.m,
&p.n,
p.a,
&p.lda,
p.s,
p.u,
&p.ldu,
p.vt,
&p.ldvt,
p.work,
&p.lwork,
&p.info
);
}
GURLS_EXPORT int gesvd_(char *jobu, char *jobvt, int *m, int *n, float *a, int *lda, float *s, float *u, int *ldu, float *vt, int *ldvt, float *work, int *lwork, int *info)
{
return sgesvd_(jobu, jobvt, m, n, a, lda, s, u, ldu, vt, ldvt, work, lwork, info);
}
/* Subroutine */ int serred_(char *path, integer *nunit)
{
/* Format strings */
static char fmt_9999[] = "(1x,a3,\002 routines passed the tests of the e"
"rror exits (\002,i3,\002 tests done)\002)";
static char fmt_9998[] = "(\002 *** \002,a3,\002 routines failed the tes"
"ts of the error ex\002,\002its ***\002)";
/* Builtin functions */
integer s_wsle(cilist *), e_wsle(void);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
static integer info, sdim;
static real a[16] /* was [4][4] */;
static logical b[4];
static integer i__, j;
static real s[4], u[16] /* was [4][4] */, w[16], abnrm;
extern /* Subroutine */ int sgees_(char *, char *, L_fp, integer *, real *
, integer *, integer *, real *, real *, real *, integer *, real *,
integer *, logical *, integer *), sgeev_(char *,
char *, integer *, real *, integer *, real *, real *, real *,
integer *, real *, integer *, real *, integer *, integer *);
static char c2[2];
static real r1[4], r2[4];
static integer iw[8];
static real wi[4];
static integer nt;
static real vl[16] /* was [4][4] */, vr[16] /* was [4][4] */, wr[
4], vt[16] /* was [4][4] */;
extern /* Subroutine */ int sgesdd_(char *, integer *, integer *, real *,
integer *, real *, real *, integer *, real *, integer *, real *,
integer *, integer *, integer *);
extern logical lsamen_(integer *, char *, char *);
extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical
*, logical *), sgesvd_(char *, char *, integer *, integer
*, real *, integer *, real *, real *, integer *, real *, integer *
, real *, integer *, integer *);
extern logical sslect_();
extern /* Subroutine */ int sgeesx_(char *, char *, L_fp, char *, integer
*, real *, integer *, integer *, real *, real *, real *, integer *
, real *, real *, real *, integer *, integer *, integer *,
logical *, integer *), sgeevx_(char *,
char *, char *, char *, integer *, real *, integer *, real *,
real *, real *, integer *, real *, integer *, integer *, integer *
, real *, real *, real *, real *, real *, integer *, integer *,
integer *);
static integer ihi, ilo;
/* Fortran I/O blocks */
static cilist io___1 = { 0, 0, 0, 0, 0 };
static cilist io___24 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___25 = { 0, 0, 0, fmt_9998, 0 };
#define a_ref(a_1,a_2) a[(a_2)*4 + a_1 - 5]
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
December 22, 1999
Purpose
=======
SERRED tests the error exits for the eigenvalue driver routines for
REAL matrices:
PATH driver description
---- ------ -----------
SEV SGEEV find eigenvalues/eigenvectors for nonsymmetric A
SES SGEES find eigenvalues/Schur form for nonsymmetric A
SVX SGEEVX SGEEV + balancing and condition estimation
SSX SGEESX SGEES + balancing and condition estimation
SBD SGESVD compute SVD of an M-by-N matrix A
SGESDD compute SVD of an M-by-N matrix A (by divide and
conquer)
Arguments
=========
PATH (input) CHARACTER*3
The LAPACK path name for the routines to be tested.
NUNIT (input) INTEGER
The unit number for output.
===================================================================== */
infoc_1.nout = *nunit;
io___1.ciunit = infoc_1.nout;
s_wsle(&io___1);
e_wsle();
s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
/* Initialize A */
for (j = 1; j <= 4; ++j) {
for (i__ = 1; i__ <= 4; ++i__) {
a_ref(i__, j) = 0.f;
/* L10: */
}
/* L20: */
}
for (i__ = 1; i__ <= 4; ++i__) {
a_ref(i__, i__) = 1.f;
/* L30: */
}
infoc_1.ok = TRUE_;
nt = 0;
if (lsamen_(&c__2, c2, "EV")) {
/* Test SGEEV */
s_copy(srnamc_1.srnamt, "SGEEV ", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
sgeev_("X", "N", &c__0, a, &c__1, wr, wi, vl, &c__1, vr, &c__1, w, &
c__1, &info);
chkxer_("SGEEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
sgeev_("N", "X", &c__0, a, &c__1, wr, wi, vl, &c__1, vr, &c__1, w, &
c__1, &info);
chkxer_("SGEEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
sgeev_("N", "N", &c_n1, a, &c__1, wr, wi, vl, &c__1, vr, &c__1, w, &
c__1, &info);
chkxer_("SGEEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
sgeev_("N", "N", &c__2, a, &c__1, wr, wi, vl, &c__1, vr, &c__1, w, &
c__6, &info);
chkxer_("SGEEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 9;
sgeev_("V", "N", &c__2, a, &c__2, wr, wi, vl, &c__1, vr, &c__1, w, &
c__8, &info);
chkxer_("SGEEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 11;
sgeev_("N", "V", &c__2, a, &c__2, wr, wi, vl, &c__1, vr, &c__1, w, &
c__8, &info);
chkxer_("SGEEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 13;
sgeev_("V", "V", &c__1, a, &c__1, wr, wi, vl, &c__1, vr, &c__1, w, &
c__3, &info);
chkxer_("SGEEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 7;
} else if (lsamen_(&c__2, c2, "ES")) {
/* Test SGEES */
s_copy(srnamc_1.srnamt, "SGEES ", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
sgees_("X", "N", (L_fp)sslect_, &c__0, a, &c__1, &sdim, wr, wi, vl, &
c__1, w, &c__1, b, &info);
chkxer_("SGEES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
sgees_("N", "X", (L_fp)sslect_, &c__0, a, &c__1, &sdim, wr, wi, vl, &
c__1, w, &c__1, b, &info);
chkxer_("SGEES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
sgees_("N", "S", (L_fp)sslect_, &c_n1, a, &c__1, &sdim, wr, wi, vl, &
c__1, w, &c__1, b, &info);
chkxer_("SGEES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
sgees_("N", "S", (L_fp)sslect_, &c__2, a, &c__1, &sdim, wr, wi, vl, &
c__1, w, &c__6, b, &info);
chkxer_("SGEES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 11;
sgees_("V", "S", (L_fp)sslect_, &c__2, a, &c__2, &sdim, wr, wi, vl, &
c__1, w, &c__6, b, &info);
chkxer_("SGEES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 13;
sgees_("N", "S", (L_fp)sslect_, &c__1, a, &c__1, &sdim, wr, wi, vl, &
c__1, w, &c__2, b, &info);
chkxer_("SGEES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 6;
} else if (lsamen_(&c__2, c2, "VX")) {
/* Test SGEEVX */
s_copy(srnamc_1.srnamt, "SGEEVX", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
sgeevx_("X", "N", "N", "N", &c__0, a, &c__1, wr, wi, vl, &c__1, vr, &
c__1, &ilo, &ihi, s, &abnrm, r1, r2, w, &c__1, iw, &info);
chkxer_("SGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
sgeevx_("N", "X", "N", "N", &c__0, a, &c__1, wr, wi, vl, &c__1, vr, &
c__1, &ilo, &ihi, s, &abnrm, r1, r2, w, &c__1, iw, &info);
chkxer_("SGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
sgeevx_("N", "N", "X", "N", &c__0, a, &c__1, wr, wi, vl, &c__1, vr, &
c__1, &ilo, &ihi, s, &abnrm, r1, r2, w, &c__1, iw, &info);
chkxer_("SGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
sgeevx_("N", "N", "N", "X", &c__0, a, &c__1, wr, wi, vl, &c__1, vr, &
c__1, &ilo, &ihi, s, &abnrm, r1, r2, w, &c__1, iw, &info);
chkxer_("SGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
sgeevx_("N", "N", "N", "N", &c_n1, a, &c__1, wr, wi, vl, &c__1, vr, &
c__1, &ilo, &ihi, s, &abnrm, r1, r2, w, &c__1, iw, &info);
chkxer_("SGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
sgeevx_("N", "N", "N", "N", &c__2, a, &c__1, wr, wi, vl, &c__1, vr, &
c__1, &ilo, &ihi, s, &abnrm, r1, r2, w, &c__1, iw, &info);
chkxer_("SGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 11;
sgeevx_("N", "V", "N", "N", &c__2, a, &c__2, wr, wi, vl, &c__1, vr, &
c__1, &ilo, &ihi, s, &abnrm, r1, r2, w, &c__6, iw, &info);
chkxer_("SGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 13;
sgeevx_("N", "N", "V", "N", &c__2, a, &c__2, wr, wi, vl, &c__1, vr, &
c__1, &ilo, &ihi, s, &abnrm, r1, r2, w, &c__6, iw, &info);
chkxer_("SGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 21;
sgeevx_("N", "N", "N", "N", &c__1, a, &c__1, wr, wi, vl, &c__1, vr, &
c__1, &ilo, &ihi, s, &abnrm, r1, r2, w, &c__1, iw, &info);
chkxer_("SGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 21;
sgeevx_("N", "V", "N", "N", &c__1, a, &c__1, wr, wi, vl, &c__1, vr, &
c__1, &ilo, &ihi, s, &abnrm, r1, r2, w, &c__2, iw, &info);
chkxer_("SGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 21;
sgeevx_("N", "N", "V", "V", &c__1, a, &c__1, wr, wi, vl, &c__1, vr, &
c__1, &ilo, &ihi, s, &abnrm, r1, r2, w, &c__3, iw, &info);
chkxer_("SGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 11;
} else if (lsamen_(&c__2, c2, "SX")) {
/* Test SGEESX */
s_copy(srnamc_1.srnamt, "SGEESX", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
sgeesx_("X", "N", (L_fp)sslect_, "N", &c__0, a, &c__1, &sdim, wr, wi,
vl, &c__1, r1, r2, w, &c__1, iw, &c__1, b, &info);
chkxer_("SGEESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
sgeesx_("N", "X", (L_fp)sslect_, "N", &c__0, a, &c__1, &sdim, wr, wi,
vl, &c__1, r1, r2, w, &c__1, iw, &c__1, b, &info);
chkxer_("SGEESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
sgeesx_("N", "N", (L_fp)sslect_, "X", &c__0, a, &c__1, &sdim, wr, wi,
vl, &c__1, r1, r2, w, &c__1, iw, &c__1, b, &info);
chkxer_("SGEESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
sgeesx_("N", "N", (L_fp)sslect_, "N", &c_n1, a, &c__1, &sdim, wr, wi,
vl, &c__1, r1, r2, w, &c__1, iw, &c__1, b, &info);
chkxer_("SGEESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
sgeesx_("N", "N", (L_fp)sslect_, "N", &c__2, a, &c__1, &sdim, wr, wi,
vl, &c__1, r1, r2, w, &c__6, iw, &c__1, b, &info);
chkxer_("SGEESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 12;
sgeesx_("V", "N", (L_fp)sslect_, "N", &c__2, a, &c__2, &sdim, wr, wi,
vl, &c__1, r1, r2, w, &c__6, iw, &c__1, b, &info);
chkxer_("SGEESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 16;
sgeesx_("N", "N", (L_fp)sslect_, "N", &c__1, a, &c__1, &sdim, wr, wi,
vl, &c__1, r1, r2, w, &c__2, iw, &c__1, b, &info);
chkxer_("SGEESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 7;
} else if (lsamen_(&c__2, c2, "BD")) {
/* Test SGESVD */
s_copy(srnamc_1.srnamt, "SGESVD", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
sgesvd_("X", "N", &c__0, &c__0, a, &c__1, s, u, &c__1, vt, &c__1, w, &
c__1, &info);
chkxer_("SGESVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
sgesvd_("N", "X", &c__0, &c__0, a, &c__1, s, u, &c__1, vt, &c__1, w, &
c__1, &info);
chkxer_("SGESVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
sgesvd_("O", "O", &c__0, &c__0, a, &c__1, s, u, &c__1, vt, &c__1, w, &
c__1, &info);
chkxer_("SGESVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
sgesvd_("N", "N", &c_n1, &c__0, a, &c__1, s, u, &c__1, vt, &c__1, w, &
c__1, &info);
chkxer_("SGESVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
sgesvd_("N", "N", &c__0, &c_n1, a, &c__1, s, u, &c__1, vt, &c__1, w, &
c__1, &info);
chkxer_("SGESVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
sgesvd_("N", "N", &c__2, &c__1, a, &c__1, s, u, &c__1, vt, &c__1, w, &
c__5, &info);
chkxer_("SGESVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 9;
sgesvd_("A", "N", &c__2, &c__1, a, &c__2, s, u, &c__1, vt, &c__1, w, &
c__5, &info);
chkxer_("SGESVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 11;
sgesvd_("N", "A", &c__1, &c__2, a, &c__1, s, u, &c__1, vt, &c__1, w, &
c__5, &info);
chkxer_("SGESVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 8;
/* Test SGESDD */
s_copy(srnamc_1.srnamt, "SGESDD", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
sgesdd_("X", &c__0, &c__0, a, &c__1, s, u, &c__1, vt, &c__1, w, &c__1,
iw, &info);
chkxer_("SGESDD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
sgesdd_("N", &c_n1, &c__0, a, &c__1, s, u, &c__1, vt, &c__1, w, &c__1,
iw, &info);
chkxer_("SGESDD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
sgesdd_("N", &c__0, &c_n1, a, &c__1, s, u, &c__1, vt, &c__1, w, &c__1,
iw, &info);
chkxer_("SGESDD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
sgesdd_("N", &c__2, &c__1, a, &c__1, s, u, &c__1, vt, &c__1, w, &c__5,
iw, &info);
chkxer_("SGESDD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
sgesdd_("A", &c__2, &c__1, a, &c__2, s, u, &c__1, vt, &c__1, w, &c__5,
iw, &info);
chkxer_("SGESDD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 10;
sgesdd_("A", &c__1, &c__2, a, &c__1, s, u, &c__1, vt, &c__1, w, &c__5,
iw, &info);
chkxer_("SGESDD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 6;
}
/* Print a summary line. */
if (! lsamen_(&c__2, c2, "BD")) {
if (infoc_1.ok) {
io___24.ciunit = infoc_1.nout;
s_wsfe(&io___24);
do_fio(&c__1, path, (ftnlen)3);
do_fio(&c__1, (char *)&nt, (ftnlen)sizeof(integer));
e_wsfe();
} else {
io___25.ciunit = infoc_1.nout;
s_wsfe(&io___25);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
}
}
return 0;
/* End of SERRED */
} /* serred_ */
/* 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 */
integer i__, j, i1, mm;
real pl[2];
integer mn2, qba, qbb;
real ulp, temp1, temp2, abnrm;
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 *);
char sense[1];
integer nerrs, ntest;
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 *);
real thrsh2;
logical ilabad;
extern /* Subroutine */ int slabad_(real *, real *);
integer bdspac;
extern doublereal slamch_(char *), slange_(char *, integer *,
integer *, real *, integer *, real *);
extern /* Subroutine */ int xerbla_(char *, integer *);
real difest[2];
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
real bignum;
extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
*, integer *);
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 *);
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 *);
integer minwrk, maxwrk;
real smlnum, ulpinv;
integer nptknt;
real result[10];
extern logical slctsx_();
integer ntestt, prtype;
/* 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 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* 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. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Executable Statements .. */
/* Check for errors */
/* Parameter adjustments */
q_dim1 = *lda;
q_offset = 1 + q_dim1;
q -= q_offset;
z_dim1 = *lda;
z_offset = 1 + z_dim1;
z__ -= z_offset;
bi_dim1 = *lda;
bi_offset = 1 + bi_dim1;
bi -= bi_offset;
ai_dim1 = *lda;
ai_offset = 1 + ai_dim1;
ai -= ai_offset;
b_dim1 = *lda;
b_offset = 1 + b_dim1;
b -= b_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--alphar;
--alphai;
--beta;
c_dim1 = *ldc;
c_offset = 1 + c_dim1;
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);
/* Computing MAX */
i__1 = maxwrk, i__2 = (*nsize + 1) * 9 + *nsize * ilaenv_(&c__1,
"SORGQR", " ", nsize, &c__1, nsize, &c_n1);
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);
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[mn_1.m + 1 + (mn_1.m + 1) * ai_dim1], lda, &ai[
(mn_1.m + 1) * ai_dim1 + 1], lda, &bi[bi_offset],
lda, &bi[mn_1.m + 1 + (mn_1.m + 1) * bi_dim1],
lda, &bi[(mn_1.m + 1) * bi_dim1 + 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[j + j * ai_dim1], 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[j + j * bi_dim1], dabs(r__6));
temp2 = ((r__1 = alphar[j] - ai[j + j * ai_dim1],
dabs(r__1)) / dmax(r__7,r__8) + (r__4 =
beta[j] - bi[j + j * bi_dim1], dabs(r__4))
/ dmax(r__9,r__10)) / ulp;
if (j < mn_1.mplusn) {
if (ai[j + 1 + j * ai_dim1] != 0.f) {
ilabad = TRUE_;
result[4] = ulpinv;
}
}
if (j > 1) {
if (ai[j + (j - 1) * ai_dim1] != 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[i1 + 2 + (i1 + 1) * ai_dim1] != 0.f) {
ilabad = TRUE_;
result[4] = ulpinv;
}
} else if (i1 > 1) {
if (ai[i1 + (i1 - 1) * ai_dim1] != 0.f) {
ilabad = TRUE_;
result[4] = ulpinv;
}
}
if (! ilabad) {
sget53_(&ai[i1 + i1 * ai_dim1], lda, &bi[i1 +
i1 * bi_dim1], 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[mm + 1 +
(mm + 1) * ai_dim1], &bi[bi_offset], &bi[mm +
1 + (mm + 1) * bi_dim1], &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[i__ + j * ai_dim1], (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[i__ + j * bi_dim1], (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[j + j * ai_dim1], 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[j + j * bi_dim1], dabs(
r__6));
temp2 = ((r__1 = alphar[j] - ai[j + j * ai_dim1], dabs(r__1)) /
dmax(r__7,r__8) + (r__4 = beta[j] - bi[j + j * bi_dim1],
dabs(r__4)) / dmax(r__9,r__10)) / ulp;
if (j < mn_1.mplusn) {
if (ai[j + 1 + j * ai_dim1] != 0.f) {
ilabad = TRUE_;
result[4] = ulpinv;
}
}
if (j > 1) {
if (ai[j + (j - 1) * ai_dim1] != 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[i1 + 2 + (i1 + 1) * ai_dim1] != 0.f) {
ilabad = TRUE_;
result[4] = ulpinv;
}
} else if (i1 > 1) {
if (ai[i1 + (i1 - 1) * ai_dim1] != 0.f) {
ilabad = TRUE_;
result[4] = ulpinv;
}
}
if (! ilabad) {
sget53_(&ai[i1 + i1 * ai_dim1], lda, &bi[i1 + i1 * bi_dim1],
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 slatm6_(integer *type__, integer *n, real *a, integer *
lda, real *b, real *x, integer *ldx, real *y, integer *ldy, real *
alpha, real *beta, real *wx, real *wy, real *s, real *dif)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, y_dim1,
y_offset, i__1, i__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
static integer info;
static real work[100];
static integer i__, j;
static real z__[144] /* was [12][12] */;
extern /* Subroutine */ int slakf2_(integer *, integer *, real *, integer
*, real *, real *, real *, real *, integer *), sgesvd_(char *,
char *, integer *, integer *, real *, integer *, real *, real *,
integer *, real *, integer *, real *, integer *, integer *), slacpy_(char *, integer *, integer *, real *,
integer *, real *, integer *);
#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
#define b_ref(a_1,a_2) b[(a_2)*b_dim1 + a_1]
#define x_ref(a_1,a_2) x[(a_2)*x_dim1 + a_1]
#define y_ref(a_1,a_2) y[(a_2)*y_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
=======
SLATM6 generates test matrices for the generalized eigenvalue
problem, their corresponding right and left eigenvector matrices,
and also reciprocal condition numbers for all eigenvalues and
the reciprocal condition numbers of eigenvectors corresponding to
the 1th and 5th eigenvalues.
Test Matrices
=============
Two kinds of test matrix pairs
(A, B) = inverse(YH) * (Da, Db) * inverse(X)
are used in the tests:
Type 1:
Da = 1+a 0 0 0 0 Db = 1 0 0 0 0
0 2+a 0 0 0 0 1 0 0 0
0 0 3+a 0 0 0 0 1 0 0
0 0 0 4+a 0 0 0 0 1 0
0 0 0 0 5+a , 0 0 0 0 1 , and
Type 2:
Da = 1 -1 0 0 0 Db = 1 0 0 0 0
1 1 0 0 0 0 1 0 0 0
0 0 1 0 0 0 0 1 0 0
0 0 0 1+a 1+b 0 0 0 1 0
0 0 0 -1-b 1+a , 0 0 0 0 1 .
In both cases the same inverse(YH) and inverse(X) are used to compute
(A, B), giving the exact eigenvectors to (A,B) as (YH, X):
YH: = 1 0 -y y -y X = 1 0 -x -x x
0 1 -y y -y 0 1 x -x -x
0 0 1 0 0 0 0 1 0 0
0 0 0 1 0 0 0 0 1 0
0 0 0 0 1, 0 0 0 0 1 ,
where a, b, x and y will have all values independently of each other.
Arguments
=========
TYPE (input) INTEGER
Specifies the problem type (see futher details).
N (input) INTEGER
Size of the matrices A and B.
A (output) REAL array, dimension (LDA, N).
On exit A N-by-N is initialized according to TYPE.
LDA (input) INTEGER
The leading dimension of A and of B.
B (output) REAL array, dimension (LDA, N).
On exit B N-by-N is initialized according to TYPE.
X (output) REAL array, dimension (LDX, N).
On exit X is the N-by-N matrix of right eigenvectors.
LDX (input) INTEGER
The leading dimension of X.
Y (output) REAL array, dimension (LDY, N).
On exit Y is the N-by-N matrix of left eigenvectors.
LDY (input) INTEGER
The leading dimension of Y.
ALPHA (input) REAL
BETA (input) REAL
Weighting constants for matrix A.
WX (input) REAL
Constant for right eigenvector matrix.
WY (input) REAL
Constant for left eigenvector matrix.
S (output) REAL array, dimension (N)
S(i) is the reciprocal condition number for eigenvalue i.
DIF (output) REAL array, dimension (N)
DIF(i) is the reciprocal condition number for eigenvector i.
=====================================================================
Generate test problem ...
(Da, Db) ...
Parameter adjustments */
b_dim1 = *lda;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1 * 1;
x -= x_offset;
y_dim1 = *ldy;
y_offset = 1 + y_dim1 * 1;
y -= y_offset;
--s;
--dif;
/* Function Body */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
if (i__ == j) {
a_ref(i__, i__) = (real) i__ + *alpha;
b_ref(i__, i__) = 1.f;
} else {
a_ref(i__, j) = 0.f;
b_ref(i__, j) = 0.f;
}
/* L10: */
}
/* L20: */
}
/* Form X and Y */
slacpy_("F", n, n, &b[b_offset], lda, &y[y_offset], ldy);
y_ref(3, 1) = -(*wy);
y_ref(4, 1) = *wy;
y_ref(5, 1) = -(*wy);
y_ref(3, 2) = -(*wy);
y_ref(4, 2) = *wy;
y_ref(5, 2) = -(*wy);
slacpy_("F", n, n, &b[b_offset], lda, &x[x_offset], ldx);
x_ref(1, 3) = -(*wx);
x_ref(1, 4) = -(*wx);
x_ref(1, 5) = *wx;
x_ref(2, 3) = *wx;
x_ref(2, 4) = -(*wx);
x_ref(2, 5) = -(*wx);
/* Form (A, B) */
b_ref(1, 3) = *wx + *wy;
b_ref(2, 3) = -(*wx) + *wy;
b_ref(1, 4) = *wx - *wy;
b_ref(2, 4) = *wx - *wy;
b_ref(1, 5) = -(*wx) + *wy;
b_ref(2, 5) = *wx + *wy;
if (*type__ == 1) {
a_ref(1, 3) = *wx * a_ref(1, 1) + *wy * a_ref(3, 3);
a_ref(2, 3) = -(*wx) * a_ref(2, 2) + *wy * a_ref(3, 3);
a_ref(1, 4) = *wx * a_ref(1, 1) - *wy * a_ref(4, 4);
a_ref(2, 4) = *wx * a_ref(2, 2) - *wy * a_ref(4, 4);
a_ref(1, 5) = -(*wx) * a_ref(1, 1) + *wy * a_ref(5, 5);
a_ref(2, 5) = *wx * a_ref(2, 2) + *wy * a_ref(5, 5);
} else if (*type__ == 2) {
a_ref(1, 3) = *wx * 2.f + *wy;
a_ref(2, 3) = *wy;
a_ref(1, 4) = -(*wy) * (*alpha + 2.f + *beta);
a_ref(2, 4) = *wx * 2.f - *wy * (*alpha + 2.f + *beta);
a_ref(1, 5) = *wx * -2.f + *wy * (*alpha - *beta);
a_ref(2, 5) = *wy * (*alpha - *beta);
a_ref(1, 1) = 1.f;
a_ref(1, 2) = -1.f;
a_ref(2, 1) = 1.f;
a_ref(2, 2) = a_ref(1, 1);
a_ref(3, 3) = 1.f;
a_ref(4, 4) = *alpha + 1.f;
a_ref(4, 5) = *beta + 1.f;
a_ref(5, 4) = -a_ref(4, 5);
a_ref(5, 5) = a_ref(4, 4);
}
/* Compute condition numbers */
if (*type__ == 1) {
s[1] = 1.f / sqrt((*wy * 3.f * *wy + 1.f) / (a_ref(1, 1) * a_ref(1, 1)
+ 1.f));
s[2] = 1.f / sqrt((*wy * 3.f * *wy + 1.f) / (a_ref(2, 2) * a_ref(2, 2)
+ 1.f));
s[3] = 1.f / sqrt((*wx * 2.f * *wx + 1.f) / (a_ref(3, 3) * a_ref(3, 3)
+ 1.f));
s[4] = 1.f / sqrt((*wx * 2.f * *wx + 1.f) / (a_ref(4, 4) * a_ref(4, 4)
+ 1.f));
s[5] = 1.f / sqrt((*wx * 2.f * *wx + 1.f) / (a_ref(5, 5) * a_ref(5, 5)
+ 1.f));
slakf2_(&c__1, &c__4, &a[a_offset], lda, &a_ref(2, 2), &b[b_offset], &
b_ref(2, 2), z__, &c__12);
sgesvd_("N", "N", &c__8, &c__8, z__, &c__12, work, &work[8], &c__1, &
work[9], &c__1, &work[10], &c__40, &info);
dif[1] = work[7];
slakf2_(&c__4, &c__1, &a[a_offset], lda, &a_ref(5, 5), &b[b_offset], &
b_ref(5, 5), z__, &c__12);
sgesvd_("N", "N", &c__8, &c__8, z__, &c__12, work, &work[8], &c__1, &
work[9], &c__1, &work[10], &c__40, &info);
dif[5] = work[7];
} else if (*type__ == 2) {
s[1] = 1.f / sqrt(*wy * *wy + .33333333333333331f);
s[2] = s[1];
s[3] = 1.f / sqrt(*wx * *wx + .5f);
s[4] = 1.f / sqrt((*wx * 2.f * *wx + 1.f) / ((*alpha + 1.f) * (*alpha
+ 1.f) + 1.f + (*beta + 1.f) * (*beta + 1.f)));
s[5] = s[4];
slakf2_(&c__2, &c__3, &a[a_offset], lda, &a_ref(3, 3), &b[b_offset], &
b_ref(3, 3), z__, &c__12);
sgesvd_("N", "N", &c__12, &c__12, z__, &c__12, work, &work[12], &c__1,
&work[13], &c__1, &work[14], &c__60, &info);
dif[1] = work[11];
slakf2_(&c__3, &c__2, &a[a_offset], lda, &a_ref(4, 4), &b[b_offset], &
b_ref(4, 4), z__, &c__12);
sgesvd_("N", "N", &c__12, &c__12, z__, &c__12, work, &work[12], &c__1,
&work[13], &c__1, &work[14], &c__60, &info);
dif[5] = work[11];
}
return 0;
/* End of SLATM6 */
} /* slatm6_ */
int svdcmp (float **A, int m, int n, float *s, float **V)
{
float *afort, *vfort; /*Vector format work spaces */
int i;
int info=0;
#ifndef SUNPERF
int one=1;
float *swork;
int ldwork;
#endif
/*Alloc work spaces and copy from numerical recipes matrix
form to the form sunperf wants */
afort = (float *) calloc(m*MAX(m,n),sizeof(float));
vfort = (float *) calloc(n*n,sizeof(float));
if( (afort == NULL) || (vfort == NULL))
die(0,"svdcmp could not alloc work arrays\n");
#ifdef SUNPERF
for(i=0;i<m;++i)
scopy(n,A[i],1,(afort+i),m);
#else
for(i=0;i<m;++i)
scopy_(&n,A[i],&one,(afort+i),&m);
#endif
/* old rule: always initialize things like this */
for(i=0;i<n*n;++i) vfort[i] = 0.0;
#ifdef SUNPERF
sgesvd('o','s',m,n,afort,m,s,NULL,m,vfort,n,&info);
#else
ldwork = 12+2*n; /* This is slightly larger than the minimum
required for safety. Space required is never
large by modern standards */
swork = calloc(ldwork,sizeof(float));
if(n == NULL) die(0,"Cannot alloc work space for SVD routine\n");
sgesvd_("o","s",&m,&n,afort,&m,s,NULL,&m,vfort,&n,
swork, &ldwork,
&info);
free(swork);
#endif
if(info!=0)
{
if(info > 0)
elog_notify(0,"Convergence failure in svd routine\n");
else
elog_notify(0,"Illegal value for argument %d passed to sgesvd\nNo solution possible\n",
-info);
free(afort);
free(vfort);
return(info);
}
#ifdef SUNPERF
/* note we do return something even when convergence failed.
Must handle negative return as junk is returned then. */
for(i=0;i<m;++i)
scopy(n,(afort+i),m,A[i],1);
/* Note this copies V transpose in vfort to V in the matrix V.
Tricky BLAS code I know*/
for(i=0;i<n;++i)
scopy(n,(vfort+i*n),1,V[i],1);
#else
for(i=0;i<m;++i)
scopy_(&n,(afort+i),&m,A[i],&one);
for(i=0;i<n;++i)
scopy_(&n,(vfort+i*n),&one,V[i],&one);
#endif
free(afort);
free(vfort);
return(0);
}
void StrandBlockSolver::lspMap()
{
int mm,nn,jj,ii,j1,j2,jm,jmax,nmax,info,ldu,ldvt,rows,cols,lwork;
double dsm,dx,dy,ds,w,r1,r2,rs,cond,rcond,xn,yn,ax,ay,xu,xl,bu,bl,xcn,ycn;
double b[4];
double* sv;
double* work1;
double* uu;
double* vt;
double* dr;
double** lspT;
char u='U',jobu='n',jobvt='a';
cond = 0.;
ldu = 1;
ldvt = 2;
cols = 2;
for (int n=0; n<nNodes-nGnodes; n++){
mm = ncsp(n);
rows = mm;
ii = cols;
if (rows < ii) ii = rows;
jj = cols;
if (rows > jj) jj = rows;
lwork = 1;
if (3*ii+jj > lwork) lwork = 3*ii+jj;
if (5*ii > lwork) lwork = 5*ii;
uu = new double[ldu*ldu];
sv = new double[cols];
vt = new double[ldvt*cols];
work1 = new double[lwork];
dr = new double[rows*2];
lspT = new double*[nPstr+1];
for (int j=0; j<nPstr+1; j++) lspT[j] = new double[rows];
rcond = 0.;
info = 0;
for (int m=0; m<ldu*ldu; m++) uu [m] = 0.;
for (int m=0; m<cols; m++) sv [m] = 0.;
for (int m=0; m<ldvt*cols; m++) vt [m] = 0.;
for (int m=0; m<lwork; m++) work1[m] = 0.;
double work [2] = {0.,0.};
double work2[4] = {0.,0.,0.,0.};
int iwork[2] = {0,0};
int ipiv [2] = {0,0};
for (int j=1; j<nPstr+1; j++){ //mid strand nodes
// coordinates of the mid-strand location in question
jm = j-1;
xn = .5*(x(0,j,n)+x(0,jm,n));
yn = .5*(x(1,j,n)+x(1,jm,n));
// find data centroid
xcn = 0.;
ycn = 0.;
for (int m=0; m<mm; m++){
nn = csp[n][m];
xcn = xcn+xc(0,j,nn);
ycn = ycn+xc(1,j,nn);
}
xcn = xcn/double(mm);
ycn = ycn/double(mm);
// find plane which most closely fits surrounding cell centers
for (int m=0; m<mm; m++){
nn = csp[n][m];
dr[m ] = xc(0,j,nn)-xcn;
dr[m+mm] = xc(1,j,nn)-ycn;
}
sgesvd_(jobu,jobvt,rows,cols,dr,rows,sv,uu,ldu,vt,ldvt,work1,lwork,info);
if (info != 0){
cout << "\n*** svd procedure failure in lspMap ***" << endl;
exit(0);
}
ax = vt[0];
ay = vt[2];
ds = 1./sqrt(ax*ax+ay*ay);
ax = ax*ds;
ay = ay*ds;
// compute 2d least squares problem with projected distances
// largest distance in stencil
dsm = 0.;
for (int m=0; m<mm; m++){
nn = csp[n][m];
dx = xc(0,j,nn)-xn;
dy = xc(1,j,nn)-yn;
ds = dx*ax+dy*ay;
ds = ds*ds;
if (ds > dsm) dsm = ds;
}
dsm = 1./sqrt(dsm);
// form least squares matrix
jj = jm;
for (int m=0; m<4; m++) b[m] = 0.;
for (int m=0; m<mm; m++){
nn = csp[n][m];
dx = xc(0,j,nn)-xn;
dy = xc(1,j,nn)-yn;
ds =(dx*ax+dy*ay)*dsm;
w = 1./(ds*ds);
b[0] = b[0]+w;
b[2] = b[2]+w*ds;
b[3] = b[3]+w*ds*ds;
}
// find max abs row sum for condition number computation
r1 = fabs(b[0])+fabs(b[2]);
r2 = fabs(b[1])+fabs(b[3]);
rs = r1;
if (r2 > rs) rs = r2;
// invert matrix and determine condition number
ii = 2;
ssytrf_(u,ii,b,ii,ipiv,work,ii,info);
ssycon_(u,ii,b,ii,ipiv,rs,rcond,work2,iwork,info);
ssytri_(u,ii,b,ii,ipiv,work,info);
rcond = 1./rcond;
if (rcond > cond){
nmax = n;
jmax = j;
cond = rcond;
}
// form and store least squares coefficient
for (int m=0; m<mm; m++){
nn = csp[n][m];
dx = xc(0,j,nn)-xn;
dy = xc(1,j,nn)-yn;
ds =(dx*ax+dy*ay)*dsm;
w = 1./(ds*ds);
lspT[j][m] =(b[0]*w +
b[2]*w*ds);
}
}
// interpolate projected coefficients to the nodal positions along each strand
for (int j=0; j<nPstr+1; j++){
if (j == 0 ){
j1 = 1;
j2 = 2;
}
else if (j == nPstr){
j1 = nPstr-1;
j2 = nPstr;
}
else{
j1 = j;
j2 = j+1;
}
xn = xStr(j);
jm = j1-1;
xl = .5*(xStr(jm)+xStr(j1));
jm = j2-1;
xu = .5*(xStr(jm)+xStr(j2));
bl =(xu-xn)/(xu-xl);
bu =(xn-xl)/(xu-xl);
indlsp(0,j,n,ii);
for (int m=0; m<mm; m++){
lsp[ii ][m] = bl*lspT[j1][m];
lsp[ii+1][m] = bu*lspT[j2][m];
}
}
delete [] sv;
delete [] uu;
delete [] vt;
delete [] work1;
delete [] dr;
for (int j=0; j<nPstr+1; j++) delete [] lspT[j];
delete [] lspT;
}
// output condition information
xn = x(0,jmax,nmax);
yn = x(1,jmax,nmax);
cout << "\nMaximum condition number for LS procedure: "
<< cond << endl
<< "Index of maximum condition number: "
<< nmax << "\t" << jmax << endl
<< "Coordinates of maximum condition number: "
<< xn << "\t" << yn << "\n" << endl;
/*
// try using volume averaging on outer boundary nodes
for (int n=0; n<nNodes-nGnodes; n++){
mm = ncsp(n);
for (int j=nPstr; j<nPstr+1; j++){
if (j == 0 ) jj = 1;
else if (j == nPstr) jj = nPstr-1;
else jj = j;
w = 0.;
for (int k=0; k<2; k++){
indlsp(k,j,n,ii);
for (int m=0; m<mm; m++){
nn = csp[n][m];
lsp[ii][m] = v(jj,nn);
w += v(jj,nn);
}
jj++;
}
w = 1./w;
for (int k=0; k<2; k++){
indlsp(k,j,n,ii);
for (int m=0; m<mm; m++){
lsp[ii][m] = lsp[ii][m]*w;
}}}}
*/
}
