value_t compute(const FUNC &f, const input_t& a, const input_t& b)
{
typedef typename details::fudge<FUNC,1,vtab_t,input_t,test> fudge1;
typedef typename details::fudge<FUNC,13,vtab_t,input_t,test> fudge13;
input_t d = b-a;
real_t e = nt2::eps(nt2::abs(d));
input_t c = nt2::average(a, b);
input_t h = d*Half<real_t>();
input_t se = e*sign(d);
const real_t cs[] = {real_t(.942882415695480), nt2::Sqrt_2o_3<real_t>(),
real_t(.641853342345781),
nt2::Sqrt_1o_5<real_t>(), real_t(.236383199662150)};
rtab_t s(nt2::of_size(1, 5), &cs[0], &cs[5]);
itab_t z = h*s;
itab_t x = nt2::cath(nt2::cath(nt2::cath(nt2::cath(a, c-z), c), c+nt2::fliplr(z)), b);
vtab_t y = f(x);
fcnt_ = 13;
fudge1::fdg(f, y, fcnt_, singular_a_, a, se); // Fudge a to avoid infinities.
fudge13::fdg(f, y, fcnt_, singular_b_, b, -se); // Fudge b to avoid infinities.
// Call the recursive core integrator.
// Increase tolerance if refinement appears to be effective.
value_t Q1 = h*nt2::globalsum(lobatto()*y(nt2::_(1,4,13)))*c245_;
value_t Q2 = h*nt2::globalsum(kronrod()*y(nt2::_(1,2,13)));
const real_t cs1[] = {real_t(.0158271919734802),real_t(.094273840218850),real_t(.155071987336585),
real_t(.188821573960182),real_t(.199773405226859),real_t(.224926465333340)};
rtab_t s1(nt2::of_size(1, 6), &cs1[0], &cs1[6]);
rtab_t w = nt2::cath(nt2::cath(s1, real_t(.242611071901408)), nt2::fliplr(s1));
value_t Q0 = h*nt2::globalsum(w*y)*c1470_;
real_t r = nt2::abs((Q2-Q0)/(Q1-Q0+nt2::Smallestposval<real_t>()));
if (r > 0 && r < 1) tol_ /= r;
tol_*= c1470_;
// Call the recursive core integrator.
hmin_ = fast_ldexp(e, -10); //e/1024
return quadlstep(f,a,b,y(1),y(13))/c1470_;
}
value_t quadlstep(const FUNC & f, const input_t & a, const input_t & b,
const value_t &fa, const value_t& fb)
{
// recursive core routine for function quadl.
// Evaluate integrand five times in interior of subinterval [a,b].
input_t d = b-a;
input_t c = nt2::average(a, b);
input_t h = d*Half<real_t>();
if (abs(h) < hmin_ || c == a || c == b ) //Minimum step size reached; singularity possible.
{
setwarn(1); return h*(fa+fb);
}
itab_t x = h*c1();
x = c+x;
vtab_t y = f(x);
fcnt_ += 5;
if (fcnt_ > maxfcnt_){ setwarn(2); return h*(fa+fb); } // Maximum function count exceeded; singularity likely.
itab_t x1 = nt2::cath(nt2::cath(a, x), b); x = x1;
vtab_t y1 = nt2::cath(nt2::cath(fa, y), fb);y = y1;
value_t Q1 = h*nt2::globalsum(lobatto()*y(_(1, 2, 7)))*c245_; // Four point Lobatto quadrature times 1470.
value_t Q = h*nt2::globalsum(kronrod()*y); // Seven point Kronrod refinement times 1470.
if (nt2::is_invalid(Q)) { setwarn(3); return Q; } // Infinite or Not-a-Number function value encountered.
// Check accuracy of integral over this subinterval.
real_t curerr = nt2::abs(Q1 - Q);
if (curerr <= tol_*nt2::abs(h))
{
err_+= curerr;
setwarn(0); return Q;
}
else // % Subdivide into six subintervals.
{
setwarn(0);
Q = Zero<value_t>();
for(size_t k = 1; k <= 6; ++k)
{
Q += quadlstep(f, x(k), x(k+1), y(k), y(k+1));
}
return Q;
}
};
KNDdeTorusCollocation::KNDdeTorusCollocation(KNExprSystem& sys_, size_t ndeg1_, size_t ndeg2_, size_t nint1_, size_t nint2_) :
sys(&sys_),
ndim(sys_.ndim()), ntau(sys_.ntau()), npar(sys_.npar()),
ndeg1(ndeg1_), ndeg2(ndeg2_), nint1(nint1_), nint2(nint2_),
col1(ndeg1_), col2(ndeg2_),
mesh1(ndeg1_ + 1), mesh2(ndeg2_ + 1),
lgr1(ndeg1_ + 1, ndeg1_ + 1), lgr2(ndeg2_ + 1, ndeg2_ + 1),
dlg1(ndeg1_ + 1, ndeg1_ + 1), dlg2(ndeg2_ + 1, ndeg2_ + 1),
I1((ndeg1_ + 1), (ndeg1_ + 1)),
ID1((ndeg1_ + 1), (ndeg1_ + 1)),
I2((ndeg2_ + 1), (ndeg2_ + 1)),
ID2((ndeg2_ + 1), (ndeg2_ + 1)),
mlg1((ndeg1_ + 1)*(ndeg1_ + 1)),
mlg2((ndeg2_ + 1)*(ndeg2_ + 1)),
mlgd1((ndeg1_ + 1)*(ndeg1_ + 1)),
mlgd2((ndeg2_ + 1)*(ndeg2_ + 1)),
ilg1((ndeg1_ + 1)*(ndeg1_ + 1) + 1),
ilg2((ndeg2_ + 1)*(ndeg2_ + 1) + 1),
ilgd1((ndeg1_ + 1)*(ndeg1_ + 1) + 1),
ilgd2((ndeg2_ + 1)*(ndeg2_ + 1) + 1),
time1(ndeg1*ndeg2*nint1*nint2), time2(ndeg1*ndeg2*nint1*nint2),
kk((ntau+1)*(ndeg1+1)*(ndeg2+1), ndeg1*ndeg2*nint1*nint2),
ee((ntau+1)*(ndeg1+1)*(ndeg2+1), ndeg1*ndeg2*nint1*nint2),
rr((ntau+1)*(ndeg1+1)*(ndeg2+1), ndeg1*ndeg2*nint1*nint2),
p_tau(ntau, ndeg1*ndeg2*nint1*nint2), p_dtau(ntau, ndeg1*ndeg2*nint1*nint2),
p_xx(ndim, ntau+2*(ntau+1), ndeg1*ndeg2*nint1*nint2),
p_fx(ndim, ndeg1*ndeg2*nint1*nint2),
p_dfp(ndim, 1, ndeg1*ndeg2*nint1*nint2),
p_dfx(ndim, ndim, ndeg1*ndeg2*nint1*nint2),
p_dummy(0, 0, ndeg1*ndeg2*nint1*nint2)
{
lobatto(mesh1);
lobatto(mesh2);
gauss(col1);
gauss(col2);
for (size_t i = 0; i < mesh1.size(); i++)
{
poly_coeff_lgr(lgr1(i), mesh1, i);
poly_coeff_diff(dlg1(i), lgr1(i));
}
for (size_t i = 0; i < mesh2.size(); i++)
{
poly_coeff_lgr(lgr2(i), mesh2, i);
poly_coeff_diff(dlg2(i), lgr2(i));
}
// here comes the phase condition for par(OMEGA0) and par(OMEGA1)
// the integration in the bottom border
// construct the diffint matrix
for (size_t i = 0; i < ndeg1 + 1; i++)
{
for (size_t k = 0; k < ndeg1 + 1; k++)
{
mlg1.clear();
mlgd1.clear();
ilg1.clear();
ilgd1.clear();
poly_coeff_mul(mlg1, lgr1(i), lgr1(k));
poly_coeff_mul(mlgd1, dlg1(i), lgr1(k));
poly_coeff_int(ilg1, mlg1);
poly_coeff_int(ilgd1, mlgd1);
I1(i, k) = (poly_eval(ilg1, 1.0)-poly_eval(ilg1, 0.0)) / nint1;
ID1(i, k) = poly_eval(ilgd1, 1.0);
}
}
for (size_t j = 0; j < ndeg2 + 1; j++)
{
for (size_t l = 0; l < ndeg2 + 1; l++)
{
mlg2.clear();
mlgd2.clear();
ilg2.clear();
ilgd2.clear();
poly_coeff_mul(mlg2, lgr2(j), lgr2(l));
poly_coeff_mul(mlgd2, dlg2(j), lgr2(l));
poly_coeff_int(ilg2, mlg2);
poly_coeff_int(ilgd2, mlgd2);
I2(j, l) = (poly_eval(ilg2, 1.0) - poly_eval(ilg2, 0.0))/ nint2;
ID2(j, l) = poly_eval(ilgd2, 1.0);
}
}
}
void fill_trans_matrices(TransMatrix trans_matrix_left,
TransMatrix trans_matrix_right)
{
fprintf(stderr, "Filling transformation matrices...");
fflush(stderr);
int max_order = 2*MAX_P;
const int max_fns_num = MAX_P + 1;
ProjMatrix proj_matrix;
fill_proj_matrix(max_fns_num, max_order, &proj_matrix);
// prepare quadrature in (-1, 0) and (0, 1)
double phys_x_left[MAX_QUAD_PTS_NUM]; // quad points
double phys_x_right[MAX_QUAD_PTS_NUM]; // quad points
double phys_weights_left[MAX_QUAD_PTS_NUM]; // quad weights
double phys_weights_right[MAX_QUAD_PTS_NUM]; // quad weights
int pts_num_left = 0;
int pts_num_right = 0;
create_phys_element_quadrature(-1, 0, max_order, phys_x_left, phys_weights_left,
&pts_num_left);
create_phys_element_quadrature(0, 1, max_order, phys_x_right, phys_weights_right,
&pts_num_right);
// loop over shape functions on coarse element
for (int j=0; j < max_fns_num; j++) {
// backup of projectionmatrix
double** mat_left = new_matrix<double>(max_fns_num, max_fns_num);
double** mat_right = new_matrix<double>(max_fns_num, max_fns_num);
for (int r=0; r < max_fns_num; r++) {
for (int s=0; s < max_fns_num; s++) {
mat_left[r][s] += proj_matrix[r][s];
mat_right[r][s] += proj_matrix[r][s];
}
}
// fill right-hand side vectors f_left and f_right for j-th
// Lobatto shape function on (-1, 0) and (0, 1), respectively
double f_left[max_fns_num];
double f_right[max_fns_num];
for (int i=0; i < max_fns_num; i++) {
f_left[i] = 0;
f_right[i] = 0;
for (int k=0; k < pts_num_left; k++) {
f_left[i] += phys_weights_left[k] * lobatto(j, phys_x_left[k]) *
lobatto_left(i, phys_x_left[k]);
}
for (int k=0; k < pts_num_right; k++) {
f_right[i] += phys_weights_right[k] * lobatto(j, phys_x_right[k]) *
lobatto_right(i, phys_x_right[k]);
}
}
// for each 'j' we get a new column in the
// transformation matrices
int *indx = new int[max_fns_num];
double d;
ludcmp(mat_left, max_fns_num, indx, &d);
// solve system
lubksb(mat_left, max_fns_num, indx, f_left);
ludcmp(mat_right, max_fns_num, indx, &d);
// solve system
lubksb(mat_right, max_fns_num, indx, f_right);
for (int i=0; i < max_fns_num; i++) {
trans_matrix_left[i][j] = f_left[i];
trans_matrix_right[i][j] = f_right[i];
}
delete [] mat_left;
delete [] mat_right;
}
/* DEBUG
for (int i=0; i < n; i++) {
for (int j=0; j < p+1; j++) {
printf("transf_matrix_left[%d][%d] = %g\n", i, j, transf_matrix_left[i][j]);
printf("transf_matrix_right[%d][%d] = %g\n", i, j, transf_matrix_right[i][j]);
}
printf("\n");
}
//error("stop.");
*/
fprintf(stderr, "done.\n");
}