void
FUNCTION (test, ops) (size_t stride1, size_t stride2, size_t N)
{
size_t i;
TYPE (gsl_vector) * a = FUNCTION (create, vector) (stride1, N);
TYPE (gsl_vector) * b = FUNCTION (create, vector) (stride2, N);
TYPE (gsl_vector) * v = FUNCTION (create, vector) (stride1, N);
for (i = 0; i < N; i++)
{
BASE z, z1;
GSL_REAL (z) = (ATOMIC) 3+i;
GSL_IMAG (z) = (ATOMIC) (3+i + 10);
GSL_REAL (z1) = (ATOMIC) (3 + 2*i + 5);
GSL_IMAG (z1) = (ATOMIC) (3 + 2*i + 20);
FUNCTION (gsl_vector, set) (a, i, z);
FUNCTION (gsl_vector, set) (b, i, z1);
}
{
int status = (FUNCTION(gsl_vector,equal) (a,b) != 0);
TEST2 (status, "_equal vectors unequal");
}
FUNCTION(gsl_vector, memcpy) (v, a);
{
int status = (FUNCTION(gsl_vector,equal) (a,v) != 1);
TEST2 (status, "_equal vectors equal");
}
FUNCTION(gsl_vector, add) (v, b);
{
int status = 0;
for (i = 0; i < N; i++)
{
BASE r = FUNCTION(gsl_vector,get) (v,i);
if (GSL_REAL(r) != (ATOMIC) (3*i+11)
|| GSL_IMAG(r) != (ATOMIC) (3*i+36))
status = 1;
}
TEST2 (status, "_add vector addition");
}
{
int status = 0;
FUNCTION(gsl_vector, swap) (a, b);
for (i = 0; i < N; i++)
{
BASE z, z1;
BASE x = FUNCTION (gsl_vector, get) (a, i);
BASE y = FUNCTION (gsl_vector, get) (b, i);
GSL_REAL (z) = (ATOMIC) 3+i;
GSL_IMAG (z) = (ATOMIC) (3+i + 10);
GSL_REAL (z1) = (ATOMIC) (3 + 2*i + 5);
GSL_IMAG (z1) = (ATOMIC) (3 + 2*i + 20);
status |= !GSL_COMPLEX_EQ(z,y);
status |= !GSL_COMPLEX_EQ(z1,x);
}
FUNCTION(gsl_vector, swap) (a, b);
for (i = 0; i < N; i++)
{
BASE z, z1;
BASE x = FUNCTION (gsl_vector, get) (a, i);
BASE y = FUNCTION (gsl_vector, get) (b, i);
GSL_REAL (z) = (ATOMIC) 3+i;
GSL_IMAG (z) = (ATOMIC) (3+i + 10);
GSL_REAL (z1) = (ATOMIC) (3 + 2*i + 5);
GSL_IMAG (z1) = (ATOMIC) (3 + 2*i + 20);
status |= !GSL_COMPLEX_EQ(z,x);
status |= !GSL_COMPLEX_EQ(z1,y);
}
TEST2 (status, "_swap exchange vectors");
}
FUNCTION(gsl_vector, memcpy) (v, a);
FUNCTION(gsl_vector, sub) (v, b);
{
int status = 0;
for (i = 0; i < N; i++)
{
BASE r = FUNCTION(gsl_vector,get) (v,i);
if (GSL_REAL(r) != (-(ATOMIC)i-(ATOMIC)5) || GSL_IMAG(r) != (-(ATOMIC)i-(ATOMIC)10))
status = 1;
}
TEST2 (status, "_sub vector subtraction");
}
FUNCTION(gsl_vector, memcpy) (v, a);
FUNCTION(gsl_vector, mul) (v, b);
{
int status = 0;
for (i = 0; i < N; i++)
{
BASE r = FUNCTION(gsl_vector,get) (v,i);
ATOMIC real = (-35*(ATOMIC)i-275);
ATOMIC imag = (173+((ATOMIC)i)*(63+4*(ATOMIC)i));
if (fabs(GSL_REAL(r) - real) > 100 * BASE_EPSILON ||
fabs(GSL_IMAG(r) - imag) > 100 * BASE_EPSILON)
status = 1;
}
TEST2 (status, "_mul multiplication");
}
FUNCTION(gsl_vector, memcpy) (v, a);
FUNCTION(gsl_vector, div) (v, b);
{
int status = 0;
for (i = 0; i < N; i++)
{
BASE r = FUNCTION(gsl_vector,get) (v,i);
ATOMIC denom = 593 + ((ATOMIC)i)*(124+((ATOMIC)i)*8);
ATOMIC real = (323+((ATOMIC)i)*(63+4*((ATOMIC)i))) / denom;
ATOMIC imag = (35 +((ATOMIC)i)*5) / denom;
if (fabs(GSL_REAL(r) - real) > 100 * BASE_EPSILON)
status = 1;
if (fabs(GSL_IMAG(r) - imag) > 100 * BASE_EPSILON)
status = 1;
}
TEST2 (status, "_div division");
}
FUNCTION(gsl_vector, free) (a);
FUNCTION(gsl_vector, free) (b);
FUNCTION(gsl_vector, free) (v);
}
void MBlockUser::Run() {
//
// Allocation Matrices
//
gsl_matrix_uint signature_frequencies=min2.GetDataObj();
gsl_matrix signature_powers=min3.GetDataObj();
//
// input bits
//
gsl_matrix_uint inputbits = min1.GetDataObj();
//
// outer loop: the users
//
for (int u=0;u<M();u++) {
gsl_vector_complex_view tmpout = gsl_matrix_complex_column(outmat,u);
//
//
// FETCH K INPUT SYMBOLS
//
//
for (int j=0;j<K();j++) {
symbol_id=0;
//////// I take Nb bits from input and map it in new_symbol
for (int i=0;i<Nb();i++) {
symbol_id = (symbol_id << 1);
// symbol_id += in1.GetDataObj();
symbol_id += gsl_matrix_uint_get(&inputbits,u,j*Nb()+i);
}
new_symbol = gsl_complex_polar(1.0,
symbol_arg *
double(gsl_vector_uint_get(gray_encoding,
symbol_id)));
gsl_vector_complex_set(tmp,j,new_symbol);
}
//
//
// SELECTION MATRIX UPDATE and POWER
//
//
// gsl_matrix_complex_set_identity(selection_mat);
gsl_matrix_complex_set_zero(selection_mat);
for (int i=0;i<J(); i++) {
unsigned int carrier=gsl_matrix_uint_get(&signature_frequencies,u,i);
double power=gsl_matrix_get(&signature_powers,u,i);
gsl_complex one=gsl_complex_polar(power,0.0);
gsl_matrix_complex_set(selection_mat,carrier,i,one);
}
//
//
// PRECODING MATRIX UPDATE
//
//
#ifdef GIANNAKIS_PRECODING
double roarg=2.0*double(M_PI/N());
for (int i=0;i<J(); i++) {
unsigned int carrier=gsl_matrix_uint_get(&signature_frequencies,u,i);
for (int j=0; j<K(); j++) {
gsl_complex ro=gsl_complex_polar(sqrt(1.0/double(J())),-j*carrier*roarg);
gsl_matrix_complex_set(coding_mat,i,j,ro);
}
}
#else
double roarg=2.0*double(M_PI/J());
for (int i=0;i<J(); i++) {
for (int j=0; j<K(); j++) {
gsl_complex ro=gsl_complex_polar(sqrt(1.0/double(J())),-j*i*roarg);
gsl_matrix_complex_set(coding_mat,i,j,ro);
}
}
#endif
#ifdef SHOW_MATRIX
cout << endl << BlockName << " user: "******"coding matrix (theta) = " << endl;
gsl_matrix_complex_show(coding_mat);
cout << "T^h*T matrix = " << endl;
gsl_matrix_complex_show(THT);
cout << "T^h*T trace = "
<< GSL_REAL(trace)
<< ", "
<< GSL_IMAG(trace)
<< endl;
gsl_matrix_complex_free(THT);
#endif
//
//
// PRECODING
//
//
gsl_blas_zgemv(CblasNoTrans,
gsl_complex_rect(1.0,0),
coding_mat,
tmp,
gsl_complex_rect(0,0),
tmp1);
//
//
// CARRIER SELECTION
//
//
gsl_blas_zgemv(CblasNoTrans,
gsl_complex_rect(1.0,0),
selection_mat,
tmp1,
gsl_complex_rect(0,0),
tmp2);
//
//
// IFFT TRANSFORM
//
//
gsl_blas_zgemv(CblasNoTrans,
gsl_complex_rect(1.0,0),
transform_mat,
tmp2,
gsl_complex_rect(0,0),
&tmpout.vector);
// cout << "\n\n symbols (user " << u << ") = " << endl;
// gsl_vector_complex_fprintf(stdout,tmp,"%f");
#ifdef SHOW_MATRIX
cout << "\n\n symbols (user " << u << ") = " << endl;
gsl_vector_complex_fprintf(stdout,tmp,"%f");
cout << "\n\n precoded = " << endl;
gsl_vector_complex_fprintf(stdout,tmp1,"%f");
cout << "\n\n precoded selected = " << endl;
gsl_vector_complex_fprintf(stdout,tmp2,"%f");
cout << "\n\n precoded selected transformed = " << endl;
gsl_vector_complex_fprintf(stdout,&tmpout.vector,"%f");
#endif
} // close user loop
mout1.DeliverDataObj(*outmat);
}
int
gsl_eigen_herm (gsl_matrix_complex * A, gsl_vector * eval,
gsl_eigen_herm_workspace * w)
{
if (A->size1 != A->size2)
{
GSL_ERROR ("matrix must be square to compute eigenvalues", GSL_ENOTSQR);
}
else if (eval->size != A->size1)
{
GSL_ERROR ("eigenvalue vector must match matrix size", GSL_EBADLEN);
}
else
{
const size_t N = A->size1;
double *const d = w->d;
double *const sd = w->sd;
size_t a, b;
/* handle special case */
if (N == 1)
{
gsl_complex A00 = gsl_matrix_complex_get (A, 0, 0);
gsl_vector_set (eval, 0, GSL_REAL(A00));
return GSL_SUCCESS;
}
{
gsl_vector_view d_vec = gsl_vector_view_array (d, N);
gsl_vector_view sd_vec = gsl_vector_view_array (sd, N - 1);
gsl_vector_complex_view tau_vec = gsl_vector_complex_view_array (w->tau, N-1);
gsl_linalg_hermtd_decomp (A, &tau_vec.vector);
gsl_linalg_hermtd_unpack_T (A, &d_vec.vector, &sd_vec.vector);
}
/* Make an initial pass through the tridiagonal decomposition
to remove off-diagonal elements which are effectively zero */
chop_small_elements (N, d, sd);
/* Progressively reduce the matrix until it is diagonal */
b = N - 1;
while (b > 0)
{
if (sd[b - 1] == 0.0 || isnan(sd[b - 1]))
{
b--;
continue;
}
/* Find the largest unreduced block (a,b) starting from b
and working backwards */
a = b - 1;
while (a > 0)
{
if (sd[a - 1] == 0.0)
{
break;
}
a--;
}
{
const size_t n_block = b - a + 1;
double *d_block = d + a;
double *sd_block = sd + a;
/* apply QR reduction with implicit deflation to the
unreduced block */
qrstep (n_block, d_block, sd_block, NULL, NULL);
/* remove any small off-diagonal elements */
chop_small_elements (n_block, d_block, sd_block);
}
}
{
gsl_vector_view d_vec = gsl_vector_view_array (d, N);
gsl_vector_memcpy (eval, &d_vec.vector);
}
return GSL_SUCCESS;
}
}
void
test_eigen_gen_pencil(const gsl_matrix * A, const gsl_matrix * B,
size_t count, const char * desc, int test_schur,
test_eigen_gen_workspace *w)
{
const size_t N = A->size1;
size_t i;
gsl_matrix_memcpy(w->A, A);
gsl_matrix_memcpy(w->B, B);
if (test_schur)
{
gsl_eigen_genv_QZ(w->A, w->B, w->alphav, w->betav, w->evec, w->Q, w->Z, w->genv_p);
test_eigen_schur(A, w->A, w->Q, w->Z, count, "genv/A", desc);
test_eigen_schur(B, w->B, w->Q, w->Z, count, "genv/B", desc);
}
else
gsl_eigen_genv(w->A, w->B, w->alphav, w->betav, w->evec, w->genv_p);
test_eigen_gen_results(A, B, w->alphav, w->betav, w->evec, count, desc, "unsorted");
gsl_matrix_memcpy(w->A, A);
gsl_matrix_memcpy(w->B, B);
if (test_schur)
{
gsl_eigen_gen_params(1, 1, 0, w->gen_p);
gsl_eigen_gen_QZ(w->A, w->B, w->alpha, w->beta, w->Q, w->Z, w->gen_p);
test_eigen_schur(A, w->A, w->Q, w->Z, count, "gen/A", desc);
test_eigen_schur(B, w->B, w->Q, w->Z, count, "gen/B", desc);
}
else
{
gsl_eigen_gen_params(0, 0, 0, w->gen_p);
gsl_eigen_gen(w->A, w->B, w->alpha, w->beta, w->gen_p);
}
/* compute eval = alpha / beta values */
for (i = 0; i < N; ++i)
{
gsl_complex z, ai;
double bi;
ai = gsl_vector_complex_get(w->alpha, i);
bi = gsl_vector_get(w->beta, i);
GSL_SET_COMPLEX(&z, GSL_REAL(ai) / bi, GSL_IMAG(ai) / bi);
gsl_vector_complex_set(w->eval, i, z);
ai = gsl_vector_complex_get(w->alphav, i);
bi = gsl_vector_get(w->betav, i);
GSL_SET_COMPLEX(&z, GSL_REAL(ai) / bi, GSL_IMAG(ai) / bi);
gsl_vector_complex_set(w->evalv, i, z);
}
/* sort eval and evalv and test them */
gsl_eigen_nonsymmv_sort(w->eval, NULL, GSL_EIGEN_SORT_ABS_ASC);
gsl_eigen_nonsymmv_sort(w->evalv, NULL, GSL_EIGEN_SORT_ABS_ASC);
test_eigenvalues_complex(w->evalv, w->eval, "gen", desc);
gsl_eigen_genv_sort(w->alphav, w->betav, w->evec, GSL_EIGEN_SORT_ABS_ASC);
test_eigen_gen_results(A, B, w->alphav, w->betav, w->evec, count, desc, "abs/asc");
gsl_eigen_genv_sort(w->alphav, w->betav, w->evec, GSL_EIGEN_SORT_ABS_DESC);
test_eigen_gen_results(A, B, w->alphav, w->betav, w->evec, count, desc, "abs/desc");
} /* test_eigen_gen_pencil() */
void
test_eigen_nonsymm_results (const gsl_matrix * m,
const gsl_vector_complex * eval,
const gsl_matrix_complex * evec,
size_t count,
const char * desc,
const char * desc2)
{
size_t i,j;
size_t N = m->size1;
gsl_vector_complex * x = gsl_vector_complex_alloc(N);
gsl_vector_complex * y = gsl_vector_complex_alloc(N);
gsl_matrix_complex * A = gsl_matrix_complex_alloc(N, N);
/* we need a complex matrix for the blas routines, so copy m into A */
for (i = 0; i < N; ++i)
{
for (j = 0; j < N; ++j)
{
gsl_complex z;
GSL_SET_COMPLEX(&z, gsl_matrix_get(m, i, j), 0.0);
gsl_matrix_complex_set(A, i, j, z);
}
}
for (i = 0; i < N; i++)
{
gsl_complex ei = gsl_vector_complex_get (eval, i);
gsl_vector_complex_const_view vi = gsl_matrix_complex_const_column(evec, i);
double norm = gsl_blas_dznrm2(&vi.vector);
/* check that eigenvector is normalized */
gsl_test_rel(norm, 1.0, N * GSL_DBL_EPSILON,
"nonsymm(N=%u,cnt=%u), %s, normalized(%d), %s", N, count, desc, i, desc2);
gsl_vector_complex_memcpy(x, &vi.vector);
/* compute y = m x (should = lambda v) */
gsl_blas_zgemv (CblasNoTrans, GSL_COMPLEX_ONE, A, x,
GSL_COMPLEX_ZERO, y);
/* compute x = lambda v */
gsl_blas_zscal(ei, x);
/* now test if y = x */
for (j = 0; j < N; j++)
{
gsl_complex xj = gsl_vector_complex_get (x, j);
gsl_complex yj = gsl_vector_complex_get (y, j);
/* use abs here in case the values are close to 0 */
gsl_test_abs(GSL_REAL(yj), GSL_REAL(xj), 1e8*GSL_DBL_EPSILON,
"nonsymm(N=%u,cnt=%u), %s, eigenvalue(%d,%d), real, %s", N, count, desc, i, j, desc2);
gsl_test_abs(GSL_IMAG(yj), GSL_IMAG(xj), 1e8*GSL_DBL_EPSILON,
"nonsymm(N=%u,cnt=%u), %s, eigenvalue(%d,%d), imag, %s", N, count, desc, i, j, desc2);
}
}
gsl_matrix_complex_free(A);
gsl_vector_complex_free(x);
gsl_vector_complex_free(y);
}
complex::complex(const gsl_complex& z)
{
// _complex = (gsl_complex*)malloc(sizeof(gsl_complex));
GSL_SET_COMPLEX(&_complex, GSL_REAL(z), GSL_IMAG(z));
}
double& complex::real()
{
return GSL_REAL(_complex);
}
gsl_complex f_bessel(gsl_complex p, const Params *params)
{
double m = params->m;
return gsl_complex_rect(0, 2*m * gsl_sf_bessel_K1(m * GSL_REAL(p)));
}
gsl_complex integrate_line_segment(Params *params,
gsl_complex p0,
gsl_complex p1)
{
gsl_complex k = gsl_complex_sub(p1, p0);
const double r = params->r;
const double a = 0.0; // parameter interval start
const double b = 1.0; // parameter interval end
const double L = b - a; // length of parameter interval
const size_t table_size = 1000;
// calculate frequency of oscillatory part
double omega = GSL_REAL(k) * r;
gsl_integration_workspace *ws = gsl_integration_workspace_alloc(table_size);
// prepare sine/cosine tables for integration
gsl_integration_qawo_table *table_cos = gsl_integration_qawo_table_alloc(omega, L, GSL_INTEG_COSINE, table_size);
gsl_integration_qawo_table *table_sin = gsl_integration_qawo_table_alloc(omega, L, GSL_INTEG_SINE, table_size);
LineSegmentParams lsp;
lsp.p0 = p0;
lsp.k = k;
lsp.damping = params->r * GSL_IMAG(k);
lsp.params = params;
//fprintf(stderr, "p0 = %g %g, p1 = %g %g, k = %g %g, r = %g, omega = %g, damping = %g\n",
// GSL_REAL(p0), GSL_IMAG(p0), GSL_REAL(p1), GSL_IMAG(p1),
// GSL_REAL(k), GSL_IMAG(k), r, omega, lsp.damping);
gsl_function F;
F.function = &line_segment_integrand_wrapper;
F.params = &lsp;
double result_real_cos, abserr_real_cos;
double result_real_sin, abserr_real_sin;
double result_imag_cos, abserr_imag_cos;
double result_imag_sin, abserr_imag_sin;
double epsabs = 1e-9;
double epsrel = 1e-9;
lsp.part = REAL;
gsl_integration_qawo(&F, a, epsabs, epsrel, table_size, ws, table_cos, &result_real_cos, &abserr_real_cos);
gsl_integration_qawo(&F, a, epsabs, epsrel, table_size, ws, table_sin, &result_real_sin, &abserr_real_sin);
lsp.part = IMAG;
gsl_integration_qawo(&F, a, epsabs, epsrel, table_size, ws, table_cos, &result_imag_cos, &abserr_imag_cos);
gsl_integration_qawo(&F, a, epsabs, epsrel, table_size, ws, table_sin, &result_imag_sin, &abserr_imag_sin);
//fprintf(stderr, " cos: %g (+- %g) %g (+- %g) sin: %g (+- %g) %g (+- %g)\n",
// result_real_cos, abserr_real_cos, result_imag_cos, abserr_imag_cos,
// result_real_sin, abserr_real_sin, result_imag_sin, abserr_imag_sin);
gsl_complex cos_part = gsl_complex_rect(result_real_cos, result_imag_cos);
gsl_complex sin_part = gsl_complex_rect(-result_imag_sin, result_real_sin);
gsl_complex sum = gsl_complex_add(cos_part, sin_part);
gsl_complex result = gsl_complex_mul(
k,
gsl_complex_mul(sum, gsl_complex_exp(gsl_complex_mul_imag(p0, params->r))));
gsl_integration_qawo_table_free(table_sin);
gsl_integration_qawo_table_free(table_cos);
gsl_integration_workspace_free(ws);
return result;
}
void
gsl_complex_negative (complex_t const *a, complex_t *res)
{ /* z=1/a */
complex_init (res, -GSL_REAL (a), -GSL_IMAG (a));
}
int main(void) {
gsl_matrix *TS; /* the training set of real waveforms */
gsl_matrix_complex *cTS; /* the training set of complex waveforms */
size_t TSsize; /* the size of the training set (number of waveforms) */
size_t wl; /* the length of each waveform */
size_t k = 0, j = 0, i = 0, nbases = 0, cnbases = 0;
REAL8 *RB = NULL; /* the real reduced basis set */
COMPLEX16 *cRB = NULL; /* the complex reduced basis set */
LALInferenceREALROQInterpolant *interp = NULL;
LALInferenceCOMPLEXROQInterpolant *cinterp = NULL;
gsl_vector *freqs;
double tolerance = TOLERANCE; /* tolerance for reduced basis generation loop */
TSsize = TSSIZE;
wl = WL;
/* allocate memory for training set */
TS = gsl_matrix_calloc(TSsize, wl);
cTS = gsl_matrix_complex_calloc(TSsize, wl);
/* the waveform model is just a simple chirp so set up chirp mass range for training set */
double fmin0 = 48, fmax0 = 256, f0 = 0., m0 = 0.;
double df = (fmax0-fmin0)/(wl-1.); /* model time steps */
freqs = gsl_vector_alloc(wl); /* times at which to calculate the model */
double Mcmax = 2., Mcmin = 1.5, Mc = 0.;
gsl_vector_view fweights = gsl_vector_view_array(&df, 1);
/* set up training sets (one real and one complex) */
for ( k=0; k < TSsize; k++ ){
Mc = pow(pow(Mcmin, 5./3.) + (double)k*(pow(Mcmax, 5./3.)-pow(Mcmin, 5./3.))/((double)TSsize-1), 3./5.);
for ( j=0; j < wl; j++ ){
f0 = fmin0 + (double)j*(fmax0-fmin0)/((double)wl-1.);
gsl_complex gctmp;
COMPLEX16 ctmp;
m0 = real_model(f0, Mc);
ctmp = imag_model(f0, Mc);
GSL_SET_COMPLEX(&gctmp, creal(ctmp), cimag(ctmp));
gsl_vector_set(freqs, j, f0);
gsl_matrix_set(TS, k, j, m0);
gsl_matrix_complex_set(cTS, k, j, gctmp);
}
}
/* create reduced orthonormal basis from training set */
if ( (RB = LALInferenceGenerateREAL8OrthonormalBasis(&fweights.vector, tolerance, TS, &nbases)) == NULL){
fprintf(stderr, "Error... problem producing basis\n");
return 1;
}
if ( (cRB = LALInferenceGenerateCOMPLEX16OrthonormalBasis(&fweights.vector, tolerance, cTS, &cnbases)) == NULL){
fprintf(stderr, "Error... problem producing basis\n");
return 1;
}
/* free the training set */
gsl_matrix_free(TS);
gsl_matrix_complex_free(cTS);
gsl_matrix_view RBview = gsl_matrix_view_array(RB, nbases, wl);
gsl_matrix_complex_view cRBview = gsl_matrix_complex_view_array((double*)cRB, cnbases, wl);
fprintf(stderr, "No. nodes (real) = %zu, %zu x %zu\n", nbases, RBview.matrix.size1, RBview.matrix.size2);
fprintf(stderr, "No. nodes (complex) = %zu, %zu x %zu\n", cnbases, cRBview.matrix.size1, cRBview.matrix.size2);
/* get the interpolant */
interp = LALInferenceGenerateREALROQInterpolant(&RBview.matrix);
cinterp = LALInferenceGenerateCOMPLEXROQInterpolant(&cRBview.matrix);
/* free the reduced basis */
XLALFree(RB);
XLALFree(cRB);
/* now get the terms for the likelihood with and without the reduced order quadrature
* and do some timing tests */
/* create the model dot model weights */
REAL8 varval = 1.;
gsl_vector_view vars = gsl_vector_view_array(&varval, 1);
gsl_matrix *mmw = LALInferenceGenerateREALModelModelWeights(interp->B, &vars.vector);
gsl_matrix_complex *cmmw = LALInferenceGenerateCOMPLEXModelModelWeights(cinterp->B, &vars.vector);
/* let's create some Gaussian random data */
const gsl_rng_type *T;
gsl_rng *r;
gsl_rng_env_setup();
T = gsl_rng_default;
r = gsl_rng_alloc(T);
REAL8 *data = XLALCalloc(wl, sizeof(REAL8));
COMPLEX16 *cdata = XLALCalloc(wl, sizeof(COMPLEX16));
for ( i=0; i<wl; i++ ){
data[i] = gsl_ran_gaussian(r, 1.0); /* real data */
cdata[i] = gsl_ran_gaussian(r, 1.0) + I*gsl_ran_gaussian(r, 1.0); /* complex data */
}
/* create the data dot model weights */
gsl_vector_view dataview = gsl_vector_view_array(data, wl);
gsl_vector *dmw = LALInferenceGenerateREAL8DataModelWeights(interp->B, &dataview.vector, &vars.vector);
gsl_vector_complex_view cdataview = gsl_vector_complex_view_array((double*)cdata, wl);
gsl_vector_complex *cdmw = LALInferenceGenerateCOMPLEX16DataModelWeights(cinterp->B, &cdataview.vector, &vars.vector);
/* pick a chirp mass and generate a model to compare likelihoods */
double randMc = 1.873; /* a random frequency to create a model */
gsl_vector *modelfull = gsl_vector_alloc(wl);
gsl_vector *modelreduced = gsl_vector_alloc(nbases);
gsl_vector_complex *cmodelfull = gsl_vector_complex_alloc(wl);
gsl_vector_complex *cmodelreduced = gsl_vector_complex_alloc(cnbases);
/* create models */
for ( i=0; i<wl; i++ ){
/* models at all frequencies */
gsl_vector_set(modelfull, i, real_model(gsl_vector_get(freqs, i), randMc));
COMPLEX16 cval = imag_model(gsl_vector_get(freqs, i), randMc);
gsl_complex gcval;
GSL_SET_COMPLEX(&gcval, creal(cval), cimag(cval));
gsl_vector_complex_set(cmodelfull, i, gcval);
}
/* models at interpolant nodes */
for ( i=0; i<nbases; i++ ){ /* real model */
gsl_vector_set(modelreduced, i, real_model(gsl_vector_get(freqs, interp->nodes[i]), randMc));
}
for ( i=0; i<cnbases; i++ ){ /* complex model */
COMPLEX16 cval = imag_model(gsl_vector_get(freqs, cinterp->nodes[i]), randMc);
gsl_complex gcval;
GSL_SET_COMPLEX(&gcval, creal(cval), cimag(cval));
gsl_vector_complex_set(cmodelreduced, i, gcval);
}
/* timing variables */
struct timeval t1, t2, t3, t4;
double dt1, dt2;
/* start with the real model */
/* get the model model term with the full model */
REAL8 mmfull, mmred;
gettimeofday(&t1, NULL);
XLAL_CALLGSL( gsl_blas_ddot(modelfull, modelfull, &mmfull) ); /* real model */
gettimeofday(&t2, NULL);
/* now get it with the reduced order quadrature */
gettimeofday(&t3, NULL);
mmred = LALInferenceROQREAL8ModelDotModel(mmw, modelreduced);
gettimeofday(&t4, NULL);
dt1 = (double)((t2.tv_sec + t2.tv_usec*1.e-6) - (t1.tv_sec + t1.tv_usec*1.e-6));
dt2 = (double)((t4.tv_sec + t4.tv_usec*1.e-6) - (t3.tv_sec + t3.tv_usec*1.e-6));
fprintf(stderr, "Real Signal:\n - M dot M (full) = %le [%.9lf s], M dot M (reduced) = %le [%.9lf s], time ratio = %lf\n", mmfull, dt1, mmred, dt2, dt1/dt2);
/* get the data model term with the full model */
REAL8 dmfull, dmred;
gettimeofday(&t1, NULL);
XLAL_CALLGSL( gsl_blas_ddot(&dataview.vector, modelfull, &dmfull) );
gettimeofday(&t2, NULL);
/* now get it with the reduced order quadrature */
gettimeofday(&t3, NULL);
dmred = LALInferenceROQREAL8DataDotModel(dmw, modelreduced);
gettimeofday(&t4, NULL);
dt1 = (double)((t2.tv_sec + t2.tv_usec*1.e-6) - (t1.tv_sec + t1.tv_usec*1.e-6));
dt2 = (double)((t4.tv_sec + t4.tv_usec*1.e-6) - (t3.tv_sec + t3.tv_usec*1.e-6));
fprintf(stderr, " - D dot M (full) = %le [%.9lf s], D dot M (reduced) = %le [%.9lf s], time ratio = %lf\n", dmfull, dt1, dmred, dt2, dt1/dt2);
/* check difference in log likelihoods */
double Lfull, Lred, Lfrac;
Lfull = mmfull - 2.*dmfull;
Lred = mmred - 2.*dmred;
Lfrac = 100.*fabs(Lfull-Lred)/fabs(Lfull); /* fractional log likelihood difference (in %) */
fprintf(stderr, " - Fractional difference in log likelihoods = %lf%%\n", Lfrac);
XLALFree(data);
gsl_vector_free(modelfull);
gsl_vector_free(modelreduced);
gsl_matrix_free(mmw);
gsl_vector_free(dmw);
/* check log likelihood difference is within tolerance */
if ( Lfrac > LTOL ) { return 1; }
/* now do the same with the complex model */
/* get the model model term with the full model */
COMPLEX16 cmmred, cmmfull;
gsl_complex cmmfulltmp;
gettimeofday(&t1, NULL);
XLAL_CALLGSL( gsl_blas_zdotc(cmodelfull, cmodelfull, &cmmfulltmp) ); /* complex model */
cmmfull = GSL_REAL(cmmfulltmp) + I*GSL_IMAG(cmmfulltmp);
gettimeofday(&t2, NULL);
gettimeofday(&t3, NULL);
cmmred = LALInferenceROQCOMPLEX16ModelDotModel(cmmw, cmodelreduced);
gettimeofday(&t4, NULL);
dt1 = (double)((t2.tv_sec + t2.tv_usec*1.e-6) - (t1.tv_sec + t1.tv_usec*1.e-6));
dt2 = (double)((t4.tv_sec + t4.tv_usec*1.e-6) - (t3.tv_sec + t3.tv_usec*1.e-6));
fprintf(stderr, "Complex Signal:\n - M dot M (full) = %le [%.9lf s], M dot M (reduced) = %le [%.9lf s], time ratio = %lf\n", creal(cmmfull), dt1, creal(cmmred), dt2, dt1/dt2);
COMPLEX16 cdmfull, cdmred;
gsl_complex cdmfulltmp;
gettimeofday(&t1, NULL);
XLAL_CALLGSL( gsl_blas_zdotc(&cdataview.vector, cmodelfull, &cdmfulltmp) );
cdmfull = GSL_REAL(cdmfulltmp) + I*GSL_IMAG(cdmfulltmp);
gettimeofday(&t2, NULL);
gettimeofday(&t3, NULL);
cdmred = LALInferenceROQCOMPLEX16DataDotModel(cdmw, cmodelreduced);
gettimeofday(&t4, NULL);
dt1 = (double)((t2.tv_sec + t2.tv_usec*1.e-6) - (t1.tv_sec + t1.tv_usec*1.e-6));
dt2 = (double)((t4.tv_sec + t4.tv_usec*1.e-6) - (t3.tv_sec + t3.tv_usec*1.e-6));
fprintf(stderr, " - D dot M (full) = %le [%.9lf s], D dot M (reduced) = %le [%.9lf s], time ratio = %lf\n", creal(cdmfull), dt1, creal(cdmred), dt2, dt1/dt2);
/* check difference in log likelihoods */
Lfull = creal(cmmfull) - 2.*creal(cdmfull);
Lred = creal(cmmred) - 2.*creal(cdmred);
Lfrac = 100.*fabs(Lfull-Lred)/fabs(Lfull); /* fractional log likelihood difference (in %) */
fprintf(stderr, " - Fractional difference in log likelihoods = %lf%%\n", Lfrac);
XLALFree(cdata);
gsl_vector_complex_free(cmodelfull);
gsl_vector_complex_free(cmodelreduced);
gsl_matrix_complex_free(cmmw);
gsl_vector_complex_free(cdmw);
LALInferenceRemoveREALROQInterpolant( interp );
LALInferenceRemoveCOMPLEXROQInterpolant( cinterp );
/* check log likelihood difference is within tolerance */
if ( Lfrac > LTOL ) { return 1; }
return 0;
}
static inline void
gsl_complex_mul_imag (complex_t const *a, gnm_float y, complex_t *res)
{ /* z=a*iy */
complex_init (res, -y * GSL_IMAG (a), y * GSL_REAL (a));
}
void SteadyState::classifyState( const double* T )
{
#ifdef USE_GSL
// unsigned int nConsv = numVarPools_ - rank_;
gsl_matrix* J = gsl_matrix_calloc ( numVarPools_, numVarPools_ );
// double* yprime = new double[ numVarPools_ ];
// vector< double > yprime( numVarPools_, 0.0 );
// Generate an approximation to the Jacobean by generating small
// increments to each of the molecules in the steady state, one
// at a time, and putting the resultant rate vector into a column
// of the J matrix.
// This needs a bit of heuristic to decide what is a 'small' increment.
// Use the CoInits for this. Stoichiometry shouldn't matter too much.
// I used the totals from consv rules earlier, but that can have
// negative values.
double tot = 0.0;
Stoich* s = reinterpret_cast< Stoich* >( stoich_.eref().data() );
vector< double > nVec = LookupField< unsigned int, vector< double > >::get(
s->getKsolve(), "nVec", 0 );
for ( unsigned int i = 0; i < numVarPools_; ++i ) {
tot += nVec[i];
}
tot *= DELTA;
vector< double > yprime( nVec.size(), 0.0 );
// Fill up Jacobian
for ( unsigned int i = 0; i < numVarPools_; ++i ) {
double orig = nVec[i];
if ( isNaN( orig ) ) {
cout << "Warning: SteadyState::classifyState: orig=nan\n";
solutionStatus_ = 2; // Steady state OK, eig failed
gsl_matrix_free ( J );
return;
}
if ( isNaN( tot ) ) {
cout << "Warning: SteadyState::classifyState: tot=nan\n";
solutionStatus_ = 2; // Steady state OK, eig failed
gsl_matrix_free ( J );
return;
}
nVec[i] = orig + tot;
pool_.updateRates( &nVec[0], &yprime[0] );
nVec[i] = orig;
// Assign the rates for each mol.
for ( unsigned int j = 0; j < numVarPools_; ++j ) {
gsl_matrix_set( J, i, j, yprime[j] );
}
}
// Jacobian is now ready. Find eigenvalues.
gsl_vector_complex* vec = gsl_vector_complex_alloc( numVarPools_ );
gsl_eigen_nonsymm_workspace* workspace =
gsl_eigen_nonsymm_alloc( numVarPools_ );
int status = gsl_eigen_nonsymm( J, vec, workspace );
eigenvalues_.clear();
eigenvalues_.resize( numVarPools_, 0.0 );
if ( status != GSL_SUCCESS ) {
cout << "Warning: SteadyState::classifyState failed to find eigenvalues. Status = " <<
status << endl;
solutionStatus_ = 2; // Steady state OK, eig classification failed
} else { // Eigenvalues are ready. Classify state.
nNegEigenvalues_ = 0;
nPosEigenvalues_ = 0;
for ( unsigned int i = 0; i < numVarPools_; ++i ) {
gsl_complex z = gsl_vector_complex_get( vec, i );
double r = GSL_REAL( z );
nNegEigenvalues_ += ( r < -EPSILON );
nPosEigenvalues_ += ( r > EPSILON );
eigenvalues_[i] = r;
// We have a problem here because numVarPools_ usually > rank
// This means we have several zero eigenvalues.
}
if ( nNegEigenvalues_ == rank_ )
stateType_ = 0; // Stable
else if ( nPosEigenvalues_ == rank_ ) // Never see it.
stateType_ = 1; // Unstable
else if (nPosEigenvalues_ == 1)
stateType_ = 2; // Saddle
else if ( nPosEigenvalues_ >= 2 )
stateType_ = 3; // putative oscillatory
else if ( nNegEigenvalues_ == ( rank_ - 1) && nPosEigenvalues_ == 0 )
stateType_ = 4; // one zero or unclassified eigenvalue. Messy.
else
stateType_ = 5; // Other
}
gsl_vector_complex_free( vec );
gsl_matrix_free ( J );
gsl_eigen_nonsymm_free( workspace );
#endif
}
void smf_filter_mce( smfFilter *filt, int noinverse, int *status ) {
/* Filter parameters */
double B_1_1;
double B_1_2;
double B_2_1;
double B_2_2;
double CLOCK_PERIOD;
double ROW_DWELL;
double NUM_ROWS=41;
double DELTA_TIME;
double SRATE;
double datechange; /* UTC MJD for change in MCE filter parameters */
AstTimeFrame *tf=NULL; /* time frame for date conversion */
size_t i; /* Loop counter */
if( *status != SAI__OK ) return;
if( !filt ) {
*status = SAI__ERROR;
errRep( FUNC_NAME, "NULL smfFilter supplied.", status );
return;
}
if( filt->ndims != 1 ) {
*status = SAI__ERROR;
errRep( "", FUNC_NAME ": function only generates filters for time-series",
status );
return;
}
if( !filt->fdims[0] ) {
*status = SAI__ERROR;
errRep( "", FUNC_NAME ": 0-length smfFilter supplied.",
status );
return;
}
if( filt->dateobs == VAL__BADD ) {
*status = SAI__ERROR;
errRep( "", FUNC_NAME ": dateobs (date of data to which filter will be "
"applied) is not set - can't determine correct MCE filter "
"parameters.", status );
return;
}
/* If filt->real is NULL, create a complex identity filter first. Similarly,
if the filter is currently only real-valued, add an imaginary part. */
if( !filt->real ) {
smf_filter_ident( filt, 1, status );
if( *status != SAI__OK ) return;
} else if( !filt->imag ) {
filt->imag = astCalloc( filt->fdims[0], sizeof(*filt->imag) );
if( *status != SAI__OK ) return;
filt->isComplex = 1;
}
/* Set up filter parameters */
tf = astTimeFrame( " " );
astSet( tf, "TimeScale=UTC" );
astSet( tf, "TimeOrigin=%s", "2011-06-03T00:00:00" );
datechange = astGetD( tf, "TimeOrigin" );
tf = astAnnul( tf );
if( filt->dateobs > datechange ) {
/* Data taken after 20110603 */
B_1_1 = -1.9712524; /* -2.*32297./2.^15. */
B_1_2 = 0.97253418; /* 2.*15934./2.^15. */
B_2_1 = -1.9337769; /* -2.*31683./2.^15. */
B_2_2 = 0.93505859; /* 2.*15320./2.^15. */
ROW_DWELL = 94.; /* time to dwell at each row (in clocks) */
msgOutiff(MSG__DEBUG, "", FUNC_NAME
": filter for data UTC MJD %lf after %lf", status,
filt->dateobs, datechange );
} else {
/* Older data */
B_1_1 = -1.9587402; /* -2.*32092./2.^15. */
B_1_2 = 0.96130371; /* 2.*15750./2.^15. */
B_2_1 = -1.9066162; /* -2.*31238./2.^15. */
B_2_2 = 0.90911865; /* 2.*14895./2.^15. */
ROW_DWELL = 128.; /* time to dwell at each row (in clocks) */
msgOutiff(MSG__DEBUG, "", FUNC_NAME
": filter for data UTC MJD %lf before %lf", status,
filt->dateobs, datechange );
}
CLOCK_PERIOD = 20E-9; /* 50 MHz clock */
NUM_ROWS = 41.; /* number of rows addressed */
DELTA_TIME = (CLOCK_PERIOD*ROW_DWELL*NUM_ROWS); /* sample length */
SRATE = (1./DELTA_TIME); /* sample rate */
/* Loop over all frequencies in the filter */
for( i=0; i<filt->fdims[0]; i++ ) {
double cos_m_o;
double sin_m_o;
double cos_m_2o;
double sin_m_2o;
double f;
gsl_complex den;
gsl_complex h1_omega;
gsl_complex h2_omega;
gsl_complex h_omega;
gsl_complex num;
gsl_complex temp;
double omega;
f = filt->df[0]*i; /* Frequency at this step */
omega = (f / SRATE)*2*AST__DPI; /* Angular frequency */
cos_m_o = cos(-omega);
sin_m_o = sin(-omega);
cos_m_2o = cos(-2*omega);
sin_m_2o = sin(-2*omega);
/*
h1_omega=(1 + 2*complex(cos_m_o,sin_m_o) + complex(cos_m_2o,sin_m_2o)) /
(1 + b_1_1*complex(cos_m_o,sin_m_o) + b_1_2 * complex(cos_m_2o,sin_m_2o))
*/
/* numerator */
GSL_SET_COMPLEX(&num, 1, 0);
GSL_SET_COMPLEX(&temp, cos_m_o, sin_m_o);
num = gsl_complex_add( num, gsl_complex_mul_real(temp, 2) );
GSL_SET_COMPLEX(&temp, cos_m_2o, sin_m_2o);
num = gsl_complex_add( num, temp );
/* denominator */
GSL_SET_COMPLEX(&den, 1, 0);
GSL_SET_COMPLEX(&temp, cos_m_o, sin_m_o);
den = gsl_complex_add( den, gsl_complex_mul_real(temp,B_1_1) );
GSL_SET_COMPLEX(&temp, cos_m_2o, sin_m_2o);
den = gsl_complex_add( den, gsl_complex_mul_real(temp,B_1_2) );
/* quotient */
h1_omega = gsl_complex_div( num, den );
/*
h2_omega=(1 + 2*complex(cos_m_o,sin_m_o) + complex(cos_m_2o,sin_m_2o)) /
(1 + b_2_1*complex(cos_m_o,sin_m_o) + b_2_2*complex(cos_m_2o,sin_m_2o))
note: we can re-use numerator from above
*/
/* denominator */
GSL_SET_COMPLEX(&den, 1, 0);
GSL_SET_COMPLEX(&temp, cos_m_o, sin_m_o);
den = gsl_complex_add( den, gsl_complex_mul_real(temp,B_2_1) );
GSL_SET_COMPLEX(&temp, cos_m_2o, sin_m_2o);
den = gsl_complex_add( den, gsl_complex_mul_real(temp,B_2_2) );
/* quotient */
h2_omega = gsl_complex_div( num, den );
/* And finally...
h_omega=h1_omega*h2_omega/2048.
*/
h_omega = gsl_complex_mul( h1_omega, gsl_complex_div_real(h2_omega,2048.) );
/* Normally we are applying the inverse of the filter to remove
its effect from the time-series. */
if( !noinverse ) {
h_omega = gsl_complex_inverse( h_omega );
}
/* Then apply this factor to the filter. */
GSL_SET_COMPLEX( &temp, filt->real[i], filt->imag[i] );
temp = gsl_complex_mul( temp, h_omega );
filt->real[i] = GSL_REAL( temp );
filt->imag[i] = GSL_IMAG( temp );
}
}
int
gsl_linalg_complex_cholesky_invert(gsl_matrix_complex * LLT)
{
if (LLT->size1 != LLT->size2)
{
GSL_ERROR ("cholesky matrix must be square", GSL_ENOTSQR);
}
else
{
size_t N = LLT->size1;
size_t i, j;
gsl_vector_complex_view v1;
/* invert the lower triangle of LLT */
for (i = 0; i < N; ++i)
{
double ajj;
gsl_complex z;
j = N - i - 1;
{
gsl_complex z0 = gsl_matrix_complex_get(LLT, j, j);
ajj = 1.0 / GSL_REAL(z0);
}
GSL_SET_COMPLEX(&z, ajj, 0.0);
gsl_matrix_complex_set(LLT, j, j, z);
{
gsl_complex z1 = gsl_matrix_complex_get(LLT, j, j);
ajj = -GSL_REAL(z1);
}
if (j < N - 1)
{
gsl_matrix_complex_view m;
m = gsl_matrix_complex_submatrix(LLT, j + 1, j + 1,
N - j - 1, N - j - 1);
v1 = gsl_matrix_complex_subcolumn(LLT, j, j + 1, N - j - 1);
gsl_blas_ztrmv(CblasLower, CblasNoTrans, CblasNonUnit,
&m.matrix, &v1.vector);
gsl_blas_zdscal(ajj, &v1.vector);
}
} /* for (i = 0; i < N; ++i) */
/*
* The lower triangle of LLT now contains L^{-1}. Now compute
* A^{-1} = L^{-H} L^{-1}
*
* The (ij) element of A^{-1} is column i of conj(L^{-1}) dotted into
* column j of L^{-1}
*/
for (i = 0; i < N; ++i)
{
gsl_complex sum;
for (j = i + 1; j < N; ++j)
{
gsl_vector_complex_view v2;
v1 = gsl_matrix_complex_subcolumn(LLT, i, j, N - j);
v2 = gsl_matrix_complex_subcolumn(LLT, j, j, N - j);
/* compute Ainv[i,j] = sum_k{conj(Linv[k,i]) * Linv[k,j]} */
gsl_blas_zdotc(&v1.vector, &v2.vector, &sum);
/* store in upper triangle */
gsl_matrix_complex_set(LLT, i, j, sum);
}
/* now compute the diagonal element */
v1 = gsl_matrix_complex_subcolumn(LLT, i, i, N - i);
gsl_blas_zdotc(&v1.vector, &v1.vector, &sum);
gsl_matrix_complex_set(LLT, i, i, sum);
}
/* copy the Hermitian upper triangle to the lower triangle */
for (j = 1; j < N; j++)
{
for (i = 0; i < j; i++)
{
gsl_complex z = gsl_matrix_complex_get(LLT, i, j);
gsl_matrix_complex_set(LLT, j, i, gsl_complex_conjugate(z));
}
}
return GSL_SUCCESS;
}
} /* gsl_linalg_complex_cholesky_invert() */
int main(int argc, char **argv)
{
Params params;
params.m = 1;
params.r = 2;
params.Pr = 60;
params.Pi = 60;
params.peps = 0.2;
params.t = 0.0;
params.smear = 0;
params.sigma = 0.0;
const char* opt_prefix = "";
int opt_select = OPT_SELECT_INTEGRAL;
int opt_contour = OPT_CONTOUR_M;
gsl_complex opt_z0 = { { 0.0 } };
gsl_complex opt_z1 = { { 0.0 } };
int opt_n = 10000;
const char* const short_options = "";
const struct option long_options[] = {
{ "help", 0, NULL, 'h' },
{ "envelope", 0, &opt_select, OPT_SELECT_ENVELOPE },
{ "integrand", 0, &opt_select, OPT_SELECT_INTEGRAND },
{ "bessel", 0, &opt_select, OPT_SELECT_BESSEL },
{ "contour-II", 0, &opt_contour, OPT_CONTOUR_II },
{ "contour-IUI", 0, &opt_contour, OPT_CONTOUR_IUI },
{ "d", 1, NULL, 'd' },
{ "n", 1, NULL, 'n' },
{ "m", 1, NULL, 'm' },
{ "prefix", 1, NULL, 'p' },
{ "r", 1, NULL, 'r' },
{ "t", 1, NULL, 't' },
{ "z0", 1, NULL, '0' },
{ "z1", 1, NULL, '1' },
{ "Pr", 1, NULL, 'P' },
{ "Pi", 1, NULL, 'I' },
{ "smear", 1, NULL, 's' },
{ NULL, 0, NULL, 0 } /* end */
};
int next_option;
do {
next_option = getopt_long(argc, argv, short_options,
long_options, NULL);
switch (next_option)
{
case 'h':
print_usage(stdout, 0);
case 'd':
parse_double(optarg, ¶ms.d);
break;
case 'm':
parse_double(optarg, ¶ms.m);
break;
case 'n':
opt_n = atoi(optarg);
if (opt_n < 1)
opt_n = 1;
break;
case 'p':
opt_prefix = optarg;
break;
case 'r':
parse_double(optarg, ¶ms.r);
break;
case 's':
parse_double(optarg, ¶ms.sigma);
params.smear = 1;
break;
case 't':
parse_double(optarg, ¶ms.t);
break;
case '?':
// invalid option
print_usage(stderr, 1);
case '0':
parse_complex(optarg, &opt_z0);
break;
case '1':
parse_complex(optarg, &opt_z1);
break;
case 'P':
parse_double(optarg, ¶ms.Pr);
break;
case 'I':
parse_double(optarg, ¶ms.Pi);
break;
case 0: break; // flag handled
case -1: break; // end of options
default:
abort();
}
}
while (next_option != -1);
PlotContext ctx;
memset(&ctx, 0, sizeof(ctx));
ctx.filename_contour = alloc_sprintf("%sCONTOUR.dat", opt_prefix);
ctx.filename_data = alloc_sprintf("%sFUNCTION.dat", opt_prefix);
if (opt_select != OPT_SELECT_INTEGRAL)
{
FILE *os = fopen(ctx.filename_data, "w");
ComplexFunction func;
switch (opt_select)
{
case OPT_SELECT_ENVELOPE : func = (ComplexFunction) &f_envelope; break;
case OPT_SELECT_INTEGRAND: func = (ComplexFunction) &f_integrand; break;
case OPT_SELECT_BESSEL : func = (ComplexFunction) &f_bessel; break;
default: abort();
}
tabulate(os, func, ¶ms, opt_z0, opt_z1, opt_n);
fclose(os);
Contour contour;
define_contour_line_segment(opt_z0, opt_z1, &contour);
os = fopen(ctx.filename_contour, "w");
emit_contour_points(¶ms, &contour, os);
fclose(os);
}
else
{
Contour contour;
switch (opt_contour)
{
case OPT_CONTOUR_II:
define_contour_II(¶ms, params.d, &contour);
break;
case OPT_CONTOUR_IUI:
define_contour_M(¶ms, params.d, 1, &contour);
break;
case OPT_CONTOUR_M:
define_contour_M(¶ms, params.d, 0, &contour);
break;
default: abort();
}
FILE *os = fopen(ctx.filename_data, "w");
tabulate_integral(
¶ms,
&contour,
GSL_REAL(opt_z0), GSL_REAL(opt_z1),
opt_n, os);
fclose(os);
os = fopen(ctx.filename_contour, "w");
emit_contour_points(¶ms, &contour, os);
fclose(os);
}
return 0;
}
int
gsl_linalg_complex_cholesky_decomp(gsl_matrix_complex *A)
{
const size_t N = A->size1;
if (N != A->size2)
{
GSL_ERROR("cholesky decomposition requires square matrix", GSL_ENOTSQR);
}
else
{
size_t i, j;
gsl_complex z;
double ajj;
for (j = 0; j < N; ++j)
{
z = gsl_matrix_complex_get(A, j, j);
ajj = GSL_REAL(z);
if (j > 0)
{
gsl_vector_complex_const_view aj =
gsl_matrix_complex_const_subrow(A, j, 0, j);
gsl_blas_zdotc(&aj.vector, &aj.vector, &z);
ajj -= GSL_REAL(z);
}
if (ajj <= 0.0)
{
GSL_ERROR("matrix is not positive definite", GSL_EDOM);
}
ajj = sqrt(ajj);
GSL_SET_COMPLEX(&z, ajj, 0.0);
gsl_matrix_complex_set(A, j, j, z);
if (j < N - 1)
{
gsl_vector_complex_view av =
gsl_matrix_complex_subcolumn(A, j, j + 1, N - j - 1);
if (j > 0)
{
gsl_vector_complex_view aj =
gsl_matrix_complex_subrow(A, j, 0, j);
gsl_matrix_complex_view am =
gsl_matrix_complex_submatrix(A, j + 1, 0, N - j - 1, j);
cholesky_complex_conj_vector(&aj.vector);
gsl_blas_zgemv(CblasNoTrans,
GSL_COMPLEX_NEGONE,
&am.matrix,
&aj.vector,
GSL_COMPLEX_ONE,
&av.vector);
cholesky_complex_conj_vector(&aj.vector);
}
gsl_blas_zdscal(1.0 / ajj, &av.vector);
}
}
/* Now store L^H in upper triangle */
for (i = 1; i < N; ++i)
{
for (j = 0; j < i; ++j)
{
z = gsl_matrix_complex_get(A, i, j);
gsl_matrix_complex_set(A, j, i, gsl_complex_conjugate(z));
}
}
return GSL_SUCCESS;
}
} /* gsl_linalg_complex_cholesky_decomp() */
gsl_complex
gsl_complex_arccos (gsl_complex a)
{ /* z = arccos(a) */
double R = GSL_REAL (a), I = GSL_IMAG (a);
gsl_complex z;
if (I == 0)
{
z = gsl_complex_arccos_real (R);
}
else
{
double x = fabs (R), y = fabs (I);
double r = hypot (x + 1, y), s = hypot (x - 1, y);
double A = 0.5 * (r + s);
double B = x / A;
double y2 = y * y;
double real, imag;
const double A_crossover = 1.5, B_crossover = 0.6417;
if (B <= B_crossover)
{
real = acos (B);
}
else
{
if (x <= 1)
{
double D = 0.5 * (A + x) * (y2 / (r + x + 1) + (s + (1 - x)));
real = atan (sqrt (D) / x);
}
else
{
double Apx = A + x;
double D = 0.5 * (Apx / (r + x + 1) + Apx / (s + (x - 1)));
real = atan ((y * sqrt (D)) / x);
}
}
if (A <= A_crossover)
{
double Am1;
if (x < 1)
{
Am1 = 0.5 * (y2 / (r + (x + 1)) + y2 / (s + (1 - x)));
}
else
{
Am1 = 0.5 * (y2 / (r + (x + 1)) + (s + (x - 1)));
}
imag = log1p (Am1 + sqrt (Am1 * (A + 1)));
}
else
{
imag = log (A + sqrt (A * A - 1));
}
GSL_SET_COMPLEX (&z, (R >= 0) ? real : M_PI - real, (I >= 0) ? -imag : imag);
}
return z;
}
const double& complex::real() const
{
return GSL_REAL(_complex);
}
double
gsl_complex_arg (gsl_complex z)
{ /* return arg(z), -pi < arg(z) <= +pi */
return atan2 (GSL_IMAG (z), GSL_REAL (z));
}
void
test_eigen_gen_results (const gsl_matrix * A, const gsl_matrix * B,
const gsl_vector_complex * alpha,
const gsl_vector * beta,
const gsl_matrix_complex * evec,
size_t count, const char * desc,
const char * desc2)
{
const size_t N = A->size1;
size_t i, j;
gsl_matrix_complex *ma, *mb;
gsl_vector_complex *x, *y;
gsl_complex z_one, z_zero;
ma = gsl_matrix_complex_alloc(N, N);
mb = gsl_matrix_complex_alloc(N, N);
y = gsl_vector_complex_alloc(N);
x = gsl_vector_complex_alloc(N);
/* ma <- A, mb <- B */
for (i = 0; i < N; ++i)
{
for (j = 0; j < N; ++j)
{
gsl_complex z;
GSL_SET_COMPLEX(&z, gsl_matrix_get(A, i, j), 0.0);
gsl_matrix_complex_set(ma, i, j, z);
GSL_SET_COMPLEX(&z, gsl_matrix_get(B, i, j), 0.0);
gsl_matrix_complex_set(mb, i, j, z);
}
}
GSL_SET_COMPLEX(&z_one, 1.0, 0.0);
GSL_SET_COMPLEX(&z_zero, 0.0, 0.0);
/* check eigenvalues */
for (i = 0; i < N; ++i)
{
gsl_vector_complex_const_view vi =
gsl_matrix_complex_const_column(evec, i);
gsl_complex ai = gsl_vector_complex_get(alpha, i);
double bi = gsl_vector_get(beta, i);
/* compute x = alpha * B * v */
gsl_blas_zgemv(CblasNoTrans, z_one, mb, &vi.vector, z_zero, x);
gsl_blas_zscal(ai, x);
/* compute y = beta * A v */
gsl_blas_zgemv(CblasNoTrans, z_one, ma, &vi.vector, z_zero, y);
gsl_blas_zdscal(bi, y);
/* now test if y = x */
for (j = 0; j < N; ++j)
{
gsl_complex xj = gsl_vector_complex_get(x, j);
gsl_complex yj = gsl_vector_complex_get(y, j);
gsl_test_abs(GSL_REAL(yj), GSL_REAL(xj), 1e8*GSL_DBL_EPSILON,
"gen(N=%u,cnt=%u), %s, eigenvalue(%d,%d), real, %s",
N, count, desc, i, j, desc2);
gsl_test_abs(GSL_IMAG(yj), GSL_IMAG(xj), 1e8*GSL_DBL_EPSILON,
"gen(N=%u,cnt=%u), %s, eigenvalue(%d,%d), real, %s",
N, count, desc, i, j, desc2);
}
}
gsl_matrix_complex_free(ma);
gsl_matrix_complex_free(mb);
gsl_vector_complex_free(y);
gsl_vector_complex_free(x);
} /* test_eigen_gen_results() */
double
gsl_complex_abs (gsl_complex z)
{ /* return |z| */
return hypot (GSL_REAL (z), GSL_IMAG (z));
}
void
test_eigen_herm_results (const gsl_matrix_complex * A,
const gsl_vector * eval,
const gsl_matrix_complex * evec,
size_t count,
const char * desc,
const char * desc2)
{
const size_t N = A->size1;
size_t i, j;
gsl_vector_complex * x = gsl_vector_complex_alloc(N);
gsl_vector_complex * y = gsl_vector_complex_alloc(N);
/* check eigenvalues */
for (i = 0; i < N; i++)
{
double ei = gsl_vector_get (eval, i);
gsl_vector_complex_const_view vi =
gsl_matrix_complex_const_column(evec, i);
gsl_vector_complex_memcpy(x, &vi.vector);
/* compute y = m x (should = lambda v) */
gsl_blas_zgemv (CblasNoTrans, GSL_COMPLEX_ONE, A, x,
GSL_COMPLEX_ZERO, y);
for (j = 0; j < N; j++)
{
gsl_complex xj = gsl_vector_complex_get (x, j);
gsl_complex yj = gsl_vector_complex_get (y, j);
gsl_test_rel(GSL_REAL(yj), ei * GSL_REAL(xj), 1e8*GSL_DBL_EPSILON,
"%s, eigenvalue(%d,%d), real, %s", desc, i, j, desc2);
gsl_test_rel(GSL_IMAG(yj), ei * GSL_IMAG(xj), 1e8*GSL_DBL_EPSILON,
"%s, eigenvalue(%d,%d), imag, %s", desc, i, j, desc2);
}
}
/* check eigenvectors are orthonormal */
for (i = 0; i < N; i++)
{
gsl_vector_complex_const_view vi = gsl_matrix_complex_const_column(evec, i);
double nrm_v = gsl_blas_dznrm2(&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_complex_const_view vi = gsl_matrix_complex_const_column(evec, i);
for (j = i + 1; j < N; j++)
{
gsl_vector_complex_const_view vj
= gsl_matrix_complex_const_column(evec, j);
gsl_complex vivj;
gsl_blas_zdotc (&vi.vector, &vj.vector, &vivj);
gsl_test_abs (gsl_complex_abs(vivj), 0.0, 10.0 * N * GSL_DBL_EPSILON,
"%s, orthogonal(%d,%d), %s", desc, i, j, desc2);
}
}
gsl_vector_complex_free(x);
gsl_vector_complex_free(y);
} /* test_eigen_herm_results() */
int
gsl_eigen_genv_sort (gsl_vector_complex * alpha, gsl_vector * beta,
gsl_matrix_complex * evec, gsl_eigen_sort_t sort_type)
{
if (evec->size1 != evec->size2)
{
GSL_ERROR ("eigenvector matrix must be square", GSL_ENOTSQR);
}
else if (alpha->size != evec->size1 || beta->size != evec->size1)
{
GSL_ERROR ("eigenvalues must match eigenvector matrix", GSL_EBADLEN);
}
else
{
const size_t N = alpha->size;
size_t i;
for (i = 0; i < N - 1; i++)
{
size_t j;
size_t k = i;
gsl_complex ak = gsl_vector_complex_get (alpha, i);
double bk = gsl_vector_get(beta, i);
gsl_complex ek;
if (bk < GSL_DBL_EPSILON)
{
GSL_SET_COMPLEX(&ek,
GSL_SIGN(GSL_REAL(ak)) ? GSL_POSINF : GSL_NEGINF,
GSL_SIGN(GSL_IMAG(ak)) ? GSL_POSINF : GSL_NEGINF);
}
else
ek = gsl_complex_div_real(ak, bk);
/* search for something to swap */
for (j = i + 1; j < N; j++)
{
int test;
const gsl_complex aj = gsl_vector_complex_get (alpha, j);
double bj = gsl_vector_get(beta, j);
gsl_complex ej;
if (bj < GSL_DBL_EPSILON)
{
GSL_SET_COMPLEX(&ej,
GSL_SIGN(GSL_REAL(aj)) ? GSL_POSINF : GSL_NEGINF,
GSL_SIGN(GSL_IMAG(aj)) ? GSL_POSINF : GSL_NEGINF);
}
else
ej = gsl_complex_div_real(aj, bj);
switch (sort_type)
{
case GSL_EIGEN_SORT_ABS_ASC:
test = (gsl_complex_abs (ej) < gsl_complex_abs (ek));
break;
case GSL_EIGEN_SORT_ABS_DESC:
test = (gsl_complex_abs (ej) > gsl_complex_abs (ek));
break;
case GSL_EIGEN_SORT_VAL_ASC:
case GSL_EIGEN_SORT_VAL_DESC:
default:
GSL_ERROR ("invalid sort type", GSL_EINVAL);
}
if (test)
{
k = j;
ek = ej;
}
}
if (k != i)
{
/* swap eigenvalues */
gsl_vector_complex_swap_elements (alpha, i, k);
gsl_vector_swap_elements (beta, i, k);
/* swap eigenvectors */
gsl_matrix_complex_swap_columns (evec, i, k);
}
}
return GSL_SUCCESS;
}
}
static void
nonsymmv_get_right_eigenvectors(gsl_matrix *T, gsl_matrix *Z,
gsl_vector_complex *eval,
gsl_matrix_complex *evec,
gsl_eigen_nonsymmv_workspace *w)
{
const size_t N = T->size1;
const double smlnum = GSL_DBL_MIN * N / GSL_DBL_EPSILON;
const double bignum = (1.0 - GSL_DBL_EPSILON) / smlnum;
int i; /* looping */
size_t iu, /* looping */
ju,
ii;
gsl_complex lambda; /* current eigenvalue */
double lambda_re, /* Re(lambda) */
lambda_im; /* Im(lambda) */
gsl_matrix_view Tv, /* temporary views */
Zv;
gsl_vector_view y, /* temporary views */
y2,
ev,
ev2;
double dat[4], /* scratch arrays */
dat_X[4];
double scale; /* scale factor */
double xnorm; /* |X| */
gsl_vector_complex_view ecol, /* column of evec */
ecol2;
int complex_pair; /* complex eigenvalue pair? */
double smin;
/*
* Compute 1-norm of each column of upper triangular part of T
* to control overflow in triangular solver
*/
gsl_vector_set(w->work3, 0, 0.0);
for (ju = 1; ju < N; ++ju)
{
gsl_vector_set(w->work3, ju, 0.0);
for (iu = 0; iu < ju; ++iu)
{
gsl_vector_set(w->work3, ju,
gsl_vector_get(w->work3, ju) +
fabs(gsl_matrix_get(T, iu, ju)));
}
}
for (i = (int) N - 1; i >= 0; --i)
{
iu = (size_t) i;
/* get current eigenvalue and store it in lambda */
lambda_re = gsl_matrix_get(T, iu, iu);
if (iu != 0 && gsl_matrix_get(T, iu, iu - 1) != 0.0)
{
lambda_im = sqrt(fabs(gsl_matrix_get(T, iu, iu - 1))) *
sqrt(fabs(gsl_matrix_get(T, iu - 1, iu)));
}
else
{
lambda_im = 0.0;
}
GSL_SET_COMPLEX(&lambda, lambda_re, lambda_im);
smin = GSL_MAX(GSL_DBL_EPSILON * (fabs(lambda_re) + fabs(lambda_im)),
smlnum);
smin = GSL_MAX(smin, GSL_NONSYMMV_SMLNUM);
if (lambda_im == 0.0)
{
int k, l;
gsl_vector_view bv, xv;
/* real eigenvector */
/*
* The ordering of eigenvalues in 'eval' is arbitrary and
* does not necessarily follow the Schur form T, so store
* lambda in the right slot in eval to ensure it corresponds
* to the eigenvector we are about to compute
*/
gsl_vector_complex_set(eval, iu, lambda);
/*
* We need to solve the system:
*
* (T(1:iu-1, 1:iu-1) - lambda*I)*X = -T(1:iu-1,iu)
*/
/* construct right hand side */
for (k = 0; k < i; ++k)
{
gsl_vector_set(w->work,
(size_t) k,
-gsl_matrix_get(T, (size_t) k, iu));
}
gsl_vector_set(w->work, iu, 1.0);
for (l = i - 1; l >= 0; --l)
{
size_t lu = (size_t) l;
if (lu == 0)
complex_pair = 0;
else
complex_pair = gsl_matrix_get(T, lu, lu - 1) != 0.0;
if (!complex_pair)
{
double x;
/*
* 1-by-1 diagonal block - solve the system:
*
* (T_{ll} - lambda)*x = -T_{l(iu)}
*/
Tv = gsl_matrix_submatrix(T, lu, lu, 1, 1);
bv = gsl_vector_view_array(dat, 1);
gsl_vector_set(&bv.vector, 0,
gsl_vector_get(w->work, lu));
xv = gsl_vector_view_array(dat_X, 1);
gsl_schur_solve_equation(1.0,
&Tv.matrix,
lambda_re,
1.0,
1.0,
&bv.vector,
&xv.vector,
&scale,
&xnorm,
smin);
/* scale x to avoid overflow */
x = gsl_vector_get(&xv.vector, 0);
if (xnorm > 1.0)
{
if (gsl_vector_get(w->work3, lu) > bignum / xnorm)
{
x /= xnorm;
scale /= xnorm;
}
}
if (scale != 1.0)
{
gsl_vector_view wv;
wv = gsl_vector_subvector(w->work, 0, iu + 1);
gsl_blas_dscal(scale, &wv.vector);
}
gsl_vector_set(w->work, lu, x);
if (lu > 0)
{
gsl_vector_view v1, v2;
/* update right hand side */
v1 = gsl_matrix_subcolumn(T, lu, 0, lu);
v2 = gsl_vector_subvector(w->work, 0, lu);
gsl_blas_daxpy(-x, &v1.vector, &v2.vector);
} /* if (l > 0) */
} /* if (!complex_pair) */
else
{
double x11, x21;
/*
* 2-by-2 diagonal block
*/
Tv = gsl_matrix_submatrix(T, lu - 1, lu - 1, 2, 2);
bv = gsl_vector_view_array(dat, 2);
gsl_vector_set(&bv.vector, 0,
gsl_vector_get(w->work, lu - 1));
gsl_vector_set(&bv.vector, 1,
gsl_vector_get(w->work, lu));
xv = gsl_vector_view_array(dat_X, 2);
gsl_schur_solve_equation(1.0,
&Tv.matrix,
lambda_re,
1.0,
1.0,
&bv.vector,
&xv.vector,
&scale,
&xnorm,
smin);
/* scale X(1,1) and X(2,1) to avoid overflow */
x11 = gsl_vector_get(&xv.vector, 0);
x21 = gsl_vector_get(&xv.vector, 1);
if (xnorm > 1.0)
{
double beta;
beta = GSL_MAX(gsl_vector_get(w->work3, lu - 1),
gsl_vector_get(w->work3, lu));
if (beta > bignum / xnorm)
{
x11 /= xnorm;
x21 /= xnorm;
scale /= xnorm;
}
}
/* scale if necessary */
if (scale != 1.0)
{
gsl_vector_view wv;
wv = gsl_vector_subvector(w->work, 0, iu + 1);
gsl_blas_dscal(scale, &wv.vector);
}
gsl_vector_set(w->work, lu - 1, x11);
gsl_vector_set(w->work, lu, x21);
/* update right hand side */
if (lu > 1)
{
gsl_vector_view v1, v2;
v1 = gsl_matrix_subcolumn(T, lu - 1, 0, lu - 1);
v2 = gsl_vector_subvector(w->work, 0, lu - 1);
gsl_blas_daxpy(-x11, &v1.vector, &v2.vector);
v1 = gsl_matrix_subcolumn(T, lu, 0, lu - 1);
gsl_blas_daxpy(-x21, &v1.vector, &v2.vector);
}
--l;
} /* if (complex_pair) */
} /* for (l = i - 1; l >= 0; --l) */
/*
* At this point, w->work is an eigenvector of the
* Schur form T. To get an eigenvector of the original
* matrix, we multiply on the left by Z, the matrix of
* Schur vectors
*/
ecol = gsl_matrix_complex_column(evec, iu);
y = gsl_matrix_column(Z, iu);
if (iu > 0)
{
gsl_vector_view x;
Zv = gsl_matrix_submatrix(Z, 0, 0, N, iu);
x = gsl_vector_subvector(w->work, 0, iu);
/* compute Z * w->work and store it in Z(:,iu) */
gsl_blas_dgemv(CblasNoTrans,
1.0,
&Zv.matrix,
&x.vector,
gsl_vector_get(w->work, iu),
&y.vector);
} /* if (iu > 0) */
/* store eigenvector into evec */
ev = gsl_vector_complex_real(&ecol.vector);
ev2 = gsl_vector_complex_imag(&ecol.vector);
scale = 0.0;
for (ii = 0; ii < N; ++ii)
{
double a = gsl_vector_get(&y.vector, ii);
/* store real part of eigenvector */
gsl_vector_set(&ev.vector, ii, a);
/* set imaginary part to 0 */
gsl_vector_set(&ev2.vector, ii, 0.0);
if (fabs(a) > scale)
scale = fabs(a);
}
if (scale != 0.0)
scale = 1.0 / scale;
/* scale by magnitude of largest element */
gsl_blas_dscal(scale, &ev.vector);
} /* if (GSL_IMAG(lambda) == 0.0) */
else
{
gsl_vector_complex_view bv, xv;
size_t k;
int l;
gsl_complex lambda2;
/* complex eigenvector */
/*
* Store the complex conjugate eigenvalues in the right
* slots in eval
*/
GSL_SET_REAL(&lambda2, GSL_REAL(lambda));
GSL_SET_IMAG(&lambda2, -GSL_IMAG(lambda));
gsl_vector_complex_set(eval, iu - 1, lambda);
gsl_vector_complex_set(eval, iu, lambda2);
/*
* First solve:
*
* [ T(i:i+1,i:i+1) - lambda*I ] * X = 0
*/
if (fabs(gsl_matrix_get(T, iu - 1, iu)) >=
fabs(gsl_matrix_get(T, iu, iu - 1)))
{
gsl_vector_set(w->work, iu - 1, 1.0);
gsl_vector_set(w->work2, iu,
lambda_im / gsl_matrix_get(T, iu - 1, iu));
}
else
{
gsl_vector_set(w->work, iu - 1,
-lambda_im / gsl_matrix_get(T, iu, iu - 1));
gsl_vector_set(w->work2, iu, 1.0);
}
gsl_vector_set(w->work, iu, 0.0);
gsl_vector_set(w->work2, iu - 1, 0.0);
/* construct right hand side */
for (k = 0; k < iu - 1; ++k)
{
gsl_vector_set(w->work, k,
-gsl_vector_get(w->work, iu - 1) *
gsl_matrix_get(T, k, iu - 1));
gsl_vector_set(w->work2, k,
-gsl_vector_get(w->work2, iu) *
gsl_matrix_get(T, k, iu));
}
/*
* We must solve the upper quasi-triangular system:
*
* [ T(1:i-2,1:i-2) - lambda*I ] * X = s*(work + i*work2)
*/
for (l = i - 2; l >= 0; --l)
{
size_t lu = (size_t) l;
if (lu == 0)
complex_pair = 0;
else
complex_pair = gsl_matrix_get(T, lu, lu - 1) != 0.0;
if (!complex_pair)
{
gsl_complex bval;
gsl_complex x;
/*
* 1-by-1 diagonal block - solve the system:
*
* (T_{ll} - lambda)*x = work + i*work2
*/
Tv = gsl_matrix_submatrix(T, lu, lu, 1, 1);
bv = gsl_vector_complex_view_array(dat, 1);
xv = gsl_vector_complex_view_array(dat_X, 1);
GSL_SET_COMPLEX(&bval,
gsl_vector_get(w->work, lu),
gsl_vector_get(w->work2, lu));
gsl_vector_complex_set(&bv.vector, 0, bval);
gsl_schur_solve_equation_z(1.0,
&Tv.matrix,
&lambda,
1.0,
1.0,
&bv.vector,
&xv.vector,
&scale,
&xnorm,
smin);
if (xnorm > 1.0)
{
if (gsl_vector_get(w->work3, lu) > bignum / xnorm)
{
gsl_blas_zdscal(1.0/xnorm, &xv.vector);
scale /= xnorm;
}
}
/* scale if necessary */
if (scale != 1.0)
{
gsl_vector_view wv;
wv = gsl_vector_subvector(w->work, 0, iu + 1);
gsl_blas_dscal(scale, &wv.vector);
wv = gsl_vector_subvector(w->work2, 0, iu + 1);
gsl_blas_dscal(scale, &wv.vector);
}
x = gsl_vector_complex_get(&xv.vector, 0);
gsl_vector_set(w->work, lu, GSL_REAL(x));
gsl_vector_set(w->work2, lu, GSL_IMAG(x));
/* update the right hand side */
if (lu > 0)
{
gsl_vector_view v1, v2;
v1 = gsl_matrix_subcolumn(T, lu, 0, lu);
v2 = gsl_vector_subvector(w->work, 0, lu);
gsl_blas_daxpy(-GSL_REAL(x), &v1.vector, &v2.vector);
v2 = gsl_vector_subvector(w->work2, 0, lu);
gsl_blas_daxpy(-GSL_IMAG(x), &v1.vector, &v2.vector);
} /* if (lu > 0) */
} /* if (!complex_pair) */
else
{
gsl_complex b1, b2, x1, x2;
/*
* 2-by-2 diagonal block - solve the system
*/
Tv = gsl_matrix_submatrix(T, lu - 1, lu - 1, 2, 2);
bv = gsl_vector_complex_view_array(dat, 2);
xv = gsl_vector_complex_view_array(dat_X, 2);
GSL_SET_COMPLEX(&b1,
gsl_vector_get(w->work, lu - 1),
gsl_vector_get(w->work2, lu - 1));
GSL_SET_COMPLEX(&b2,
gsl_vector_get(w->work, lu),
gsl_vector_get(w->work2, lu));
gsl_vector_complex_set(&bv.vector, 0, b1);
gsl_vector_complex_set(&bv.vector, 1, b2);
gsl_schur_solve_equation_z(1.0,
&Tv.matrix,
&lambda,
1.0,
1.0,
&bv.vector,
&xv.vector,
&scale,
&xnorm,
smin);
x1 = gsl_vector_complex_get(&xv.vector, 0);
x2 = gsl_vector_complex_get(&xv.vector, 1);
if (xnorm > 1.0)
{
double beta;
beta = GSL_MAX(gsl_vector_get(w->work3, lu - 1),
gsl_vector_get(w->work3, lu));
if (beta > bignum / xnorm)
{
gsl_blas_zdscal(1.0/xnorm, &xv.vector);
scale /= xnorm;
}
}
/* scale if necessary */
if (scale != 1.0)
{
gsl_vector_view wv;
wv = gsl_vector_subvector(w->work, 0, iu + 1);
gsl_blas_dscal(scale, &wv.vector);
wv = gsl_vector_subvector(w->work2, 0, iu + 1);
gsl_blas_dscal(scale, &wv.vector);
}
gsl_vector_set(w->work, lu - 1, GSL_REAL(x1));
gsl_vector_set(w->work, lu, GSL_REAL(x2));
gsl_vector_set(w->work2, lu - 1, GSL_IMAG(x1));
gsl_vector_set(w->work2, lu, GSL_IMAG(x2));
/* update right hand side */
if (lu > 1)
{
gsl_vector_view v1, v2, v3, v4;
v1 = gsl_matrix_subcolumn(T, lu - 1, 0, lu - 1);
v4 = gsl_matrix_subcolumn(T, lu, 0, lu - 1);
v2 = gsl_vector_subvector(w->work, 0, lu - 1);
v3 = gsl_vector_subvector(w->work2, 0, lu - 1);
gsl_blas_daxpy(-GSL_REAL(x1), &v1.vector, &v2.vector);
gsl_blas_daxpy(-GSL_REAL(x2), &v4.vector, &v2.vector);
gsl_blas_daxpy(-GSL_IMAG(x1), &v1.vector, &v3.vector);
gsl_blas_daxpy(-GSL_IMAG(x2), &v4.vector, &v3.vector);
} /* if (lu > 1) */
--l;
} /* if (complex_pair) */
} /* for (l = i - 2; l >= 0; --l) */
/*
* At this point, work + i*work2 is an eigenvector
* of T - backtransform to get an eigenvector of the
* original matrix
*/
y = gsl_matrix_column(Z, iu - 1);
y2 = gsl_matrix_column(Z, iu);
if (iu > 1)
{
gsl_vector_view x;
/* compute real part of eigenvectors */
Zv = gsl_matrix_submatrix(Z, 0, 0, N, iu - 1);
x = gsl_vector_subvector(w->work, 0, iu - 1);
gsl_blas_dgemv(CblasNoTrans,
1.0,
&Zv.matrix,
&x.vector,
gsl_vector_get(w->work, iu - 1),
&y.vector);
/* now compute the imaginary part */
x = gsl_vector_subvector(w->work2, 0, iu - 1);
gsl_blas_dgemv(CblasNoTrans,
1.0,
&Zv.matrix,
&x.vector,
gsl_vector_get(w->work2, iu),
&y2.vector);
}
else
{
gsl_blas_dscal(gsl_vector_get(w->work, iu - 1), &y.vector);
gsl_blas_dscal(gsl_vector_get(w->work2, iu), &y2.vector);
}
/*
* Now store the eigenvectors into evec - the real parts
* are Z(:,iu - 1) and the imaginary parts are
* +/- Z(:,iu)
*/
/* get views of the two eigenvector slots */
ecol = gsl_matrix_complex_column(evec, iu - 1);
ecol2 = gsl_matrix_complex_column(evec, iu);
/*
* save imaginary part first as it may get overwritten
* when copying the real part due to our storage scheme
* in Z/evec
*/
ev = gsl_vector_complex_imag(&ecol.vector);
ev2 = gsl_vector_complex_imag(&ecol2.vector);
scale = 0.0;
for (ii = 0; ii < N; ++ii)
{
double a = gsl_vector_get(&y2.vector, ii);
scale = GSL_MAX(scale,
fabs(a) + fabs(gsl_vector_get(&y.vector, ii)));
gsl_vector_set(&ev.vector, ii, a);
gsl_vector_set(&ev2.vector, ii, -a);
}
/* now save the real part */
ev = gsl_vector_complex_real(&ecol.vector);
ev2 = gsl_vector_complex_real(&ecol2.vector);
for (ii = 0; ii < N; ++ii)
{
double a = gsl_vector_get(&y.vector, ii);
gsl_vector_set(&ev.vector, ii, a);
gsl_vector_set(&ev2.vector, ii, a);
}
if (scale != 0.0)
scale = 1.0 / scale;
/* scale by largest element magnitude */
gsl_blas_zdscal(scale, &ecol.vector);
gsl_blas_zdscal(scale, &ecol2.vector);
/*
* decrement i since we took care of two eigenvalues at
* the same time
*/
--i;
} /* if (GSL_IMAG(lambda) != 0.0) */
} /* for (i = (int) N - 1; i >= 0; --i) */
} /* nonsymmv_get_right_eigenvectors() */
/* Compares real parts of a and b and returns nonzero if they are not
* approximately equal and Re(a) < Re(b); otherwise returns Im(a) < Im(b). */
static INLINE_DECL int
complex_less(gsl_complex a, gsl_complex b)
{
return gsl_fcmp(GSL_REAL(a), GSL_REAL(b), GSL_DBL_EPSILON) == 0 ?
GSL_IMAG(a) < GSL_IMAG(b) : GSL_REAL(a) < GSL_REAL(b);
}
/*
* Calculate eigenvectors and eigenvalues for a non-symmetric complex matrix
* using the CLAPACK zgeev_ function.
*
*/
int
gsl_ext_eigen_zgeev(gsl_matrix_complex *A_gsl, gsl_matrix_complex *evec, gsl_vector_complex *eval)
{
//integer *pivot;
integer n,i,j,info,lwork, ldvl, ldvr, lda;
doublecomplex *A,*vr,*vl,*w,*work;
doublereal *rwork;
char jobvl,jobvr;
n = A_gsl->size1;
// pivot = (integer *)malloc((size_t)n * sizeof(int));
A = (doublecomplex *)malloc((size_t)n * n * sizeof(doublecomplex));
w = (doublecomplex *)malloc((size_t)n * sizeof(doublecomplex));
vr = (doublecomplex *)malloc((size_t)n * n * sizeof(doublecomplex));
vl = (doublecomplex *)malloc((size_t)n * n * sizeof(doublecomplex));
lwork = 16 * n;
work = (doublecomplex *)malloc((size_t)lwork * sizeof(doublecomplex));
rwork = (doublereal *)malloc((size_t)lwork * sizeof(doublereal));
for (i = 0; i < n; i++)
{
for (j = 0; j < n; j++)
{
gsl_complex z;
double re,im;
z = gsl_matrix_complex_get(A_gsl, i, j);
re = GSL_REAL(z);
im = GSL_IMAG(z);
A[j*n+i] = (doublecomplex){re,im};
}
}
jobvl='N';
jobvr='V';
lda = n;
ldvr = n;
ldvl = n;
zgeev_(&jobvl, &jobvr, &n, A, &lda, w, vl, &ldvl, vr, &ldvr, work, &lwork, rwork, &info);
//ZGEEVX(BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, W, VL, LDVL, VR, LDVR, ILO, IHI, SCALE, ABNRM, RCONDE, RCONDV, WORK, LWORK, RWORK, INFO )
for (i = 0; i < n; i++)
{
gsl_complex z;
GSL_SET_COMPLEX(&z, w[i].r, w[i].i);
gsl_vector_complex_set(eval, i, z);
}
for (j = 0; j < n; j++)
{
for (i = 0; i < n; i++)
{
gsl_complex z;
GSL_SET_COMPLEX(&z, vr[j*n+i].r, vr[j*n+i].i);
gsl_matrix_complex_set(evec, i, j, z);
}
}
if (info != 0)
{
printf("zgeev_: error: info = %d\n", (int)info);
}
// free(pivot);
free(A);
free(w);
free(vr);
free(vl);
free(work);
free(rwork);
return 0;
}
int
gsl_linalg_complex_LU_decomp (gsl_matrix_complex * A, gsl_permutation * p, int *signum)
{
if (A->size1 != A->size2)
{
GSL_ERROR ("LU decomposition requires square matrix", GSL_ENOTSQR);
}
else if (p->size != A->size1)
{
GSL_ERROR ("permutation length must match matrix size", GSL_EBADLEN);
}
else
{
const size_t N = A->size1;
size_t i, j, k;
*signum = 1;
gsl_permutation_init (p);
for (j = 0; j < N - 1; j++)
{
/* Find maximum in the j-th column */
gsl_complex ajj = gsl_matrix_complex_get (A, j, j);
double max = gsl_complex_abs (ajj);
size_t i_pivot = j;
for (i = j + 1; i < N; i++)
{
gsl_complex aij = gsl_matrix_complex_get (A, i, j);
double ai = gsl_complex_abs (aij);
if (ai > max)
{
max = ai;
i_pivot = i;
}
}
if (i_pivot != j)
{
gsl_matrix_complex_swap_rows (A, j, i_pivot);
gsl_permutation_swap (p, j, i_pivot);
*signum = -(*signum);
}
ajj = gsl_matrix_complex_get (A, j, j);
if (!(GSL_REAL(ajj) == 0.0 && GSL_IMAG(ajj) == 0.0))
{
for (i = j + 1; i < N; i++)
{
gsl_complex aij_orig = gsl_matrix_complex_get (A, i, j);
gsl_complex aij = gsl_complex_div (aij_orig, ajj);
gsl_matrix_complex_set (A, i, j, aij);
for (k = j + 1; k < N; k++)
{
gsl_complex aik = gsl_matrix_complex_get (A, i, k);
gsl_complex ajk = gsl_matrix_complex_get (A, j, k);
/* aik = aik - aij * ajk */
gsl_complex aijajk = gsl_complex_mul (aij, ajk);
gsl_complex aik_new = gsl_complex_sub (aik, aijajk);
gsl_matrix_complex_set (A, i, k, aik_new);
}
}
}
}
return GSL_SUCCESS;
}
}
int
gsl_eigen_hermv (gsl_matrix_complex * A, gsl_vector * eval,
gsl_matrix_complex * evec,
gsl_eigen_hermv_workspace * w)
{
if (A->size1 != A->size2)
{
GSL_ERROR ("matrix must be square to compute eigenvalues", GSL_ENOTSQR);
}
else if (eval->size != A->size1)
{
GSL_ERROR ("eigenvalue vector must match matrix size", GSL_EBADLEN);
}
else if (evec->size1 != A->size1 || evec->size2 != A->size1)
{
GSL_ERROR ("eigenvector matrix must match matrix size", GSL_EBADLEN);
}
else
{
const size_t N = A->size1;
double *const d = w->d;
double *const sd = w->sd;
size_t a, b;
/* handle special case */
if (N == 1)
{
gsl_complex A00 = gsl_matrix_complex_get (A, 0, 0);
gsl_vector_set (eval, 0, GSL_REAL(A00));
gsl_matrix_complex_set (evec, 0, 0, GSL_COMPLEX_ONE);
return GSL_SUCCESS;
}
/* Transform the matrix into a symmetric tridiagonal form */
{
gsl_vector_view d_vec = gsl_vector_view_array (d, N);
gsl_vector_view sd_vec = gsl_vector_view_array (sd, N - 1);
gsl_vector_complex_view tau_vec = gsl_vector_complex_view_array (w->tau, N-1);
gsl_linalg_hermtd_decomp (A, &tau_vec.vector);
gsl_linalg_hermtd_unpack (A, &tau_vec.vector, evec, &d_vec.vector, &sd_vec.vector);
}
/* Make an initial pass through the tridiagonal decomposition
to remove off-diagonal elements which are effectively zero */
chop_small_elements (N, d, sd);
/* Progressively reduce the matrix until it is diagonal */
b = N - 1;
while (b > 0)
{
if (sd[b - 1] == 0.0 || isnan(sd[b - 1]))
{
b--;
continue;
}
/* Find the largest unreduced block (a,b) starting from b
and working backwards */
a = b - 1;
while (a > 0)
{
if (sd[a - 1] == 0.0)
{
break;
}
a--;
}
{
size_t i;
const size_t n_block = b - a + 1;
double *d_block = d + a;
double *sd_block = sd + a;
double * const gc = w->gc;
double * const gs = w->gs;
/* apply QR reduction with implicit deflation to the
unreduced block */
qrstep (n_block, d_block, sd_block, gc, gs);
/* Apply Givens rotation Gij(c,s) to matrix Q, Q <- Q G */
for (i = 0; i < n_block - 1; i++)
{
const double c = gc[i], s = gs[i];
size_t k;
for (k = 0; k < N; k++)
{
gsl_complex qki = gsl_matrix_complex_get (evec, k, a + i);
gsl_complex qkj = gsl_matrix_complex_get (evec, k, a + i + 1);
/* qki <= qki * c - qkj * s */
/* qkj <= qki * s + qkj * c */
gsl_complex x1 = gsl_complex_mul_real(qki, c);
gsl_complex y1 = gsl_complex_mul_real(qkj, -s);
gsl_complex x2 = gsl_complex_mul_real(qki, s);
gsl_complex y2 = gsl_complex_mul_real(qkj, c);
gsl_complex qqki = gsl_complex_add(x1, y1);
gsl_complex qqkj = gsl_complex_add(x2, y2);
gsl_matrix_complex_set (evec, k, a + i, qqki);
gsl_matrix_complex_set (evec, k, a + i + 1, qqkj);
}
}
/* remove any small off-diagonal elements */
chop_small_elements (n_block, d_block, sd_block);
}
}
{
gsl_vector_view d_vec = gsl_vector_view_array (d, N);
gsl_vector_memcpy (eval, &d_vec.vector);
}
return GSL_SUCCESS;
}
}
void
FUNCTION (test, func) (size_t stride, size_t N)
{
TYPE (gsl_vector) * v0;
TYPE (gsl_vector) * v;
QUALIFIED_VIEW(gsl_vector,view) view;
size_t i, j;
if (stride == 1)
{
v = FUNCTION (gsl_vector, calloc) (N);
TEST(v->data == 0, "_calloc pointer");
TEST(v->size != N, "_calloc size");
TEST(v->stride != 1, "_calloc stride");
{
int status = (FUNCTION(gsl_vector,isnull)(v) != 1);
TEST (status, "_isnull" DESC " on calloc vector");
status = (FUNCTION(gsl_vector,ispos)(v) != 0);
TEST (status, "_ispos" DESC " on calloc vector");
status = (FUNCTION(gsl_vector,isneg)(v) != 0);
TEST (status, "_isneg" DESC " on calloc vector");
}
FUNCTION (gsl_vector, free) (v); /* free whatever is in v */
}
if (stride == 1)
{
v = FUNCTION (gsl_vector, alloc) (N);
TEST(v->data == 0, "_alloc pointer");
TEST(v->size != N, "_alloc size");
TEST(v->stride != 1, "_alloc stride");
FUNCTION (gsl_vector, free) (v); /* free whatever is in v */
}
if (stride == 1)
{
v0 = FUNCTION (gsl_vector, alloc) (N);
view = FUNCTION (gsl_vector, subvector) (v0, 0, N);
v = &view.vector;
}
else
{
v0 = FUNCTION (gsl_vector, alloc) (N * stride);
for (i = 0; i < N*stride; i++)
{
BASE x = ZERO;
GSL_REAL (x) = (ATOMIC)i;
GSL_IMAG (x) = (ATOMIC)(i + 1234);
FUNCTION (gsl_vector, set) (v0, i, x);
}
view = FUNCTION (gsl_vector, subvector_with_stride) (v0, 0, stride, N);
v = &view.vector;
}
{
int status = 0;
for (i = 0; i < N; i++)
{
BASE x = ZERO;
GSL_REAL (x) = (ATOMIC)i;
GSL_IMAG (x) = (ATOMIC)(i + 1234);
FUNCTION (gsl_vector, set) (v, i, x);
}
for (i = 0; i < N; i++)
{
if (v->data[2*i*stride] != (ATOMIC) (i) || v->data[2 * i * stride + 1] != (ATOMIC) (i + 1234))
status = 1;
};
TEST(status,"_set" DESC " writes into array");
}
{
int status = 0;
for (i = 0; i < N; i++)
{
BASE x, y;
GSL_REAL (x) = (ATOMIC)i;
GSL_IMAG (x) = (ATOMIC)(i + 1234);
y = FUNCTION (gsl_vector, get) (v, i);
if (!GSL_COMPLEX_EQ (x, y))
status = 1;
};
TEST (status, "_get" DESC " reads from array");
}
{
int status = 0;
for (i = 0; i < N; i++)
{
if (FUNCTION (gsl_vector, ptr) (v, i) != (BASE *)v->data + i*stride)
status = 1;
};
TEST (status, "_ptr" DESC " access to array");
}
{
int status = 0;
for (i = 0; i < N; i++)
{
if (FUNCTION (gsl_vector, const_ptr) (v, i) != (BASE *)v->data + i*stride)
status = 1;
};
TEST (status, "_const_ptr" DESC " access to array");
}
{
int status = 0;
for (i = 0; i < N; i++)
{
BASE x = ZERO;
FUNCTION (gsl_vector, set) (v, i, x);
}
status = (FUNCTION(gsl_vector,isnull)(v) != 1);
TEST (status, "_isnull" DESC " on null vector") ;
status = (FUNCTION(gsl_vector,ispos)(v) != 0);
TEST (status, "_ispos" DESC " on null vector") ;
status = (FUNCTION(gsl_vector,isneg)(v) != 0);
TEST (status, "_isneg" DESC " on null vector") ;
}
{
int status = 0;
for (i = 0; i < N; i++)
{
BASE x = ZERO;
GSL_REAL (x) = (ATOMIC)i;
GSL_IMAG (x) = (ATOMIC)(i + 1234);
FUNCTION (gsl_vector, set) (v, i, x);
}
status = (FUNCTION(gsl_vector,isnull)(v) != 0);
TEST (status, "_isnull" DESC " on non-null vector") ;
status = (FUNCTION(gsl_vector,ispos)(v) != 0);
TEST (status, "_ispos" DESC " on non-null vector") ;
status = (FUNCTION(gsl_vector,ispos)(v) != 0);
TEST (status, "_isneg" DESC " on non-null vector") ;
}
{
int status = 0;
FUNCTION (gsl_vector, set_zero) (v);
for (i = 0; i < N; i++)
{
BASE x, y = ZERO;
x = FUNCTION (gsl_vector, get) (v, i);
if (!GSL_COMPLEX_EQ (x, y))
status = 1;
};
TEST (status, "_setzero" DESC " on non-null vector") ;
}
{
int status = 0;
BASE x;
GSL_REAL (x) = (ATOMIC)27;
GSL_IMAG (x) = (ATOMIC)(27 + 1234);
FUNCTION (gsl_vector, set_all) (v, x);
for (i = 0; i < N; i++)
{
BASE y = FUNCTION (gsl_vector, get) (v, i);
if (!GSL_COMPLEX_EQ (x, y))
status = 1;
};
TEST (status, "_setall" DESC " to non-zero value") ;
}
{
int status = 0;
for (i = 0; i < N; i++)
{
FUNCTION (gsl_vector, set_basis) (v, i);
for (j = 0; j < N; j++)
{
BASE x = FUNCTION (gsl_vector, get) (v, j);
BASE one = ONE;
BASE zero = ZERO;
if (i == j)
{
if (!GSL_COMPLEX_EQ (x, one))
status = 1 ;
}
else
{
if (!GSL_COMPLEX_EQ (x, zero))
status = 1;
}
};
}
TEST (status, "_setbasis" DESC " over range") ;
}
{
int status = 0;
for (i = 0; i < N; i++)
{
BASE x = ZERO;
GSL_REAL (x) = (ATOMIC)i;
GSL_IMAG (x) = (ATOMIC)(i + 1234);
FUNCTION (gsl_vector, set) (v, i, x);
}
{
BASE x = ZERO;
GSL_REAL(x) = 2.0;
GSL_IMAG(x) = 3.0;
FUNCTION (gsl_vector, scale) (v, x);
}
for (i = 0; i < N; i++)
{
BASE r = FUNCTION(gsl_vector,get) (v,i);
ATOMIC real = -(ATOMIC)i-(ATOMIC)3702;
ATOMIC imag = 5*(ATOMIC)i+(ATOMIC)2468;
if (GSL_REAL(r) != real || GSL_IMAG(r) != imag)
status = 1;
};
TEST (status, "_scale" DESC " by 2") ;
}
{
int status = 0;
{
BASE x = ZERO;
GSL_REAL(x) = 7.0;
GSL_IMAG(x) = 13.0;
FUNCTION (gsl_vector, add_constant) (v, x);
}
for (i = 0; i < N; i++)
{
BASE r = FUNCTION(gsl_vector,get) (v,i);
ATOMIC real = -(ATOMIC)i-(ATOMIC)3695;
ATOMIC imag = 5*(ATOMIC)i+(ATOMIC)2481;
if (GSL_REAL(r) != real || GSL_IMAG(r) != imag)
status = 1;
};
TEST (status, "_add_constant" DESC) ;
}
for (i = 0; i < N; i++)
{
BASE x = ZERO;
GSL_REAL (x) = (ATOMIC)i;
GSL_IMAG (x) = (ATOMIC)(i + 1234);
FUNCTION (gsl_vector, set) (v, i, x);
}
{
int status;
BASE x, y, r, s ;
GSL_REAL(x) = 2 ;
GSL_IMAG(x) = 2 + 1234;
GSL_REAL(y) = 5 ;
GSL_IMAG(y) = 5 + 1234;
FUNCTION (gsl_vector,swap_elements) (v, 2, 5) ;
r = FUNCTION(gsl_vector,get)(v,2);
s = FUNCTION(gsl_vector,get)(v,5);
status = ! GSL_COMPLEX_EQ(r,y) ;
status |= ! GSL_COMPLEX_EQ(s,x) ;
FUNCTION (gsl_vector,swap_elements) (v, 2, 5) ;
r = FUNCTION(gsl_vector,get)(v,2);
s = FUNCTION(gsl_vector,get)(v,5);
status |= ! GSL_COMPLEX_EQ(r,x) ;
status |= ! GSL_COMPLEX_EQ(s,y) ;
TEST (status, "_swap_elements" DESC " exchanges elements") ;
}
{
int status = 0;
FUNCTION (gsl_vector,reverse) (v) ;
for (i = 0; i < N; i++)
{
BASE x,r ;
GSL_REAL(x) = (ATOMIC)(N - i - 1) ;
GSL_IMAG(x) = (ATOMIC)(N - i - 1 + 1234);
r = FUNCTION (gsl_vector, get) (v, i);
status |= !GSL_COMPLEX_EQ(r,x);
}
gsl_test (status, NAME(gsl_vector) "_reverse" DESC " reverses elements") ;
}
{
int status = 0;
QUALIFIED_VIEW(gsl_vector,view) v1 = FUNCTION(gsl_vector, view_array) (v->data, N*stride);
for (i = 0; i < N; i++)
{
BASE x = FUNCTION (gsl_vector, get) (&v1.vector, i*stride) ;
BASE y = FUNCTION (gsl_vector, get) (v, i);
if (!GSL_COMPLEX_EQ(x,y))
status = 1;
};
TEST (status, "_view_array" DESC);
}
{
int status = 0;
QUALIFIED_VIEW(gsl_vector,view) v1 = FUNCTION(gsl_vector, view_array_with_stride) (v->data, stride, N*stride);
for (i = 0; i < N; i++)
{
BASE x = FUNCTION (gsl_vector, get) (&v1.vector, i) ;
BASE y = FUNCTION (gsl_vector, get) (v, i);
if (!GSL_COMPLEX_EQ(x,y))
status = 1;
};
TEST (status, "_view_array_with_stride" DESC);
}
{
int status = 0;
QUALIFIED_VIEW(gsl_vector,view) v1 = FUNCTION(gsl_vector, subvector) (v, N/3, N/2);
for (i = 0; i < N/2; i++)
{
BASE x = FUNCTION (gsl_vector, get) (&v1.vector, i) ;
BASE y = FUNCTION (gsl_vector, get) (v, (N/3)+i);
if (!GSL_COMPLEX_EQ(x,y))
status = 1;
};
TEST (status, "_view_subvector" DESC);
}
{
int status = 0;
QUALIFIED_VIEW(gsl_vector,view) v1 = FUNCTION(gsl_vector, subvector_with_stride) (v, N/5, 3, N/4);
for (i = 0; i < N/4; i++)
{
BASE x = FUNCTION (gsl_vector, get) (&v1.vector, i) ;
BASE y = FUNCTION (gsl_vector, get) (v, (N/5)+3*i);
if (!GSL_COMPLEX_EQ(x,y))
status = 1;
};
TEST (status, "_view_subvector_with_stride" DESC);
}
{
int status = 0;
QUALIFIED_REAL_VIEW(gsl_vector,view) vv = FUNCTION(gsl_vector, real) (v);
for (i = 0; i < N; i++)
{
ATOMIC xr = REAL_VIEW (gsl_vector, get) (&vv.vector, i) ;
BASE y = FUNCTION (gsl_vector, get) (v, i);
ATOMIC yr = GSL_REAL(y);
if (xr != yr)
status = 1;
};
TEST (status, "_real" DESC);
}
{
int status = 0;
QUALIFIED_REAL_VIEW(gsl_vector,view) vv = FUNCTION(gsl_vector, imag) (v);
for (i = 0; i < N; i++)
{
ATOMIC xr = REAL_VIEW (gsl_vector, get) (&vv.vector, i) ;
BASE y = FUNCTION (gsl_vector, get) (v, i);
ATOMIC yr = GSL_IMAG(y);
if (xr != yr)
status = 1;
};
TEST (status, "_imag" DESC);
}
FUNCTION (gsl_vector, free) (v0); /* free whatever is in v */
}