void
Stokhos::RecurrenceBasis<ordinal_type,value_type>::
getQuadPoints(ordinal_type quad_order,
Teuchos::Array<value_type>& quad_points,
Teuchos::Array<value_type>& quad_weights,
Teuchos::Array< Teuchos::Array<value_type> >& quad_values) const
{
//This is a transposition into C++ of Gautschi's code for taking the first
// N recurrance coefficient and generating a N point quadrature rule.
// The MATLAB version is available at
// http://www.cs.purdue.edu/archives/2002/wxg/codes/gauss.m
ordinal_type num_points =
static_cast<ordinal_type>(std::ceil((quad_order+1)/2.0));
Teuchos::Array<value_type> a(num_points,0);
Teuchos::Array<value_type> b(num_points,0);
Teuchos::Array<value_type> c(num_points,0);
Teuchos::Array<value_type> d(num_points,0);
// If we don't have enough recurrance coefficients, get some more.
if(num_points > p+1) {
bool is_normalized = computeRecurrenceCoefficients(num_points, a, b, c, d);
if (!is_normalized)
normalizeRecurrenceCoefficients(a, b, c, d);
}
else { //else just take the ones we already have.
for(ordinal_type n = 0; n<num_points; n++) {
a[n] = alpha[n];
b[n] = beta[n];
c[n] = delta[n];
d[n] = gamma[n];
}
if (!normalize)
normalizeRecurrenceCoefficients(a, b, c, d);
}
// With normalized coefficients, A is symmetric and tri-diagonal, with
// diagonal = a, and off-diagonal = b, starting at b[1]
Teuchos::SerialDenseMatrix<ordinal_type,value_type> eig_vectors(num_points,
num_points);
Teuchos::Array<value_type> workspace(2*num_points);
ordinal_type info_flag;
Teuchos::LAPACK<ordinal_type,value_type> my_lapack;
// compute the eigenvalues (stored in a) and right eigenvectors.
if (num_points == 1)
my_lapack.STEQR('I', num_points, &a[0], &b[0], eig_vectors.values(),
num_points, &workspace[0], &info_flag);
else
my_lapack.STEQR('I', num_points, &a[0], &b[1], eig_vectors.values(),
num_points, &workspace[0], &info_flag);
// eigenvalues are sorted by STEQR
quad_points.resize(num_points);
quad_weights.resize(num_points);
for (ordinal_type i=0; i<num_points; i++) {
quad_points[i] = a[i];
if (std::abs(quad_points[i]) < quad_zero_tol)
quad_points[i] = 0.0;
quad_weights[i] = beta[0]*eig_vectors[i][0]*eig_vectors[i][0];
}
// Evalute basis at gauss points
quad_values.resize(num_points);
for (ordinal_type i=0; i<num_points; i++) {
quad_values[i].resize(p+1);
evaluateBases(quad_points[i], quad_values[i]);
}
}
void eig_hess(double *A, size_t n, size_t low, size_t high,
double *wr, double *wi, int matq, double *Q, size_t *iter, size_t *rc)
{
size_t i, j, m, k, l, na, ll, en;
int cur_iter, flag, MAXIT;
double p, q, r, s, t, w, x, y, z;
double mach_eps;
mach_eps = MACH_EPS();
MAXIT = 30;
p = q = r = 0.0;
for(i = 0; i < n; i++)
{
if (i < low || i > high)
{
wr[i] = A[i*n + i];
wi[i] = 0.0;
iter[i] = 0;
}
}
en = high;
t = 0.0;
flag = 1;
while (en >= low && flag)
{
cur_iter = 0;
na = en - 1;
while(1)
{
ll = 0;
for(l = en; l > low; l--) /* search for small subdiagonal element */
{
if (fabs(A[l*n + l - 1]) <= mach_eps * (fabs(A[(l - 1)*n + l - 1]) + fabs(A[l*n + l])))
{
ll = l; /* save current index */
break;
}
}
l = ll; /* restore l */
x = A[en*n + en];
if (l == en) /* found one evalue */
{
wr[en] = x + t;
A[en*n + en] = x + t;
wi[en] = 0.0;
iter[en] = cur_iter;
if (en > 0)
en--;
else
flag = 0;
break; /* exit from loop while(1) */
}
y = A[na*n + na];
w = A[en*n + na] * A[na*n + en];
if (l == na) /* found two evalues */
{
p = (y - x) * 0.5;
q = p * p + w;
z = sqrt(fabs(q));
x = x + t;
A[en*n + en] = x + t;
A[na*n + na] = y + t;
iter[en] = -cur_iter;
iter[na] = cur_iter;
if (q >= 0.0) /* real eigenvalues */
{
if (p < 0.0)
z = p - z;
else
z = p + z;
wr[na] = x + z;
wr[en] = x - w / z;
wi[na] = 0.0;
wi[en] = 0.0;
x = A[en*n + na];
r = sqrt(x * x + z * z);
if (matq)
{
p = x / r;
q = z / r;
for(j = na; j < n; j++)
{
z = A[na*n + j];
A[na*n + j] = q * z + p * A[en*n + j];
A[en*n + j] = q * A[en*n + j] - p * z;
}
for(i = 0; i <= en; i++)
{
z = A[i*n + na];
A[i*n + na] = q * z + p * A[i*n + en];
A[i*n + en] = q * A[i*n + en] - p * z;
}
if (matq) for(i = low; i <= high; i++)
{
z = Q[i*n + na];
Q[i*n + na] = q * z + p * Q[i*n + en];
Q[i*n + en] = q * Q[i*n + en] - p * z;
}
}
}
else
{ /* pair of complex */
wr[na] = x + p;
wr[en] = x + p;
wi[na] = z;
wi[en] = - z;
}
if (en > 1)
en -= 2;
else
flag = 0;
break; /* exit while(1) */
} /* if l = na */
if (cur_iter >= MAXIT)
{
iter[en] = MAXIT + 1;
*rc = en;
return;
}
if (cur_iter == 10 || cur_iter == 20)
{
t += x;
for(i = low; i <= en; i++)
A[i*n + i] -= x;
s = fabs(A[en*n + na]) + fabs(A[na*n + en - 2]);
x = 0.75 * s;
y = x;
w = -0.4375 * s * s;
}
cur_iter++;
for(m = en - 1; m > l; m--)
{
z = A[(m - 1)*n + m - 1];
r = x - z;
s = y - z;
p = (r*s - w)/A[m*n + m - 1] + A[(m - 1)*n + m];
q = A[m*n + m] - z - r - s;
r = A[(m + 1)*n + m];
s = fabs(p) + fabs(q) + fabs (r);
p = p / s;
q = q / s;
r = r / s;
if (m == l + 1) break;
if (fabs(A[(m - 1)*n + m - 2]) * (fabs(q) + fabs(r)) <= mach_eps * fabs(p)
* (fabs(A[(m - 2)*n + m - 2]) + fabs(z) + fabs(A[m*n + m])))
break;
}
for(i = m + 1; i <= en; i++)
A[i*n + i - 2] = 0.0;
for(i = m + 2; i <= en; i++)
A[i*n + i - 3] = 0.0;
for(k = m - 1; k <= na; k++)
{
if (k != m - 1) /* double QR step, for rows l to en */
{ /* and columns m to en */
p = A[k*n + k - 1];
q = A[(k + 1)*n + k - 1];
if (k != na)
r = A[(k + 2)*n + k - 1];
else
r = 0.0;
x = fabs(p) + fabs(q) + fabs(r);
if (x == 0.0)
continue; /* next k */
p = p / x;
q = q / x;
r = r / x;
}
s = sqrt(p*p + q*q + r*r);
if (p < 0.0)
s = -s;
if (k != m - 1)
A[k*n + k - 1] = -s * x;
else if (l != m - 1)
A[k*n + k - 1] = -A[k*n + k - 1];
p = p + s;
x = p / s;
y = q / s;
z = r / s;
q = q / p;
r = r / p;
for(j = k; j < n; j++) /* modify rows */
{
p = A[k*n + j] + q * A[(k + 1)*n + j];
if (k != na)
{
p = p + r * A[(k + 2)*n + j];
A[(k + 2)*n + j] = A[(k + 2)*n + j] - p * z;
}
A[(k + 1)*n + j] = A[(k + 1)*n + j] - p * y;
A[k*n + j] = A[k*n + j] - p * x;
}
if (k + 3 < en)
j = k + 3;
else
j = en;
for(i = 0; i <= j; i++) /* modify columns */
{
p = x * A[i*n + k] + y * A[i*n + k+1];
if (k != na)
{
p = p + z * A[i*n + k+2];
A[i*n + k+2] = A[i*n + k+2] - p * r;
}
A[i*n + k+1] = A[i*n + k+1] - p * q;
A[i*n + k] = A[i*n + k] - p;
}
if (matq) /* if eigenvectors are needed */
{
for(i = low; i <= high; i++)
{
p = x * Q[i*n + k] + y * Q[i*n + k+1];
if (k != na)
{
p = p + z * Q[i*n + k+2];
Q[i*n + k+2] = Q[i*n + k+2] - p * r;
}
Q[i*n + k+1] = Q[i*n + k+1] - p * q;
Q[i*n + k] = Q[i*n + k] - p;
}
}
} /* k loop */
} /* while (1<2) */
} /* while en >= low All evalues found */
if (matq) /* transform evectors back */
eig_vectors(A, n, low, high, wr, wi, Q);
*rc = 0;
}
