int
gsl_linalg_QR_QTmat (const gsl_matrix * QR, const gsl_vector * tau, gsl_matrix * A)
{
const size_t M = QR->size1;
const size_t N = QR->size2;
if (tau->size != GSL_MIN (M, N))
{
GSL_ERROR ("size of tau must be MIN(M,N)", GSL_EBADLEN);
}
else if (A->size1 != M)
{
GSL_ERROR ("matrix must have M rows", GSL_EBADLEN);
}
else
{
size_t i;
/* compute Q^T A */
for (i = 0; i < GSL_MIN (M, N); i++)
{
gsl_vector_const_view c = gsl_matrix_const_column (QR, i);
gsl_vector_const_view h = gsl_vector_const_subvector (&(c.vector), i, M - i);
gsl_matrix_view m = gsl_matrix_submatrix(A, i, 0, M - i, A->size2);
double ti = gsl_vector_get (tau, i);
gsl_linalg_householder_hm (ti, &(h.vector), &(m.matrix));
}
return GSL_SUCCESS;
}
}
/// Copy a column into a GSLVector
/// @param i :: A column index.
GSLVector GSLMatrix::copyColumn(size_t i) const {
if (i >= size2()) {
throw std::out_of_range("GSLMatrix column index is out of range.");
}
auto columnView = gsl_matrix_const_column(gsl(), i);
return GSLVector(&columnView.vector);
}
int
gsl_linalg_QR_Qvec (const gsl_matrix * QR, const gsl_vector * tau, gsl_vector * v)
{
const size_t M = QR->size1;
const size_t N = QR->size2;
if (tau->size != GSL_MIN (M, N))
{
GSL_ERROR ("size of tau must be MIN(M,N)", GSL_EBADLEN);
}
else if (v->size != M)
{
GSL_ERROR ("vector size must be M", GSL_EBADLEN);
}
else
{
size_t i;
/* compute Q^T v */
for (i = GSL_MIN (M, N); i-- > 0;)
{
gsl_vector_const_view c = gsl_matrix_const_column (QR, i);
gsl_vector_const_view h = gsl_vector_const_subvector (&(c.vector),
i, M - i);
gsl_vector_view w = gsl_vector_subvector (v, i, M - i);
double ti = gsl_vector_get (tau, i);
gsl_linalg_householder_hv (ti, &h.vector, &w.vector);
}
return GSL_SUCCESS;
}
}
int wrap_gsl_linalg_SV_solve(gsl_matrix* U, gsl_matrix* V, gsl_matrix* S,
const gsl_matrix* b, gsl_matrix* x)
{
gsl_vector_view _S = gsl_matrix_diagonal(S);
gsl_vector_const_view _b = gsl_matrix_const_column(b, 0);
gsl_vector_view _x = gsl_matrix_column(x, 0);
return gsl_linalg_SV_solve(U, V, &_S.vector, &_b.vector, &_x.vector);
}
void VarproFunction::setPhiPermCol( size_t i, const gsl_matrix *perm,
gsl_vector *phiPermCol ) {
if (perm != NULL) {
gsl_vector permCol = gsl_matrix_const_column(perm, i).vector;
gsl_blas_dgemv(CblasNoTrans, 1.0, myPhi, &permCol, 0.0, phiPermCol);
} else {
gsl_vector phiCol = gsl_matrix_column(myPhi, i).vector;
gsl_vector_memcpy(phiPermCol, &phiCol);
}
}
void
test_eigen_gensymm_results (const gsl_matrix * A,
const gsl_matrix * B,
const gsl_vector * eval,
const gsl_matrix * evec,
size_t count,
const char * desc,
const char * desc2)
{
const size_t N = A->size1;
size_t i, j;
gsl_vector * x = gsl_vector_alloc(N);
gsl_vector * y = gsl_vector_alloc(N);
gsl_vector * z = gsl_vector_alloc(N);
/* check A v = lambda B v */
for (i = 0; i < N; i++)
{
double ei = gsl_vector_get (eval, i);
gsl_vector_const_view vi = gsl_matrix_const_column(evec, i);
double norm = gsl_blas_dnrm2(&vi.vector);
/* check that eigenvector is normalized */
gsl_test_rel(norm, 1.0, N * GSL_DBL_EPSILON,
"gensymm(N=%u,cnt=%u), %s, normalized(%d), %s", N, count,
desc, i, desc2);
gsl_vector_memcpy(z, &vi.vector);
/* compute y = A z */
gsl_blas_dgemv (CblasNoTrans, 1.0, A, z, 0.0, y);
/* compute x = B z */
gsl_blas_dgemv (CblasNoTrans, 1.0, B, z, 0.0, x);
/* compute x = lambda B z */
gsl_blas_dscal(ei, x);
/* now test if y = x */
for (j = 0; j < N; j++)
{
double xj = gsl_vector_get (x, j);
double yj = gsl_vector_get (y, j);
gsl_test_rel(yj, xj, 1e9 * GSL_DBL_EPSILON,
"gensymm(N=%u,cnt=%u), %s, eigenvalue(%d,%d), real, %s", N, count, desc, i, j, desc2);
}
}
gsl_vector_free(x);
gsl_vector_free(y);
gsl_vector_free(z);
}
int ap_gsl_linalg_SV_solve(gsl_matrix * x, gsl_matrix const * u,
gsl_vector const * s, gsl_matrix const * v,
gsl_matrix const * b){
const size_t p = x->size2;
for(size_t i = 0; i < p; ++i){
gsl_vector_view xcol = gsl_matrix_column(x,i);
gsl_vector_const_view bcol = gsl_matrix_const_column(b, i);
gsl_linalg_SV_solve(u, v, s, &bcol.vector, &xcol.vector);
}
return GSL_SUCCESS;
}
int
SparseGp_computeVarAt (SparseGp *gp, gsl_vector *var, const gsl_matrix *x)
{
PetscErrorCode ierr;
PetscInt N = gp->trainLabels->size;
Vec invKk;
ierr = petsc_util_createVec (&invKk, gp->nlocal, N);
for (int i=0; i<x->size2; i++) {
gsl_vector *k = gsl_vector_calloc (gp->trainObs->size2);
gsl_vector_const_view xi = gsl_matrix_const_column (x, i);
for (int j=0; j<k->size; j++) {
gsl_vector_const_view xj = gsl_matrix_const_column (gp->trainObs, j);
gsl_vector_set (k, j, AcfrKern_eval (gp->kern, &xj.vector, &xi.vector));
}
Vec _k;
ierr = petsc_util_createVec (&_k, gp->nlocal, N);
petsc_util_fillVec (k, &_k, gp->rstart, gp->rend);
SparseGp_solve (gp, _k, &invKk);
double val;
ierr = VecDot (_k, invKk, &val);
double c;
c = AcfrKern_eval (gp->kern, &xi.vector, &xi.vector) + gp->kern->beta;
gsl_vector_set (var, i, c - val);
/* clean up */
gsl_vector_free (k);
VecDestroy (&_k);
}
ierr = VecDestroy (&invKk);
return EXIT_SUCCESS;
}
int
gsl_linalg_QR_unpack (const gsl_matrix * QR, const gsl_vector * tau, gsl_matrix * Q, gsl_matrix * R)
{
const size_t M = QR->size1;
const size_t N = QR->size2;
if (Q->size1 != M || Q->size2 != M)
{
GSL_ERROR ("Q matrix must be M x M", GSL_ENOTSQR);
}
else if (R->size1 != M || R->size2 != N)
{
GSL_ERROR ("R matrix must be M x N", GSL_ENOTSQR);
}
else if (tau->size != GSL_MIN (M, N))
{
GSL_ERROR ("size of tau must be MIN(M,N)", GSL_EBADLEN);
}
else
{
size_t i, j;
/* Initialize Q to the identity */
gsl_matrix_set_identity (Q);
for (i = GSL_MIN (M, N); i-- > 0;)
{
gsl_vector_const_view c = gsl_matrix_const_column (QR, i);
gsl_vector_const_view h = gsl_vector_const_subvector (&c.vector,
i, M - i);
gsl_matrix_view m = gsl_matrix_submatrix (Q, i, i, M - i, M - i);
double ti = gsl_vector_get (tau, i);
gsl_linalg_householder_hm (ti, &h.vector, &m.matrix);
}
/* Form the right triangular matrix R from a packed QR matrix */
for (i = 0; i < M; i++)
{
for (j = 0; j < i && j < N; j++)
gsl_matrix_set (R, i, j, 0.0);
for (j = i; j < N; j++)
gsl_matrix_set (R, i, j, gsl_matrix_get (QR, i, j));
}
return GSL_SUCCESS;
}
}
//------------------------------------------------------------------------------------------
int svd_solve(gsl_matrix * x, gsl_matrix const * a, gsl_matrix const * b,
double const tol){
// solve for X in AX=B by SVD decomposition method.
// m == numRows A == numRows B
// n == numCols A == numRows X
// p == numCols X == numCols B
std::cout << "\n" __FILE__ << " --> " << __func__ << "() --> " << __LINE__ << "\n";
const size_t m = a->size1;
const size_t n = a->size2;
const size_t p = b->size2;
gsl_matrix * U = gsl_matrix_alloc(m, n);
gsl_matrix * V = gsl_matrix_alloc(n, n);
gsl_vector * s = gsl_vector_alloc(n);
gsl_vector * w = gsl_vector_alloc(n);
gsl_matrix_memcpy(U, a);
assert(GSL_SUCCESS == gsl_linalg_SV_decomp(U, V, s, w));
{
//double norm = gsl_vector_get(s, 0); // largest singular value
//SHOW(std::max(m,n)*norm*std::numeric_limits<double>::epsilon());
//SHOW(gsl_vector_get(s, 0)/gsl_vector_get(s, n-1));
}
//AP_GSL_SHOW(s);
for(size_t i = 0; i < n; ++i){
if(tol > gsl_vector_get(s, i)){
gsl_vector_set(s, i, 0.0);
}
}
for(size_t i = 0; i < p; ++i){
gsl_vector_view xcol = gsl_matrix_column(x,i);
gsl_vector_const_view bcol = gsl_matrix_const_column(b, i);
gsl_linalg_SV_solve(U, V, s, &bcol.vector, &xcol.vector);
}
gsl_matrix_free(U);
gsl_matrix_free(V);
gsl_vector_free(s);
gsl_vector_free(w);
return GSL_SUCCESS;
}
// Calculate the 'normalized' Frobenius norm (i.e., divide
// by the square root of the number of elements in matrix).
// Instead of doing element-wise computation, use the GSL
// BLAS interface to compute the L2 norm of the columns
// and get the Frobenius norm as the sum of the squares of
// L2 norms of the column vectors
double shapeAlign::normFrobenius(const gsl_matrix *M)
{
double L2n, Fn = 0;
double val = 0;
for (size_t i = 0; i < M->size2; i++){
if (! gsl_isnan(gsl_matrix_get(M,0,i))){
gsl_vector_const_view column = gsl_matrix_const_column(M,i);
L2n = gsl_blas_dnrm2(&column.vector);
Fn += L2n*L2n;
val+=1.0;
}
}
if (val >= 4*thresh){
return sqrt(Fn/val);
}
return GSL_NAN;
}
void orderMatrix(const gsl_matrix* x, gsl_matrix* y)
{
int n = x->size1;
int m = x->size2;
gsl_vector* x_norms = gsl_vector_alloc(m);
for (int i =0;i<m;i++)
{
gsl_vector_const_view xcol = gsl_matrix_const_column(x,i);
gsl_vector_set(x_norms, i, -norm2(&xcol.vector));
}
gsl_permutation* p = gsl_permutation_alloc(m);
gsl_sort_vector_index(p, x_norms);
for (int i=0; i<n; i++) {
for (int j=0; j<m; j++) {
gsl_matrix_set(y, i, j, gsl_matrix_get(x, i, gsl_permutation_get(p, j)));
}
}
gsl_vector_free(x_norms);
gsl_permutation_free(p);
}
void orderMatrix(const gsl_matrix* x, gsl_matrix* y, const gsl_matrix* M)
{
int n = x->size1;
int m = x->size2;
gsl_matrix* invM = gsl_matrix_alloc(n,n);
gsl_matrix_memcpy(invM,M);
int info=0;
char lower = 'U';
int lda = invM->tda;
dpotrf_(&lower, &n, invM->data, &lda, &info);
dpotri_(&lower, &n, invM->data, &lda, &info);
for (int i=0; i<n; i++) {
for (int j=i+1 ; j<n; j++) {
gsl_matrix_set(invM,i,j,gsl_matrix_get(invM,j,i)) ;
}
}
gsl_vector* x_ell_norms = gsl_vector_alloc(m);
gsl_vector* temp = gsl_vector_alloc(n);
for (int i =0;i<m;i++)
{
gsl_vector_const_view xcol = gsl_matrix_const_column(x,i);
My_dgemv(CblasNoTrans, 1.0, invM, &xcol.vector, 0.0, temp);
gsl_vector_set(x_ell_norms, i, -My_ddot(&xcol.vector, temp));
}
gsl_permutation* p = gsl_permutation_alloc(m);
gsl_sort_vector_index(p, x_ell_norms);
for (int i=0; i<n; i++) {
for (int j=0; j<m; j++) {
gsl_matrix_set(y, i, j, gsl_matrix_get(x, i, gsl_permutation_get(p, j)));
}
}
gsl_vector_free(x_ell_norms);
gsl_vector_free(temp);
gsl_matrix_free(invM);
gsl_permutation_free(p);
}
int model::get_col_sd()
{
size_t nrow = _fm->size1;
size_t ncol = _fm->size2;
gsl_vector_free(_col_sd);
gsl_vector *sd = gsl_vector_alloc(ncol);
if (sd == NULL) {
ULIB_FATAL("couldn't allocate vector");
return -1;
}
double k = sqrt(nrow);
for (size_t j = 0; j < ncol; ++j) {
gsl_vector_const_view cv = gsl_matrix_const_column(_fm, j);
double d = gsl_blas_dnrm2(&cv.vector);
gsl_vector_set(sd, j, d/k);
}
_col_sd = sd;
return 0;
}
/* Compute the maximum-likelihood estimate of the mean vector of samples
* from a multivariate Gaussian distribution.
*
* Example from R (GPL): http://www.r-project.org/
* (samples <- matrix(c(4.348817, 2.995049, -3.793431, 4.711934, 1.190864, -1.357363), nrow=3, ncol=2))
* colMeans(samples) # 1.183478 1.515145
*/
int
gsl_ran_multivariate_gaussian_mean (const gsl_matrix * X, gsl_vector * mu_hat)
{
const size_t M = X->size1;
const size_t N = X->size2;
if (N != mu_hat->size)
{
GSL_ERROR("mu_hat vector has wrong size", GSL_EBADLEN);
}
else
{
size_t j;
for (j = 0; j < N; ++j)
{
gsl_vector_const_view c = gsl_matrix_const_column(X, j);
double mean = gsl_stats_mean(c.vector.data, c.vector.stride, M);
gsl_vector_set(mu_hat, j, mean);
}
return GSL_SUCCESS;
}
}
static int BasicTest(
size_t n,
const int bound_on_0,
const int bound_on_1,
const int bound_on_2,
const int bound_on_3,
const char *lattice_name,
const UINT8 total_ref_0,
const UINT8 total_ref_1,
const UINT8 total_ref_2,
const UINT8 total_ref_3
)
{
const int bound_on[4] = {bound_on_0, bound_on_1, bound_on_2, bound_on_3};
const UINT8 total_ref[4] = {total_ref_0, total_ref_1, total_ref_2, total_ref_3};
// Create lattice tiling
LatticeTiling *tiling = XLALCreateLatticeTiling(n);
XLAL_CHECK(tiling != NULL, XLAL_EFUNC);
// Add bounds
for (size_t i = 0; i < n; ++i) {
XLAL_CHECK(bound_on[i] == 0 || bound_on[i] == 1, XLAL_EFAILED);
XLAL_CHECK(XLALSetLatticeTilingConstantBound(tiling, i, 0.0, bound_on[i] * pow(100.0, 1.0/n)) == XLAL_SUCCESS, XLAL_EFUNC);
}
// Set metric to the Lehmer matrix
const double max_mismatch = 0.3;
{
gsl_matrix *GAMAT(metric, n, n);
for (size_t i = 0; i < n; ++i) {
for (size_t j = 0; j < n; ++j) {
const double ii = i+1, jj = j+1;
gsl_matrix_set(metric, i, j, jj >= ii ? ii/jj : jj/ii);
}
}
XLAL_CHECK(XLALSetTilingLatticeAndMetric(tiling, lattice_name, metric, max_mismatch) == XLAL_SUCCESS, XLAL_EFUNC);
GFMAT(metric);
printf("Number of (tiled) dimensions: %zu (%zu)\n", XLALTotalLatticeTilingDimensions(tiling), XLALTiledLatticeTilingDimensions(tiling));
printf(" Bounds: %i %i %i %i\n", bound_on_0, bound_on_1, bound_on_2, bound_on_3);
printf(" Lattice type: %s\n", lattice_name);
}
// Create lattice tiling locator
LatticeTilingLocator *loc = XLALCreateLatticeTilingLocator(tiling);
XLAL_CHECK(loc != NULL, XLAL_EFUNC);
if (lalDebugLevel & LALINFOBIT) {
printf(" Index trie:\n");
XLAL_CHECK(XLALPrintLatticeTilingIndexTrie(loc, stdout) == XLAL_SUCCESS, XLAL_EFUNC);
}
for (size_t i = 0; i < n; ++i) {
// Create lattice tiling iterator and locator over 'i+1' dimensions
LatticeTilingIterator *itr = XLALCreateLatticeTilingIterator(tiling, i+1);
XLAL_CHECK(itr != NULL, XLAL_EFUNC);
// Count number of points
const UINT8 total = XLALTotalLatticeTilingPoints(itr);
printf("Number of lattice points in %zu dimensions: %" LAL_UINT8_FORMAT "\n", i+1, total);
XLAL_CHECK(imaxabs(total - total_ref[i]) <= 1, XLAL_EFUNC,
"ERROR: |total - total_ref[%zu]| = |%" LAL_UINT8_FORMAT " - %" LAL_UINT8_FORMAT "| > 1", i, total, total_ref[i]);
for (UINT8 k = 0; XLALNextLatticeTilingPoint(itr, NULL) > 0; ++k) {
const UINT8 itr_index = XLALCurrentLatticeTilingIndex(itr);
XLAL_CHECK(k == itr_index, XLAL_EFUNC,
"ERROR: k = %" LAL_UINT8_FORMAT " != %" LAL_UINT8_FORMAT " = itr_index", k, itr_index);
}
XLAL_CHECK(XLALResetLatticeTilingIterator(itr) == XLAL_SUCCESS, XLAL_EFUNC);
// Check tiling statistics
printf(" Check tiling statistics ...");
for (size_t j = 0; j < n; ++j) {
const LatticeTilingStats *stats = XLALLatticeTilingStatistics(tiling, j);
XLAL_CHECK(stats != NULL, XLAL_EFUNC);
XLAL_CHECK(imaxabs(stats->total_points - total_ref[j]) <= 1, XLAL_EFAILED, "\n "
"ERROR: |total - total_ref[%zu]| = |%" LAL_UINT8_FORMAT " - %" LAL_UINT8_FORMAT "| > 1", j, stats->total_points, total_ref[j]);
XLAL_CHECK(stats->min_points <= stats->avg_points, XLAL_EFAILED, "\n "
"ERROR: min_points = %" LAL_INT4_FORMAT " > %g = avg_points", stats->min_points, stats->avg_points);
XLAL_CHECK(stats->max_points >= stats->avg_points, XLAL_EFAILED, "\n "
"ERROR: max_points = %" LAL_INT4_FORMAT " < %g = avg_points", stats->max_points, stats->avg_points);
}
printf(" done\n");
// Get all points
gsl_matrix *GAMAT(points, n, total);
XLAL_CHECK(XLALNextLatticeTilingPoints(itr, &points) == (int)total, XLAL_EFUNC);
XLAL_CHECK(XLALNextLatticeTilingPoint(itr, NULL) == 0, XLAL_EFUNC);
// Get nearest points to each template, check for consistency
printf(" Testing XLALNearestLatticeTiling{Point|Block}() ...");
gsl_vector *GAVEC(nearest, n);
UINT8Vector *nearest_indexes = XLALCreateUINT8Vector(n);
XLAL_CHECK(nearest_indexes != NULL, XLAL_ENOMEM);
for (UINT8 k = 0; k < total; ++k) {
gsl_vector_const_view point_view = gsl_matrix_const_column(points, k);
const gsl_vector *point = &point_view.vector;
XLAL_CHECK(XLALNearestLatticeTilingPoint(loc, point, nearest, nearest_indexes) == XLAL_SUCCESS, XLAL_EFUNC);
gsl_vector_sub(nearest, point);
double err = gsl_blas_dasum(nearest) / n;
XLAL_CHECK(err < 1e-6, XLAL_EFAILED, "\n "
"ERROR: err = %e < 1e-6", err);
XLAL_CHECK(nearest_indexes->data[i] == k, XLAL_EFAILED, "\n "
"ERROR: nearest_indexes[%zu] = %" LAL_UINT8_FORMAT " != %" LAL_UINT8_FORMAT "\n", i, nearest_indexes->data[i], k);
if (0 < i) {
const LatticeTilingStats *stats = XLALLatticeTilingStatistics(tiling, i);
UINT8 nearest_index = 0;
UINT4 nearest_left = 0, nearest_right = 0;
XLAL_CHECK(XLALNearestLatticeTilingBlock(loc, point, i, nearest, &nearest_index, &nearest_left, &nearest_right) == XLAL_SUCCESS, XLAL_EFUNC);
XLAL_CHECK(nearest_index == nearest_indexes->data[i-1], XLAL_EFAILED, "\n "
"ERROR: nearest_index = %" LAL_UINT8_FORMAT " != %" LAL_UINT8_FORMAT "\n", nearest_index, nearest_indexes->data[i-1]);
UINT4 nearest_len = 1 + nearest_left + nearest_right;
XLAL_CHECK(nearest_len <= stats->max_points, XLAL_EFAILED, "\n "
"ERROR: nearest_len = %i > %i = stats[%zu]->max_points\n", nearest_len, stats->max_points, i);
}
if (i+1 < n) {
const LatticeTilingStats *stats = XLALLatticeTilingStatistics(tiling, i+1);
UINT8 nearest_index = 0;
UINT4 nearest_left = 0, nearest_right = 0;
XLAL_CHECK(XLALNearestLatticeTilingBlock(loc, point, i+1, nearest, &nearest_index, &nearest_left, &nearest_right) == XLAL_SUCCESS, XLAL_EFUNC);
XLAL_CHECK(nearest_index == nearest_indexes->data[i], XLAL_EFAILED, "\n "
"ERROR: nearest_index = %" LAL_UINT8_FORMAT " != %" LAL_UINT8_FORMAT "\n", nearest_index, nearest_indexes->data[i]);
UINT4 nearest_len = 1 + nearest_left + nearest_right;
XLAL_CHECK(nearest_len <= stats->max_points, XLAL_EFAILED, "\n "
"ERROR: nearest_len = %i > %i = stats[%zu]->max_points\n", nearest_len, stats->max_points, i+1);
}
}
printf(" done\n");
// Cleanup
XLALDestroyLatticeTilingIterator(itr);
GFMAT(points);
GFVEC(nearest);
XLALDestroyUINT8Vector(nearest_indexes);
}
for (size_t i = 0; i < n; ++i) {
// Create alternating lattice tiling iterator over 'i+1' dimensions
LatticeTilingIterator *itr_alt = XLALCreateLatticeTilingIterator(tiling, i+1);
XLAL_CHECK(itr_alt != NULL, XLAL_EFUNC);
XLAL_CHECK(XLALSetLatticeTilingAlternatingIterator(itr_alt, true) == XLAL_SUCCESS, XLAL_EFUNC);
// Count number of points, check for consistency with non-alternating count
UINT8 total = 0;
while (XLALNextLatticeTilingPoint(itr_alt, NULL) > 0) ++total;
XLAL_CHECK(imaxabs(total - total_ref[i]) <= 1, XLAL_EFUNC, "ERROR: alternating |total - total_ref[%zu]| = |%" LAL_UINT8_FORMAT " - %" LAL_UINT8_FORMAT "| > 1", i, total, total_ref[i]);
// Cleanup
XLALDestroyLatticeTilingIterator(itr_alt);
}
// Cleanup
XLALDestroyLatticeTiling(tiling);
XLALDestroyLatticeTilingLocator(loc);
LALCheckMemoryLeaks();
printf("\n");
fflush(stdout);
return XLAL_SUCCESS;
}
int
print_pc_maps(const char *filename, const gsl_matrix * U,
green_workspace *green_p)
{
int s = 0;
FILE *fp;
const double r = R_EARTH_KM + 0.0; /* radius of magnetic field maps */
const double b = R_EARTH_KM + 110.0; /* radius of current shell */
double lat, lon;
size_t nnm = green_nnm(green_p);
double *X = malloc(nnm * sizeof(double));
double *Y = malloc(nnm * sizeof(double));
double *Z = malloc(nnm * sizeof(double));
gsl_vector_view Xv = gsl_vector_view_array(X, nnm);
gsl_vector_view Yv = gsl_vector_view_array(Y, nnm);
gsl_vector_view Zv = gsl_vector_view_array(Z, nnm);
gsl_vector_const_view pc1 = gsl_matrix_const_column(U, 0);
gsl_vector_const_view pc2 = gsl_matrix_const_column(U, 1);
gsl_vector_const_view pc3 = gsl_matrix_const_column(U, 2);
gsl_vector *gnm1 = gsl_vector_alloc(nnm);
gsl_vector *gnm2 = gsl_vector_alloc(nnm);
gsl_vector *gnm3 = gsl_vector_alloc(nnm);
size_t i;
fp = fopen(filename, "w");
if (!fp)
{
fprintf(stderr, "print_pc_maps: unable to open %s: %s\n",
filename, strerror(errno));
return -1;
}
/* compute gnm coefficients in case r > b */
convert_k2g(b, &pc1.vector, gnm1, green_p);
convert_k2g(b, &pc2.vector, gnm2, green_p);
convert_k2g(b, &pc3.vector, gnm3, green_p);
i = 1;
fprintf(fp, "# Field %zu: longitude (degrees)\n", i++);
fprintf(fp, "# Field %zu: latitude (degrees)\n", i++);
fprintf(fp, "# Field %zu: PC1 chi (kA / nT)\n", i++);
fprintf(fp, "# Field %zu: PC1 B_x (dimensionless)\n", i++);
fprintf(fp, "# Field %zu: PC1 B_y (dimensionless)\n", i++);
fprintf(fp, "# Field %zu: PC1 B_z (dimensionless)\n", i++);
fprintf(fp, "# Field %zu: PC2 chi (kA / nT)\n", i++);
fprintf(fp, "# Field %zu: PC2 B_x (dimensionless)\n", i++);
fprintf(fp, "# Field %zu: PC2 B_y (dimensionless)\n", i++);
fprintf(fp, "# Field %zu: PC2 B_z (dimensionless)\n", i++);
fprintf(fp, "# Field %zu: PC3 chi (kA / nT)\n", i++);
fprintf(fp, "# Field %zu: PC3 B_x (dimensionless)\n", i++);
fprintf(fp, "# Field %zu: PC3 B_y (dimensionless)\n", i++);
fprintf(fp, "# Field %zu: PC3 B_z (dimensionless)\n", i++);
for (lon = -180.0; lon <= 180.0; lon += 1.0)
{
double phi = lon * M_PI / 180.0;
for (lat = -89.9; lat <= 89.9; lat += 1.0)
{
double theta = M_PI / 2.0 - lat * M_PI / 180.0;
double B_pc1[3], B_pc2[3], B_pc3[3];
double chi1, chi2, chi3;
green_calc_ext(R_EARTH_KM, theta, phi, X, Y, Z, green_p);
chi1 = chi_ext(b, phi, &pc1.vector, green_p);
chi2 = chi_ext(b, phi, &pc2.vector, green_p);
chi3 = chi_ext(b, phi, &pc3.vector, green_p);
/*
* If r < b, the current shell is an external source so
* we can directly use the knm coefficients in the U matrix.
*
* If r > b, the current shell is an internal source, and
* we must first compute the gnm coefficients from knm (done
* above via convert_k2g, and then use internal Green's functions
* for the dot product
*/
if (r <= b)
{
green_calc_ext(r, theta, phi, X, Y, Z, green_p);
gsl_blas_ddot(&pc1.vector, &Xv.vector, &B_pc1[0]);
gsl_blas_ddot(&pc1.vector, &Yv.vector, &B_pc1[1]);
gsl_blas_ddot(&pc1.vector, &Zv.vector, &B_pc1[2]);
gsl_blas_ddot(&pc2.vector, &Xv.vector, &B_pc2[0]);
gsl_blas_ddot(&pc2.vector, &Yv.vector, &B_pc2[1]);
gsl_blas_ddot(&pc2.vector, &Zv.vector, &B_pc2[2]);
gsl_blas_ddot(&pc3.vector, &Xv.vector, &B_pc3[0]);
gsl_blas_ddot(&pc3.vector, &Yv.vector, &B_pc3[1]);
gsl_blas_ddot(&pc3.vector, &Zv.vector, &B_pc3[2]);
}
else
{
green_calc_int(r, theta, phi, X, Y, Z, green_p);
gsl_blas_ddot(gnm1, &Xv.vector, &B_pc1[0]);
gsl_blas_ddot(gnm1, &Yv.vector, &B_pc1[1]);
gsl_blas_ddot(gnm1, &Zv.vector, &B_pc1[2]);
gsl_blas_ddot(gnm2, &Xv.vector, &B_pc2[0]);
gsl_blas_ddot(gnm2, &Yv.vector, &B_pc2[1]);
gsl_blas_ddot(gnm2, &Zv.vector, &B_pc2[2]);
gsl_blas_ddot(gnm3, &Xv.vector, &B_pc3[0]);
gsl_blas_ddot(gnm3, &Yv.vector, &B_pc3[1]);
gsl_blas_ddot(gnm3, &Zv.vector, &B_pc3[2]);
}
fprintf(fp, "%f %f %f %f %f %f %f %f %f %f %f %f %f %f\n",
lon,
lat,
chi1,
B_pc1[0],
B_pc1[1],
B_pc1[2],
chi2,
B_pc2[0],
B_pc2[1],
B_pc2[2],
chi3,
B_pc3[0],
B_pc3[1],
B_pc3[2]);
}
fprintf(fp, "\n");
}
free(X);
free(Y);
free(Z);
fclose(fp);
gsl_vector_free(gnm1);
gsl_vector_free(gnm2);
gsl_vector_free(gnm3);
return s;
}
int
gsl_linalg_symmtd_unpack (const gsl_matrix * A,
const gsl_vector * tau,
gsl_matrix * Q,
gsl_vector * diag,
gsl_vector * sdiag)
{
if (A->size1 != A->size2)
{
GSL_ERROR ("matrix A must be square", GSL_ENOTSQR);
}
else if (tau->size + 1 != A->size1)
{
GSL_ERROR ("size of tau must be (matrix size - 1)", GSL_EBADLEN);
}
else if (Q->size1 != A->size1 || Q->size2 != A->size1)
{
GSL_ERROR ("size of Q must match size of A", GSL_EBADLEN);
}
else if (diag->size != A->size1)
{
GSL_ERROR ("size of diagonal must match size of A", GSL_EBADLEN);
}
else if (sdiag->size + 1 != A->size1)
{
GSL_ERROR ("size of subdiagonal must be (matrix size - 1)", GSL_EBADLEN);
}
else
{
const size_t N = A->size1;
size_t i;
/* Initialize Q to the identity */
gsl_matrix_set_identity (Q);
for (i = N - 2; i-- > 0;)
{
gsl_vector_const_view c = gsl_matrix_const_column (A, i);
gsl_vector_const_view h = gsl_vector_const_subvector (&c.vector, i + 1, N - (i+1));
double ti = gsl_vector_get (tau, i);
gsl_matrix_view m = gsl_matrix_submatrix (Q, i + 1, i + 1, N-(i+1), N-(i+1));
gsl_linalg_householder_hm (ti, &h.vector, &m.matrix);
}
/* Copy diagonal into diag */
for (i = 0; i < N; i++)
{
double Aii = gsl_matrix_get (A, i, i);
gsl_vector_set (diag, i, Aii);
}
/* Copy subdiagonal into sd */
for (i = 0; i < N - 1; i++)
{
double Aji = gsl_matrix_get (A, i+1, i);
gsl_vector_set (sdiag, i, Aji);
}
return GSL_SUCCESS;
}
}
void
test_eigen_symm_results (const gsl_matrix * A,
const gsl_vector * eval,
const gsl_matrix * evec,
size_t count,
const char * desc,
const char * desc2)
{
const size_t N = A->size1;
size_t i, j;
double emax = 0;
gsl_vector * x = gsl_vector_alloc(N);
gsl_vector * y = gsl_vector_alloc(N);
/* check eigenvalues */
for (i = 0; i < N; i++)
{
double ei = gsl_vector_get (eval, i);
if (fabs(ei) > emax) emax = fabs(ei);
}
for (i = 0; i < N; i++)
{
double ei = gsl_vector_get (eval, i);
gsl_vector_const_view vi = gsl_matrix_const_column(evec, i);
gsl_vector_memcpy(x, &vi.vector);
/* compute y = A x (should = lambda v) */
gsl_blas_dgemv (CblasNoTrans, 1.0, A, x, 0.0, y);
for (j = 0; j < N; j++)
{
double xj = gsl_vector_get (x, j);
double yj = gsl_vector_get (y, j);
double eixj = chop_subnormals(ei * xj);
gsl_test_abs(yj, eixj, emax * 1e8 * GSL_DBL_EPSILON,
"%s, eigenvalue(%d,%d), %s", desc, i, j, desc2);
}
}
/* check eigenvectors are orthonormal */
for (i = 0; i < N; i++)
{
gsl_vector_const_view vi = gsl_matrix_const_column(evec, i);
double nrm_v = gsl_blas_dnrm2(&vi.vector);
gsl_test_rel (nrm_v, 1.0, N * GSL_DBL_EPSILON, "%s, normalized(%d), %s",
desc, i, desc2);
}
for (i = 0; i < N; i++)
{
gsl_vector_const_view vi = gsl_matrix_const_column(evec, i);
for (j = i + 1; j < N; j++)
{
gsl_vector_const_view vj = gsl_matrix_const_column(evec, j);
double vivj;
gsl_blas_ddot (&vi.vector, &vj.vector, &vivj);
gsl_test_abs (vivj, 0.0, N * GSL_DBL_EPSILON,
"%s, orthogonal(%d,%d), %s", desc, i, j, desc2);
}
}
gsl_vector_free(x);
gsl_vector_free(y);
}
