lo-specfun.cc

Go to the documentation of this file.

////////////////////////////////////////////////////////////////////////
//
// Copyright (C) 1996-2025 The Octave Project Developers
//
// See the file COPYRIGHT.md in the top-level directory of this
// distribution or <https://octave.org/copyright/>.
//
// This file is part of Octave.
//
// Octave 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 3 of the License, or
// (at your option) any later version.
//
// Octave 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 Octave; see the file COPYING.  If not, see
// <https://www.gnu.org/licenses/>.
//
////////////////////////////////////////////////////////////////////////
 
#if defined (HAVE_CONFIG_H)
#  include "config.h"
#endif
 
#include <cmath>
 
#include <algorithm>
#include <limits>
#include <string>
 
#include "CColVector.h"
#include "CMatrix.h"
#include "CNDArray.h"
#include "Faddeeva.hh"
#include "dMatrix.h"
#include "dNDArray.h"
#include "dRowVector.h"
#include "f77-fcn.h"
#include "fCColVector.h"
#include "fCMatrix.h"
#include "fCNDArray.h"
#include "fMatrix.h"
#include "fNDArray.h"
#include "fRowVector.h"
#include "lo-amos-proto.h"
#include "lo-error.h"
#include "lo-ieee.h"
#include "lo-mappers.h"
#include "lo-slatec-proto.h"
#include "lo-specfun.h"
#include "mx-inlines.cc"
 
OCTAVE_BEGIN_NAMESPACE(octave)
 
OCTAVE_BEGIN_NAMESPACE(math)
 
static inline Complex
bessel_return_value (const Complex& val, octave_idx_type ierr)
{
  static const Complex inf_val
    = Complex (numeric_limits<double>::Inf (),
               numeric_limits<double>::Inf ());
 
  static const Complex nan_val
    = Complex (numeric_limits<double>::NaN (),
               numeric_limits<double>::NaN ());
 
  Complex retval;
 
  switch (ierr)
    {
    case 0:
    case 3:
    case 4:
      retval = val;
      break;
 
    case 2:
      retval = inf_val;
      break;
 
    default:
      retval = nan_val;
      break;
    }
 
  return retval;
}
 
static inline FloatComplex
bessel_return_value (const FloatComplex& val, octave_idx_type ierr)
{
  static const FloatComplex inf_val
    = FloatComplex (numeric_limits<float>::Inf (),
                    numeric_limits<float>::Inf ());
 
  static const FloatComplex nan_val
    = FloatComplex (numeric_limits<float>::NaN (),
                    numeric_limits<float>::NaN ());
 
  FloatComplex retval;
 
  switch (ierr)
    {
    case 0:
    case 3:
    case 4:
      retval = val;
      break;
 
    case 2:
      retval = inf_val;
      break;
 
    default:
      retval = nan_val;
      break;
    }
 
  return retval;
}
 
Complex
airy (const Complex& z, bool deriv, bool scaled, octave_idx_type& ierr)
{
  double ar = 0.0;
  double ai = 0.0;
 
  double zr = z.real ();
  double zi = z.imag ();
 
  F77_INT id = (deriv ? 1 : 0);
  F77_INT nz, t_ierr;
  F77_INT sc = (scaled ? 2 : 1);
 
  F77_FUNC (zairy, ZAIRY) (zr, zi, id, sc, ar, ai, nz, t_ierr);
 
  ierr = t_ierr;
 
  if (zi == 0.0 && (! scaled || zr >= 0.0))
    ai = 0.0;
 
  return bessel_return_value (Complex (ar, ai), ierr);
}
 
ComplexMatrix
airy (const ComplexMatrix& z, bool deriv, bool scaled,
      Array<octave_idx_type>& ierr)
{
  octave_idx_type nr = z.rows ();
  octave_idx_type nc = z.cols ();
 
  ComplexMatrix retval (nr, nc);
 
  ierr.resize (dim_vector (nr, nc));
 
  for (octave_idx_type j = 0; j < nc; j++)
    for (octave_idx_type i = 0; i < nr; i++)
      retval(i, j) = airy (z(i, j), deriv, scaled, ierr(i, j));
 
  return retval;
}
 
ComplexNDArray
airy (const ComplexNDArray& z, bool deriv, bool scaled,
      Array<octave_idx_type>& ierr)
{
  const dim_vector& dv = z.dims ();
  octave_idx_type nel = dv.numel ();
  ComplexNDArray retval (dv);
 
  ierr.resize (dv);
 
  for (octave_idx_type i = 0; i < nel; i++)
    retval(i) = airy (z(i), deriv, scaled, ierr(i));
 
  return retval;
}
 
FloatComplex
airy (const FloatComplex& z, bool deriv, bool scaled,
      octave_idx_type& ierr)
{
  FloatComplex a;
 
  F77_INT id = (deriv ? 1 : 0);
  F77_INT nz, t_ierr;
  F77_INT sc = (scaled ? 2 : 1);
 
  F77_FUNC (cairy, CAIRY) (F77_CONST_CMPLX_ARG (&z), id, sc,
                           F77_CMPLX_ARG (&a), nz, t_ierr);
 
  ierr = t_ierr;
 
  float ar = a.real ();
  float ai = a.imag ();
 
  if (z.imag () == 0.0 && (! scaled || z.real () >= 0.0))
    ai = 0.0;
 
  return bessel_return_value (FloatComplex (ar, ai), ierr);
}
 
FloatComplexMatrix
airy (const FloatComplexMatrix& z, bool deriv, bool scaled,
      Array<octave_idx_type>& ierr)
{
  octave_idx_type nr = z.rows ();
  octave_idx_type nc = z.cols ();
 
  FloatComplexMatrix retval (nr, nc);
 
  ierr.resize (dim_vector (nr, nc));
 
  for (octave_idx_type j = 0; j < nc; j++)
    for (octave_idx_type i = 0; i < nr; i++)
      retval(i, j) = airy (z(i, j), deriv, scaled, ierr(i, j));
 
  return retval;
}
 
FloatComplexNDArray
airy (const FloatComplexNDArray& z, bool deriv, bool scaled,
      Array<octave_idx_type>& ierr)
{
  const dim_vector& dv = z.dims ();
  octave_idx_type nel = dv.numel ();
  FloatComplexNDArray retval (dv);
 
  ierr.resize (dv);
 
  for (octave_idx_type i = 0; i < nel; i++)
    retval(i) = airy (z(i), deriv, scaled, ierr(i));
 
  return retval;
}
 
static inline bool
is_integer_value (double x)
{
  return x == static_cast<double> (static_cast<long> (x));
}
 
static inline Complex
zbesj (const Complex& z, double alpha, int kode, octave_idx_type& ierr);
 
static inline Complex
zbesy (const Complex& z, double alpha, int kode, octave_idx_type& ierr);
 
static inline Complex
zbesi (const Complex& z, double alpha, int kode, octave_idx_type& ierr);
 
static inline Complex
zbesk (const Complex& z, double alpha, int kode, octave_idx_type& ierr);
 
static inline Complex
zbesh1 (const Complex& z, double alpha, int kode, octave_idx_type& ierr);
 
static inline Complex
zbesh2 (const Complex& z, double alpha, int kode, octave_idx_type& ierr);
 
static inline Complex
zbesj (const Complex& z, double alpha, int kode, octave_idx_type& ierr)
{
  Complex retval;
 
  if (alpha >= 0.0)
    {
      double yr = 0.0;
      double yi = 0.0;
 
      F77_INT nz, t_ierr;
 
      double zr = z.real ();
      double zi = z.imag ();
 
      F77_FUNC (zbesj, ZBESJ) (zr, zi, alpha, kode, 1, &yr, &yi, nz, t_ierr);
 
      ierr = t_ierr;
 
      if (zi == 0.0 && zr >= 0.0)
        yi = 0.0;
 
      retval = bessel_return_value (Complex (yr, yi), ierr);
    }
  else if (is_integer_value (alpha))
    {
      // zbesy can overflow as z->0, and cause troubles for generic case below
      alpha = -alpha;
      Complex tmp = zbesj (z, alpha, kode, ierr);
      if ((static_cast<long> (alpha)) & 1)
        tmp = - tmp;
      retval = bessel_return_value (tmp, ierr);
    }
  else
    {
      alpha = -alpha;
 
      Complex tmp = cos (M_PI * alpha) * zbesj (z, alpha, kode, ierr);
 
      if (ierr == 0 || ierr == 3)
        {
          tmp -= sin (M_PI * alpha) * zbesy (z, alpha, kode, ierr);
 
          retval = bessel_return_value (tmp, ierr);
        }
      else
        retval = Complex (numeric_limits<double>::NaN (),
                          numeric_limits<double>::NaN ());
    }
 
  return retval;
}
 
static inline Complex
zbesy (const Complex& z, double alpha, int kode, octave_idx_type& ierr)
{
  Complex retval;
 
  if (alpha >= 0.0)
    {
      double yr = 0.0;
      double yi = 0.0;
 
      F77_INT nz, t_ierr;
 
      double wr, wi;
 
      double zr = z.real ();
      double zi = z.imag ();
 
      ierr = 0;
 
      if (zr == 0.0 && zi == 0.0)
        {
          yr = -numeric_limits<double>::Inf ();
          yi = 0.0;
        }
      else
        {
          F77_FUNC (zbesy, ZBESY) (zr, zi, alpha, kode, 1, &yr, &yi, nz,
                                   &wr, &wi, t_ierr);
 
          ierr = t_ierr;
 
          if (zi == 0.0 && zr >= 0.0)
            yi = 0.0;
        }
 
      return bessel_return_value (Complex (yr, yi), ierr);
    }
  else if (is_integer_value (alpha - 0.5))
    {
      // zbesy can overflow as z->0, and cause troubles for generic case below
      alpha = -alpha;
      Complex tmp = zbesj (z, alpha, kode, ierr);
      if ((static_cast<long> (alpha - 0.5)) & 1)
        tmp = - tmp;
      retval = bessel_return_value (tmp, ierr);
    }
  else
    {
      alpha = -alpha;
 
      Complex tmp = cos (M_PI * alpha) * zbesy (z, alpha, kode, ierr);
 
      if (ierr == 0 || ierr == 3)
        {
          tmp += sin (M_PI * alpha) * zbesj (z, alpha, kode, ierr);
 
          retval = bessel_return_value (tmp, ierr);
        }
      else
        retval = Complex (numeric_limits<double>::NaN (),
                          numeric_limits<double>::NaN ());
    }
 
  return retval;
}
 
static inline Complex
zbesi (const Complex& z, double alpha, int kode, octave_idx_type& ierr)
{
  Complex retval;
 
  if (alpha >= 0.0)
    {
      double yr = 0.0;
      double yi = 0.0;
 
      F77_INT nz, t_ierr;
 
      double zr = z.real ();
      double zi = z.imag ();
 
      F77_FUNC (zbesi, ZBESI) (zr, zi, alpha, kode, 1, &yr, &yi, nz, t_ierr);
 
      ierr = t_ierr;
 
      if (zi == 0.0 && zr >= 0.0)
        yi = 0.0;
 
      retval = bessel_return_value (Complex (yr, yi), ierr);
    }
  else if (is_integer_value (alpha))
    {
      // zbesi can overflow as z->0, and cause troubles for generic case below
      alpha = -alpha;
      Complex tmp = zbesi (z, alpha, kode, ierr);
      retval = bessel_return_value (tmp, ierr);
    }
  else
    {
      alpha = -alpha;
 
      Complex tmp = zbesi (z, alpha, kode, ierr);
 
      if (ierr == 0 || ierr == 3)
        {
          Complex tmp2 = (2.0 / M_PI) * sin (M_PI * alpha)
                         * zbesk (z, alpha, kode, ierr);
 
          if (kode == 2)
            {
              // Compensate for different scaling factor of besk.
              tmp2 *= exp (-z - std::abs (z.real ()));
            }
 
          tmp += tmp2;
 
          retval = bessel_return_value (tmp, ierr);
        }
      else
        retval = Complex (numeric_limits<double>::NaN (),
                          numeric_limits<double>::NaN ());
    }
 
  return retval;
}
 
static inline Complex
zbesk (const Complex& z, double alpha, int kode, octave_idx_type& ierr)
{
  Complex retval;
 
  if (alpha >= 0.0)
    {
      double yr = 0.0;
      double yi = 0.0;
 
      F77_INT nz, t_ierr;
 
      double zr = z.real ();
      double zi = z.imag ();
 
      ierr = 0;
 
      if (zr == 0.0 && zi == 0.0)
        {
          yr = numeric_limits<double>::Inf ();
          yi = 0.0;
        }
      else
        {
          F77_FUNC (zbesk, ZBESK) (zr, zi, alpha, kode, 1, &yr, &yi, nz,
                                   t_ierr);
 
          ierr = t_ierr;
 
          if (zi == 0.0 && zr >= 0.0)
            yi = 0.0;
        }
 
      retval = bessel_return_value (Complex (yr, yi), ierr);
    }
  else
    {
      Complex tmp = zbesk (z, -alpha, kode, ierr);
 
      retval = bessel_return_value (tmp, ierr);
    }
 
  return retval;
}
 
static inline Complex
zbesh1 (const Complex& z, double alpha, int kode, octave_idx_type& ierr)
{
  Complex retval;
 
  if (alpha >= 0.0)
    {
      double yr = 0.0;
      double yi = 0.0;
 
      F77_INT nz, t_ierr;
 
      double zr = z.real ();
      double zi = z.imag ();
 
      F77_FUNC (zbesh, ZBESH) (zr, zi, alpha, kode, 1, 1, &yr, &yi, nz,
                               t_ierr);
 
      ierr = t_ierr;
 
      retval = bessel_return_value (Complex (yr, yi), ierr);
    }
  else
    {
      alpha = -alpha;
 
      static const Complex eye = Complex (0.0, 1.0);
 
      Complex tmp = exp (M_PI * alpha * eye) * zbesh1 (z, alpha, kode, ierr);
 
      retval = bessel_return_value (tmp, ierr);
    }
 
  return retval;
}
 
static inline Complex
zbesh2 (const Complex& z, double alpha, int kode, octave_idx_type& ierr)
{
  Complex retval;
 
  if (alpha >= 0.0)
    {
      double yr = 0.0;
      double yi = 0.0;
 
      F77_INT nz, t_ierr;
 
      double zr = z.real ();
      double zi = z.imag ();
 
      F77_FUNC (zbesh, ZBESH) (zr, zi, alpha, kode, 2, 1, &yr, &yi, nz,
                               t_ierr);
 
      ierr = t_ierr;
 
      retval = bessel_return_value (Complex (yr, yi), ierr);
    }
  else
    {
      alpha = -alpha;
 
      static const Complex eye = Complex (0.0, 1.0);
 
      Complex tmp = exp (-M_PI * alpha * eye) * zbesh2 (z, alpha, kode, ierr);
 
      retval = bessel_return_value (tmp, ierr);
    }
 
  return retval;
}
 
typedef Complex (*dptr) (const Complex&, double, int, octave_idx_type&);
 
static inline Complex
do_bessel (dptr f, const char *, double alpha, const Complex& x,
           bool scaled, octave_idx_type& ierr)
{
  Complex retval;
 
  retval = f (x, alpha, (scaled ? 2 : 1), ierr);
 
  return retval;
}
 
static inline ComplexMatrix
do_bessel (dptr f, const char *, double alpha, const ComplexMatrix& x,
           bool scaled, Array<octave_idx_type>& ierr)
{
  octave_idx_type nr = x.rows ();
  octave_idx_type nc = x.cols ();
 
  ComplexMatrix retval (nr, nc);
 
  ierr.resize (dim_vector (nr, nc));
 
  for (octave_idx_type j = 0; j < nc; j++)
    for (octave_idx_type i = 0; i < nr; i++)
      retval(i, j) = f (x(i, j), alpha, (scaled ? 2 : 1), ierr(i, j));
 
  return retval;
}
 
static inline ComplexMatrix
do_bessel (dptr f, const char *, const Matrix& alpha, const Complex& x,
           bool scaled, Array<octave_idx_type>& ierr)
{
  octave_idx_type nr = alpha.rows ();
  octave_idx_type nc = alpha.cols ();
 
  ComplexMatrix retval (nr, nc);
 
  ierr.resize (dim_vector (nr, nc));
 
  for (octave_idx_type j = 0; j < nc; j++)
    for (octave_idx_type i = 0; i < nr; i++)
      retval(i, j) = f (x, alpha(i, j), (scaled ? 2 : 1), ierr(i, j));
 
  return retval;
}
 
static inline ComplexMatrix
do_bessel (dptr f, const char *fn, const Matrix& alpha,
           const ComplexMatrix& x, bool scaled, Array<octave_idx_type>& ierr)
{
  ComplexMatrix retval;
 
  octave_idx_type x_nr = x.rows ();
  octave_idx_type x_nc = x.cols ();
 
  octave_idx_type alpha_nr = alpha.rows ();
  octave_idx_type alpha_nc = alpha.cols ();
 
  if (x_nr != alpha_nr || x_nc != alpha_nc)
    (*current_liboctave_error_handler)
      ("%s: the sizes of alpha and x must conform", fn);
 
  octave_idx_type nr = x_nr;
  octave_idx_type nc = x_nc;
 
  retval.resize (nr, nc);
 
  ierr.resize (dim_vector (nr, nc));
 
  for (octave_idx_type j = 0; j < nc; j++)
    for (octave_idx_type i = 0; i < nr; i++)
      retval(i, j) = f (x(i, j), alpha(i, j), (scaled ? 2 : 1), ierr(i, j));
 
  return retval;
}
 
static inline ComplexNDArray
do_bessel (dptr f, const char *, double alpha, const ComplexNDArray& x,
           bool scaled, Array<octave_idx_type>& ierr)
{
  const dim_vector& dv = x.dims ();
  octave_idx_type nel = dv.numel ();
  ComplexNDArray retval (dv);
 
  ierr.resize (dv);
 
  for (octave_idx_type i = 0; i < nel; i++)
    retval(i) = f (x(i), alpha, (scaled ? 2 : 1), ierr(i));
 
  return retval;
}
 
static inline ComplexNDArray
do_bessel (dptr f, const char *, const NDArray& alpha, const Complex& x,
           bool scaled, Array<octave_idx_type>& ierr)
{
  const dim_vector& dv = alpha.dims ();
  octave_idx_type nel = dv.numel ();
  ComplexNDArray retval (dv);
 
  ierr.resize (dv);
 
  for (octave_idx_type i = 0; i < nel; i++)
    retval(i) = f (x, alpha(i), (scaled ? 2 : 1), ierr(i));
 
  return retval;
}
 
static inline ComplexNDArray
do_bessel (dptr f, const char *fn, const NDArray& alpha,
           const ComplexNDArray& x, bool scaled, Array<octave_idx_type>& ierr)
{
  const dim_vector& dv = x.dims ();
  ComplexNDArray retval;
 
  if (dv != alpha.dims ())
    (*current_liboctave_error_handler)
      ("%s: the sizes of alpha and x must conform", fn);
 
  octave_idx_type nel = dv.numel ();
 
  retval.resize (dv);
  ierr.resize (dv);
 
  for (octave_idx_type i = 0; i < nel; i++)
    retval(i) = f (x(i), alpha(i), (scaled ? 2 : 1), ierr(i));
 
  return retval;
}
 
static inline ComplexMatrix
do_bessel (dptr f, const char *, const RowVector& alpha,
           const ComplexColumnVector& x, bool scaled,
           Array<octave_idx_type>& ierr)
{
  octave_idx_type nr = x.numel ();
  octave_idx_type nc = alpha.numel ();
 
  ComplexMatrix retval (nr, nc);
 
  ierr.resize (dim_vector (nr, nc));
 
  for (octave_idx_type j = 0; j < nc; j++)
    for (octave_idx_type i = 0; i < nr; i++)
      retval(i, j) = f (x(i), alpha(j), (scaled ? 2 : 1), ierr(i, j));
 
  return retval;
}
 
#define SS_BESSEL(name, fcn)                                            \
    Complex                                                             \
    name (double alpha, const Complex& x, bool scaled, octave_idx_type& ierr) \
    {                                                                   \
      return do_bessel (fcn, #name, alpha, x, scaled, ierr);            \
    }
 
#define SM_BESSEL(name, fcn)                                    \
    ComplexMatrix                                               \
    name (double alpha, const ComplexMatrix& x, bool scaled,    \
          Array<octave_idx_type>& ierr)                         \
    {                                                           \
      return do_bessel (fcn, #name, alpha, x, scaled, ierr);    \
    }
 
#define MS_BESSEL(name, fcn)                                    \
    ComplexMatrix                                               \
    name (const Matrix& alpha, const Complex& x, bool scaled,   \
          Array<octave_idx_type>& ierr)                         \
    {                                                           \
      return do_bessel (fcn, #name, alpha, x, scaled, ierr);    \
    }
 
#define MM_BESSEL(name, fcn)                                            \
    ComplexMatrix                                                       \
    name (const Matrix& alpha, const ComplexMatrix& x, bool scaled,     \
          Array<octave_idx_type>& ierr)                                 \
    {                                                                   \
      return do_bessel (fcn, #name, alpha, x, scaled, ierr);            \
    }
 
#define SN_BESSEL(name, fcn)                                    \
    ComplexNDArray                                              \
    name (double alpha, const ComplexNDArray& x, bool scaled,   \
          Array<octave_idx_type>& ierr)                         \
    {                                                           \
      return do_bessel (fcn, #name, alpha, x, scaled, ierr);    \
    }
 
#define NS_BESSEL(name, fcn)                                    \
    ComplexNDArray                                              \
    name (const NDArray& alpha, const Complex& x, bool scaled,  \
          Array<octave_idx_type>& ierr)                         \
    {                                                           \
      return do_bessel (fcn, #name, alpha, x, scaled, ierr);    \
    }
 
#define NN_BESSEL(name, fcn)                                            \
    ComplexNDArray                                                      \
    name (const NDArray& alpha, const ComplexNDArray& x, bool scaled,   \
          Array<octave_idx_type>& ierr)                                 \
    {                                                                   \
      return do_bessel (fcn, #name, alpha, x, scaled, ierr);            \
    }
 
#define RC_BESSEL(name, fcn)                                            \
    ComplexMatrix                                                       \
    name (const RowVector& alpha, const ComplexColumnVector& x, bool scaled, \
          Array<octave_idx_type>& ierr)                                 \
    {                                                                   \
      return do_bessel (fcn, #name, alpha, x, scaled, ierr);            \
    }
 
#define ALL_BESSEL(name, fcn)                   \
    SS_BESSEL (name, fcn)                       \
    SM_BESSEL (name, fcn)                       \
    MS_BESSEL (name, fcn)                       \
    MM_BESSEL (name, fcn)                       \
    SN_BESSEL (name, fcn)                       \
    NS_BESSEL (name, fcn)                       \
    NN_BESSEL (name, fcn)                       \
    RC_BESSEL (name, fcn)
 
ALL_BESSEL (besselj, zbesj)
ALL_BESSEL (bessely, zbesy)
ALL_BESSEL (besseli, zbesi)
ALL_BESSEL (besselk, zbesk)
ALL_BESSEL (besselh1, zbesh1)
ALL_BESSEL (besselh2, zbesh2)
 
#undef ALL_BESSEL
#undef SS_BESSEL
#undef SM_BESSEL
#undef MS_BESSEL
#undef MM_BESSEL
#undef SN_BESSEL
#undef NS_BESSEL
#undef NN_BESSEL
#undef RC_BESSEL
 
static inline FloatComplex
cbesj (const FloatComplex& z, float alpha, int kode, octave_idx_type& ierr);
 
static inline FloatComplex
cbesy (const FloatComplex& z, float alpha, int kode, octave_idx_type& ierr);
 
static inline FloatComplex
cbesi (const FloatComplex& z, float alpha, int kode, octave_idx_type& ierr);
 
static inline FloatComplex
cbesk (const FloatComplex& z, float alpha, int kode, octave_idx_type& ierr);
 
static inline FloatComplex
cbesh1 (const FloatComplex& z, float alpha, int kode, octave_idx_type& ierr);
 
static inline FloatComplex
cbesh2 (const FloatComplex& z, float alpha, int kode, octave_idx_type& ierr);
 
static inline bool
is_integer_value (float x)
{
  return x == static_cast<float> (static_cast<long> (x));
}
 
static inline FloatComplex
cbesj (const FloatComplex& z, float alpha, int kode, octave_idx_type& ierr)
{
  FloatComplex retval;
 
  if (alpha >= 0.0)
    {
      FloatComplex y = 0.0;
 
      F77_INT nz, t_ierr;
 
      F77_FUNC (cbesj, CBESJ) (F77_CONST_CMPLX_ARG (&z), alpha, kode, 1,
                               F77_CMPLX_ARG (&y), nz, t_ierr);
 
      ierr = t_ierr;
 
      if (z.imag () == 0.0 && z.real () >= 0.0)
        y = FloatComplex (y.real (), 0.0);
 
      retval = bessel_return_value (y, ierr);
    }
  else if (is_integer_value (alpha))
    {
      // zbesy can overflow as z->0, and cause troubles for generic case below
      alpha = -alpha;
      FloatComplex tmp = cbesj (z, alpha, kode, ierr);
      if ((static_cast<long> (alpha)) & 1)
        tmp = - tmp;
      retval = bessel_return_value (tmp, ierr);
    }
  else
    {
      alpha = -alpha;
 
      FloatComplex tmp = cosf (static_cast<float> (M_PI) * alpha)
                         * cbesj (z, alpha, kode, ierr);
 
      if (ierr == 0 || ierr == 3)
        {
          tmp -= sinf (static_cast<float> (M_PI) * alpha)
                 * cbesy (z, alpha, kode, ierr);
 
          retval = bessel_return_value (tmp, ierr);
        }
      else
        retval = FloatComplex (numeric_limits<float>::NaN (),
                               numeric_limits<float>::NaN ());
    }
 
  return retval;
}
 
static inline FloatComplex
cbesy (const FloatComplex& z, float alpha, int kode, octave_idx_type& ierr)
{
  FloatComplex retval;
 
  if (alpha >= 0.0)
    {
      FloatComplex y = 0.0;
 
      F77_INT nz, t_ierr;
 
      FloatComplex w;
 
      ierr = 0;
 
      if (z.real () == 0.0 && z.imag () == 0.0)
        {
          y = FloatComplex (-numeric_limits<float>::Inf (), 0.0);
        }
      else
        {
          F77_FUNC (cbesy, CBESY) (F77_CONST_CMPLX_ARG (&z), alpha, kode, 1,
                                   F77_CMPLX_ARG (&y), nz,
                                   F77_CMPLX_ARG (&w), t_ierr);
 
          ierr = t_ierr;
 
          if (z.imag () == 0.0 && z.real () >= 0.0)
            y = FloatComplex (y.real (), 0.0);
        }
 
      return bessel_return_value (y, ierr);
    }
  else if (is_integer_value (alpha - 0.5))
    {
      // zbesy can overflow as z->0, and cause troubles for generic case below
      alpha = -alpha;
      FloatComplex tmp = cbesj (z, alpha, kode, ierr);
      if ((static_cast<long> (alpha - 0.5)) & 1)
        tmp = - tmp;
      retval = bessel_return_value (tmp, ierr);
    }
  else
    {
      alpha = -alpha;
 
      FloatComplex tmp = cosf (static_cast<float> (M_PI) * alpha)
                         * cbesy (z, alpha, kode, ierr);
 
      if (ierr == 0 || ierr == 3)
        {
          tmp += sinf (static_cast<float> (M_PI) * alpha)
                 * cbesj (z, alpha, kode, ierr);
 
          retval = bessel_return_value (tmp, ierr);
        }
      else
        retval = FloatComplex (numeric_limits<float>::NaN (),
                               numeric_limits<float>::NaN ());
    }
 
  return retval;
}
 
static inline FloatComplex
cbesi (const FloatComplex& z, float alpha, int kode, octave_idx_type& ierr)
{
  FloatComplex retval;
 
  if (alpha >= 0.0)
    {
      FloatComplex y = 0.0;
 
      F77_INT nz, t_ierr;
 
      F77_FUNC (cbesi, CBESI) (F77_CONST_CMPLX_ARG (&z), alpha, kode, 1,
                               F77_CMPLX_ARG (&y), nz, t_ierr);
 
      ierr = t_ierr;
 
      if (z.imag () == 0.0 && z.real () >= 0.0)
        y = FloatComplex (y.real (), 0.0);
 
      retval = bessel_return_value (y, ierr);
    }
  else
    {
      alpha = -alpha;
 
      FloatComplex tmp = cbesi (z, alpha, kode, ierr);
 
      if (ierr == 0 || ierr == 3)
        {
          FloatComplex tmp2 = static_cast<float> (2.0 / M_PI)
                              * sinf (static_cast<float> (M_PI) * alpha)
                              * cbesk (z, alpha, kode, ierr);
 
          if (kode == 2)
            {
              // Compensate for different scaling factor of besk.
              tmp2 *= exp (-z - std::abs (z.real ()));
            }
 
          tmp += tmp2;
 
          retval = bessel_return_value (tmp, ierr);
        }
      else
        retval = FloatComplex (numeric_limits<float>::NaN (),
                               numeric_limits<float>::NaN ());
    }
 
  return retval;
}
 
static inline FloatComplex
cbesk (const FloatComplex& z, float alpha, int kode, octave_idx_type& ierr)
{
  FloatComplex retval;
 
  if (alpha >= 0.0)
    {
      FloatComplex y = 0.0;
 
      F77_INT nz, t_ierr;
 
      ierr = 0;
 
      if (z.real () == 0.0 && z.imag () == 0.0)
        {
          y = FloatComplex (numeric_limits<float>::Inf (), 0.0);
        }
      else
        {
          F77_FUNC (cbesk, CBESK) (F77_CONST_CMPLX_ARG (&z), alpha, kode, 1,
                                   F77_CMPLX_ARG (&y), nz, t_ierr);
 
          ierr = t_ierr;
 
          if (z.imag () == 0.0 && z.real () >= 0.0)
            y = FloatComplex (y.real (), 0.0);
        }
 
      retval = bessel_return_value (y, ierr);
    }
  else
    {
      FloatComplex tmp = cbesk (z, -alpha, kode, ierr);
 
      retval = bessel_return_value (tmp, ierr);
    }
 
  return retval;
}
 
static inline FloatComplex
cbesh1 (const FloatComplex& z, float alpha, int kode, octave_idx_type& ierr)
{
  FloatComplex retval;
 
  if (alpha >= 0.0)
    {
      FloatComplex y = 0.0;
 
      F77_INT nz, t_ierr;
 
      F77_FUNC (cbesh, CBESH) (F77_CONST_CMPLX_ARG (&z), alpha, kode, 1, 1,
                               F77_CMPLX_ARG (&y), nz, t_ierr);
 
      ierr = t_ierr;
 
      retval = bessel_return_value (y, ierr);
    }
  else
    {
      alpha = -alpha;
 
      static const FloatComplex eye = FloatComplex (0.0, 1.0);
 
      FloatComplex tmp = exp (static_cast<float> (M_PI) * alpha * eye)
                         * cbesh1 (z, alpha, kode, ierr);
 
      retval = bessel_return_value (tmp, ierr);
    }
 
  return retval;
}
 
static inline FloatComplex
cbesh2 (const FloatComplex& z, float alpha, int kode, octave_idx_type& ierr)
{
  FloatComplex retval;
 
  if (alpha >= 0.0)
    {
      FloatComplex y = 0.0;
 
      F77_INT nz, t_ierr;
 
      F77_FUNC (cbesh, CBESH) (F77_CONST_CMPLX_ARG (&z), alpha, kode, 2, 1,
                               F77_CMPLX_ARG (&y), nz, t_ierr);
 
      ierr = t_ierr;
 
      retval = bessel_return_value (y, ierr);
    }
  else
    {
      alpha = -alpha;
 
      static const FloatComplex eye = FloatComplex (0.0, 1.0);
 
      FloatComplex tmp = exp (-static_cast<float> (M_PI) * alpha * eye)
                         * cbesh2 (z, alpha, kode, ierr);
 
      retval = bessel_return_value (tmp, ierr);
    }
 
  return retval;
}
 
typedef FloatComplex (*fptr) (const FloatComplex&, float, int,
                              octave_idx_type&);
 
static inline FloatComplex
do_bessel (fptr f, const char *, float alpha, const FloatComplex& x,
           bool scaled, octave_idx_type& ierr)
{
  FloatComplex retval;
 
  retval = f (x, alpha, (scaled ? 2 : 1), ierr);
 
  return retval;
}
 
static inline FloatComplexMatrix
do_bessel (fptr f, const char *, float alpha, const FloatComplexMatrix& x,
           bool scaled, Array<octave_idx_type>& ierr)
{
  octave_idx_type nr = x.rows ();
  octave_idx_type nc = x.cols ();
 
  FloatComplexMatrix retval (nr, nc);
 
  ierr.resize (dim_vector (nr, nc));
 
  for (octave_idx_type j = 0; j < nc; j++)
    for (octave_idx_type i = 0; i < nr; i++)
      retval(i, j) = f (x(i, j), alpha, (scaled ? 2 : 1), ierr(i, j));
 
  return retval;
}
 
static inline FloatComplexMatrix
do_bessel (fptr f, const char *, const FloatMatrix& alpha,
           const FloatComplex& x,
           bool scaled, Array<octave_idx_type>& ierr)
{
  octave_idx_type nr = alpha.rows ();
  octave_idx_type nc = alpha.cols ();
 
  FloatComplexMatrix retval (nr, nc);
 
  ierr.resize (dim_vector (nr, nc));
 
  for (octave_idx_type j = 0; j < nc; j++)
    for (octave_idx_type i = 0; i < nr; i++)
      retval(i, j) = f (x, alpha(i, j), (scaled ? 2 : 1), ierr(i, j));
 
  return retval;
}
 
static inline FloatComplexMatrix
do_bessel (fptr f, const char *fn, const FloatMatrix& alpha,
           const FloatComplexMatrix& x, bool scaled,
           Array<octave_idx_type>& ierr)
{
  FloatComplexMatrix retval;
 
  octave_idx_type x_nr = x.rows ();
  octave_idx_type x_nc = x.cols ();
 
  octave_idx_type alpha_nr = alpha.rows ();
  octave_idx_type alpha_nc = alpha.cols ();
 
  if (x_nr != alpha_nr || x_nc != alpha_nc)
    (*current_liboctave_error_handler)
      ("%s: the sizes of alpha and x must conform", fn);
 
  octave_idx_type nr = x_nr;
  octave_idx_type nc = x_nc;
 
  retval.resize (nr, nc);
 
  ierr.resize (dim_vector (nr, nc));
 
  for (octave_idx_type j = 0; j < nc; j++)
    for (octave_idx_type i = 0; i < nr; i++)
      retval(i, j) = f (x(i, j), alpha(i, j), (scaled ? 2 : 1), ierr(i, j));
 
  return retval;
}
 
static inline FloatComplexNDArray
do_bessel (fptr f, const char *, float alpha, const FloatComplexNDArray& x,
           bool scaled, Array<octave_idx_type>& ierr)
{
  const dim_vector& dv = x.dims ();
  octave_idx_type nel = dv.numel ();
  FloatComplexNDArray retval (dv);
 
  ierr.resize (dv);
 
  for (octave_idx_type i = 0; i < nel; i++)
    retval(i) = f (x(i), alpha, (scaled ? 2 : 1), ierr(i));
 
  return retval;
}
 
static inline FloatComplexNDArray
do_bessel (fptr f, const char *, const FloatNDArray& alpha,
           const FloatComplex& x, bool scaled, Array<octave_idx_type>& ierr)
{
  const dim_vector& dv = alpha.dims ();
  octave_idx_type nel = dv.numel ();
  FloatComplexNDArray retval (dv);
 
  ierr.resize (dv);
 
  for (octave_idx_type i = 0; i < nel; i++)
    retval(i) = f (x, alpha(i), (scaled ? 2 : 1), ierr(i));
 
  return retval;
}
 
static inline FloatComplexNDArray
do_bessel (fptr f, const char *fn, const FloatNDArray& alpha,
           const FloatComplexNDArray& x, bool scaled,
           Array<octave_idx_type>& ierr)
{
  const dim_vector& dv = x.dims ();
  FloatComplexNDArray retval;
 
  if (dv != alpha.dims ())
    (*current_liboctave_error_handler)
      ("%s: the sizes of alpha and x must conform", fn);
 
  octave_idx_type nel = dv.numel ();
 
  retval.resize (dv);
  ierr.resize (dv);
 
  for (octave_idx_type i = 0; i < nel; i++)
    retval(i) = f (x(i), alpha(i), (scaled ? 2 : 1), ierr(i));
 
  return retval;
}
 
static inline FloatComplexMatrix
do_bessel (fptr f, const char *, const FloatRowVector& alpha,
           const FloatComplexColumnVector& x, bool scaled,
           Array<octave_idx_type>& ierr)
{
  octave_idx_type nr = x.numel ();
  octave_idx_type nc = alpha.numel ();
 
  FloatComplexMatrix retval (nr, nc);
 
  ierr.resize (dim_vector (nr, nc));
 
  for (octave_idx_type j = 0; j < nc; j++)
    for (octave_idx_type i = 0; i < nr; i++)
      retval(i, j) = f (x(i), alpha(j), (scaled ? 2 : 1), ierr(i, j));
 
  return retval;
}
 
#define SS_BESSEL(name, fcn)                                    \
    FloatComplex                                                \
    name (float alpha, const FloatComplex& x, bool scaled,      \
          octave_idx_type& ierr)                                \
    {                                                           \
      return do_bessel (fcn, #name, alpha, x, scaled, ierr);    \
    }
 
#define SM_BESSEL(name, fcn)                                            \
    FloatComplexMatrix                                                  \
    name (float alpha, const FloatComplexMatrix& x, bool scaled,        \
          Array<octave_idx_type>& ierr)                                 \
    {                                                                   \
      return do_bessel (fcn, #name, alpha, x, scaled, ierr);            \
    }
 
#define MS_BESSEL(name, fcn)                                            \
    FloatComplexMatrix                                                  \
    name (const FloatMatrix& alpha, const FloatComplex& x, bool scaled, \
          Array<octave_idx_type>& ierr)                                 \
    {                                                                   \
      return do_bessel (fcn, #name, alpha, x, scaled, ierr);            \
    }
 
#define MM_BESSEL(name, fcn)                                            \
    FloatComplexMatrix                                                  \
    name (const FloatMatrix& alpha, const FloatComplexMatrix& x,        \
          bool scaled, Array<octave_idx_type>& ierr)                    \
    {                                                                   \
      return do_bessel (fcn, #name, alpha, x, scaled, ierr);            \
    }
 
#define SN_BESSEL(name, fcn)                                            \
    FloatComplexNDArray                                                 \
    name (float alpha, const FloatComplexNDArray& x, bool scaled,       \
          Array<octave_idx_type>& ierr)                                 \
    {                                                                   \
      return do_bessel (fcn, #name, alpha, x, scaled, ierr);            \
    }
 
#define NS_BESSEL(name, fcn)                                    \
    FloatComplexNDArray                                         \
    name (const FloatNDArray& alpha, const FloatComplex& x,     \
          bool scaled, Array<octave_idx_type>& ierr)            \
    {                                                           \
      return do_bessel (fcn, #name, alpha, x, scaled, ierr);    \
    }
 
#define NN_BESSEL(name, fcn)                                            \
    FloatComplexNDArray                                                 \
    name (const FloatNDArray& alpha, const FloatComplexNDArray& x,      \
          bool scaled, Array<octave_idx_type>& ierr)                    \
    {                                                                   \
      return do_bessel (fcn, #name, alpha, x, scaled, ierr);            \
    }
 
#define RC_BESSEL(name, fcn)                                    \
    FloatComplexMatrix                                          \
    name (const FloatRowVector& alpha,                          \
          const FloatComplexColumnVector& x, bool scaled,       \
          Array<octave_idx_type>& ierr)                         \
    {                                                           \
      return do_bessel (fcn, #name, alpha, x, scaled, ierr);    \
    }
 
#define ALL_BESSEL(name, fcn)                   \
    SS_BESSEL (name, fcn)                       \
    SM_BESSEL (name, fcn)                       \
    MS_BESSEL (name, fcn)                       \
    MM_BESSEL (name, fcn)                       \
    SN_BESSEL (name, fcn)                       \
    NS_BESSEL (name, fcn)                       \
    NN_BESSEL (name, fcn)                       \
    RC_BESSEL (name, fcn)
 
ALL_BESSEL (besselj, cbesj)
ALL_BESSEL (bessely, cbesy)
ALL_BESSEL (besseli, cbesi)
ALL_BESSEL (besselk, cbesk)
ALL_BESSEL (besselh1, cbesh1)
ALL_BESSEL (besselh2, cbesh2)
 
#undef ALL_BESSEL
#undef SS_BESSEL
#undef SM_BESSEL
#undef MS_BESSEL
#undef MM_BESSEL
#undef SN_BESSEL
#undef NS_BESSEL
#undef NN_BESSEL
#undef RC_BESSEL
 
Complex
biry (const Complex& z, bool deriv, bool scaled, octave_idx_type& ierr)
{
  double ar = 0.0;
  double ai = 0.0;
 
  double zr = z.real ();
  double zi = z.imag ();
 
  F77_INT id = (deriv ? 1 : 0);
  F77_INT t_ierr;
  F77_INT sc = (scaled ? 2 : 1);
 
  F77_FUNC (zbiry, ZBIRY) (zr, zi, id, sc, ar, ai, t_ierr);
 
  ierr = t_ierr;
 
  if (zi == 0.0 && (! scaled || zr >= 0.0))
    ai = 0.0;
 
  return bessel_return_value (Complex (ar, ai), ierr);
}
 
ComplexMatrix
biry (const ComplexMatrix& z, bool deriv, bool scaled,
      Array<octave_idx_type>& ierr)
{
  octave_idx_type nr = z.rows ();
  octave_idx_type nc = z.cols ();
 
  ComplexMatrix retval (nr, nc);
 
  ierr.resize (dim_vector (nr, nc));
 
  for (octave_idx_type j = 0; j < nc; j++)
    for (octave_idx_type i = 0; i < nr; i++)
      retval(i, j) = biry (z(i, j), deriv, scaled, ierr(i, j));
 
  return retval;
}
 
ComplexNDArray
biry (const ComplexNDArray& z, bool deriv, bool scaled,
      Array<octave_idx_type>& ierr)
{
  const dim_vector& dv = z.dims ();
  octave_idx_type nel = dv.numel ();
  ComplexNDArray retval (dv);
 
  ierr.resize (dv);
 
  for (octave_idx_type i = 0; i < nel; i++)
    retval(i) = biry (z(i), deriv, scaled, ierr(i));
 
  return retval;
}
 
FloatComplex
biry (const FloatComplex& z, bool deriv, bool scaled,
      octave_idx_type& ierr)
{
  FloatComplex a;
 
  F77_INT id = (deriv ? 1 : 0);
  F77_INT t_ierr;
  F77_INT sc = (scaled ? 2 : 1);
 
  F77_FUNC (cbiry, CBIRY) (F77_CONST_CMPLX_ARG (&z), id, sc,
                           F77_CMPLX_ARG (&a), t_ierr);
 
  ierr = t_ierr;
 
  float ar = a.real ();
  float ai = a.imag ();
 
  if (z.imag () == 0.0 && (! scaled || z.real () >= 0.0))
    ai = 0.0;
 
  return bessel_return_value (FloatComplex (ar, ai), ierr);
}
 
FloatComplexMatrix
biry (const FloatComplexMatrix& z, bool deriv, bool scaled,
      Array<octave_idx_type>& ierr)
{
  octave_idx_type nr = z.rows ();
  octave_idx_type nc = z.cols ();
 
  FloatComplexMatrix retval (nr, nc);
 
  ierr.resize (dim_vector (nr, nc));
 
  for (octave_idx_type j = 0; j < nc; j++)
    for (octave_idx_type i = 0; i < nr; i++)
      retval(i, j) = biry (z(i, j), deriv, scaled, ierr(i, j));
 
  return retval;
}
 
FloatComplexNDArray
biry (const FloatComplexNDArray& z, bool deriv, bool scaled,
      Array<octave_idx_type>& ierr)
{
  const dim_vector& dv = z.dims ();
  octave_idx_type nel = dv.numel ();
  FloatComplexNDArray retval (dv);
 
  ierr.resize (dv);
 
  for (octave_idx_type i = 0; i < nel; i++)
    retval(i) = biry (z(i), deriv, scaled, ierr(i));
 
  return retval;
}
 
// Real and complex Dawson function (= scaled erfi) from Faddeeva package
double
dawson (double x) { return Faddeeva::Dawson (x); }
float
dawson (float x) { return Faddeeva::Dawson (x); }
 
Complex
dawson (const Complex& x)
{
  return Faddeeva::Dawson (x);
}
 
FloatComplex
dawson (const FloatComplex& x)
{
  Complex xd (x.real (), x.imag ());
  Complex ret;
  ret = Faddeeva::Dawson (xd, std::numeric_limits<float>::epsilon ());
  return FloatComplex (ret.real (), ret.imag ());
}
 
void
ellipj (double u, double m, double& sn, double& cn, double& dn, double& err)
{
  static const int Nmax = 16;
  double m1, t=0, si_u, co_u, se_u, ta_u, b, c[Nmax], a[Nmax], phi;
  int n, Nn, ii;
 
  if (m < 0 || m > 1)
    {
      (*current_liboctave_warning_with_id_handler)
        ("Octave:ellipj-invalid-m",
         "ellipj: invalid M value, required value 0 <= M <= 1");
 
      sn = cn = dn = lo_ieee_nan_value ();
 
      return;
    }
 
  double sqrt_eps = std::sqrt (std::numeric_limits<double>::epsilon ());
  if (m < sqrt_eps)
    {
      // For small m, (Abramowitz and Stegun, Section 16.13)
      si_u = sin (u);
      co_u = cos (u);
      t = 0.25*m*(u - si_u*co_u);
      sn = si_u - t * co_u;
      cn = co_u + t * si_u;
      dn = 1 - 0.5*m*si_u*si_u;
    }
  else if ((1 - m) < sqrt_eps)
    {
      // For m1 = (1-m) small (Abramowitz and Stegun, Section 16.15)
      m1 = 1 - m;
      si_u = sinh (u);
      co_u = cosh (u);
      ta_u = tanh (u);
      se_u = 1/co_u;
      sn = ta_u + 0.25*m1*(si_u*co_u - u)*se_u*se_u;
      cn = se_u - 0.25*m1*(si_u*co_u - u)*ta_u*se_u;
      dn = se_u + 0.25*m1*(si_u*co_u + u)*ta_u*se_u;
    }
  else
    {
      // Arithmetic-Geometric Mean (AGM) algorithm
      //   (Abramowitz and Stegun, Section 16.4)
      a[0] = 1;
      b    = std::sqrt (1 - m);
      c[0] = std::sqrt (m);
      for (n = 1; n < Nmax; ++n)
        {
          a[n] = (a[n - 1] + b)/2;
          c[n] = (a[n - 1] - b)/2;
          b = std::sqrt (a[n - 1]*b);
          if (c[n]/a[n] < std::numeric_limits<double>::epsilon ()) break;
        }
      if (n >= Nmax - 1)
        {
          err = 1;
          return;
        }
      Nn = n;
      for (ii = 1; n > 0; ii *= 2, --n) {}  // ii = pow(2,Nn)
      phi = ii*a[Nn]*u;
      for (n = Nn; n > 0; --n)
        {
          phi = (std::asin ((c[n]/a[n])* sin (phi)) + phi)/2;
        }
      sn = sin (phi);
      cn = cos (phi);
      dn = std::sqrt (1 - m*sn*sn);
    }
}
 
void
ellipj (const Complex& u, double m, Complex& sn, Complex& cn, Complex& dn,
        double& err)
{
  double m1 = 1 - m, ss1, cc1, dd1;
 
  ellipj (u.imag (), m1, ss1, cc1, dd1, err);
  if (u.real () == 0)
    {
      // u is pure imag: Jacoby imag. transf.
      sn = Complex (0, ss1/cc1);
      cn = 1/cc1;         //    cn.imag = 0;
      dn = dd1/cc1;       //    dn.imag = 0;
    }
  else
    {
      // u is generic complex
      double ss, cc, dd, ddd;
 
      ellipj (u.real (), m, ss, cc, dd, err);
      ddd = cc1*cc1 + m*ss*ss*ss1*ss1;
      sn = Complex (ss*dd1/ddd, cc*dd*ss1*cc1/ddd);
      cn = Complex (cc*cc1/ddd, -ss*dd*ss1*dd1/ddd);
      dn = Complex (dd*cc1*dd1/ddd, -m*ss*cc*ss1/ddd);
    }
}
 
// Complex error function from the Faddeeva package
Complex
erf (const Complex& x)
{
  return Faddeeva::erf (x);
}
 
FloatComplex
erf (const FloatComplex& x)
{
  Complex xd (x.real (), x.imag ());
  Complex ret = Faddeeva::erf (xd, std::numeric_limits<float>::epsilon ());
  return FloatComplex (ret.real (), ret.imag ());
}
 
// Complex complementary error function from the Faddeeva package
Complex
erfc (const Complex& x)
{
  return Faddeeva::erfc (x);
}
 
FloatComplex
erfc (const FloatComplex& x)
{
  Complex xd (x.real (), x.imag ());
  Complex ret = Faddeeva::erfc (xd, std::numeric_limits<float>::epsilon ());
  return FloatComplex (ret.real (), ret.imag ());
}
 
// The algorithm for erfcinv is an adaptation of the erfinv algorithm
// above from P. J. Acklam.  It has been modified to run over the
// different input domain of erfcinv.  See the notes for erfinv for an
// explanation.
 
static double
do_erfcinv (double x, bool refine)
{
  // Coefficients of rational approximation.
  static const double a[] =
  {
    -2.806989788730439e+01,  1.562324844726888e+02,
      -1.951109208597547e+02,  9.783370457507161e+01,
      -2.168328665628878e+01,  1.772453852905383e+00
    };
  static const double b[] =
  {
    -5.447609879822406e+01,  1.615858368580409e+02,
      -1.556989798598866e+02,  6.680131188771972e+01,
      -1.328068155288572e+01
    };
  static const double c[] =
  {
    -5.504751339936943e-03, -2.279687217114118e-01,
      -1.697592457770869e+00, -1.802933168781950e+00,
      3.093354679843505e+00,  2.077595676404383e+00
    };
  static const double d[] =
  {
    7.784695709041462e-03,  3.224671290700398e-01,
    2.445134137142996e+00,  3.754408661907416e+00
  };
 
  static const double spi2 = 8.862269254527579e-01; // sqrt(pi)/2.
  static const double pbreak_lo = 0.04850;  // 1-pbreak
  static const double pbreak_hi = 1.95150;  // 1+pbreak
  double y;
 
  // Select case.
  if (x >= pbreak_lo && x <= pbreak_hi)
    {
      // Middle region.
      const double q = 0.5*(1-x), r = q*q;
      const double yn = (((((a[0]*r + a[1])*r + a[2])*r + a[3])*r + a[4])*r + a[5])*q;
      const double yd = ((((b[0]*r + b[1])*r + b[2])*r + b[3])*r + b[4])*r + 1.0;
      y = yn / yd;
    }
  else if (x > 0.0 && x < 2.0)
    {
      // Tail region.
      const double q = (x < 1
                        ? std::sqrt (-2*std::log (0.5*x))
                        : std::sqrt (-2*std::log (0.5*(2-x))));
 
      const double yn = ((((c[0]*q + c[1])*q + c[2])*q + c[3])*q + c[4])*q + c[5];
 
      const double yd = (((d[0]*q + d[1])*q + d[2])*q + d[3])*q + 1.0;
 
      y = yn / yd;
 
      if (x < pbreak_lo)
        y = -y;
    }
  else if (x == 0.0)
    return numeric_limits<double>::Inf ();
  else if (x == 2.0)
    return -numeric_limits<double>::Inf ();
  else
    return numeric_limits<double>::NaN ();
 
  if (refine)
    {
      // One iteration of Halley's method gives full precision.
      double u = (erf (y) - (1-x)) * spi2 * exp (y*y);
      y -= u / (1 + y*u);
    }
 
  return y;
}
 
double
erfcinv (double x)
{
  return do_erfcinv (x, true);
}
 
float
erfcinv (float x)
{
  return do_erfcinv (x, false);
}
 
// Real and complex scaled complementary error function from Faddeeva pkg.
double
erfcx (double x) { return Faddeeva::erfcx (x); }
float
erfcx (float x) { return Faddeeva::erfcx (x); }
 
Complex
erfcx (const Complex& x)
{
  return Faddeeva::erfcx (x);
}
 
FloatComplex
erfcx (const FloatComplex& x)
{
  Complex xd (x.real (), x.imag ());
  Complex ret;
  ret = Faddeeva::erfcx (xd, std::numeric_limits<float>::epsilon ());
  return FloatComplex (ret.real (), ret.imag ());
}
 
// Real and complex imaginary error function from Faddeeva package
double
erfi (double x) { return Faddeeva::erfi (x); }
float
erfi (float x) { return Faddeeva::erfi (x); }
 
Complex
erfi (const Complex& x)
{
  return Faddeeva::erfi (x);
}
 
FloatComplex
erfi (const FloatComplex& x)
{
  Complex xd (x.real (), x.imag ());
  Complex ret = Faddeeva::erfi (xd, std::numeric_limits<float>::epsilon ());
  return FloatComplex (ret.real (), ret.imag ());
}
 
// This algorithm is due to P. J. Acklam.
//
// See http://home.online.no/~pjacklam/notes/invnorm/
//
// The rational approximation has relative accuracy 1.15e-9 in the whole
// region.  For doubles, it is refined by a single step of Halley's 3rd
// order method.  For single precision, the accuracy is already OK, so
// we skip it to get faster evaluation.
 
static double
do_erfinv (double x, bool refine)
{
  // Coefficients of rational approximation.
  static const double a[] =
  {
    -2.806989788730439e+01,  1.562324844726888e+02,
      -1.951109208597547e+02,  9.783370457507161e+01,
      -2.168328665628878e+01,  1.772453852905383e+00
    };
  static const double b[] =
  {
    -5.447609879822406e+01,  1.615858368580409e+02,
      -1.556989798598866e+02,  6.680131188771972e+01,
      -1.328068155288572e+01
    };
  static const double c[] =
  {
    -5.504751339936943e-03, -2.279687217114118e-01,
      -1.697592457770869e+00, -1.802933168781950e+00,
      3.093354679843505e+00,  2.077595676404383e+00
    };
  static const double d[] =
  {
    7.784695709041462e-03,  3.224671290700398e-01,
    2.445134137142996e+00,  3.754408661907416e+00
  };
 
  static const double spi2 = 8.862269254527579e-01; // sqrt(pi)/2.
  static const double pbreak = 0.95150;
  double ax = fabs (x), y;
 
  // Select case.
  if (ax <= pbreak)
    {
      // Middle region.
      const double q = 0.5 * x, r = q*q;
      const double yn = (((((a[0]*r + a[1])*r + a[2])*r + a[3])*r + a[4])*r + a[5])*q;
      const double yd = ((((b[0]*r + b[1])*r + b[2])*r + b[3])*r + b[4])*r + 1.0;
      y = yn / yd;
    }
  else if (ax < 1.0)
    {
      // Tail region.
      const double q = std::sqrt (-2*std::log (0.5*(1-ax)));
      const double yn = ((((c[0]*q + c[1])*q + c[2])*q + c[3])*q + c[4])*q + c[5];
      const double yd = (((d[0]*q + d[1])*q + d[2])*q + d[3])*q + 1.0;
      y = yn / yd * math::signum (-x);
    }
  else if (ax == 1.0)
    return numeric_limits<double>::Inf () * math::signum (x);
  else
    return numeric_limits<double>::NaN ();
 
  if (refine)
    {
      // One iteration of Halley's method gives full precision.
      double u = (erf (y) - x) * spi2 * exp (y*y);
      y -= u / (1 + y*u);
    }
 
  return y;
}
 
double
erfinv (double x)
{
  return do_erfinv (x, true);
}
 
float
erfinv (float x)
{
  return do_erfinv (x, false);
}
 
Complex
expm1 (const Complex& x)
{
  Complex retval;
 
  if (std::abs (x) < 1)
    {
      double im = x.imag ();
      double u = expm1 (x.real ());
      double v = sin (im/2);
      v = -2*v*v;
      retval = Complex (u*v + u + v, (u+1) * sin (im));
    }
  else
    retval = std::exp (x) - Complex (1);
 
  return retval;
}
 
FloatComplex
expm1 (const FloatComplex& x)
{
  FloatComplex retval;
 
  if (std::abs (x) < 1)
    {
      float im = x.imag ();
      float u = expm1 (x.real ());
      float v = sin (im/2);
      v = -2*v*v;
      retval = FloatComplex (u*v + u + v, (u+1) * sin (im));
    }
  else
    retval = std::exp (x) - FloatComplex (1);
 
  return retval;
}
 
double
gamma (double x)
{
  double result;
 
  // Special cases for (near) compatibility with Matlab instead of tgamma.
  // Matlab does not have -0.
 
  if (x == 0)
    result = (math::negative_sign (x)
              ? -numeric_limits<double>::Inf ()
              : numeric_limits<double>::Inf ());
  else if ((x < 0 && math::x_nint (x) == x)
           || math::isinf (x))
    result = numeric_limits<double>::Inf ();
  else if (math::isnan (x))
    result = numeric_limits<double>::NaN ();
  else
    result = std::tgamma (x);
 
  return result;
}
 
float
gamma (float x)
{
  float result;
 
  // Special cases for (near) compatibility with Matlab instead of tgamma.
  // Matlab does not have -0.
 
  if (x == 0)
    result = (math::negative_sign (x)
              ? -numeric_limits<float>::Inf ()
              : numeric_limits<float>::Inf ());
  else if ((x < 0 && math::x_nint (x) == x)
           || math::isinf (x))
    result = numeric_limits<float>::Inf ();
  else if (math::isnan (x))
    result = numeric_limits<float>::NaN ();
  else
    result = std::tgammaf (x);
 
  return result;
}
 
Complex
log1p (const Complex& x)
{
  Complex retval;
 
  double r = x.real (), i = x.imag ();
 
  if (fabs (r) < 0.5 && fabs (i) < 0.5)
    {
      double u = 2*r + r*r + i*i;
      retval = Complex (log1p (u / (1+std::sqrt (u+1))),
                        atan2 (i, 1 + r));
    }
  else
    retval = std::log (Complex (1) + x);
 
  return retval;
}
 
FloatComplex
log1p (const FloatComplex& x)
{
  FloatComplex retval;
 
  float r = x.real (), i = x.imag ();
 
  if (fabs (r) < 0.5 && fabs (i) < 0.5)
    {
      float u = 2*r + r*r + i*i;
      retval = FloatComplex (log1p (u / (1+std::sqrt (u+1))),
                             atan2 (i, 1 + r));
    }
  else
    retval = std::log (FloatComplex (1) + x);
 
  return retval;
}
 
static const double pi = 3.14159265358979323846;
 
template <typename T>
static inline T
xlog (const T& x)
{
  return log (x);
}
 
template <>
inline double
xlog (const double& x)
{
  return std::log (x);
}
 
template <>
inline float
xlog (const float& x)
{
  return std::log (x);
}
 
template <typename T>
static T
lanczos_approximation_psi (const T zc)
{
  // Coefficients for C.Lanczos expansion of psi function from XLiFE++
  // gammaFunctions psi_coef[k] = - (2k+1) * lg_coef[k] (see melina++
  // gamma functions -1/12, 3/360,-5/1260, 7/1680,-9/1188,
  // 11*691/360360,-13/156, 15*3617/122400, ? , ?
  static const T dg_coeff[10] =
  {
    -0.83333333333333333e-1, 0.83333333333333333e-2,
      -0.39682539682539683e-2, 0.41666666666666667e-2,
      -0.75757575757575758e-2, 0.21092796092796093e-1,
      -0.83333333333333333e-1, 0.4432598039215686,
      -0.3053954330270122e+1,  0.125318899521531e+2
    };
 
  T overz2  = T (1.0) / (zc * zc);
  T overz2k = overz2;
 
  T p = 0;
  for (octave_idx_type k = 0; k < 10; k++, overz2k *= overz2)
    p += dg_coeff[k] * overz2k;
  p += xlog (zc) - T (0.5) / zc;
  return p;
}
 
template <typename T>
T
xpsi (T z)
{
  static const double euler_mascheroni
    = 0.577215664901532860606512090082402431042;
 
  const bool is_int = (std::floor (z) == z);
 
  T p = 0;
  if (z <= 0)
    {
      // limits - zeros of the gamma function
      if (is_int)
        p = -numeric_limits<T>::Inf (); // Matlab returns -Inf for psi (0)
      else
        // Abramowitz and Stegun, page 259, eq 6.3.7
        p = psi (1 - z) - (pi / tan (pi * z));
    }
  else if (is_int)
    {
      // Abramowitz and Stegun, page 258, eq 6.3.2
      p = - euler_mascheroni;
      for (octave_idx_type k = z - 1; k > 0; k--)
        p += 1.0 / k;
    }
  else if (std::floor (z + 0.5) == z + 0.5)
    {
      // Abramowitz and Stegun, page 258, eq 6.3.3 and 6.3.4
      for (octave_idx_type k = z; k > 0; k--)
        p += 1.0 / (2 * k - 1);
 
      p = - euler_mascheroni - 2 * std::log (2) + 2 * (p);
    }
  else
    {
      // adapted from XLiFE++ gammaFunctions
 
      T zc = z;
      // Use formula for derivative of LogGamma(z)
      if (z < 10)
        {
          const signed char n = 10 - z;
          for (signed char k = n - 1; k >= 0; k--)
            p -= 1.0 / (k + z);
          zc += n;
        }
      p += lanczos_approximation_psi (zc);
    }
 
  return p;
}
 
// explicit instantiations
double
psi (double z) { return xpsi (z); }
float
psi (float z) { return xpsi (z); }
 
template <typename T>
std::complex<T>
xpsi (const std::complex<T>& z)
{
  // adapted from XLiFE++ gammaFunctions
 
  typedef typename std::complex<T>::value_type P;
 
  P z_r  = z.real ();
  P z_ra = z_r;
 
  std::complex<T> dgam (0.0, 0.0);
  if (z.imag () == 0)
    dgam = std::complex<T> (psi (z_r), 0.0);
  else if (z_r < 0)
    dgam = psi (P (1.0) - z)- (P (pi) / tan (P (pi) * z));
  else
    {
      // Use formula for derivative of LogGamma(z)
      std::complex<T> z_m = z;
      if (z_ra < 8)
        {
          unsigned char n = 8 - z_ra;
          z_m = z + std::complex<T> (n, 0.0);
 
          // Recurrence formula.  For | Re(z) | < 8, use recursively
          //
          //   DiGamma(z) = DiGamma(z+1) - 1/z
          std::complex<T> z_p = z + P (n - 1);
          for (unsigned char k = n; k > 0; k--, z_p -= 1.0)
            dgam -= P (1.0) / z_p;
        }
 
      // for | Re(z) | > 8, use derivative of C.Lanczos expansion for
      // LogGamma
      //
      //   psi(z) = log(z) - 1/(2z) - 1/12z^2 + 3/360z^4 - 5/1260z^6
      //     + 7/1680z^8 - 9/1188z^10 + ...
      //
      // (Abramowitz&Stegun, page 259, formula 6.3.18
      dgam += lanczos_approximation_psi (z_m);
    }
  return dgam;
}
 
// explicit instantiations
Complex
psi (const Complex& z) { return xpsi (z); }
FloatComplex
psi (const FloatComplex& z) { return xpsi (z); }
 
template <typename T>
static inline void
fortran_psifn (T z, octave_idx_type n, T& ans, octave_idx_type& ierr);
 
template <>
inline void
fortran_psifn<double> (double z, octave_idx_type n_arg,
                       double& ans, octave_idx_type& ierr)
{
  F77_INT n = to_f77_int (n_arg);
  F77_INT flag = 0;
  F77_INT t_ierr;
  F77_XFCN (dpsifn, DPSIFN, (z, n, 1, 1, ans, flag, t_ierr));
  ierr = t_ierr;
}
 
template <>
inline void
fortran_psifn<float> (float z, octave_idx_type n_arg,
                      float& ans, octave_idx_type& ierr)
{
  F77_INT n = to_f77_int (n_arg);
  F77_INT flag = 0;
  F77_INT t_ierr;
  F77_XFCN (psifn, PSIFN, (z, n, 1, 1, ans, flag, t_ierr));
  ierr = t_ierr;
}
 
template <typename T>
T
xpsi (octave_idx_type n, T z)
{
  T ans;
  octave_idx_type ierr = 0;
  fortran_psifn<T> (z, n, ans, ierr);
  if (ierr == 0)
    {
      // Remember that psifn and dpsifn return scales values
      // When n is 1: do nothing since ((-1)**(n+1)/gamma(n+1)) == 1
      // When n is 0: change sign since ((-1)**(n+1)/gamma(n+1)) == -1
      if (n > 1)
        // FIXME: xgamma here is a killer for our precision since it grows
        //        way too fast.
        ans = ans / (std::pow (-1.0, n + 1) / gamma (double (n+1)));
      else if (n == 0)
        ans = -ans;
    }
  else if (ierr == 2)
    ans = - numeric_limits<T>::Inf ();
  else // we probably never get here
    ans = numeric_limits<T>::NaN ();
 
  return ans;
}
 
double
psi (octave_idx_type n, double z) { return xpsi (n, z); }
float
psi (octave_idx_type n, float z) { return xpsi (n, z); }
 
Complex
rc_lgamma (double x)
{
  double result;
 
#if defined (HAVE_LGAMMA_R)
  int sgngam;
  result = lgamma_r (x, &sgngam);
#else
  result = std::lgamma (x);
  int sgngam = signgam;
#endif
 
  if (sgngam < 0 && std::isfinite (result))
    return result + Complex (0., M_PI);
  else
    return result;
}
 
FloatComplex
rc_lgamma (float x)
{
  float result;
 
#if defined (HAVE_LGAMMAF_R)
  int sgngam;
  result = lgammaf_r (x, &sgngam);
#else
  result = std::lgammaf (x);
  int sgngam = signgam;
#endif
 
  if (sgngam < 0 && std::isfinite (result))
    return result + FloatComplex (0., M_PI);
  else
    return result;
}
 
Complex
rc_log1p (double x)
{
  return (x < -1.0
          ? Complex (std::log (-(1.0 + x)), M_PI)
          : Complex (log1p (x)));
}
 
FloatComplex
rc_log1p (float x)
{
  return (x < -1.0f
          ? FloatComplex (std::log (-(1.0f + x)), M_PI)
          : FloatComplex (log1p (x)));
}
 
OCTAVE_END_NAMESPACE(math)
OCTAVE_END_NAMESPACE(octave)