Mercurial > hg > octave-nkf
diff liboctave/lo-specfun.cc @ 3220:3deb1105fbc1
[project @ 1998-11-19 00:06:30 by jwe]
author | jwe |
---|---|
date | Thu, 19 Nov 1998 00:06:34 +0000 |
parents | 45490c020e47 |
children | 7aae2c3636a7 |
line wrap: on
line diff
--- a/liboctave/lo-specfun.cc +++ b/liboctave/lo-specfun.cc @@ -25,25 +25,46 @@ #endif #include "Range.h" -#include "dColVector.h" +#include "CColVector.h" +#include "CMatrix.h" +#include "dRowVector.h" #include "dMatrix.h" #include "f77-fcn.h" #include "lo-error.h" +#include "lo-ieee.h" +#include "lo-specfun.h" #include "mx-inlines.cc" extern "C" { - int F77_FCN (rjbesl, RJBESL) (const double&, const double&, - const int&, double*, int&); + int F77_FCN (zbesj, ZBESJ) (const double&, const double&, + const double&, const int&, const int&, + double*, double*, int&, int&); - int F77_FCN (rybesl, RYBESL) (const double&, const double&, - const int&, double*, int&); + int F77_FCN (zbesy, ZBESY) (const double&, const double&, + const double&, const int&, const int&, + double*, double*, int&, + double*, double*, int&); + + int F77_FCN (zbesi, ZBESI) (const double&, const double&, + const double&, const int&, const int&, + double*, double*, int&, int&); - int F77_FCN (ribesl, RIBESL) (const double&, const double&, - const int&, const int&, double*, int&); + int F77_FCN (zbesk, ZBESK) (const double&, const double&, + const double&, const int&, const int&, + double*, double*, int&, int&); + + int F77_FCN (zbesh, ZBESH) (const double&, const double&, + const double&, const int&, const int&, + const int&, double*, double*, int&, int&); - int F77_FCN (rkbesl, RKBESL) (const double&, const double&, - const int&, const int&, double*, int&); + int F77_FCN (zairy, ZAIRY) (const double&, const double&, + const int&, const int&, + double&, double&, int&, int&); + + int F77_FCN (zbiry, ZBIRY) (const double&, const double&, + const int&, const int&, + double&, double&, int&); int F77_FCN (xdacosh, XDACOSH) (const double&, double&); @@ -132,179 +153,518 @@ return result; } -int -F77_FCN (ribesl, RIBESL) (const double& x, const double& alpha, - const int& nb, double *result, int& ncalc) +static inline Complex +zbesj (const Complex& z, double alpha, int kode, int& ierr); + +static inline Complex +zbesy (const Complex& z, double alpha, int kode, int& ierr); + +static inline Complex +zbesi (const Complex& z, double alpha, int kode, int& ierr); + +static inline Complex +zbesk (const Complex& z, double alpha, int kode, int& ierr); + +static inline Complex +zbesh1 (const Complex& z, double alpha, int kode, int& ierr); + +static inline Complex +zbesh2 (const Complex& z, double alpha, int kode, int& ierr); + +static inline Complex +bessel_return_value (const Complex& val, int ierr) { - int retval = 0; - F77_FCN (ribesl, RIBESL) (x, alpha, nb, 1, result, ncalc); + static const Complex inf_val = Complex (octave_Inf, octave_Inf); + static const Complex nan_val = Complex (octave_NaN, octave_NaN); + + Complex retval; + + switch (ierr) + { + case 0: + case 3: + retval = val; + break; + + case 2: + retval = inf_val; + break; + + default: + retval = nan_val; + break; + } + return retval; } -int -F77_FCN (rkbesl, RKBESL) (const double& x, const double& alpha, - const int& nb, double *result, int& ncalc) +static inline Complex +zbesj (const Complex& z, double alpha, int kode, int& ierr) { - int retval = 0; - F77_FCN (rkbesl, RKBESL) (x, alpha, nb, 1, result, ncalc); + Complex retval; + + if (alpha >= 0.0) + { + double yr = 0.0; + double yi = 0.0; + + int nz; + + double zr = z.real (); + double zi = z.imag (); + + F77_FCN (zbesj, ZBESJ) (zr, zi, alpha, kode, 1, &yr, &yi, nz, ierr); + + if (zi == 0.0 && zr > 0.0) + yi = 0.0; + + retval = bessel_return_value (Complex (yr, yi), 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 (octave_NaN, octave_NaN); + } + return retval; } -typedef int (*fptr) (const double&, const double&, const int&, double*, int&); - -static Matrix -do_bessel (fptr f, const char *fn, double alpha, const Matrix& x) +static inline Complex +zbesy (const Complex& z, double alpha, int kode, int& ierr) { - Matrix retval; + Complex retval; if (alpha >= 0.0) { - int nb = 1; + double yr = 0.0; + double yi = 0.0; + + int nz; + + double wr, wi; - if (alpha >= 1.0) + double zr = z.real (); + double zi = z.imag (); + + ierr = 0; + + if (zr == 0.0 && zi == 0.0) { - double integral; - alpha = modf (alpha, &integral); - nb = static_cast<int> (integral) + 1; + yr = -octave_Inf; + yi = 0.0; + } + else + { + F77_FCN (zbesy, ZBESY) (zr, zi, alpha, kode, 1, &yr, &yi, nz, + &wr, &wi, ierr); + + if (zi == 0.0 && zr > 0.0) + yi = 0.0; } - Array<double> tmp (nb); - - double *ptmp = tmp.fortran_vec (); + return bessel_return_value (Complex (yr, yi), ierr); + } + else + { + alpha = -alpha; - int x_nr = x.rows (); - int x_nc = x.cols (); + Complex tmp = cos (M_PI * alpha) * zbesy (z, alpha, kode, ierr); - retval.resize (x_nr, x_nc); - - int ncalc; - - for (int j = 0; j < x_nc; j++) + if (ierr == 0 || ierr == 3) { - for (int i = 0; i < x_nr; i++) - { - f (x(i,j), alpha, nb, ptmp, ncalc); + tmp += sin (M_PI * alpha) * zbesj (z, alpha, kode, ierr); + + retval = bessel_return_value (tmp, ierr); + } + else + retval = Complex (octave_NaN, octave_NaN); + } + + return retval; +} + +static inline Complex +zbesi (const Complex& z, double alpha, int kode, int& ierr) +{ + Complex retval; - if (ncalc < 0) - { - (*current_liboctave_error_handler) - ("%s: error computing function values", fn); + if (alpha >= 0.0) + { + double yr = 0.0; + double yi = 0.0; + + int nz; - return Matrix (); - } + double zr = z.real (); + double zi = z.imag (); + + F77_FCN (zbesi, ZBESI) (zr, zi, alpha, kode, 1, &yr, &yi, nz, ierr); - retval(i,j) = tmp(nb-1); - } - } + if (zi == 0.0 && zr > 0.0) + yi = 0.0; + + retval = bessel_return_value (Complex (yr, yi), ierr); } else - (*current_liboctave_error_handler) - ("%s: alpha must be greater than zero", fn); + { + alpha = -alpha; + + Complex tmp = zbesi (z, alpha, kode, ierr); + + if (ierr == 0 || ierr == 3) + { + tmp += (2.0 / M_PI) * sin (M_PI * alpha) + * zbesk (z, alpha, kode, ierr); + + retval = bessel_return_value (tmp, ierr); + } + else + retval = Complex (octave_NaN, octave_NaN); + } + + return retval; +} + +static inline Complex +zbesk (const Complex& z, double alpha, int kode, int& ierr) +{ + Complex retval; + + if (alpha >= 0.0) + { + double yr = 0.0; + double yi = 0.0; + + int nz; + + double zr = z.real (); + double zi = z.imag (); + + ierr = 0; + + if (zr == 0.0 && zi == 0.0) + { + yr = octave_Inf; + yi = 0.0; + } + else + { + F77_FCN (zbesk, ZBESK) (zr, zi, alpha, kode, 1, &yr, &yi, nz, 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 Matrix -do_bessel (fptr f, const char *fn, const Range& alpha_range, - const ColumnVector& x) +static inline Complex +zbesh1 (const Complex& z, double alpha, int kode, int& ierr) { - Matrix retval; + Complex retval; - double alpha_base = alpha_range.base (); - - if (alpha_base >= 0.0) + if (alpha >= 0.0) { - int nb_orig = alpha_range.nelem (); - int nb = nb_orig; - int offset = 0; + double yr = 0.0; + double yi = 0.0; + + int nz; + + double zr = z.real (); + double zi = z.imag (); - if (alpha_base >= 1.0) - { - double integral; - alpha_base = modf (alpha_base, &integral); - offset = static_cast<int> (integral); - nb += offset; - } + F77_FCN (zbesh, ZBESH) (zr, zi, alpha, kode, 1, 1, &yr, &yi, nz, ierr); - Array<double> tmp (nb); + retval = bessel_return_value (Complex (yr, yi), ierr); + } + else + { + alpha = -alpha; + + static const Complex eye = Complex (0.0, 1.0); - double *ptmp = tmp.fortran_vec (); + Complex tmp = exp (M_PI * alpha * eye) * zbesh1 (z, alpha, kode, ierr); - int x_len = x.length (); - - retval.resize (x_len, nb_orig); + retval = bessel_return_value (tmp, ierr); + } - int ncalc; + return retval; +} - for (int i = 0; i < x_len; i++) - { - f (x(i), alpha_base, nb, ptmp, ncalc); +static inline Complex +zbesh2 (const Complex& z, double alpha, int kode, int& ierr) +{ + Complex retval; - if (ncalc < 0) - { - (*current_liboctave_error_handler) - ("%s: error computing function values", fn); + if (alpha >= 0.0) + { + double yr = 0.0; + double yi = 0.0; + + int nz; - return Matrix (); - } + double zr = z.real (); + double zi = z.imag (); - for (int j = 0; j < nb_orig; j++) - retval(i,j) = tmp(offset+j); - } + F77_FCN (zbesh, ZBESH) (zr, zi, alpha, kode, 2, 1, &yr, &yi, nz, ierr); + + retval = bessel_return_value (Complex (yr, yi), ierr); } else - (*current_liboctave_error_handler) - ("%s: alpha must be greater than zero", fn); + { + 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 (*fptr) (const Complex&, double, int, int&); + +static inline Complex +do_bessel (fptr f, const char *, double alpha, const Complex& x, + bool scaled, int& ierr) +{ + Complex retval; + + retval = f (x, alpha, (scaled ? 2 : 1), ierr); + + return retval; +} + +static inline ComplexMatrix +do_bessel (fptr f, const char *, double alpha, const ComplexMatrix& x, + bool scaled, Array2<int>& ierr) +{ + int nr = x.rows (); + int nc = x.cols (); + + ComplexMatrix retval (nr, nc); + + ierr.resize (nr, nc); + + for (int j = 0; j < nc; j++) + for (int 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 (fptr f, const char *, const Matrix& alpha, const Complex& x, + bool scaled, Array2<int>& ierr) +{ + int nr = alpha.rows (); + int nc = alpha.cols (); + + ComplexMatrix retval (nr, nc); + + ierr.resize (nr, nc); + + for (int j = 0; j < nc; j++) + for (int i = 0; i < nr; i++) + retval(i,j) = f (x, alpha(i,j), (scaled ? 2 : 1), ierr(i,j)); return retval; } -Matrix -besselj (double alpha, const Matrix& x) +static inline ComplexMatrix +do_bessel (fptr f, const char *fn, const Matrix& alpha, + const ComplexMatrix& x, bool scaled, Array2<int>& ierr) { - return do_bessel (F77_FCN (rjbesl, RJBESL), "besselj", alpha, x); + ComplexMatrix retval; + + int x_nr = x.rows (); + int x_nc = x.cols (); + + int alpha_nr = alpha.rows (); + int alpha_nc = alpha.cols (); + + if (x_nr == alpha_nr && x_nc == alpha_nc) + { + int nr = x_nr; + int nc = x_nc; + + retval.resize (nr, nc); + + ierr.resize (nr, nc); + + for (int j = 0; j < nc; j++) + for (int i = 0; i < nr; i++) + retval(i,j) = f (x(i,j), alpha(i,j), (scaled ? 2 : 1), ierr(i,j)); + } + else + (*current_liboctave_error_handler) + ("%s: the sizes of alpha and x must conform", fn); + + return retval; } -Matrix -bessely (double alpha, const Matrix& x) +static inline ComplexMatrix +do_bessel (fptr f, const char *, const RowVector& alpha, + const ComplexColumnVector& x, bool scaled, Array2<int>& ierr) { - return do_bessel (F77_FCN (rybesl, RYBESL), "bessely", alpha, x); -} + int nr = x.length (); + int nc = alpha.length (); + + ComplexMatrix retval (nr, nc); -Matrix -besseli (double alpha, const Matrix& x) -{ - return do_bessel (F77_FCN (ribesl, RIBESL), "besseli", alpha, x); + ierr.resize (nr, nc); + + for (int j = 0; j < nc; j++) + for (int i = 0; i < nr; i++) + retval(i,j) = f (x(i), alpha(j), (scaled ? 2 : 1), ierr(i,j)); + + return retval; } -Matrix -besselk (double alpha, const Matrix& x) +#define SS_BESSEL(name, fcn) \ + Complex \ + name (double alpha, const Complex& x, bool scaled, int& ierr) \ + { \ + return do_bessel (fcn, #name, alpha, x, scaled, ierr); \ + } + +#define SM_BESSEL(name, fcn) \ + ComplexMatrix \ + name (double alpha, const ComplexMatrix& x, bool scaled, \ + Array2<int>& 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, \ + Array2<int>& 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, \ + Array2<int>& 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, \ + Array2<int>& 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) \ + 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) + +Complex +airy (const Complex& z, bool deriv, bool scaled, int& ierr) { - return do_bessel (F77_FCN (rkbesl, RKBESL), "besselk", alpha, x); -} + double ar = 0.0; + double ai = 0.0; + + int nz; + + double zr = z.real (); + double zi = z.imag (); -Matrix -besselj (const Range& alpha, const ColumnVector& x) -{ - return do_bessel (F77_FCN (rjbesl, RJBESL), "besselj", alpha, x); + int id = deriv ? 1 : 0; + + int kode = scaled ? 2 : 1; + + F77_FCN (zairy, ZAIRY) (zr, zi, id, kode, ar, ai, nz, ierr); + + return bessel_return_value (Complex (ar, ai), ierr); } -Matrix -bessely (const Range& alpha, const ColumnVector& x) +Complex +biry (const Complex& z, bool deriv, bool scaled, int& ierr) { - return do_bessel (F77_FCN (rybesl, RYBESL), "bessely", alpha, x); + double ar = 0.0; + double ai = 0.0; + + double zr = z.real (); + double zi = z.imag (); + + int id = deriv ? 1 : 0; + + int kode = scaled ? 2 : 1; + + F77_FCN (zbiry, ZBIRY) (zr, zi, id, kode, ar, ai, ierr); + + return bessel_return_value (Complex (ar, ai), ierr); } -Matrix -besseli (const Range& alpha, const ColumnVector& x) +ComplexMatrix +airy (const ComplexMatrix& z, bool deriv, bool scaled, Array2<int>& ierr) { - return do_bessel (F77_FCN (ribesl, RIBESL), "besseli", alpha, x); + int nr = z.rows (); + int nc = z.cols (); + + ComplexMatrix retval (nr, nc); + + ierr.resize (nr, nc); + + for (int j = 0; j < nc; j++) + for (int i = 0; i < nr; i++) + retval(i,j) = airy (z(i,j), deriv, scaled, ierr(i,j)); + + return retval; } -Matrix -besselk (const Range& alpha, const ColumnVector& x) +ComplexMatrix +biry (const ComplexMatrix& z, bool deriv, bool scaled, Array2<int>& ierr) { - return do_bessel (F77_FCN (rkbesl, RKBESL), "besselk", alpha, x); + int nr = z.rows (); + int nc = z.cols (); + + ComplexMatrix retval (nr, nc); + + ierr.resize (nr, nc); + + for (int j = 0; j < nc; j++) + for (int i = 0; i < nr; i++) + retval(i,j) = biry (z(i,j), deriv, scaled, ierr(i,j)); + + return retval; } static void