legendre_con.c

开放gsl矩阵运算

/* specfunc/legendre_con.c
 * 
 * Copyright (C) 1996, 1997, 1998, 1999, 2000 Gerard Jungman
 * 
 * This program 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.
 * 
 * This program 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 this program; if not, write to the Free Software
 * Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 */

/* Author:  G. Jungman */

#include <config.h>
#include <gsl/gsl_math.h>
#include <gsl/gsl_errno.h>
#include <gsl/gsl_poly.h>
#include "gsl_sf_exp.h"
#include "gsl_sf_trig.h"
#include "gsl_sf_gamma.h"
#include "gsl_sf_ellint.h"
#include "gsl_sf_pow_int.h"
#include "gsl_sf_bessel.h"
#include "gsl_sf_hyperg.h"
#include "gsl_sf_legendre.h"

#include "error.h"
#include "legendre.h"

#define Root_2OverPi_  0.797884560802865355879892
#define locEPS         (1000.0*GSL_DBL_EPSILON)


/*-*-*-*-*-*-*-*-*-*-*-* Private Section *-*-*-*-*-*-*-*-*-*-*-*/


#define RECURSE_LARGE  (1.0e-5*GSL_DBL_MAX)
#define RECURSE_SMALL  (1.0e+5*GSL_DBL_MIN)


/* Continued fraction for f_{ell+1}/f_ell
 * f_ell := P^{-mu-ell}_{-1/2 + I tau}(x),  x < 1.0
 *
 * Uses standard CF method from Temme's book.
 */
static
int
conicalP_negmu_xlt1_CF1(const double mu, const int ell, const double tau,
                        const double x, gsl_sf_result * result)
{
  const double RECUR_BIG = GSL_SQRT_DBL_MAX;
  const int maxiter = 5000;
  int n = 1;
  double xi = x/(sqrt(1.0-x)*sqrt(1.0+x));
  double Anm2 = 1.0;
  double Bnm2 = 0.0;
  double Anm1 = 0.0;
  double Bnm1 = 1.0;
  double a1 = 1.0;
  double b1 = 2.0*(mu + ell + 1.0) * xi;
  double An = b1*Anm1 + a1*Anm2;
  double Bn = b1*Bnm1 + a1*Bnm2;
  double an, bn;
  double fn = An/Bn;

  while(n < maxiter) {
    double old_fn;
    double del;
    n++;
    Anm2 = Anm1;
    Bnm2 = Bnm1;
    Anm1 = An;
    Bnm1 = Bn;
    an = tau*tau + (mu - 0.5 + ell + n)*(mu - 0.5 + ell + n);
    bn = 2.0*(ell + mu + n) * xi;
    An = bn*Anm1 + an*Anm2;
    Bn = bn*Bnm1 + an*Bnm2;

    if(fabs(An) > RECUR_BIG || fabs(Bn) > RECUR_BIG) {
      An /= RECUR_BIG;
      Bn /= RECUR_BIG;
      Anm1 /= RECUR_BIG;
      Bnm1 /= RECUR_BIG;
      Anm2 /= RECUR_BIG;
      Bnm2 /= RECUR_BIG;
    }

    old_fn = fn;
    fn = An/Bn;
    del = old_fn/fn;
    
    if(fabs(del - 1.0) < 2.0*GSL_DBL_EPSILON) break;
  }

  result->val = fn;
  result->err = 4.0 * GSL_DBL_EPSILON * (sqrt(n) + 1.0) * fabs(fn);

  if(n >= maxiter)
    GSL_ERROR ("error", GSL_EMAXITER);
  else
    return GSL_SUCCESS;
}


/* Continued fraction for f_{ell+1}/f_ell
 * f_ell := P^{-mu-ell}_{-1/2 + I tau}(x),  x >= 1.0
 *
 * Uses Gautschi (Euler) equivalent series.
 */
static
int
conicalP_negmu_xgt1_CF1(const double mu, const int ell, const double tau,
                        const double x, gsl_sf_result * result)
{ 
  const int maxk = 20000;
  const double gamma = 1.0-1.0/(x*x);
  const double pre = sqrt(x-1.0)*sqrt(x+1.0) / (x*(2.0*(ell+mu+1.0)));
  double tk   = 1.0;
  double sum  = 1.0;
  double rhok = 0.0;
  int k;
 
  for(k=1; k<maxk; k++) {
    double tlk = 2.0*(ell + mu + k);
    double l1k = (ell + mu - 0.5 + 1.0 + k);
    double ak = -(tau*tau + l1k*l1k)/(tlk*(tlk+2.0)) * gamma;
    rhok = -ak*(1.0 + rhok)/(1.0 + ak*(1.0 + rhok));
    tk  *= rhok;
    sum += tk;
    if(fabs(tk/sum) < GSL_DBL_EPSILON) break;
  }

  result->val  = pre * sum;
  result->err  = fabs(pre * tk);
  result->err += 2.0 * GSL_DBL_EPSILON * (sqrt(k) + 1.0) * fabs(pre*sum);

  if(k >= maxk)
    GSL_ERROR ("error", GSL_EMAXITER);
  else
    return GSL_SUCCESS;
}


/* Implementation of large negative mu asymptotic
 * [Dunster, Proc. Roy. Soc. Edinburgh 119A, 311 (1991), p. 326]
 */

inline
static double olver_U1(double beta2, double p)
{
  return (p-1.0)/(24.0*(1.0+beta2)) * (3.0 + beta2*(2.0 + 5.0*p*(1.0+p)));
}

inline
static double olver_U2(double beta2, double p)
{
  double beta4 = beta2*beta2;
  double p2    = p*p;
  double poly1 =  4.0*beta4 + 84.0*beta2 - 63.0;
  double poly2 = 16.0*beta4 + 90.0*beta2 - 81.0;
  double poly3 = beta2*p2*(97.0*beta2 - 432.0 + 77.0*p*(beta2-6.0) - 385.0*beta2*p2*(1.0 + p));
  return (1.0-p)/(1152.0*(1.0+beta2)) * (poly1 + poly2 + poly3);
}

static const double U3c1[] = {   -1307.0,   -1647.0,    3375.0,    3675.0 };
static const double U3c2[] = {   29366.0,   35835.0, -252360.0, -272630.0,
                                276810.0,  290499.0 };
static const double U3c3[] = {  -29748.0,   -8840.0, 1725295.0, 1767025.0,
                              -7313470.0, -754778.0, 6309875.0, 6480045.0 };
static const double U3c4[] = {    2696.0,    -16740.0,   -524250.0,  -183975.0,
                              14670540.0,  14172939.0, -48206730.0, -48461985.0,
			      36756720.0,  37182145.0 };
static const double U3c5[] = {       9136.0,      22480.0,     12760.0,
                                  -252480.0,   -4662165.0,   -1705341.0,
				 92370135.0,   86244015.0, -263678415.0,
			       -260275015.0, 185910725.0,  185910725.0 };

#if 0
static double olver_U3(double beta2, double p)
{
  double beta4 = beta2*beta2;
  double beta6 = beta4*beta2;
  double opb2s = (1.0+beta2)*(1.0+beta2);
  double den   = 39813120.0 * opb2s*opb2s;
  double poly1 = gsl_poly_eval(U3c1, 4, p);
  double poly2 = gsl_poly_eval(U3c2, 6, p);
  double poly3 = gsl_poly_eval(U3c3, 8, p);
  double poly4 = gsl_poly_eval(U3c4, 10, p);
  double poly5 = gsl_poly_eval(U3c5, 12, p);
  
  return (p-1.0)*(     1215.0*poly1 + 324.0*beta2*poly2
                 + 54.0*beta4*poly3 +  12.0*beta6*poly4
		 + beta4*beta4*poly5
		 ) / den;
}
#endif /* 0 */


/* Large negative mu asymptotic
 * P^{-mu}_{-1/2 + I tau}, mu -> Inf
 * |x| < 1
 *
 * [Dunster, Proc. Roy. Soc. Edinburgh 119A, 311 (1991), p. 326]
 */
int
gsl_sf_conicalP_xlt1_large_neg_mu_e(double mu, double tau, double x,
                                       gsl_sf_result * result, double * ln_multiplier)
{
  double beta  = tau/mu;
  double beta2 = beta*beta;
  double S     = beta * acos((1.0-beta2)/(1.0+beta2));
  double p     = x/sqrt(beta2*(1.0-x*x) + 1.0);
  gsl_sf_result lg_mup1;
  int lg_stat = gsl_sf_lngamma_e(mu+1.0, &lg_mup1);
  double ln_pre_1 =  0.5*mu*(S - log(1.0+beta2) + log((1.0-p)/(1.0+p))) - lg_mup1.val;
  double ln_pre_2 = -0.25 * log(1.0 + beta2*(1.0-x));
  double ln_pre_3 = -tau * atan(p*beta);
  double ln_pre = ln_pre_1 + ln_pre_2 + ln_pre_3;
  double sum   = 1.0 - olver_U1(beta2, p)/mu + olver_U2(beta2, p)/(mu*mu);

  if(sum == 0.0) {
    result->val = 0.0;
    result->err = 0.0;
    *ln_multiplier = 0.0;
    return GSL_SUCCESS;
  }
  else {
    int stat_e = gsl_sf_exp_mult_e(ln_pre, sum, result);
    if(stat_e != GSL_SUCCESS) {
      result->val = sum;
      result->err = 2.0 * GSL_DBL_EPSILON * fabs(sum);
      *ln_multiplier = ln_pre;
    }
    else {
      *ln_multiplier = 0.0;
    }
    return lg_stat;
  }
}


/* Implementation of large tau asymptotic
 *
 * A_n^{-mu}, B_n^{-mu}  [Olver, p.465, 469]
 */

inline
static double olver_B0_xi(double mu, double xi)
{
  return (1.0 - 4.0*mu*mu)/(8.0*xi) * (1.0/tanh(xi) - 1.0/xi);
}

static double olver_A1_xi(double mu, double xi, double x)
{
  double B = olver_B0_xi(mu, xi);
  double psi;
  if(fabs(x - 1.0) < GSL_ROOT4_DBL_EPSILON) {
    double y = x - 1.0;
    double s = -1.0/3.0 + y*(2.0/15.0 - y *(61.0/945.0 - 452.0/14175.0*y));
    psi = (4.0*mu*mu - 1.0)/16.0 * s;
  }
  else {
    psi = (4.0*mu*mu - 1.0)/16.0 * (1.0/(x*x-1.0) - 1.0/(xi*xi));
  }
  return 0.5*xi*xi*B*B + (mu+0.5)*B - psi + mu/6.0*(0.25 - mu*mu);
}

inline
static double olver_B0_th(double mu, double theta)
{
  return -(1.0 - 4.0*mu*mu)/(8.0*theta) * (1.0/tan(theta) - 1.0/theta);
}

static double olver_A1_th(double mu, double theta, double x)
{
  double B = olver_B0_th(mu, theta);
  double psi;
  if(fabs(x - 1.0) < GSL_ROOT4_DBL_EPSILON) {
    double y = 1.0 - x;
    double s = -1.0/3.0 + y*(2.0/15.0 - y *(61.0/945.0 - 452.0/14175.0*y));
    psi = (4.0*mu*mu - 1.0)/16.0 * s;
  }
  else {
    psi = (4.0*mu*mu - 1.0)/16.0 * (1.0/(x*x-1.0) + 1.0/(theta*theta));
  }
  return -0.5*theta*theta*B*B + (mu+0.5)*B - psi + mu/6.0*(0.25 - mu*mu);
}


/* Large tau uniform asymptotics
 * P^{-mu}_{-1/2 + I tau}
 * 1 < x
 * tau -> Inf 
 * [Olver, p. 469]
 */
int
gsl_sf_conicalP_xgt1_neg_mu_largetau_e(const double mu, const double tau,
                                          const double x, double acosh_x,
                                          gsl_sf_result * result, double * ln_multiplier)
{
  double xi = acosh_x;
  double ln_xi_pre;
  double ln_pre;
  double sumA, sumB, sum;
  double arg;
  gsl_sf_result J_mup1;
  gsl_sf_result J_mu;
  double J_mum1;

  if(xi < GSL_ROOT4_DBL_EPSILON) {
    ln_xi_pre = -xi*xi/6.0;           /* log(1.0 - xi*xi/6.0) */
  }
  else {
    gsl_sf_result lnshxi;
    gsl_sf_lnsinh_e(xi, &lnshxi);
    ln_xi_pre = log(xi) - lnshxi.val;     /* log(xi/sinh(xi) */
  }

  ln_pre = 0.5*ln_xi_pre - mu*log(tau);

  arg = tau*xi;

  gsl_sf_bessel_Jnu_e(mu + 1.0,   arg, &J_mup1);
  gsl_sf_bessel_Jnu_e(mu,         arg, &J_mu);
  J_mum1 = -J_mup1.val + 2.0*mu/arg*J_mu.val;      /* careful of mu < 1 */

  sumA = 1.0 - olver_A1_xi(-mu, xi, x)/(tau*tau);
  sumB = olver_B0_xi(-mu, xi);
  sum  = J_mu.val * sumA - xi/tau * J_mum1 * sumB;

  if(sum == 0.0) {
    result->val = 0.0;
    result->err = 0.0;
    *ln_multiplier = 0.0;
    return GSL_SUCCESS;
  }
  else {
    int stat_e = gsl_sf_exp_mult_e(ln_pre, sum, result);
    if(stat_e != GSL_SUCCESS) {
      result->val = sum;
      result->err = 2.0 * GSL_DBL_EPSILON * fabs(sum);
      *ln_multiplier = ln_pre;
    }
    else {
      *ln_multiplier = 0.0;
    }
    return GSL_SUCCESS;
  }
}


/* Large tau uniform asymptotics
 * P^{-mu}_{-1/2 + I tau}
 * -1 < x < 1
 * tau -> Inf 
 * [Olver, p. 473]
 */
int
gsl_sf_conicalP_xlt1_neg_mu_largetau_e(const double mu, const double tau,
                                          const double x, const double acos_x,
                                          gsl_sf_result * result, double * ln_multiplier)
{
  double theta = acos_x;
  double ln_th_pre;
  double ln_pre;
  double sumA, sumB, sum, sumerr;
  double arg;
  gsl_sf_result I_mup1, I_mu;
  double I_mum1;

  if(theta < GSL_ROOT4_DBL_EPSILON) {
    ln_th_pre = theta*theta/6.0;   /* log(1.0 + theta*theta/6.0) */
  }
  else {
    ln_th_pre = log(theta/sin(theta));
  }

  ln_pre = 0.5 * ln_th_pre - mu * log(tau);

  arg = tau*theta;
  gsl_sf_bessel_Inu_e(mu + 1.0,   arg, &I_mup1);
  gsl_sf_bessel_Inu_e(mu,         arg, &I_mu);
  I_mum1 = I_mup1.val + 2.0*mu/arg * I_mu.val; /* careful of mu < 1 */

  sumA = 1.0 - olver_A1_th(-mu, theta, x)/(tau*tau);
  sumB = olver_B0_th(-mu, theta);
  sum  = I_mu.val * sumA - theta/tau * I_mum1 * sumB;
  sumerr  = fabs(I_mu.err * sumA);
  sumerr += fabs(I_mup1.err * theta/tau * sumB);
  sumerr += fabs(I_mu.err   * theta/tau * sumB * 2.0 * mu/arg);

  if(sum == 0.0) {
    result->val = 0.0;
    result->err = 0.0;
    *ln_multiplier = 0.0;
    return GSL_SUCCESS;
  }
  else {
    int stat_e = gsl_sf_exp_mult_e(ln_pre, sum, result);
    if(stat_e != GSL_SUCCESS) {
      result->val  = sum;
      result->err  = sumerr;
      result->err += GSL_DBL_EPSILON * fabs(sum);
      *ln_multiplier = ln_pre;
    }
    else {
      *ln_multiplier = 0.0;
    }
    return GSL_SUCCESS;
  }
}


/* Hypergeometric function which appears in the
 * large x expansion below:
 *
 *   2F1(1/4 - mu/2 - I tau/2, 3/4 - mu/2 - I tau/2, 1 - I tau, y)
 *
 * Note that for the usage below y = 1/x^2;
 */
static
int
conicalP_hyperg_large_x(const double mu, const double tau, const double y,
                        double * reF, double * imF)
{
  const int kmax = 1000;
  const double re_a = 0.25 - 0.5*mu;
  const double re_b = 0.75 - 0.5*mu;
  const double re_c = 1.0;
  const double im_a = -0.5*tau;
  const double im_b = -0.5*tau;
  const double im_c = -tau;

  double re_sum = 1.0;
  double im_sum = 0.0;
  double re_term = 1.0;
  double im_term = 0.0;
  int k;

  for(k=1; k<=kmax; k++) {
    double re_ak = re_a + k - 1.0;
    double re_bk = re_b + k - 1.0;
    double re_ck = re_c + k - 1.0;
    double im_ak = im_a;
    double im_bk = im_b;
    double im_ck = im_c;
    double den = re_ck*re_ck + im_ck*im_ck;
    double re_multiplier = ((re_ak*re_bk - im_ak*im_bk)*re_ck + im_ck*(im_ak*re_bk + re_ak*im_bk)) / den;
    double im_multiplier = ((im_ak*re_bk + re_ak*im_bk)*re_ck - im_ck*(re_ak*re_bk - im_ak*im_bk)) / den;
    double re_tmp = re_multiplier*re_term - im_multiplier*im_term;