arb/acb_hypgeom/pfq_sum_fme.c

/*=============================================================================

    This file is part of ARB.

    ARB is free software; you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation; either version 2 of the License, or
    (at your option) any later version.

    ARB is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with ARB; if not, write to the Free Software
    Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA

=============================================================================*/
/******************************************************************************

    Copyright (C) 2014 Fredrik Johansson

******************************************************************************/

#include "acb_hypgeom.h"

static void
evaluate(acb_poly_t A, acb_srcptr a, slong p, const acb_t z, slong n, slong prec)
{
    acb_poly_fit_length(A, p + 1);

    if (p == 1)
    {
        acb_add_ui(A->coeffs, a, n, prec);
        if (z != NULL)
            acb_mul(A->coeffs, A->coeffs, z, prec);
    }
    else if (p == 2)
    {
        acb_add(A->coeffs, a + 0, a + 1, prec);
        acb_add_ui(A->coeffs + 1, A->coeffs, 2 * n, prec);
        acb_add_ui(A->coeffs, A->coeffs, n, prec);
        acb_mul_ui(A->coeffs, A->coeffs, n, prec);
        acb_addmul(A->coeffs, a + 0, a + 1, prec);
        if (z != NULL)
        {
            acb_mul(A->coeffs, A->coeffs, z, prec);
            acb_mul(A->coeffs + 1, A->coeffs + 1, z, prec);
        }
    }
    else if (p == 3)
    {
        acb_t t, u;
        acb_init(t);
        acb_init(u);

        acb_add(t, a + 0, a + 1, prec);
        acb_add(t, t, a + 2, prec);

        acb_mul(u, a + 0, a + 1, prec);
        acb_mul(A->coeffs, u, a + 2, prec);

        acb_addmul(u, a + 0, a + 2, prec);
        acb_addmul(u, a + 1, a + 2, prec);

        /*
        (a0 + n)(a1 + n)(a2 + n) = a0 a1 a2 + (a0 a1 + a0 a2 + a1 a2) n + (a0 + a1 + a2) n^2 + n^3
        (a0 a1 + a0 a2 + a1 a2) + 2 (a0 + a1 + a2) n + 3 n^2
        (a0 + a1 + a2) + 3n
        1
        */

        acb_addmul_ui(A->coeffs, u, n, prec);
        acb_addmul_ui(A->coeffs, t, n * n, prec);
        acb_add_ui(A->coeffs, A->coeffs, n * n * n, prec);

        acb_set(A->coeffs + 1, u);
        acb_addmul_ui(A->coeffs + 1, t, 2 * n, prec);
        acb_add_ui(A->coeffs + 1, A->coeffs + 1, 3 * n * n, prec);

        acb_add_ui(A->coeffs + 2, t, 3 * n, prec);

        if (z != NULL)
        {
            acb_mul(A->coeffs + 0, A->coeffs + 0, z, prec);
            acb_mul(A->coeffs + 1, A->coeffs + 1, z, prec);
            acb_mul(A->coeffs + 2, A->coeffs + 2, z, prec);
        }

        acb_clear(t);
        acb_clear(u);
    }
    else if (p != 0)
    {
        abort();
    }

    if (z != NULL)
        acb_set(A->coeffs + p, z);
    else
        acb_one(A->coeffs + p);

    _acb_poly_set_length(A, p + 1);
    _acb_poly_normalise(A);
}

/* todo: do this using underscore methods */
static void
bsplit(acb_poly_t A, acb_poly_t B, acb_poly_t C,
    acb_srcptr a, slong p, acb_srcptr b, slong q,
    const acb_t z, slong an, slong bn, slong prec)
{
    if (bn - an == 1)
    {
        evaluate(A, a, p, z, an, prec);
        evaluate(B, b, q, NULL, an, prec);
        acb_poly_set(C, B);
    }
    else if (bn - an == 2)  /* inlined */
    {
        acb_poly_t A2, B2;

        acb_poly_init(A2);
        acb_poly_init(B2);

        evaluate(A, a, p, z, an, prec);
        evaluate(A2, a, p, z, an + 1, prec);
        evaluate(B, b, q, NULL, an, prec);
        evaluate(B2, b, q, NULL, an + 1, prec);

        acb_poly_mul(C, B, B2, prec);
        acb_poly_set(B, C);
        acb_poly_mul(C, A, B2, prec);
        acb_poly_add(C, C, B, prec);
        acb_poly_mul(A2, A, A2, prec);
        acb_poly_swap(A, A2);

        acb_poly_clear(A2);
        acb_poly_clear(B2);
    }
    else
    {
        slong m = an + (bn - an) / 2;

        acb_poly_t A2, B2, C2, T;

        acb_poly_init(A2);
        acb_poly_init(B2);
        acb_poly_init(C2);
        acb_poly_init(T);

        bsplit(A, B, C, a, p, b, q, z, an, m, prec);
        bsplit(A2, B2, C2, a, p, b, q, z, m, bn, prec);

        acb_poly_mul(T, B2, C, prec);
        acb_poly_mul(C, A, C2, prec);
        acb_poly_add(C, C, T, prec);
        acb_poly_mul(C2, B, B2, prec);
        acb_poly_swap(B, C2);
        acb_poly_mul(B2, A, A2, prec);
        acb_poly_swap(A, B2);

        acb_poly_clear(A2);
        acb_poly_clear(B2);
        acb_poly_clear(C2);
        acb_poly_clear(T);
    }
}

void
acb_hypgeom_pfq_sum_fme(acb_t s, acb_t t,
    acb_srcptr a, slong p, acb_srcptr b, slong q,
    const acb_t z, slong n, slong prec)
{
    acb_poly_t A, B, C;
    acb_ptr ks, As, Bs, Cs;
    acb_t u, v;
    acb_ptr * tree;
    slong i, k, m, w;

    m = n_sqrt(n) / 4;  /* tuning parameter */
    w = n / FLINT_MAX(m, 1);

    if (m < 1 || w < 1 || p > 3 || q > 3)
    {
        acb_hypgeom_pfq_sum_forward(s, t, a, p, b, q, z, n, prec);
        return;
    }

    acb_poly_init(A);
    acb_poly_init(B);
    acb_poly_init(C);

    acb_init(u);
    acb_init(v);

    ks = _acb_vec_init(w);
    As = _acb_vec_init(w);
    Bs = _acb_vec_init(w);
    Cs = _acb_vec_init(w);

    bsplit(A, B, C, a, p, b, q, z, 0, m, prec);

    for (i = 0; i < w; i++)
        acb_set_ui(ks + i, i * m);

    tree = _acb_poly_tree_alloc(w);
    _acb_poly_tree_build(tree, ks, w, prec);
    _acb_poly_evaluate_vec_fast_precomp(As, A->coeffs, A->length, tree, w, prec);
    _acb_poly_evaluate_vec_fast_precomp(Bs, B->coeffs, B->length, tree, w, prec);
    _acb_poly_evaluate_vec_fast_precomp(Cs, C->coeffs, C->length, tree, w, prec);
    _acb_poly_tree_free(tree, w);

    /* todo: use binary splitting here for improved numerical stability */
    for (i = 1; i < w; i++)
    {
        acb_mul(Cs, Cs, Bs + i, prec);
        acb_addmul(Cs, As, Cs + i, prec);
        acb_mul(As, As, As + i, prec);
        acb_mul(Bs, Bs, Bs + i, prec);
    }

    acb_div(s, Cs, Bs, prec);
    acb_div(t, As, Bs, prec);

    for (k = w * m; k < n && !acb_is_zero(t); k++)
    {
        acb_add(s, s, t, prec);

        if (p > 0)
        {
            acb_add_ui(u, a, k, prec);

            for (i = 1; i < p; i++)
            {
                acb_add_ui(v, a + i, k, prec);
                acb_mul(u, u, v, prec);
            }

            acb_mul(t, t, u, prec);
        }

        if (q > 0)
        {
            acb_add_ui(u, b, k, prec);

            for (i = 1; i < q; i++)
            {
                acb_add_ui(v, b + i, k, prec);
                acb_mul(u, u, v, prec);
            }

            acb_div(t, t, u, prec);
        }

        acb_mul(t, t, z, prec);
    }

    acb_clear(u);
    acb_clear(v);

    _acb_vec_clear(ks, w);
    _acb_vec_clear(As, w);
    _acb_vec_clear(Bs, w);
    _acb_vec_clear(Cs, w);

    acb_poly_clear(A);
    acb_poly_clear(B);
    acb_poly_clear(C);
}