void F77_drot( const int *N, double *X, const int *incX, double *Y,
const int *incY, const double *c, const double *s)
{
cblas_drot(*N,X,*incX,Y,*incY,*c,*s);
return;
}
JNIEXPORT void JNICALL Java_uncomplicate_neanderthal_CBLAS_drot
(JNIEnv *env, jclass clazz, jint N,
jobject X, jint offsetX, jint incX,
jobject Y, jint offsetY, jint incY,
double c, double s) {
double *cX = (double *) (*env)->GetDirectBufferAddress(env, X);
double *cY = (double *) (*env)->GetDirectBufferAddress(env, Y);
cblas_drot(N, cX + offsetX, incX, cY + offsetY, incY, c, s);
};
void My_drot(gsl_vector* x, gsl_vector* y, const double c, const double s)
{
cblas_drot (x->size, x->data,x->stride,y->data,y->stride,c,s);
}
void
test_rot (void) {
const double flteps = 1e-4, dbleps = 1e-6;
{
int N = 1;
float c = 0.0f;
float s = 0.0f;
float X[] = { -0.314f };
int incX = 1;
float Y[] = { -0.406f };
int incY = -1;
float x_expected[] = { 0.0f };
float y_expected[] = { 0.0f };
cblas_srot(N, X, incX, Y, incY, c, s);
{
int i;
for (i = 0; i < 1; i++) {
gsl_test_rel(X[i], x_expected[i], flteps, "srot(case 558)");
}
};
{
int i;
for (i = 0; i < 1; i++) {
gsl_test_rel(Y[i], y_expected[i], flteps, "srot(case 559)");
}
};
};
{
int N = 1;
float c = 0.866025403784f;
float s = 0.5f;
float X[] = { -0.314f };
int incX = 1;
float Y[] = { -0.406f };
int incY = -1;
float x_expected[] = { -0.474932f };
float y_expected[] = { -0.194606f };
cblas_srot(N, X, incX, Y, incY, c, s);
{
int i;
for (i = 0; i < 1; i++) {
gsl_test_rel(X[i], x_expected[i], flteps, "srot(case 560)");
}
};
{
int i;
for (i = 0; i < 1; i++) {
gsl_test_rel(Y[i], y_expected[i], flteps, "srot(case 561)");
}
};
};
{
int N = 1;
float c = 0.0f;
float s = -1.0f;
float X[] = { -0.314f };
int incX = 1;
float Y[] = { -0.406f };
int incY = -1;
float x_expected[] = { 0.406f };
float y_expected[] = { -0.314f };
cblas_srot(N, X, incX, Y, incY, c, s);
{
int i;
for (i = 0; i < 1; i++) {
gsl_test_rel(X[i], x_expected[i], flteps, "srot(case 562)");
}
};
{
int i;
for (i = 0; i < 1; i++) {
gsl_test_rel(Y[i], y_expected[i], flteps, "srot(case 563)");
}
};
};
{
int N = 1;
float c = -1.0f;
float s = 0.0f;
float X[] = { -0.314f };
int incX = 1;
float Y[] = { -0.406f };
int incY = -1;
float x_expected[] = { 0.314f };
float y_expected[] = { 0.406f };
cblas_srot(N, X, incX, Y, incY, c, s);
{
int i;
for (i = 0; i < 1; i++) {
gsl_test_rel(X[i], x_expected[i], flteps, "srot(case 564)");
}
};
{
int i;
for (i = 0; i < 1; i++) {
gsl_test_rel(Y[i], y_expected[i], flteps, "srot(case 565)");
}
};
};
{
int N = 1;
double c = 0;
double s = 0;
double X[] = { -0.493 };
int incX = 1;
double Y[] = { -0.014 };
int incY = -1;
double x_expected[] = { 0.0 };
double y_expected[] = { 0.0 };
cblas_drot(N, X, incX, Y, incY, c, s);
{
int i;
for (i = 0; i < 1; i++) {
gsl_test_rel(X[i], x_expected[i], dbleps, "drot(case 566)");
}
};
{
int i;
for (i = 0; i < 1; i++) {
gsl_test_rel(Y[i], y_expected[i], dbleps, "drot(case 567)");
}
};
};
{
int N = 1;
double c = 0.866025403784;
double s = 0.5;
double X[] = { -0.493 };
int incX = 1;
double Y[] = { -0.014 };
int incY = -1;
double x_expected[] = { -0.433950524066 };
double y_expected[] = { 0.234375644347 };
cblas_drot(N, X, incX, Y, incY, c, s);
{
int i;
for (i = 0; i < 1; i++) {
gsl_test_rel(X[i], x_expected[i], dbleps, "drot(case 568)");
}
};
{
int i;
for (i = 0; i < 1; i++) {
gsl_test_rel(Y[i], y_expected[i], dbleps, "drot(case 569)");
}
};
};
{
int N = 1;
double c = 0;
double s = -1;
double X[] = { -0.493 };
int incX = 1;
double Y[] = { -0.014 };
int incY = -1;
double x_expected[] = { 0.014 };
double y_expected[] = { -0.493 };
cblas_drot(N, X, incX, Y, incY, c, s);
{
int i;
for (i = 0; i < 1; i++) {
gsl_test_rel(X[i], x_expected[i], dbleps, "drot(case 570)");
}
};
{
int i;
for (i = 0; i < 1; i++) {
gsl_test_rel(Y[i], y_expected[i], dbleps, "drot(case 571)");
}
};
};
{
int N = 1;
double c = -1;
double s = 0;
double X[] = { -0.493 };
int incX = 1;
double Y[] = { -0.014 };
int incY = -1;
double x_expected[] = { 0.493 };
double y_expected[] = { 0.014 };
cblas_drot(N, X, incX, Y, incY, c, s);
{
int i;
for (i = 0; i < 1; i++) {
gsl_test_rel(X[i], x_expected[i], dbleps, "drot(case 572)");
}
};
{
int i;
for (i = 0; i < 1; i++) {
gsl_test_rel(Y[i], y_expected[i], dbleps, "drot(case 573)");
}
};
};
{
int N = 1;
float c = 0.0f;
float s = 0.0f;
float X[] = { -0.808f };
int incX = -1;
float Y[] = { -0.511f };
int incY = 1;
float x_expected[] = { 0.0f };
float y_expected[] = { 0.0f };
cblas_srot(N, X, incX, Y, incY, c, s);
{
int i;
for (i = 0; i < 1; i++) {
gsl_test_rel(X[i], x_expected[i], flteps, "srot(case 574)");
}
};
{
int i;
for (i = 0; i < 1; i++) {
gsl_test_rel(Y[i], y_expected[i], flteps, "srot(case 575)");
}
};
};
{
int N = 1;
float c = 0.866025403784f;
float s = 0.5f;
float X[] = { -0.808f };
int incX = -1;
float Y[] = { -0.511f };
int incY = 1;
float x_expected[] = { -0.955249f };
float y_expected[] = { -0.038539f };
cblas_srot(N, X, incX, Y, incY, c, s);
{
int i;
for (i = 0; i < 1; i++) {
gsl_test_rel(X[i], x_expected[i], flteps, "srot(case 576)");
}
};
{
int i;
for (i = 0; i < 1; i++) {
gsl_test_rel(Y[i], y_expected[i], flteps, "srot(case 577)");
}
};
};
{
int N = 1;
float c = 0.0f;
float s = -1.0f;
float X[] = { -0.808f };
int incX = -1;
float Y[] = { -0.511f };
int incY = 1;
float x_expected[] = { 0.511f };
float y_expected[] = { -0.808f };
cblas_srot(N, X, incX, Y, incY, c, s);
{
int i;
for (i = 0; i < 1; i++) {
gsl_test_rel(X[i], x_expected[i], flteps, "srot(case 578)");
}
};
{
int i;
for (i = 0; i < 1; i++) {
gsl_test_rel(Y[i], y_expected[i], flteps, "srot(case 579)");
}
};
};
{
int N = 1;
float c = -1.0f;
float s = 0.0f;
float X[] = { -0.808f };
int incX = -1;
float Y[] = { -0.511f };
int incY = 1;
float x_expected[] = { 0.808f };
float y_expected[] = { 0.511f };
cblas_srot(N, X, incX, Y, incY, c, s);
{
int i;
for (i = 0; i < 1; i++) {
gsl_test_rel(X[i], x_expected[i], flteps, "srot(case 580)");
}
};
{
int i;
for (i = 0; i < 1; i++) {
gsl_test_rel(Y[i], y_expected[i], flteps, "srot(case 581)");
}
};
};
{
int N = 1;
double c = 0;
double s = 0;
double X[] = { -0.176 };
int incX = -1;
double Y[] = { -0.165 };
int incY = 1;
double x_expected[] = { 0.0 };
double y_expected[] = { 0.0 };
cblas_drot(N, X, incX, Y, incY, c, s);
{
int i;
for (i = 0; i < 1; i++) {
gsl_test_rel(X[i], x_expected[i], dbleps, "drot(case 582)");
}
};
{
int i;
for (i = 0; i < 1; i++) {
gsl_test_rel(Y[i], y_expected[i], dbleps, "drot(case 583)");
}
};
};
{
int N = 1;
double c = 0.866025403784;
double s = 0.5;
double X[] = { -0.176 };
int incX = -1;
double Y[] = { -0.165 };
int incY = 1;
double x_expected[] = { -0.234920471066 };
double y_expected[] = { -0.0548941916244 };
cblas_drot(N, X, incX, Y, incY, c, s);
{
int i;
for (i = 0; i < 1; i++) {
gsl_test_rel(X[i], x_expected[i], dbleps, "drot(case 584)");
}
};
{
int i;
for (i = 0; i < 1; i++) {
gsl_test_rel(Y[i], y_expected[i], dbleps, "drot(case 585)");
}
};
};
{
int N = 1;
double c = 0;
double s = -1;
double X[] = { -0.176 };
int incX = -1;
double Y[] = { -0.165 };
int incY = 1;
double x_expected[] = { 0.165 };
double y_expected[] = { -0.176 };
cblas_drot(N, X, incX, Y, incY, c, s);
{
int i;
for (i = 0; i < 1; i++) {
gsl_test_rel(X[i], x_expected[i], dbleps, "drot(case 586)");
}
};
{
int i;
for (i = 0; i < 1; i++) {
gsl_test_rel(Y[i], y_expected[i], dbleps, "drot(case 587)");
}
};
};
{
int N = 1;
double c = -1;
double s = 0;
double X[] = { -0.176 };
int incX = -1;
double Y[] = { -0.165 };
int incY = 1;
double x_expected[] = { 0.176 };
double y_expected[] = { 0.165 };
cblas_drot(N, X, incX, Y, incY, c, s);
{
int i;
for (i = 0; i < 1; i++) {
gsl_test_rel(X[i], x_expected[i], dbleps, "drot(case 588)");
}
};
{
int i;
for (i = 0; i < 1; i++) {
gsl_test_rel(Y[i], y_expected[i], dbleps, "drot(case 589)");
}
};
};
{
int N = 1;
float c = 0.0f;
float s = 0.0f;
float X[] = { -0.201f };
int incX = -1;
float Y[] = { 0.087f };
int incY = -1;
float x_expected[] = { 0.0f };
float y_expected[] = { 0.0f };
cblas_srot(N, X, incX, Y, incY, c, s);
{
int i;
for (i = 0; i < 1; i++) {
gsl_test_rel(X[i], x_expected[i], flteps, "srot(case 590)");
}
};
{
int i;
for (i = 0; i < 1; i++) {
gsl_test_rel(Y[i], y_expected[i], flteps, "srot(case 591)");
}
};
};
{
int N = 1;
float c = 0.866025403784f;
float s = 0.5f;
float X[] = { -0.201f };
int incX = -1;
float Y[] = { 0.087f };
int incY = -1;
float x_expected[] = { -0.130571f };
float y_expected[] = { 0.175844f };
cblas_srot(N, X, incX, Y, incY, c, s);
{
int i;
for (i = 0; i < 1; i++) {
gsl_test_rel(X[i], x_expected[i], flteps, "srot(case 592)");
}
};
{
int i;
for (i = 0; i < 1; i++) {
gsl_test_rel(Y[i], y_expected[i], flteps, "srot(case 593)");
}
};
};
{
int N = 1;
float c = 0.0f;
float s = -1.0f;
float X[] = { -0.201f };
int incX = -1;
float Y[] = { 0.087f };
int incY = -1;
float x_expected[] = { -0.087f };
float y_expected[] = { -0.201f };
cblas_srot(N, X, incX, Y, incY, c, s);
{
int i;
for (i = 0; i < 1; i++) {
gsl_test_rel(X[i], x_expected[i], flteps, "srot(case 594)");
}
};
{
int i;
for (i = 0; i < 1; i++) {
gsl_test_rel(Y[i], y_expected[i], flteps, "srot(case 595)");
}
};
};
{
int N = 1;
float c = -1.0f;
float s = 0.0f;
float X[] = { -0.201f };
int incX = -1;
float Y[] = { 0.087f };
int incY = -1;
float x_expected[] = { 0.201f };
float y_expected[] = { -0.087f };
cblas_srot(N, X, incX, Y, incY, c, s);
{
int i;
for (i = 0; i < 1; i++) {
gsl_test_rel(X[i], x_expected[i], flteps, "srot(case 596)");
}
};
{
int i;
for (i = 0; i < 1; i++) {
gsl_test_rel(Y[i], y_expected[i], flteps, "srot(case 597)");
}
};
};
{
int N = 1;
double c = 0;
double s = 0;
double X[] = { -0.464 };
int incX = -1;
double Y[] = { 0.7 };
int incY = -1;
double x_expected[] = { 0.0 };
double y_expected[] = { 0.0 };
cblas_drot(N, X, incX, Y, incY, c, s);
{
int i;
for (i = 0; i < 1; i++) {
gsl_test_rel(X[i], x_expected[i], dbleps, "drot(case 598)");
}
};
{
int i;
for (i = 0; i < 1; i++) {
gsl_test_rel(Y[i], y_expected[i], dbleps, "drot(case 599)");
}
};
};
{
int N = 1;
double c = 0.866025403784;
double s = 0.5;
double X[] = { -0.464 };
int incX = -1;
double Y[] = { 0.7 };
int incY = -1;
double x_expected[] = { -0.051835787356 };
double y_expected[] = { 0.838217782649 };
cblas_drot(N, X, incX, Y, incY, c, s);
{
int i;
for (i = 0; i < 1; i++) {
gsl_test_rel(X[i], x_expected[i], dbleps, "drot(case 600)");
}
};
{
int i;
for (i = 0; i < 1; i++) {
gsl_test_rel(Y[i], y_expected[i], dbleps, "drot(case 601)");
}
};
};
{
int N = 1;
double c = 0;
double s = -1;
double X[] = { -0.464 };
int incX = -1;
double Y[] = { 0.7 };
int incY = -1;
double x_expected[] = { -0.7 };
double y_expected[] = { -0.464 };
cblas_drot(N, X, incX, Y, incY, c, s);
{
int i;
for (i = 0; i < 1; i++) {
gsl_test_rel(X[i], x_expected[i], dbleps, "drot(case 602)");
}
};
{
int i;
for (i = 0; i < 1; i++) {
gsl_test_rel(Y[i], y_expected[i], dbleps, "drot(case 603)");
}
};
};
{
int N = 1;
double c = -1;
double s = 0;
double X[] = { -0.464 };
int incX = -1;
double Y[] = { 0.7 };
int incY = -1;
double x_expected[] = { 0.464 };
double y_expected[] = { -0.7 };
cblas_drot(N, X, incX, Y, incY, c, s);
{
int i;
for (i = 0; i < 1; i++) {
gsl_test_rel(X[i], x_expected[i], dbleps, "drot(case 604)");
}
};
{
int i;
for (i = 0; i < 1; i++) {
gsl_test_rel(Y[i], y_expected[i], dbleps, "drot(case 605)");
}
};
};
}
__cminpack_attr__
void __cminpack_func__(qrsolv)(int n, real *r, int ldr,
const int *ipvt, const real *diag, const real *qtb, real *x,
real *sdiag, real *wa)
{
/* Initialized data */
#define p5 .5
#define p25 .25
/* Local variables */
int i, j, k, l;
real cos, sin, sum, temp;
int nsing;
real qtbpj;
/* ********** */
/* subroutine qrsolv */
/* given an m by n matrix a, an n by n diagonal matrix d, */
/* and an m-vector b, the problem is to determine an x which */
/* solves the system */
/* a*x = b , d*x = 0 , */
/* in the least squares sense. */
/* this subroutine completes the solution of the problem */
/* if it is provided with the necessary information from the */
/* qr factorization, with column pivoting, of a. that is, if */
/* a*p = q*r, where p is a permutation matrix, q has orthogonal */
/* columns, and r is an upper triangular matrix with diagonal */
/* elements of nonincreasing magnitude, then qrsolv expects */
/* the full upper triangle of r, the permutation matrix p, */
/* and the first n components of (q transpose)*b. the system */
/* a*x = b, d*x = 0, is then equivalent to */
/* t t */
/* r*z = q *b , p *d*p*z = 0 , */
/* where x = p*z. if this system does not have full rank, */
/* then a least squares solution is obtained. on output qrsolv */
/* also provides an upper triangular matrix s such that */
/* t t t */
/* p *(a *a + d*d)*p = s *s . */
/* s is computed within qrsolv and may be of separate interest. */
/* the subroutine statement is */
/* subroutine qrsolv(n,r,ldr,ipvt,diag,qtb,x,sdiag,wa) */
/* where */
/* n is a positive integer input variable set to the order of r. */
/* r is an n by n array. on input the full upper triangle */
/* must contain the full upper triangle of the matrix r. */
/* on output the full upper triangle is unaltered, and the */
/* strict lower triangle contains the strict upper triangle */
/* (transposed) of the upper triangular matrix s. */
/* ldr is a positive integer input variable not less than n */
/* which specifies the leading dimension of the array r. */
/* ipvt is an integer input array of length n which defines the */
/* permutation matrix p such that a*p = q*r. column j of p */
/* is column ipvt(j) of the identity matrix. */
/* diag is an input array of length n which must contain the */
/* diagonal elements of the matrix d. */
/* qtb is an input array of length n which must contain the first */
/* n elements of the vector (q transpose)*b. */
/* x is an output array of length n which contains the least */
/* squares solution of the system a*x = b, d*x = 0. */
/* sdiag is an output array of length n which contains the */
/* diagonal elements of the upper triangular matrix s. */
/* wa is a work array of length n. */
/* subprograms called */
/* fortran-supplied ... dabs,dsqrt */
/* argonne national laboratory. minpack project. march 1980. */
/* burton s. garbow, kenneth e. hillstrom, jorge j. more */
/* ********** */
/* copy r and (q transpose)*b to preserve input and initialize s. */
/* in particular, save the diagonal elements of r in x. */
for (j = 0; j < n; ++j) {
for (i = j; i < n; ++i) {
r[i + j * ldr] = r[j + i * ldr];
}
x[j] = r[j + j * ldr];
wa[j] = qtb[j];
}
/* eliminate the diagonal matrix d using a givens rotation. */
for (j = 0; j < n; ++j) {
/* prepare the row of d to be eliminated, locating the */
/* diagonal element using p from the qr factorization. */
l = ipvt[j]-1;
if (diag[l] != 0.) {
for (k = j; k < n; ++k) {
sdiag[k] = 0.;
}
sdiag[j] = diag[l];
/* the transformations to eliminate the row of d */
/* modify only a single element of (q transpose)*b */
/* beyond the first n, which is initially zero. */
qtbpj = 0.;
for (k = j; k < n; ++k) {
/* determine a givens rotation which eliminates the */
/* appropriate element in the current row of d. */
if (sdiag[k] != 0.) {
# ifdef USE_LAPACK
dlartg_( &r[k + k * ldr], &sdiag[k], &cos, &sin, &temp );
# else /* !USE_LAPACK */
if (fabs(r[k + k * ldr]) < fabs(sdiag[k])) {
real cotan;
cotan = r[k + k * ldr] / sdiag[k];
sin = p5 / sqrt(p25 + p25 * (cotan * cotan));
cos = sin * cotan;
} else {
real tan;
tan = sdiag[k] / r[k + k * ldr];
cos = p5 / sqrt(p25 + p25 * (tan * tan));
sin = cos * tan;
}
/* compute the modified diagonal element of r and */
/* the modified element of ((q transpose)*b,0). */
# endif /* !USE_LAPACK */
temp = cos * wa[k] + sin * qtbpj;
qtbpj = -sin * wa[k] + cos * qtbpj;
wa[k] = temp;
/* accumulate the tranformation in the row of s. */
# ifdef USE_CBLAS
cblas_drot( n-k, &r[k + k * ldr], 1, &sdiag[k], 1, cos, sin );
# else /* !USE_CBLAS */
r[k + k * ldr] = cos * r[k + k * ldr] + sin * sdiag[k];
if (n > k+1) {
for (i = k+1; i < n; ++i) {
temp = cos * r[i + k * ldr] + sin * sdiag[i];
sdiag[i] = -sin * r[i + k * ldr] + cos * sdiag[i];
r[i + k * ldr] = temp;
}
}
# endif /* !USE_CBLAS */
}
}
}
/* store the diagonal element of s and restore */
/* the corresponding diagonal element of r. */
sdiag[j] = r[j + j * ldr];
r[j + j * ldr] = x[j];
}
/* solve the triangular system for z. if the system is */
/* singular, then obtain a least squares solution. */
nsing = n;
for (j = 0; j < n; ++j) {
if (sdiag[j] == 0. && nsing == n) {
nsing = j;
}
if (nsing < n) {
wa[j] = 0.;
}
}
if (nsing >= 1) {
for (k = 1; k <= nsing; ++k) {
j = nsing - k;
sum = 0.;
if (nsing > j+1) {
for (i = j+1; i < nsing; ++i) {
sum += r[i + j * ldr] * wa[i];
}
}
wa[j] = (wa[j] - sum) / sdiag[j];
}
}
/* permute the components of z back to components of x. */
for (j = 0; j < n; ++j) {
l = ipvt[j]-1;
x[l] = wa[j];
}
return;
/* last card of subroutine qrsolv. */
} /* qrsolv_ */
void dlaed2(int *K_bis, int *n_bis, int *m_bis, double *D, double *Q, int *LDQ_bis,
int *perm, double *beta_bis, double *Z,
double *DLAMBDA, double *W_3, double *Q2_3,
int *INDX, int *INDXC, int *INDXP,
int *COLTYP, int *info)
{
(void)info;
int LDQ = LDQ_bis[0];
(void) LDQ;
int K = K_bis[0];
int n = n_bis[0];
int m = m_bis[0];
double beta = beta_bis[0];
int n2 = n - m;
int i;
int K2;
if (beta <= 0.0){
cblas_dscal(n2, -1.0, Z+m, 1.0);
}
/* Normalize z by dscal 1/sqrt(2) */
cblas_dscal(n, 1./sqrt(2), Z, 1);
/* beta = abs(2*beta) : cancel Z normalization */
beta = fabs(2*beta);
/* sort eigenvalues into increasing order using perm*/
for (i=m; i<n; i++){
perm[i] += m;
}
/* copy D in Dlambda modulo permutation */
for (i=0; i<n; i++){
DLAMBDA[i] = D[perm[i]];
}
int id1 = 1;
int id2 = 1;
dlamrg_(&m, &n2, DLAMBDA, &id1, &id2, INDXC);
/* For C */
for (i=0; i<n; i++){
INDXC[i]--;
}
for (i=0; i<n; i++){
INDX[i] = perm[INDXC[i]];
}
/* tolerance */
double max = 0.0;
double max_Z = 0.0;
double comp, eps, tol;
for (i=0; i<n; i++){
comp = fabs(D[i]);
if (comp > max){
max = comp;
}
comp = fabs(Z[i]);
if (comp > max){
max = comp;
}
if (comp > max_Z){
max_Z = comp;
}
}
eps = 1.110223e-16; /* real machine precision? */
tol = 8*eps*max;
/* if beta is small enough, just reorganize Q */
if (beta*max_Z <= tol){
K = 0;
int IQ2 = 0;
int ind;
for (i=0; i<n; i++){
ind = INDX[i];
cblas_dcopy(n, Q+LDQ*ind, 1, Q2_3+IQ2, 1);
DLAMBDA[i] = D[ind];
IQ2 += n;
}
for (i=0; i<n; i++){
cblas_dcopy(n, Q2_3+n*i, 1, Q+LDQ*i, 1);
}
cblas_dcopy(n, DLAMBDA, 1, D, 1);
K_bis[0] = K;
beta_bis[0] = beta;
return;
}
/* otherwise search multiple eigenvalues*/
/* 1 for T1, 2 for mixte, 3 for T2 and 4 for deflated */
for (i=0; i<m; i++){
COLTYP[i] = 1;
}
for (i=m; i<n; i++){
COLTYP[i] = 3;
}
K = 0;
K2 = n; /* index of last deflated eigenvalue */
int ni; /* permuted index of i */
int pi; /* next value */
double C, S;
int go = 1;
i = 0;
while (i<n && go == 1){
ni = INDX[i];
if (beta*fabs(Z[ni]) <= tol){
K2--;
COLTYP[ni] = 4;
INDXP[K2] = ni;
i++;
}
else{
pi = ni;
go = 0;
}
}
while (i < n-1){
i++;
ni = INDX[i];
if (beta*fabs(Z[ni]) <= tol){
K2--;
COLTYP[ni] = 4;
INDXP[K2] = ni;
}
else{
S = Z[pi];
C = Z[ni];
double tau = dlapy2_(&C, &S); /* WARNING: accuracy */
double t = D[ni] - D[pi];
C = C/tau;
S = -S/tau;
/* Deflation is possible */
if (fabs(t*C*S) <= tol){
/* printf("Deflation closed eigenvalues %d %d\n", ni, pi); */
Z[ni] = tau;
Z[pi] = 0.0;
/* Mixte eigenvector */
if (COLTYP[ni] != COLTYP[pi]){
COLTYP[ni] = 2;
}
COLTYP[pi] = 4;
cblas_drot(n, Q+LDQ*pi, 1, Q+LDQ*ni, 1, C, S);
t = D[pi]*C*C + D[ni]*S*S;
D[ni] = D[pi]*S*S + D[ni]*C*C;
D[pi] = t;
K2--;
int j = 1;
go = 1;
while (j+K2 < n && go == 1){
if (D[pi] < D[INDXP[j+K2]]){
INDXP[K2+j-1] = INDXP[K2+j];
INDXP[K2+j] = pi;
j++;
}
else{
INDXP[K2+j-1] = pi;
go = 0;
}
}
if (go == 1){
INDXP[K2+j-1] = pi;
}
pi = ni;
}
/* No deflation */
else{
DLAMBDA[K] = D[pi];
W_3[K] = Z[pi];
INDXP[K] = pi;
K++;
pi = ni;
}
}
}
DLAMBDA[K] = D[pi];
W_3[K] = Z[pi];
INDXP[K] = pi;
K++;
/* Different kind of eigenvalues: from T1, mixte, from T2 and deflated */
int ctot[4];
int ct;
for (i=0; i<4; i++){
ctot[i] = 0;
}
for (i=0; i<n; i++){
ct = COLTYP[i];
ctot[ct-1]++;
}
/* Positions of eigenvectors in matrix */
int pos[4];
pos[0] = 0;
pos[1] = ctot[0];
pos[2] = pos[1] + ctot[1];
pos[3] = pos[2] + ctot[2];
K = n - ctot[3];
/* Fill out INDXC for Q2 columns */
int is;
for (i=0; i<n; i++){
is = INDXP[i];
ct = COLTYP[is];
INDX[pos[ct-1]] = is;
INDXC[pos[ct-1]] = i;
pos[ct-1]++;
}
/* Sort eigenpairs */
int Ind = 0;
int IQ1 = 0;
int IQ2 = (ctot[0] + ctot[1])*m;
/* From first subproblem */
for (i=0; i<ctot[0]; i++){
is = INDX[Ind];
cblas_dcopy(m, Q+LDQ*is, 1, Q2_3+IQ1, 1);
Z[Ind] = D[is];
Ind++;
IQ1 += m;
}
/* Mixte */
for (i=0; i<ctot[1]; i++){
is = INDX[Ind];
cblas_dcopy(m, Q+LDQ*is, 1, Q2_3+IQ1, 1);
cblas_dcopy(n2, Q+m+LDQ*is, 1, Q2_3+IQ2, 1);
Z[Ind] = D[is];
Ind++;
IQ1 += m;
IQ2 += n2;
}
/* From second subproblem */
for (i=0; i<ctot[2]; i++){
is = INDX[Ind];
cblas_dcopy(n2, Q+m+LDQ*is, 1, Q2_3+IQ2, 1);
Z[Ind] = D[is];
Ind++;
IQ2 += n2;
}
IQ1 = IQ2;
/* Deflated */
for (i=0; i<ctot[3]; i++){
is = INDX[Ind];
cblas_dcopy(n, Q+LDQ*is, 1, Q2_3+IQ2, 1);
Z[Ind] = D[is];
Ind++;
IQ2 += n;
}
/* Copy deflated results in D and Q */
for (i=0; i<n-K; i++){
cblas_dcopy(n, Q2_3+IQ1+n*i, 1, Q+LDQ*(K+i), 1);
}
cblas_dcopy(n-K, Z+K, 1, D+K, 1);
/* Save ctot */
for (i=0; i<4; i++){
COLTYP[i] = ctot[i];
}
K_bis[0] = K;
beta_bis[0] = beta;
}
//
// Overloaded function for dispatching to
// * CBLAS backend, and
// * double value-type.
//
inline void rot( const int n, double* x, const int incx, double* y,
const int incy, const double c, const double s ) {
cblas_drot( n, x, incx, y, incy, c, s );
}
extern "C" magma_int_t
magma_dgeev(
char jobvl, char jobvr, magma_int_t n,
double *A, magma_int_t lda,
double *WR, double *WI,
double *vl, magma_int_t ldvl,
double *vr, magma_int_t ldvr,
double *work, magma_int_t lwork,
magma_int_t *info )
{
/* -- MAGMA (version 1.4.1) --
Univ. of Tennessee, Knoxville
Univ. of California, Berkeley
Univ. of Colorado, Denver
December 2013
Purpose
=======
DGEEV computes for an N-by-N real nonsymmetric matrix A, the
eigenvalues and, optionally, the left and/or right eigenvectors.
The right eigenvector v(j) of A satisfies
A * v(j) = lambda(j) * v(j)
where lambda(j) is its eigenvalue.
The left eigenvector u(j) of A satisfies
u(j)**T * A = lambda(j) * u(j)**T
where u(j)**T denotes the transpose of u(j).
The computed eigenvectors are normalized to have Euclidean norm
equal to 1 and largest component real.
Arguments
=========
JOBVL (input) CHARACTER*1
= 'N': left eigenvectors of A are not computed;
= 'V': left eigenvectors of are computed.
JOBVR (input) CHARACTER*1
= 'N': right eigenvectors of A are not computed;
= 'V': right eigenvectors of A are computed.
N (input) INTEGER
The order of the matrix A. N >= 0.
A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
On entry, the N-by-N matrix A.
On exit, A has been overwritten.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
WR (output) DOUBLE PRECISION array, dimension (N)
WI (output) DOUBLE PRECISION array, dimension (N)
WR and WI contain the real and imaginary parts,
respectively, of the computed eigenvalues. Complex
conjugate pairs of eigenvalues appear consecutively
with the eigenvalue having the positive imaginary part
first.
VL (output) DOUBLE PRECISION array, dimension (LDVL,N)
If JOBVL = 'V', the left eigenvectors u(j) are stored one
after another in the columns of VL, in the same order
as their eigenvalues.
If JOBVL = 'N', VL is not referenced.
u(j) = VL(:,j), the j-th column of VL.
LDVL (input) INTEGER
The leading dimension of the array VL. LDVL >= 1; if
JOBVL = 'V', LDVL >= N.
VR (output) DOUBLE PRECISION array, dimension (LDVR,N)
If JOBVR = 'V', the right eigenvectors v(j) are stored one
after another in the columns of VR, in the same order
as their eigenvalues.
If JOBVR = 'N', VR is not referenced.
v(j) = VR(:,j), the j-th column of VR.
LDVR (input) INTEGER
The leading dimension of the array VR. LDVR >= 1; if
JOBVR = 'V', LDVR >= N.
WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
LWORK (input) INTEGER
The dimension of the array WORK. LWORK >= (2+nb)*N.
For optimal performance, LWORK >= (2+2*nb)*N.
If LWORK = -1, then a workspace query is assumed; the routine
only calculates the optimal size of the WORK array, returns
this value as the first entry of the WORK array, and no error
message related to LWORK is issued by XERBLA.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value.
> 0: if INFO = i, the QR algorithm failed to compute all the
eigenvalues, and no eigenvectors have been computed;
elements and i+1:N of W contain eigenvalues which have
converged.
===================================================================== */
#define vl(i,j) (vl + (i) + (j)*ldvl)
#define vr(i,j) (vr + (i) + (j)*ldvr)
magma_int_t c_one = 1;
magma_int_t c_zero = 0;
double d__1, d__2;
double r, cs, sn, scl;
double dum[1], eps;
double anrm, cscale, bignum, smlnum;
magma_int_t i, k, ilo, ihi;
magma_int_t ibal, ierr, itau, iwrk, nout, liwrk, i__1, i__2, nb;
magma_int_t scalea, minwrk, lquery, wantvl, wantvr, select[1];
char side[2] = {0, 0};
char jobvl_[2] = {jobvl, 0};
char jobvr_[2] = {jobvr, 0};
*info = 0;
lquery = lwork == -1;
wantvl = lapackf77_lsame( jobvl_, "V" );
wantvr = lapackf77_lsame( jobvr_, "V" );
if (! wantvl && ! lapackf77_lsame( jobvl_, "N" )) {
*info = -1;
} else if (! wantvr && ! lapackf77_lsame( jobvr_, "N" )) {
*info = -2;
} else if (n < 0) {
*info = -3;
} else if (lda < max(1,n)) {
*info = -5;
} else if ( (ldvl < 1) || (wantvl && (ldvl < n))) {
*info = -9;
} else if ( (ldvr < 1) || (wantvr && (ldvr < n))) {
*info = -11;
}
/* Compute workspace */
nb = magma_get_dgehrd_nb( n );
if (*info == 0) {
minwrk = (2+nb)*n;
work[0] = MAGMA_D_MAKE( (double) minwrk, 0. );
if (lwork < minwrk && ! lquery) {
*info = -13;
}
}
if (*info != 0) {
magma_xerbla( __func__, -(*info) );
return *info;
}
else if (lquery) {
return *info;
}
/* Quick return if possible */
if (n == 0) {
return *info;
}
#if defined(VERSION3)
double *dT;
if (MAGMA_SUCCESS != magma_dmalloc( &dT, nb*n )) {
*info = MAGMA_ERR_DEVICE_ALLOC;
return *info;
}
#endif
/* Get machine constants */
eps = lapackf77_dlamch( "P" );
smlnum = lapackf77_dlamch( "S" );
bignum = 1. / smlnum;
lapackf77_dlabad( &smlnum, &bignum );
smlnum = magma_dsqrt( smlnum ) / eps;
bignum = 1. / smlnum;
/* Scale A if max element outside range [SMLNUM,BIGNUM] */
anrm = lapackf77_dlange( "M", &n, &n, A, &lda, dum );
scalea = 0;
if (anrm > 0. && anrm < smlnum) {
scalea = 1;
cscale = smlnum;
} else if (anrm > bignum) {
scalea = 1;
cscale = bignum;
}
if (scalea) {
lapackf77_dlascl( "G", &c_zero, &c_zero, &anrm, &cscale, &n, &n, A, &lda, &ierr );
}
/* Balance the matrix
* (Workspace: need N) */
ibal = 0;
lapackf77_dgebal( "B", &n, A, &lda, &ilo, &ihi, &work[ibal], &ierr );
/* Reduce to upper Hessenberg form
* (Workspace: need 3*N, prefer 2*N + N*NB) */
itau = ibal + n;
iwrk = itau + n;
liwrk = lwork - iwrk;
#if defined(VERSION1)
// Version 1 - LAPACK
lapackf77_dgehrd( &n, &ilo, &ihi, A, &lda,
&work[itau], &work[iwrk], &liwrk, &ierr );
#elif defined(VERSION2)
// Version 2 - LAPACK consistent HRD
magma_dgehrd2( n, ilo, ihi, A, lda,
&work[itau], &work[iwrk], liwrk, &ierr );
#elif defined(VERSION3)
// Version 3 - LAPACK consistent MAGMA HRD + T matrices stored,
magma_dgehrd( n, ilo, ihi, A, lda,
&work[itau], &work[iwrk], liwrk, dT, &ierr );
#endif
if (wantvl) {
/* Want left eigenvectors
* Copy Householder vectors to VL */
side[0] = 'L';
lapackf77_dlacpy( MagmaLowerStr, &n, &n,
A, &lda, vl, &ldvl );
/* Generate orthogonal matrix in VL
* (Workspace: need 3*N-1, prefer 2*N + (N-1)*NB) */
#if defined(VERSION1) || defined(VERSION2)
// Version 1 & 2 - LAPACK
lapackf77_dorghr( &n, &ilo, &ihi, vl, &ldvl, &work[itau],
&work[iwrk], &liwrk, &ierr );
#elif defined(VERSION3)
// Version 3 - LAPACK consistent MAGMA HRD + T matrices stored
magma_dorghr( n, ilo, ihi, vl, ldvl, &work[itau], dT, nb, &ierr );
#endif
/* Perform QR iteration, accumulating Schur vectors in VL
* (Workspace: need N+1, prefer N+HSWORK (see comments) ) */
iwrk = itau;
liwrk = lwork - iwrk;
lapackf77_dhseqr( "S", "V", &n, &ilo, &ihi, A, &lda, WR, WI,
vl, &ldvl, &work[iwrk], &liwrk, info );
if (wantvr) {
/* Want left and right eigenvectors
* Copy Schur vectors to VR */
side[0] = 'B';
lapackf77_dlacpy( "F", &n, &n, vl, &ldvl, vr, &ldvr );
}
}
else if (wantvr) {
/* Want right eigenvectors
* Copy Householder vectors to VR */
side[0] = 'R';
lapackf77_dlacpy( "L", &n, &n, A, &lda, vr, &ldvr );
/* Generate orthogonal matrix in VR
* (Workspace: need 3*N-1, prefer 2*N + (N-1)*NB) */
#if defined(VERSION1) || defined(VERSION2)
// Version 1 & 2 - LAPACK
lapackf77_dorghr( &n, &ilo, &ihi, vr, &ldvr, &work[itau],
&work[iwrk], &liwrk, &ierr );
#elif defined(VERSION3)
// Version 3 - LAPACK consistent MAGMA HRD + T matrices stored
magma_dorghr( n, ilo, ihi, vr, ldvr, &work[itau], dT, nb, &ierr );
#endif
/* Perform QR iteration, accumulating Schur vectors in VR
* (Workspace: need N+1, prefer N+HSWORK (see comments) ) */
iwrk = itau;
liwrk = lwork - iwrk;
lapackf77_dhseqr( "S", "V", &n, &ilo, &ihi, A, &lda, WR, WI,
vr, &ldvr, &work[iwrk], &liwrk, info );
}
else {
/* Compute eigenvalues only
* (Workspace: need N+1, prefer N+HSWORK (see comments) ) */
iwrk = itau;
liwrk = lwork - iwrk;
lapackf77_dhseqr( "E", "N", &n, &ilo, &ihi, A, &lda, WR, WI,
vr, &ldvr, &work[iwrk], &liwrk, info );
}
/* If INFO > 0 from DHSEQR, then quit */
if (*info > 0) {
goto CLEANUP;
}
if (wantvl || wantvr) {
/* Compute left and/or right eigenvectors
* (Workspace: need 4*N) */
liwrk = lwork - iwrk;
#if TREVC_VERSION == 1
lapackf77_dtrevc( side, "B", select, &n, A, &lda, vl, &ldvl,
vr, &ldvr, &n, &nout, &work[iwrk], &ierr );
#elif TREVC_VERSION == 2
lapackf77_dtrevc3( side, "B", select, &n, A, &lda, vl, &ldvl,
vr, &ldvr, &n, &nout, &work[iwrk], &liwrk, &ierr );
#endif
}
if (wantvl) {
/* Undo balancing of left eigenvectors
* (Workspace: need N) */
lapackf77_dgebak( "B", "L", &n, &ilo, &ihi, &work[ibal], &n,
vl, &ldvl, &ierr );
/* Normalize left eigenvectors and make largest component real */
for (i = 0; i < n; ++i) {
if ( WI[i] == 0. ) {
scl = 1. / cblas_dnrm2( n, vl(0,i), 1 );
cblas_dscal( n, scl, vl(0,i), 1 );
}
else if ( WI[i] > 0. ) {
d__1 = cblas_dnrm2( n, vl(0,i), 1 );
d__2 = cblas_dnrm2( n, vl(0,i+1), 1 );
scl = 1. / lapackf77_dlapy2( &d__1, &d__2 );
cblas_dscal( n, scl, vl(0,i), 1 );
cblas_dscal( n, scl, vl(0,i+1), 1 );
for (k = 0; k < n; ++k) {
/* Computing 2nd power */
d__1 = *vl(k,i);
d__2 = *vl(k,i+1);
work[iwrk + k] = d__1*d__1 + d__2*d__2;
}
k = cblas_idamax( n, &work[iwrk], 1 );
lapackf77_dlartg( vl(k,i), vl(k,i+1), &cs, &sn, &r );
cblas_drot( n, vl(0,i), 1, vl(0,i+1), 1, cs, sn );
*vl(k,i+1) = 0.;
}
}
}
if (wantvr) {
/* Undo balancing of right eigenvectors
* (Workspace: need N) */
lapackf77_dgebak( "B", "R", &n, &ilo, &ihi, &work[ibal], &n,
vr, &ldvr, &ierr );
/* Normalize right eigenvectors and make largest component real */
for (i = 0; i < n; ++i) {
if ( WI[i] == 0. ) {
scl = 1. / cblas_dnrm2( n, vr(0,i), 1 );
cblas_dscal( n, scl, vr(0,i), 1 );
}
else if ( WI[i] > 0. ) {
d__1 = cblas_dnrm2( n, vr(0,i), 1 );
d__2 = cblas_dnrm2( n, vr(0,i+1), 1 );
scl = 1. / lapackf77_dlapy2( &d__1, &d__2 );
cblas_dscal( n, scl, vr(0,i), 1 );
cblas_dscal( n, scl, vr(0,i+1), 1 );
for (k = 0; k < n; ++k) {
/* Computing 2nd power */
d__1 = *vr(k,i);
d__2 = *vr(k,i+1);
work[iwrk + k] = d__1*d__1 + d__2*d__2;
}
k = cblas_idamax( n, &work[iwrk], 1 );
lapackf77_dlartg( vr(k,i), vr(k,i+1), &cs, &sn, &r );
cblas_drot( n, vr(0,i), 1, vr(0,i+1), 1, cs, sn );
*vr(k,i+1) = 0.;
}
}
}
CLEANUP:
/* Undo scaling if necessary */
if (scalea) {
i__1 = n - (*info);
i__2 = max( n - (*info), 1 );
lapackf77_dlascl( "G", &c_zero, &c_zero, &cscale, &anrm, &i__1, &c_one,
WR + (*info), &i__2, &ierr );
lapackf77_dlascl( "G", &c_zero, &c_zero, &cscale, &anrm, &i__1, &c_one,
WI + (*info), &i__2, &ierr );
if (*info > 0) {
i__1 = ilo - 1;
lapackf77_dlascl( "G", &c_zero, &c_zero, &cscale, &anrm, &i__1, &c_one,
WR, &n, &ierr );
lapackf77_dlascl( "G", &c_zero, &c_zero, &cscale, &anrm, &i__1, &c_one,
WI, &n, &ierr );
}
}
#if defined(VERSION3)
magma_free( dT );
#endif
return *info;
} /* magma_dgeev */
