pax_global_header00006660000000000000000000000064123244531060014512gustar00rootroot0000000000000052 comment=a986197e178f8476fefcc17a88b810f0e237751d openspecfun-0.3/000077500000000000000000000000001232445310600137015ustar00rootroot00000000000000openspecfun-0.3/.gitignore000066400000000000000000000004401232445310600156670ustar00rootroot00000000000000# Object files *.o *.ko # Libraries *.lib *.a # Shared objects (inc. Windows DLLs) *.dll *.so *.so.* *.dylib *.dylib.* # Executables *.exe *.out *.app # Debian build junk debian/tmp/* debian/libopenspecfun-*/* debian/*.debhelper debian/*.debhelper.log debian/*.substvars debian/files openspecfun-0.3/Faddeeva/000077500000000000000000000000001232445310600154005ustar00rootroot00000000000000openspecfun-0.3/Faddeeva/Faddeeva.c000066400000000000000000000002351232445310600172430ustar00rootroot00000000000000/* The Faddeeva.cc file contains macros to let it compile as C code (assuming C99 complex-number support), so just #include it. */ #include "Faddeeva.cc" openspecfun-0.3/Faddeeva/Faddeeva.cc000066400000000000000000003665661232445310600174340ustar00rootroot00000000000000// -*- mode:c++; tab-width:2; indent-tabs-mode:nil; -*- /* Copyright (c) 2012 Massachusetts Institute of Technology * * Permission is hereby granted, free of charge, to any person obtaining * a copy of this software and associated documentation files (the * "Software"), to deal in the Software without restriction, including * without limitation the rights to use, copy, modify, merge, publish, * distribute, sublicense, and/or sell copies of the Software, and to * permit persons to whom the Software is furnished to do so, subject to * the following conditions: * * The above copyright notice and this permission notice shall be * included in all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND * NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE * LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION * OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. */ /* (Note that this file can be compiled with either C++, in which case it uses C++ std::complex, or C, in which case it uses C99 double complex.) */ /* Available at: http://ab-initio.mit.edu/Faddeeva Computes various error functions (erf, erfc, erfi, erfcx), including the Dawson integral, in the complex plane, based on algorithms for the computation of the Faddeeva function w(z) = exp(-z^2) * erfc(-i*z). Given w(z), the error functions are mostly straightforward to compute, except for certain regions where we have to switch to Taylor expansions to avoid cancellation errors [e.g. near the origin for erf(z)]. To compute the Faddeeva function, we use a combination of two algorithms: For sufficiently large |z|, we use a continued-fraction expansion for w(z) similar to those described in: Walter Gautschi, "Efficient computation of the complex error function," SIAM J. Numer. Anal. 7(1), pp. 187-198 (1970) G. P. M. Poppe and C. M. J. Wijers, "More efficient computation of the complex error function," ACM Trans. Math. Soft. 16(1), pp. 38-46 (1990). Unlike those papers, however, we switch to a completely different algorithm for smaller |z|: Mofreh R. Zaghloul and Ahmed N. Ali, "Algorithm 916: Computing the Faddeyeva and Voigt Functions," ACM Trans. Math. Soft. 38(2), 15 (2011). (I initially used this algorithm for all z, but it turned out to be significantly slower than the continued-fraction expansion for larger |z|. On the other hand, it is competitive for smaller |z|, and is significantly more accurate than the Poppe & Wijers code in some regions, e.g. in the vicinity of z=1+1i.) Note that this is an INDEPENDENT RE-IMPLEMENTATION of these algorithms, based on the description in the papers ONLY. In particular, I did not refer to the authors' Fortran or Matlab implementations, respectively, (which are under restrictive ACM copyright terms and therefore unusable in free/open-source software). Steven G. Johnson, Massachusetts Institute of Technology http://math.mit.edu/~stevenj October 2012. -- Note that Algorithm 916 assumes that the erfc(x) function, or rather the scaled function erfcx(x) = exp(x*x)*erfc(x), is supplied for REAL arguments x. I originally used an erfcx routine derived from DERFC in SLATEC, but I have since replaced it with a much faster routine written by me which uses a combination of continued-fraction expansions and a lookup table of Chebyshev polynomials. For speed, I implemented a similar algorithm for Im[w(x)] of real x, since this comes up frequently in the other error functions. A small test program is included the end, which checks the w(z) etc. results against several known values. To compile the test function, compile with -DTEST_FADDEEVA (that is, #define TEST_FADDEEVA). If HAVE_CONFIG_H is #defined (e.g. by compiling with -DHAVE_CONFIG_H), then we #include "config.h", which is assumed to be a GNU autoconf-style header defining HAVE_* macros to indicate the presence of features. In particular, if HAVE_ISNAN and HAVE_ISINF are #defined, we use those functions in math.h instead of defining our own, and if HAVE_ERF and/or HAVE_ERFC are defined we use those functions from for erf and erfc of real arguments, respectively, instead of defining our own. REVISION HISTORY: 4 October 2012: Initial public release (SGJ) 5 October 2012: Revised (SGJ) to fix spelling error, start summation for large x at round(x/a) (> 1) rather than ceil(x/a) as in the original paper, which should slightly improve performance (and, apparently, slightly improves accuracy) 19 October 2012: Revised (SGJ) to fix bugs for large x, large -y, and 15 1e154. Set relerr argument to min(relerr,0.1). 27 October 2012: Enhance accuracy in Re[w(z)] taken by itself, by switching to Alg. 916 in a region near the real-z axis where continued fractions have poor relative accuracy in Re[w(z)]. Thanks to M. Zaghloul for the tip. 29 October 2012: Replace SLATEC-derived erfcx routine with completely rewritten code by me, using a very different algorithm which is much faster. 30 October 2012: Implemented special-case code for real z (where real part is exp(-x^2) and imag part is Dawson integral), using algorithm similar to erfx. Export ImFaddeeva_w function to make Dawson's integral directly accessible. 3 November 2012: Provide implementations of erf, erfc, erfcx, and Dawson functions in Faddeeva:: namespace, in addition to Faddeeva::w. Provide header file Faddeeva.hh. 4 November 2012: Slightly faster erf for real arguments. Updated MATLAB and Octave plugins. 27 November 2012: Support compilation with either C++ or plain C (using C99 complex numbers). For real x, use standard-library erf(x) and erfc(x) if available (for C99 or C++11). #include "config.h" if HAVE_CONFIG_H is #defined. 15 December 2012: Portability fixes (copysign, Inf/NaN creation), use CMPLX/__builtin_complex if available in C, slight accuracy improvements to erf and dawson functions near the origin. Use gnulib functions if GNULIB_NAMESPACE is defined. 18 December 2012: Slight tweaks (remove recomputation of x*x in Dawson) */ ///////////////////////////////////////////////////////////////////////// /* If this file is compiled as a part of a larger project, support using an autoconf-style config.h header file (with various "HAVE_*" #defines to indicate features) if HAVE_CONFIG_H is #defined (in GNU autotools style). */ #ifdef HAVE_CONFIG_H # include "config.h" #endif ///////////////////////////////////////////////////////////////////////// // macros to allow us to use either C++ or C (with C99 features) #ifdef __cplusplus # include "Faddeeva.hh" # include # include # include using namespace std; // use std::numeric_limits, since 1./0. and 0./0. fail with some compilers (MS) # define Inf numeric_limits::infinity() # define NaN numeric_limits::quiet_NaN() typedef complex cmplx; // Use C-like complex syntax, since the C syntax is more restrictive # define cexp(z) exp(z) # define creal(z) real(z) # define cimag(z) imag(z) # define cpolar(r,t) polar(r,t) # define C(a,b) cmplx(a,b) # define FADDEEVA(name) Faddeeva::name # define FADDEEVA_RE(name) Faddeeva::name // isnan/isinf were introduced in C++11 # if (__cplusplus < 201103L) && (!defined(HAVE_ISNAN) || !defined(HAVE_ISINF)) static inline bool my_isnan(double x) { return x != x; } # define isnan my_isnan static inline bool my_isinf(double x) { return 1/x == 0.; } # define isinf my_isinf # elif (__cplusplus >= 201103L) // g++ gets confused between the C and C++ isnan/isinf functions # define isnan std::isnan # define isinf std::isinf # endif // copysign was introduced in C++11 (and is also in POSIX and C99) # if defined(_WIN32) || defined(__WIN32__) # define copysign _copysign // of course MS had to be different # elif defined(GNULIB_NAMESPACE) // we are using using gnulib # define copysign GNULIB_NAMESPACE::copysign # elif (__cplusplus < 201103L) && !defined(HAVE_COPYSIGN) && !defined(__linux__) && !(defined(__APPLE__) && defined(__MACH__)) && !defined(_AIX) static inline double my_copysign(double x, double y) { return y<0 ? -x : x; } # define copysign my_copysign # endif // If we are using the gnulib (e.g. in the GNU Octave sources), // gnulib generates a link warning if we use ::floor instead of gnulib::floor. // This warning is completely innocuous because the only difference between // gnulib::floor and the system ::floor (and only on ancient OSF systems) // has to do with floor(-0), which doesn't occur in the usage below, but // the Octave developers prefer that we silence the warning. # ifdef GNULIB_NAMESPACE # define floor GNULIB_NAMESPACE::floor # endif #else // !__cplusplus, i.e. pure C (requires C99 features) # include "Faddeeva.h" # define _GNU_SOURCE // enable GNU libc NAN extension if possible # include #ifdef USE_OPENLIBM # include #else # include #endif typedef double complex cmplx; # define FADDEEVA(name) Faddeeva_ ## name # define FADDEEVA_RE(name) Faddeeva_ ## name ## _re /* Constructing complex numbers like 0+i*NaN is problematic in C99 without the C11 CMPLX macro, because 0.+I*NAN may give NaN+i*NAN if I is a complex (rather than imaginary) constant. For some reason, however, it works fine in (pre-4.7) gcc if I define Inf and NaN as 1/0 and 0/0 (and only if I compile with optimization -O1 or more), but not if I use the INFINITY or NAN macros. */ /* __builtin_complex was introduced in gcc 4.7, but the C11 CMPLX macro may not be defined unless we are using a recent (2012) version of glibc and compile with -std=c11... note that icc lies about being gcc and probably doesn't have this builtin(?), so exclude icc explicitly */ # if !defined(CMPLX) && (__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 7)) && !(defined(__ICC) || defined(__INTEL_COMPILER)) # define CMPLX(a,b) __builtin_complex((double) (a), (double) (b)) # endif # ifdef USE_OPENLIBM # ifndef CMPLX # include "openlibm.h" # define CMPLX(a,b) cpack(a,b) # endif # endif # ifdef CMPLX // C11 # define C(a,b) CMPLX(a,b) # define Inf INFINITY // C99 infinity # ifdef NAN // GNU libc extension # define NaN NAN # else # define NaN (0./0.) // NaN # endif # else # define C(a,b) ((a) + I*(b)) # define Inf (1./0.) # define NaN (0./0.) # endif static inline cmplx cpolar(double r, double t) { if (r == 0.0 && !isnan(t)) return 0.0; else return C(r * cos(t), r * sin(t)); } #endif // !__cplusplus, i.e. pure C (requires C99 features) ///////////////////////////////////////////////////////////////////////// // Auxiliary routines to compute other special functions based on w(z) // compute erfcx(z) = exp(z^2) erfz(z) cmplx FADDEEVA(erfcx)(cmplx z, double relerr) { return FADDEEVA(w)(C(-cimag(z), creal(z)), relerr); } // compute the error function erf(x) double FADDEEVA_RE(erf)(double x) { #if !defined(__cplusplus) return erf(x); // C99 supplies erf in math.h #elif (__cplusplus >= 201103L) || defined(HAVE_ERF) return ::erf(x); // C++11 supplies std::erf in cmath #else double mx2 = -x*x; if (mx2 < -750) // underflow return (x >= 0 ? 1.0 : -1.0); if (x >= 0) { if (x < 8e-2) goto taylor; return 1.0 - exp(mx2) * FADDEEVA_RE(erfcx)(x); } else { // x < 0 if (x > -8e-2) goto taylor; return exp(mx2) * FADDEEVA_RE(erfcx)(-x) - 1.0; } // Use Taylor series for small |x|, to avoid cancellation inaccuracy // erf(x) = 2/sqrt(pi) * x * (1 - x^2/3 + x^4/10 - x^6/42 + x^8/216 + ...) taylor: return x * (1.1283791670955125739 + mx2 * (0.37612638903183752464 + mx2 * (0.11283791670955125739 + mx2 * (0.026866170645131251760 + mx2 * 0.0052239776254421878422)))); #endif } // compute the error function erf(z) cmplx FADDEEVA(erf)(cmplx z, double relerr) { double x = creal(z), y = cimag(z); if (y == 0) return C(FADDEEVA_RE(erf)(x), y); // preserve sign of 0 if (x == 0) // handle separately for speed & handling of y = Inf or NaN return C(x, // preserve sign of 0 /* handle y -> Inf limit manually, since exp(y^2) -> Inf but Im[w(y)] -> 0, so IEEE will give us a NaN when it should be Inf */ y*y > 720 ? (y > 0 ? Inf : -Inf) : exp(y*y) * FADDEEVA(w_im)(y)); double mRe_z2 = (y - x) * (x + y); // Re(-z^2), being careful of overflow double mIm_z2 = -2*x*y; // Im(-z^2) if (mRe_z2 < -750) // underflow return (x >= 0 ? 1.0 : -1.0); /* Handle positive and negative x via different formulas, using the mirror symmetries of w, to avoid overflow/underflow problems from multiplying exponentially large and small quantities. */ if (x >= 0) { if (x < 8e-2) { if (fabs(y) < 1e-2) goto taylor; else if (fabs(mIm_z2) < 5e-3 && x < 5e-3) goto taylor_erfi; } /* don't use complex exp function, since that will produce spurious NaN values when multiplying w in an overflow situation. */ return 1.0 - exp(mRe_z2) * (C(cos(mIm_z2), sin(mIm_z2)) * FADDEEVA(w)(C(-y,x), relerr)); } else { // x < 0 if (x > -8e-2) { // duplicate from above to avoid fabs(x) call if (fabs(y) < 1e-2) goto taylor; else if (fabs(mIm_z2) < 5e-3 && x > -5e-3) goto taylor_erfi; } else if (isnan(x)) return C(NaN, y == 0 ? 0 : NaN); /* don't use complex exp function, since that will produce spurious NaN values when multiplying w in an overflow situation. */ return exp(mRe_z2) * (C(cos(mIm_z2), sin(mIm_z2)) * FADDEEVA(w)(C(y,-x), relerr)) - 1.0; } // Use Taylor series for small |z|, to avoid cancellation inaccuracy // erf(z) = 2/sqrt(pi) * z * (1 - z^2/3 + z^4/10 - z^6/42 + z^8/216 + ...) taylor: { cmplx mz2 = C(mRe_z2, mIm_z2); // -z^2 return z * (1.1283791670955125739 + mz2 * (0.37612638903183752464 + mz2 * (0.11283791670955125739 + mz2 * (0.026866170645131251760 + mz2 * 0.0052239776254421878422)))); } /* for small |x| and small |xy|, use Taylor series to avoid cancellation inaccuracy: erf(x+iy) = erf(iy) + 2*exp(y^2)/sqrt(pi) * [ x * (1 - x^2 * (1+2y^2)/3 + x^4 * (3+12y^2+4y^4)/30 + ... - i * x^2 * y * (1 - x^2 * (3+2y^2)/6 + ...) ] where: erf(iy) = exp(y^2) * Im[w(y)] */ taylor_erfi: { double x2 = x*x, y2 = y*y; double expy2 = exp(y2); return C (expy2 * x * (1.1283791670955125739 - x2 * (0.37612638903183752464 + 0.75225277806367504925*y2) + x2*x2 * (0.11283791670955125739 + y2 * (0.45135166683820502956 + 0.15045055561273500986*y2))), expy2 * (FADDEEVA(w_im)(y) - x2*y * (1.1283791670955125739 - x2 * (0.56418958354775628695 + 0.37612638903183752464*y2)))); } } // erfi(z) = -i erf(iz) cmplx FADDEEVA(erfi)(cmplx z, double relerr) { cmplx e = FADDEEVA(erf)(C(-cimag(z),creal(z)), relerr); return C(cimag(e), -creal(e)); } // erfi(x) = -i erf(ix) double FADDEEVA_RE(erfi)(double x) { return x*x > 720 ? (x > 0 ? Inf : -Inf) : exp(x*x) * FADDEEVA(w_im)(x); } // erfc(x) = 1 - erf(x) double FADDEEVA_RE(erfc)(double x) { #if !defined(__cplusplus) return erfc(x); // C99 supplies erfc in math.h #elif (__cplusplus >= 201103L) || defined(HAVE_ERFC) return ::erfc(x); // C++11 supplies std::erfc in cmath #else if (x*x > 750) // underflow return (x >= 0 ? 0.0 : 2.0); return x >= 0 ? exp(-x*x) * FADDEEVA_RE(erfcx)(x) : 2. - exp(-x*x) * FADDEEVA_RE(erfcx)(-x); #endif } // erfc(z) = 1 - erf(z) cmplx FADDEEVA(erfc)(cmplx z, double relerr) { double x = creal(z), y = cimag(z); if (x == 0.) return C(1, /* handle y -> Inf limit manually, since exp(y^2) -> Inf but Im[w(y)] -> 0, so IEEE will give us a NaN when it should be Inf */ y*y > 720 ? (y > 0 ? -Inf : Inf) : -exp(y*y) * FADDEEVA(w_im)(y)); if (y == 0.) { if (x*x > 750) // underflow return C(x >= 0 ? 0.0 : 2.0, -y); // preserve sign of 0 return C(x >= 0 ? exp(-x*x) * FADDEEVA_RE(erfcx)(x) : 2. - exp(-x*x) * FADDEEVA_RE(erfcx)(-x), -y); // preserve sign of zero } double mRe_z2 = (y - x) * (x + y); // Re(-z^2), being careful of overflow double mIm_z2 = -2*x*y; // Im(-z^2) if (mRe_z2 < -750) // underflow return (x >= 0 ? 0.0 : 2.0); if (x >= 0) return cexp(C(mRe_z2, mIm_z2)) * FADDEEVA(w)(C(-y,x), relerr); else return 2.0 - cexp(C(mRe_z2, mIm_z2)) * FADDEEVA(w)(C(y,-x), relerr); } // compute Dawson(x) = sqrt(pi)/2 * exp(-x^2) * erfi(x) double FADDEEVA_RE(Dawson)(double x) { const double spi2 = 0.8862269254527580136490837416705725913990; // sqrt(pi)/2 return spi2 * FADDEEVA(w_im)(x); } // compute Dawson(z) = sqrt(pi)/2 * exp(-z^2) * erfi(z) cmplx FADDEEVA(Dawson)(cmplx z, double relerr) { const double spi2 = 0.8862269254527580136490837416705725913990; // sqrt(pi)/2 double x = creal(z), y = cimag(z); // handle axes separately for speed & proper handling of x or y = Inf or NaN if (y == 0) return C(spi2 * FADDEEVA(w_im)(x), -y); // preserve sign of 0 if (x == 0) { double y2 = y*y; if (y2 < 2.5e-5) { // Taylor expansion return C(x, // preserve sign of 0 y * (1. + y2 * (0.6666666666666666666666666666666666666667 + y2 * 0.26666666666666666666666666666666666667))); } return C(x, // preserve sign of 0 spi2 * (y >= 0 ? exp(y2) - FADDEEVA_RE(erfcx)(y) : FADDEEVA_RE(erfcx)(-y) - exp(y2))); } double mRe_z2 = (y - x) * (x + y); // Re(-z^2), being careful of overflow double mIm_z2 = -2*x*y; // Im(-z^2) cmplx mz2 = C(mRe_z2, mIm_z2); // -z^2 /* Handle positive and negative x via different formulas, using the mirror symmetries of w, to avoid overflow/underflow problems from multiplying exponentially large and small quantities. */ if (y >= 0) { if (y < 5e-3) { if (fabs(x) < 5e-3) goto taylor; else if (fabs(mIm_z2) < 5e-3) goto taylor_realaxis; } cmplx res = cexp(mz2) - FADDEEVA(w)(z, relerr); return spi2 * C(-cimag(res), creal(res)); } else { // y < 0 if (y > -5e-3) { // duplicate from above to avoid fabs(x) call if (fabs(x) < 5e-3) goto taylor; else if (fabs(mIm_z2) < 5e-3) goto taylor_realaxis; } else if (isnan(y)) return C(x == 0 ? 0 : NaN, NaN); cmplx res = FADDEEVA(w)(-z, relerr) - cexp(mz2); return spi2 * C(-cimag(res), creal(res)); } // Use Taylor series for small |z|, to avoid cancellation inaccuracy // dawson(z) = z - 2/3 z^3 + 4/15 z^5 + ... taylor: return z * (1. + mz2 * (0.6666666666666666666666666666666666666667 + mz2 * 0.2666666666666666666666666666666666666667)); /* for small |y| and small |xy|, use Taylor series to avoid cancellation inaccuracy: dawson(x + iy) = D + y^2 (D + x - 2Dx^2) + y^4 (D/2 + 5x/6 - 2Dx^2 - x^3/3 + 2Dx^4/3) + iy [ (1-2Dx) + 2/3 y^2 (1 - 3Dx - x^2 + 2Dx^3) + y^4/15 (4 - 15Dx - 9x^2 + 20Dx^3 + 2x^4 - 4Dx^5) ] + ... where D = dawson(x) However, for large |x|, 2Dx -> 1 which gives cancellation problems in this series (many of the leading terms cancel). So, for large |x|, we need to substitute a continued-fraction expansion for D. dawson(x) = 0.5 / (x-0.5/(x-1/(x-1.5/(x-2/(x-2.5/(x...)))))) The 6 terms shown here seems to be the minimum needed to be accurate as soon as the simpler Taylor expansion above starts breaking down. Using this 6-term expansion, factoring out the denominator, and simplifying with Maple, we obtain: Re dawson(x + iy) * (-15 + 90x^2 - 60x^4 + 8x^6) / x = 33 - 28x^2 + 4x^4 + y^2 (18 - 4x^2) + 4 y^4 Im dawson(x + iy) * (-15 + 90x^2 - 60x^4 + 8x^6) / y = -15 + 24x^2 - 4x^4 + 2/3 y^2 (6x^2 - 15) - 4 y^4 Finally, for |x| > 5e7, we can use a simpler 1-term continued-fraction expansion for the real part, and a 2-term expansion for the imaginary part. (This avoids overflow problems for huge |x|.) This yields: Re dawson(x + iy) = [1 + y^2 (1 + y^2/2 - (xy)^2/3)] / (2x) Im dawson(x + iy) = y [ -1 - 2/3 y^2 + y^4/15 (2x^2 - 4) ] / (2x^2 - 1) */ taylor_realaxis: { double x2 = x*x; if (x2 > 1600) { // |x| > 40 double y2 = y*y; if (x2 > 25e14) {// |x| > 5e7 double xy2 = (x*y)*(x*y); return C((0.5 + y2 * (0.5 + 0.25*y2 - 0.16666666666666666667*xy2)) / x, y * (-1 + y2 * (-0.66666666666666666667 + 0.13333333333333333333*xy2 - 0.26666666666666666667*y2)) / (2*x2 - 1)); } return (1. / (-15 + x2*(90 + x2*(-60 + 8*x2)))) * C(x * (33 + x2 * (-28 + 4*x2) + y2 * (18 - 4*x2 + 4*y2)), y * (-15 + x2 * (24 - 4*x2) + y2 * (4*x2 - 10 - 4*y2))); } else { double D = spi2 * FADDEEVA(w_im)(x); double y2 = y*y; return C (D + y2 * (D + x - 2*D*x2) + y2*y2 * (D * (0.5 - x2 * (2 - 0.66666666666666666667*x2)) + x * (0.83333333333333333333 - 0.33333333333333333333 * x2)), y * (1 - 2*D*x + y2 * 0.66666666666666666667 * (1 - x2 - D*x * (3 - 2*x2)) + y2*y2 * (0.26666666666666666667 - x2 * (0.6 - 0.13333333333333333333 * x2) - D*x * (1 - x2 * (1.3333333333333333333 - 0.26666666666666666667 * x2))))); } } } ///////////////////////////////////////////////////////////////////////// // return sinc(x) = sin(x)/x, given both x and sin(x) // [since we only use this in cases where sin(x) has already been computed] static inline double sinc(double x, double sinx) { return fabs(x) < 1e-4 ? 1 - (0.1666666666666666666667)*x*x : sinx / x; } // sinh(x) via Taylor series, accurate to machine precision for |x| < 1e-2 static inline double sinh_taylor(double x) { return x * (1 + (x*x) * (0.1666666666666666666667 + 0.00833333333333333333333 * (x*x))); } static inline double sqr(double x) { return x*x; } // precomputed table of expa2n2[n-1] = exp(-a2*n*n) // for double-precision a2 = 0.26865... in FADDEEVA(w), below. static const double expa2n2[] = { 7.64405281671221563e-01, 3.41424527166548425e-01, 8.91072646929412548e-02, 1.35887299055460086e-02, 1.21085455253437481e-03, 6.30452613933449404e-05, 1.91805156577114683e-06, 3.40969447714832381e-08, 3.54175089099469393e-10, 2.14965079583260682e-12, 7.62368911833724354e-15, 1.57982797110681093e-17, 1.91294189103582677e-20, 1.35344656764205340e-23, 5.59535712428588720e-27, 1.35164257972401769e-30, 1.90784582843501167e-34, 1.57351920291442930e-38, 7.58312432328032845e-43, 2.13536275438697082e-47, 3.51352063787195769e-52, 3.37800830266396920e-57, 1.89769439468301000e-62, 6.22929926072668851e-68, 1.19481172006938722e-73, 1.33908181133005953e-79, 8.76924303483223939e-86, 3.35555576166254986e-92, 7.50264110688173024e-99, 9.80192200745410268e-106, 7.48265412822268959e-113, 3.33770122566809425e-120, 8.69934598159861140e-128, 1.32486951484088852e-135, 1.17898144201315253e-143, 6.13039120236180012e-152, 1.86258785950822098e-160, 3.30668408201432783e-169, 3.43017280887946235e-178, 2.07915397775808219e-187, 7.36384545323984966e-197, 1.52394760394085741e-206, 1.84281935046532100e-216, 1.30209553802992923e-226, 5.37588903521080531e-237, 1.29689584599763145e-247, 1.82813078022866562e-258, 1.50576355348684241e-269, 7.24692320799294194e-281, 2.03797051314726829e-292, 3.34880215927873807e-304, 0.0 // underflow (also prevents reads past array end, below) }; ///////////////////////////////////////////////////////////////////////// cmplx FADDEEVA(w)(cmplx z, double relerr) { if (creal(z) == 0.0) return C(FADDEEVA_RE(erfcx)(cimag(z)), creal(z)); // give correct sign of 0 in cimag(w) else if (cimag(z) == 0) return C(exp(-sqr(creal(z))), FADDEEVA(w_im)(creal(z))); double a, a2, c; if (relerr <= DBL_EPSILON) { relerr = DBL_EPSILON; a = 0.518321480430085929872; // pi / sqrt(-log(eps*0.5)) c = 0.329973702884629072537; // (2/pi) * a; a2 = 0.268657157075235951582; // a^2 } else { const double pi = 3.14159265358979323846264338327950288419716939937510582; if (relerr > 0.1) relerr = 0.1; // not sensible to compute < 1 digit a = pi / sqrt(-log(relerr*0.5)); c = (2/pi)*a; a2 = a*a; } const double x = fabs(creal(z)); const double y = cimag(z), ya = fabs(y); cmplx ret = 0.; // return value double sum1 = 0, sum2 = 0, sum3 = 0, sum4 = 0, sum5 = 0; #define USE_CONTINUED_FRACTION 1 // 1 to use continued fraction for large |z| #if USE_CONTINUED_FRACTION if (ya > 7 || (x > 6 // continued fraction is faster /* As pointed out by M. Zaghloul, the continued fraction seems to give a large relative error in Re w(z) for |x| ~ 6 and small |y|, so use algorithm 816 in this region: */ && (ya > 0.1 || (x > 8 && ya > 1e-10) || x > 28))) { /* Poppe & Wijers suggest using a number of terms nu = 3 + 1442 / (26*rho + 77) where rho = sqrt((x/x0)^2 + (y/y0)^2) where x0=6.3, y0=4.4. (They only use this expansion for rho >= 1, but rho a little less than 1 seems okay too.) Instead, I did my own fit to a slightly different function that avoids the hypotenuse calculation, using NLopt to minimize the sum of the squares of the errors in nu with the constraint that the estimated nu be >= minimum nu to attain machine precision. I also separate the regions where nu == 2 and nu == 1. */ const double ispi = 0.56418958354775628694807945156; // 1 / sqrt(pi) double xs = y < 0 ? -creal(z) : creal(z); // compute for -z if y < 0 if (x + ya > 4000) { // nu <= 2 if (x + ya > 1e7) { // nu == 1, w(z) = i/sqrt(pi) / z // scale to avoid overflow if (x > ya) { double yax = ya / xs; double denom = ispi / (xs + yax*ya); ret = C(denom*yax, denom); } else if (isinf(ya)) return ((isnan(x) || y < 0) ? C(NaN,NaN) : C(0,0)); else { double xya = xs / ya; double denom = ispi / (xya*xs + ya); ret = C(denom, denom*xya); } } else { // nu == 2, w(z) = i/sqrt(pi) * z / (z*z - 0.5) double dr = xs*xs - ya*ya - 0.5, di = 2*xs*ya; double denom = ispi / (dr*dr + di*di); ret = C(denom * (xs*di-ya*dr), denom * (xs*dr+ya*di)); } } else { // compute nu(z) estimate and do general continued fraction const double c0=3.9, c1=11.398, c2=0.08254, c3=0.1421, c4=0.2023; // fit double nu = floor(c0 + c1 / (c2*x + c3*ya + c4)); double wr = xs, wi = ya; for (nu = 0.5 * (nu - 1); nu > 0.4; nu -= 0.5) { // w <- z - nu/w: double denom = nu / (wr*wr + wi*wi); wr = xs - wr * denom; wi = ya + wi * denom; } { // w(z) = i/sqrt(pi) / w: double denom = ispi / (wr*wr + wi*wi); ret = C(denom*wi, denom*wr); } } if (y < 0) { // use w(z) = 2.0*exp(-z*z) - w(-z), // but be careful of overflow in exp(-z*z) // = exp(-(xs*xs-ya*ya) -2*i*xs*ya) return 2.0*cexp(C((ya-xs)*(xs+ya), 2*xs*y)) - ret; } else return ret; } #else // !USE_CONTINUED_FRACTION if (x + ya > 1e7) { // w(z) = i/sqrt(pi) / z, to machine precision const double ispi = 0.56418958354775628694807945156; // 1 / sqrt(pi) double xs = y < 0 ? -creal(z) : creal(z); // compute for -z if y < 0 // scale to avoid overflow if (x > ya) { double yax = ya / xs; double denom = ispi / (xs + yax*ya); ret = C(denom*yax, denom); } else { double xya = xs / ya; double denom = ispi / (xya*xs + ya); ret = C(denom, denom*xya); } if (y < 0) { // use w(z) = 2.0*exp(-z*z) - w(-z), // but be careful of overflow in exp(-z*z) // = exp(-(xs*xs-ya*ya) -2*i*xs*ya) return 2.0*cexp(C((ya-xs)*(xs+ya), 2*xs*y)) - ret; } else return ret; } #endif // !USE_CONTINUED_FRACTION /* Note: The test that seems to be suggested in the paper is x < sqrt(-log(DBL_MIN)), about 26.6, since otherwise exp(-x^2) underflows to zero and sum1,sum2,sum4 are zero. However, long before this occurs, the sum1,sum2,sum4 contributions are negligible in double precision; I find that this happens for x > about 6, for all y. On the other hand, I find that the case where we compute all of the sums is faster (at least with the precomputed expa2n2 table) until about x=10. Furthermore, if we try to compute all of the sums for x > 20, I find that we sometimes run into numerical problems because underflow/overflow problems start to appear in the various coefficients of the sums, below. Therefore, we use x < 10 here. */ else if (x < 10) { double prod2ax = 1, prodm2ax = 1; double expx2; if (isnan(y)) return C(y,y); /* Somewhat ugly copy-and-paste duplication here, but I see significant speedups from using the special-case code with the precomputed exponential, and the x < 5e-4 special case is needed for accuracy. */ if (relerr == DBL_EPSILON) { // use precomputed exp(-a2*(n*n)) table if (x < 5e-4) { // compute sum4 and sum5 together as sum5-sum4 const double x2 = x*x; expx2 = 1 - x2 * (1 - 0.5*x2); // exp(-x*x) via Taylor // compute exp(2*a*x) and exp(-2*a*x) via Taylor, to double precision const double ax2 = 1.036642960860171859744*x; // 2*a*x const double exp2ax = 1 + ax2 * (1 + ax2 * (0.5 + 0.166666666666666666667*ax2)); const double expm2ax = 1 - ax2 * (1 - ax2 * (0.5 - 0.166666666666666666667*ax2)); for (int n = 1; 1; ++n) { const double coef = expa2n2[n-1] * expx2 / (a2*(n*n) + y*y); prod2ax *= exp2ax; prodm2ax *= expm2ax; sum1 += coef; sum2 += coef * prodm2ax; sum3 += coef * prod2ax; // really = sum5 - sum4 sum5 += coef * (2*a) * n * sinh_taylor((2*a)*n*x); // test convergence via sum3 if (coef * prod2ax < relerr * sum3) break; } } else { // x > 5e-4, compute sum4 and sum5 separately expx2 = exp(-x*x); const double exp2ax = exp((2*a)*x), expm2ax = 1 / exp2ax; for (int n = 1; 1; ++n) { const double coef = expa2n2[n-1] * expx2 / (a2*(n*n) + y*y); prod2ax *= exp2ax; prodm2ax *= expm2ax; sum1 += coef; sum2 += coef * prodm2ax; sum4 += (coef * prodm2ax) * (a*n); sum3 += coef * prod2ax; sum5 += (coef * prod2ax) * (a*n); // test convergence via sum5, since this sum has the slowest decay if ((coef * prod2ax) * (a*n) < relerr * sum5) break; } } } else { // relerr != DBL_EPSILON, compute exp(-a2*(n*n)) on the fly const double exp2ax = exp((2*a)*x), expm2ax = 1 / exp2ax; if (x < 5e-4) { // compute sum4 and sum5 together as sum5-sum4 const double x2 = x*x; expx2 = 1 - x2 * (1 - 0.5*x2); // exp(-x*x) via Taylor for (int n = 1; 1; ++n) { const double coef = exp(-a2*(n*n)) * expx2 / (a2*(n*n) + y*y); prod2ax *= exp2ax; prodm2ax *= expm2ax; sum1 += coef; sum2 += coef * prodm2ax; sum3 += coef * prod2ax; // really = sum5 - sum4 sum5 += coef * (2*a) * n * sinh_taylor((2*a)*n*x); // test convergence via sum3 if (coef * prod2ax < relerr * sum3) break; } } else { // x > 5e-4, compute sum4 and sum5 separately expx2 = exp(-x*x); for (int n = 1; 1; ++n) { const double coef = exp(-a2*(n*n)) * expx2 / (a2*(n*n) + y*y); prod2ax *= exp2ax; prodm2ax *= expm2ax; sum1 += coef; sum2 += coef * prodm2ax; sum4 += (coef * prodm2ax) * (a*n); sum3 += coef * prod2ax; sum5 += (coef * prod2ax) * (a*n); // test convergence via sum5, since this sum has the slowest decay if ((coef * prod2ax) * (a*n) < relerr * sum5) break; } } } const double expx2erfcxy = // avoid spurious overflow for large negative y y > -6 // for y < -6, erfcx(y) = 2*exp(y*y) to double precision ? expx2*FADDEEVA_RE(erfcx)(y) : 2*exp(y*y-x*x); if (y > 5) { // imaginary terms cancel const double sinxy = sin(x*y); ret = (expx2erfcxy - c*y*sum1) * cos(2*x*y) + (c*x*expx2) * sinxy * sinc(x*y, sinxy); } else { double xs = creal(z); const double sinxy = sin(xs*y); const double sin2xy = sin(2*xs*y), cos2xy = cos(2*xs*y); const double coef1 = expx2erfcxy - c*y*sum1; const double coef2 = c*xs*expx2; ret = C(coef1 * cos2xy + coef2 * sinxy * sinc(xs*y, sinxy), coef2 * sinc(2*xs*y, sin2xy) - coef1 * sin2xy); } } else { // x large: only sum3 & sum5 contribute (see above note) if (isnan(x)) return C(x,x); if (isnan(y)) return C(y,y); #if USE_CONTINUED_FRACTION ret = exp(-x*x); // |y| < 1e-10, so we only need exp(-x*x) term #else if (y < 0) { /* erfcx(y) ~ 2*exp(y*y) + (< 1) if y < 0, so erfcx(y)*exp(-x*x) ~ 2*exp(y*y-x*x) term may not be negligible if y*y - x*x > -36 or so. So, compute this term just in case. We also need the -exp(-x*x) term to compute Re[w] accurately in the case where y is very small. */ ret = cpolar(2*exp(y*y-x*x) - exp(-x*x), -2*creal(z)*y); } else ret = exp(-x*x); // not negligible in real part if y very small #endif // (round instead of ceil as in original paper; note that x/a > 1 here) double n0 = floor(x/a + 0.5); // sum in both directions, starting at n0 double dx = a*n0 - x; sum3 = exp(-dx*dx) / (a2*(n0*n0) + y*y); sum5 = a*n0 * sum3; double exp1 = exp(4*a*dx), exp1dn = 1; int dn; for (dn = 1; n0 - dn > 0; ++dn) { // loop over n0-dn and n0+dn terms double np = n0 + dn, nm = n0 - dn; double tp = exp(-sqr(a*dn+dx)); double tm = tp * (exp1dn *= exp1); // trick to get tm from tp tp /= (a2*(np*np) + y*y); tm /= (a2*(nm*nm) + y*y); sum3 += tp + tm; sum5 += a * (np * tp + nm * tm); if (a * (np * tp + nm * tm) < relerr * sum5) goto finish; } while (1) { // loop over n0+dn terms only (since n0-dn <= 0) double np = n0 + dn++; double tp = exp(-sqr(a*dn+dx)) / (a2*(np*np) + y*y); sum3 += tp; sum5 += a * np * tp; if (a * np * tp < relerr * sum5) goto finish; } } finish: return ret + C((0.5*c)*y*(sum2+sum3), (0.5*c)*copysign(sum5-sum4, creal(z))); } ///////////////////////////////////////////////////////////////////////// /* erfcx(x) = exp(x^2) erfc(x) function, for real x, written by Steven G. Johnson, October 2012. This function combines a few different ideas. First, for x > 50, it uses a continued-fraction expansion (same as for the Faddeeva function, but with algebraic simplifications for z=i*x). Second, for 0 <= x <= 50, it uses Chebyshev polynomial approximations, but with two twists: a) It maps x to y = 4 / (4+x) in [0,1]. This simple transformation, inspired by a similar transformation in the octave-forge/specfun erfcx by Soren Hauberg, results in much faster Chebyshev convergence than other simple transformations I have examined. b) Instead of using a single Chebyshev polynomial for the entire [0,1] y interval, we break the interval up into 100 equal subintervals, with a switch/lookup table, and use much lower degree Chebyshev polynomials in each subinterval. This greatly improves performance in my tests. For x < 0, we use the relationship erfcx(-x) = 2 exp(x^2) - erfc(x), with the usual checks for overflow etcetera. Performance-wise, it seems to be substantially faster than either the SLATEC DERFC function [or an erfcx function derived therefrom] or Cody's CALERF function (from netlib.org/specfun), while retaining near machine precision in accuracy. */ /* Given y100=100*y, where y = 4/(4+x) for x >= 0, compute erfc(x). Uses a look-up table of 100 different Chebyshev polynomials for y intervals [0,0.01], [0.01,0.02], ...., [0.99,1], generated with the help of Maple and a little shell script. This allows the Chebyshev polynomials to be of significantly lower degree (about 1/4) compared to fitting the whole [0,1] interval with a single polynomial. */ static double erfcx_y100(double y100) { switch ((int) y100) { case 0: { double t = 2*y100 - 1; return 0.70878032454106438663e-3 + (0.71234091047026302958e-3 + (0.35779077297597742384e-5 + (0.17403143962587937815e-7 + (0.81710660047307788845e-10 + (0.36885022360434957634e-12 + 0.15917038551111111111e-14 * t) * t) * t) * t) * t) * t; } case 1: { double t = 2*y100 - 3; return 0.21479143208285144230e-2 + (0.72686402367379996033e-3 + (0.36843175430938995552e-5 + (0.18071841272149201685e-7 + (0.85496449296040325555e-10 + (0.38852037518534291510e-12 + 0.16868473576888888889e-14 * t) * t) * t) * t) * t) * t; } case 2: { double t = 2*y100 - 5; return 0.36165255935630175090e-2 + (0.74182092323555510862e-3 + (0.37948319957528242260e-5 + (0.18771627021793087350e-7 + (0.89484715122415089123e-10 + (0.40935858517772440862e-12 + 0.17872061464888888889e-14 * t) * t) * t) * t) * t) * t; } case 3: { double t = 2*y100 - 7; return 0.51154983860031979264e-2 + (0.75722840734791660540e-3 + (0.39096425726735703941e-5 + (0.19504168704300468210e-7 + (0.93687503063178993915e-10 + (0.43143925959079664747e-12 + 0.18939926435555555556e-14 * t) * t) * t) * t) * t) * t; } case 4: { double t = 2*y100 - 9; return 0.66457513172673049824e-2 + (0.77310406054447454920e-3 + (0.40289510589399439385e-5 + (0.20271233238288381092e-7 + (0.98117631321709100264e-10 + (0.45484207406017752971e-12 + 0.20076352213333333333e-14 * t) * t) * t) * t) * t) * t; } case 5: { double t = 2*y100 - 11; return 0.82082389970241207883e-2 + (0.78946629611881710721e-3 + (0.41529701552622656574e-5 + (0.21074693344544655714e-7 + (0.10278874108587317989e-9 + (0.47965201390613339638e-12 + 0.21285907413333333333e-14 * t) * t) * t) * t) * t) * t; } case 6: { double t = 2*y100 - 13; return 0.98039537275352193165e-2 + (0.80633440108342840956e-3 + (0.42819241329736982942e-5 + (0.21916534346907168612e-7 + (0.10771535136565470914e-9 + (0.50595972623692822410e-12 + 0.22573462684444444444e-14 * t) * t) * t) * t) * t) * t; } case 7: { double t = 2*y100 - 15; return 0.11433927298290302370e-1 + (0.82372858383196561209e-3 + (0.44160495311765438816e-5 + (0.22798861426211986056e-7 + (0.11291291745879239736e-9 + (0.53386189365816880454e-12 + 0.23944209546666666667e-14 * t) * t) * t) * t) * t) * t; } case 8: { double t = 2*y100 - 17; return 0.13099232878814653979e-1 + (0.84167002467906968214e-3 + (0.45555958988457506002e-5 + (0.23723907357214175198e-7 + (0.11839789326602695603e-9 + (0.56346163067550237877e-12 + 0.25403679644444444444e-14 * t) * t) * t) * t) * t) * t; } case 9: { double t = 2*y100 - 19; return 0.14800987015587535621e-1 + (0.86018092946345943214e-3 + (0.47008265848816866105e-5 + (0.24694040760197315333e-7 + (0.12418779768752299093e-9 + (0.59486890370320261949e-12 + 0.26957764568888888889e-14 * t) * t) * t) * t) * t) * t; } case 10: { double t = 2*y100 - 21; return 0.16540351739394069380e-1 + (0.87928458641241463952e-3 + (0.48520195793001753903e-5 + (0.25711774900881709176e-7 + (0.13030128534230822419e-9 + (0.62820097586874779402e-12 + 0.28612737351111111111e-14 * t) * t) * t) * t) * t) * t; } case 11: { double t = 2*y100 - 23; return 0.18318536789842392647e-1 + (0.89900542647891721692e-3 + (0.50094684089553365810e-5 + (0.26779777074218070482e-7 + (0.13675822186304615566e-9 + (0.66358287745352705725e-12 + 0.30375273884444444444e-14 * t) * t) * t) * t) * t) * t; } case 12: { double t = 2*y100 - 25; return 0.20136801964214276775e-1 + (0.91936908737673676012e-3 + (0.51734830914104276820e-5 + (0.27900878609710432673e-7 + (0.14357976402809042257e-9 + (0.70114790311043728387e-12 + 0.32252476000000000000e-14 * t) * t) * t) * t) * t) * t; } case 13: { double t = 2*y100 - 27; return 0.21996459598282740954e-1 + (0.94040248155366777784e-3 + (0.53443911508041164739e-5 + (0.29078085538049374673e-7 + (0.15078844500329731137e-9 + (0.74103813647499204269e-12 + 0.34251892320000000000e-14 * t) * t) * t) * t) * t) * t; } case 14: { double t = 2*y100 - 29; return 0.23898877187226319502e-1 + (0.96213386835900177540e-3 + (0.55225386998049012752e-5 + (0.30314589961047687059e-7 + (0.15840826497296335264e-9 + (0.78340500472414454395e-12 + 0.36381553564444444445e-14 * t) * t) * t) * t) * t) * t; } case 15: { double t = 2*y100 - 31; return 0.25845480155298518485e-1 + (0.98459293067820123389e-3 + (0.57082915920051843672e-5 + (0.31613782169164830118e-7 + (0.16646478745529630813e-9 + (0.82840985928785407942e-12 + 0.38649975768888888890e-14 * t) * t) * t) * t) * t) * t; } case 16: { double t = 2*y100 - 33; return 0.27837754783474696598e-1 + (0.10078108563256892757e-2 + (0.59020366493792212221e-5 + (0.32979263553246520417e-7 + (0.17498524159268458073e-9 + (0.87622459124842525110e-12 + 0.41066206488888888890e-14 * t) * t) * t) * t) * t) * t; } case 17: { double t = 2*y100 - 35; return 0.29877251304899307550e-1 + (0.10318204245057349310e-2 + (0.61041829697162055093e-5 + (0.34414860359542720579e-7 + (0.18399863072934089607e-9 + (0.92703227366365046533e-12 + 0.43639844053333333334e-14 * t) * t) * t) * t) * t) * t; } case 18: { double t = 2*y100 - 37; return 0.31965587178596443475e-1 + (0.10566560976716574401e-2 + (0.63151633192414586770e-5 + (0.35924638339521924242e-7 + (0.19353584758781174038e-9 + (0.98102783859889264382e-12 + 0.46381060817777777779e-14 * t) * t) * t) * t) * t) * t; } case 19: { double t = 2*y100 - 39; return 0.34104450552588334840e-1 + (0.10823541191350532574e-2 + (0.65354356159553934436e-5 + (0.37512918348533521149e-7 + (0.20362979635817883229e-9 + (0.10384187833037282363e-11 + 0.49300625262222222221e-14 * t) * t) * t) * t) * t) * t; } case 20: { double t = 2*y100 - 41; return 0.36295603928292425716e-1 + (0.11089526167995268200e-2 + (0.67654845095518363577e-5 + (0.39184292949913591646e-7 + (0.21431552202133775150e-9 + (0.10994259106646731797e-11 + 0.52409949102222222221e-14 * t) * t) * t) * t) * t) * t; } case 21: { double t = 2*y100 - 43; return 0.38540888038840509795e-1 + (0.11364917134175420009e-2 + (0.70058230641246312003e-5 + (0.40943644083718586939e-7 + (0.22563034723692881631e-9 + (0.11642841011361992885e-11 + 0.55721092871111111110e-14 * t) * t) * t) * t) * t) * t; } case 22: { double t = 2*y100 - 45; return 0.40842225954785960651e-1 + (0.11650136437945673891e-2 + (0.72569945502343006619e-5 + (0.42796161861855042273e-7 + (0.23761401711005024162e-9 + (0.12332431172381557035e-11 + 0.59246802364444444445e-14 * t) * t) * t) * t) * t) * t; } case 23: { double t = 2*y100 - 47; return 0.43201627431540222422e-1 + (0.11945628793917272199e-2 + (0.75195743532849206263e-5 + (0.44747364553960993492e-7 + (0.25030885216472953674e-9 + (0.13065684400300476484e-11 + 0.63000532853333333334e-14 * t) * t) * t) * t) * t) * t; } case 24: { double t = 2*y100 - 49; return 0.45621193513810471438e-1 + (0.12251862608067529503e-2 + (0.77941720055551920319e-5 + (0.46803119830954460212e-7 + (0.26375990983978426273e-9 + (0.13845421370977119765e-11 + 0.66996477404444444445e-14 * t) * t) * t) * t) * t) * t; } case 25: { double t = 2*y100 - 51; return 0.48103121413299865517e-1 + (0.12569331386432195113e-2 + (0.80814333496367673980e-5 + (0.48969667335682018324e-7 + (0.27801515481905748484e-9 + (0.14674637611609884208e-11 + 0.71249589351111111110e-14 * t) * t) * t) * t) * t) * t; } case 26: { double t = 2*y100 - 53; return 0.50649709676983338501e-1 + (0.12898555233099055810e-2 + (0.83820428414568799654e-5 + (0.51253642652551838659e-7 + (0.29312563849675507232e-9 + (0.15556512782814827846e-11 + 0.75775607822222222221e-14 * t) * t) * t) * t) * t) * t; } case 27: { double t = 2*y100 - 55; return 0.53263363664388864181e-1 + (0.13240082443256975769e-2 + (0.86967260015007658418e-5 + (0.53662102750396795566e-7 + (0.30914568786634796807e-9 + (0.16494420240828493176e-11 + 0.80591079644444444445e-14 * t) * t) * t) * t) * t) * t; } case 28: { double t = 2*y100 - 57; return 0.55946601353500013794e-1 + (0.13594491197408190706e-2 + (0.90262520233016380987e-5 + (0.56202552975056695376e-7 + (0.32613310410503135996e-9 + (0.17491936862246367398e-11 + 0.85713381688888888890e-14 * t) * t) * t) * t) * t) * t; } case 29: { double t = 2*y100 - 59; return 0.58702059496154081813e-1 + (0.13962391363223647892e-2 + (0.93714365487312784270e-5 + (0.58882975670265286526e-7 + (0.34414937110591753387e-9 + (0.18552853109751857859e-11 + 0.91160736711111111110e-14 * t) * t) * t) * t) * t) * t; } case 30: { double t = 2*y100 - 61; return 0.61532500145144778048e-1 + (0.14344426411912015247e-2 + (0.97331446201016809696e-5 + (0.61711860507347175097e-7 + (0.36325987418295300221e-9 + (0.19681183310134518232e-11 + 0.96952238400000000000e-14 * t) * t) * t) * t) * t) * t; } case 31: { double t = 2*y100 - 63; return 0.64440817576653297993e-1 + (0.14741275456383131151e-2 + (0.10112293819576437838e-4 + (0.64698236605933246196e-7 + (0.38353412915303665586e-9 + (0.20881176114385120186e-11 + 0.10310784480000000000e-13 * t) * t) * t) * t) * t) * t; } case 32: { double t = 2*y100 - 65; return 0.67430045633130393282e-1 + (0.15153655418916540370e-2 + (0.10509857606888328667e-4 + (0.67851706529363332855e-7 + (0.40504602194811140006e-9 + (0.22157325110542534469e-11 + 0.10964842115555555556e-13 * t) * t) * t) * t) * t) * t; } case 33: { double t = 2*y100 - 67; return 0.70503365513338850709e-1 + (0.15582323336495709827e-2 + (0.10926868866865231089e-4 + (0.71182482239613507542e-7 + (0.42787405890153386710e-9 + (0.23514379522274416437e-11 + 0.11659571751111111111e-13 * t) * t) * t) * t) * t) * t; } case 34: { double t = 2*y100 - 69; return 0.73664114037944596353e-1 + (0.16028078812438820413e-2 + (0.11364423678778207991e-4 + (0.74701423097423182009e-7 + (0.45210162777476488324e-9 + (0.24957355004088569134e-11 + 0.12397238257777777778e-13 * t) * t) * t) * t) * t) * t; } case 35: { double t = 2*y100 - 71; return 0.76915792420819562379e-1 + (0.16491766623447889354e-2 + (0.11823685320041302169e-4 + (0.78420075993781544386e-7 + (0.47781726956916478925e-9 + (0.26491544403815724749e-11 + 0.13180196462222222222e-13 * t) * t) * t) * t) * t) * t; } case 36: { double t = 2*y100 - 73; return 0.80262075578094612819e-1 + (0.16974279491709504117e-2 + (0.12305888517309891674e-4 + (0.82350717698979042290e-7 + (0.50511496109857113929e-9 + (0.28122528497626897696e-11 + 0.14010889635555555556e-13 * t) * t) * t) * t) * t) * t; } case 37: { double t = 2*y100 - 75; return 0.83706822008980357446e-1 + (0.17476561032212656962e-2 + (0.12812343958540763368e-4 + (0.86506399515036435592e-7 + (0.53409440823869467453e-9 + (0.29856186620887555043e-11 + 0.14891851591111111111e-13 * t) * t) * t) * t) * t) * t; } case 38: { double t = 2*y100 - 77; return 0.87254084284461718231e-1 + (0.17999608886001962327e-2 + (0.13344443080089492218e-4 + (0.90900994316429008631e-7 + (0.56486134972616465316e-9 + (0.31698707080033956934e-11 + 0.15825697795555555556e-13 * t) * t) * t) * t) * t) * t; } case 39: { double t = 2*y100 - 79; return 0.90908120182172748487e-1 + (0.18544478050657699758e-2 + (0.13903663143426120077e-4 + (0.95549246062549906177e-7 + (0.59752787125242054315e-9 + (0.33656597366099099413e-11 + 0.16815130613333333333e-13 * t) * t) * t) * t) * t) * t; } case 40: { double t = 2*y100 - 81; return 0.94673404508075481121e-1 + (0.19112284419887303347e-2 + (0.14491572616545004930e-4 + (0.10046682186333613697e-6 + (0.63221272959791000515e-9 + (0.35736693975589130818e-11 + 0.17862931591111111111e-13 * t) * t) * t) * t) * t) * t; } case 41: { double t = 2*y100 - 83; return 0.98554641648004456555e-1 + (0.19704208544725622126e-2 + (0.15109836875625443935e-4 + (0.10567036667675984067e-6 + (0.66904168640019354565e-9 + (0.37946171850824333014e-11 + 0.18971959040000000000e-13 * t) * t) * t) * t) * t) * t; } case 42: { double t = 2*y100 - 85; return 0.10255677889470089531e0 + (0.20321499629472857418e-2 + (0.15760224242962179564e-4 + (0.11117756071353507391e-6 + (0.70814785110097658502e-9 + (0.40292553276632563925e-11 + 0.20145143075555555556e-13 * t) * t) * t) * t) * t) * t; } case 43: { double t = 2*y100 - 87; return 0.10668502059865093318e0 + (0.20965479776148731610e-2 + (0.16444612377624983565e-4 + (0.11700717962026152749e-6 + (0.74967203250938418991e-9 + (0.42783716186085922176e-11 + 0.21385479360000000000e-13 * t) * t) * t) * t) * t) * t; } case 44: { double t = 2*y100 - 89; return 0.11094484319386444474e0 + (0.21637548491908170841e-2 + (0.17164995035719657111e-4 + (0.12317915750735938089e-6 + (0.79376309831499633734e-9 + (0.45427901763106353914e-11 + 0.22696025653333333333e-13 * t) * t) * t) * t) * t) * t; } case 45: { double t = 2*y100 - 91; return 0.11534201115268804714e0 + (0.22339187474546420375e-2 + (0.17923489217504226813e-4 + (0.12971465288245997681e-6 + (0.84057834180389073587e-9 + (0.48233721206418027227e-11 + 0.24079890062222222222e-13 * t) * t) * t) * t) * t) * t; } case 46: { double t = 2*y100 - 93; return 0.11988259392684094740e0 + (0.23071965691918689601e-2 + (0.18722342718958935446e-4 + (0.13663611754337957520e-6 + (0.89028385488493287005e-9 + (0.51210161569225846701e-11 + 0.25540227111111111111e-13 * t) * t) * t) * t) * t) * t; } case 47: { double t = 2*y100 - 95; return 0.12457298393509812907e0 + (0.23837544771809575380e-2 + (0.19563942105711612475e-4 + (0.14396736847739470782e-6 + (0.94305490646459247016e-9 + (0.54366590583134218096e-11 + 0.27080225920000000000e-13 * t) * t) * t) * t) * t) * t; } case 48: { double t = 2*y100 - 97; return 0.12941991566142438816e0 + (0.24637684719508859484e-2 + (0.20450821127475879816e-4 + (0.15173366280523906622e-6 + (0.99907632506389027739e-9 + (0.57712760311351625221e-11 + 0.28703099555555555556e-13 * t) * t) * t) * t) * t) * t; } case 49: { double t = 2*y100 - 99; return 0.13443048593088696613e0 + (0.25474249981080823877e-2 + (0.21385669591362915223e-4 + (0.15996177579900443030e-6 + (0.10585428844575134013e-8 + (0.61258809536787882989e-11 + 0.30412080142222222222e-13 * t) * t) * t) * t) * t) * t; } case 50: { double t = 2*y100 - 101; return 0.13961217543434561353e0 + (0.26349215871051761416e-2 + (0.22371342712572567744e-4 + (0.16868008199296822247e-6 + (0.11216596910444996246e-8 + (0.65015264753090890662e-11 + 0.32210394506666666666e-13 * t) * t) * t) * t) * t) * t; } case 51: { double t = 2*y100 - 103; return 0.14497287157673800690e0 + (0.27264675383982439814e-2 + (0.23410870961050950197e-4 + (0.17791863939526376477e-6 + (0.11886425714330958106e-8 + (0.68993039665054288034e-11 + 0.34101266222222222221e-13 * t) * t) * t) * t) * t) * t; } case 52: { double t = 2*y100 - 105; return 0.15052089272774618151e0 + (0.28222846410136238008e-2 + (0.24507470422713397006e-4 + (0.18770927679626136909e-6 + (0.12597184587583370712e-8 + (0.73203433049229821618e-11 + 0.36087889048888888890e-13 * t) * t) * t) * t) * t) * t; } case 53: { double t = 2*y100 - 107; return 0.15626501395774612325e0 + (0.29226079376196624949e-2 + (0.25664553693768450545e-4 + (0.19808568415654461964e-6 + (0.13351257759815557897e-8 + (0.77658124891046760667e-11 + 0.38173420035555555555e-13 * t) * t) * t) * t) * t) * t; } case 54: { double t = 2*y100 - 109; return 0.16221449434620737567e0 + (0.30276865332726475672e-2 + (0.26885741326534564336e-4 + (0.20908350604346384143e-6 + (0.14151148144240728728e-8 + (0.82369170665974313027e-11 + 0.40360957457777777779e-13 * t) * t) * t) * t) * t) * t; } case 55: { double t = 2*y100 - 111; return 0.16837910595412130659e0 + (0.31377844510793082301e-2 + (0.28174873844911175026e-4 + (0.22074043807045782387e-6 + (0.14999481055996090039e-8 + (0.87348993661930809254e-11 + 0.42653528977777777779e-13 * t) * t) * t) * t) * t) * t; } case 56: { double t = 2*y100 - 113; return 0.17476916455659369953e0 + (0.32531815370903068316e-2 + (0.29536024347344364074e-4 + (0.23309632627767074202e-6 + (0.15899007843582444846e-8 + (0.92610375235427359475e-11 + 0.45054073102222222221e-13 * t) * t) * t) * t) * t) * t; } case 57: { double t = 2*y100 - 115; return 0.18139556223643701364e0 + (0.33741744168096996041e-2 + (0.30973511714709500836e-4 + (0.24619326937592290996e-6 + (0.16852609412267750744e-8 + (0.98166442942854895573e-11 + 0.47565418097777777779e-13 * t) * t) * t) * t) * t) * t; } case 58: { double t = 2*y100 - 117; return 0.18826980194443664549e0 + (0.35010775057740317997e-2 + (0.32491914440014267480e-4 + (0.26007572375886319028e-6 + (0.17863299617388376116e-8 + (0.10403065638343878679e-10 + 0.50190265831111111110e-13 * t) * t) * t) * t) * t) * t; } case 59: { double t = 2*y100 - 119; return 0.19540403413693967350e0 + (0.36342240767211326315e-2 + (0.34096085096200907289e-4 + (0.27479061117017637474e-6 + (0.18934228504790032826e-8 + (0.11021679075323598664e-10 + 0.52931171733333333334e-13 * t) * t) * t) * t) * t) * t; } case 60: { double t = 2*y100 - 121; return 0.20281109560651886959e0 + (0.37739673859323597060e-2 + (0.35791165457592409054e-4 + (0.29038742889416172404e-6 + (0.20068685374849001770e-8 + (0.11673891799578381999e-10 + 0.55790523093333333334e-13 * t) * t) * t) * t) * t) * t; } case 61: { double t = 2*y100 - 123; return 0.21050455062669334978e0 + (0.39206818613925652425e-2 + (0.37582602289680101704e-4 + (0.30691836231886877385e-6 + (0.21270101645763677824e-8 + (0.12361138551062899455e-10 + 0.58770520160000000000e-13 * t) * t) * t) * t) * t) * t; } case 62: { double t = 2*y100 - 125; return 0.21849873453703332479e0 + (0.40747643554689586041e-2 + (0.39476163820986711501e-4 + (0.32443839970139918836e-6 + (0.22542053491518680200e-8 + (0.13084879235290858490e-10 + 0.61873153262222222221e-13 * t) * t) * t) * t) * t) * t; } case 63: { double t = 2*y100 - 127; return 0.22680879990043229327e0 + (0.42366354648628516935e-2 + (0.41477956909656896779e-4 + (0.34300544894502810002e-6 + (0.23888264229264067658e-8 + (0.13846596292818514601e-10 + 0.65100183751111111110e-13 * t) * t) * t) * t) * t) * t; } case 64: { double t = 2*y100 - 129; return 0.23545076536988703937e0 + (0.44067409206365170888e-2 + (0.43594444916224700881e-4 + (0.36268045617760415178e-6 + (0.25312606430853202748e-8 + (0.14647791812837903061e-10 + 0.68453122631111111110e-13 * t) * t) * t) * t) * t) * t; } case 65: { double t = 2*y100 - 131; return 0.24444156740777432838e0 + (0.45855530511605787178e-2 + (0.45832466292683085475e-4 + (0.38352752590033030472e-6 + (0.26819103733055603460e-8 + (0.15489984390884756993e-10 + 0.71933206364444444445e-13 * t) * t) * t) * t) * t) * t; } case 66: { double t = 2*y100 - 133; return 0.25379911500634264643e0 + (0.47735723208650032167e-2 + (0.48199253896534185372e-4 + (0.40561404245564732314e-6 + (0.28411932320871165585e-8 + (0.16374705736458320149e-10 + 0.75541379822222222221e-13 * t) * t) * t) * t) * t) * t; } case 67: { double t = 2*y100 - 135; return 0.26354234756393613032e0 + (0.49713289477083781266e-2 + (0.50702455036930367504e-4 + (0.42901079254268185722e-6 + (0.30095422058900481753e-8 + (0.17303497025347342498e-10 + 0.79278273368888888890e-13 * t) * t) * t) * t) * t) * t; } case 68: { double t = 2*y100 - 137; return 0.27369129607732343398e0 + (0.51793846023052643767e-2 + (0.53350152258326602629e-4 + (0.45379208848865015485e-6 + (0.31874057245814381257e-8 + (0.18277905010245111046e-10 + 0.83144182364444444445e-13 * t) * t) * t) * t) * t) * t; } case 69: { double t = 2*y100 - 139; return 0.28426714781640316172e0 + (0.53983341916695141966e-2 + (0.56150884865255810638e-4 + (0.48003589196494734238e-6 + (0.33752476967570796349e-8 + (0.19299477888083469086e-10 + 0.87139049137777777779e-13 * t) * t) * t) * t) * t) * t; } case 70: { double t = 2*y100 - 141; return 0.29529231465348519920e0 + (0.56288077305420795663e-2 + (0.59113671189913307427e-4 + (0.50782393781744840482e-6 + (0.35735475025851713168e-8 + (0.20369760937017070382e-10 + 0.91262442613333333334e-13 * t) * t) * t) * t) * t) * t; } case 71: { double t = 2*y100 - 143; return 0.30679050522528838613e0 + (0.58714723032745403331e-2 + (0.62248031602197686791e-4 + (0.53724185766200945789e-6 + (0.37827999418960232678e-8 + (0.21490291930444538307e-10 + 0.95513539182222222221e-13 * t) * t) * t) * t) * t) * t; } case 72: { double t = 2*y100 - 145; return 0.31878680111173319425e0 + (0.61270341192339103514e-2 + (0.65564012259707640976e-4 + (0.56837930287837738996e-6 + (0.40035151353392378882e-8 + (0.22662596341239294792e-10 + 0.99891109760000000000e-13 * t) * t) * t) * t) * t) * t; } case 73: { double t = 2*y100 - 147; return 0.33130773722152622027e0 + (0.63962406646798080903e-2 + (0.69072209592942396666e-4 + (0.60133006661885941812e-6 + (0.42362183765883466691e-8 + (0.23888182347073698382e-10 + 0.10439349811555555556e-12 * t) * t) * t) * t) * t) * t; } case 74: { double t = 2*y100 - 149; return 0.34438138658041336523e0 + (0.66798829540414007258e-2 + (0.72783795518603561144e-4 + (0.63619220443228800680e-6 + (0.44814499336514453364e-8 + (0.25168535651285475274e-10 + 0.10901861383111111111e-12 * t) * t) * t) * t) * t) * t; } case 75: { double t = 2*y100 - 151; return 0.35803744972380175583e0 + (0.69787978834882685031e-2 + (0.76710543371454822497e-4 + (0.67306815308917386747e-6 + (0.47397647975845228205e-8 + (0.26505114141143050509e-10 + 0.11376390933333333333e-12 * t) * t) * t) * t) * t) * t; } case 76: { double t = 2*y100 - 153; return 0.37230734890119724188e0 + (0.72938706896461381003e-2 + (0.80864854542670714092e-4 + (0.71206484718062688779e-6 + (0.50117323769745883805e-8 + (0.27899342394100074165e-10 + 0.11862637614222222222e-12 * t) * t) * t) * t) * t) * t; } case 77: { double t = 2*y100 - 155; return 0.38722432730555448223e0 + (0.76260375162549802745e-2 + (0.85259785810004603848e-4 + (0.75329383305171327677e-6 + (0.52979361368388119355e-8 + (0.29352606054164086709e-10 + 0.12360253370666666667e-12 * t) * t) * t) * t) * t) * t; } case 78: { double t = 2*y100 - 157; return 0.40282355354616940667e0 + (0.79762880915029728079e-2 + (0.89909077342438246452e-4 + (0.79687137961956194579e-6 + (0.55989731807360403195e-8 + (0.30866246101464869050e-10 + 0.12868841946666666667e-12 * t) * t) * t) * t) * t) * t; } case 79: { double t = 2*y100 - 159; return 0.41914223158913787649e0 + (0.83456685186950463538e-2 + (0.94827181359250161335e-4 + (0.84291858561783141014e-6 + (0.59154537751083485684e-8 + (0.32441553034347469291e-10 + 0.13387957943111111111e-12 * t) * t) * t) * t) * t) * t; } case 80: { double t = 2*y100 - 161; return 0.43621971639463786896e0 + (0.87352841828289495773e-2 + (0.10002929142066799966e-3 + (0.89156148280219880024e-6 + (0.62480008150788597147e-8 + (0.34079760983458878910e-10 + 0.13917107176888888889e-12 * t) * t) * t) * t) * t) * t; } case 81: { double t = 2*y100 - 163; return 0.45409763548534330981e0 + (0.91463027755548240654e-2 + (0.10553137232446167258e-3 + (0.94293113464638623798e-6 + (0.65972492312219959885e-8 + (0.35782041795476563662e-10 + 0.14455745872000000000e-12 * t) * t) * t) * t) * t) * t; } case 82: { double t = 2*y100 - 165; return 0.47282001668512331468e0 + (0.95799574408860463394e-2 + (0.11135019058000067469e-3 + (0.99716373005509038080e-6 + (0.69638453369956970347e-8 + (0.37549499088161345850e-10 + 0.15003280712888888889e-12 * t) * t) * t) * t) * t) * t; } case 83: { double t = 2*y100 - 167; return 0.49243342227179841649e0 + (0.10037550043909497071e-1 + (0.11750334542845234952e-3 + (0.10544006716188967172e-5 + (0.73484461168242224872e-8 + (0.39383162326435752965e-10 + 0.15559069118222222222e-12 * t) * t) * t) * t) * t) * t; } case 84: { double t = 2*y100 - 169; return 0.51298708979209258326e0 + (0.10520454564612427224e-1 + (0.12400930037494996655e-3 + (0.11147886579371265246e-5 + (0.77517184550568711454e-8 + (0.41283980931872622611e-10 + 0.16122419680000000000e-12 * t) * t) * t) * t) * t) * t; } case 85: { double t = 2*y100 - 171; return 0.53453307979101369843e0 + (0.11030120618800726938e-1 + (0.13088741519572269581e-3 + (0.11784797595374515432e-5 + (0.81743383063044825400e-8 + (0.43252818449517081051e-10 + 0.16692592640000000000e-12 * t) * t) * t) * t) * t) * t; } case 86: { double t = 2*y100 - 173; return 0.55712643071169299478e0 + (0.11568077107929735233e-1 + (0.13815797838036651289e-3 + (0.12456314879260904558e-5 + (0.86169898078969313597e-8 + (0.45290446811539652525e-10 + 0.17268801084444444444e-12 * t) * t) * t) * t) * t) * t; } case 87: { double t = 2*y100 - 175; return 0.58082532122519320968e0 + (0.12135935999503877077e-1 + (0.14584223996665838559e-3 + (0.13164068573095710742e-5 + (0.90803643355106020163e-8 + (0.47397540713124619155e-10 + 0.17850211608888888889e-12 * t) * t) * t) * t) * t) * t; } case 88: { double t = 2*y100 - 177; return 0.60569124025293375554e0 + (0.12735396239525550361e-1 + (0.15396244472258863344e-3 + (0.13909744385382818253e-5 + (0.95651595032306228245e-8 + (0.49574672127669041550e-10 + 0.18435945564444444444e-12 * t) * t) * t) * t) * t) * t; } case 89: { double t = 2*y100 - 179; return 0.63178916494715716894e0 + (0.13368247798287030927e-1 + (0.16254186562762076141e-3 + (0.14695084048334056083e-5 + (0.10072078109604152350e-7 + (0.51822304995680707483e-10 + 0.19025081422222222222e-12 * t) * t) * t) * t) * t) * t; } case 90: { double t = 2*y100 - 181; return 0.65918774689725319200e0 + (0.14036375850601992063e-1 + (0.17160483760259706354e-3 + (0.15521885688723188371e-5 + (0.10601827031535280590e-7 + (0.54140790105837520499e-10 + 0.19616655146666666667e-12 * t) * t) * t) * t) * t) * t; } case 91: { double t = 2*y100 - 183; return 0.68795950683174433822e0 + (0.14741765091365869084e-1 + (0.18117679143520433835e-3 + (0.16392004108230585213e-5 + (0.11155116068018043001e-7 + (0.56530360194925690374e-10 + 0.20209663662222222222e-12 * t) * t) * t) * t) * t) * t; } case 92: { double t = 2*y100 - 185; return 0.71818103808729967036e0 + (0.15486504187117112279e-1 + (0.19128428784550923217e-3 + (0.17307350969359975848e-5 + (0.11732656736113607751e-7 + (0.58991125287563833603e-10 + 0.20803065333333333333e-12 * t) * t) * t) * t) * t) * t; } case 93: { double t = 2*y100 - 187; return 0.74993321911726254661e0 + (0.16272790364044783382e-1 + (0.20195505163377912645e-3 + (0.18269894883203346953e-5 + (0.12335161021630225535e-7 + (0.61523068312169087227e-10 + 0.21395783431111111111e-12 * t) * t) * t) * t) * t) * t; } case 94: { double t = 2*y100 - 189; return 0.78330143531283492729e0 + (0.17102934132652429240e-1 + (0.21321800585063327041e-3 + (0.19281661395543913713e-5 + (0.12963340087354341574e-7 + (0.64126040998066348872e-10 + 0.21986708942222222222e-12 * t) * t) * t) * t) * t) * t; } case 95: { double t = 2*y100 - 191; return 0.81837581041023811832e0 + (0.17979364149044223802e-1 + (0.22510330592753129006e-3 + (0.20344732868018175389e-5 + (0.13617902941839949718e-7 + (0.66799760083972474642e-10 + 0.22574701262222222222e-12 * t) * t) * t) * t) * t) * t; } case 96: { double t = 2*y100 - 193; return 0.85525144775685126237e0 + (0.18904632212547561026e-1 + (0.23764237370371255638e-3 + (0.21461248251306387979e-5 + (0.14299555071870523786e-7 + (0.69543803864694171934e-10 + 0.23158593688888888889e-12 * t) * t) * t) * t) * t) * t; } case 97: { double t = 2*y100 - 195; return 0.89402868170849933734e0 + (0.19881418399127202569e-1 + (0.25086793128395995798e-3 + (0.22633402747585233180e-5 + (0.15008997042116532283e-7 + (0.72357609075043941261e-10 + 0.23737194737777777778e-12 * t) * t) * t) * t) * t) * t; } case 98: { double t = 2*y100 - 197; return 0.93481333942870796363e0 + (0.20912536329780368893e-1 + (0.26481403465998477969e-3 + (0.23863447359754921676e-5 + (0.15746923065472184451e-7 + (0.75240468141720143653e-10 + 0.24309291271111111111e-12 * t) * t) * t) * t) * t) * t; } case 99: { double t = 2*y100 - 199; return 0.97771701335885035464e0 + (0.22000938572830479551e-1 + (0.27951610702682383001e-3 + (0.25153688325245314530e-5 + (0.16514019547822821453e-7 + (0.78191526829368231251e-10 + 0.24873652355555555556e-12 * t) * t) * t) * t) * t) * t; } } // we only get here if y = 1, i.e. |x| < 4*eps, in which case // erfcx is within 1e-15 of 1.. return 1.0; } double FADDEEVA_RE(erfcx)(double x) { if (x >= 0) { if (x > 50) { // continued-fraction expansion is faster const double ispi = 0.56418958354775628694807945156; // 1 / sqrt(pi) if (x > 5e7) // 1-term expansion, important to avoid overflow return ispi / x; /* 5-term expansion (rely on compiler for CSE), simplified from: ispi / (x+0.5/(x+1/(x+1.5/(x+2/x)))) */ return ispi*((x*x) * (x*x+4.5) + 2) / (x * ((x*x) * (x*x+5) + 3.75)); } return erfcx_y100(400/(4+x)); } else return x < -26.7 ? HUGE_VAL : (x < -6.1 ? 2*exp(x*x) : 2*exp(x*x) - erfcx_y100(400/(4-x))); } ///////////////////////////////////////////////////////////////////////// /* Compute a scaled Dawson integral FADDEEVA(w_im)(x) = 2*Dawson(x)/sqrt(pi) equivalent to the imaginary part w(x) for real x. Uses methods similar to the erfcx calculation above: continued fractions for large |x|, a lookup table of Chebyshev polynomials for smaller |x|, and finally a Taylor expansion for |x|<0.01. Steven G. Johnson, October 2012. */ /* Given y100=100*y, where y = 1/(1+x) for x >= 0, compute w_im(x). Uses a look-up table of 100 different Chebyshev polynomials for y intervals [0,0.01], [0.01,0.02], ...., [0.99,1], generated with the help of Maple and a little shell script. This allows the Chebyshev polynomials to be of significantly lower degree (about 1/30) compared to fitting the whole [0,1] interval with a single polynomial. */ static double w_im_y100(double y100, double x) { switch ((int) y100) { case 0: { double t = 2*y100 - 1; return 0.28351593328822191546e-2 + (0.28494783221378400759e-2 + (0.14427470563276734183e-4 + (0.10939723080231588129e-6 + (0.92474307943275042045e-9 + (0.89128907666450075245e-11 + 0.92974121935111111110e-13 * t) * t) * t) * t) * t) * t; } case 1: { double t = 2*y100 - 3; return 0.85927161243940350562e-2 + (0.29085312941641339862e-2 + (0.15106783707725582090e-4 + (0.11716709978531327367e-6 + (0.10197387816021040024e-8 + (0.10122678863073360769e-10 + 0.10917479678400000000e-12 * t) * t) * t) * t) * t) * t; } case 2: { double t = 2*y100 - 5; return 0.14471159831187703054e-1 + (0.29703978970263836210e-2 + (0.15835096760173030976e-4 + (0.12574803383199211596e-6 + (0.11278672159518415848e-8 + (0.11547462300333495797e-10 + 0.12894535335111111111e-12 * t) * t) * t) * t) * t) * t; } case 3: { double t = 2*y100 - 7; return 0.20476320420324610618e-1 + (0.30352843012898665856e-2 + (0.16617609387003727409e-4 + (0.13525429711163116103e-6 + (0.12515095552507169013e-8 + (0.13235687543603382345e-10 + 0.15326595042666666667e-12 * t) * t) * t) * t) * t) * t; } case 4: { double t = 2*y100 - 9; return 0.26614461952489004566e-1 + (0.31034189276234947088e-2 + (0.17460268109986214274e-4 + (0.14582130824485709573e-6 + (0.13935959083809746345e-8 + (0.15249438072998932900e-10 + 0.18344741882133333333e-12 * t) * t) * t) * t) * t) * t; } case 5: { double t = 2*y100 - 11; return 0.32892330248093586215e-1 + (0.31750557067975068584e-2 + (0.18369907582308672632e-4 + (0.15761063702089457882e-6 + (0.15577638230480894382e-8 + (0.17663868462699097951e-10 + (0.22126732680711111111e-12 + 0.30273474177737853668e-14 * t) * t) * t) * t) * t) * t) * t; } case 6: { double t = 2*y100 - 13; return 0.39317207681134336024e-1 + (0.32504779701937539333e-2 + (0.19354426046513400534e-4 + (0.17081646971321290539e-6 + (0.17485733959327106250e-8 + (0.20593687304921961410e-10 + (0.26917401949155555556e-12 + 0.38562123837725712270e-14 * t) * t) * t) * t) * t) * t) * t; } case 7: { double t = 2*y100 - 15; return 0.45896976511367738235e-1 + (0.33300031273110976165e-2 + (0.20423005398039037313e-4 + (0.18567412470376467303e-6 + (0.19718038363586588213e-8 + (0.24175006536781219807e-10 + (0.33059982791466666666e-12 + 0.49756574284439426165e-14 * t) * t) * t) * t) * t) * t) * t; } case 8: { double t = 2*y100 - 17; return 0.52640192524848962855e-1 + (0.34139883358846720806e-2 + (0.21586390240603337337e-4 + (0.20247136501568904646e-6 + (0.22348696948197102935e-8 + (0.28597516301950162548e-10 + (0.41045502119111111110e-12 + 0.65151614515238361946e-14 * t) * t) * t) * t) * t) * t) * t; } case 9: { double t = 2*y100 - 19; return 0.59556171228656770456e-1 + (0.35028374386648914444e-2 + (0.22857246150998562824e-4 + (0.22156372146525190679e-6 + (0.25474171590893813583e-8 + (0.34122390890697400584e-10 + (0.51593189879111111110e-12 + 0.86775076853908006938e-14 * t) * t) * t) * t) * t) * t) * t; } case 10: { double t = 2*y100 - 21; return 0.66655089485108212551e-1 + (0.35970095381271285568e-2 + (0.24250626164318672928e-4 + (0.24339561521785040536e-6 + (0.29221990406518411415e-8 + (0.41117013527967776467e-10 + (0.65786450716444444445e-12 + 0.11791885745450623331e-13 * t) * t) * t) * t) * t) * t) * t; } case 11: { double t = 2*y100 - 23; return 0.73948106345519174661e-1 + (0.36970297216569341748e-2 + (0.25784588137312868792e-4 + (0.26853012002366752770e-6 + (0.33763958861206729592e-8 + (0.50111549981376976397e-10 + (0.85313857496888888890e-12 + 0.16417079927706899860e-13 * t) * t) * t) * t) * t) * t) * t; } case 12: { double t = 2*y100 - 25; return 0.81447508065002963203e-1 + (0.38035026606492705117e-2 + (0.27481027572231851896e-4 + (0.29769200731832331364e-6 + (0.39336816287457655076e-8 + (0.61895471132038157624e-10 + (0.11292303213511111111e-11 + 0.23558532213703884304e-13 * t) * t) * t) * t) * t) * t) * t; } case 13: { double t = 2*y100 - 27; return 0.89166884027582716628e-1 + (0.39171301322438946014e-2 + (0.29366827260422311668e-4 + (0.33183204390350724895e-6 + (0.46276006281647330524e-8 + (0.77692631378169813324e-10 + (0.15335153258844444444e-11 + 0.35183103415916026911e-13 * t) * t) * t) * t) * t) * t) * t; } case 14: { double t = 2*y100 - 29; return 0.97121342888032322019e-1 + (0.40387340353207909514e-2 + (0.31475490395950776930e-4 + (0.37222714227125135042e-6 + (0.55074373178613809996e-8 + (0.99509175283990337944e-10 + (0.21552645758222222222e-11 + 0.55728651431872687605e-13 * t) * t) * t) * t) * t) * t) * t; } case 15: { double t = 2*y100 - 31; return 0.10532778218603311137e0 + (0.41692873614065380607e-2 + (0.33849549774889456984e-4 + (0.42064596193692630143e-6 + (0.66494579697622432987e-8 + (0.13094103581931802337e-9 + (0.31896187409777777778e-11 + 0.97271974184476560742e-13 * t) * t) * t) * t) * t) * t) * t; } case 16: { double t = 2*y100 - 33; return 0.11380523107427108222e0 + (0.43099572287871821013e-2 + (0.36544324341565929930e-4 + (0.47965044028581857764e-6 + (0.81819034238463698796e-8 + (0.17934133239549647357e-9 + (0.50956666166186293627e-11 + (0.18850487318190638010e-12 + 0.79697813173519853340e-14 * t) * t) * t) * t) * t) * t) * t) * t; } case 17: { double t = 2*y100 - 35; return 0.12257529703447467345e0 + (0.44621675710026986366e-2 + (0.39634304721292440285e-4 + (0.55321553769873381819e-6 + (0.10343619428848520870e-7 + (0.26033830170470368088e-9 + (0.87743837749108025357e-11 + (0.34427092430230063401e-12 + 0.10205506615709843189e-13 * t) * t) * t) * t) * t) * t) * t) * t; } case 18: { double t = 2*y100 - 37; return 0.13166276955656699478e0 + (0.46276970481783001803e-2 + (0.43225026380496399310e-4 + (0.64799164020016902656e-6 + (0.13580082794704641782e-7 + (0.39839800853954313927e-9 + (0.14431142411840000000e-10 + 0.42193457308830027541e-12 * t) * t) * t) * t) * t) * t) * t; } case 19: { double t = 2*y100 - 39; return 0.14109647869803356475e0 + (0.48088424418545347758e-2 + (0.47474504753352150205e-4 + (0.77509866468724360352e-6 + (0.18536851570794291724e-7 + (0.60146623257887570439e-9 + (0.18533978397305276318e-10 + (0.41033845938901048380e-13 - 0.46160680279304825485e-13 * t) * t) * t) * t) * t) * t) * t) * t; } case 20: { double t = 2*y100 - 41; return 0.15091057940548936603e0 + (0.50086864672004685703e-2 + (0.52622482832192230762e-4 + (0.95034664722040355212e-6 + (0.25614261331144718769e-7 + (0.80183196716888606252e-9 + (0.12282524750534352272e-10 + (-0.10531774117332273617e-11 - 0.86157181395039646412e-13 * t) * t) * t) * t) * t) * t) * t) * t; } case 21: { double t = 2*y100 - 43; return 0.16114648116017010770e0 + (0.52314661581655369795e-2 + (0.59005534545908331315e-4 + (0.11885518333915387760e-5 + (0.33975801443239949256e-7 + (0.82111547144080388610e-9 + (-0.12357674017312854138e-10 + (-0.24355112256914479176e-11 - 0.75155506863572930844e-13 * t) * t) * t) * t) * t) * t) * t) * t; } case 22: { double t = 2*y100 - 45; return 0.17185551279680451144e0 + (0.54829002967599420860e-2 + (0.67013226658738082118e-4 + (0.14897400671425088807e-5 + (0.40690283917126153701e-7 + (0.44060872913473778318e-9 + (-0.52641873433280000000e-10 - 0.30940587864543343124e-11 * t) * t) * t) * t) * t) * t) * t; } case 23: { double t = 2*y100 - 47; return 0.18310194559815257381e0 + (0.57701559375966953174e-2 + (0.76948789401735193483e-4 + (0.18227569842290822512e-5 + (0.41092208344387212276e-7 + (-0.44009499965694442143e-9 + (-0.92195414685628803451e-10 + (-0.22657389705721753299e-11 + 0.10004784908106839254e-12 * t) * t) * t) * t) * t) * t) * t) * t; } case 24: { double t = 2*y100 - 49; return 0.19496527191546630345e0 + (0.61010853144364724856e-2 + (0.88812881056342004864e-4 + (0.21180686746360261031e-5 + (0.30652145555130049203e-7 + (-0.16841328574105890409e-8 + (-0.11008129460612823934e-9 + (-0.12180794204544515779e-12 + 0.15703325634590334097e-12 * t) * t) * t) * t) * t) * t) * t) * t; } case 25: { double t = 2*y100 - 51; return 0.20754006813966575720e0 + (0.64825787724922073908e-2 + (0.10209599627522311893e-3 + (0.22785233392557600468e-5 + (0.73495224449907568402e-8 + (-0.29442705974150112783e-8 + (-0.94082603434315016546e-10 + (0.23609990400179321267e-11 + 0.14141908654269023788e-12 * t) * t) * t) * t) * t) * t) * t) * t; } case 26: { double t = 2*y100 - 53; return 0.22093185554845172146e0 + (0.69182878150187964499e-2 + (0.11568723331156335712e-3 + (0.22060577946323627739e-5 + (-0.26929730679360840096e-7 + (-0.38176506152362058013e-8 + (-0.47399503861054459243e-10 + (0.40953700187172127264e-11 + 0.69157730376118511127e-13 * t) * t) * t) * t) * t) * t) * t) * t; } case 27: { double t = 2*y100 - 55; return 0.23524827304057813918e0 + (0.74063350762008734520e-2 + (0.12796333874615790348e-3 + (0.18327267316171054273e-5 + (-0.66742910737957100098e-7 + (-0.40204740975496797870e-8 + (0.14515984139495745330e-10 + (0.44921608954536047975e-11 - 0.18583341338983776219e-13 * t) * t) * t) * t) * t) * t) * t) * t; } case 28: { double t = 2*y100 - 57; return 0.25058626331812744775e0 + (0.79377285151602061328e-2 + (0.13704268650417478346e-3 + (0.11427511739544695861e-5 + (-0.10485442447768377485e-6 + (-0.34850364756499369763e-8 + (0.72656453829502179208e-10 + (0.36195460197779299406e-11 - 0.84882136022200714710e-13 * t) * t) * t) * t) * t) * t) * t) * t; } case 29: { double t = 2*y100 - 59; return 0.26701724900280689785e0 + (0.84959936119625864274e-2 + (0.14112359443938883232e-3 + (0.17800427288596909634e-6 + (-0.13443492107643109071e-6 + (-0.23512456315677680293e-8 + (0.11245846264695936769e-9 + (0.19850501334649565404e-11 - 0.11284666134635050832e-12 * t) * t) * t) * t) * t) * t) * t) * t; } case 30: { double t = 2*y100 - 61; return 0.28457293586253654144e0 + (0.90581563892650431899e-2 + (0.13880520331140646738e-3 + (-0.97262302362522896157e-6 + (-0.15077100040254187366e-6 + (-0.88574317464577116689e-9 + (0.12760311125637474581e-9 + (0.20155151018282695055e-12 - 0.10514169375181734921e-12 * t) * t) * t) * t) * t) * t) * t) * t; } case 31: { double t = 2*y100 - 63; return 0.30323425595617385705e0 + (0.95968346790597422934e-2 + (0.12931067776725883939e-3 + (-0.21938741702795543986e-5 + (-0.15202888584907373963e-6 + (0.61788350541116331411e-9 + (0.11957835742791248256e-9 + (-0.12598179834007710908e-11 - 0.75151817129574614194e-13 * t) * t) * t) * t) * t) * t) * t) * t; } case 32: { double t = 2*y100 - 65; return 0.32292521181517384379e0 + (0.10082957727001199408e-1 + (0.11257589426154962226e-3 + (-0.33670890319327881129e-5 + (-0.13910529040004008158e-6 + (0.19170714373047512945e-8 + (0.94840222377720494290e-10 + (-0.21650018351795353201e-11 - 0.37875211678024922689e-13 * t) * t) * t) * t) * t) * t) * t) * t; } case 33: { double t = 2*y100 - 67; return 0.34351233557911753862e0 + (0.10488575435572745309e-1 + (0.89209444197248726614e-4 + (-0.43893459576483345364e-5 + (-0.11488595830450424419e-6 + (0.28599494117122464806e-8 + (0.61537542799857777779e-10 - 0.24935749227658002212e-11 * t) * t) * t) * t) * t) * t) * t; } case 34: { double t = 2*y100 - 69; return 0.36480946642143669093e0 + (0.10789304203431861366e-1 + (0.60357993745283076834e-4 + (-0.51855862174130669389e-5 + (-0.83291664087289801313e-7 + (0.33898011178582671546e-8 + (0.27082948188277716482e-10 + (-0.23603379397408694974e-11 + 0.19328087692252869842e-13 * t) * t) * t) * t) * t) * t) * t) * t; } case 35: { double t = 2*y100 - 71; return 0.38658679935694939199e0 + (0.10966119158288804999e-1 + (0.27521612041849561426e-4 + (-0.57132774537670953638e-5 + (-0.48404772799207914899e-7 + (0.35268354132474570493e-8 + (-0.32383477652514618094e-11 + (-0.19334202915190442501e-11 + 0.32333189861286460270e-13 * t) * t) * t) * t) * t) * t) * t) * t; } case 36: { double t = 2*y100 - 73; return 0.40858275583808707870e0 + (0.11006378016848466550e-1 + (-0.76396376685213286033e-5 + (-0.59609835484245791439e-5 + (-0.13834610033859313213e-7 + (0.33406952974861448790e-8 + (-0.26474915974296612559e-10 + (-0.13750229270354351983e-11 + 0.36169366979417390637e-13 * t) * t) * t) * t) * t) * t) * t) * t; } case 37: { double t = 2*y100 - 75; return 0.43051714914006682977e0 + (0.10904106549500816155e-1 + (-0.43477527256787216909e-4 + (-0.59429739547798343948e-5 + (0.17639200194091885949e-7 + (0.29235991689639918688e-8 + (-0.41718791216277812879e-10 + (-0.81023337739508049606e-12 + 0.33618915934461994428e-13 * t) * t) * t) * t) * t) * t) * t) * t; } case 38: { double t = 2*y100 - 77; return 0.45210428135559607406e0 + (0.10659670756384400554e-1 + (-0.78488639913256978087e-4 + (-0.56919860886214735936e-5 + (0.44181850467477733407e-7 + (0.23694306174312688151e-8 + (-0.49492621596685443247e-10 + (-0.31827275712126287222e-12 + 0.27494438742721623654e-13 * t) * t) * t) * t) * t) * t) * t) * t; } case 39: { double t = 2*y100 - 79; return 0.47306491195005224077e0 + (0.10279006119745977570e-1 + (-0.11140268171830478306e-3 + (-0.52518035247451432069e-5 + (0.64846898158889479518e-7 + (0.17603624837787337662e-8 + (-0.51129481592926104316e-10 + (0.62674584974141049511e-13 + 0.20055478560829935356e-13 * t) * t) * t) * t) * t) * t) * t) * t; } case 40: { double t = 2*y100 - 81; return 0.49313638965719857647e0 + (0.97725799114772017662e-2 + (-0.14122854267291533334e-3 + (-0.46707252568834951907e-5 + (0.79421347979319449524e-7 + (0.11603027184324708643e-8 + (-0.48269605844397175946e-10 + (0.32477251431748571219e-12 + 0.12831052634143527985e-13 * t) * t) * t) * t) * t) * t) * t) * t; } case 41: { double t = 2*y100 - 83; return 0.51208057433416004042e0 + (0.91542422354009224951e-2 + (-0.16726530230228647275e-3 + (-0.39964621752527649409e-5 + (0.88232252903213171454e-7 + (0.61343113364949928501e-9 + (-0.42516755603130443051e-10 + (0.47910437172240209262e-12 + 0.66784341874437478953e-14 * t) * t) * t) * t) * t) * t) * t) * t; } case 42: { double t = 2*y100 - 85; return 0.52968945458607484524e0 + (0.84400880445116786088e-2 + (-0.18908729783854258774e-3 + (-0.32725905467782951931e-5 + (0.91956190588652090659e-7 + (0.14593989152420122909e-9 + (-0.35239490687644444445e-10 + 0.54613829888448694898e-12 * t) * t) * t) * t) * t) * t) * t; } case 43: { double t = 2*y100 - 87; return 0.54578857454330070965e0 + (0.76474155195880295311e-2 + (-0.20651230590808213884e-3 + (-0.25364339140543131706e-5 + (0.91455367999510681979e-7 + (-0.23061359005297528898e-9 + (-0.27512928625244444444e-10 + 0.54895806008493285579e-12 * t) * t) * t) * t) * t) * t) * t; } case 44: { double t = 2*y100 - 89; return 0.56023851910298493910e0 + (0.67938321739997196804e-2 + (-0.21956066613331411760e-3 + (-0.18181127670443266395e-5 + (0.87650335075416845987e-7 + (-0.51548062050366615977e-9 + (-0.20068462174044444444e-10 + 0.50912654909758187264e-12 * t) * t) * t) * t) * t) * t) * t; } case 45: { double t = 2*y100 - 91; return 0.57293478057455721150e0 + (0.58965321010394044087e-2 + (-0.22841145229276575597e-3 + (-0.11404605562013443659e-5 + (0.81430290992322326296e-7 + (-0.71512447242755357629e-9 + (-0.13372664928000000000e-10 + 0.44461498336689298148e-12 * t) * t) * t) * t) * t) * t) * t; } case 46: { double t = 2*y100 - 93; return 0.58380635448407827360e0 + (0.49717469530842831182e-2 + (-0.23336001540009645365e-3 + (-0.51952064448608850822e-6 + (0.73596577815411080511e-7 + (-0.84020916763091566035e-9 + (-0.76700972702222222221e-11 + 0.36914462807972467044e-12 * t) * t) * t) * t) * t) * t) * t; } case 47: { double t = 2*y100 - 95; return 0.59281340237769489597e0 + (0.40343592069379730568e-2 + (-0.23477963738658326185e-3 + (0.34615944987790224234e-7 + (0.64832803248395814574e-7 + (-0.90329163587627007971e-9 + (-0.30421940400000000000e-11 + 0.29237386653743536669e-12 * t) * t) * t) * t) * t) * t) * t; } case 48: { double t = 2*y100 - 97; return 0.59994428743114271918e0 + (0.30976579788271744329e-2 + (-0.23308875765700082835e-3 + (0.51681681023846925160e-6 + (0.55694594264948268169e-7 + (-0.91719117313243464652e-9 + (0.53982743680000000000e-12 + 0.22050829296187771142e-12 * t) * t) * t) * t) * t) * t) * t; } case 49: { double t = 2*y100 - 99; return 0.60521224471819875444e0 + (0.21732138012345456060e-2 + (-0.22872428969625997456e-3 + (0.92588959922653404233e-6 + (0.46612665806531930684e-7 + (-0.89393722514414153351e-9 + (0.31718550353777777778e-11 + 0.15705458816080549117e-12 * t) * t) * t) * t) * t) * t) * t; } case 50: { double t = 2*y100 - 101; return 0.60865189969791123620e0 + (0.12708480848877451719e-2 + (-0.22212090111534847166e-3 + (0.12636236031532793467e-5 + (0.37904037100232937574e-7 + (-0.84417089968101223519e-9 + (0.49843180828444444445e-11 + 0.10355439441049048273e-12 * t) * t) * t) * t) * t) * t) * t; } case 51: { double t = 2*y100 - 103; return 0.61031580103499200191e0 + (0.39867436055861038223e-3 + (-0.21369573439579869291e-3 + (0.15339402129026183670e-5 + (0.29787479206646594442e-7 + (-0.77687792914228632974e-9 + (0.61192452741333333334e-11 + 0.60216691829459295780e-13 * t) * t) * t) * t) * t) * t) * t; } case 52: { double t = 2*y100 - 105; return 0.61027109047879835868e0 + (-0.43680904508059878254e-3 + (-0.20383783788303894442e-3 + (0.17421743090883439959e-5 + (0.22400425572175715576e-7 + (-0.69934719320045128997e-9 + (0.67152759655111111110e-11 + 0.26419960042578359995e-13 * t) * t) * t) * t) * t) * t) * t; } case 53: { double t = 2*y100 - 107; return 0.60859639489217430521e0 + (-0.12305921390962936873e-2 + (-0.19290150253894682629e-3 + (0.18944904654478310128e-5 + (0.15815530398618149110e-7 + (-0.61726850580964876070e-9 + 0.68987888999111111110e-11 * t) * t) * t) * t) * t) * t; } case 54: { double t = 2*y100 - 109; return 0.60537899426486075181e0 + (-0.19790062241395705751e-2 + (-0.18120271393047062253e-3 + (0.19974264162313241405e-5 + (0.10055795094298172492e-7 + (-0.53491997919318263593e-9 + (0.67794550295111111110e-11 - 0.17059208095741511603e-13 * t) * t) * t) * t) * t) * t) * t; } case 55: { double t = 2*y100 - 111; return 0.60071229457904110537e0 + (-0.26795676776166354354e-2 + (-0.16901799553627508781e-3 + (0.20575498324332621581e-5 + (0.51077165074461745053e-8 + (-0.45536079828057221858e-9 + (0.64488005516444444445e-11 - 0.29311677573152766338e-13 * t) * t) * t) * t) * t) * t) * t; } case 56: { double t = 2*y100 - 113; return 0.59469361520112714738e0 + (-0.33308208190600993470e-2 + (-0.15658501295912405679e-3 + (0.20812116912895417272e-5 + (0.93227468760614182021e-9 + (-0.38066673740116080415e-9 + (0.59806790359111111110e-11 - 0.36887077278950440597e-13 * t) * t) * t) * t) * t) * t) * t; } case 57: { double t = 2*y100 - 115; return 0.58742228631775388268e0 + (-0.39321858196059227251e-2 + (-0.14410441141450122535e-3 + (0.20743790018404020716e-5 + (-0.25261903811221913762e-8 + (-0.31212416519526924318e-9 + (0.54328422462222222221e-11 - 0.40864152484979815972e-13 * t) * t) * t) * t) * t) * t) * t; } case 58: { double t = 2*y100 - 117; return 0.57899804200033018447e0 + (-0.44838157005618913447e-2 + (-0.13174245966501437965e-3 + (0.20425306888294362674e-5 + (-0.53330296023875447782e-8 + (-0.25041289435539821014e-9 + (0.48490437205333333334e-11 - 0.42162206939169045177e-13 * t) * t) * t) * t) * t) * t) * t; } case 59: { double t = 2*y100 - 119; return 0.56951968796931245974e0 + (-0.49864649488074868952e-2 + (-0.11963416583477567125e-3 + (0.19906021780991036425e-5 + (-0.75580140299436494248e-8 + (-0.19576060961919820491e-9 + (0.42613011928888888890e-11 - 0.41539443304115604377e-13 * t) * t) * t) * t) * t) * t) * t; } case 60: { double t = 2*y100 - 121; return 0.55908401930063918964e0 + (-0.54413711036826877753e-2 + (-0.10788661102511914628e-3 + (0.19229663322982839331e-5 + (-0.92714731195118129616e-8 + (-0.14807038677197394186e-9 + (0.36920870298666666666e-11 - 0.39603726688419162617e-13 * t) * t) * t) * t) * t) * t) * t; } case 61: { double t = 2*y100 - 123; return 0.54778496152925675315e0 + (-0.58501497933213396670e-2 + (-0.96582314317855227421e-4 + (0.18434405235069270228e-5 + (-0.10541580254317078711e-7 + (-0.10702303407788943498e-9 + (0.31563175582222222222e-11 - 0.36829748079110481422e-13 * t) * t) * t) * t) * t) * t) * t; } case 62: { double t = 2*y100 - 125; return 0.53571290831682823999e0 + (-0.62147030670760791791e-2 + (-0.85782497917111760790e-4 + (0.17553116363443470478e-5 + (-0.11432547349815541084e-7 + (-0.72157091369041330520e-10 + (0.26630811607111111111e-11 - 0.33578660425893164084e-13 * t) * t) * t) * t) * t) * t) * t; } case 63: { double t = 2*y100 - 127; return 0.52295422962048434978e0 + (-0.65371404367776320720e-2 + (-0.75530164941473343780e-4 + (0.16613725797181276790e-5 + (-0.12003521296598910761e-7 + (-0.42929753689181106171e-10 + (0.22170894940444444444e-11 - 0.30117697501065110505e-13 * t) * t) * t) * t) * t) * t) * t; } case 64: { double t = 2*y100 - 129; return 0.50959092577577886140e0 + (-0.68197117603118591766e-2 + (-0.65852936198953623307e-4 + (0.15639654113906716939e-5 + (-0.12308007991056524902e-7 + (-0.18761997536910939570e-10 + (0.18198628922666666667e-11 - 0.26638355362285200932e-13 * t) * t) * t) * t) * t) * t) * t; } case 65: { double t = 2*y100 - 131; return 0.49570040481823167970e0 + (-0.70647509397614398066e-2 + (-0.56765617728962588218e-4 + (0.14650274449141448497e-5 + (-0.12393681471984051132e-7 + (0.92904351801168955424e-12 + (0.14706755960177777778e-11 - 0.23272455351266325318e-13 * t) * t) * t) * t) * t) * t) * t; } case 66: { double t = 2*y100 - 133; return 0.48135536250935238066e0 + (-0.72746293327402359783e-2 + (-0.48272489495730030780e-4 + (0.13661377309113939689e-5 + (-0.12302464447599382189e-7 + (0.16707760028737074907e-10 + (0.11672928324444444444e-11 - 0.20105801424709924499e-13 * t) * t) * t) * t) * t) * t) * t; } case 67: { double t = 2*y100 - 135; return 0.46662374675511439448e0 + (-0.74517177649528487002e-2 + (-0.40369318744279128718e-4 + (0.12685621118898535407e-5 + (-0.12070791463315156250e-7 + (0.29105507892605823871e-10 + (0.90653314645333333334e-12 - 0.17189503312102982646e-13 * t) * t) * t) * t) * t) * t) * t; } case 68: { double t = 2*y100 - 137; return 0.45156879030168268778e0 + (-0.75983560650033817497e-2 + (-0.33045110380705139759e-4 + (0.11732956732035040896e-5 + (-0.11729986947158201869e-7 + (0.38611905704166441308e-10 + (0.68468768305777777779e-12 - 0.14549134330396754575e-13 * t) * t) * t) * t) * t) * t) * t; } case 69: { double t = 2*y100 - 139; return 0.43624909769330896904e0 + (-0.77168291040309554679e-2 + (-0.26283612321339907756e-4 + (0.10811018836893550820e-5 + (-0.11306707563739851552e-7 + (0.45670446788529607380e-10 + (0.49782492549333333334e-12 - 0.12191983967561779442e-13 * t) * t) * t) * t) * t) * t) * t; } case 70: { double t = 2*y100 - 141; return 0.42071877443548481181e0 + (-0.78093484015052730097e-2 + (-0.20064596897224934705e-4 + (0.99254806680671890766e-6 + (-0.10823412088884741451e-7 + (0.50677203326904716247e-10 + (0.34200547594666666666e-12 - 0.10112698698356194618e-13 * t) * t) * t) * t) * t) * t) * t; } case 71: { double t = 2*y100 - 143; return 0.40502758809710844280e0 + (-0.78780384460872937555e-2 + (-0.14364940764532853112e-4 + (0.90803709228265217384e-6 + (-0.10298832847014466907e-7 + (0.53981671221969478551e-10 + (0.21342751381333333333e-12 - 0.82975901848387729274e-14 * t) * t) * t) * t) * t) * t) * t; } case 72: { double t = 2*y100 - 145; return 0.38922115269731446690e0 + (-0.79249269708242064120e-2 + (-0.91595258799106970453e-5 + (0.82783535102217576495e-6 + (-0.97484311059617744437e-8 + (0.55889029041660225629e-10 + (0.10851981336888888889e-12 - 0.67278553237853459757e-14 * t) * t) * t) * t) * t) * t) * t; } case 73: { double t = 2*y100 - 147; return 0.37334112915460307335e0 + (-0.79519385109223148791e-2 + (-0.44219833548840469752e-5 + (0.75209719038240314732e-6 + (-0.91848251458553190451e-8 + (0.56663266668051433844e-10 + (0.23995894257777777778e-13 - 0.53819475285389344313e-14 * t) * t) * t) * t) * t) * t) * t; } case 74: { double t = 2*y100 - 149; return 0.35742543583374223085e0 + (-0.79608906571527956177e-2 + (-0.12530071050975781198e-6 + (0.68088605744900552505e-6 + (-0.86181844090844164075e-8 + (0.56530784203816176153e-10 + (-0.43120012248888888890e-13 - 0.42372603392496813810e-14 * t) * t) * t) * t) * t) * t) * t; } case 75: { double t = 2*y100 - 151; return 0.34150846431979618536e0 + (-0.79534924968773806029e-2 + (0.37576885610891515813e-5 + (0.61419263633090524326e-6 + (-0.80565865409945960125e-8 + (0.55684175248749269411e-10 + (-0.95486860764444444445e-13 - 0.32712946432984510595e-14 * t) * t) * t) * t) * t) * t) * t; } case 76: { double t = 2*y100 - 153; return 0.32562129649136346824e0 + (-0.79313448067948884309e-2 + (0.72539159933545300034e-5 + (0.55195028297415503083e-6 + (-0.75063365335570475258e-8 + (0.54281686749699595941e-10 - 0.13545424295111111111e-12 * t) * t) * t) * t) * t) * t; } case 77: { double t = 2*y100 - 155; return 0.30979191977078391864e0 + (-0.78959416264207333695e-2 + (0.10389774377677210794e-4 + (0.49404804463196316464e-6 + (-0.69722488229411164685e-8 + (0.52469254655951393842e-10 - 0.16507860650666666667e-12 * t) * t) * t) * t) * t) * t; } case 78: { double t = 2*y100 - 157; return 0.29404543811214459904e0 + (-0.78486728990364155356e-2 + (0.13190885683106990459e-4 + (0.44034158861387909694e-6 + (-0.64578942561562616481e-8 + (0.50354306498006928984e-10 - 0.18614473550222222222e-12 * t) * t) * t) * t) * t) * t; } case 79: { double t = 2*y100 - 159; return 0.27840427686253660515e0 + (-0.77908279176252742013e-2 + (0.15681928798708548349e-4 + (0.39066226205099807573e-6 + (-0.59658144820660420814e-8 + (0.48030086420373141763e-10 - 0.20018995173333333333e-12 * t) * t) * t) * t) * t) * t; } case 80: { double t = 2*y100 - 161; return 0.26288838011163800908e0 + (-0.77235993576119469018e-2 + (0.17886516796198660969e-4 + (0.34482457073472497720e-6 + (-0.54977066551955420066e-8 + (0.45572749379147269213e-10 - 0.20852924954666666667e-12 * t) * t) * t) * t) * t) * t; } case 81: { double t = 2*y100 - 163; return 0.24751539954181029717e0 + (-0.76480877165290370975e-2 + (0.19827114835033977049e-4 + (0.30263228619976332110e-6 + (-0.50545814570120129947e-8 + (0.43043879374212005966e-10 - 0.21228012028444444444e-12 * t) * t) * t) * t) * t) * t; } case 82: { double t = 2*y100 - 165; return 0.23230087411688914593e0 + (-0.75653060136384041587e-2 + (0.21524991113020016415e-4 + (0.26388338542539382413e-6 + (-0.46368974069671446622e-8 + (0.40492715758206515307e-10 - 0.21238627815111111111e-12 * t) * t) * t) * t) * t) * t; } case 83: { double t = 2*y100 - 167; return 0.21725840021297341931e0 + (-0.74761846305979730439e-2 + (0.23000194404129495243e-4 + (0.22837400135642906796e-6 + (-0.42446743058417541277e-8 + (0.37958104071765923728e-10 - 0.20963978568888888889e-12 * t) * t) * t) * t) * t) * t; } case 84: { double t = 2*y100 - 169; return 0.20239979200788191491e0 + (-0.73815761980493466516e-2 + (0.24271552727631854013e-4 + (0.19590154043390012843e-6 + (-0.38775884642456551753e-8 + (0.35470192372162901168e-10 - 0.20470131678222222222e-12 * t) * t) * t) * t) * t) * t; } case 85: { double t = 2*y100 - 171; return 0.18773523211558098962e0 + (-0.72822604530339834448e-2 + (0.25356688567841293697e-4 + (0.16626710297744290016e-6 + (-0.35350521468015310830e-8 + (0.33051896213898864306e-10 - 0.19811844544000000000e-12 * t) * t) * t) * t) * t) * t; } case 86: { double t = 2*y100 - 173; return 0.17327341258479649442e0 + (-0.71789490089142761950e-2 + (0.26272046822383820476e-4 + (0.13927732375657362345e-6 + (-0.32162794266956859603e-8 + (0.30720156036105652035e-10 - 0.19034196304000000000e-12 * t) * t) * t) * t) * t) * t; } case 87: { double t = 2*y100 - 175; return 0.15902166648328672043e0 + (-0.70722899934245504034e-2 + (0.27032932310132226025e-4 + (0.11474573347816568279e-6 + (-0.29203404091754665063e-8 + (0.28487010262547971859e-10 - 0.18174029063111111111e-12 * t) * t) * t) * t) * t) * t; } case 88: { double t = 2*y100 - 177; return 0.14498609036610283865e0 + (-0.69628725220045029273e-2 + (0.27653554229160596221e-4 + (0.92493727167393036470e-7 + (-0.26462055548683583849e-8 + (0.26360506250989943739e-10 - 0.17261211260444444444e-12 * t) * t) * t) * t) * t) * t; } case 89: { double t = 2*y100 - 179; return 0.13117165798208050667e0 + (-0.68512309830281084723e-2 + (0.28147075431133863774e-4 + (0.72351212437979583441e-7 + (-0.23927816200314358570e-8 + (0.24345469651209833155e-10 - 0.16319736960000000000e-12 * t) * t) * t) * t) * t) * t; } case 90: { double t = 2*y100 - 181; return 0.11758232561160626306e0 + (-0.67378491192463392927e-2 + (0.28525664781722907847e-4 + (0.54156999310046790024e-7 + (-0.21589405340123827823e-8 + (0.22444150951727334619e-10 - 0.15368675584000000000e-12 * t) * t) * t) * t) * t) * t; } case 91: { double t = 2*y100 - 183; return 0.10422112945361673560e0 + (-0.66231638959845581564e-2 + (0.28800551216363918088e-4 + (0.37758983397952149613e-7 + (-0.19435423557038933431e-8 + (0.20656766125421362458e-10 - 0.14422990012444444444e-12 * t) * t) * t) * t) * t) * t; } case 92: { double t = 2*y100 - 185; return 0.91090275493541084785e-1 + (-0.65075691516115160062e-2 + (0.28982078385527224867e-4 + (0.23014165807643012781e-7 + (-0.17454532910249875958e-8 + (0.18981946442680092373e-10 - 0.13494234691555555556e-12 * t) * t) * t) * t) * t) * t; } case 93: { double t = 2*y100 - 187; return 0.78191222288771379358e-1 + (-0.63914190297303976434e-2 + (0.29079759021299682675e-4 + (0.97885458059415717014e-8 + (-0.15635596116134296819e-8 + (0.17417110744051331974e-10 - 0.12591151763555555556e-12 * t) * t) * t) * t) * t) * t; } case 94: { double t = 2*y100 - 189; return 0.65524757106147402224e-1 + (-0.62750311956082444159e-2 + (0.29102328354323449795e-4 + (-0.20430838882727954582e-8 + (-0.13967781903855367270e-8 + (0.15958771833747057569e-10 - 0.11720175765333333333e-12 * t) * t) * t) * t) * t) * t; } case 95: { double t = 2*y100 - 191; return 0.53091065838453612773e-1 + (-0.61586898417077043662e-2 + (0.29057796072960100710e-4 + (-0.12597414620517987536e-7 + (-0.12440642607426861943e-8 + (0.14602787128447932137e-10 - 0.10885859114666666667e-12 * t) * t) * t) * t) * t) * t; } case 96: { double t = 2*y100 - 193; return 0.40889797115352738582e-1 + (-0.60426484889413678200e-2 + (0.28953496450191694606e-4 + (-0.21982952021823718400e-7 + (-0.11044169117553026211e-8 + (0.13344562332430552171e-10 - 0.10091231402844444444e-12 * t) * t) * t) * t) * t) * t; } case 97: case 98: case 99: case 100: { // use Taylor expansion for small x (|x| <= 0.0309...) // (2/sqrt(pi)) * (x - 2/3 x^3 + 4/15 x^5 - 8/105 x^7 + 16/945 x^9) double x2 = x*x; return x * (1.1283791670955125739 - x2 * (0.75225277806367504925 - x2 * (0.30090111122547001970 - x2 * (0.085971746064420005629 - x2 * 0.016931216931216931217)))); } } /* Since 0 <= y100 < 101, this is only reached if x is NaN, in which case we should return NaN. */ return NaN; } double FADDEEVA(w_im)(double x) { if (x >= 0) { if (x > 45) { // continued-fraction expansion is faster const double ispi = 0.56418958354775628694807945156; // 1 / sqrt(pi) if (x > 5e7) // 1-term expansion, important to avoid overflow return ispi / x; /* 5-term expansion (rely on compiler for CSE), simplified from: ispi / (x-0.5/(x-1/(x-1.5/(x-2/x)))) */ return ispi*((x*x) * (x*x-4.5) + 2) / (x * ((x*x) * (x*x-5) + 3.75)); } return w_im_y100(100/(1+x), x); } else { // = -FADDEEVA(w_im)(-x) if (x < -45) { // continued-fraction expansion is faster const double ispi = 0.56418958354775628694807945156; // 1 / sqrt(pi) if (x < -5e7) // 1-term expansion, important to avoid overflow return ispi / x; /* 5-term expansion (rely on compiler for CSE), simplified from: ispi / (x-0.5/(x-1/(x-1.5/(x-2/x)))) */ return ispi*((x*x) * (x*x-4.5) + 2) / (x * ((x*x) * (x*x-5) + 3.75)); } return -w_im_y100(100/(1-x), -x); } } ///////////////////////////////////////////////////////////////////////// // Compile with -DTEST_FADDEEVA to compile a little test program #ifdef TEST_FADDEEVA #ifdef __cplusplus # include #else # include #endif // compute relative error |b-a|/|a|, handling case of NaN and Inf, static double relerr(double a, double b) { if (isnan(a) || isnan(b) || isinf(a) || isinf(b)) { if ((isnan(a) && !isnan(b)) || (!isnan(a) && isnan(b)) || (isinf(a) && !isinf(b)) || (!isinf(a) && isinf(b)) || (isinf(a) && isinf(b) && a*b < 0)) return Inf; // "infinite" error return 0; // matching infinity/nan results counted as zero error } if (a == 0) return b == 0 ? 0 : Inf; else return fabs((b-a) / a); } int main(void) { double errmax_all = 0; { printf("############# w(z) tests #############\n"); #define NTST 57 // define instead of const for C compatibility cmplx z[NTST] = { C(624.2,-0.26123), C(-0.4,3.), C(0.6,2.), C(-1.,1.), C(-1.,-9.), C(-1.,9.), C(-0.0000000234545,1.1234), C(-3.,5.1), C(-53,30.1), C(0.0,0.12345), C(11,1), C(-22,-2), C(9,-28), C(21,-33), C(1e5,1e5), C(1e14,1e14), C(-3001,-1000), C(1e160,-1e159), C(-6.01,0.01), C(-0.7,-0.7), C(2.611780000000000e+01, 4.540909610972489e+03), C(0.8e7,0.3e7), C(-20,-19.8081), C(1e-16,-1.1e-16), C(2.3e-8,1.3e-8), C(6.3,-1e-13), C(6.3,1e-20), C(1e-20,6.3), C(1e-20,16.3), C(9,1e-300), C(6.01,0.11), C(8.01,1.01e-10), C(28.01,1e-300), C(10.01,1e-200), C(10.01,-1e-200), C(10.01,0.99e-10), C(10.01,-0.99e-10), C(1e-20,7.01), C(-1,7.01), C(5.99,7.01), C(1,0), C(55,0), C(-0.1,0), C(1e-20,0), C(0,5e-14), C(0,51), C(Inf,0), C(-Inf,0), C(0,Inf), C(0,-Inf), C(Inf,Inf), C(Inf,-Inf), C(NaN,NaN), C(NaN,0), C(0,NaN), C(NaN,Inf), C(Inf,NaN) }; cmplx w[NTST] = { /* w(z), computed with WolframAlpha ... note that WolframAlpha is problematic some of the above inputs, so I had to use the continued-fraction expansion in WolframAlpha in some cases, or switch to Maple */ C(-3.78270245518980507452677445620103199303131110e-7, 0.000903861276433172057331093754199933411710053155), C(0.1764906227004816847297495349730234591778719532788, -0.02146550539468457616788719893991501311573031095617), C(0.2410250715772692146133539023007113781272362309451, 0.06087579663428089745895459735240964093522265589350), C(0.30474420525691259245713884106959496013413834051768, -0.20821893820283162728743734725471561394145872072738), C(7.317131068972378096865595229600561710140617977e34, 8.321873499714402777186848353320412813066170427e34), C(0.0615698507236323685519612934241429530190806818395, -0.00676005783716575013073036218018565206070072304635), C(0.3960793007699874918961319170187598400134746631, -5.593152259116644920546186222529802777409274656e-9), C(0.08217199226739447943295069917990417630675021771804, -0.04701291087643609891018366143118110965272615832184), C(0.00457246000350281640952328010227885008541748668738, -0.00804900791411691821818731763401840373998654987934), C(0.8746342859608052666092782112565360755791467973338452, 0.), C(0.00468190164965444174367477874864366058339647648741, 0.0510735563901306197993676329845149741675029197050), C(-0.0023193175200187620902125853834909543869428763219, -0.025460054739731556004902057663500272721780776336), C(9.11463368405637174660562096516414499772662584e304, 3.97101807145263333769664875189354358563218932e305), C(-4.4927207857715598976165541011143706155432296e281, -2.8019591213423077494444700357168707775769028e281), C(2.820947917809305132678577516325951485807107151e-6, 2.820947917668257736791638444590253942253354058e-6), C(2.82094791773878143474039725787438662716372268e-15, 2.82094791773878143474039725773333923127678361e-15), C(-0.0000563851289696244350147899376081488003110150498, -0.000169211755126812174631861529808288295454992688), C(-5.586035480670854326218608431294778077663867e-162, 5.586035480670854326218608431294778077663867e-161), C(0.00016318325137140451888255634399123461580248456, -0.095232456573009287370728788146686162555021209999), C(0.69504753678406939989115375989939096800793577783885, -1.8916411171103639136680830887017670616339912024317), C(0.0001242418269653279656612334210746733213167234822, 7.145975826320186888508563111992099992116786763e-7), C(2.318587329648353318615800865959225429377529825e-8, 6.182899545728857485721417893323317843200933380e-8), C(-0.0133426877243506022053521927604277115767311800303, -0.0148087097143220769493341484176979826888871576145), C(1.00000000000000012412170838050638522857747934, 1.12837916709551279389615890312156495593616433e-16), C(0.9999999853310704677583504063775310832036830015, 2.595272024519678881897196435157270184030360773e-8), C(-1.4731421795638279504242963027196663601154624e-15, 0.090727659684127365236479098488823462473074709), C(5.79246077884410284575834156425396800754409308e-18, 0.0907276596841273652364790985059772809093822374), C(0.0884658993528521953466533278764830881245144368, 1.37088352495749125283269718778582613192166760e-22), C(0.0345480845419190424370085249304184266813447878, 2.11161102895179044968099038990446187626075258e-23), C(6.63967719958073440070225527042829242391918213e-36, 0.0630820900592582863713653132559743161572639353), C(0.00179435233208702644891092397579091030658500743634, 0.0951983814805270647939647438459699953990788064762), C(9.09760377102097999924241322094863528771095448e-13, 0.0709979210725138550986782242355007611074966717), C(7.2049510279742166460047102593255688682910274423e-304, 0.0201552956479526953866611812593266285000876784321), C(3.04543604652250734193622967873276113872279682e-44, 0.0566481651760675042930042117726713294607499165), C(3.04543604652250734193622967873276113872279682e-44, 0.0566481651760675042930042117726713294607499165), C(0.5659928732065273429286988428080855057102069081e-12, 0.056648165176067504292998527162143030538756683302), C(-0.56599287320652734292869884280802459698927645e-12, 0.0566481651760675042929985271621430305387566833029), C(0.0796884251721652215687859778119964009569455462, 1.11474461817561675017794941973556302717225126e-22), C(0.07817195821247357458545539935996687005781943386550, -0.01093913670103576690766705513142246633056714279654), C(0.04670032980990449912809326141164730850466208439937, 0.03944038961933534137558064191650437353429669886545), C(0.36787944117144232159552377016146086744581113103176, 0.60715770584139372911503823580074492116122092866515), C(0, 0.010259688805536830986089913987516716056946786526145), C(0.99004983374916805357390597718003655777207908125383, -0.11208866436449538036721343053869621153527769495574), C(0.99999999999999999999999999999999999999990000, 1.12837916709551257389615890312154517168802603e-20), C(0.999999999999943581041645226871305192054749891144158, 0), C(0.0110604154853277201542582159216317923453996211744250, 0), C(0,0), C(0,0), C(0,0), C(Inf,0), C(0,0), C(NaN,NaN), C(NaN,NaN), C(NaN,NaN), C(NaN,0), C(NaN,NaN), C(NaN,NaN) }; double errmax = 0; for (int i = 0; i < NTST; ++i) { cmplx fw = FADDEEVA(w)(z[i],0.); double re_err = relerr(creal(w[i]), creal(fw)); double im_err = relerr(cimag(w[i]), cimag(fw)); printf("w(%g%+gi) = %g%+gi (vs. %g%+gi), re/im rel. err. = %0.2g/%0.2g)\n", creal(z[i]),cimag(z[i]), creal(fw),cimag(fw), creal(w[i]),cimag(w[i]), re_err, im_err); if (re_err > errmax) errmax = re_err; if (im_err > errmax) errmax = im_err; } if (errmax > 1e-13) { printf("FAILURE -- relative error %g too large!\n", errmax); return 1; } printf("SUCCESS (max relative error = %g)\n", errmax); if (errmax > errmax_all) errmax_all = errmax; } { #undef NTST #define NTST 41 // define instead of const for C compatibility cmplx z[NTST] = { C(1,2), C(-1,2), C(1,-2), C(-1,-2), C(9,-28), C(21,-33), C(1e3,1e3), C(-3001,-1000), C(1e160,-1e159), C(5.1e-3, 1e-8), C(-4.9e-3, 4.95e-3), C(4.9e-3, 0.5), C(4.9e-4, -0.5e1), C(-4.9e-5, -0.5e2), C(5.1e-3, 0.5), C(5.1e-4, -0.5e1), C(-5.1e-5, -0.5e2), C(1e-6,2e-6), C(0,2e-6), C(0,2), C(0,20), C(0,200), C(Inf,0), C(-Inf,0), C(0,Inf), C(0,-Inf), C(Inf,Inf), C(Inf,-Inf), C(NaN,NaN), C(NaN,0), C(0,NaN), C(NaN,Inf), C(Inf,NaN), C(1e-3,NaN), C(7e-2,7e-2), C(7e-2,-7e-4), C(-9e-2,7e-4), C(-9e-2,9e-2), C(-7e-4,9e-2), C(7e-2,0.9e-2), C(7e-2,1.1e-2) }; cmplx w[NTST] = { // erf(z[i]), evaluated with Maple C(-0.5366435657785650339917955593141927494421, -5.049143703447034669543036958614140565553), C(0.5366435657785650339917955593141927494421, -5.049143703447034669543036958614140565553), C(-0.5366435657785650339917955593141927494421, 5.049143703447034669543036958614140565553), C(0.5366435657785650339917955593141927494421, 5.049143703447034669543036958614140565553), C(0.3359473673830576996788000505817956637777e304, -0.1999896139679880888755589794455069208455e304), C(0.3584459971462946066523939204836760283645e278, 0.3818954885257184373734213077678011282505e280), C(0.9996020422657148639102150147542224526887, 0.00002801044116908227889681753993542916894856), C(-1, 0), C(1, 0), C(0.005754683859034800134412990541076554934877, 0.1128349818335058741511924929801267822634e-7), C(-0.005529149142341821193633460286828381876955, 0.005585388387864706679609092447916333443570), C(0.007099365669981359632319829148438283865814, 0.6149347012854211635026981277569074001219), C(0.3981176338702323417718189922039863062440e8, -0.8298176341665249121085423917575122140650e10), C(-Inf, -Inf), C(0.007389128308257135427153919483147229573895, 0.6149332524601658796226417164791221815139), C(0.4143671923267934479245651547534414976991e8, -0.8298168216818314211557046346850921446950e10), C(-Inf, -Inf), C(0.1128379167099649964175513742247082845155e-5, 0.2256758334191777400570377193451519478895e-5), C(0, 0.2256758334194034158904576117253481476197e-5), C(0, 18.56480241457555259870429191324101719886), C(0, 0.1474797539628786202447733153131835124599e173), C(0, Inf), C(1,0), C(-1,0), C(0,Inf), C(0,-Inf), C(NaN,NaN), C(NaN,NaN), C(NaN,NaN), C(NaN,0), C(0,NaN), C(NaN,NaN), C(NaN,NaN), C(NaN,NaN), C(0.07924380404615782687930591956705225541145, 0.07872776218046681145537914954027729115247), C(0.07885775828512276968931773651224684454495, -0.0007860046704118224342390725280161272277506), C(-0.1012806432747198859687963080684978759881, 0.0007834934747022035607566216654982820299469), C(-0.1020998418798097910247132140051062512527, 0.1010030778892310851309082083238896270340), C(-0.0007962891763147907785684591823889484764272, 0.1018289385936278171741809237435404896152), C(0.07886408666470478681566329888615410479530, 0.01010604288780868961492224347707949372245), C(0.07886723099940260286824654364807981336591, 0.01235199327873258197931147306290916629654) }; #define TST(f,isc) \ printf("############# " #f "(z) tests #############\n"); \ double errmax = 0; \ for (int i = 0; i < NTST; ++i) { \ cmplx fw = FADDEEVA(f)(z[i],0.); \ double re_err = relerr(creal(w[i]), creal(fw)); \ double im_err = relerr(cimag(w[i]), cimag(fw)); \ printf(#f "(%g%+gi) = %g%+gi (vs. %g%+gi), re/im rel. err. = %0.2g/%0.2g)\n", \ creal(z[i]),cimag(z[i]), creal(fw),cimag(fw), creal(w[i]),cimag(w[i]), \ re_err, im_err); \ if (re_err > errmax) errmax = re_err; \ if (im_err > errmax) errmax = im_err; \ } \ if (errmax > 1e-13) { \ printf("FAILURE -- relative error %g too large!\n", errmax); \ return 1; \ } \ printf("Checking " #f "(x) special case...\n"); \ for (int i = 0; i < 10000; ++i) { \ double x = pow(10., -300. + i * 600. / (10000 - 1)); \ double re_err = relerr(FADDEEVA_RE(f)(x), \ creal(FADDEEVA(f)(C(x,x*isc),0.))); \ if (re_err > errmax) errmax = re_err; \ re_err = relerr(FADDEEVA_RE(f)(-x), \ creal(FADDEEVA(f)(C(-x,x*isc),0.))); \ if (re_err > errmax) errmax = re_err; \ } \ { \ double re_err = relerr(FADDEEVA_RE(f)(Inf), \ creal(FADDEEVA(f)(C(Inf,0.),0.))); \ if (re_err > errmax) errmax = re_err; \ re_err = relerr(FADDEEVA_RE(f)(-Inf), \ creal(FADDEEVA(f)(C(-Inf,0.),0.))); \ if (re_err > errmax) errmax = re_err; \ re_err = relerr(FADDEEVA_RE(f)(NaN), \ creal(FADDEEVA(f)(C(NaN,0.),0.))); \ if (re_err > errmax) errmax = re_err; \ } \ if (errmax > 1e-13) { \ printf("FAILURE -- relative error %g too large!\n", errmax); \ return 1; \ } \ printf("SUCCESS (max relative error = %g)\n", errmax); \ if (errmax > errmax_all) errmax_all = errmax TST(erf, 1e-20); } { // since erfi just calls through to erf, just one test should // be sufficient to make sure I didn't screw up the signs or something #undef NTST #define NTST 1 // define instead of const for C compatibility cmplx z[NTST] = { C(1.234,0.5678) }; cmplx w[NTST] = { // erfi(z[i]), computed with Maple C(1.081032284405373149432716643834106923212, 1.926775520840916645838949402886591180834) }; TST(erfi, 0); } { // since erfcx just calls through to w, just one test should // be sufficient to make sure I didn't screw up the signs or something #undef NTST #define NTST 1 // define instead of const for C compatibility cmplx z[NTST] = { C(1.234,0.5678) }; cmplx w[NTST] = { // erfcx(z[i]), computed with Maple C(0.3382187479799972294747793561190487832579, -0.1116077470811648467464927471872945833154) }; TST(erfcx, 0); } { #undef NTST #define NTST 30 // define instead of const for C compatibility cmplx z[NTST] = { C(1,2), C(-1,2), C(1,-2), C(-1,-2), C(9,-28), C(21,-33), C(1e3,1e3), C(-3001,-1000), C(1e160,-1e159), C(5.1e-3, 1e-8), C(0,2e-6), C(0,2), C(0,20), C(0,200), C(2e-6,0), C(2,0), C(20,0), C(200,0), C(Inf,0), C(-Inf,0), C(0,Inf), C(0,-Inf), C(Inf,Inf), C(Inf,-Inf), C(NaN,NaN), C(NaN,0), C(0,NaN), C(NaN,Inf), C(Inf,NaN), C(88,0) }; cmplx w[NTST] = { // erfc(z[i]), evaluated with Maple C(1.536643565778565033991795559314192749442, 5.049143703447034669543036958614140565553), C(0.4633564342214349660082044406858072505579, 5.049143703447034669543036958614140565553), C(1.536643565778565033991795559314192749442, -5.049143703447034669543036958614140565553), C(0.4633564342214349660082044406858072505579, -5.049143703447034669543036958614140565553), C(-0.3359473673830576996788000505817956637777e304, 0.1999896139679880888755589794455069208455e304), C(-0.3584459971462946066523939204836760283645e278, -0.3818954885257184373734213077678011282505e280), C(0.0003979577342851360897849852457775473112748, -0.00002801044116908227889681753993542916894856), C(2, 0), C(0, 0), C(0.9942453161409651998655870094589234450651, -0.1128349818335058741511924929801267822634e-7), C(1, -0.2256758334194034158904576117253481476197e-5), C(1, -18.56480241457555259870429191324101719886), C(1, -0.1474797539628786202447733153131835124599e173), C(1, -Inf), C(0.9999977432416658119838633199332831406314, 0), C(0.004677734981047265837930743632747071389108, 0), C(0.5395865611607900928934999167905345604088e-175, 0), C(0, 0), C(0, 0), C(2, 0), C(1, -Inf), C(1, Inf), C(NaN, NaN), C(NaN, NaN), C(NaN, NaN), C(NaN, 0), C(1, NaN), C(NaN, NaN), C(NaN, NaN), C(0,0) }; TST(erfc, 1e-20); } { #undef NTST #define NTST 48 // define instead of const for C compatibility cmplx z[NTST] = { C(2,1), C(-2,1), C(2,-1), C(-2,-1), C(-28,9), C(33,-21), C(1e3,1e3), C(-1000,-3001), C(1e-8, 5.1e-3), C(4.95e-3, -4.9e-3), C(5.1e-3, 5.1e-3), C(0.5, 4.9e-3), C(-0.5e1, 4.9e-4), C(-0.5e2, -4.9e-5), C(0.5e3, 4.9e-6), C(0.5, 5.1e-3), C(-0.5e1, 5.1e-4), C(-0.5e2, -5.1e-5), C(1e-6,2e-6), C(2e-6,0), C(2,0), C(20,0), C(200,0), C(0,4.9e-3), C(0,-5.1e-3), C(0,2e-6), C(0,-2), C(0,20), C(0,-200), C(Inf,0), C(-Inf,0), C(0,Inf), C(0,-Inf), C(Inf,Inf), C(Inf,-Inf), C(NaN,NaN), C(NaN,0), C(0,NaN), C(NaN,Inf), C(Inf,NaN), C(39, 6.4e-5), C(41, 6.09e-5), C(4.9e7, 5e-11), C(5.1e7, 4.8e-11), C(1e9, 2.4e-12), C(1e11, 2.4e-14), C(1e13, 2.4e-16), C(1e300, 2.4e-303) }; cmplx w[NTST] = { // dawson(z[i]), evaluated with Maple C(0.1635394094345355614904345232875688576839, -0.1531245755371229803585918112683241066853), C(-0.1635394094345355614904345232875688576839, -0.1531245755371229803585918112683241066853), C(0.1635394094345355614904345232875688576839, 0.1531245755371229803585918112683241066853), C(-0.1635394094345355614904345232875688576839, 0.1531245755371229803585918112683241066853), C(-0.01619082256681596362895875232699626384420, -0.005210224203359059109181555401330902819419), C(0.01078377080978103125464543240346760257008, 0.006866888783433775382193630944275682670599), C(-0.5808616819196736225612296471081337245459, 0.6688593905505562263387760667171706325749), C(Inf, -Inf), C(0.1000052020902036118082966385855563526705e-7, 0.005100088434920073153418834680320146441685), C(0.004950156837581592745389973960217444687524, -0.004899838305155226382584756154100963570500), C(0.005100176864319675957314822982399286703798, 0.005099823128319785355949825238269336481254), C(0.4244534840871830045021143490355372016428, 0.002820278933186814021399602648373095266538), C(-0.1021340733271046543881236523269967674156, -0.00001045696456072005761498961861088944159916), C(-0.01000200120119206748855061636187197886859, 0.9805885888237419500266621041508714123763e-8), C(0.001000002000012000023960527532953151819595, -0.9800058800588007290937355024646722133204e-11), C(0.4244549085628511778373438768121222815752, 0.002935393851311701428647152230552122898291), C(-0.1021340732357117208743299813648493928105, -0.00001088377943049851799938998805451564893540), C(-0.01000200120119126652710792390331206563616, 0.1020612612857282306892368985525393707486e-7), C(0.1000000000007333333333344266666666664457e-5, 0.2000000000001333333333323199999999978819e-5), C(0.1999999999994666666666675199999999990248e-5, 0), C(0.3013403889237919660346644392864226952119, 0), C(0.02503136792640367194699495234782353186858, 0), C(0.002500031251171948248596912483183760683918, 0), C(0,0.004900078433419939164774792850907128053308), C(0,-0.005100088434920074173454208832365950009419), C(0,0.2000000000005333333333341866666666676419e-5), C(0,-48.16001211429122974789822893525016528191), C(0,0.4627407029504443513654142715903005954668e174), C(0,-Inf), C(0,0), C(-0,0), C(0, Inf), C(0, -Inf), C(NaN, NaN), C(NaN, NaN), C(NaN, NaN), C(NaN, 0), C(0, NaN), C(NaN, NaN), C(NaN, NaN), C(0.01282473148489433743567240624939698290584, -0.2105957276516618621447832572909153498104e-7), C(0.01219875253423634378984109995893708152885, -0.1813040560401824664088425926165834355953e-7), C(0.1020408163265306334945473399689037886997e-7, -0.1041232819658476285651490827866174985330e-25), C(0.9803921568627452865036825956835185367356e-8, -0.9227220299884665067601095648451913375754e-26), C(0.5000000000000000002500000000000000003750e-9, -0.1200000000000000001800000188712838420241e-29), C(5.00000000000000000000025000000000000000000003e-12, -1.20000000000000000000018000000000000000000004e-36), C(5.00000000000000000000000002500000000000000000e-14, -1.20000000000000000000000001800000000000000000e-42), C(5e-301, 0) }; TST(Dawson, 1e-20); } printf("#####################################\n"); printf("SUCCESS (max relative error = %g)\n", errmax_all); } #endif openspecfun-0.3/Faddeeva/Faddeeva.h000066400000000000000000000053341232445310600172550ustar00rootroot00000000000000/* Copyright (c) 2012 Massachusetts Institute of Technology * * Permission is hereby granted, free of charge, to any person obtaining * a copy of this software and associated documentation files (the * "Software"), to deal in the Software without restriction, including * without limitation the rights to use, copy, modify, merge, publish, * distribute, sublicense, and/or sell copies of the Software, and to * permit persons to whom the Software is furnished to do so, subject to * the following conditions: * * The above copyright notice and this permission notice shall be * included in all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND * NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE * LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION * OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. */ /* Available at: http://ab-initio.mit.edu/Faddeeva Header file for Faddeeva.c; see Faddeeva.cc for more information. */ #ifndef FADDEEVA_H #define FADDEEVA_H 1 // Require C99 complex-number support #include #ifdef __cplusplus extern "C" { #endif /* __cplusplus */ // compute w(z) = exp(-z^2) erfc(-iz) [ Faddeeva / scaled complex error func ] extern double complex Faddeeva_w(double complex z,double relerr); extern double Faddeeva_w_im(double x); // special-case code for Im[w(x)] of real x // Various functions that we can compute with the help of w(z) // compute erfcx(z) = exp(z^2) erfc(z) extern double complex Faddeeva_erfcx(double complex z, double relerr); extern double Faddeeva_erfcx_re(double x); // special case for real x // compute erf(z), the error function of complex arguments extern double complex Faddeeva_erf(double complex z, double relerr); extern double Faddeeva_erf_re(double x); // special case for real x // compute erfi(z) = -i erf(iz), the imaginary error function extern double complex Faddeeva_erfi(double complex z, double relerr); extern double Faddeeva_erfi_re(double x); // special case for real x // compute erfc(z) = 1 - erf(z), the complementary error function extern double complex Faddeeva_erfc(double complex z, double relerr); extern double Faddeeva_erfc_re(double x); // special case for real x // compute Dawson(z) = sqrt(pi)/2 * exp(-z^2) * erfi(z) extern double complex Faddeeva_Dawson(double complex z, double relerr); extern double Faddeeva_Dawson_re(double x); // special case for real x #ifdef __cplusplus } #endif /* __cplusplus */ #endif // FADDEEVA_H openspecfun-0.3/Faddeeva/Make.files000066400000000000000000000001641232445310600173020ustar00rootroot00000000000000# complex error functions from the Faddeeva package # (http://ab-initio.mit.edu/Faddeeva) $(CUR_SRCS) += Faddeeva.c openspecfun-0.3/LICENSE.md000066400000000000000000000034401232445310600153060ustar00rootroot00000000000000# OpenSpecFun License ## Faddeeva license > Copyright (c) 2012 Massachusetts Institute of Technology > > Permission is hereby granted, free of charge, to any person obtaining > a copy of this software and associated documentation files (the > "Software"), to deal in the Software without restriction, including > without limitation the rights to use, copy, modify, merge, publish, > distribute, sublicense, and/or sell copies of the Software, and to > permit persons to whom the Software is furnished to do so, subject to > the following conditions: > > The above copyright notice and this permission notice shall be > included in all copies or substantial portions of the Software. > > THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, > EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF > MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND > NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE > LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION > OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION > WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. ## AMOS license Based on the discussion at http://octave.1599824.n4.nabble.com/Can-we-freely-use-AMOS-in-Octave-td4642557.html, AMOS is included in openspecfun as public domain software > The AMOS functions are included in SLATEC, and the SLATEC guide > (http://www.netlib.org/slatec/guide) explicitly states: > > "The Library is in the public domain and distributed by the Energy > Science and Technology Software Center." > > Mention of AMOS's inclusion in SLATEC goes back at least to this 1985 > technical report from Sandia National Labs: > http://infoserve.sandia.gov/sand_doc/1985/851018.pdf openspecfun-0.3/Make.inc000066400000000000000000000044211232445310600152520ustar00rootroot00000000000000# -*- mode: makefile-gmake -*- OS := $(shell uname) VERSION = 0.3.0 VERSION_SPLIT = $(subst ., , $(VERSION)) DESTDIR = prefix = /usr/local bindir = $(prefix)/bin libdir = $(prefix)/lib includedir = $(prefix)/include FC = gfortran # CFLAGS_add and FFLAGS_add are flags that we always want to include # They are not overridable by the user, whereas CFLAGS and FFLAGS are # simply defaults and are overridable via environment variables or # `make CFLAGS="foo"` on the command line FFLAGS = -O3 CFLAGS = -std=c99 -Wall -O3 CPPFLAGS = override FFLAGS_add = override CFLAGS_add = override CPPFLAGS_add = USEGCC = 1 USECLANG = 0 ifeq ($(OS), Darwin) USEGCC = 0 USECLANG = 1 endif AR = ar ifeq ($(USECLANG),1) USEGCC = 0 CC = clang override CFLAGS_add += -fno-builtin endif ifeq ($(USEGCC),1) CC = gcc override CFLAGS_add += -fno-gnu89-inline -std=c99 endif ARCH := $(shell $(CC) -dumpmachine | sed "s/\([^-]*\).*$$/\1/") ifeq ($(ARCH),mingw32) $(error "the mingw32 compiler you are using fails the openblas testsuite. please see the Julia README.windows.md document for a replacement") endif ifeq ($(USE_OPENLIBM),1) override CPPFLAGS_add += -DUSE_OPENLIBM -I$(includedir) -I$(includedir)/openlibm/ endif default: all %.c.o: %.c $(CC) $(CPPFLAGS) $(CPPFLAGS_add) $(CFLAGS_add) $(CFLAGS) -c $< -o $@ %.f.o: %.f $(FC) $(FFLAGS) $(FFLAGS_add) -c $< -o $@ %.S.o: %.S $(CC) $(SFLAGS) $(filter -m% -B% -I% -D%,$(CFLAGS_add)) -c $< -o $@ # OS-specific stuff ifeq ($(ARCH),i386) override ARCH := i387 endif ifeq ($(ARCH),i486) override ARCH := i387 endif ifeq ($(ARCH),i686) override ARCH := i387 endif ifeq ($(ARCH),x86_64) override ARCH := amd64 endif ifneq (,$(findstring MINGW,$(OS))) override OS=WINNT endif #keep these if statements separate ifeq ($(OS), WINNT) SHLIB_EXT = dll SONAME_FLAG = -soname override CFLAGS_add += -nodefaultlibs override FFLAGS_add += -nodefaultlibs shlibdir = $(bindir) else shlibdir = $(libdir) endif ifeq ($(OS), Linux) SHLIB_EXT = so SONAME_FLAG = -soname override CFLAGS_add += -fPIC override FFLAGS_add += -fPIC endif ifeq ($(OS), FreeBSD) SHLIB_EXT = so SONAME_FLAG = -soname override CFLAGS_add += -fPIC override FFLAGS_add += -fPIC endif ifeq ($(OS), Darwin) SONAME_FLAG = -install_name SHLIB_EXT = dylib override CFLAGS_add += -fPIC override FFLAGS_add += -fPIC endif openspecfun-0.3/Makefile000066400000000000000000000032161232445310600153430ustar00rootroot00000000000000OPENLIBM_HOME=$(abspath .) include ./Make.inc SUBDIRS = amos Faddeeva define INC_template TEST=test override CUR_SRCS = $(1)_SRCS include $(1)/Make.files SRCS += $$(addprefix $(1)/,$$($(1)_SRCS)) endef DIR=test $(foreach dir,$(SUBDIRS),$(eval $(call INC_template,$(dir)))) DUPLICATE_NAMES = $(filter $(patsubst %.S,%,$($(ARCH)_SRCS)),$(patsubst %.c,%,$(src_SRCS))) DUPLICATE_SRCS = $(addsuffix .c,$(DUPLICATE_NAMES)) OBJS = $(patsubst %.f,%.f.o,\ $(patsubst %.S,%.S.o,\ $(patsubst %.c,%.c.o,$(filter-out $(addprefix src/,$(DUPLICATE_SRCS)),$(SRCS))))) all: libopenspecfun.a libopenspecfun.$(SHLIB_EXT) libopenspecfun.a: $(OBJS) $(AR) -rcs libopenspecfun.a $(OBJS) libopenspecfun.$(SHLIB_EXT): $(OBJS) ifeq ($(OS),WINNT) $(FC) -shared $(OBJS) $(LDFLAGS) -Wl,$(SONAME_FLAG),libopenspecfun.$(SHLIB_EXT) -o libopenspecfun.$(SHLIB_EXT) else $(FC) -shared $(OBJS) $(LDFLAGS) -Wl,$(SONAME_FLAG),libopenspecfun.$(SHLIB_EXT).$(VERSION) -o libopenspecfun.$(SHLIB_EXT).$(VERSION) ln -s libopenspecfun.$(SHLIB_EXT).$(VERSION) libopenspecfun.$(SHLIB_EXT).$(word 1,$(VERSION_SPLIT)).$(word 2,$(VERSION_SPLIT)) ln -s libopenspecfun.$(SHLIB_EXT).$(VERSION) libopenspecfun.$(SHLIB_EXT).$(word 1,$(VERSION_SPLIT)) ln -s libopenspecfun.$(SHLIB_EXT).$(VERSION) libopenspecfun.$(SHLIB_EXT) endif install: all mkdir -p $(DESTDIR)$(shlibdir) mkdir -p $(DESTDIR)$(libdir) mkdir -p $(DESTDIR)$(includedir) cp -a libopenspecfun.$(SHLIB_EXT)* $(DESTDIR)$(shlibdir)/ cp -a libopenspecfun.a $(DESTDIR)$(libdir)/ cp -a Faddeeva/Faddeeva.h $(DESTDIR)$(includedir) clean: @for dir in Faddeeva amos .; do \ rm -fr $$dir/*.o $$dir/*.a $$dir/*.$(SHLIB_EXT)*; \ done distclean: clean openspecfun-0.3/README.md000066400000000000000000000012171232445310600151610ustar00rootroot00000000000000openspecfun =========== Openspecfun provides AMOS and Faddeeva. AMOS (from Netlib) is a portable package for Bessel Functions of a Complex Argument and Nonnegative Order; it contains subroutines for computing Bessel functions and Airy functions. Faddeeva allows computing the various error functions of arbitrary complex arguments (Faddeeva function, error function, complementary error function, scaled complementary error function, imaginary error function, and Dawson function); given these, one can also easily compute Voigt functions, Fresnel integrals, and similar related functions as well. To build, run: make clean && make && make install openspecfun-0.3/amos/000077500000000000000000000000001232445310600146405ustar00rootroot00000000000000openspecfun-0.3/amos/Make.files000066400000000000000000000005651232445310600165470ustar00rootroot00000000000000$(CUR_SRCS) += d1mach.f zabs.f zasyi.f zbesk.f zbknu.f zexp.f zmlt.f zshch.f zuni1.f zunk2.f \ dgamln.f zacai.f zbesh.f zbesy.f zbuni.f zkscl.f zrati.f zsqrt.f zuni2.f zuoik.f \ i1mach.f zacon.f zbesi.f zbinu.f zbunk.f zlog.f zs1s2.f zuchk.f zunik.f zwrsk.f \ xerror.f zairy.f zbesj.f zbiry.f zdiv.f zmlri.f zseri.f zunhj.f zunk1.f openspecfun-0.3/amos/d1mach.f000066400000000000000000000064171232445310600161540ustar00rootroot00000000000000*DECK D1MACH DOUBLE PRECISION FUNCTION D1MACH(I) C***BEGIN PROLOGUE D1MACH C***DATE WRITTEN 750101 (YYMMDD) C***REVISION DATE 890213 (YYMMDD) C***CATEGORY NO. R1 C***KEYWORDS LIBRARY=SLATEC,TYPE=DOUBLE PRECISION(R1MACH-S D1MACH-D), C MACHINE CONSTANTS C***AUTHOR FOX, P. A., (BELL LABS) C HALL, A. D., (BELL LABS) C SCHRYER, N. L., (BELL LABS) C***PURPOSE Returns double precision machine dependent constants C***DESCRIPTION C C D1MACH can be used to obtain machine-dependent parameters C for the local machine environment. It is a function C subprogram with one (input) argument, and can be called C as follows, for example C C D = D1MACH(I) C C where I=1,...,5. The (output) value of D above is C determined by the (input) value of I. The results for C various values of I are discussed below. C C D1MACH( 1) = B**(EMIN-1), the smallest positive magnitude. C D1MACH( 2) = B**EMAX*(1 - B**(-T)), the largest magnitude. C D1MACH( 3) = B**(-T), the smallest relative spacing. C D1MACH( 4) = B**(1-T), the largest relative spacing. C D1MACH( 5) = LOG10(B) C C Assume double precision numbers are represented in the T-digit, C base-B form C C sign (B**E)*( (X(1)/B) + ... + (X(T)/B**T) ) C C where 0 .LE. X(I) .LT. B for I=1,...,T, 0 .LT. X(1), and C EMIN .LE. E .LE. EMAX. C C The values of B, T, EMIN and EMAX are provided in I1MACH as C follows: C I1MACH(10) = B, the base. C I1MACH(14) = T, the number of base-B digits. C I1MACH(15) = EMIN, the smallest exponent E. C I1MACH(16) = EMAX, the largest exponent E. C C To alter this function for a particular environment, C the desired set of DATA statements should be activated by C removing the C from column 1. Also, the values of C D1MACH(1) - D1MACH(4) should be checked for consistency C with the local operating system. C C***REFERENCES FOX P.A., HALL A.D., SCHRYER N.L.,*FRAMEWORK FOR A C PORTABLE LIBRARY*, ACM TRANSACTIONS ON MATHEMATICAL C SOFTWARE, VOL. 4, NO. 2, JUNE 1978, PP. 177-188. C***ROUTINES CALLED XERROR C***END PROLOGUE D1MACH C INTEGER SMALL(4) INTEGER LARGE(4) INTEGER RIGHT(4) INTEGER DIVER(4) INTEGER LOG10(4) C DOUBLE PRECISION DMACH(5) SAVE DMACH C C EQUIVALENCE (DMACH(1),SMALL(1)) C EQUIVALENCE (DMACH(2),LARGE(1)) C EQUIVALENCE (DMACH(3),RIGHT(1)) C EQUIVALENCE (DMACH(4),DIVER(1)) C EQUIVALENCE (DMACH(5),LOG10(1)) C C MACHINE CONSTANTS FOR THE IBM PC C ASSUMES THAT ALL ARITHMETIC IS DONE IN DOUBLE PRECISION C ON 8088, I.E., NOT IN 80 BIT FORM FOR THE 8087. C DATA DMACH(1) / 2.23D-308 / C DATA SMALL(1),SMALL(2) / 2002288515, 1050897 / DATA DMACH(2) / 1.79D-308 / C DATA LARGE(1),LARGE(2) / 1487780761, 2146426097 / DATA DMACH(3) / 1.11D-16 / C DATA RIGHT(1),RIGHT(2) / -1209488034, 1017118298 / DATA DMACH(4) / 2.22D-16 / C DATA DIVER(1),DIVER(2) / -1209488034, 1018166874 / DATA DMACH(5) / 0.3010299956639812 / C DATA LOG10(1),LOG10(2) / 1352628735, 1070810131 / C C C***FIRST EXECUTABLE STATEMENT D1MACH IF (I .LT. 1 .OR. I .GT. 5) 1 CALL XERROR ('D1MACH -- I OUT OF BOUNDS', 25, 1, 2) C D1MACH = DMACH(I) RETURN C END openspecfun-0.3/amos/dgamln.f000066400000000000000000000206251232445310600162560ustar00rootroot00000000000000 DOUBLE PRECISION FUNCTION DGAMLN(Z,IERR) C***BEGIN PROLOGUE DGAMLN C***DATE WRITTEN 830501 (YYMMDD) C***REVISION DATE 830501 (YYMMDD) C***CATEGORY NO. B5F C***KEYWORDS GAMMA FUNCTION,LOGARITHM OF GAMMA FUNCTION C***AUTHOR AMOS, DONALD E., SANDIA NATIONAL LABORATORIES C***PURPOSE TO COMPUTE THE LOGARITHM OF THE GAMMA FUNCTION C***DESCRIPTION C C **** A DOUBLE PRECISION ROUTINE **** C DGAMLN COMPUTES THE NATURAL LOG OF THE GAMMA FUNCTION FOR C Z.GT.0. THE ASYMPTOTIC EXPANSION IS USED TO GENERATE VALUES C GREATER THAN ZMIN WHICH ARE ADJUSTED BY THE RECURSION C G(Z+1)=Z*G(Z) FOR Z.LE.ZMIN. THE FUNCTION WAS MADE AS C PORTABLE AS POSSIBLE BY COMPUTIMG ZMIN FROM THE NUMBER OF BASE C 10 DIGITS IN A WORD, RLN=AMAX1(-ALOG10(R1MACH(4)),0.5E-18) C LIMITED TO 18 DIGITS OF (RELATIVE) ACCURACY. C C SINCE INTEGER ARGUMENTS ARE COMMON, A TABLE LOOK UP ON 100 C VALUES IS USED FOR SPEED OF EXECUTION. C C DESCRIPTION OF ARGUMENTS C C INPUT Z IS D0UBLE PRECISION C Z - ARGUMENT, Z.GT.0.0D0 C C OUTPUT DGAMLN IS DOUBLE PRECISION C DGAMLN - NATURAL LOG OF THE GAMMA FUNCTION AT Z.NE.0.0D0 C IERR - ERROR FLAG C IERR=0, NORMAL RETURN, COMPUTATION COMPLETED C IERR=1, Z.LE.0.0D0, NO COMPUTATION C C C***REFERENCES COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT C BY D. E. AMOS, SAND83-0083, MAY, 1983. C***ROUTINES CALLED I1MACH,D1MACH C***END PROLOGUE DGAMLN DOUBLE PRECISION CF, CON, FLN, FZ, GLN, RLN, S, TLG, TRM, TST, * T1, WDTOL, Z, ZDMY, ZINC, ZM, ZMIN, ZP, ZSQ, D1MACH INTEGER I, IERR, I1M, K, MZ, NZ, I1MACH DIMENSION CF(22), GLN(100) C LNGAMMA(N), N=1,100 DATA GLN(1), GLN(2), GLN(3), GLN(4), GLN(5), GLN(6), GLN(7), 1 GLN(8), GLN(9), GLN(10), GLN(11), GLN(12), GLN(13), GLN(14), 2 GLN(15), GLN(16), GLN(17), GLN(18), GLN(19), GLN(20), 3 GLN(21), GLN(22)/ 4 0.00000000000000000D+00, 0.00000000000000000D+00, 5 6.93147180559945309D-01, 1.79175946922805500D+00, 6 3.17805383034794562D+00, 4.78749174278204599D+00, 7 6.57925121201010100D+00, 8.52516136106541430D+00, 8 1.06046029027452502D+01, 1.28018274800814696D+01, 9 1.51044125730755153D+01, 1.75023078458738858D+01, A 1.99872144956618861D+01, 2.25521638531234229D+01, B 2.51912211827386815D+01, 2.78992713838408916D+01, C 3.06718601060806728D+01, 3.35050734501368889D+01, D 3.63954452080330536D+01, 3.93398841871994940D+01, E 4.23356164607534850D+01, 4.53801388984769080D+01/ DATA GLN(23), GLN(24), GLN(25), GLN(26), GLN(27), GLN(28), 1 GLN(29), GLN(30), GLN(31), GLN(32), GLN(33), GLN(34), 2 GLN(35), GLN(36), GLN(37), GLN(38), GLN(39), GLN(40), 3 GLN(41), GLN(42), GLN(43), GLN(44)/ 4 4.84711813518352239D+01, 5.16066755677643736D+01, 5 5.47847293981123192D+01, 5.80036052229805199D+01, 6 6.12617017610020020D+01, 6.45575386270063311D+01, 7 6.78897431371815350D+01, 7.12570389671680090D+01, 8 7.46582363488301644D+01, 7.80922235533153106D+01, 9 8.15579594561150372D+01, 8.50544670175815174D+01, A 8.85808275421976788D+01, 9.21361756036870925D+01, B 9.57196945421432025D+01, 9.93306124547874269D+01, C 1.02968198614513813D+02, 1.06631760260643459D+02, D 1.10320639714757395D+02, 1.14034211781461703D+02, E 1.17771881399745072D+02, 1.21533081515438634D+02/ DATA GLN(45), GLN(46), GLN(47), GLN(48), GLN(49), GLN(50), 1 GLN(51), GLN(52), GLN(53), GLN(54), GLN(55), GLN(56), 2 GLN(57), GLN(58), GLN(59), GLN(60), GLN(61), GLN(62), 3 GLN(63), GLN(64), GLN(65), GLN(66)/ 4 1.25317271149356895D+02, 1.29123933639127215D+02, 5 1.32952575035616310D+02, 1.36802722637326368D+02, 6 1.40673923648234259D+02, 1.44565743946344886D+02, 7 1.48477766951773032D+02, 1.52409592584497358D+02, 8 1.56360836303078785D+02, 1.60331128216630907D+02, 9 1.64320112263195181D+02, 1.68327445448427652D+02, A 1.72352797139162802D+02, 1.76395848406997352D+02, B 1.80456291417543771D+02, 1.84533828861449491D+02, C 1.88628173423671591D+02, 1.92739047287844902D+02, D 1.96866181672889994D+02, 2.01009316399281527D+02, E 2.05168199482641199D+02, 2.09342586752536836D+02/ DATA GLN(67), GLN(68), GLN(69), GLN(70), GLN(71), GLN(72), 1 GLN(73), GLN(74), GLN(75), GLN(76), GLN(77), GLN(78), 2 GLN(79), GLN(80), GLN(81), GLN(82), GLN(83), GLN(84), 3 GLN(85), GLN(86), GLN(87), GLN(88)/ 4 2.13532241494563261D+02, 2.17736934113954227D+02, 5 2.21956441819130334D+02, 2.26190548323727593D+02, 6 2.30439043565776952D+02, 2.34701723442818268D+02, 7 2.38978389561834323D+02, 2.43268849002982714D+02, 8 2.47572914096186884D+02, 2.51890402209723194D+02, 9 2.56221135550009525D+02, 2.60564940971863209D+02, A 2.64921649798552801D+02, 2.69291097651019823D+02, B 2.73673124285693704D+02, 2.78067573440366143D+02, C 2.82474292687630396D+02, 2.86893133295426994D+02, D 2.91323950094270308D+02, 2.95766601350760624D+02, E 3.00220948647014132D+02, 3.04686856765668715D+02/ DATA GLN(89), GLN(90), GLN(91), GLN(92), GLN(93), GLN(94), 1 GLN(95), GLN(96), GLN(97), GLN(98), GLN(99), GLN(100)/ 2 3.09164193580146922D+02, 3.13652829949879062D+02, 3 3.18152639620209327D+02, 3.22663499126726177D+02, 4 3.27185287703775217D+02, 3.31717887196928473D+02, 5 3.36261181979198477D+02, 3.40815058870799018D+02, 6 3.45379407062266854D+02, 3.49954118040770237D+02, 7 3.54539085519440809D+02, 3.59134205369575399D+02/ C COEFFICIENTS OF ASYMPTOTIC EXPANSION DATA CF(1), CF(2), CF(3), CF(4), CF(5), CF(6), CF(7), CF(8), 1 CF(9), CF(10), CF(11), CF(12), CF(13), CF(14), CF(15), 2 CF(16), CF(17), CF(18), CF(19), CF(20), CF(21), CF(22)/ 3 8.33333333333333333D-02, -2.77777777777777778D-03, 4 7.93650793650793651D-04, -5.95238095238095238D-04, 5 8.41750841750841751D-04, -1.91752691752691753D-03, 6 6.41025641025641026D-03, -2.95506535947712418D-02, 7 1.79644372368830573D-01, -1.39243221690590112D+00, 8 1.34028640441683920D+01, -1.56848284626002017D+02, 9 2.19310333333333333D+03, -3.61087712537249894D+04, A 6.91472268851313067D+05, -1.52382215394074162D+07, B 3.82900751391414141D+08, -1.08822660357843911D+10, C 3.47320283765002252D+11, -1.23696021422692745D+13, D 4.88788064793079335D+14, -2.13203339609193739D+16/ C C LN(2*PI) DATA CON / 1.83787706640934548D+00/ C C***FIRST EXECUTABLE STATEMENT DGAMLN IERR=0 IF (Z.LE.0.0D0) GO TO 70 IF (Z.GT.101.0D0) GO TO 10 NZ = INT(SNGL(Z)) FZ = Z - FLOAT(NZ) IF (FZ.GT.0.0D0) GO TO 10 IF (NZ.GT.100) GO TO 10 DGAMLN = GLN(NZ) RETURN 10 CONTINUE WDTOL = D1MACH(4) WDTOL = DMAX1(WDTOL,0.5D-18) I1M = I1MACH(14) RLN = D1MACH(5)*FLOAT(I1M) FLN = DMIN1(RLN,20.0D0) FLN = DMAX1(FLN,3.0D0) FLN = FLN - 3.0D0 ZM = 1.8000D0 + 0.3875D0*FLN MZ = INT(SNGL(ZM)) + 1 ZMIN = FLOAT(MZ) ZDMY = Z ZINC = 0.0D0 IF (Z.GE.ZMIN) GO TO 20 ZINC = ZMIN - FLOAT(NZ) ZDMY = Z + ZINC 20 CONTINUE ZP = 1.0D0/ZDMY T1 = CF(1)*ZP S = T1 IF (ZP.LT.WDTOL) GO TO 40 ZSQ = ZP*ZP TST = T1*WDTOL DO 30 K=2,22 ZP = ZP*ZSQ TRM = CF(K)*ZP IF (DABS(TRM).LT.TST) GO TO 40 S = S + TRM 30 CONTINUE 40 CONTINUE IF (ZINC.NE.0.0D0) GO TO 50 TLG = DLOG(Z) DGAMLN = Z*(TLG-1.0D0) + 0.5D0*(CON-TLG) + S RETURN 50 CONTINUE ZP = 1.0D0 NZ = INT(SNGL(ZINC)) DO 60 I=1,NZ ZP = ZP*(Z+FLOAT(I-1)) 60 CONTINUE TLG = DLOG(ZDMY) DGAMLN = ZDMY*(TLG-1.0D0) - DLOG(ZP) + 0.5D0*(CON-TLG) + S RETURN C C 70 CONTINUE IERR=1 RETURN END openspecfun-0.3/amos/i1mach.f000066400000000000000000000070431232445310600161550ustar00rootroot00000000000000*DECK I1MACH INTEGER FUNCTION I1MACH(I) C***BEGIN PROLOGUE I1MACH C***DATE WRITTEN 750101 (YYMMDD) C***REVISION DATE 890213 (YYMMDD) C***CATEGORY NO. R1 C***KEYWORDS LIBRARY=SLATEC,TYPE=INTEGER(I1MACH-I),MACHINE CONSTANTS C***AUTHOR FOX, P. A., (BELL LABS) C HALL, A. D., (BELL LABS) C SCHRYER, N. L., (BELL LABS) C***PURPOSE Returns integer machine dependent constants C***DESCRIPTION C C I1MACH can be used to obtain machine-dependent parameters C for the local machine environment. It is a function C subroutine with one (input) argument, and can be called C as follows, for example C C K = I1MACH(I) C C where I=1,...,16. The (output) value of K above is C determined by the (input) value of I. The results for C various values of I are discussed below. C C I/O unit numbers. C I1MACH( 1) = the standard input unit. C I1MACH( 2) = the standard output unit. C I1MACH( 3) = the standard punch unit. C I1MACH( 4) = the standard error message unit. C C Words. C I1MACH( 5) = the number of bits per integer storage unit. C I1MACH( 6) = the number of characters per integer storage unit. C C Integers. C assume integers are represented in the S-digit, base-A form C C sign ( X(S-1)*A**(S-1) + ... + X(1)*A + X(0) ) C C where 0 .LE. X(I) .LT. A for I=0,...,S-1. C I1MACH( 7) = A, the base. C I1MACH( 8) = S, the number of base-A digits. C I1MACH( 9) = A**S - 1, the largest magnitude. C C Floating-Point Numbers. C Assume floating-point numbers are represented in the T-digit, C base-B form C sign (B**E)*( (X(1)/B) + ... + (X(T)/B**T) ) C C where 0 .LE. X(I) .LT. B for I=1,...,T, C 0 .LT. X(1), and EMIN .LE. E .LE. EMAX. C I1MACH(10) = B, the base. C C Single-Precision C I1MACH(11) = T, the number of base-B digits. C I1MACH(12) = EMIN, the smallest exponent E. C I1MACH(13) = EMAX, the largest exponent E. C C Double-Precision C I1MACH(14) = T, the number of base-B digits. C I1MACH(15) = EMIN, the smallest exponent E. C I1MACH(16) = EMAX, the largest exponent E. C C To alter this function for a particular environment, C the desired set of DATA statements should be activated by C removing the C from column 1. Also, the values of C I1MACH(1) - I1MACH(4) should be checked for consistency C with the local operating system. C C***REFERENCES FOX P.A., HALL A.D., SCHRYER N.L.,*FRAMEWORK FOR A C PORTABLE LIBRARY*, ACM TRANSACTIONS ON MATHEMATICAL C SOFTWARE, VOL. 4, NO. 2, JUNE 1978, PP. 177-188. C***ROUTINES CALLED (NONE) C***END PROLOGUE I1MACH C INTEGER IMACH(16),OUTPUT SAVE IMACH EQUIVALENCE (IMACH(4),OUTPUT) C C MACHINE CONSTANTS FOR THE IBM PC C DATA IMACH( 1) / 5 / DATA IMACH( 2) / 6 / DATA IMACH( 3) / 0 / DATA IMACH( 4) / 0 / DATA IMACH( 5) / 32 / DATA IMACH( 6) / 4 / DATA IMACH( 7) / 2 / DATA IMACH( 8) / 31 / DATA IMACH( 9) / 2147483647 / DATA IMACH(10) / 2 / DATA IMACH(11) / 24 / DATA IMACH(12) / -125 / DATA IMACH(13) / 127 / DATA IMACH(14) / 53 / DATA IMACH(15) / -1021 / DATA IMACH(16) / 1023 / C C***FIRST EXECUTABLE STATEMENT I1MACH IF (I .LT. 1 .OR. I .GT. 16) GO TO 10 C I1MACH = IMACH(I) RETURN C 10 CONTINUE WRITE (UNIT = OUTPUT, FMT = 9000) 9000 FORMAT ('1ERROR 1 IN I1MACH - I OUT OF BOUNDS') C C CALL FDUMP C C STOP END openspecfun-0.3/amos/xerror.f000066400000000000000000000010461232445310600163310ustar00rootroot00000000000000 SUBROUTINE XERROR(MESS,NMESS,L1,L2) C C THIS IS A DUMMY XERROR ROUTINE TO PRINT ERROR MESSAGES WITH NMESS C CHARACTERS. L1 AND L2 ARE DUMMY PARAMETERS TO MAKE THIS CALL C COMPATIBLE WITH THE SLATEC XERROR ROUTINE. THIS IS A FORTRAN 77 C ROUTINE. C CHARACTER*(*) MESS NN=NMESS/70 NR=NMESS-70*NN IF(NR.NE.0) NN=NN+1 K=1 PRINT 900 900 FORMAT(/) DO 10 I=1,NN KMIN=MIN0(K+69,NMESS) PRINT *, MESS(K:KMIN) K=K+70 10 CONTINUE PRINT 900 RETURN END openspecfun-0.3/amos/zabs.f000066400000000000000000000015421232445310600157500ustar00rootroot00000000000000 DOUBLE PRECISION FUNCTION ZABS(ZR, ZI) C***BEGIN PROLOGUE ZABS C***REFER TO ZBESH,ZBESI,ZBESJ,ZBESK,ZBESY,ZAIRY,ZBIRY C C ZABS COMPUTES THE ABSOLUTE VALUE OR MAGNITUDE OF A DOUBLE C PRECISION COMPLEX VARIABLE CMPLX(ZR,ZI) C C***ROUTINES CALLED (NONE) C***END PROLOGUE ZABS DOUBLE PRECISION ZR, ZI, U, V, Q, S U = DABS(ZR) V = DABS(ZI) S = U + V C----------------------------------------------------------------------- C S*1.0D0 MAKES AN UNNORMALIZED UNDERFLOW ON CDC MACHINES INTO A C TRUE FLOATING ZERO C----------------------------------------------------------------------- S = S*1.0D+0 IF (S.EQ.0.0D+0) GO TO 20 IF (U.GT.V) GO TO 10 Q = U/V ZABS = V*DSQRT(1.D+0+Q*Q) RETURN 10 Q = V/U ZABS = U*DSQRT(1.D+0+Q*Q) RETURN 20 ZABS = 0.0D+0 RETURN END openspecfun-0.3/amos/zacai.f000066400000000000000000000071701232445310600161030ustar00rootroot00000000000000 SUBROUTINE ZACAI(ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, RL, TOL, * ELIM, ALIM) C***BEGIN PROLOGUE ZACAI C***REFER TO ZAIRY C C ZACAI APPLIES THE ANALYTIC CONTINUATION FORMULA C C K(FNU,ZN*EXP(MP))=K(FNU,ZN)*EXP(-MP*FNU) - MP*I(FNU,ZN) C MP=PI*MR*CMPLX(0.0,1.0) C C TO CONTINUE THE K FUNCTION FROM THE RIGHT HALF TO THE LEFT C HALF Z PLANE FOR USE WITH ZAIRY WHERE FNU=1/3 OR 2/3 AND N=1. C ZACAI IS THE SAME AS ZACON WITH THE PARTS FOR LARGER ORDERS AND C RECURRENCE REMOVED. A RECURSIVE CALL TO ZACON CAN RESULT IF ZACON C IS CALLED FROM ZAIRY. C C***ROUTINES CALLED ZASYI,ZBKNU,ZMLRI,ZSERI,ZS1S2,D1MACH,ZABS C***END PROLOGUE ZACAI C COMPLEX CSGN,CSPN,C1,C2,Y,Z,ZN,CY DOUBLE PRECISION ALIM, ARG, ASCLE, AZ, CSGNR, CSGNI, CSPNR, * CSPNI, C1R, C1I, C2R, C2I, CYR, CYI, DFNU, ELIM, FMR, FNU, PI, * RL, SGN, TOL, YY, YR, YI, ZR, ZI, ZNR, ZNI, D1MACH, ZABS INTEGER INU, IUF, KODE, MR, N, NN, NW, NZ DIMENSION YR(N), YI(N), CYR(2), CYI(2) DATA PI / 3.14159265358979324D0 / NZ = 0 ZNR = -ZR ZNI = -ZI AZ = ZABS(COMPLEX(ZR,ZI)) NN = N DFNU = FNU + DBLE(FLOAT(N-1)) IF (AZ.LE.2.0D0) GO TO 10 IF (AZ*AZ*0.25D0.GT.DFNU+1.0D0) GO TO 20 10 CONTINUE C----------------------------------------------------------------------- C POWER SERIES FOR THE I FUNCTION C----------------------------------------------------------------------- CALL ZSERI(ZNR, ZNI, FNU, KODE, NN, YR, YI, NW, TOL, ELIM, ALIM) GO TO 40 20 CONTINUE IF (AZ.LT.RL) GO TO 30 C----------------------------------------------------------------------- C ASYMPTOTIC EXPANSION FOR LARGE Z FOR THE I FUNCTION C----------------------------------------------------------------------- CALL ZASYI(ZNR, ZNI, FNU, KODE, NN, YR, YI, NW, RL, TOL, ELIM, * ALIM) IF (NW.LT.0) GO TO 80 GO TO 40 30 CONTINUE C----------------------------------------------------------------------- C MILLER ALGORITHM NORMALIZED BY THE SERIES FOR THE I FUNCTION C----------------------------------------------------------------------- CALL ZMLRI(ZNR, ZNI, FNU, KODE, NN, YR, YI, NW, TOL) IF(NW.LT.0) GO TO 80 40 CONTINUE C----------------------------------------------------------------------- C ANALYTIC CONTINUATION TO THE LEFT HALF PLANE FOR THE K FUNCTION C----------------------------------------------------------------------- CALL ZBKNU(ZNR, ZNI, FNU, KODE, 1, CYR, CYI, NW, TOL, ELIM, ALIM) IF (NW.NE.0) GO TO 80 FMR = DBLE(FLOAT(MR)) SGN = -DSIGN(PI,FMR) CSGNR = 0.0D0 CSGNI = SGN IF (KODE.EQ.1) GO TO 50 YY = -ZNI CSGNR = -CSGNI*DSIN(YY) CSGNI = CSGNI*DCOS(YY) 50 CONTINUE C----------------------------------------------------------------------- C CALCULATE CSPN=EXP(FNU*PI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE C WHEN FNU IS LARGE C----------------------------------------------------------------------- INU = INT(SNGL(FNU)) ARG = (FNU-DBLE(FLOAT(INU)))*SGN CSPNR = DCOS(ARG) CSPNI = DSIN(ARG) IF (MOD(INU,2).EQ.0) GO TO 60 CSPNR = -CSPNR CSPNI = -CSPNI 60 CONTINUE C1R = CYR(1) C1I = CYI(1) C2R = YR(1) C2I = YI(1) IF (KODE.EQ.1) GO TO 70 IUF = 0 ASCLE = 1.0D+3*D1MACH(1)/TOL CALL ZS1S2(ZNR, ZNI, C1R, C1I, C2R, C2I, NW, ASCLE, ALIM, IUF) NZ = NZ + NW 70 CONTINUE YR(1) = CSPNR*C1R - CSPNI*C1I + CSGNR*C2R - CSGNI*C2I YI(1) = CSPNR*C1I + CSPNI*C1R + CSGNR*C2I + CSGNI*C2R RETURN 80 CONTINUE NZ = -1 IF(NW.EQ.(-2)) NZ=-2 RETURN END openspecfun-0.3/amos/zacon.f000066400000000000000000000135541232445310600161310ustar00rootroot00000000000000 SUBROUTINE ZACON(ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, RL, FNUL, * TOL, ELIM, ALIM) C***BEGIN PROLOGUE ZACON C***REFER TO ZBESK,ZBESH C C ZACON APPLIES THE ANALYTIC CONTINUATION FORMULA C C K(FNU,ZN*EXP(MP))=K(FNU,ZN)*EXP(-MP*FNU) - MP*I(FNU,ZN) C MP=PI*MR*CMPLX(0.0,1.0) C C TO CONTINUE THE K FUNCTION FROM THE RIGHT HALF TO THE LEFT C HALF Z PLANE C C***ROUTINES CALLED ZBINU,ZBKNU,ZS1S2,D1MACH,ZABS,ZMLT C***END PROLOGUE ZACON C COMPLEX CK,CONE,CSCL,CSCR,CSGN,CSPN,CY,CZERO,C1,C2,RZ,SC1,SC2,ST, C *S1,S2,Y,Z,ZN DOUBLE PRECISION ALIM, ARG, ASCLE, AS2, AZN, BRY, BSCLE, CKI, * CKR, CONER, CPN, CSCL, CSCR, CSGNI, CSGNR, CSPNI, CSPNR, * CSR, CSRR, CSSR, CYI, CYR, C1I, C1M, C1R, C2I, C2R, ELIM, FMR, * FN, FNU, FNUL, PI, PTI, PTR, RAZN, RL, RZI, RZR, SC1I, SC1R, * SC2I, SC2R, SGN, SPN, STI, STR, S1I, S1R, S2I, S2R, TOL, YI, YR, * YY, ZEROR, ZI, ZNI, ZNR, ZR, D1MACH, ZABS INTEGER I, INU, IUF, KFLAG, KODE, MR, N, NN, NW, NZ DIMENSION YR(N), YI(N), CYR(2), CYI(2), CSSR(3), CSRR(3), BRY(3) DATA PI / 3.14159265358979324D0 / DATA ZEROR,CONER / 0.0D0,1.0D0 / NZ = 0 ZNR = -ZR ZNI = -ZI NN = N CALL ZBINU(ZNR, ZNI, FNU, KODE, NN, YR, YI, NW, RL, FNUL, TOL, * ELIM, ALIM) IF (NW.LT.0) GO TO 90 C----------------------------------------------------------------------- C ANALYTIC CONTINUATION TO THE LEFT HALF PLANE FOR THE K FUNCTION C----------------------------------------------------------------------- NN = MIN0(2,N) CALL ZBKNU(ZNR, ZNI, FNU, KODE, NN, CYR, CYI, NW, TOL, ELIM, ALIM) IF (NW.NE.0) GO TO 90 S1R = CYR(1) S1I = CYI(1) FMR = DBLE(FLOAT(MR)) SGN = -DSIGN(PI,FMR) CSGNR = ZEROR CSGNI = SGN IF (KODE.EQ.1) GO TO 10 YY = -ZNI CPN = DCOS(YY) SPN = DSIN(YY) CALL ZMLT(CSGNR, CSGNI, CPN, SPN, CSGNR, CSGNI) 10 CONTINUE C----------------------------------------------------------------------- C CALCULATE CSPN=EXP(FNU*PI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE C WHEN FNU IS LARGE C----------------------------------------------------------------------- INU = INT(SNGL(FNU)) ARG = (FNU-DBLE(FLOAT(INU)))*SGN CPN = DCOS(ARG) SPN = DSIN(ARG) CSPNR = CPN CSPNI = SPN IF (MOD(INU,2).EQ.0) GO TO 20 CSPNR = -CSPNR CSPNI = -CSPNI 20 CONTINUE IUF = 0 C1R = S1R C1I = S1I C2R = YR(1) C2I = YI(1) ASCLE = 1.0D+3*D1MACH(1)/TOL IF (KODE.EQ.1) GO TO 30 CALL ZS1S2(ZNR, ZNI, C1R, C1I, C2R, C2I, NW, ASCLE, ALIM, IUF) NZ = NZ + NW SC1R = C1R SC1I = C1I 30 CONTINUE CALL ZMLT(CSPNR, CSPNI, C1R, C1I, STR, STI) CALL ZMLT(CSGNR, CSGNI, C2R, C2I, PTR, PTI) YR(1) = STR + PTR YI(1) = STI + PTI IF (N.EQ.1) RETURN CSPNR = -CSPNR CSPNI = -CSPNI S2R = CYR(2) S2I = CYI(2) C1R = S2R C1I = S2I C2R = YR(2) C2I = YI(2) IF (KODE.EQ.1) GO TO 40 CALL ZS1S2(ZNR, ZNI, C1R, C1I, C2R, C2I, NW, ASCLE, ALIM, IUF) NZ = NZ + NW SC2R = C1R SC2I = C1I 40 CONTINUE CALL ZMLT(CSPNR, CSPNI, C1R, C1I, STR, STI) CALL ZMLT(CSGNR, CSGNI, C2R, C2I, PTR, PTI) YR(2) = STR + PTR YI(2) = STI + PTI IF (N.EQ.2) RETURN CSPNR = -CSPNR CSPNI = -CSPNI AZN = ZABS(COMPLEX(ZNR,ZNI)) RAZN = 1.0D0/AZN STR = ZNR*RAZN STI = -ZNI*RAZN RZR = (STR+STR)*RAZN RZI = (STI+STI)*RAZN FN = FNU + 1.0D0 CKR = FN*RZR CKI = FN*RZI C----------------------------------------------------------------------- C SCALE NEAR EXPONENT EXTREMES DURING RECURRENCE ON K FUNCTIONS C----------------------------------------------------------------------- CSCL = 1.0D0/TOL CSCR = TOL CSSR(1) = CSCL CSSR(2) = CONER CSSR(3) = CSCR CSRR(1) = CSCR CSRR(2) = CONER CSRR(3) = CSCL BRY(1) = ASCLE BRY(2) = 1.0D0/ASCLE BRY(3) = D1MACH(2) AS2 = ZABS(COMPLEX(S2R,S2I)) KFLAG = 2 IF (AS2.GT.BRY(1)) GO TO 50 KFLAG = 1 GO TO 60 50 CONTINUE IF (AS2.LT.BRY(2)) GO TO 60 KFLAG = 3 60 CONTINUE BSCLE = BRY(KFLAG) S1R = S1R*CSSR(KFLAG) S1I = S1I*CSSR(KFLAG) S2R = S2R*CSSR(KFLAG) S2I = S2I*CSSR(KFLAG) CSR = CSRR(KFLAG) DO 80 I=3,N STR = S2R STI = S2I S2R = CKR*STR - CKI*STI + S1R S2I = CKR*STI + CKI*STR + S1I S1R = STR S1I = STI C1R = S2R*CSR C1I = S2I*CSR STR = C1R STI = C1I C2R = YR(I) C2I = YI(I) IF (KODE.EQ.1) GO TO 70 IF (IUF.LT.0) GO TO 70 CALL ZS1S2(ZNR, ZNI, C1R, C1I, C2R, C2I, NW, ASCLE, ALIM, IUF) NZ = NZ + NW SC1R = SC2R SC1I = SC2I SC2R = C1R SC2I = C1I IF (IUF.NE.3) GO TO 70 IUF = -4 S1R = SC1R*CSSR(KFLAG) S1I = SC1I*CSSR(KFLAG) S2R = SC2R*CSSR(KFLAG) S2I = SC2I*CSSR(KFLAG) STR = SC2R STI = SC2I 70 CONTINUE PTR = CSPNR*C1R - CSPNI*C1I PTI = CSPNR*C1I + CSPNI*C1R YR(I) = PTR + CSGNR*C2R - CSGNI*C2I YI(I) = PTI + CSGNR*C2I + CSGNI*C2R CKR = CKR + RZR CKI = CKI + RZI CSPNR = -CSPNR CSPNI = -CSPNI IF (KFLAG.GE.3) GO TO 80 PTR = DABS(C1R) PTI = DABS(C1I) C1M = DMAX1(PTR,PTI) IF (C1M.LE.BSCLE) GO TO 80 KFLAG = KFLAG + 1 BSCLE = BRY(KFLAG) S1R = S1R*CSR S1I = S1I*CSR S2R = STR S2I = STI S1R = S1R*CSSR(KFLAG) S1I = S1I*CSSR(KFLAG) S2R = S2R*CSSR(KFLAG) S2I = S2I*CSSR(KFLAG) CSR = CSRR(KFLAG) 80 CONTINUE RETURN 90 CONTINUE NZ = -1 IF(NW.EQ.(-2)) NZ=-2 RETURN END openspecfun-0.3/amos/zairy.f000066400000000000000000000350021232445310600161450ustar00rootroot00000000000000 SUBROUTINE ZAIRY(ZR, ZI, ID, KODE, AIR, AII, NZ, IERR) C***BEGIN PROLOGUE ZAIRY C***DATE WRITTEN 830501 (YYMMDD) C***REVISION DATE 890801 (YYMMDD) C***CATEGORY NO. B5K C***KEYWORDS AIRY FUNCTION,BESSEL FUNCTIONS OF ORDER ONE THIRD C***AUTHOR AMOS, DONALD E., SANDIA NATIONAL LABORATORIES C***PURPOSE TO COMPUTE AIRY FUNCTIONS AI(Z) AND DAI(Z) FOR COMPLEX Z C***DESCRIPTION C C ***A DOUBLE PRECISION ROUTINE*** C ON KODE=1, ZAIRY COMPUTES THE COMPLEX AIRY FUNCTION AI(Z) OR C ITS DERIVATIVE DAI(Z)/DZ ON ID=0 OR ID=1 RESPECTIVELY. ON C KODE=2, A SCALING OPTION CEXP(ZTA)*AI(Z) OR CEXP(ZTA)* C DAI(Z)/DZ IS PROVIDED TO REMOVE THE EXPONENTIAL DECAY IN C -PI/3.LT.ARG(Z).LT.PI/3 AND THE EXPONENTIAL GROWTH IN C PI/3.LT.ABS(ARG(Z)).LT.PI WHERE ZTA=(2/3)*Z*CSQRT(Z). C C WHILE THE AIRY FUNCTIONS AI(Z) AND DAI(Z)/DZ ARE ANALYTIC IN C THE WHOLE Z PLANE, THE CORRESPONDING SCALED FUNCTIONS DEFINED C FOR KODE=2 HAVE A CUT ALONG THE NEGATIVE REAL AXIS. C DEFINTIONS AND NOTATION ARE FOUND IN THE NBS HANDBOOK OF C MATHEMATICAL FUNCTIONS (REF. 1). C C INPUT ZR,ZI ARE DOUBLE PRECISION C ZR,ZI - Z=CMPLX(ZR,ZI) C ID - ORDER OF DERIVATIVE, ID=0 OR ID=1 C KODE - A PARAMETER TO INDICATE THE SCALING OPTION C KODE= 1 RETURNS C AI=AI(Z) ON ID=0 OR C AI=DAI(Z)/DZ ON ID=1 C = 2 RETURNS C AI=CEXP(ZTA)*AI(Z) ON ID=0 OR C AI=CEXP(ZTA)*DAI(Z)/DZ ON ID=1 WHERE C ZTA=(2/3)*Z*CSQRT(Z) C C OUTPUT AIR,AII ARE DOUBLE PRECISION C AIR,AII- COMPLEX ANSWER DEPENDING ON THE CHOICES FOR ID AND C KODE C NZ - UNDERFLOW INDICATOR C NZ= 0 , NORMAL RETURN C NZ= 1 , AI=CMPLX(0.0D0,0.0D0) DUE TO UNDERFLOW IN C -PI/3.LT.ARG(Z).LT.PI/3 ON KODE=1 C IERR - ERROR FLAG C IERR=0, NORMAL RETURN - COMPUTATION COMPLETED C IERR=1, INPUT ERROR - NO COMPUTATION C IERR=2, OVERFLOW - NO COMPUTATION, REAL(ZTA) C TOO LARGE ON KODE=1 C IERR=3, CABS(Z) LARGE - COMPUTATION COMPLETED C LOSSES OF SIGNIFCANCE BY ARGUMENT REDUCTION C PRODUCE LESS THAN HALF OF MACHINE ACCURACY C IERR=4, CABS(Z) TOO LARGE - NO COMPUTATION C COMPLETE LOSS OF ACCURACY BY ARGUMENT C REDUCTION C IERR=5, ERROR - NO COMPUTATION, C ALGORITHM TERMINATION CONDITION NOT MET C C***LONG DESCRIPTION C C AI AND DAI ARE COMPUTED FOR CABS(Z).GT.1.0 FROM THE K BESSEL C FUNCTIONS BY C C AI(Z)=C*SQRT(Z)*K(1/3,ZTA) , DAI(Z)=-C*Z*K(2/3,ZTA) C C=1.0/(PI*SQRT(3.0)) C ZTA=(2/3)*Z**(3/2) C C WITH THE POWER SERIES FOR CABS(Z).LE.1.0. C C IN MOST COMPLEX VARIABLE COMPUTATION, ONE MUST EVALUATE ELE- C MENTARY FUNCTIONS. WHEN THE MAGNITUDE OF Z IS LARGE, LOSSES C OF SIGNIFICANCE BY ARGUMENT REDUCTION OCCUR. CONSEQUENTLY, IF C THE MAGNITUDE OF ZETA=(2/3)*Z**1.5 EXCEEDS U1=SQRT(0.5/UR), C THEN LOSSES EXCEEDING HALF PRECISION ARE LIKELY AND AN ERROR C FLAG IERR=3 IS TRIGGERED WHERE UR=DMAX1(D1MACH(4),1.0D-18) IS C DOUBLE PRECISION UNIT ROUNDOFF LIMITED TO 18 DIGITS PRECISION. C ALSO, IF THE MAGNITUDE OF ZETA IS LARGER THAN U2=0.5/UR, THEN C ALL SIGNIFICANCE IS LOST AND IERR=4. IN ORDER TO USE THE INT C FUNCTION, ZETA MUST BE FURTHER RESTRICTED NOT TO EXCEED THE C LARGEST INTEGER, U3=I1MACH(9). THUS, THE MAGNITUDE OF ZETA C MUST BE RESTRICTED BY MIN(U2,U3). ON 32 BIT MACHINES, U1,U2, C AND U3 ARE APPROXIMATELY 2.0E+3, 4.2E+6, 2.1E+9 IN SINGLE C PRECISION ARITHMETIC AND 1.3E+8, 1.8E+16, 2.1E+9 IN DOUBLE C PRECISION ARITHMETIC RESPECTIVELY. THIS MAKES U2 AND U3 LIMIT- C ING IN THEIR RESPECTIVE ARITHMETICS. THIS MEANS THAT THE MAG- C NITUDE OF Z CANNOT EXCEED 3.1E+4 IN SINGLE AND 2.1E+6 IN C DOUBLE PRECISION ARITHMETIC. THIS ALSO MEANS THAT ONE CAN C EXPECT TO RETAIN, IN THE WORST CASES ON 32 BIT MACHINES, C NO DIGITS IN SINGLE PRECISION AND ONLY 7 DIGITS IN DOUBLE C PRECISION ARITHMETIC. SIMILAR CONSIDERATIONS HOLD FOR OTHER C MACHINES. C C THE APPROXIMATE RELATIVE ERROR IN THE MAGNITUDE OF A COMPLEX C BESSEL FUNCTION CAN BE EXPRESSED BY P*10**S WHERE P=MAX(UNIT C ROUNDOFF,1.0E-18) IS THE NOMINAL PRECISION AND 10**S REPRE- C SENTS THE INCREASE IN ERROR DUE TO ARGUMENT REDUCTION IN THE C ELEMENTARY FUNCTIONS. HERE, S=MAX(1,ABS(LOG10(CABS(Z))), C ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF C CABS(Z),ABS(EXPONENT OF FNU)) ). HOWEVER, THE PHASE ANGLE MAY C HAVE ONLY ABSOLUTE ACCURACY. THIS IS MOST LIKELY TO OCCUR WHEN C ONE COMPONENT (IN ABSOLUTE VALUE) IS LARGER THAN THE OTHER BY C SEVERAL ORDERS OF MAGNITUDE. IF ONE COMPONENT IS 10**K LARGER C THAN THE OTHER, THEN ONE CAN EXPECT ONLY MAX(ABS(LOG10(P))-K, C 0) SIGNIFICANT DIGITS; OR, STATED ANOTHER WAY, WHEN K EXCEEDS C THE EXPONENT OF P, NO SIGNIFICANT DIGITS REMAIN IN THE SMALLER C COMPONENT. HOWEVER, THE PHASE ANGLE RETAINS ABSOLUTE ACCURACY C BECAUSE, IN COMPLEX ARITHMETIC WITH PRECISION P, THE SMALLER C COMPONENT WILL NOT (AS A RULE) DECREASE BELOW P TIMES THE C MAGNITUDE OF THE LARGER COMPONENT. IN THESE EXTREME CASES, C THE PRINCIPAL PHASE ANGLE IS ON THE ORDER OF +P, -P, PI/2-P, C OR -PI/2+P. C C***REFERENCES HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ C AND I. A. STEGUN, NBS AMS SERIES 55, U.S. DEPT. OF C COMMERCE, 1955. C C COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT C AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983 C C A SUBROUTINE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85- C 1018, MAY, 1985 C C A PORTABLE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, TRANS. C MATH. SOFTWARE, 1986 C C***ROUTINES CALLED ZACAI,ZBKNU,ZEXP,ZSQRT,I1MACH,D1MACH C***END PROLOGUE ZAIRY C COMPLEX AI,CONE,CSQ,CY,S1,S2,TRM1,TRM2,Z,ZTA,Z3 DOUBLE PRECISION AA, AD, AII, AIR, AK, ALIM, ATRM, AZ, AZ3, BK, * CC, CK, COEF, CONEI, CONER, CSQI, CSQR, CYI, CYR, C1, C2, DIG, * DK, D1, D2, ELIM, FID, FNU, PTR, RL, R1M5, SFAC, STI, STR, * S1I, S1R, S2I, S2R, TOL, TRM1I, TRM1R, TRM2I, TRM2R, TTH, ZEROI, * ZEROR, ZI, ZR, ZTAI, ZTAR, Z3I, Z3R, D1MACH, ZABS, ALAZ, BB INTEGER ID, IERR, IFLAG, K, KODE, K1, K2, MR, NN, NZ, I1MACH DIMENSION CYR(1), CYI(1) DATA TTH, C1, C2, COEF /6.66666666666666667D-01, * 3.55028053887817240D-01,2.58819403792806799D-01, * 1.83776298473930683D-01/ DATA ZEROR, ZEROI, CONER, CONEI /0.0D0,0.0D0,1.0D0,0.0D0/ C***FIRST EXECUTABLE STATEMENT ZAIRY IERR = 0 NZ=0 IF (ID.LT.0 .OR. ID.GT.1) IERR=1 IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1 IF (IERR.NE.0) RETURN AZ = ZABS(COMPLEX(ZR,ZI)) TOL = DMAX1(D1MACH(4),1.0D-18) FID = DBLE(FLOAT(ID)) IF (AZ.GT.1.0D0) GO TO 70 C----------------------------------------------------------------------- C POWER SERIES FOR CABS(Z).LE.1. C----------------------------------------------------------------------- S1R = CONER S1I = CONEI S2R = CONER S2I = CONEI IF (AZ.LT.TOL) GO TO 170 AA = AZ*AZ IF (AA.LT.TOL/AZ) GO TO 40 TRM1R = CONER TRM1I = CONEI TRM2R = CONER TRM2I = CONEI ATRM = 1.0D0 STR = ZR*ZR - ZI*ZI STI = ZR*ZI + ZI*ZR Z3R = STR*ZR - STI*ZI Z3I = STR*ZI + STI*ZR AZ3 = AZ*AA AK = 2.0D0 + FID BK = 3.0D0 - FID - FID CK = 4.0D0 - FID DK = 3.0D0 + FID + FID D1 = AK*DK D2 = BK*CK AD = DMIN1(D1,D2) AK = 24.0D0 + 9.0D0*FID BK = 30.0D0 - 9.0D0*FID DO 30 K=1,25 STR = (TRM1R*Z3R-TRM1I*Z3I)/D1 TRM1I = (TRM1R*Z3I+TRM1I*Z3R)/D1 TRM1R = STR S1R = S1R + TRM1R S1I = S1I + TRM1I STR = (TRM2R*Z3R-TRM2I*Z3I)/D2 TRM2I = (TRM2R*Z3I+TRM2I*Z3R)/D2 TRM2R = STR S2R = S2R + TRM2R S2I = S2I + TRM2I ATRM = ATRM*AZ3/AD D1 = D1 + AK D2 = D2 + BK AD = DMIN1(D1,D2) IF (ATRM.LT.TOL*AD) GO TO 40 AK = AK + 18.0D0 BK = BK + 18.0D0 30 CONTINUE 40 CONTINUE IF (ID.EQ.1) GO TO 50 AIR = S1R*C1 - C2*(ZR*S2R-ZI*S2I) AII = S1I*C1 - C2*(ZR*S2I+ZI*S2R) IF (KODE.EQ.1) RETURN CALL ZSQRT(ZR, ZI, STR, STI) ZTAR = TTH*(ZR*STR-ZI*STI) ZTAI = TTH*(ZR*STI+ZI*STR) CALL ZEXP(ZTAR, ZTAI, STR, STI) PTR = AIR*STR - AII*STI AII = AIR*STI + AII*STR AIR = PTR RETURN 50 CONTINUE AIR = -S2R*C2 AII = -S2I*C2 IF (AZ.LE.TOL) GO TO 60 STR = ZR*S1R - ZI*S1I STI = ZR*S1I + ZI*S1R CC = C1/(1.0D0+FID) AIR = AIR + CC*(STR*ZR-STI*ZI) AII = AII + CC*(STR*ZI+STI*ZR) 60 CONTINUE IF (KODE.EQ.1) RETURN CALL ZSQRT(ZR, ZI, STR, STI) ZTAR = TTH*(ZR*STR-ZI*STI) ZTAI = TTH*(ZR*STI+ZI*STR) CALL ZEXP(ZTAR, ZTAI, STR, STI) PTR = STR*AIR - STI*AII AII = STR*AII + STI*AIR AIR = PTR RETURN C----------------------------------------------------------------------- C CASE FOR CABS(Z).GT.1.0 C----------------------------------------------------------------------- 70 CONTINUE FNU = (1.0D0+FID)/3.0D0 C----------------------------------------------------------------------- C SET PARAMETERS RELATED TO MACHINE CONSTANTS. C TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0D-18. C ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT. C EXP(-ELIM).LT.EXP(-ALIM)=EXP(-ELIM)/TOL AND C EXP(ELIM).GT.EXP(ALIM)=EXP(ELIM)*TOL ARE INTERVALS NEAR C UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE. C RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z. C DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG). C----------------------------------------------------------------------- K1 = I1MACH(15) K2 = I1MACH(16) R1M5 = D1MACH(5) K = MIN0(IABS(K1),IABS(K2)) ELIM = 2.303D0*(DBLE(FLOAT(K))*R1M5-3.0D0) K1 = I1MACH(14) - 1 AA = R1M5*DBLE(FLOAT(K1)) DIG = DMIN1(AA,18.0D0) AA = AA*2.303D0 ALIM = ELIM + DMAX1(-AA,-41.45D0) RL = 1.2D0*DIG + 3.0D0 ALAZ = DLOG(AZ) C-------------------------------------------------------------------------- C TEST FOR PROPER RANGE C----------------------------------------------------------------------- AA=0.5D0/TOL BB=DBLE(FLOAT(I1MACH(9)))*0.5D0 AA=DMIN1(AA,BB) AA=AA**TTH IF (AZ.GT.AA) GO TO 260 AA=DSQRT(AA) IF (AZ.GT.AA) IERR=3 CALL ZSQRT(ZR, ZI, CSQR, CSQI) ZTAR = TTH*(ZR*CSQR-ZI*CSQI) ZTAI = TTH*(ZR*CSQI+ZI*CSQR) C----------------------------------------------------------------------- C RE(ZTA).LE.0 WHEN RE(Z).LT.0, ESPECIALLY WHEN IM(Z) IS SMALL C----------------------------------------------------------------------- IFLAG = 0 SFAC = 1.0D0 AK = ZTAI IF (ZR.GE.0.0D0) GO TO 80 BK = ZTAR CK = -DABS(BK) ZTAR = CK ZTAI = AK 80 CONTINUE IF (ZI.NE.0.0D0) GO TO 90 IF (ZR.GT.0.0D0) GO TO 90 ZTAR = 0.0D0 ZTAI = AK 90 CONTINUE AA = ZTAR IF (AA.GE.0.0D0 .AND. ZR.GT.0.0D0) GO TO 110 IF (KODE.EQ.2) GO TO 100 C----------------------------------------------------------------------- C OVERFLOW TEST C----------------------------------------------------------------------- IF (AA.GT.(-ALIM)) GO TO 100 AA = -AA + 0.25D0*ALAZ IFLAG = 1 SFAC = TOL IF (AA.GT.ELIM) GO TO 270 100 CONTINUE C----------------------------------------------------------------------- C CBKNU AND CACON RETURN EXP(ZTA)*K(FNU,ZTA) ON KODE=2 C----------------------------------------------------------------------- MR = 1 IF (ZI.LT.0.0D0) MR = -1 CALL ZACAI(ZTAR, ZTAI, FNU, KODE, MR, 1, CYR, CYI, NN, RL, TOL, * ELIM, ALIM) IF (NN.LT.0) GO TO 280 NZ = NZ + NN GO TO 130 110 CONTINUE IF (KODE.EQ.2) GO TO 120 C----------------------------------------------------------------------- C UNDERFLOW TEST C----------------------------------------------------------------------- IF (AA.LT.ALIM) GO TO 120 AA = -AA - 0.25D0*ALAZ IFLAG = 2 SFAC = 1.0D0/TOL IF (AA.LT.(-ELIM)) GO TO 210 120 CONTINUE CALL ZBKNU(ZTAR, ZTAI, FNU, KODE, 1, CYR, CYI, NZ, TOL, ELIM, * ALIM) 130 CONTINUE S1R = CYR(1)*COEF S1I = CYI(1)*COEF IF (IFLAG.NE.0) GO TO 150 IF (ID.EQ.1) GO TO 140 AIR = CSQR*S1R - CSQI*S1I AII = CSQR*S1I + CSQI*S1R RETURN 140 CONTINUE AIR = -(ZR*S1R-ZI*S1I) AII = -(ZR*S1I+ZI*S1R) RETURN 150 CONTINUE S1R = S1R*SFAC S1I = S1I*SFAC IF (ID.EQ.1) GO TO 160 STR = S1R*CSQR - S1I*CSQI S1I = S1R*CSQI + S1I*CSQR S1R = STR AIR = S1R/SFAC AII = S1I/SFAC RETURN 160 CONTINUE STR = -(S1R*ZR-S1I*ZI) S1I = -(S1R*ZI+S1I*ZR) S1R = STR AIR = S1R/SFAC AII = S1I/SFAC RETURN 170 CONTINUE AA = 1.0D+3*D1MACH(1) S1R = ZEROR S1I = ZEROI IF (ID.EQ.1) GO TO 190 IF (AZ.LE.AA) GO TO 180 S1R = C2*ZR S1I = C2*ZI 180 CONTINUE AIR = C1 - S1R AII = -S1I RETURN 190 CONTINUE AIR = -C2 AII = 0.0D0 AA = DSQRT(AA) IF (AZ.LE.AA) GO TO 200 S1R = 0.5D0*(ZR*ZR-ZI*ZI) S1I = ZR*ZI 200 CONTINUE AIR = AIR + C1*S1R AII = AII + C1*S1I RETURN 210 CONTINUE NZ = 1 AIR = ZEROR AII = ZEROI RETURN 270 CONTINUE NZ = 0 IERR=2 RETURN 280 CONTINUE IF(NN.EQ.(-1)) GO TO 270 NZ=0 IERR=5 RETURN 260 CONTINUE IERR=4 NZ=0 RETURN END openspecfun-0.3/amos/zasyi.f000066400000000000000000000116631232445310600161550ustar00rootroot00000000000000 SUBROUTINE ZASYI(ZR, ZI, FNU, KODE, N, YR, YI, NZ, RL, TOL, ELIM, * ALIM) C***BEGIN PROLOGUE ZASYI C***REFER TO ZBESI,ZBESK C C ZASYI COMPUTES THE I BESSEL FUNCTION FOR REAL(Z).GE.0.0 BY C MEANS OF THE ASYMPTOTIC EXPANSION FOR LARGE CABS(Z) IN THE C REGION CABS(Z).GT.MAX(RL,FNU*FNU/2). NZ=0 IS A NORMAL RETURN. C NZ.LT.0 INDICATES AN OVERFLOW ON KODE=1. C C***ROUTINES CALLED D1MACH,ZABS,ZDIV,ZEXP,ZMLT,ZSQRT C***END PROLOGUE ZASYI C COMPLEX AK1,CK,CONE,CS1,CS2,CZ,CZERO,DK,EZ,P1,RZ,S2,Y,Z DOUBLE PRECISION AA, AEZ, AK, AK1I, AK1R, ALIM, ARG, ARM, ATOL, * AZ, BB, BK, CKI, CKR, CONEI, CONER, CS1I, CS1R, CS2I, CS2R, CZI, * CZR, DFNU, DKI, DKR, DNU2, ELIM, EZI, EZR, FDN, FNU, PI, P1I, * P1R, RAZ, RL, RTPI, RTR1, RZI, RZR, S, SGN, SQK, STI, STR, S2I, * S2R, TOL, TZI, TZR, YI, YR, ZEROI, ZEROR, ZI, ZR, D1MACH, ZABS INTEGER I, IB, IL, INU, J, JL, K, KODE, KODED, M, N, NN, NZ DIMENSION YR(N), YI(N) DATA PI, RTPI /3.14159265358979324D0 , 0.159154943091895336D0 / DATA ZEROR,ZEROI,CONER,CONEI / 0.0D0, 0.0D0, 1.0D0, 0.0D0 / C NZ = 0 AZ = ZABS(COMPLEX(ZR,ZI)) ARM = 1.0D+3*D1MACH(1) RTR1 = DSQRT(ARM) IL = MIN0(2,N) DFNU = FNU + DBLE(FLOAT(N-IL)) C----------------------------------------------------------------------- C OVERFLOW TEST C----------------------------------------------------------------------- RAZ = 1.0D0/AZ STR = ZR*RAZ STI = -ZI*RAZ AK1R = RTPI*STR*RAZ AK1I = RTPI*STI*RAZ CALL ZSQRT(AK1R, AK1I, AK1R, AK1I) CZR = ZR CZI = ZI IF (KODE.NE.2) GO TO 10 CZR = ZEROR CZI = ZI 10 CONTINUE IF (DABS(CZR).GT.ELIM) GO TO 100 DNU2 = DFNU + DFNU KODED = 1 IF ((DABS(CZR).GT.ALIM) .AND. (N.GT.2)) GO TO 20 KODED = 0 CALL ZEXP(CZR, CZI, STR, STI) CALL ZMLT(AK1R, AK1I, STR, STI, AK1R, AK1I) 20 CONTINUE FDN = 0.0D0 IF (DNU2.GT.RTR1) FDN = DNU2*DNU2 EZR = ZR*8.0D0 EZI = ZI*8.0D0 C----------------------------------------------------------------------- C WHEN Z IS IMAGINARY, THE ERROR TEST MUST BE MADE RELATIVE TO THE C FIRST RECIPROCAL POWER SINCE THIS IS THE LEADING TERM OF THE C EXPANSION FOR THE IMAGINARY PART. C----------------------------------------------------------------------- AEZ = 8.0D0*AZ S = TOL/AEZ JL = INT(SNGL(RL+RL)) + 2 P1R = ZEROR P1I = ZEROI IF (ZI.EQ.0.0D0) GO TO 30 C----------------------------------------------------------------------- C CALCULATE EXP(PI*(0.5+FNU+N-IL)*I) TO MINIMIZE LOSSES OF C SIGNIFICANCE WHEN FNU OR N IS LARGE C----------------------------------------------------------------------- INU = INT(SNGL(FNU)) ARG = (FNU-DBLE(FLOAT(INU)))*PI INU = INU + N - IL AK = -DSIN(ARG) BK = DCOS(ARG) IF (ZI.LT.0.0D0) BK = -BK P1R = AK P1I = BK IF (MOD(INU,2).EQ.0) GO TO 30 P1R = -P1R P1I = -P1I 30 CONTINUE DO 70 K=1,IL SQK = FDN - 1.0D0 ATOL = S*DABS(SQK) SGN = 1.0D0 CS1R = CONER CS1I = CONEI CS2R = CONER CS2I = CONEI CKR = CONER CKI = CONEI AK = 0.0D0 AA = 1.0D0 BB = AEZ DKR = EZR DKI = EZI DO 40 J=1,JL CALL ZDIV(CKR, CKI, DKR, DKI, STR, STI) CKR = STR*SQK CKI = STI*SQK CS2R = CS2R + CKR CS2I = CS2I + CKI SGN = -SGN CS1R = CS1R + CKR*SGN CS1I = CS1I + CKI*SGN DKR = DKR + EZR DKI = DKI + EZI AA = AA*DABS(SQK)/BB BB = BB + AEZ AK = AK + 8.0D0 SQK = SQK - AK IF (AA.LE.ATOL) GO TO 50 40 CONTINUE GO TO 110 50 CONTINUE S2R = CS1R S2I = CS1I IF (ZR+ZR.GE.ELIM) GO TO 60 TZR = ZR + ZR TZI = ZI + ZI CALL ZEXP(-TZR, -TZI, STR, STI) CALL ZMLT(STR, STI, P1R, P1I, STR, STI) CALL ZMLT(STR, STI, CS2R, CS2I, STR, STI) S2R = S2R + STR S2I = S2I + STI 60 CONTINUE FDN = FDN + 8.0D0*DFNU + 4.0D0 P1R = -P1R P1I = -P1I M = N - IL + K YR(M) = S2R*AK1R - S2I*AK1I YI(M) = S2R*AK1I + S2I*AK1R 70 CONTINUE IF (N.LE.2) RETURN NN = N K = NN - 2 AK = DBLE(FLOAT(K)) STR = ZR*RAZ STI = -ZI*RAZ RZR = (STR+STR)*RAZ RZI = (STI+STI)*RAZ IB = 3 DO 80 I=IB,NN YR(K) = (AK+FNU)*(RZR*YR(K+1)-RZI*YI(K+1)) + YR(K+2) YI(K) = (AK+FNU)*(RZR*YI(K+1)+RZI*YR(K+1)) + YI(K+2) AK = AK - 1.0D0 K = K - 1 80 CONTINUE IF (KODED.EQ.0) RETURN CALL ZEXP(CZR, CZI, CKR, CKI) DO 90 I=1,NN STR = YR(I)*CKR - YI(I)*CKI YI(I) = YR(I)*CKI + YI(I)*CKR YR(I) = STR 90 CONTINUE RETURN 100 CONTINUE NZ = -1 RETURN 110 CONTINUE NZ=-2 RETURN END openspecfun-0.3/amos/zbesh.f000066400000000000000000000345661232445310600161400ustar00rootroot00000000000000 SUBROUTINE ZBESH(ZR, ZI, FNU, KODE, M, N, CYR, CYI, NZ, IERR) C***BEGIN PROLOGUE ZBESH C***DATE WRITTEN 830501 (YYMMDD) C***REVISION DATE 890801 (YYMMDD) C***CATEGORY NO. B5K C***KEYWORDS H-BESSEL FUNCTIONS,BESSEL FUNCTIONS OF COMPLEX ARGUMENT, C BESSEL FUNCTIONS OF THIRD KIND,HANKEL FUNCTIONS C***AUTHOR AMOS, DONALD E., SANDIA NATIONAL LABORATORIES C***PURPOSE TO COMPUTE THE H-BESSEL FUNCTIONS OF A COMPLEX ARGUMENT C***DESCRIPTION C C ***A DOUBLE PRECISION ROUTINE*** C ON KODE=1, ZBESH COMPUTES AN N MEMBER SEQUENCE OF COMPLEX C HANKEL (BESSEL) FUNCTIONS CY(J)=H(M,FNU+J-1,Z) FOR KINDS M=1 C OR 2, REAL, NONNEGATIVE ORDERS FNU+J-1, J=1,...,N, AND COMPLEX C Z.NE.CMPLX(0.0,0.0) IN THE CUT PLANE -PI.LT.ARG(Z).LE.PI. C ON KODE=2, ZBESH RETURNS THE SCALED HANKEL FUNCTIONS C C CY(I)=EXP(-MM*Z*I)*H(M,FNU+J-1,Z) MM=3-2*M, I**2=-1. C C WHICH REMOVES THE EXPONENTIAL BEHAVIOR IN BOTH THE UPPER AND C LOWER HALF PLANES. DEFINITIONS AND NOTATION ARE FOUND IN THE C NBS HANDBOOK OF MATHEMATICAL FUNCTIONS (REF. 1). C C INPUT ZR,ZI,FNU ARE DOUBLE PRECISION C ZR,ZI - Z=CMPLX(ZR,ZI), Z.NE.CMPLX(0.0D0,0.0D0), C -PT.LT.ARG(Z).LE.PI C FNU - ORDER OF INITIAL H FUNCTION, FNU.GE.0.0D0 C KODE - A PARAMETER TO INDICATE THE SCALING OPTION C KODE= 1 RETURNS C CY(J)=H(M,FNU+J-1,Z), J=1,...,N C = 2 RETURNS C CY(J)=H(M,FNU+J-1,Z)*EXP(-I*Z*(3-2M)) C J=1,...,N , I**2=-1 C M - KIND OF HANKEL FUNCTION, M=1 OR 2 C N - NUMBER OF MEMBERS IN THE SEQUENCE, N.GE.1 C C OUTPUT CYR,CYI ARE DOUBLE PRECISION C CYR,CYI- DOUBLE PRECISION VECTORS WHOSE FIRST N COMPONENTS C CONTAIN REAL AND IMAGINARY PARTS FOR THE SEQUENCE C CY(J)=H(M,FNU+J-1,Z) OR C CY(J)=H(M,FNU+J-1,Z)*EXP(-I*Z*(3-2M)) J=1,...,N C DEPENDING ON KODE, I**2=-1. C NZ - NUMBER OF COMPONENTS SET TO ZERO DUE TO UNDERFLOW, C NZ= 0 , NORMAL RETURN C NZ.GT.0 , FIRST NZ COMPONENTS OF CY SET TO ZERO DUE C TO UNDERFLOW, CY(J)=CMPLX(0.0D0,0.0D0) C J=1,...,NZ WHEN Y.GT.0.0 AND M=1 OR C Y.LT.0.0 AND M=2. FOR THE COMPLMENTARY C HALF PLANES, NZ STATES ONLY THE NUMBER C OF UNDERFLOWS. C IERR - ERROR FLAG C IERR=0, NORMAL RETURN - COMPUTATION COMPLETED C IERR=1, INPUT ERROR - NO COMPUTATION C IERR=2, OVERFLOW - NO COMPUTATION, FNU TOO C LARGE OR CABS(Z) TOO SMALL OR BOTH C IERR=3, CABS(Z) OR FNU+N-1 LARGE - COMPUTATION DONE C BUT LOSSES OF SIGNIFCANCE BY ARGUMENT C REDUCTION PRODUCE LESS THAN HALF OF MACHINE C ACCURACY C IERR=4, CABS(Z) OR FNU+N-1 TOO LARGE - NO COMPUTA- C TION BECAUSE OF COMPLETE LOSSES OF SIGNIFI- C CANCE BY ARGUMENT REDUCTION C IERR=5, ERROR - NO COMPUTATION, C ALGORITHM TERMINATION CONDITION NOT MET C C***LONG DESCRIPTION C C THE COMPUTATION IS CARRIED OUT BY THE RELATION C C H(M,FNU,Z)=(1/MP)*EXP(-MP*FNU)*K(FNU,Z*EXP(-MP)) C MP=MM*HPI*I, MM=3-2*M, HPI=PI/2, I**2=-1 C C FOR M=1 OR 2 WHERE THE K BESSEL FUNCTION IS COMPUTED FOR THE C RIGHT HALF PLANE RE(Z).GE.0.0. THE K FUNCTION IS CONTINUED C TO THE LEFT HALF PLANE BY THE RELATION C C K(FNU,Z*EXP(MP)) = EXP(-MP*FNU)*K(FNU,Z)-MP*I(FNU,Z) C MP=MR*PI*I, MR=+1 OR -1, RE(Z).GT.0, I**2=-1 C C WHERE I(FNU,Z) IS THE I BESSEL FUNCTION. C C EXPONENTIAL DECAY OF H(M,FNU,Z) OCCURS IN THE UPPER HALF Z C PLANE FOR M=1 AND THE LOWER HALF Z PLANE FOR M=2. EXPONENTIAL C GROWTH OCCURS IN THE COMPLEMENTARY HALF PLANES. SCALING C BY EXP(-MM*Z*I) REMOVES THE EXPONENTIAL BEHAVIOR IN THE C WHOLE Z PLANE FOR Z TO INFINITY. C C FOR NEGATIVE ORDERS,THE FORMULAE C C H(1,-FNU,Z) = H(1,FNU,Z)*CEXP( PI*FNU*I) C H(2,-FNU,Z) = H(2,FNU,Z)*CEXP(-PI*FNU*I) C I**2=-1 C C CAN BE USED. C C IN MOST COMPLEX VARIABLE COMPUTATION, ONE MUST EVALUATE ELE- C MENTARY FUNCTIONS. WHEN THE MAGNITUDE OF Z OR FNU+N-1 IS C LARGE, LOSSES OF SIGNIFICANCE BY ARGUMENT REDUCTION OCCUR. C CONSEQUENTLY, IF EITHER ONE EXCEEDS U1=SQRT(0.5/UR), THEN C LOSSES EXCEEDING HALF PRECISION ARE LIKELY AND AN ERROR FLAG C IERR=3 IS TRIGGERED WHERE UR=DMAX1(D1MACH(4),1.0D-18) IS C DOUBLE PRECISION UNIT ROUNDOFF LIMITED TO 18 DIGITS PRECISION. C IF EITHER IS LARGER THAN U2=0.5/UR, THEN ALL SIGNIFICANCE IS C LOST AND IERR=4. IN ORDER TO USE THE INT FUNCTION, ARGUMENTS C MUST BE FURTHER RESTRICTED NOT TO EXCEED THE LARGEST MACHINE C INTEGER, U3=I1MACH(9). THUS, THE MAGNITUDE OF Z AND FNU+N-1 IS C RESTRICTED BY MIN(U2,U3). ON 32 BIT MACHINES, U1,U2, AND U3 C ARE APPROXIMATELY 2.0E+3, 4.2E+6, 2.1E+9 IN SINGLE PRECISION C ARITHMETIC AND 1.3E+8, 1.8E+16, 2.1E+9 IN DOUBLE PRECISION C ARITHMETIC RESPECTIVELY. THIS MAKES U2 AND U3 LIMITING IN C THEIR RESPECTIVE ARITHMETICS. THIS MEANS THAT ONE CAN EXPECT C TO RETAIN, IN THE WORST CASES ON 32 BIT MACHINES, NO DIGITS C IN SINGLE AND ONLY 7 DIGITS IN DOUBLE PRECISION ARITHMETIC. C SIMILAR CONSIDERATIONS HOLD FOR OTHER MACHINES. C C THE APPROXIMATE RELATIVE ERROR IN THE MAGNITUDE OF A COMPLEX C BESSEL FUNCTION CAN BE EXPRESSED BY P*10**S WHERE P=MAX(UNIT C ROUNDOFF,1.0D-18) IS THE NOMINAL PRECISION AND 10**S REPRE- C SENTS THE INCREASE IN ERROR DUE TO ARGUMENT REDUCTION IN THE C ELEMENTARY FUNCTIONS. HERE, S=MAX(1,ABS(LOG10(CABS(Z))), C ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF C CABS(Z),ABS(EXPONENT OF FNU)) ). HOWEVER, THE PHASE ANGLE MAY C HAVE ONLY ABSOLUTE ACCURACY. THIS IS MOST LIKELY TO OCCUR WHEN C ONE COMPONENT (IN ABSOLUTE VALUE) IS LARGER THAN THE OTHER BY C SEVERAL ORDERS OF MAGNITUDE. IF ONE COMPONENT IS 10**K LARGER C THAN THE OTHER, THEN ONE CAN EXPECT ONLY MAX(ABS(LOG10(P))-K, C 0) SIGNIFICANT DIGITS; OR, STATED ANOTHER WAY, WHEN K EXCEEDS C THE EXPONENT OF P, NO SIGNIFICANT DIGITS REMAIN IN THE SMALLER C COMPONENT. HOWEVER, THE PHASE ANGLE RETAINS ABSOLUTE ACCURACY C BECAUSE, IN COMPLEX ARITHMETIC WITH PRECISION P, THE SMALLER C COMPONENT WILL NOT (AS A RULE) DECREASE BELOW P TIMES THE C MAGNITUDE OF THE LARGER COMPONENT. IN THESE EXTREME CASES, C THE PRINCIPAL PHASE ANGLE IS ON THE ORDER OF +P, -P, PI/2-P, C OR -PI/2+P. C C***REFERENCES HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ C AND I. A. STEGUN, NBS AMS SERIES 55, U.S. DEPT. OF C COMMERCE, 1955. C C COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT C BY D. E. AMOS, SAND83-0083, MAY, 1983. C C COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT C AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983 C C A SUBROUTINE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85- C 1018, MAY, 1985 C C A PORTABLE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, TRANS. C MATH. SOFTWARE, 1986 C C***ROUTINES CALLED ZACON,ZBKNU,ZBUNK,ZUOIK,ZABS,I1MACH,D1MACH C***END PROLOGUE ZBESH C C COMPLEX CY,Z,ZN,ZT,CSGN DOUBLE PRECISION AA, ALIM, ALN, ARG, AZ, CYI, CYR, DIG, ELIM, * FMM, FN, FNU, FNUL, HPI, RHPI, RL, R1M5, SGN, STR, TOL, UFL, ZI, * ZNI, ZNR, ZR, ZTI, D1MACH, ZABS, BB, ASCLE, RTOL, ATOL, STI, * CSGNR, CSGNI INTEGER I, IERR, INU, INUH, IR, K, KODE, K1, K2, M, * MM, MR, N, NN, NUF, NW, NZ, I1MACH DIMENSION CYR(N), CYI(N) C DATA HPI /1.57079632679489662D0/ C C***FIRST EXECUTABLE STATEMENT ZBESH IERR = 0 NZ=0 IF (ZR.EQ.0.0D0 .AND. ZI.EQ.0.0D0) IERR=1 IF (FNU.LT.0.0D0) IERR=1 IF (M.LT.1 .OR. M.GT.2) IERR=1 IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1 IF (N.LT.1) IERR=1 IF (IERR.NE.0) RETURN NN = N C----------------------------------------------------------------------- C SET PARAMETERS RELATED TO MACHINE CONSTANTS. C TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18. C ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT. C EXP(-ELIM).LT.EXP(-ALIM)=EXP(-ELIM)/TOL AND C EXP(ELIM).GT.EXP(ALIM)=EXP(ELIM)*TOL ARE INTERVALS NEAR C UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE. C RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z. C DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG). C FNUL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC SERIES FOR LARGE FNU C----------------------------------------------------------------------- TOL = DMAX1(D1MACH(4),1.0D-18) K1 = I1MACH(15) K2 = I1MACH(16) R1M5 = D1MACH(5) K = MIN0(IABS(K1),IABS(K2)) ELIM = 2.303D0*(DBLE(FLOAT(K))*R1M5-3.0D0) K1 = I1MACH(14) - 1 AA = R1M5*DBLE(FLOAT(K1)) DIG = DMIN1(AA,18.0D0) AA = AA*2.303D0 ALIM = ELIM + DMAX1(-AA,-41.45D0) FNUL = 10.0D0 + 6.0D0*(DIG-3.0D0) RL = 1.2D0*DIG + 3.0D0 FN = FNU + DBLE(FLOAT(NN-1)) MM = 3 - M - M FMM = DBLE(FLOAT(MM)) ZNR = FMM*ZI ZNI = -FMM*ZR C----------------------------------------------------------------------- C TEST FOR PROPER RANGE C----------------------------------------------------------------------- AZ = ZABS(COMPLEX(ZR,ZI)) AA = 0.5D0/TOL BB=DBLE(FLOAT(I1MACH(9)))*0.5D0 AA = DMIN1(AA,BB) IF (AZ.GT.AA) GO TO 260 IF (FN.GT.AA) GO TO 260 AA = DSQRT(AA) IF (AZ.GT.AA) IERR=3 IF (FN.GT.AA) IERR=3 C----------------------------------------------------------------------- C OVERFLOW TEST ON THE LAST MEMBER OF THE SEQUENCE C----------------------------------------------------------------------- UFL = D1MACH(1)*1.0D+3 IF (AZ.LT.UFL) GO TO 230 IF (FNU.GT.FNUL) GO TO 90 IF (FN.LE.1.0D0) GO TO 70 IF (FN.GT.2.0D0) GO TO 60 IF (AZ.GT.TOL) GO TO 70 ARG = 0.5D0*AZ ALN = -FN*DLOG(ARG) IF (ALN.GT.ELIM) GO TO 230 GO TO 70 60 CONTINUE CALL ZUOIK(ZNR, ZNI, FNU, KODE, 2, NN, CYR, CYI, NUF, TOL, ELIM, * ALIM) IF (NUF.LT.0) GO TO 230 NZ = NZ + NUF NN = NN - NUF C----------------------------------------------------------------------- C HERE NN=N OR NN=0 SINCE NUF=0,NN, OR -1 ON RETURN FROM CUOIK C IF NUF=NN, THEN CY(I)=CZERO FOR ALL I C----------------------------------------------------------------------- IF (NN.EQ.0) GO TO 140 70 CONTINUE IF ((ZNR.LT.0.0D0) .OR. (ZNR.EQ.0.0D0 .AND. ZNI.LT.0.0D0 .AND. * M.EQ.2)) GO TO 80 C----------------------------------------------------------------------- C RIGHT HALF PLANE COMPUTATION, XN.GE.0. .AND. (XN.NE.0. .OR. C YN.GE.0. .OR. M=1) C----------------------------------------------------------------------- CALL ZBKNU(ZNR, ZNI, FNU, KODE, NN, CYR, CYI, NZ, TOL, ELIM, ALIM) GO TO 110 C----------------------------------------------------------------------- C LEFT HALF PLANE COMPUTATION C----------------------------------------------------------------------- 80 CONTINUE MR = -MM CALL ZACON(ZNR, ZNI, FNU, KODE, MR, NN, CYR, CYI, NW, RL, FNUL, * TOL, ELIM, ALIM) IF (NW.LT.0) GO TO 240 NZ=NW GO TO 110 90 CONTINUE C----------------------------------------------------------------------- C UNIFORM ASYMPTOTIC EXPANSIONS FOR FNU.GT.FNUL C----------------------------------------------------------------------- MR = 0 IF ((ZNR.GE.0.0D0) .AND. (ZNR.NE.0.0D0 .OR. ZNI.GE.0.0D0 .OR. * M.NE.2)) GO TO 100 MR = -MM IF (ZNR.NE.0.0D0 .OR. ZNI.GE.0.0D0) GO TO 100 ZNR = -ZNR ZNI = -ZNI 100 CONTINUE CALL ZBUNK(ZNR, ZNI, FNU, KODE, MR, NN, CYR, CYI, NW, TOL, ELIM, * ALIM) IF (NW.LT.0) GO TO 240 NZ = NZ + NW 110 CONTINUE C----------------------------------------------------------------------- C H(M,FNU,Z) = -FMM*(I/HPI)*(ZT**FNU)*K(FNU,-Z*ZT) C C ZT=EXP(-FMM*HPI*I) = CMPLX(0.0,-FMM), FMM=3-2*M, M=1,2 C----------------------------------------------------------------------- SGN = DSIGN(HPI,-FMM) C----------------------------------------------------------------------- C CALCULATE EXP(FNU*HPI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE C WHEN FNU IS LARGE C----------------------------------------------------------------------- INU = INT(SNGL(FNU)) INUH = INU/2 IR = INU - 2*INUH ARG = (FNU-DBLE(FLOAT(INU-IR)))*SGN RHPI = 1.0D0/SGN C ZNI = RHPI*DCOS(ARG) C ZNR = -RHPI*DSIN(ARG) CSGNI = RHPI*DCOS(ARG) CSGNR = -RHPI*DSIN(ARG) IF (MOD(INUH,2).EQ.0) GO TO 120 C ZNR = -ZNR C ZNI = -ZNI CSGNR = -CSGNR CSGNI = -CSGNI 120 CONTINUE ZTI = -FMM RTOL = 1.0D0/TOL ASCLE = UFL*RTOL DO 130 I=1,NN C STR = CYR(I)*ZNR - CYI(I)*ZNI C CYI(I) = CYR(I)*ZNI + CYI(I)*ZNR C CYR(I) = STR C STR = -ZNI*ZTI C ZNI = ZNR*ZTI C ZNR = STR AA = CYR(I) BB = CYI(I) ATOL = 1.0D0 IF (DMAX1(DABS(AA),DABS(BB)).GT.ASCLE) GO TO 135 AA = AA*RTOL BB = BB*RTOL ATOL = TOL 135 CONTINUE STR = AA*CSGNR - BB*CSGNI STI = AA*CSGNI + BB*CSGNR CYR(I) = STR*ATOL CYI(I) = STI*ATOL STR = -CSGNI*ZTI CSGNI = CSGNR*ZTI CSGNR = STR 130 CONTINUE RETURN 140 CONTINUE IF (ZNR.LT.0.0D0) GO TO 230 RETURN 230 CONTINUE NZ=0 IERR=2 RETURN 240 CONTINUE IF(NW.EQ.(-1)) GO TO 230 NZ=0 IERR=5 RETURN 260 CONTINUE NZ=0 IERR=4 RETURN END openspecfun-0.3/amos/zbesi.f000066400000000000000000000273511232445310600161330ustar00rootroot00000000000000 SUBROUTINE ZBESI(ZR, ZI, FNU, KODE, N, CYR, CYI, NZ, IERR) C***BEGIN PROLOGUE ZBESI C***DATE WRITTEN 830501 (YYMMDD) C***REVISION DATE 890801 (YYMMDD) C***CATEGORY NO. B5K C***KEYWORDS I-BESSEL FUNCTION,COMPLEX BESSEL FUNCTION, C MODIFIED BESSEL FUNCTION OF THE FIRST KIND C***AUTHOR AMOS, DONALD E., SANDIA NATIONAL LABORATORIES C***PURPOSE TO COMPUTE I-BESSEL FUNCTIONS OF COMPLEX ARGUMENT C***DESCRIPTION C C ***A DOUBLE PRECISION ROUTINE*** C ON KODE=1, ZBESI COMPUTES AN N MEMBER SEQUENCE OF COMPLEX C BESSEL FUNCTIONS CY(J)=I(FNU+J-1,Z) FOR REAL, NONNEGATIVE C ORDERS FNU+J-1, J=1,...,N AND COMPLEX Z IN THE CUT PLANE C -PI.LT.ARG(Z).LE.PI. ON KODE=2, ZBESI RETURNS THE SCALED C FUNCTIONS C C CY(J)=EXP(-ABS(X))*I(FNU+J-1,Z) J = 1,...,N , X=REAL(Z) C C WITH THE EXPONENTIAL GROWTH REMOVED IN BOTH THE LEFT AND C RIGHT HALF PLANES FOR Z TO INFINITY. DEFINITIONS AND NOTATION C ARE FOUND IN THE NBS HANDBOOK OF MATHEMATICAL FUNCTIONS C (REF. 1). C C INPUT ZR,ZI,FNU ARE DOUBLE PRECISION C ZR,ZI - Z=CMPLX(ZR,ZI), -PI.LT.ARG(Z).LE.PI C FNU - ORDER OF INITIAL I FUNCTION, FNU.GE.0.0D0 C KODE - A PARAMETER TO INDICATE THE SCALING OPTION C KODE= 1 RETURNS C CY(J)=I(FNU+J-1,Z), J=1,...,N C = 2 RETURNS C CY(J)=I(FNU+J-1,Z)*EXP(-ABS(X)), J=1,...,N C N - NUMBER OF MEMBERS OF THE SEQUENCE, N.GE.1 C C OUTPUT CYR,CYI ARE DOUBLE PRECISION C CYR,CYI- DOUBLE PRECISION VECTORS WHOSE FIRST N COMPONENTS C CONTAIN REAL AND IMAGINARY PARTS FOR THE SEQUENCE C CY(J)=I(FNU+J-1,Z) OR C CY(J)=I(FNU+J-1,Z)*EXP(-ABS(X)) J=1,...,N C DEPENDING ON KODE, X=REAL(Z) C NZ - NUMBER OF COMPONENTS SET TO ZERO DUE TO UNDERFLOW, C NZ= 0 , NORMAL RETURN C NZ.GT.0 , LAST NZ COMPONENTS OF CY SET TO ZERO C TO UNDERFLOW, CY(J)=CMPLX(0.0D0,0.0D0) C J = N-NZ+1,...,N C IERR - ERROR FLAG C IERR=0, NORMAL RETURN - COMPUTATION COMPLETED C IERR=1, INPUT ERROR - NO COMPUTATION C IERR=2, OVERFLOW - NO COMPUTATION, REAL(Z) TOO C LARGE ON KODE=1 C IERR=3, CABS(Z) OR FNU+N-1 LARGE - COMPUTATION DONE C BUT LOSSES OF SIGNIFCANCE BY ARGUMENT C REDUCTION PRODUCE LESS THAN HALF OF MACHINE C ACCURACY C IERR=4, CABS(Z) OR FNU+N-1 TOO LARGE - NO COMPUTA- C TION BECAUSE OF COMPLETE LOSSES OF SIGNIFI- C CANCE BY ARGUMENT REDUCTION C IERR=5, ERROR - NO COMPUTATION, C ALGORITHM TERMINATION CONDITION NOT MET C C***LONG DESCRIPTION C C THE COMPUTATION IS CARRIED OUT BY THE POWER SERIES FOR C SMALL CABS(Z), THE ASYMPTOTIC EXPANSION FOR LARGE CABS(Z), C THE MILLER ALGORITHM NORMALIZED BY THE WRONSKIAN AND A C NEUMANN SERIES FOR IMTERMEDIATE MAGNITUDES, AND THE C UNIFORM ASYMPTOTIC EXPANSIONS FOR I(FNU,Z) AND J(FNU,Z) C FOR LARGE ORDERS. BACKWARD RECURRENCE IS USED TO GENERATE C SEQUENCES OR REDUCE ORDERS WHEN NECESSARY. C C THE CALCULATIONS ABOVE ARE DONE IN THE RIGHT HALF PLANE AND C CONTINUED INTO THE LEFT HALF PLANE BY THE FORMULA C C I(FNU,Z*EXP(M*PI)) = EXP(M*PI*FNU)*I(FNU,Z) REAL(Z).GT.0.0 C M = +I OR -I, I**2=-1 C C FOR NEGATIVE ORDERS,THE FORMULA C C I(-FNU,Z) = I(FNU,Z) + (2/PI)*SIN(PI*FNU)*K(FNU,Z) C C CAN BE USED. HOWEVER,FOR LARGE ORDERS CLOSE TO INTEGERS, THE C THE FUNCTION CHANGES RADICALLY. WHEN FNU IS A LARGE POSITIVE C INTEGER,THE MAGNITUDE OF I(-FNU,Z)=I(FNU,Z) IS A LARGE C NEGATIVE POWER OF TEN. BUT WHEN FNU IS NOT AN INTEGER, C K(FNU,Z) DOMINATES IN MAGNITUDE WITH A LARGE POSITIVE POWER OF C TEN AND THE MOST THAT THE SECOND TERM CAN BE REDUCED IS BY C UNIT ROUNDOFF FROM THE COEFFICIENT. THUS, WIDE CHANGES CAN C OCCUR WITHIN UNIT ROUNDOFF OF A LARGE INTEGER FOR FNU. HERE, C LARGE MEANS FNU.GT.CABS(Z). C C IN MOST COMPLEX VARIABLE COMPUTATION, ONE MUST EVALUATE ELE- C MENTARY FUNCTIONS. WHEN THE MAGNITUDE OF Z OR FNU+N-1 IS C LARGE, LOSSES OF SIGNIFICANCE BY ARGUMENT REDUCTION OCCUR. C CONSEQUENTLY, IF EITHER ONE EXCEEDS U1=SQRT(0.5/UR), THEN C LOSSES EXCEEDING HALF PRECISION ARE LIKELY AND AN ERROR FLAG C IERR=3 IS TRIGGERED WHERE UR=DMAX1(D1MACH(4),1.0D-18) IS C DOUBLE PRECISION UNIT ROUNDOFF LIMITED TO 18 DIGITS PRECISION. C IF EITHER IS LARGER THAN U2=0.5/UR, THEN ALL SIGNIFICANCE IS C LOST AND IERR=4. IN ORDER TO USE THE INT FUNCTION, ARGUMENTS C MUST BE FURTHER RESTRICTED NOT TO EXCEED THE LARGEST MACHINE C INTEGER, U3=I1MACH(9). THUS, THE MAGNITUDE OF Z AND FNU+N-1 IS C RESTRICTED BY MIN(U2,U3). ON 32 BIT MACHINES, U1,U2, AND U3 C ARE APPROXIMATELY 2.0E+3, 4.2E+6, 2.1E+9 IN SINGLE PRECISION C ARITHMETIC AND 1.3E+8, 1.8E+16, 2.1E+9 IN DOUBLE PRECISION C ARITHMETIC RESPECTIVELY. THIS MAKES U2 AND U3 LIMITING IN C THEIR RESPECTIVE ARITHMETICS. THIS MEANS THAT ONE CAN EXPECT C TO RETAIN, IN THE WORST CASES ON 32 BIT MACHINES, NO DIGITS C IN SINGLE AND ONLY 7 DIGITS IN DOUBLE PRECISION ARITHMETIC. C SIMILAR CONSIDERATIONS HOLD FOR OTHER MACHINES. C C THE APPROXIMATE RELATIVE ERROR IN THE MAGNITUDE OF A COMPLEX C BESSEL FUNCTION CAN BE EXPRESSED BY P*10**S WHERE P=MAX(UNIT C ROUNDOFF,1.0E-18) IS THE NOMINAL PRECISION AND 10**S REPRE- C SENTS THE INCREASE IN ERROR DUE TO ARGUMENT REDUCTION IN THE C ELEMENTARY FUNCTIONS. HERE, S=MAX(1,ABS(LOG10(CABS(Z))), C ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF C CABS(Z),ABS(EXPONENT OF FNU)) ). HOWEVER, THE PHASE ANGLE MAY C HAVE ONLY ABSOLUTE ACCURACY. THIS IS MOST LIKELY TO OCCUR WHEN C ONE COMPONENT (IN ABSOLUTE VALUE) IS LARGER THAN THE OTHER BY C SEVERAL ORDERS OF MAGNITUDE. IF ONE COMPONENT IS 10**K LARGER C THAN THE OTHER, THEN ONE CAN EXPECT ONLY MAX(ABS(LOG10(P))-K, C 0) SIGNIFICANT DIGITS; OR, STATED ANOTHER WAY, WHEN K EXCEEDS C THE EXPONENT OF P, NO SIGNIFICANT DIGITS REMAIN IN THE SMALLER C COMPONENT. HOWEVER, THE PHASE ANGLE RETAINS ABSOLUTE ACCURACY C BECAUSE, IN COMPLEX ARITHMETIC WITH PRECISION P, THE SMALLER C COMPONENT WILL NOT (AS A RULE) DECREASE BELOW P TIMES THE C MAGNITUDE OF THE LARGER COMPONENT. IN THESE EXTREME CASES, C THE PRINCIPAL PHASE ANGLE IS ON THE ORDER OF +P, -P, PI/2-P, C OR -PI/2+P. C C***REFERENCES HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ C AND I. A. STEGUN, NBS AMS SERIES 55, U.S. DEPT. OF C COMMERCE, 1955. C C COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT C BY D. E. AMOS, SAND83-0083, MAY, 1983. C C COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT C AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983 C C A SUBROUTINE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85- C 1018, MAY, 1985 C C A PORTABLE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, TRANS. C MATH. SOFTWARE, 1986 C C***ROUTINES CALLED ZBINU,I1MACH,D1MACH C***END PROLOGUE ZBESI C COMPLEX CONE,CSGN,CW,CY,CZERO,Z,ZN DOUBLE PRECISION AA, ALIM, ARG, CONEI, CONER, CSGNI, CSGNR, CYI, * CYR, DIG, ELIM, FNU, FNUL, PI, RL, R1M5, STR, TOL, ZI, ZNI, ZNR, * ZR, D1MACH, AZ, BB, FN, ZABS, ASCLE, RTOL, ATOL, STI INTEGER I, IERR, INU, K, KODE, K1,K2,N,NZ,NN, I1MACH DIMENSION CYR(N), CYI(N) DATA PI /3.14159265358979324D0/ DATA CONER, CONEI /1.0D0,0.0D0/ C C***FIRST EXECUTABLE STATEMENT ZBESI IERR = 0 NZ=0 IF (FNU.LT.0.0D0) IERR=1 IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1 IF (N.LT.1) IERR=1 IF (IERR.NE.0) RETURN C----------------------------------------------------------------------- C SET PARAMETERS RELATED TO MACHINE CONSTANTS. C TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18. C ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT. C EXP(-ELIM).LT.EXP(-ALIM)=EXP(-ELIM)/TOL AND C EXP(ELIM).GT.EXP(ALIM)=EXP(ELIM)*TOL ARE INTERVALS NEAR C UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE. C RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z. C DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG). C FNUL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC SERIES FOR LARGE FNU. C----------------------------------------------------------------------- TOL = DMAX1(D1MACH(4),1.0D-18) K1 = I1MACH(15) K2 = I1MACH(16) R1M5 = D1MACH(5) K = MIN0(IABS(K1),IABS(K2)) ELIM = 2.303D0*(DBLE(FLOAT(K))*R1M5-3.0D0) K1 = I1MACH(14) - 1 AA = R1M5*DBLE(FLOAT(K1)) DIG = DMIN1(AA,18.0D0) AA = AA*2.303D0 ALIM = ELIM + DMAX1(-AA,-41.45D0) RL = 1.2D0*DIG + 3.0D0 FNUL = 10.0D0 + 6.0D0*(DIG-3.0D0) C----------------------------------------------------------------------------- C TEST FOR PROPER RANGE C----------------------------------------------------------------------- AZ = ZABS(COMPLEX(ZR,ZI)) FN = FNU+DBLE(FLOAT(N-1)) AA = 0.5D0/TOL BB=DBLE(FLOAT(I1MACH(9)))*0.5D0 AA = DMIN1(AA,BB) IF (AZ.GT.AA) GO TO 260 IF (FN.GT.AA) GO TO 260 AA = DSQRT(AA) IF (AZ.GT.AA) IERR=3 IF (FN.GT.AA) IERR=3 ZNR = ZR ZNI = ZI CSGNR = CONER CSGNI = CONEI IF (ZR.GE.0.0D0) GO TO 40 ZNR = -ZR ZNI = -ZI C----------------------------------------------------------------------- C CALCULATE CSGN=EXP(FNU*PI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE C WHEN FNU IS LARGE C----------------------------------------------------------------------- INU = INT(SNGL(FNU)) ARG = (FNU-DBLE(FLOAT(INU)))*PI IF (ZI.LT.0.0D0) ARG = -ARG CSGNR = DCOS(ARG) CSGNI = DSIN(ARG) IF (MOD(INU,2).EQ.0) GO TO 40 CSGNR = -CSGNR CSGNI = -CSGNI 40 CONTINUE CALL ZBINU(ZNR, ZNI, FNU, KODE, N, CYR, CYI, NZ, RL, FNUL, TOL, * ELIM, ALIM) IF (NZ.LT.0) GO TO 120 IF (ZR.GE.0.0D0) RETURN C----------------------------------------------------------------------- C ANALYTIC CONTINUATION TO THE LEFT HALF PLANE C----------------------------------------------------------------------- NN = N - NZ IF (NN.EQ.0) RETURN RTOL = 1.0D0/TOL ASCLE = D1MACH(1)*RTOL*1.0D+3 DO 50 I=1,NN C STR = CYR(I)*CSGNR - CYI(I)*CSGNI C CYI(I) = CYR(I)*CSGNI + CYI(I)*CSGNR C CYR(I) = STR AA = CYR(I) BB = CYI(I) ATOL = 1.0D0 IF (DMAX1(DABS(AA),DABS(BB)).GT.ASCLE) GO TO 55 AA = AA*RTOL BB = BB*RTOL ATOL = TOL 55 CONTINUE STR = AA*CSGNR - BB*CSGNI STI = AA*CSGNI + BB*CSGNR CYR(I) = STR*ATOL CYI(I) = STI*ATOL CSGNR = -CSGNR CSGNI = -CSGNI 50 CONTINUE RETURN 120 CONTINUE IF(NZ.EQ.(-2)) GO TO 130 NZ = 0 IERR=2 RETURN 130 CONTINUE NZ=0 IERR=5 RETURN 260 CONTINUE NZ=0 IERR=4 RETURN END openspecfun-0.3/amos/zbesj.f000066400000000000000000000265021232445310600161310ustar00rootroot00000000000000 SUBROUTINE ZBESJ(ZR, ZI, FNU, KODE, N, CYR, CYI, NZ, IERR) C***BEGIN PROLOGUE ZBESJ C***DATE WRITTEN 830501 (YYMMDD) C***REVISION DATE 890801 (YYMMDD) C***CATEGORY NO. B5K C***KEYWORDS J-BESSEL FUNCTION,BESSEL FUNCTION OF COMPLEX ARGUMENT, C BESSEL FUNCTION OF FIRST KIND C***AUTHOR AMOS, DONALD E., SANDIA NATIONAL LABORATORIES C***PURPOSE TO COMPUTE THE J-BESSEL FUNCTION OF A COMPLEX ARGUMENT C***DESCRIPTION C C ***A DOUBLE PRECISION ROUTINE*** C ON KODE=1, CBESJ COMPUTES AN N MEMBER SEQUENCE OF COMPLEX C BESSEL FUNCTIONS CY(I)=J(FNU+I-1,Z) FOR REAL, NONNEGATIVE C ORDERS FNU+I-1, I=1,...,N AND COMPLEX Z IN THE CUT PLANE C -PI.LT.ARG(Z).LE.PI. ON KODE=2, CBESJ RETURNS THE SCALED C FUNCTIONS C C CY(I)=EXP(-ABS(Y))*J(FNU+I-1,Z) I = 1,...,N , Y=AIMAG(Z) C C WHICH REMOVE THE EXPONENTIAL GROWTH IN BOTH THE UPPER AND C LOWER HALF PLANES FOR Z TO INFINITY. DEFINITIONS AND NOTATION C ARE FOUND IN THE NBS HANDBOOK OF MATHEMATICAL FUNCTIONS C (REF. 1). C C INPUT ZR,ZI,FNU ARE DOUBLE PRECISION C ZR,ZI - Z=CMPLX(ZR,ZI), -PI.LT.ARG(Z).LE.PI C FNU - ORDER OF INITIAL J FUNCTION, FNU.GE.0.0D0 C KODE - A PARAMETER TO INDICATE THE SCALING OPTION C KODE= 1 RETURNS C CY(I)=J(FNU+I-1,Z), I=1,...,N C = 2 RETURNS C CY(I)=J(FNU+I-1,Z)EXP(-ABS(Y)), I=1,...,N C N - NUMBER OF MEMBERS OF THE SEQUENCE, N.GE.1 C C OUTPUT CYR,CYI ARE DOUBLE PRECISION C CYR,CYI- DOUBLE PRECISION VECTORS WHOSE FIRST N COMPONENTS C CONTAIN REAL AND IMAGINARY PARTS FOR THE SEQUENCE C CY(I)=J(FNU+I-1,Z) OR C CY(I)=J(FNU+I-1,Z)EXP(-ABS(Y)) I=1,...,N C DEPENDING ON KODE, Y=AIMAG(Z). C NZ - NUMBER OF COMPONENTS SET TO ZERO DUE TO UNDERFLOW, C NZ= 0 , NORMAL RETURN C NZ.GT.0 , LAST NZ COMPONENTS OF CY SET ZERO DUE C TO UNDERFLOW, CY(I)=CMPLX(0.0D0,0.0D0), C I = N-NZ+1,...,N C IERR - ERROR FLAG C IERR=0, NORMAL RETURN - COMPUTATION COMPLETED C IERR=1, INPUT ERROR - NO COMPUTATION C IERR=2, OVERFLOW - NO COMPUTATION, AIMAG(Z) C TOO LARGE ON KODE=1 C IERR=3, CABS(Z) OR FNU+N-1 LARGE - COMPUTATION DONE C BUT LOSSES OF SIGNIFCANCE BY ARGUMENT C REDUCTION PRODUCE LESS THAN HALF OF MACHINE C ACCURACY C IERR=4, CABS(Z) OR FNU+N-1 TOO LARGE - NO COMPUTA- C TION BECAUSE OF COMPLETE LOSSES OF SIGNIFI- C CANCE BY ARGUMENT REDUCTION C IERR=5, ERROR - NO COMPUTATION, C ALGORITHM TERMINATION CONDITION NOT MET C C***LONG DESCRIPTION C C THE COMPUTATION IS CARRIED OUT BY THE FORMULA C C J(FNU,Z)=EXP( FNU*PI*I/2)*I(FNU,-I*Z) AIMAG(Z).GE.0.0 C C J(FNU,Z)=EXP(-FNU*PI*I/2)*I(FNU, I*Z) AIMAG(Z).LT.0.0 C C WHERE I**2 = -1 AND I(FNU,Z) IS THE I BESSEL FUNCTION. C C FOR NEGATIVE ORDERS,THE FORMULA C C J(-FNU,Z) = J(FNU,Z)*COS(PI*FNU) - Y(FNU,Z)*SIN(PI*FNU) C C CAN BE USED. HOWEVER,FOR LARGE ORDERS CLOSE TO INTEGERS, THE C THE FUNCTION CHANGES RADICALLY. WHEN FNU IS A LARGE POSITIVE C INTEGER,THE MAGNITUDE OF J(-FNU,Z)=J(FNU,Z)*COS(PI*FNU) IS A C LARGE NEGATIVE POWER OF TEN. BUT WHEN FNU IS NOT AN INTEGER, C Y(FNU,Z) DOMINATES IN MAGNITUDE WITH A LARGE POSITIVE POWER OF C TEN AND THE MOST THAT THE SECOND TERM CAN BE REDUCED IS BY C UNIT ROUNDOFF FROM THE COEFFICIENT. THUS, WIDE CHANGES CAN C OCCUR WITHIN UNIT ROUNDOFF OF A LARGE INTEGER FOR FNU. HERE, C LARGE MEANS FNU.GT.CABS(Z). C C IN MOST COMPLEX VARIABLE COMPUTATION, ONE MUST EVALUATE ELE- C MENTARY FUNCTIONS. WHEN THE MAGNITUDE OF Z OR FNU+N-1 IS C LARGE, LOSSES OF SIGNIFICANCE BY ARGUMENT REDUCTION OCCUR. C CONSEQUENTLY, IF EITHER ONE EXCEEDS U1=SQRT(0.5/UR), THEN C LOSSES EXCEEDING HALF PRECISION ARE LIKELY AND AN ERROR FLAG C IERR=3 IS TRIGGERED WHERE UR=DMAX1(D1MACH(4),1.0D-18) IS C DOUBLE PRECISION UNIT ROUNDOFF LIMITED TO 18 DIGITS PRECISION. C IF EITHER IS LARGER THAN U2=0.5/UR, THEN ALL SIGNIFICANCE IS C LOST AND IERR=4. IN ORDER TO USE THE INT FUNCTION, ARGUMENTS C MUST BE FURTHER RESTRICTED NOT TO EXCEED THE LARGEST MACHINE C INTEGER, U3=I1MACH(9). THUS, THE MAGNITUDE OF Z AND FNU+N-1 IS C RESTRICTED BY MIN(U2,U3). ON 32 BIT MACHINES, U1,U2, AND U3 C ARE APPROXIMATELY 2.0E+3, 4.2E+6, 2.1E+9 IN SINGLE PRECISION C ARITHMETIC AND 1.3E+8, 1.8E+16, 2.1E+9 IN DOUBLE PRECISION C ARITHMETIC RESPECTIVELY. THIS MAKES U2 AND U3 LIMITING IN C THEIR RESPECTIVE ARITHMETICS. THIS MEANS THAT ONE CAN EXPECT C TO RETAIN, IN THE WORST CASES ON 32 BIT MACHINES, NO DIGITS C IN SINGLE AND ONLY 7 DIGITS IN DOUBLE PRECISION ARITHMETIC. C SIMILAR CONSIDERATIONS HOLD FOR OTHER MACHINES. C C THE APPROXIMATE RELATIVE ERROR IN THE MAGNITUDE OF A COMPLEX C BESSEL FUNCTION CAN BE EXPRESSED BY P*10**S WHERE P=MAX(UNIT C ROUNDOFF,1.0E-18) IS THE NOMINAL PRECISION AND 10**S REPRE- C SENTS THE INCREASE IN ERROR DUE TO ARGUMENT REDUCTION IN THE C ELEMENTARY FUNCTIONS. HERE, S=MAX(1,ABS(LOG10(CABS(Z))), C ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF C CABS(Z),ABS(EXPONENT OF FNU)) ). HOWEVER, THE PHASE ANGLE MAY C HAVE ONLY ABSOLUTE ACCURACY. THIS IS MOST LIKELY TO OCCUR WHEN C ONE COMPONENT (IN ABSOLUTE VALUE) IS LARGER THAN THE OTHER BY C SEVERAL ORDERS OF MAGNITUDE. IF ONE COMPONENT IS 10**K LARGER C THAN THE OTHER, THEN ONE CAN EXPECT ONLY MAX(ABS(LOG10(P))-K, C 0) SIGNIFICANT DIGITS; OR, STATED ANOTHER WAY, WHEN K EXCEEDS C THE EXPONENT OF P, NO SIGNIFICANT DIGITS REMAIN IN THE SMALLER C COMPONENT. HOWEVER, THE PHASE ANGLE RETAINS ABSOLUTE ACCURACY C BECAUSE, IN COMPLEX ARITHMETIC WITH PRECISION P, THE SMALLER C COMPONENT WILL NOT (AS A RULE) DECREASE BELOW P TIMES THE C MAGNITUDE OF THE LARGER COMPONENT. IN THESE EXTREME CASES, C THE PRINCIPAL PHASE ANGLE IS ON THE ORDER OF +P, -P, PI/2-P, C OR -PI/2+P. C C***REFERENCES HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ C AND I. A. STEGUN, NBS AMS SERIES 55, U.S. DEPT. OF C COMMERCE, 1955. C C COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT C BY D. E. AMOS, SAND83-0083, MAY, 1983. C C COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT C AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983 C C A SUBROUTINE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85- C 1018, MAY, 1985 C C A PORTABLE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, TRANS. C MATH. SOFTWARE, 1986 C C***ROUTINES CALLED ZBINU,I1MACH,D1MACH C***END PROLOGUE ZBESJ C C COMPLEX CI,CSGN,CY,Z,ZN DOUBLE PRECISION AA, ALIM, ARG, CII, CSGNI, CSGNR, CYI, CYR, DIG, * ELIM, FNU, FNUL, HPI, RL, R1M5, STR, TOL, ZI, ZNI, ZNR, ZR, * D1MACH, BB, FN, AZ, ZABS, ASCLE, RTOL, ATOL, STI INTEGER I, IERR, INU, INUH, IR, K, KODE, K1, K2, N, NL, NZ, I1MACH DIMENSION CYR(N), CYI(N) DATA HPI /1.57079632679489662D0/ C C***FIRST EXECUTABLE STATEMENT ZBESJ IERR = 0 NZ=0 IF (FNU.LT.0.0D0) IERR=1 IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1 IF (N.LT.1) IERR=1 IF (IERR.NE.0) RETURN C----------------------------------------------------------------------- C SET PARAMETERS RELATED TO MACHINE CONSTANTS. C TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18. C ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT. C EXP(-ELIM).LT.EXP(-ALIM)=EXP(-ELIM)/TOL AND C EXP(ELIM).GT.EXP(ALIM)=EXP(ELIM)*TOL ARE INTERVALS NEAR C UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE. C RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z. C DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG). C FNUL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC SERIES FOR LARGE FNU. C----------------------------------------------------------------------- TOL = DMAX1(D1MACH(4),1.0D-18) K1 = I1MACH(15) K2 = I1MACH(16) R1M5 = D1MACH(5) K = MIN0(IABS(K1),IABS(K2)) ELIM = 2.303D0*(DBLE(FLOAT(K))*R1M5-3.0D0) K1 = I1MACH(14) - 1 AA = R1M5*DBLE(FLOAT(K1)) DIG = DMIN1(AA,18.0D0) AA = AA*2.303D0 ALIM = ELIM + DMAX1(-AA,-41.45D0) RL = 1.2D0*DIG + 3.0D0 FNUL = 10.0D0 + 6.0D0*(DIG-3.0D0) C----------------------------------------------------------------------- C TEST FOR PROPER RANGE C----------------------------------------------------------------------- AZ = ZABS(COMPLEX(ZR,ZI)) FN = FNU+DBLE(FLOAT(N-1)) AA = 0.5D0/TOL BB=DBLE(FLOAT(I1MACH(9)))*0.5D0 AA = DMIN1(AA,BB) IF (AZ.GT.AA) GO TO 260 IF (FN.GT.AA) GO TO 260 AA = DSQRT(AA) IF (AZ.GT.AA) IERR=3 IF (FN.GT.AA) IERR=3 C----------------------------------------------------------------------- C CALCULATE CSGN=EXP(FNU*HPI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE C WHEN FNU IS LARGE C----------------------------------------------------------------------- CII = 1.0D0 INU = INT(SNGL(FNU)) INUH = INU/2 IR = INU - 2*INUH ARG = (FNU-DBLE(FLOAT(INU-IR)))*HPI CSGNR = DCOS(ARG) CSGNI = DSIN(ARG) IF (MOD(INUH,2).EQ.0) GO TO 40 CSGNR = -CSGNR CSGNI = -CSGNI 40 CONTINUE C----------------------------------------------------------------------- C ZN IS IN THE RIGHT HALF PLANE C----------------------------------------------------------------------- ZNR = ZI ZNI = -ZR IF (ZI.GE.0.0D0) GO TO 50 ZNR = -ZNR ZNI = -ZNI CSGNI = -CSGNI CII = -CII 50 CONTINUE CALL ZBINU(ZNR, ZNI, FNU, KODE, N, CYR, CYI, NZ, RL, FNUL, TOL, * ELIM, ALIM) IF (NZ.LT.0) GO TO 130 NL = N - NZ IF (NL.EQ.0) RETURN RTOL = 1.0D0/TOL ASCLE = D1MACH(1)*RTOL*1.0D+3 DO 60 I=1,NL C STR = CYR(I)*CSGNR - CYI(I)*CSGNI C CYI(I) = CYR(I)*CSGNI + CYI(I)*CSGNR C CYR(I) = STR AA = CYR(I) BB = CYI(I) ATOL = 1.0D0 IF (DMAX1(DABS(AA),DABS(BB)).GT.ASCLE) GO TO 55 AA = AA*RTOL BB = BB*RTOL ATOL = TOL 55 CONTINUE STR = AA*CSGNR - BB*CSGNI STI = AA*CSGNI + BB*CSGNR CYR(I) = STR*ATOL CYI(I) = STI*ATOL STR = -CSGNI*CII CSGNI = CSGNR*CII CSGNR = STR 60 CONTINUE RETURN 130 CONTINUE IF(NZ.EQ.(-2)) GO TO 140 NZ = 0 IERR = 2 RETURN 140 CONTINUE NZ=0 IERR=5 RETURN 260 CONTINUE NZ=0 IERR=4 RETURN END openspecfun-0.3/amos/zbesk.f000066400000000000000000000277741232445310600161460ustar00rootroot00000000000000 SUBROUTINE ZBESK(ZR, ZI, FNU, KODE, N, CYR, CYI, NZ, IERR) C***BEGIN PROLOGUE ZBESK C***DATE WRITTEN 830501 (YYMMDD) C***REVISION DATE 890801 (YYMMDD) C***CATEGORY NO. B5K C***KEYWORDS K-BESSEL FUNCTION,COMPLEX BESSEL FUNCTION, C MODIFIED BESSEL FUNCTION OF THE SECOND KIND, C BESSEL FUNCTION OF THE THIRD KIND C***AUTHOR AMOS, DONALD E., SANDIA NATIONAL LABORATORIES C***PURPOSE TO COMPUTE K-BESSEL FUNCTIONS OF COMPLEX ARGUMENT C***DESCRIPTION C C ***A DOUBLE PRECISION ROUTINE*** C C ON KODE=1, CBESK COMPUTES AN N MEMBER SEQUENCE OF COMPLEX C BESSEL FUNCTIONS CY(J)=K(FNU+J-1,Z) FOR REAL, NONNEGATIVE C ORDERS FNU+J-1, J=1,...,N AND COMPLEX Z.NE.CMPLX(0.0,0.0) C IN THE CUT PLANE -PI.LT.ARG(Z).LE.PI. ON KODE=2, CBESK C RETURNS THE SCALED K FUNCTIONS, C C CY(J)=EXP(Z)*K(FNU+J-1,Z) , J=1,...,N, C C WHICH REMOVE THE EXPONENTIAL BEHAVIOR IN BOTH THE LEFT AND C RIGHT HALF PLANES FOR Z TO INFINITY. DEFINITIONS AND C NOTATION ARE FOUND IN THE NBS HANDBOOK OF MATHEMATICAL C FUNCTIONS (REF. 1). C C INPUT ZR,ZI,FNU ARE DOUBLE PRECISION C ZR,ZI - Z=CMPLX(ZR,ZI), Z.NE.CMPLX(0.0D0,0.0D0), C -PI.LT.ARG(Z).LE.PI C FNU - ORDER OF INITIAL K FUNCTION, FNU.GE.0.0D0 C N - NUMBER OF MEMBERS OF THE SEQUENCE, N.GE.1 C KODE - A PARAMETER TO INDICATE THE SCALING OPTION C KODE= 1 RETURNS C CY(I)=K(FNU+I-1,Z), I=1,...,N C = 2 RETURNS C CY(I)=K(FNU+I-1,Z)*EXP(Z), I=1,...,N C C OUTPUT CYR,CYI ARE DOUBLE PRECISION C CYR,CYI- DOUBLE PRECISION VECTORS WHOSE FIRST N COMPONENTS C CONTAIN REAL AND IMAGINARY PARTS FOR THE SEQUENCE C CY(I)=K(FNU+I-1,Z), I=1,...,N OR C CY(I)=K(FNU+I-1,Z)*EXP(Z), I=1,...,N C DEPENDING ON KODE C NZ - NUMBER OF COMPONENTS SET TO ZERO DUE TO UNDERFLOW. C NZ= 0 , NORMAL RETURN C NZ.GT.0 , FIRST NZ COMPONENTS OF CY SET TO ZERO DUE C TO UNDERFLOW, CY(I)=CMPLX(0.0D0,0.0D0), C I=1,...,N WHEN X.GE.0.0. WHEN X.LT.0.0 C NZ STATES ONLY THE NUMBER OF UNDERFLOWS C IN THE SEQUENCE. C C IERR - ERROR FLAG C IERR=0, NORMAL RETURN - COMPUTATION COMPLETED C IERR=1, INPUT ERROR - NO COMPUTATION C IERR=2, OVERFLOW - NO COMPUTATION, FNU IS C TOO LARGE OR CABS(Z) IS TOO SMALL OR BOTH C IERR=3, CABS(Z) OR FNU+N-1 LARGE - COMPUTATION DONE C BUT LOSSES OF SIGNIFCANCE BY ARGUMENT C REDUCTION PRODUCE LESS THAN HALF OF MACHINE C ACCURACY C IERR=4, CABS(Z) OR FNU+N-1 TOO LARGE - NO COMPUTA- C TION BECAUSE OF COMPLETE LOSSES OF SIGNIFI- C CANCE BY ARGUMENT REDUCTION C IERR=5, ERROR - NO COMPUTATION, C ALGORITHM TERMINATION CONDITION NOT MET C C***LONG DESCRIPTION C C EQUATIONS OF THE REFERENCE ARE IMPLEMENTED FOR SMALL ORDERS C DNU AND DNU+1.0 IN THE RIGHT HALF PLANE X.GE.0.0. FORWARD C RECURRENCE GENERATES HIGHER ORDERS. K IS CONTINUED TO THE LEFT C HALF PLANE BY THE RELATION C C K(FNU,Z*EXP(MP)) = EXP(-MP*FNU)*K(FNU,Z)-MP*I(FNU,Z) C MP=MR*PI*I, MR=+1 OR -1, RE(Z).GT.0, I**2=-1 C C WHERE I(FNU,Z) IS THE I BESSEL FUNCTION. C C FOR LARGE ORDERS, FNU.GT.FNUL, THE K FUNCTION IS COMPUTED C BY MEANS OF ITS UNIFORM ASYMPTOTIC EXPANSIONS. C C FOR NEGATIVE ORDERS, THE FORMULA C C K(-FNU,Z) = K(FNU,Z) C C CAN BE USED. C C CBESK ASSUMES THAT A SIGNIFICANT DIGIT SINH(X) FUNCTION IS C AVAILABLE. C C IN MOST COMPLEX VARIABLE COMPUTATION, ONE MUST EVALUATE ELE- C MENTARY FUNCTIONS. WHEN THE MAGNITUDE OF Z OR FNU+N-1 IS C LARGE, LOSSES OF SIGNIFICANCE BY ARGUMENT REDUCTION OCCUR. C CONSEQUENTLY, IF EITHER ONE EXCEEDS U1=SQRT(0.5/UR), THEN C LOSSES EXCEEDING HALF PRECISION ARE LIKELY AND AN ERROR FLAG C IERR=3 IS TRIGGERED WHERE UR=DMAX1(D1MACH(4),1.0D-18) IS C DOUBLE PRECISION UNIT ROUNDOFF LIMITED TO 18 DIGITS PRECISION. C IF EITHER IS LARGER THAN U2=0.5/UR, THEN ALL SIGNIFICANCE IS C LOST AND IERR=4. IN ORDER TO USE THE INT FUNCTION, ARGUMENTS C MUST BE FURTHER RESTRICTED NOT TO EXCEED THE LARGEST MACHINE C INTEGER, U3=I1MACH(9). THUS, THE MAGNITUDE OF Z AND FNU+N-1 IS C RESTRICTED BY MIN(U2,U3). ON 32 BIT MACHINES, U1,U2, AND U3 C ARE APPROXIMATELY 2.0E+3, 4.2E+6, 2.1E+9 IN SINGLE PRECISION C ARITHMETIC AND 1.3E+8, 1.8E+16, 2.1E+9 IN DOUBLE PRECISION C ARITHMETIC RESPECTIVELY. THIS MAKES U2 AND U3 LIMITING IN C THEIR RESPECTIVE ARITHMETICS. THIS MEANS THAT ONE CAN EXPECT C TO RETAIN, IN THE WORST CASES ON 32 BIT MACHINES, NO DIGITS C IN SINGLE AND ONLY 7 DIGITS IN DOUBLE PRECISION ARITHMETIC. C SIMILAR CONSIDERATIONS HOLD FOR OTHER MACHINES. C C THE APPROXIMATE RELATIVE ERROR IN THE MAGNITUDE OF A COMPLEX C BESSEL FUNCTION CAN BE EXPRESSED BY P*10**S WHERE P=MAX(UNIT C ROUNDOFF,1.0E-18) IS THE NOMINAL PRECISION AND 10**S REPRE- C SENTS THE INCREASE IN ERROR DUE TO ARGUMENT REDUCTION IN THE C ELEMENTARY FUNCTIONS. HERE, S=MAX(1,ABS(LOG10(CABS(Z))), C ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF C CABS(Z),ABS(EXPONENT OF FNU)) ). HOWEVER, THE PHASE ANGLE MAY C HAVE ONLY ABSOLUTE ACCURACY. THIS IS MOST LIKELY TO OCCUR WHEN C ONE COMPONENT (IN ABSOLUTE VALUE) IS LARGER THAN THE OTHER BY C SEVERAL ORDERS OF MAGNITUDE. IF ONE COMPONENT IS 10**K LARGER C THAN THE OTHER, THEN ONE CAN EXPECT ONLY MAX(ABS(LOG10(P))-K, C 0) SIGNIFICANT DIGITS; OR, STATED ANOTHER WAY, WHEN K EXCEEDS C THE EXPONENT OF P, NO SIGNIFICANT DIGITS REMAIN IN THE SMALLER C COMPONENT. HOWEVER, THE PHASE ANGLE RETAINS ABSOLUTE ACCURACY C BECAUSE, IN COMPLEX ARITHMETIC WITH PRECISION P, THE SMALLER C COMPONENT WILL NOT (AS A RULE) DECREASE BELOW P TIMES THE C MAGNITUDE OF THE LARGER COMPONENT. IN THESE EXTREME CASES, C THE PRINCIPAL PHASE ANGLE IS ON THE ORDER OF +P, -P, PI/2-P, C OR -PI/2+P. C C***REFERENCES HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ C AND I. A. STEGUN, NBS AMS SERIES 55, U.S. DEPT. OF C COMMERCE, 1955. C C COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT C BY D. E. AMOS, SAND83-0083, MAY, 1983. C C COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT C AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983. C C A SUBROUTINE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85- C 1018, MAY, 1985 C C A PORTABLE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, TRANS. C MATH. SOFTWARE, 1986 C C***ROUTINES CALLED ZACON,ZBKNU,ZBUNK,ZUOIK,ZABS,I1MACH,D1MACH C***END PROLOGUE ZBESK C C COMPLEX CY,Z DOUBLE PRECISION AA, ALIM, ALN, ARG, AZ, CYI, CYR, DIG, ELIM, FN, * FNU, FNUL, RL, R1M5, TOL, UFL, ZI, ZR, D1MACH, ZABS, BB INTEGER IERR, K, KODE, K1, K2, MR, N, NN, NUF, NW, NZ, I1MACH DIMENSION CYR(N), CYI(N) C***FIRST EXECUTABLE STATEMENT ZBESK IERR = 0 NZ=0 IF (ZI.EQ.0.0E0 .AND. ZR.EQ.0.0E0) IERR=1 IF (FNU.LT.0.0D0) IERR=1 IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1 IF (N.LT.1) IERR=1 IF (IERR.NE.0) RETURN NN = N C----------------------------------------------------------------------- C SET PARAMETERS RELATED TO MACHINE CONSTANTS. C TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18. C ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT. C EXP(-ELIM).LT.EXP(-ALIM)=EXP(-ELIM)/TOL AND C EXP(ELIM).GT.EXP(ALIM)=EXP(ELIM)*TOL ARE INTERVALS NEAR C UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE. C RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z. C DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG). C FNUL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC SERIES FOR LARGE FNU C----------------------------------------------------------------------- TOL = DMAX1(D1MACH(4),1.0D-18) K1 = I1MACH(15) K2 = I1MACH(16) R1M5 = D1MACH(5) K = MIN0(IABS(K1),IABS(K2)) ELIM = 2.303D0*(DBLE(FLOAT(K))*R1M5-3.0D0) K1 = I1MACH(14) - 1 AA = R1M5*DBLE(FLOAT(K1)) DIG = DMIN1(AA,18.0D0) AA = AA*2.303D0 ALIM = ELIM + DMAX1(-AA,-41.45D0) FNUL = 10.0D0 + 6.0D0*(DIG-3.0D0) RL = 1.2D0*DIG + 3.0D0 C----------------------------------------------------------------------------- C TEST FOR PROPER RANGE C----------------------------------------------------------------------- AZ = ZABS(COMPLEX(ZR,ZI)) FN = FNU + DBLE(FLOAT(NN-1)) AA = 0.5D0/TOL BB=DBLE(FLOAT(I1MACH(9)))*0.5D0 AA = DMIN1(AA,BB) IF (AZ.GT.AA) GO TO 260 IF (FN.GT.AA) GO TO 260 AA = DSQRT(AA) IF (AZ.GT.AA) IERR=3 IF (FN.GT.AA) IERR=3 C----------------------------------------------------------------------- C OVERFLOW TEST ON THE LAST MEMBER OF THE SEQUENCE C----------------------------------------------------------------------- C UFL = DEXP(-ELIM) UFL = D1MACH(1)*1.0D+3 IF (AZ.LT.UFL) GO TO 180 IF (FNU.GT.FNUL) GO TO 80 IF (FN.LE.1.0D0) GO TO 60 IF (FN.GT.2.0D0) GO TO 50 IF (AZ.GT.TOL) GO TO 60 ARG = 0.5D0*AZ ALN = -FN*DLOG(ARG) IF (ALN.GT.ELIM) GO TO 180 GO TO 60 50 CONTINUE CALL ZUOIK(ZR, ZI, FNU, KODE, 2, NN, CYR, CYI, NUF, TOL, ELIM, * ALIM) IF (NUF.LT.0) GO TO 180 NZ = NZ + NUF NN = NN - NUF C----------------------------------------------------------------------- C HERE NN=N OR NN=0 SINCE NUF=0,NN, OR -1 ON RETURN FROM CUOIK C IF NUF=NN, THEN CY(I)=CZERO FOR ALL I C----------------------------------------------------------------------- IF (NN.EQ.0) GO TO 100 60 CONTINUE IF (ZR.LT.0.0D0) GO TO 70 C----------------------------------------------------------------------- C RIGHT HALF PLANE COMPUTATION, REAL(Z).GE.0. C----------------------------------------------------------------------- CALL ZBKNU(ZR, ZI, FNU, KODE, NN, CYR, CYI, NW, TOL, ELIM, ALIM) IF (NW.LT.0) GO TO 200 NZ=NW RETURN C----------------------------------------------------------------------- C LEFT HALF PLANE COMPUTATION C PI/2.LT.ARG(Z).LE.PI AND -PI.LT.ARG(Z).LT.-PI/2. C----------------------------------------------------------------------- 70 CONTINUE IF (NZ.NE.0) GO TO 180 MR = 1 IF (ZI.LT.0.0D0) MR = -1 CALL ZACON(ZR, ZI, FNU, KODE, MR, NN, CYR, CYI, NW, RL, FNUL, * TOL, ELIM, ALIM) IF (NW.LT.0) GO TO 200 NZ=NW RETURN C----------------------------------------------------------------------- C UNIFORM ASYMPTOTIC EXPANSIONS FOR FNU.GT.FNUL C----------------------------------------------------------------------- 80 CONTINUE MR = 0 IF (ZR.GE.0.0D0) GO TO 90 MR = 1 IF (ZI.LT.0.0D0) MR = -1 90 CONTINUE CALL ZBUNK(ZR, ZI, FNU, KODE, MR, NN, CYR, CYI, NW, TOL, ELIM, * ALIM) IF (NW.LT.0) GO TO 200 NZ = NZ + NW RETURN 100 CONTINUE IF (ZR.LT.0.0D0) GO TO 180 RETURN 180 CONTINUE NZ = 0 IERR=2 RETURN 200 CONTINUE IF(NW.EQ.(-1)) GO TO 180 NZ=0 IERR=5 RETURN 260 CONTINUE NZ=0 IERR=4 RETURN END openspecfun-0.3/amos/zbesy.f000066400000000000000000000245621232445310600161540ustar00rootroot00000000000000 SUBROUTINE ZBESY(ZR, ZI, FNU, KODE, N, CYR, CYI, NZ, CWRKR, CWRKI, * IERR) C***BEGIN PROLOGUE ZBESY C***DATE WRITTEN 830501 (YYMMDD) C***REVISION DATE 890801 (YYMMDD) C***CATEGORY NO. B5K C***KEYWORDS Y-BESSEL FUNCTION,BESSEL FUNCTION OF COMPLEX ARGUMENT, C BESSEL FUNCTION OF SECOND KIND C***AUTHOR AMOS, DONALD E., SANDIA NATIONAL LABORATORIES C***PURPOSE TO COMPUTE THE Y-BESSEL FUNCTION OF A COMPLEX ARGUMENT C***DESCRIPTION C C ***A DOUBLE PRECISION ROUTINE*** C C ON KODE=1, CBESY COMPUTES AN N MEMBER SEQUENCE OF COMPLEX C BESSEL FUNCTIONS CY(I)=Y(FNU+I-1,Z) FOR REAL, NONNEGATIVE C ORDERS FNU+I-1, I=1,...,N AND COMPLEX Z IN THE CUT PLANE C -PI.LT.ARG(Z).LE.PI. ON KODE=2, CBESY RETURNS THE SCALED C FUNCTIONS C C CY(I)=EXP(-ABS(Y))*Y(FNU+I-1,Z) I = 1,...,N , Y=AIMAG(Z) C C WHICH REMOVE THE EXPONENTIAL GROWTH IN BOTH THE UPPER AND C LOWER HALF PLANES FOR Z TO INFINITY. DEFINITIONS AND NOTATION C ARE FOUND IN THE NBS HANDBOOK OF MATHEMATICAL FUNCTIONS C (REF. 1). C C INPUT ZR,ZI,FNU ARE DOUBLE PRECISION C ZR,ZI - Z=CMPLX(ZR,ZI), Z.NE.CMPLX(0.0D0,0.0D0), C -PI.LT.ARG(Z).LE.PI C FNU - ORDER OF INITIAL Y FUNCTION, FNU.GE.0.0D0 C KODE - A PARAMETER TO INDICATE THE SCALING OPTION C KODE= 1 RETURNS C CY(I)=Y(FNU+I-1,Z), I=1,...,N C = 2 RETURNS C CY(I)=Y(FNU+I-1,Z)*EXP(-ABS(Y)), I=1,...,N C WHERE Y=AIMAG(Z) C N - NUMBER OF MEMBERS OF THE SEQUENCE, N.GE.1 C CWRKR, - DOUBLE PRECISION WORK VECTORS OF DIMENSION AT C CWRKI AT LEAST N C C OUTPUT CYR,CYI ARE DOUBLE PRECISION C CYR,CYI- DOUBLE PRECISION VECTORS WHOSE FIRST N COMPONENTS C CONTAIN REAL AND IMAGINARY PARTS FOR THE SEQUENCE C CY(I)=Y(FNU+I-1,Z) OR C CY(I)=Y(FNU+I-1,Z)*EXP(-ABS(Y)) I=1,...,N C DEPENDING ON KODE. C NZ - NZ=0 , A NORMAL RETURN C NZ.GT.0 , NZ COMPONENTS OF CY SET TO ZERO DUE TO C UNDERFLOW (GENERALLY ON KODE=2) C IERR - ERROR FLAG C IERR=0, NORMAL RETURN - COMPUTATION COMPLETED C IERR=1, INPUT ERROR - NO COMPUTATION C IERR=2, OVERFLOW - NO COMPUTATION, FNU IS C TOO LARGE OR CABS(Z) IS TOO SMALL OR BOTH C IERR=3, CABS(Z) OR FNU+N-1 LARGE - COMPUTATION DONE C BUT LOSSES OF SIGNIFCANCE BY ARGUMENT C REDUCTION PRODUCE LESS THAN HALF OF MACHINE C ACCURACY C IERR=4, CABS(Z) OR FNU+N-1 TOO LARGE - NO COMPUTA- C TION BECAUSE OF COMPLETE LOSSES OF SIGNIFI- C CANCE BY ARGUMENT REDUCTION C IERR=5, ERROR - NO COMPUTATION, C ALGORITHM TERMINATION CONDITION NOT MET C C***LONG DESCRIPTION C C THE COMPUTATION IS CARRIED OUT BY THE FORMULA C C Y(FNU,Z)=0.5*(H(1,FNU,Z)-H(2,FNU,Z))/I C C WHERE I**2 = -1 AND THE HANKEL BESSEL FUNCTIONS H(1,FNU,Z) C AND H(2,FNU,Z) ARE CALCULATED IN CBESH. C C FOR NEGATIVE ORDERS,THE FORMULA C C Y(-FNU,Z) = Y(FNU,Z)*COS(PI*FNU) + J(FNU,Z)*SIN(PI*FNU) C C CAN BE USED. HOWEVER,FOR LARGE ORDERS CLOSE TO HALF ODD C INTEGERS THE FUNCTION CHANGES RADICALLY. WHEN FNU IS A LARGE C POSITIVE HALF ODD INTEGER,THE MAGNITUDE OF Y(-FNU,Z)=J(FNU,Z)* C SIN(PI*FNU) IS A LARGE NEGATIVE POWER OF TEN. BUT WHEN FNU IS C NOT A HALF ODD INTEGER, Y(FNU,Z) DOMINATES IN MAGNITUDE WITH A C LARGE POSITIVE POWER OF TEN AND THE MOST THAT THE SECOND TERM C CAN BE REDUCED IS BY UNIT ROUNDOFF FROM THE COEFFICIENT. THUS, C WIDE CHANGES CAN OCCUR WITHIN UNIT ROUNDOFF OF A LARGE HALF C ODD INTEGER. HERE, LARGE MEANS FNU.GT.CABS(Z). C C IN MOST COMPLEX VARIABLE COMPUTATION, ONE MUST EVALUATE ELE- C MENTARY FUNCTIONS. WHEN THE MAGNITUDE OF Z OR FNU+N-1 IS C LARGE, LOSSES OF SIGNIFICANCE BY ARGUMENT REDUCTION OCCUR. C CONSEQUENTLY, IF EITHER ONE EXCEEDS U1=SQRT(0.5/UR), THEN C LOSSES EXCEEDING HALF PRECISION ARE LIKELY AND AN ERROR FLAG C IERR=3 IS TRIGGERED WHERE UR=DMAX1(D1MACH(4),1.0D-18) IS C DOUBLE PRECISION UNIT ROUNDOFF LIMITED TO 18 DIGITS PRECISION. C IF EITHER IS LARGER THAN U2=0.5/UR, THEN ALL SIGNIFICANCE IS C LOST AND IERR=4. IN ORDER TO USE THE INT FUNCTION, ARGUMENTS C MUST BE FURTHER RESTRICTED NOT TO EXCEED THE LARGEST MACHINE C INTEGER, U3=I1MACH(9). THUS, THE MAGNITUDE OF Z AND FNU+N-1 IS C RESTRICTED BY MIN(U2,U3). ON 32 BIT MACHINES, U1,U2, AND U3 C ARE APPROXIMATELY 2.0E+3, 4.2E+6, 2.1E+9 IN SINGLE PRECISION C ARITHMETIC AND 1.3E+8, 1.8E+16, 2.1E+9 IN DOUBLE PRECISION C ARITHMETIC RESPECTIVELY. THIS MAKES U2 AND U3 LIMITING IN C THEIR RESPECTIVE ARITHMETICS. THIS MEANS THAT ONE CAN EXPECT C TO RETAIN, IN THE WORST CASES ON 32 BIT MACHINES, NO DIGITS C IN SINGLE AND ONLY 7 DIGITS IN DOUBLE PRECISION ARITHMETIC. C SIMILAR CONSIDERATIONS HOLD FOR OTHER MACHINES. C C THE APPROXIMATE RELATIVE ERROR IN THE MAGNITUDE OF A COMPLEX C BESSEL FUNCTION CAN BE EXPRESSED BY P*10**S WHERE P=MAX(UNIT C ROUNDOFF,1.0E-18) IS THE NOMINAL PRECISION AND 10**S REPRE- C SENTS THE INCREASE IN ERROR DUE TO ARGUMENT REDUCTION IN THE C ELEMENTARY FUNCTIONS. HERE, S=MAX(1,ABS(LOG10(CABS(Z))), C ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF C CABS(Z),ABS(EXPONENT OF FNU)) ). HOWEVER, THE PHASE ANGLE MAY C HAVE ONLY ABSOLUTE ACCURACY. THIS IS MOST LIKELY TO OCCUR WHEN C ONE COMPONENT (IN ABSOLUTE VALUE) IS LARGER THAN THE OTHER BY C SEVERAL ORDERS OF MAGNITUDE. IF ONE COMPONENT IS 10**K LARGER C THAN THE OTHER, THEN ONE CAN EXPECT ONLY MAX(ABS(LOG10(P))-K, C 0) SIGNIFICANT DIGITS; OR, STATED ANOTHER WAY, WHEN K EXCEEDS C THE EXPONENT OF P, NO SIGNIFICANT DIGITS REMAIN IN THE SMALLER C COMPONENT. HOWEVER, THE PHASE ANGLE RETAINS ABSOLUTE ACCURACY C BECAUSE, IN COMPLEX ARITHMETIC WITH PRECISION P, THE SMALLER C COMPONENT WILL NOT (AS A RULE) DECREASE BELOW P TIMES THE C MAGNITUDE OF THE LARGER COMPONENT. IN THESE EXTREME CASES, C THE PRINCIPAL PHASE ANGLE IS ON THE ORDER OF +P, -P, PI/2-P, C OR -PI/2+P. C C***REFERENCES HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ C AND I. A. STEGUN, NBS AMS SERIES 55, U.S. DEPT. OF C COMMERCE, 1955. C C COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT C BY D. E. AMOS, SAND83-0083, MAY, 1983. C C COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT C AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983 C C A SUBROUTINE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85- C 1018, MAY, 1985 C C A PORTABLE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, TRANS. C MATH. SOFTWARE, 1986 C C***ROUTINES CALLED ZBESH,I1MACH,D1MACH C***END PROLOGUE ZBESY C C COMPLEX CWRK,CY,C1,C2,EX,HCI,Z,ZU,ZV DOUBLE PRECISION CWRKI, CWRKR, CYI, CYR, C1I, C1R, C2I, C2R, * ELIM, EXI, EXR, EY, FNU, HCII, STI, STR, TAY, ZI, ZR, DEXP, * D1MACH, ASCLE, RTOL, ATOL, AA, BB, TOL INTEGER I, IERR, K, KODE, K1, K2, N, NZ, NZ1, NZ2, I1MACH DIMENSION CYR(N), CYI(N), CWRKR(N), CWRKI(N) C***FIRST EXECUTABLE STATEMENT ZBESY IERR = 0 NZ=0 IF (ZR.EQ.0.0D0 .AND. ZI.EQ.0.0D0) IERR=1 IF (FNU.LT.0.0D0) IERR=1 IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1 IF (N.LT.1) IERR=1 IF (IERR.NE.0) RETURN HCII = 0.5D0 CALL ZBESH(ZR, ZI, FNU, KODE, 1, N, CYR, CYI, NZ1, IERR) IF (IERR.NE.0.AND.IERR.NE.3) GO TO 170 CALL ZBESH(ZR, ZI, FNU, KODE, 2, N, CWRKR, CWRKI, NZ2, IERR) IF (IERR.NE.0.AND.IERR.NE.3) GO TO 170 NZ = MIN0(NZ1,NZ2) IF (KODE.EQ.2) GO TO 60 DO 50 I=1,N STR = CWRKR(I) - CYR(I) STI = CWRKI(I) - CYI(I) CYR(I) = -STI*HCII CYI(I) = STR*HCII 50 CONTINUE RETURN 60 CONTINUE TOL = DMAX1(D1MACH(4),1.0D-18) K1 = I1MACH(15) K2 = I1MACH(16) K = MIN0(IABS(K1),IABS(K2)) R1M5 = D1MACH(5) C----------------------------------------------------------------------- C ELIM IS THE APPROXIMATE EXPONENTIAL UNDER- AND OVERFLOW LIMIT C----------------------------------------------------------------------- ELIM = 2.303D0*(DBLE(FLOAT(K))*R1M5-3.0D0) EXR = DCOS(ZR) EXI = DSIN(ZR) EY = 0.0D0 TAY = DABS(ZI+ZI) IF (TAY.LT.ELIM) EY = DEXP(-TAY) IF (ZI.LT.0.0D0) GO TO 90 C1R = EXR*EY C1I = EXI*EY C2R = EXR C2I = -EXI 70 CONTINUE NZ = 0 RTOL = 1.0D0/TOL ASCLE = D1MACH(1)*RTOL*1.0D+3 DO 80 I=1,N C STR = C1R*CYR(I) - C1I*CYI(I) C STI = C1R*CYI(I) + C1I*CYR(I) C STR = -STR + C2R*CWRKR(I) - C2I*CWRKI(I) C STI = -STI + C2R*CWRKI(I) + C2I*CWRKR(I) C CYR(I) = -STI*HCII C CYI(I) = STR*HCII AA = CWRKR(I) BB = CWRKI(I) ATOL = 1.0D0 IF (DMAX1(DABS(AA),DABS(BB)).GT.ASCLE) GO TO 75 AA = AA*RTOL BB = BB*RTOL ATOL = TOL 75 CONTINUE STR = (AA*C2R - BB*C2I)*ATOL STI = (AA*C2I + BB*C2R)*ATOL AA = CYR(I) BB = CYI(I) ATOL = 1.0D0 IF (DMAX1(DABS(AA),DABS(BB)).GT.ASCLE) GO TO 85 AA = AA*RTOL BB = BB*RTOL ATOL = TOL 85 CONTINUE STR = STR - (AA*C1R - BB*C1I)*ATOL STI = STI - (AA*C1I + BB*C1R)*ATOL CYR(I) = -STI*HCII CYI(I) = STR*HCII IF (STR.EQ.0.0D0 .AND. STI.EQ.0.0D0 .AND. EY.EQ.0.0D0) NZ = NZ * + 1 80 CONTINUE RETURN 90 CONTINUE C1R = EXR C1I = EXI C2R = EXR*EY C2I = -EXI*EY GO TO 70 170 CONTINUE NZ = 0 RETURN END openspecfun-0.3/amos/zbinu.f000066400000000000000000000075171232445310600161500ustar00rootroot00000000000000 SUBROUTINE ZBINU(ZR, ZI, FNU, KODE, N, CYR, CYI, NZ, RL, FNUL, * TOL, ELIM, ALIM) C***BEGIN PROLOGUE ZBINU C***REFER TO ZBESH,ZBESI,ZBESJ,ZBESK,ZAIRY,ZBIRY C C ZBINU COMPUTES THE I FUNCTION IN THE RIGHT HALF Z PLANE C C***ROUTINES CALLED ZABS,ZASYI,ZBUNI,ZMLRI,ZSERI,ZUOIK,ZWRSK C***END PROLOGUE ZBINU DOUBLE PRECISION ALIM, AZ, CWI, CWR, CYI, CYR, DFNU, ELIM, FNU, * FNUL, RL, TOL, ZEROI, ZEROR, ZI, ZR, ZABS INTEGER I, INW, KODE, N, NLAST, NN, NUI, NW, NZ DIMENSION CYR(N), CYI(N), CWR(2), CWI(2) DATA ZEROR,ZEROI / 0.0D0, 0.0D0 / C NZ = 0 AZ = ZABS(COMPLEX(ZR,ZI)) NN = N DFNU = FNU + DBLE(FLOAT(N-1)) IF (AZ.LE.2.0D0) GO TO 10 IF (AZ*AZ*0.25D0.GT.DFNU+1.0D0) GO TO 20 10 CONTINUE C----------------------------------------------------------------------- C POWER SERIES C----------------------------------------------------------------------- CALL ZSERI(ZR, ZI, FNU, KODE, NN, CYR, CYI, NW, TOL, ELIM, ALIM) INW = IABS(NW) NZ = NZ + INW NN = NN - INW IF (NN.EQ.0) RETURN IF (NW.GE.0) GO TO 120 DFNU = FNU + DBLE(FLOAT(NN-1)) 20 CONTINUE IF (AZ.LT.RL) GO TO 40 IF (DFNU.LE.1.0D0) GO TO 30 IF (AZ+AZ.LT.DFNU*DFNU) GO TO 50 C----------------------------------------------------------------------- C ASYMPTOTIC EXPANSION FOR LARGE Z C----------------------------------------------------------------------- 30 CONTINUE CALL ZASYI(ZR, ZI, FNU, KODE, NN, CYR, CYI, NW, RL, TOL, ELIM, * ALIM) IF (NW.LT.0) GO TO 130 GO TO 120 40 CONTINUE IF (DFNU.LE.1.0D0) GO TO 70 50 CONTINUE C----------------------------------------------------------------------- C OVERFLOW AND UNDERFLOW TEST ON I SEQUENCE FOR MILLER ALGORITHM C----------------------------------------------------------------------- CALL ZUOIK(ZR, ZI, FNU, KODE, 1, NN, CYR, CYI, NW, TOL, ELIM, * ALIM) IF (NW.LT.0) GO TO 130 NZ = NZ + NW NN = NN - NW IF (NN.EQ.0) RETURN DFNU = FNU+DBLE(FLOAT(NN-1)) IF (DFNU.GT.FNUL) GO TO 110 IF (AZ.GT.FNUL) GO TO 110 60 CONTINUE IF (AZ.GT.RL) GO TO 80 70 CONTINUE C----------------------------------------------------------------------- C MILLER ALGORITHM NORMALIZED BY THE SERIES C----------------------------------------------------------------------- CALL ZMLRI(ZR, ZI, FNU, KODE, NN, CYR, CYI, NW, TOL) IF(NW.LT.0) GO TO 130 GO TO 120 80 CONTINUE C----------------------------------------------------------------------- C MILLER ALGORITHM NORMALIZED BY THE WRONSKIAN C----------------------------------------------------------------------- C----------------------------------------------------------------------- C OVERFLOW TEST ON K FUNCTIONS USED IN WRONSKIAN C----------------------------------------------------------------------- CALL ZUOIK(ZR, ZI, FNU, KODE, 2, 2, CWR, CWI, NW, TOL, ELIM, * ALIM) IF (NW.GE.0) GO TO 100 NZ = NN DO 90 I=1,NN CYR(I) = ZEROR CYI(I) = ZEROI 90 CONTINUE RETURN 100 CONTINUE IF (NW.GT.0) GO TO 130 CALL ZWRSK(ZR, ZI, FNU, KODE, NN, CYR, CYI, NW, CWR, CWI, TOL, * ELIM, ALIM) IF (NW.LT.0) GO TO 130 GO TO 120 110 CONTINUE C----------------------------------------------------------------------- C INCREMENT FNU+NN-1 UP TO FNUL, COMPUTE AND RECUR BACKWARD C----------------------------------------------------------------------- NUI = INT(SNGL(FNUL-DFNU)) + 1 NUI = MAX0(NUI,0) CALL ZBUNI(ZR, ZI, FNU, KODE, NN, CYR, CYI, NW, NUI, NLAST, FNUL, * TOL, ELIM, ALIM) IF (NW.LT.0) GO TO 130 NZ = NZ + NW IF (NLAST.EQ.0) GO TO 120 NN = NLAST GO TO 60 120 CONTINUE RETURN 130 CONTINUE NZ = -1 IF(NW.EQ.(-2)) NZ=-2 RETURN END openspecfun-0.3/amos/zbiry.f000066400000000000000000000336611232445310600161570ustar00rootroot00000000000000 SUBROUTINE ZBIRY(ZR, ZI, ID, KODE, BIR, BII, IERR) C***BEGIN PROLOGUE ZBIRY C***DATE WRITTEN 830501 (YYMMDD) C***REVISION DATE 890801 (YYMMDD) C***CATEGORY NO. B5K C***KEYWORDS AIRY FUNCTION,BESSEL FUNCTIONS OF ORDER ONE THIRD C***AUTHOR AMOS, DONALD E., SANDIA NATIONAL LABORATORIES C***PURPOSE TO COMPUTE AIRY FUNCTIONS BI(Z) AND DBI(Z) FOR COMPLEX Z C***DESCRIPTION C C ***A DOUBLE PRECISION ROUTINE*** C ON KODE=1, CBIRY COMPUTES THE COMPLEX AIRY FUNCTION BI(Z) OR C ITS DERIVATIVE DBI(Z)/DZ ON ID=0 OR ID=1 RESPECTIVELY. ON C KODE=2, A SCALING OPTION CEXP(-AXZTA)*BI(Z) OR CEXP(-AXZTA)* C DBI(Z)/DZ IS PROVIDED TO REMOVE THE EXPONENTIAL BEHAVIOR IN C BOTH THE LEFT AND RIGHT HALF PLANES WHERE C ZTA=(2/3)*Z*CSQRT(Z)=CMPLX(XZTA,YZTA) AND AXZTA=ABS(XZTA). C DEFINTIONS AND NOTATION ARE FOUND IN THE NBS HANDBOOK OF C MATHEMATICAL FUNCTIONS (REF. 1). C C INPUT ZR,ZI ARE DOUBLE PRECISION C ZR,ZI - Z=CMPLX(ZR,ZI) C ID - ORDER OF DERIVATIVE, ID=0 OR ID=1 C KODE - A PARAMETER TO INDICATE THE SCALING OPTION C KODE= 1 RETURNS C BI=BI(Z) ON ID=0 OR C BI=DBI(Z)/DZ ON ID=1 C = 2 RETURNS C BI=CEXP(-AXZTA)*BI(Z) ON ID=0 OR C BI=CEXP(-AXZTA)*DBI(Z)/DZ ON ID=1 WHERE C ZTA=(2/3)*Z*CSQRT(Z)=CMPLX(XZTA,YZTA) C AND AXZTA=ABS(XZTA) C C OUTPUT BIR,BII ARE DOUBLE PRECISION C BIR,BII- COMPLEX ANSWER DEPENDING ON THE CHOICES FOR ID AND C KODE C IERR - ERROR FLAG C IERR=0, NORMAL RETURN - COMPUTATION COMPLETED C IERR=1, INPUT ERROR - NO COMPUTATION C IERR=2, OVERFLOW - NO COMPUTATION, REAL(Z) C TOO LARGE ON KODE=1 C IERR=3, CABS(Z) LARGE - COMPUTATION COMPLETED C LOSSES OF SIGNIFCANCE BY ARGUMENT REDUCTION C PRODUCE LESS THAN HALF OF MACHINE ACCURACY C IERR=4, CABS(Z) TOO LARGE - NO COMPUTATION C COMPLETE LOSS OF ACCURACY BY ARGUMENT C REDUCTION C IERR=5, ERROR - NO COMPUTATION, C ALGORITHM TERMINATION CONDITION NOT MET C C***LONG DESCRIPTION C C BI AND DBI ARE COMPUTED FOR CABS(Z).GT.1.0 FROM THE I BESSEL C FUNCTIONS BY C C BI(Z)=C*SQRT(Z)*( I(-1/3,ZTA) + I(1/3,ZTA) ) C DBI(Z)=C * Z * ( I(-2/3,ZTA) + I(2/3,ZTA) ) C C=1.0/SQRT(3.0) C ZTA=(2/3)*Z**(3/2) C C WITH THE POWER SERIES FOR CABS(Z).LE.1.0. C C IN MOST COMPLEX VARIABLE COMPUTATION, ONE MUST EVALUATE ELE- C MENTARY FUNCTIONS. WHEN THE MAGNITUDE OF Z IS LARGE, LOSSES C OF SIGNIFICANCE BY ARGUMENT REDUCTION OCCUR. CONSEQUENTLY, IF C THE MAGNITUDE OF ZETA=(2/3)*Z**1.5 EXCEEDS U1=SQRT(0.5/UR), C THEN LOSSES EXCEEDING HALF PRECISION ARE LIKELY AND AN ERROR C FLAG IERR=3 IS TRIGGERED WHERE UR=DMAX1(D1MACH(4),1.0D-18) IS C DOUBLE PRECISION UNIT ROUNDOFF LIMITED TO 18 DIGITS PRECISION. C ALSO, IF THE MAGNITUDE OF ZETA IS LARGER THAN U2=0.5/UR, THEN C ALL SIGNIFICANCE IS LOST AND IERR=4. IN ORDER TO USE THE INT C FUNCTION, ZETA MUST BE FURTHER RESTRICTED NOT TO EXCEED THE C LARGEST INTEGER, U3=I1MACH(9). THUS, THE MAGNITUDE OF ZETA C MUST BE RESTRICTED BY MIN(U2,U3). ON 32 BIT MACHINES, U1,U2, C AND U3 ARE APPROXIMATELY 2.0E+3, 4.2E+6, 2.1E+9 IN SINGLE C PRECISION ARITHMETIC AND 1.3E+8, 1.8E+16, 2.1E+9 IN DOUBLE C PRECISION ARITHMETIC RESPECTIVELY. THIS MAKES U2 AND U3 LIMIT- C ING IN THEIR RESPECTIVE ARITHMETICS. THIS MEANS THAT THE MAG- C NITUDE OF Z CANNOT EXCEED 3.1E+4 IN SINGLE AND 2.1E+6 IN C DOUBLE PRECISION ARITHMETIC. THIS ALSO MEANS THAT ONE CAN C EXPECT TO RETAIN, IN THE WORST CASES ON 32 BIT MACHINES, C NO DIGITS IN SINGLE PRECISION AND ONLY 7 DIGITS IN DOUBLE C PRECISION ARITHMETIC. SIMILAR CONSIDERATIONS HOLD FOR OTHER C MACHINES. C C THE APPROXIMATE RELATIVE ERROR IN THE MAGNITUDE OF A COMPLEX C BESSEL FUNCTION CAN BE EXPRESSED BY P*10**S WHERE P=MAX(UNIT C ROUNDOFF,1.0E-18) IS THE NOMINAL PRECISION AND 10**S REPRE- C SENTS THE INCREASE IN ERROR DUE TO ARGUMENT REDUCTION IN THE C ELEMENTARY FUNCTIONS. HERE, S=MAX(1,ABS(LOG10(CABS(Z))), C ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF C CABS(Z),ABS(EXPONENT OF FNU)) ). HOWEVER, THE PHASE ANGLE MAY C HAVE ONLY ABSOLUTE ACCURACY. THIS IS MOST LIKELY TO OCCUR WHEN C ONE COMPONENT (IN ABSOLUTE VALUE) IS LARGER THAN THE OTHER BY C SEVERAL ORDERS OF MAGNITUDE. IF ONE COMPONENT IS 10**K LARGER C THAN THE OTHER, THEN ONE CAN EXPECT ONLY MAX(ABS(LOG10(P))-K, C 0) SIGNIFICANT DIGITS; OR, STATED ANOTHER WAY, WHEN K EXCEEDS C THE EXPONENT OF P, NO SIGNIFICANT DIGITS REMAIN IN THE SMALLER C COMPONENT. HOWEVER, THE PHASE ANGLE RETAINS ABSOLUTE ACCURACY C BECAUSE, IN COMPLEX ARITHMETIC WITH PRECISION P, THE SMALLER C COMPONENT WILL NOT (AS A RULE) DECREASE BELOW P TIMES THE C MAGNITUDE OF THE LARGER COMPONENT. IN THESE EXTREME CASES, C THE PRINCIPAL PHASE ANGLE IS ON THE ORDER OF +P, -P, PI/2-P, C OR -PI/2+P. C C***REFERENCES HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ C AND I. A. STEGUN, NBS AMS SERIES 55, U.S. DEPT. OF C COMMERCE, 1955. C C COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT C AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983 C C A SUBROUTINE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85- C 1018, MAY, 1985 C C A PORTABLE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, TRANS. C MATH. SOFTWARE, 1986 C C***ROUTINES CALLED ZBINU,ZABS,ZDIV,ZSQRT,D1MACH,I1MACH C***END PROLOGUE ZBIRY C COMPLEX BI,CONE,CSQ,CY,S1,S2,TRM1,TRM2,Z,ZTA,Z3 DOUBLE PRECISION AA, AD, AK, ALIM, ATRM, AZ, AZ3, BB, BII, BIR, * BK, CC, CK, COEF, CONEI, CONER, CSQI, CSQR, CYI, CYR, C1, C2, * DIG, DK, D1, D2, EAA, ELIM, FID, FMR, FNU, FNUL, PI, RL, R1M5, * SFAC, STI, STR, S1I, S1R, S2I, S2R, TOL, TRM1I, TRM1R, TRM2I, * TRM2R, TTH, ZI, ZR, ZTAI, ZTAR, Z3I, Z3R, D1MACH, ZABS INTEGER ID, IERR, K, KODE, K1, K2, NZ, I1MACH DIMENSION CYR(2), CYI(2) DATA TTH, C1, C2, COEF, PI /6.66666666666666667D-01, * 6.14926627446000736D-01,4.48288357353826359D-01, * 5.77350269189625765D-01,3.14159265358979324D+00/ DATA CONER, CONEI /1.0D0,0.0D0/ C***FIRST EXECUTABLE STATEMENT ZBIRY IERR = 0 NZ=0 IF (ID.LT.0 .OR. ID.GT.1) IERR=1 IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1 IF (IERR.NE.0) RETURN AZ = ZABS(COMPLEX(ZR,ZI)) TOL = DMAX1(D1MACH(4),1.0D-18) FID = DBLE(FLOAT(ID)) IF (AZ.GT.1.0E0) GO TO 70 C----------------------------------------------------------------------- C POWER SERIES FOR CABS(Z).LE.1. C----------------------------------------------------------------------- S1R = CONER S1I = CONEI S2R = CONER S2I = CONEI IF (AZ.LT.TOL) GO TO 130 AA = AZ*AZ IF (AA.LT.TOL/AZ) GO TO 40 TRM1R = CONER TRM1I = CONEI TRM2R = CONER TRM2I = CONEI ATRM = 1.0D0 STR = ZR*ZR - ZI*ZI STI = ZR*ZI + ZI*ZR Z3R = STR*ZR - STI*ZI Z3I = STR*ZI + STI*ZR AZ3 = AZ*AA AK = 2.0D0 + FID BK = 3.0D0 - FID - FID CK = 4.0D0 - FID DK = 3.0D0 + FID + FID D1 = AK*DK D2 = BK*CK AD = DMIN1(D1,D2) AK = 24.0D0 + 9.0D0*FID BK = 30.0D0 - 9.0D0*FID DO 30 K=1,25 STR = (TRM1R*Z3R-TRM1I*Z3I)/D1 TRM1I = (TRM1R*Z3I+TRM1I*Z3R)/D1 TRM1R = STR S1R = S1R + TRM1R S1I = S1I + TRM1I STR = (TRM2R*Z3R-TRM2I*Z3I)/D2 TRM2I = (TRM2R*Z3I+TRM2I*Z3R)/D2 TRM2R = STR S2R = S2R + TRM2R S2I = S2I + TRM2I ATRM = ATRM*AZ3/AD D1 = D1 + AK D2 = D2 + BK AD = DMIN1(D1,D2) IF (ATRM.LT.TOL*AD) GO TO 40 AK = AK + 18.0D0 BK = BK + 18.0D0 30 CONTINUE 40 CONTINUE IF (ID.EQ.1) GO TO 50 BIR = C1*S1R + C2*(ZR*S2R-ZI*S2I) BII = C1*S1I + C2*(ZR*S2I+ZI*S2R) IF (KODE.EQ.1) RETURN CALL ZSQRT(ZR, ZI, STR, STI) ZTAR = TTH*(ZR*STR-ZI*STI) ZTAI = TTH*(ZR*STI+ZI*STR) AA = ZTAR AA = -DABS(AA) EAA = DEXP(AA) BIR = BIR*EAA BII = BII*EAA RETURN 50 CONTINUE BIR = S2R*C2 BII = S2I*C2 IF (AZ.LE.TOL) GO TO 60 CC = C1/(1.0D0+FID) STR = S1R*ZR - S1I*ZI STI = S1R*ZI + S1I*ZR BIR = BIR + CC*(STR*ZR-STI*ZI) BII = BII + CC*(STR*ZI+STI*ZR) 60 CONTINUE IF (KODE.EQ.1) RETURN CALL ZSQRT(ZR, ZI, STR, STI) ZTAR = TTH*(ZR*STR-ZI*STI) ZTAI = TTH*(ZR*STI+ZI*STR) AA = ZTAR AA = -DABS(AA) EAA = DEXP(AA) BIR = BIR*EAA BII = BII*EAA RETURN C----------------------------------------------------------------------- C CASE FOR CABS(Z).GT.1.0 C----------------------------------------------------------------------- 70 CONTINUE FNU = (1.0D0+FID)/3.0D0 C----------------------------------------------------------------------- C SET PARAMETERS RELATED TO MACHINE CONSTANTS. C TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18. C ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT. C EXP(-ELIM).LT.EXP(-ALIM)=EXP(-ELIM)/TOL AND C EXP(ELIM).GT.EXP(ALIM)=EXP(ELIM)*TOL ARE INTERVALS NEAR C UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE. C RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z. C DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG). C FNUL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC SERIES FOR LARGE FNU. C----------------------------------------------------------------------- K1 = I1MACH(15) K2 = I1MACH(16) R1M5 = D1MACH(5) K = MIN0(IABS(K1),IABS(K2)) ELIM = 2.303D0*(DBLE(FLOAT(K))*R1M5-3.0D0) K1 = I1MACH(14) - 1 AA = R1M5*DBLE(FLOAT(K1)) DIG = DMIN1(AA,18.0D0) AA = AA*2.303D0 ALIM = ELIM + DMAX1(-AA,-41.45D0) RL = 1.2D0*DIG + 3.0D0 FNUL = 10.0D0 + 6.0D0*(DIG-3.0D0) C----------------------------------------------------------------------- C TEST FOR RANGE C----------------------------------------------------------------------- AA=0.5D0/TOL BB=DBLE(FLOAT(I1MACH(9)))*0.5D0 AA=DMIN1(AA,BB) AA=AA**TTH IF (AZ.GT.AA) GO TO 260 AA=DSQRT(AA) IF (AZ.GT.AA) IERR=3 CALL ZSQRT(ZR, ZI, CSQR, CSQI) ZTAR = TTH*(ZR*CSQR-ZI*CSQI) ZTAI = TTH*(ZR*CSQI+ZI*CSQR) C----------------------------------------------------------------------- C RE(ZTA).LE.0 WHEN RE(Z).LT.0, ESPECIALLY WHEN IM(Z) IS SMALL C----------------------------------------------------------------------- SFAC = 1.0D0 AK = ZTAI IF (ZR.GE.0.0D0) GO TO 80 BK = ZTAR CK = -DABS(BK) ZTAR = CK ZTAI = AK 80 CONTINUE IF (ZI.NE.0.0D0 .OR. ZR.GT.0.0D0) GO TO 90 ZTAR = 0.0D0 ZTAI = AK 90 CONTINUE AA = ZTAR IF (KODE.EQ.2) GO TO 100 C----------------------------------------------------------------------- C OVERFLOW TEST C----------------------------------------------------------------------- BB = DABS(AA) IF (BB.LT.ALIM) GO TO 100 BB = BB + 0.25D0*DLOG(AZ) SFAC = TOL IF (BB.GT.ELIM) GO TO 190 100 CONTINUE FMR = 0.0D0 IF (AA.GE.0.0D0 .AND. ZR.GT.0.0D0) GO TO 110 FMR = PI IF (ZI.LT.0.0D0) FMR = -PI ZTAR = -ZTAR ZTAI = -ZTAI 110 CONTINUE C----------------------------------------------------------------------- C AA=FACTOR FOR ANALYTIC CONTINUATION OF I(FNU,ZTA) C KODE=2 RETURNS EXP(-ABS(XZTA))*I(FNU,ZTA) FROM CBESI C----------------------------------------------------------------------- CALL ZBINU(ZTAR, ZTAI, FNU, KODE, 1, CYR, CYI, NZ, RL, FNUL, TOL, * ELIM, ALIM) IF (NZ.LT.0) GO TO 200 AA = FMR*FNU Z3R = SFAC STR = DCOS(AA) STI = DSIN(AA) S1R = (STR*CYR(1)-STI*CYI(1))*Z3R S1I = (STR*CYI(1)+STI*CYR(1))*Z3R FNU = (2.0D0-FID)/3.0D0 CALL ZBINU(ZTAR, ZTAI, FNU, KODE, 2, CYR, CYI, NZ, RL, FNUL, TOL, * ELIM, ALIM) CYR(1) = CYR(1)*Z3R CYI(1) = CYI(1)*Z3R CYR(2) = CYR(2)*Z3R CYI(2) = CYI(2)*Z3R C----------------------------------------------------------------------- C BACKWARD RECUR ONE STEP FOR ORDERS -1/3 OR -2/3 C----------------------------------------------------------------------- CALL ZDIV(CYR(1), CYI(1), ZTAR, ZTAI, STR, STI) S2R = (FNU+FNU)*STR + CYR(2) S2I = (FNU+FNU)*STI + CYI(2) AA = FMR*(FNU-1.0D0) STR = DCOS(AA) STI = DSIN(AA) S1R = COEF*(S1R+S2R*STR-S2I*STI) S1I = COEF*(S1I+S2R*STI+S2I*STR) IF (ID.EQ.1) GO TO 120 STR = CSQR*S1R - CSQI*S1I S1I = CSQR*S1I + CSQI*S1R S1R = STR BIR = S1R/SFAC BII = S1I/SFAC RETURN 120 CONTINUE STR = ZR*S1R - ZI*S1I S1I = ZR*S1I + ZI*S1R S1R = STR BIR = S1R/SFAC BII = S1I/SFAC RETURN 130 CONTINUE AA = C1*(1.0D0-FID) + FID*C2 BIR = AA BII = 0.0D0 RETURN 190 CONTINUE IERR=2 NZ=0 RETURN 200 CONTINUE IF(NZ.EQ.(-1)) GO TO 190 NZ=0 IERR=5 RETURN 260 CONTINUE IERR=4 NZ=0 RETURN END openspecfun-0.3/amos/zbknu.f000066400000000000000000000412521232445310600161440ustar00rootroot00000000000000 SUBROUTINE ZBKNU(ZR, ZI, FNU, KODE, N, YR, YI, NZ, TOL, ELIM, * ALIM) C***BEGIN PROLOGUE ZBKNU C***REFER TO ZBESI,ZBESK,ZAIRY,ZBESH C C ZBKNU COMPUTES THE K BESSEL FUNCTION IN THE RIGHT HALF Z PLANE. C C***ROUTINES CALLED DGAMLN,I1MACH,D1MACH,ZKSCL,ZSHCH,ZUCHK,ZABS,ZDIV, C ZEXP,ZLOG,ZMLT,ZSQRT C***END PROLOGUE ZBKNU C DOUBLE PRECISION AA, AK, ALIM, ASCLE, A1, A2, BB, BK, BRY, CAZ, * CBI, CBR, CC, CCHI, CCHR, CKI, CKR, COEFI, COEFR, CONEI, CONER, * CRSCR, CSCLR, CSHI, CSHR, CSI, CSR, CSRR, CSSR, CTWOR, * CZEROI, CZEROR, CZI, CZR, DNU, DNU2, DPI, ELIM, ETEST, FC, FHS, * FI, FK, FKS, FMUI, FMUR, FNU, FPI, FR, G1, G2, HPI, PI, PR, PTI, * PTR, P1I, P1R, P2I, P2M, P2R, QI, QR, RAK, RCAZ, RTHPI, RZI, * RZR, R1, S, SMUI, SMUR, SPI, STI, STR, S1I, S1R, S2I, S2R, TM, * TOL, TTH, T1, T2, YI, YR, ZI, ZR, DGAMLN, D1MACH, ZABS, ELM, * CELMR, ZDR, ZDI, AS, ALAS, HELIM, CYR, CYI INTEGER I, IFLAG, INU, K, KFLAG, KK, KMAX, KODE, KODED, N, NZ, * IDUM, I1MACH, J, IC, INUB, NW DIMENSION YR(N), YI(N), CC(8), CSSR(3), CSRR(3), BRY(3), CYR(2), * CYI(2) C COMPLEX Z,Y,A,B,RZ,SMU,FU,FMU,F,FLRZ,CZ,S1,S2,CSH,CCH C COMPLEX CK,P,Q,COEF,P1,P2,CBK,PT,CZERO,CONE,CTWO,ST,EZ,CS,DK C DATA KMAX / 30 / DATA CZEROR,CZEROI,CONER,CONEI,CTWOR,R1/ 1 0.0D0 , 0.0D0 , 1.0D0 , 0.0D0 , 2.0D0 , 2.0D0 / DATA DPI, RTHPI, SPI ,HPI, FPI, TTH / 1 3.14159265358979324D0, 1.25331413731550025D0, 2 1.90985931710274403D0, 1.57079632679489662D0, 3 1.89769999331517738D0, 6.66666666666666666D-01/ DATA CC(1), CC(2), CC(3), CC(4), CC(5), CC(6), CC(7), CC(8)/ 1 5.77215664901532861D-01, -4.20026350340952355D-02, 2 -4.21977345555443367D-02, 7.21894324666309954D-03, 3 -2.15241674114950973D-04, -2.01348547807882387D-05, 4 1.13302723198169588D-06, 6.11609510448141582D-09/ C CAZ = ZABS(COMPLEX(ZR,ZI)) CSCLR = 1.0D0/TOL CRSCR = TOL CSSR(1) = CSCLR CSSR(2) = 1.0D0 CSSR(3) = CRSCR CSRR(1) = CRSCR CSRR(2) = 1.0D0 CSRR(3) = CSCLR BRY(1) = 1.0D+3*D1MACH(1)/TOL BRY(2) = 1.0D0/BRY(1) BRY(3) = D1MACH(2) NZ = 0 IFLAG = 0 KODED = KODE RCAZ = 1.0D0/CAZ STR = ZR*RCAZ STI = -ZI*RCAZ RZR = (STR+STR)*RCAZ RZI = (STI+STI)*RCAZ INU = INT(SNGL(FNU+0.5D0)) DNU = FNU - DBLE(FLOAT(INU)) IF (DABS(DNU).EQ.0.5D0) GO TO 110 DNU2 = 0.0D0 IF (DABS(DNU).GT.TOL) DNU2 = DNU*DNU IF (CAZ.GT.R1) GO TO 110 C----------------------------------------------------------------------- C SERIES FOR CABS(Z).LE.R1 C----------------------------------------------------------------------- FC = 1.0D0 CALL ZLOG(RZR, RZI, SMUR, SMUI, IDUM) FMUR = SMUR*DNU FMUI = SMUI*DNU CALL ZSHCH(FMUR, FMUI, CSHR, CSHI, CCHR, CCHI) IF (DNU.EQ.0.0D0) GO TO 10 FC = DNU*DPI FC = FC/DSIN(FC) SMUR = CSHR/DNU SMUI = CSHI/DNU 10 CONTINUE A2 = 1.0D0 + DNU C----------------------------------------------------------------------- C GAM(1-Z)*GAM(1+Z)=PI*Z/SIN(PI*Z), T1=1/GAM(1-DNU), T2=1/GAM(1+DNU) C----------------------------------------------------------------------- T2 = DEXP(-DGAMLN(A2,IDUM)) T1 = 1.0D0/(T2*FC) IF (DABS(DNU).GT.0.1D0) GO TO 40 C----------------------------------------------------------------------- C SERIES FOR F0 TO RESOLVE INDETERMINACY FOR SMALL ABS(DNU) C----------------------------------------------------------------------- AK = 1.0D0 S = CC(1) DO 20 K=2,8 AK = AK*DNU2 TM = CC(K)*AK S = S + TM IF (DABS(TM).LT.TOL) GO TO 30 20 CONTINUE 30 G1 = -S GO TO 50 40 CONTINUE G1 = (T1-T2)/(DNU+DNU) 50 CONTINUE G2 = (T1+T2)*0.5D0 FR = FC*(CCHR*G1+SMUR*G2) FI = FC*(CCHI*G1+SMUI*G2) CALL ZEXP(FMUR, FMUI, STR, STI) PR = 0.5D0*STR/T2 PI = 0.5D0*STI/T2 CALL ZDIV(0.5D0, 0.0D0, STR, STI, PTR, PTI) QR = PTR/T1 QI = PTI/T1 S1R = FR S1I = FI S2R = PR S2I = PI AK = 1.0D0 A1 = 1.0D0 CKR = CONER CKI = CONEI BK = 1.0D0 - DNU2 IF (INU.GT.0 .OR. N.GT.1) GO TO 80 C----------------------------------------------------------------------- C GENERATE K(FNU,Z), 0.0D0 .LE. FNU .LT. 0.5D0 AND N=1 C----------------------------------------------------------------------- IF (CAZ.LT.TOL) GO TO 70 CALL ZMLT(ZR, ZI, ZR, ZI, CZR, CZI) CZR = 0.25D0*CZR CZI = 0.25D0*CZI T1 = 0.25D0*CAZ*CAZ 60 CONTINUE FR = (FR*AK+PR+QR)/BK FI = (FI*AK+PI+QI)/BK STR = 1.0D0/(AK-DNU) PR = PR*STR PI = PI*STR STR = 1.0D0/(AK+DNU) QR = QR*STR QI = QI*STR STR = CKR*CZR - CKI*CZI RAK = 1.0D0/AK CKI = (CKR*CZI+CKI*CZR)*RAK CKR = STR*RAK S1R = CKR*FR - CKI*FI + S1R S1I = CKR*FI + CKI*FR + S1I A1 = A1*T1*RAK BK = BK + AK + AK + 1.0D0 AK = AK + 1.0D0 IF (A1.GT.TOL) GO TO 60 70 CONTINUE YR(1) = S1R YI(1) = S1I IF (KODED.EQ.1) RETURN CALL ZEXP(ZR, ZI, STR, STI) CALL ZMLT(S1R, S1I, STR, STI, YR(1), YI(1)) RETURN C----------------------------------------------------------------------- C GENERATE K(DNU,Z) AND K(DNU+1,Z) FOR FORWARD RECURRENCE C----------------------------------------------------------------------- 80 CONTINUE IF (CAZ.LT.TOL) GO TO 100 CALL ZMLT(ZR, ZI, ZR, ZI, CZR, CZI) CZR = 0.25D0*CZR CZI = 0.25D0*CZI T1 = 0.25D0*CAZ*CAZ 90 CONTINUE FR = (FR*AK+PR+QR)/BK FI = (FI*AK+PI+QI)/BK STR = 1.0D0/(AK-DNU) PR = PR*STR PI = PI*STR STR = 1.0D0/(AK+DNU) QR = QR*STR QI = QI*STR STR = CKR*CZR - CKI*CZI RAK = 1.0D0/AK CKI = (CKR*CZI+CKI*CZR)*RAK CKR = STR*RAK S1R = CKR*FR - CKI*FI + S1R S1I = CKR*FI + CKI*FR + S1I STR = PR - FR*AK STI = PI - FI*AK S2R = CKR*STR - CKI*STI + S2R S2I = CKR*STI + CKI*STR + S2I A1 = A1*T1*RAK BK = BK + AK + AK + 1.0D0 AK = AK + 1.0D0 IF (A1.GT.TOL) GO TO 90 100 CONTINUE KFLAG = 2 A1 = FNU + 1.0D0 AK = A1*DABS(SMUR) IF (AK.GT.ALIM) KFLAG = 3 STR = CSSR(KFLAG) P2R = S2R*STR P2I = S2I*STR CALL ZMLT(P2R, P2I, RZR, RZI, S2R, S2I) S1R = S1R*STR S1I = S1I*STR IF (KODED.EQ.1) GO TO 210 CALL ZEXP(ZR, ZI, FR, FI) CALL ZMLT(S1R, S1I, FR, FI, S1R, S1I) CALL ZMLT(S2R, S2I, FR, FI, S2R, S2I) GO TO 210 C----------------------------------------------------------------------- C IFLAG=0 MEANS NO UNDERFLOW OCCURRED C IFLAG=1 MEANS AN UNDERFLOW OCCURRED- COMPUTATION PROCEEDS WITH C KODED=2 AND A TEST FOR ON SCALE VALUES IS MADE DURING FORWARD C RECURSION C----------------------------------------------------------------------- 110 CONTINUE CALL ZSQRT(ZR, ZI, STR, STI) CALL ZDIV(RTHPI, CZEROI, STR, STI, COEFR, COEFI) KFLAG = 2 IF (KODED.EQ.2) GO TO 120 IF (ZR.GT.ALIM) GO TO 290 C BLANK LINE STR = DEXP(-ZR)*CSSR(KFLAG) STI = -STR*DSIN(ZI) STR = STR*DCOS(ZI) CALL ZMLT(COEFR, COEFI, STR, STI, COEFR, COEFI) 120 CONTINUE IF (DABS(DNU).EQ.0.5D0) GO TO 300 C----------------------------------------------------------------------- C MILLER ALGORITHM FOR CABS(Z).GT.R1 C----------------------------------------------------------------------- AK = DCOS(DPI*DNU) AK = DABS(AK) IF (AK.EQ.CZEROR) GO TO 300 FHS = DABS(0.25D0-DNU2) IF (FHS.EQ.CZEROR) GO TO 300 C----------------------------------------------------------------------- C COMPUTE R2=F(E). IF CABS(Z).GE.R2, USE FORWARD RECURRENCE TO C DETERMINE THE BACKWARD INDEX K. R2=F(E) IS A STRAIGHT LINE ON C 12.LE.E.LE.60. E IS COMPUTED FROM 2**(-E)=B**(1-I1MACH(14))= C TOL WHERE B IS THE BASE OF THE ARITHMETIC. C----------------------------------------------------------------------- T1 = DBLE(FLOAT(I1MACH(14)-1)) T1 = T1*D1MACH(5)*3.321928094D0 T1 = DMAX1(T1,12.0D0) T1 = DMIN1(T1,60.0D0) T2 = TTH*T1 - 6.0D0 IF (ZR.NE.0.0D0) GO TO 130 T1 = HPI GO TO 140 130 CONTINUE T1 = DATAN(ZI/ZR) T1 = DABS(T1) 140 CONTINUE IF (T2.GT.CAZ) GO TO 170 C----------------------------------------------------------------------- C FORWARD RECURRENCE LOOP WHEN CABS(Z).GE.R2 C----------------------------------------------------------------------- ETEST = AK/(DPI*CAZ*TOL) FK = CONER IF (ETEST.LT.CONER) GO TO 180 FKS = CTWOR CKR = CAZ + CAZ + CTWOR P1R = CZEROR P2R = CONER DO 150 I=1,KMAX AK = FHS/FKS CBR = CKR/(FK+CONER) PTR = P2R P2R = CBR*P2R - P1R*AK P1R = PTR CKR = CKR + CTWOR FKS = FKS + FK + FK + CTWOR FHS = FHS + FK + FK FK = FK + CONER STR = DABS(P2R)*FK IF (ETEST.LT.STR) GO TO 160 150 CONTINUE GO TO 310 160 CONTINUE FK = FK + SPI*T1*DSQRT(T2/CAZ) FHS = DABS(0.25D0-DNU2) GO TO 180 170 CONTINUE C----------------------------------------------------------------------- C COMPUTE BACKWARD INDEX K FOR CABS(Z).LT.R2 C----------------------------------------------------------------------- A2 = DSQRT(CAZ) AK = FPI*AK/(TOL*DSQRT(A2)) AA = 3.0D0*T1/(1.0D0+CAZ) BB = 14.7D0*T1/(28.0D0+CAZ) AK = (DLOG(AK)+CAZ*DCOS(AA)/(1.0D0+0.008D0*CAZ))/DCOS(BB) FK = 0.12125D0*AK*AK/CAZ + 1.5D0 180 CONTINUE C----------------------------------------------------------------------- C BACKWARD RECURRENCE LOOP FOR MILLER ALGORITHM C----------------------------------------------------------------------- K = INT(SNGL(FK)) FK = DBLE(FLOAT(K)) FKS = FK*FK P1R = CZEROR P1I = CZEROI P2R = TOL P2I = CZEROI CSR = P2R CSI = P2I DO 190 I=1,K A1 = FKS - FK AK = (FKS+FK)/(A1+FHS) RAK = 2.0D0/(FK+CONER) CBR = (FK+ZR)*RAK CBI = ZI*RAK PTR = P2R PTI = P2I P2R = (PTR*CBR-PTI*CBI-P1R)*AK P2I = (PTI*CBR+PTR*CBI-P1I)*AK P1R = PTR P1I = PTI CSR = CSR + P2R CSI = CSI + P2I FKS = A1 - FK + CONER FK = FK - CONER 190 CONTINUE C----------------------------------------------------------------------- C COMPUTE (P2/CS)=(P2/CABS(CS))*(CONJG(CS)/CABS(CS)) FOR BETTER C SCALING C----------------------------------------------------------------------- TM = ZABS(COMPLEX(CSR,CSI)) PTR = 1.0D0/TM S1R = P2R*PTR S1I = P2I*PTR CSR = CSR*PTR CSI = -CSI*PTR CALL ZMLT(COEFR, COEFI, S1R, S1I, STR, STI) CALL ZMLT(STR, STI, CSR, CSI, S1R, S1I) IF (INU.GT.0 .OR. N.GT.1) GO TO 200 ZDR = ZR ZDI = ZI IF(IFLAG.EQ.1) GO TO 270 GO TO 240 200 CONTINUE C----------------------------------------------------------------------- C COMPUTE P1/P2=(P1/CABS(P2)*CONJG(P2)/CABS(P2) FOR SCALING C----------------------------------------------------------------------- TM = ZABS(COMPLEX(P2R,P2I)) PTR = 1.0D0/TM P1R = P1R*PTR P1I = P1I*PTR P2R = P2R*PTR P2I = -P2I*PTR CALL ZMLT(P1R, P1I, P2R, P2I, PTR, PTI) STR = DNU + 0.5D0 - PTR STI = -PTI CALL ZDIV(STR, STI, ZR, ZI, STR, STI) STR = STR + 1.0D0 CALL ZMLT(STR, STI, S1R, S1I, S2R, S2I) C----------------------------------------------------------------------- C FORWARD RECURSION ON THE THREE TERM RECURSION WITH RELATION WITH C SCALING NEAR EXPONENT EXTREMES ON KFLAG=1 OR KFLAG=3 C----------------------------------------------------------------------- 210 CONTINUE STR = DNU + 1.0D0 CKR = STR*RZR CKI = STR*RZI IF (N.EQ.1) INU = INU - 1 IF (INU.GT.0) GO TO 220 IF (N.GT.1) GO TO 215 S1R = S2R S1I = S2I 215 CONTINUE ZDR = ZR ZDI = ZI IF(IFLAG.EQ.1) GO TO 270 GO TO 240 220 CONTINUE INUB = 1 IF(IFLAG.EQ.1) GO TO 261 225 CONTINUE P1R = CSRR(KFLAG) ASCLE = BRY(KFLAG) DO 230 I=INUB,INU STR = S2R STI = S2I S2R = CKR*STR - CKI*STI + S1R S2I = CKR*STI + CKI*STR + S1I S1R = STR S1I = STI CKR = CKR + RZR CKI = CKI + RZI IF (KFLAG.GE.3) GO TO 230 P2R = S2R*P1R P2I = S2I*P1R STR = DABS(P2R) STI = DABS(P2I) P2M = DMAX1(STR,STI) IF (P2M.LE.ASCLE) GO TO 230 KFLAG = KFLAG + 1 ASCLE = BRY(KFLAG) S1R = S1R*P1R S1I = S1I*P1R S2R = P2R S2I = P2I STR = CSSR(KFLAG) S1R = S1R*STR S1I = S1I*STR S2R = S2R*STR S2I = S2I*STR P1R = CSRR(KFLAG) 230 CONTINUE IF (N.NE.1) GO TO 240 S1R = S2R S1I = S2I 240 CONTINUE STR = CSRR(KFLAG) YR(1) = S1R*STR YI(1) = S1I*STR IF (N.EQ.1) RETURN YR(2) = S2R*STR YI(2) = S2I*STR IF (N.EQ.2) RETURN KK = 2 250 CONTINUE KK = KK + 1 IF (KK.GT.N) RETURN P1R = CSRR(KFLAG) ASCLE = BRY(KFLAG) DO 260 I=KK,N P2R = S2R P2I = S2I S2R = CKR*P2R - CKI*P2I + S1R S2I = CKI*P2R + CKR*P2I + S1I S1R = P2R S1I = P2I CKR = CKR + RZR CKI = CKI + RZI P2R = S2R*P1R P2I = S2I*P1R YR(I) = P2R YI(I) = P2I IF (KFLAG.GE.3) GO TO 260 STR = DABS(P2R) STI = DABS(P2I) P2M = DMAX1(STR,STI) IF (P2M.LE.ASCLE) GO TO 260 KFLAG = KFLAG + 1 ASCLE = BRY(KFLAG) S1R = S1R*P1R S1I = S1I*P1R S2R = P2R S2I = P2I STR = CSSR(KFLAG) S1R = S1R*STR S1I = S1I*STR S2R = S2R*STR S2I = S2I*STR P1R = CSRR(KFLAG) 260 CONTINUE RETURN C----------------------------------------------------------------------- C IFLAG=1 CASES, FORWARD RECURRENCE ON SCALED VALUES ON UNDERFLOW C----------------------------------------------------------------------- 261 CONTINUE HELIM = 0.5D0*ELIM ELM = DEXP(-ELIM) CELMR = ELM ASCLE = BRY(1) ZDR = ZR ZDI = ZI IC = -1 J = 2 DO 262 I=1,INU STR = S2R STI = S2I S2R = STR*CKR-STI*CKI+S1R S2I = STI*CKR+STR*CKI+S1I S1R = STR S1I = STI CKR = CKR+RZR CKI = CKI+RZI AS = ZABS(COMPLEX(S2R,S2I)) ALAS = DLOG(AS) P2R = -ZDR+ALAS IF(P2R.LT.(-ELIM)) GO TO 263 CALL ZLOG(S2R,S2I,STR,STI,IDUM) P2R = -ZDR+STR P2I = -ZDI+STI P2M = DEXP(P2R)/TOL P1R = P2M*DCOS(P2I) P1I = P2M*DSIN(P2I) CALL ZUCHK(P1R,P1I,NW,ASCLE,TOL) IF(NW.NE.0) GO TO 263 J = 3 - J CYR(J) = P1R CYI(J) = P1I IF(IC.EQ.(I-1)) GO TO 264 IC = I GO TO 262 263 CONTINUE IF(ALAS.LT.HELIM) GO TO 262 ZDR = ZDR-ELIM S1R = S1R*CELMR S1I = S1I*CELMR S2R = S2R*CELMR S2I = S2I*CELMR 262 CONTINUE IF(N.NE.1) GO TO 270 S1R = S2R S1I = S2I GO TO 270 264 CONTINUE KFLAG = 1 INUB = I+1 S2R = CYR(J) S2I = CYI(J) J = 3 - J S1R = CYR(J) S1I = CYI(J) IF(INUB.LE.INU) GO TO 225 IF(N.NE.1) GO TO 240 S1R = S2R S1I = S2I GO TO 240 270 CONTINUE YR(1) = S1R YI(1) = S1I IF(N.EQ.1) GO TO 280 YR(2) = S2R YI(2) = S2I 280 CONTINUE ASCLE = BRY(1) CALL ZKSCL(ZDR,ZDI,FNU,N,YR,YI,NZ,RZR,RZI,ASCLE,TOL,ELIM) INU = N - NZ IF (INU.LE.0) RETURN KK = NZ + 1 S1R = YR(KK) S1I = YI(KK) YR(KK) = S1R*CSRR(1) YI(KK) = S1I*CSRR(1) IF (INU.EQ.1) RETURN KK = NZ + 2 S2R = YR(KK) S2I = YI(KK) YR(KK) = S2R*CSRR(1) YI(KK) = S2I*CSRR(1) IF (INU.EQ.2) RETURN T2 = FNU + DBLE(FLOAT(KK-1)) CKR = T2*RZR CKI = T2*RZI KFLAG = 1 GO TO 250 290 CONTINUE C----------------------------------------------------------------------- C SCALE BY DEXP(Z), IFLAG = 1 CASES C----------------------------------------------------------------------- KODED = 2 IFLAG = 1 KFLAG = 2 GO TO 120 C----------------------------------------------------------------------- C FNU=HALF ODD INTEGER CASE, DNU=-0.5 C----------------------------------------------------------------------- 300 CONTINUE S1R = COEFR S1I = COEFI S2R = COEFR S2I = COEFI GO TO 210 C C 310 CONTINUE NZ=-2 RETURN END openspecfun-0.3/amos/zbuni.f000066400000000000000000000125341232445310600161430ustar00rootroot00000000000000 SUBROUTINE ZBUNI(ZR, ZI, FNU, KODE, N, YR, YI, NZ, NUI, NLAST, * FNUL, TOL, ELIM, ALIM) C***BEGIN PROLOGUE ZBUNI C***REFER TO ZBESI,ZBESK C C ZBUNI COMPUTES THE I BESSEL FUNCTION FOR LARGE CABS(Z).GT. C FNUL AND FNU+N-1.LT.FNUL. THE ORDER IS INCREASED FROM C FNU+N-1 GREATER THAN FNUL BY ADDING NUI AND COMPUTING C ACCORDING TO THE UNIFORM ASYMPTOTIC EXPANSION FOR I(FNU,Z) C ON IFORM=1 AND THE EXPANSION FOR J(FNU,Z) ON IFORM=2 C C***ROUTINES CALLED ZUNI1,ZUNI2,ZABS,D1MACH C***END PROLOGUE ZBUNI C COMPLEX CSCL,CSCR,CY,RZ,ST,S1,S2,Y,Z DOUBLE PRECISION ALIM, AX, AY, CSCLR, CSCRR, CYI, CYR, DFNU, * ELIM, FNU, FNUI, FNUL, GNU, RAZ, RZI, RZR, STI, STR, S1I, S1R, * S2I, S2R, TOL, YI, YR, ZI, ZR, ZABS, ASCLE, BRY, C1R, C1I, C1M, * D1MACH INTEGER I, IFLAG, IFORM, K, KODE, N, NL, NLAST, NUI, NW, NZ DIMENSION YR(N), YI(N), CYR(2), CYI(2), BRY(3) NZ = 0 AX = DABS(ZR)*1.7321D0 AY = DABS(ZI) IFORM = 1 IF (AY.GT.AX) IFORM = 2 IF (NUI.EQ.0) GO TO 60 FNUI = DBLE(FLOAT(NUI)) DFNU = FNU + DBLE(FLOAT(N-1)) GNU = DFNU + FNUI IF (IFORM.EQ.2) GO TO 10 C----------------------------------------------------------------------- C ASYMPTOTIC EXPANSION FOR I(FNU,Z) FOR LARGE FNU APPLIED IN C -PI/3.LE.ARG(Z).LE.PI/3 C----------------------------------------------------------------------- CALL ZUNI1(ZR, ZI, GNU, KODE, 2, CYR, CYI, NW, NLAST, FNUL, TOL, * ELIM, ALIM) GO TO 20 10 CONTINUE C----------------------------------------------------------------------- C ASYMPTOTIC EXPANSION FOR J(FNU,Z*EXP(M*HPI)) FOR LARGE FNU C APPLIED IN PI/3.LT.ABS(ARG(Z)).LE.PI/2 WHERE M=+I OR -I C AND HPI=PI/2 C----------------------------------------------------------------------- CALL ZUNI2(ZR, ZI, GNU, KODE, 2, CYR, CYI, NW, NLAST, FNUL, TOL, * ELIM, ALIM) 20 CONTINUE IF (NW.LT.0) GO TO 50 IF (NW.NE.0) GO TO 90 STR = ZABS(COMPLEX(CYR(1),CYI(1))) C---------------------------------------------------------------------- C SCALE BACKWARD RECURRENCE, BRY(3) IS DEFINED BUT NEVER USED C---------------------------------------------------------------------- BRY(1)=1.0D+3*D1MACH(1)/TOL BRY(2) = 1.0D0/BRY(1) BRY(3) = BRY(2) IFLAG = 2 ASCLE = BRY(2) CSCLR = 1.0D0 IF (STR.GT.BRY(1)) GO TO 21 IFLAG = 1 ASCLE = BRY(1) CSCLR = 1.0D0/TOL GO TO 25 21 CONTINUE IF (STR.LT.BRY(2)) GO TO 25 IFLAG = 3 ASCLE=BRY(3) CSCLR = TOL 25 CONTINUE CSCRR = 1.0D0/CSCLR S1R = CYR(2)*CSCLR S1I = CYI(2)*CSCLR S2R = CYR(1)*CSCLR S2I = CYI(1)*CSCLR RAZ = 1.0D0/ZABS(COMPLEX(ZR,ZI)) STR = ZR*RAZ STI = -ZI*RAZ RZR = (STR+STR)*RAZ RZI = (STI+STI)*RAZ DO 30 I=1,NUI STR = S2R STI = S2I S2R = (DFNU+FNUI)*(RZR*STR-RZI*STI) + S1R S2I = (DFNU+FNUI)*(RZR*STI+RZI*STR) + S1I S1R = STR S1I = STI FNUI = FNUI - 1.0D0 IF (IFLAG.GE.3) GO TO 30 STR = S2R*CSCRR STI = S2I*CSCRR C1R = DABS(STR) C1I = DABS(STI) C1M = DMAX1(C1R,C1I) IF (C1M.LE.ASCLE) GO TO 30 IFLAG = IFLAG+1 ASCLE = BRY(IFLAG) S1R = S1R*CSCRR S1I = S1I*CSCRR S2R = STR S2I = STI CSCLR = CSCLR*TOL CSCRR = 1.0D0/CSCLR S1R = S1R*CSCLR S1I = S1I*CSCLR S2R = S2R*CSCLR S2I = S2I*CSCLR 30 CONTINUE YR(N) = S2R*CSCRR YI(N) = S2I*CSCRR IF (N.EQ.1) RETURN NL = N - 1 FNUI = DBLE(FLOAT(NL)) K = NL DO 40 I=1,NL STR = S2R STI = S2I S2R = (FNU+FNUI)*(RZR*STR-RZI*STI) + S1R S2I = (FNU+FNUI)*(RZR*STI+RZI*STR) + S1I S1R = STR S1I = STI STR = S2R*CSCRR STI = S2I*CSCRR YR(K) = STR YI(K) = STI FNUI = FNUI - 1.0D0 K = K - 1 IF (IFLAG.GE.3) GO TO 40 C1R = DABS(STR) C1I = DABS(STI) C1M = DMAX1(C1R,C1I) IF (C1M.LE.ASCLE) GO TO 40 IFLAG = IFLAG+1 ASCLE = BRY(IFLAG) S1R = S1R*CSCRR S1I = S1I*CSCRR S2R = STR S2I = STI CSCLR = CSCLR*TOL CSCRR = 1.0D0/CSCLR S1R = S1R*CSCLR S1I = S1I*CSCLR S2R = S2R*CSCLR S2I = S2I*CSCLR 40 CONTINUE RETURN 50 CONTINUE NZ = -1 IF(NW.EQ.(-2)) NZ=-2 RETURN 60 CONTINUE IF (IFORM.EQ.2) GO TO 70 C----------------------------------------------------------------------- C ASYMPTOTIC EXPANSION FOR I(FNU,Z) FOR LARGE FNU APPLIED IN C -PI/3.LE.ARG(Z).LE.PI/3 C----------------------------------------------------------------------- CALL ZUNI1(ZR, ZI, FNU, KODE, N, YR, YI, NW, NLAST, FNUL, TOL, * ELIM, ALIM) GO TO 80 70 CONTINUE C----------------------------------------------------------------------- C ASYMPTOTIC EXPANSION FOR J(FNU,Z*EXP(M*HPI)) FOR LARGE FNU C APPLIED IN PI/3.LT.ABS(ARG(Z)).LE.PI/2 WHERE M=+I OR -I C AND HPI=PI/2 C----------------------------------------------------------------------- CALL ZUNI2(ZR, ZI, FNU, KODE, N, YR, YI, NW, NLAST, FNUL, TOL, * ELIM, ALIM) 80 CONTINUE IF (NW.LT.0) GO TO 50 NZ = NW RETURN 90 CONTINUE NLAST = N RETURN END openspecfun-0.3/amos/zbunk.f000066400000000000000000000025231232445310600161420ustar00rootroot00000000000000 SUBROUTINE ZBUNK(ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, TOL, ELIM, * ALIM) C***BEGIN PROLOGUE ZBUNK C***REFER TO ZBESK,ZBESH C C ZBUNK COMPUTES THE K BESSEL FUNCTION FOR FNU.GT.FNUL. C ACCORDING TO THE UNIFORM ASYMPTOTIC EXPANSION FOR K(FNU,Z) C IN ZUNK1 AND THE EXPANSION FOR H(2,FNU,Z) IN ZUNK2 C C***ROUTINES CALLED ZUNK1,ZUNK2 C***END PROLOGUE ZBUNK C COMPLEX Y,Z DOUBLE PRECISION ALIM, AX, AY, ELIM, FNU, TOL, YI, YR, ZI, ZR INTEGER KODE, MR, N, NZ DIMENSION YR(N), YI(N) NZ = 0 AX = DABS(ZR)*1.7321D0 AY = DABS(ZI) IF (AY.GT.AX) GO TO 10 C----------------------------------------------------------------------- C ASYMPTOTIC EXPANSION FOR K(FNU,Z) FOR LARGE FNU APPLIED IN C -PI/3.LE.ARG(Z).LE.PI/3 C----------------------------------------------------------------------- CALL ZUNK1(ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, TOL, ELIM, ALIM) GO TO 20 10 CONTINUE C----------------------------------------------------------------------- C ASYMPTOTIC EXPANSION FOR H(2,FNU,Z*EXP(M*HPI)) FOR LARGE FNU C APPLIED IN PI/3.LT.ABS(ARG(Z)).LE.PI/2 WHERE M=+I OR -I C AND HPI=PI/2 C----------------------------------------------------------------------- CALL ZUNK2(ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, TOL, ELIM, ALIM) 20 CONTINUE RETURN END openspecfun-0.3/amos/zdiv.f000066400000000000000000000007621232445310600157700ustar00rootroot00000000000000 SUBROUTINE ZDIV(AR, AI, BR, BI, CR, CI) C***BEGIN PROLOGUE ZDIV C***REFER TO ZBESH,ZBESI,ZBESJ,ZBESK,ZBESY,ZAIRY,ZBIRY C C DOUBLE PRECISION COMPLEX DIVIDE C=A/B. C C***ROUTINES CALLED ZABS C***END PROLOGUE ZDIV DOUBLE PRECISION AR, AI, BR, BI, CR, CI, BM, CA, CB, CC, CD DOUBLE PRECISION ZABS BM = 1.0D0/ZABS(COMPLEX(BR,BI)) CC = BR*BM CD = BI*BM CA = (AR*CC+AI*CD)*BM CB = (AI*CC-AR*CD)*BM CR = CA CI = CB RETURN END openspecfun-0.3/amos/zexp.f000066400000000000000000000006221232445310600157750ustar00rootroot00000000000000 SUBROUTINE ZEXP(AR, AI, BR, BI) C***BEGIN PROLOGUE ZEXP C***REFER TO ZBESH,ZBESI,ZBESJ,ZBESK,ZBESY,ZAIRY,ZBIRY C C DOUBLE PRECISION COMPLEX EXPONENTIAL FUNCTION B=EXP(A) C C***ROUTINES CALLED (NONE) C***END PROLOGUE ZEXP DOUBLE PRECISION AR, AI, BR, BI, ZM, CA, CB ZM = DEXP(AR) CA = ZM*DCOS(AI) CB = ZM*DSIN(AI) BR = CA BI = CB RETURN END openspecfun-0.3/amos/zkscl.f000066400000000000000000000060571232445310600161450ustar00rootroot00000000000000 SUBROUTINE ZKSCL(ZRR,ZRI,FNU,N,YR,YI,NZ,RZR,RZI,ASCLE,TOL,ELIM) C***BEGIN PROLOGUE ZKSCL C***REFER TO ZBESK C C SET K FUNCTIONS TO ZERO ON UNDERFLOW, CONTINUE RECURRENCE C ON SCALED FUNCTIONS UNTIL TWO MEMBERS COME ON SCALE, THEN C RETURN WITH MIN(NZ+2,N) VALUES SCALED BY 1/TOL. C C***ROUTINES CALLED ZUCHK,ZABS,ZLOG C***END PROLOGUE ZKSCL C COMPLEX CK,CS,CY,CZERO,RZ,S1,S2,Y,ZR,ZD,CELM DOUBLE PRECISION ACS, AS, ASCLE, CKI, CKR, CSI, CSR, CYI, * CYR, ELIM, FN, FNU, RZI, RZR, STR, S1I, S1R, S2I, * S2R, TOL, YI, YR, ZEROI, ZEROR, ZRI, ZRR, ZABS, * ZDR, ZDI, CELMR, ELM, HELIM, ALAS INTEGER I, IC, IDUM, KK, N, NN, NW, NZ DIMENSION YR(N), YI(N), CYR(2), CYI(2) DATA ZEROR,ZEROI / 0.0D0 , 0.0D0 / C NZ = 0 IC = 0 NN = MIN0(2,N) DO 10 I=1,NN S1R = YR(I) S1I = YI(I) CYR(I) = S1R CYI(I) = S1I AS = ZABS(COMPLEX(S1R,S1I)) ACS = -ZRR + DLOG(AS) NZ = NZ + 1 YR(I) = ZEROR YI(I) = ZEROI IF (ACS.LT.(-ELIM)) GO TO 10 CALL ZLOG(S1R, S1I, CSR, CSI, IDUM) CSR = CSR - ZRR CSI = CSI - ZRI STR = DEXP(CSR)/TOL CSR = STR*DCOS(CSI) CSI = STR*DSIN(CSI) CALL ZUCHK(CSR, CSI, NW, ASCLE, TOL) IF (NW.NE.0) GO TO 10 YR(I) = CSR YI(I) = CSI IC = I NZ = NZ - 1 10 CONTINUE IF (N.EQ.1) RETURN IF (IC.GT.1) GO TO 20 YR(1) = ZEROR YI(1) = ZEROI NZ = 2 20 CONTINUE IF (N.EQ.2) RETURN IF (NZ.EQ.0) RETURN FN = FNU + 1.0D0 CKR = FN*RZR CKI = FN*RZI S1R = CYR(1) S1I = CYI(1) S2R = CYR(2) S2I = CYI(2) HELIM = 0.5D0*ELIM ELM = DEXP(-ELIM) CELMR = ELM ZDR = ZRR ZDI = ZRI C C FIND TWO CONSECUTIVE Y VALUES ON SCALE. SCALE RECURRENCE IF C S2 GETS LARGER THAN EXP(ELIM/2) C DO 30 I=3,N KK = I CSR = S2R CSI = S2I S2R = CKR*CSR - CKI*CSI + S1R S2I = CKI*CSR + CKR*CSI + S1I S1R = CSR S1I = CSI CKR = CKR + RZR CKI = CKI + RZI AS = ZABS(COMPLEX(S2R,S2I)) ALAS = DLOG(AS) ACS = -ZDR + ALAS NZ = NZ + 1 YR(I) = ZEROR YI(I) = ZEROI IF (ACS.LT.(-ELIM)) GO TO 25 CALL ZLOG(S2R, S2I, CSR, CSI, IDUM) CSR = CSR - ZDR CSI = CSI - ZDI STR = DEXP(CSR)/TOL CSR = STR*DCOS(CSI) CSI = STR*DSIN(CSI) CALL ZUCHK(CSR, CSI, NW, ASCLE, TOL) IF (NW.NE.0) GO TO 25 YR(I) = CSR YI(I) = CSI NZ = NZ - 1 IF (IC.EQ.KK-1) GO TO 40 IC = KK GO TO 30 25 CONTINUE IF(ALAS.LT.HELIM) GO TO 30 ZDR = ZDR - ELIM S1R = S1R*CELMR S1I = S1I*CELMR S2R = S2R*CELMR S2I = S2I*CELMR 30 CONTINUE NZ = N IF(IC.EQ.N) NZ=N-1 GO TO 45 40 CONTINUE NZ = KK - 2 45 CONTINUE DO 50 I=1,NZ YR(I) = ZEROR YI(I) = ZEROI 50 CONTINUE RETURN END openspecfun-0.3/amos/zlog.f000066400000000000000000000021611232445310600157620ustar00rootroot00000000000000 SUBROUTINE ZLOG(AR, AI, BR, BI, IERR) C***BEGIN PROLOGUE ZLOG C***REFER TO ZBESH,ZBESI,ZBESJ,ZBESK,ZBESY,ZAIRY,ZBIRY C C DOUBLE PRECISION COMPLEX LOGARITHM B=CLOG(A) C IERR=0,NORMAL RETURN IERR=1, Z=CMPLX(0.0,0.0) C***ROUTINES CALLED ZABS C***END PROLOGUE ZLOG DOUBLE PRECISION AR, AI, BR, BI, ZM, DTHETA, DPI, DHPI DOUBLE PRECISION ZABS DATA DPI , DHPI / 3.141592653589793238462643383D+0, 1 1.570796326794896619231321696D+0/ C IERR=0 IF (AR.EQ.0.0D+0) GO TO 10 IF (AI.EQ.0.0D+0) GO TO 20 DTHETA = DATAN(AI/AR) IF (DTHETA.LE.0.0D+0) GO TO 40 IF (AR.LT.0.0D+0) DTHETA = DTHETA - DPI GO TO 50 10 IF (AI.EQ.0.0D+0) GO TO 60 BI = DHPI BR = DLOG(DABS(AI)) IF (AI.LT.0.0D+0) BI = -BI RETURN 20 IF (AR.GT.0.0D+0) GO TO 30 BR = DLOG(DABS(AR)) BI = DPI RETURN 30 BR = DLOG(AR) BI = 0.0D+0 RETURN 40 IF (AR.LT.0.0D+0) DTHETA = DTHETA + DPI 50 ZM = ZABS(COMPLEX(AR,AI)) BR = DLOG(ZM) BI = DTHETA RETURN 60 CONTINUE IERR=1 RETURN END openspecfun-0.3/amos/zmlri.f000066400000000000000000000137261232445310600161550ustar00rootroot00000000000000 SUBROUTINE ZMLRI(ZR, ZI, FNU, KODE, N, YR, YI, NZ, TOL) C***BEGIN PROLOGUE ZMLRI C***REFER TO ZBESI,ZBESK C C ZMLRI COMPUTES THE I BESSEL FUNCTION FOR RE(Z).GE.0.0 BY THE C MILLER ALGORITHM NORMALIZED BY A NEUMANN SERIES. C C***ROUTINES CALLED DGAMLN,D1MACH,ZABS,ZEXP,ZLOG,ZMLT C***END PROLOGUE ZMLRI C COMPLEX CK,CNORM,CONE,CTWO,CZERO,PT,P1,P2,RZ,SUM,Y,Z DOUBLE PRECISION ACK, AK, AP, AT, AZ, BK, CKI, CKR, CNORMI, * CNORMR, CONEI, CONER, FKAP, FKK, FLAM, FNF, FNU, PTI, PTR, P1I, * P1R, P2I, P2R, RAZ, RHO, RHO2, RZI, RZR, SCLE, STI, STR, SUMI, * SUMR, TFNF, TOL, TST, YI, YR, ZEROI, ZEROR, ZI, ZR, DGAMLN, * D1MACH, ZABS INTEGER I, IAZ, IDUM, IFNU, INU, ITIME, K, KK, KM, KODE, M, N, NZ DIMENSION YR(N), YI(N) DATA ZEROR,ZEROI,CONER,CONEI / 0.0D0, 0.0D0, 1.0D0, 0.0D0 / SCLE = D1MACH(1)/TOL NZ=0 AZ = ZABS(COMPLEX(ZR,ZI)) IAZ = INT(SNGL(AZ)) IFNU = INT(SNGL(FNU)) INU = IFNU + N - 1 AT = DBLE(FLOAT(IAZ)) + 1.0D0 RAZ = 1.0D0/AZ STR = ZR*RAZ STI = -ZI*RAZ CKR = STR*AT*RAZ CKI = STI*AT*RAZ RZR = (STR+STR)*RAZ RZI = (STI+STI)*RAZ P1R = ZEROR P1I = ZEROI P2R = CONER P2I = CONEI ACK = (AT+1.0D0)*RAZ RHO = ACK + DSQRT(ACK*ACK-1.0D0) RHO2 = RHO*RHO TST = (RHO2+RHO2)/((RHO2-1.0D0)*(RHO-1.0D0)) TST = TST/TOL C----------------------------------------------------------------------- C COMPUTE RELATIVE TRUNCATION ERROR INDEX FOR SERIES C----------------------------------------------------------------------- AK = AT DO 10 I=1,80 PTR = P2R PTI = P2I P2R = P1R - (CKR*PTR-CKI*PTI) P2I = P1I - (CKI*PTR+CKR*PTI) P1R = PTR P1I = PTI CKR = CKR + RZR CKI = CKI + RZI AP = ZABS(COMPLEX(P2R,P2I)) IF (AP.GT.TST*AK*AK) GO TO 20 AK = AK + 1.0D0 10 CONTINUE GO TO 110 20 CONTINUE I = I + 1 K = 0 IF (INU.LT.IAZ) GO TO 40 C----------------------------------------------------------------------- C COMPUTE RELATIVE TRUNCATION ERROR FOR RATIOS C----------------------------------------------------------------------- P1R = ZEROR P1I = ZEROI P2R = CONER P2I = CONEI AT = DBLE(FLOAT(INU)) + 1.0D0 STR = ZR*RAZ STI = -ZI*RAZ CKR = STR*AT*RAZ CKI = STI*AT*RAZ ACK = AT*RAZ TST = DSQRT(ACK/TOL) ITIME = 1 DO 30 K=1,80 PTR = P2R PTI = P2I P2R = P1R - (CKR*PTR-CKI*PTI) P2I = P1I - (CKR*PTI+CKI*PTR) P1R = PTR P1I = PTI CKR = CKR + RZR CKI = CKI + RZI AP = ZABS(COMPLEX(P2R,P2I)) IF (AP.LT.TST) GO TO 30 IF (ITIME.EQ.2) GO TO 40 ACK = ZABS(COMPLEX(CKR,CKI)) FLAM = ACK + DSQRT(ACK*ACK-1.0D0) FKAP = AP/ZABS(COMPLEX(P1R,P1I)) RHO = DMIN1(FLAM,FKAP) TST = TST*DSQRT(RHO/(RHO*RHO-1.0D0)) ITIME = 2 30 CONTINUE GO TO 110 40 CONTINUE C----------------------------------------------------------------------- C BACKWARD RECURRENCE AND SUM NORMALIZING RELATION C----------------------------------------------------------------------- K = K + 1 KK = MAX0(I+IAZ,K+INU) FKK = DBLE(FLOAT(KK)) P1R = ZEROR P1I = ZEROI C----------------------------------------------------------------------- C SCALE P2 AND SUM BY SCLE C----------------------------------------------------------------------- P2R = SCLE P2I = ZEROI FNF = FNU - DBLE(FLOAT(IFNU)) TFNF = FNF + FNF BK = DGAMLN(FKK+TFNF+1.0D0,IDUM) - DGAMLN(FKK+1.0D0,IDUM) - * DGAMLN(TFNF+1.0D0,IDUM) BK = DEXP(BK) SUMR = ZEROR SUMI = ZEROI KM = KK - INU DO 50 I=1,KM PTR = P2R PTI = P2I P2R = P1R + (FKK+FNF)*(RZR*PTR-RZI*PTI) P2I = P1I + (FKK+FNF)*(RZI*PTR+RZR*PTI) P1R = PTR P1I = PTI AK = 1.0D0 - TFNF/(FKK+TFNF) ACK = BK*AK SUMR = SUMR + (ACK+BK)*P1R SUMI = SUMI + (ACK+BK)*P1I BK = ACK FKK = FKK - 1.0D0 50 CONTINUE YR(N) = P2R YI(N) = P2I IF (N.EQ.1) GO TO 70 DO 60 I=2,N PTR = P2R PTI = P2I P2R = P1R + (FKK+FNF)*(RZR*PTR-RZI*PTI) P2I = P1I + (FKK+FNF)*(RZI*PTR+RZR*PTI) P1R = PTR P1I = PTI AK = 1.0D0 - TFNF/(FKK+TFNF) ACK = BK*AK SUMR = SUMR + (ACK+BK)*P1R SUMI = SUMI + (ACK+BK)*P1I BK = ACK FKK = FKK - 1.0D0 M = N - I + 1 YR(M) = P2R YI(M) = P2I 60 CONTINUE 70 CONTINUE IF (IFNU.LE.0) GO TO 90 DO 80 I=1,IFNU PTR = P2R PTI = P2I P2R = P1R + (FKK+FNF)*(RZR*PTR-RZI*PTI) P2I = P1I + (FKK+FNF)*(RZR*PTI+RZI*PTR) P1R = PTR P1I = PTI AK = 1.0D0 - TFNF/(FKK+TFNF) ACK = BK*AK SUMR = SUMR + (ACK+BK)*P1R SUMI = SUMI + (ACK+BK)*P1I BK = ACK FKK = FKK - 1.0D0 80 CONTINUE 90 CONTINUE PTR = ZR PTI = ZI IF (KODE.EQ.2) PTR = ZEROR CALL ZLOG(RZR, RZI, STR, STI, IDUM) P1R = -FNF*STR + PTR P1I = -FNF*STI + PTI AP = DGAMLN(1.0D0+FNF,IDUM) PTR = P1R - AP PTI = P1I C----------------------------------------------------------------------- C THE DIVISION CEXP(PT)/(SUM+P2) IS ALTERED TO AVOID OVERFLOW C IN THE DENOMINATOR BY SQUARING LARGE QUANTITIES C----------------------------------------------------------------------- P2R = P2R + SUMR P2I = P2I + SUMI AP = ZABS(COMPLEX(P2R,P2I)) P1R = 1.0D0/AP CALL ZEXP(PTR, PTI, STR, STI) CKR = STR*P1R CKI = STI*P1R PTR = P2R*P1R PTI = -P2I*P1R CALL ZMLT(CKR, CKI, PTR, PTI, CNORMR, CNORMI) DO 100 I=1,N STR = YR(I)*CNORMR - YI(I)*CNORMI YI(I) = YR(I)*CNORMI + YI(I)*CNORMR YR(I) = STR 100 CONTINUE RETURN 110 CONTINUE NZ=-2 RETURN END openspecfun-0.3/amos/zmlt.f000066400000000000000000000006011232445310600157720ustar00rootroot00000000000000 SUBROUTINE ZMLT(AR, AI, BR, BI, CR, CI) C***BEGIN PROLOGUE ZMLT C***REFER TO ZBESH,ZBESI,ZBESJ,ZBESK,ZBESY,ZAIRY,ZBIRY C C DOUBLE PRECISION COMPLEX MULTIPLY, C=A*B. C C***ROUTINES CALLED (NONE) C***END PROLOGUE ZMLT DOUBLE PRECISION AR, AI, BR, BI, CR, CI, CA, CB CA = AR*BR - AI*BI CB = AR*BI + AI*BR CR = CA CI = CB RETURN END openspecfun-0.3/amos/zrati.f000066400000000000000000000075311232445310600161460ustar00rootroot00000000000000 SUBROUTINE ZRATI(ZR, ZI, FNU, N, CYR, CYI, TOL) C***BEGIN PROLOGUE ZRATI C***REFER TO ZBESI,ZBESK,ZBESH C C ZRATI COMPUTES RATIOS OF I BESSEL FUNCTIONS BY BACKWARD C RECURRENCE. THE STARTING INDEX IS DETERMINED BY FORWARD C RECURRENCE AS DESCRIBED IN J. RES. OF NAT. BUR. OF STANDARDS-B, C MATHEMATICAL SCIENCES, VOL 77B, P111-114, SEPTEMBER, 1973, C BESSEL FUNCTIONS I AND J OF COMPLEX ARGUMENT AND INTEGER ORDER, C BY D. J. SOOKNE. C C***ROUTINES CALLED ZABS,ZDIV C***END PROLOGUE ZRATI C COMPLEX Z,CY(1),CONE,CZERO,P1,P2,T1,RZ,PT,CDFNU DOUBLE PRECISION AK, AMAGZ, AP1, AP2, ARG, AZ, CDFNUI, CDFNUR, * CONEI, CONER, CYI, CYR, CZEROI, CZEROR, DFNU, FDNU, FLAM, FNU, * FNUP, PTI, PTR, P1I, P1R, P2I, P2R, RAK, RAP1, RHO, RT2, RZI, * RZR, TEST, TEST1, TOL, TTI, TTR, T1I, T1R, ZI, ZR, ZABS INTEGER I, ID, IDNU, INU, ITIME, K, KK, MAGZ, N DIMENSION CYR(N), CYI(N) DATA CZEROR,CZEROI,CONER,CONEI,RT2/ 1 0.0D0, 0.0D0, 1.0D0, 0.0D0, 1.41421356237309505D0 / AZ = ZABS(COMPLEX(ZR,ZI)) INU = INT(SNGL(FNU)) IDNU = INU + N - 1 MAGZ = INT(SNGL(AZ)) AMAGZ = DBLE(FLOAT(MAGZ+1)) FDNU = DBLE(FLOAT(IDNU)) FNUP = DMAX1(AMAGZ,FDNU) ID = IDNU - MAGZ - 1 ITIME = 1 K = 1 PTR = 1.0D0/AZ RZR = PTR*(ZR+ZR)*PTR RZI = -PTR*(ZI+ZI)*PTR T1R = RZR*FNUP T1I = RZI*FNUP P2R = -T1R P2I = -T1I P1R = CONER P1I = CONEI T1R = T1R + RZR T1I = T1I + RZI IF (ID.GT.0) ID = 0 AP2 = ZABS(COMPLEX(P2R,P2I)) AP1 = ZABS(COMPLEX(P1R,P1I)) C----------------------------------------------------------------------- C THE OVERFLOW TEST ON K(FNU+I-1,Z) BEFORE THE CALL TO CBKNU C GUARANTEES THAT P2 IS ON SCALE. SCALE TEST1 AND ALL SUBSEQUENT C P2 VALUES BY AP1 TO ENSURE THAT AN OVERFLOW DOES NOT OCCUR C PREMATURELY. C----------------------------------------------------------------------- ARG = (AP2+AP2)/(AP1*TOL) TEST1 = DSQRT(ARG) TEST = TEST1 RAP1 = 1.0D0/AP1 P1R = P1R*RAP1 P1I = P1I*RAP1 P2R = P2R*RAP1 P2I = P2I*RAP1 AP2 = AP2*RAP1 10 CONTINUE K = K + 1 AP1 = AP2 PTR = P2R PTI = P2I P2R = P1R - (T1R*PTR-T1I*PTI) P2I = P1I - (T1R*PTI+T1I*PTR) P1R = PTR P1I = PTI T1R = T1R + RZR T1I = T1I + RZI AP2 = ZABS(COMPLEX(P2R,P2I)) IF (AP1.LE.TEST) GO TO 10 IF (ITIME.EQ.2) GO TO 20 AK = ZABS(COMPLEX(T1R,T1I)*0.5D0) FLAM = AK + DSQRT(AK*AK-1.0D0) RHO = DMIN1(AP2/AP1,FLAM) TEST = TEST1*DSQRT(RHO/(RHO*RHO-1.0D0)) ITIME = 2 GO TO 10 20 CONTINUE KK = K + 1 - ID AK = DBLE(FLOAT(KK)) T1R = AK T1I = CZEROI DFNU = FNU + DBLE(FLOAT(N-1)) P1R = 1.0D0/AP2 P1I = CZEROI P2R = CZEROR P2I = CZEROI DO 30 I=1,KK PTR = P1R PTI = P1I RAP1 = DFNU + T1R TTR = RZR*RAP1 TTI = RZI*RAP1 P1R = (PTR*TTR-PTI*TTI) + P2R P1I = (PTR*TTI+PTI*TTR) + P2I P2R = PTR P2I = PTI T1R = T1R - CONER 30 CONTINUE IF (P1R.NE.CZEROR .OR. P1I.NE.CZEROI) GO TO 40 P1R = TOL P1I = TOL 40 CONTINUE CALL ZDIV(P2R, P2I, P1R, P1I, CYR(N), CYI(N)) IF (N.EQ.1) RETURN K = N - 1 AK = DBLE(FLOAT(K)) T1R = AK T1I = CZEROI CDFNUR = FNU*RZR CDFNUI = FNU*RZI DO 60 I=2,N PTR = CDFNUR + (T1R*RZR-T1I*RZI) + CYR(K+1) PTI = CDFNUI + (T1R*RZI+T1I*RZR) + CYI(K+1) AK = ZABS(COMPLEX(PTR,PTI)) IF (AK.NE.CZEROR) GO TO 50 PTR = TOL PTI = TOL AK = TOL*RT2 50 CONTINUE RAK = CONER/AK CYR(K) = RAK*PTR*RAK CYI(K) = -RAK*PTI*RAK T1R = T1R - CONER K = K - 1 60 CONTINUE RETURN END openspecfun-0.3/amos/zs1s2.f000066400000000000000000000030241232445310600157700ustar00rootroot00000000000000 SUBROUTINE ZS1S2(ZRR, ZRI, S1R, S1I, S2R, S2I, NZ, ASCLE, ALIM, * IUF) C***BEGIN PROLOGUE ZS1S2 C***REFER TO ZBESK,ZAIRY C C ZS1S2 TESTS FOR A POSSIBLE UNDERFLOW RESULTING FROM THE C ADDITION OF THE I AND K FUNCTIONS IN THE ANALYTIC CON- C TINUATION FORMULA WHERE S1=K FUNCTION AND S2=I FUNCTION. C ON KODE=1 THE I AND K FUNCTIONS ARE DIFFERENT ORDERS OF C MAGNITUDE, BUT FOR KODE=2 THEY CAN BE OF THE SAME ORDER C OF MAGNITUDE AND THE MAXIMUM MUST BE AT LEAST ONE C PRECISION ABOVE THE UNDERFLOW LIMIT. C C***ROUTINES CALLED ZABS,ZEXP,ZLOG C***END PROLOGUE ZS1S2 C COMPLEX CZERO,C1,S1,S1D,S2,ZR DOUBLE PRECISION AA, ALIM, ALN, ASCLE, AS1, AS2, C1I, C1R, S1DI, * S1DR, S1I, S1R, S2I, S2R, ZEROI, ZEROR, ZRI, ZRR, ZABS INTEGER IUF, IDUM, NZ DATA ZEROR,ZEROI / 0.0D0 , 0.0D0 / NZ = 0 AS1 = ZABS(COMPLEX(S1R,S1I)) AS2 = ZABS(COMPLEX(S2R,S2I)) IF (S1R.EQ.0.0D0 .AND. S1I.EQ.0.0D0) GO TO 10 IF (AS1.EQ.0.0D0) GO TO 10 ALN = -ZRR - ZRR + DLOG(AS1) S1DR = S1R S1DI = S1I S1R = ZEROR S1I = ZEROI AS1 = ZEROR IF (ALN.LT.(-ALIM)) GO TO 10 CALL ZLOG(S1DR, S1DI, C1R, C1I, IDUM) C1R = C1R - ZRR - ZRR C1I = C1I - ZRI - ZRI CALL ZEXP(C1R, C1I, S1R, S1I) AS1 = ZABS(COMPLEX(S1R,S1I)) IUF = IUF + 1 10 CONTINUE AA = DMAX1(AS1,AS2) IF (AA.GT.ASCLE) RETURN S1R = ZEROR S1I = ZEROI S2R = ZEROR S2I = ZEROI NZ = 1 IUF = 0 RETURN END openspecfun-0.3/amos/zseri.f000066400000000000000000000131271232445310600161470ustar00rootroot00000000000000 SUBROUTINE ZSERI(ZR, ZI, FNU, KODE, N, YR, YI, NZ, TOL, ELIM, * ALIM) C***BEGIN PROLOGUE ZSERI C***REFER TO ZBESI,ZBESK C C ZSERI COMPUTES THE I BESSEL FUNCTION FOR REAL(Z).GE.0.0 BY C MEANS OF THE POWER SERIES FOR LARGE CABS(Z) IN THE C REGION CABS(Z).LE.2*SQRT(FNU+1). NZ=0 IS A NORMAL RETURN. C NZ.GT.0 MEANS THAT THE LAST NZ COMPONENTS WERE SET TO ZERO C DUE TO UNDERFLOW. NZ.LT.0 MEANS UNDERFLOW OCCURRED, BUT THE C CONDITION CABS(Z).LE.2*SQRT(FNU+1) WAS VIOLATED AND THE C COMPUTATION MUST BE COMPLETED IN ANOTHER ROUTINE WITH N=N-ABS(NZ). C C***ROUTINES CALLED DGAMLN,D1MACH,ZUCHK,ZABS,ZDIV,ZLOG,ZMLT C***END PROLOGUE ZSERI C COMPLEX AK1,CK,COEF,CONE,CRSC,CSCL,CZ,CZERO,HZ,RZ,S1,S2,Y,Z DOUBLE PRECISION AA, ACZ, AK, AK1I, AK1R, ALIM, ARM, ASCLE, ATOL, * AZ, CKI, CKR, COEFI, COEFR, CONEI, CONER, CRSCR, CZI, CZR, DFNU, * ELIM, FNU, FNUP, HZI, HZR, RAZ, RS, RTR1, RZI, RZR, S, SS, STI, * STR, S1I, S1R, S2I, S2R, TOL, YI, YR, WI, WR, ZEROI, ZEROR, ZI, * ZR, DGAMLN, D1MACH, ZABS INTEGER I, IB, IDUM, IFLAG, IL, K, KODE, L, M, N, NN, NZ, NW DIMENSION YR(N), YI(N), WR(2), WI(2) DATA ZEROR,ZEROI,CONER,CONEI / 0.0D0, 0.0D0, 1.0D0, 0.0D0 / C NZ = 0 AZ = ZABS(COMPLEX(ZR,ZI)) IF (AZ.EQ.0.0D0) GO TO 160 ARM = 1.0D+3*D1MACH(1) RTR1 = DSQRT(ARM) CRSCR = 1.0D0 IFLAG = 0 IF (AZ.LT.ARM) GO TO 150 HZR = 0.5D0*ZR HZI = 0.5D0*ZI CZR = ZEROR CZI = ZEROI IF (AZ.LE.RTR1) GO TO 10 CALL ZMLT(HZR, HZI, HZR, HZI, CZR, CZI) 10 CONTINUE ACZ = ZABS(COMPLEX(CZR,CZI)) NN = N CALL ZLOG(HZR, HZI, CKR, CKI, IDUM) 20 CONTINUE DFNU = FNU + DBLE(FLOAT(NN-1)) FNUP = DFNU + 1.0D0 C----------------------------------------------------------------------- C UNDERFLOW TEST C----------------------------------------------------------------------- AK1R = CKR*DFNU AK1I = CKI*DFNU AK = DGAMLN(FNUP,IDUM) AK1R = AK1R - AK IF (KODE.EQ.2) AK1R = AK1R - ZR IF (AK1R.GT.(-ELIM)) GO TO 40 30 CONTINUE NZ = NZ + 1 YR(NN) = ZEROR YI(NN) = ZEROI IF (ACZ.GT.DFNU) GO TO 190 NN = NN - 1 IF (NN.EQ.0) RETURN GO TO 20 40 CONTINUE IF (AK1R.GT.(-ALIM)) GO TO 50 IFLAG = 1 SS = 1.0D0/TOL CRSCR = TOL ASCLE = ARM*SS 50 CONTINUE AA = DEXP(AK1R) IF (IFLAG.EQ.1) AA = AA*SS COEFR = AA*DCOS(AK1I) COEFI = AA*DSIN(AK1I) ATOL = TOL*ACZ/FNUP IL = MIN0(2,NN) DO 90 I=1,IL DFNU = FNU + DBLE(FLOAT(NN-I)) FNUP = DFNU + 1.0D0 S1R = CONER S1I = CONEI IF (ACZ.LT.TOL*FNUP) GO TO 70 AK1R = CONER AK1I = CONEI AK = FNUP + 2.0D0 S = FNUP AA = 2.0D0 60 CONTINUE RS = 1.0D0/S STR = AK1R*CZR - AK1I*CZI STI = AK1R*CZI + AK1I*CZR AK1R = STR*RS AK1I = STI*RS S1R = S1R + AK1R S1I = S1I + AK1I S = S + AK AK = AK + 2.0D0 AA = AA*ACZ*RS IF (AA.GT.ATOL) GO TO 60 70 CONTINUE S2R = S1R*COEFR - S1I*COEFI S2I = S1R*COEFI + S1I*COEFR WR(I) = S2R WI(I) = S2I IF (IFLAG.EQ.0) GO TO 80 CALL ZUCHK(S2R, S2I, NW, ASCLE, TOL) IF (NW.NE.0) GO TO 30 80 CONTINUE M = NN - I + 1 YR(M) = S2R*CRSCR YI(M) = S2I*CRSCR IF (I.EQ.IL) GO TO 90 CALL ZDIV(COEFR, COEFI, HZR, HZI, STR, STI) COEFR = STR*DFNU COEFI = STI*DFNU 90 CONTINUE IF (NN.LE.2) RETURN K = NN - 2 AK = DBLE(FLOAT(K)) RAZ = 1.0D0/AZ STR = ZR*RAZ STI = -ZI*RAZ RZR = (STR+STR)*RAZ RZI = (STI+STI)*RAZ IF (IFLAG.EQ.1) GO TO 120 IB = 3 100 CONTINUE DO 110 I=IB,NN YR(K) = (AK+FNU)*(RZR*YR(K+1)-RZI*YI(K+1)) + YR(K+2) YI(K) = (AK+FNU)*(RZR*YI(K+1)+RZI*YR(K+1)) + YI(K+2) AK = AK - 1.0D0 K = K - 1 110 CONTINUE RETURN C----------------------------------------------------------------------- C RECUR BACKWARD WITH SCALED VALUES C----------------------------------------------------------------------- 120 CONTINUE C----------------------------------------------------------------------- C EXP(-ALIM)=EXP(-ELIM)/TOL=APPROX. ONE PRECISION ABOVE THE C UNDERFLOW LIMIT = ASCLE = D1MACH(1)*SS*1.0D+3 C----------------------------------------------------------------------- S1R = WR(1) S1I = WI(1) S2R = WR(2) S2I = WI(2) DO 130 L=3,NN CKR = S2R CKI = S2I S2R = S1R + (AK+FNU)*(RZR*CKR-RZI*CKI) S2I = S1I + (AK+FNU)*(RZR*CKI+RZI*CKR) S1R = CKR S1I = CKI CKR = S2R*CRSCR CKI = S2I*CRSCR YR(K) = CKR YI(K) = CKI AK = AK - 1.0D0 K = K - 1 IF (ZABS(COMPLEX(CKR,CKI)).GT.ASCLE) GO TO 140 130 CONTINUE RETURN 140 CONTINUE IB = L + 1 IF (IB.GT.NN) RETURN GO TO 100 150 CONTINUE NZ = N IF (FNU.EQ.0.0D0) NZ = NZ - 1 160 CONTINUE YR(1) = ZEROR YI(1) = ZEROI IF (FNU.NE.0.0D0) GO TO 170 YR(1) = CONER YI(1) = CONEI 170 CONTINUE IF (N.EQ.1) RETURN DO 180 I=2,N YR(I) = ZEROR YI(I) = ZEROI 180 CONTINUE RETURN C----------------------------------------------------------------------- C RETURN WITH NZ.LT.0 IF CABS(Z*Z/4).GT.FNU+N-NZ-1 COMPLETE C THE CALCULATION IN CBINU WITH N=N-IABS(NZ) C----------------------------------------------------------------------- 190 CONTINUE NZ = -NZ RETURN END openspecfun-0.3/amos/zshch.f000066400000000000000000000010451232445310600161260ustar00rootroot00000000000000 SUBROUTINE ZSHCH(ZR, ZI, CSHR, CSHI, CCHR, CCHI) C***BEGIN PROLOGUE ZSHCH C***REFER TO ZBESK,ZBESH C C ZSHCH COMPUTES THE COMPLEX HYPERBOLIC FUNCTIONS CSH=SINH(X+I*Y) C AND CCH=COSH(X+I*Y), WHERE I**2=-1. C C***ROUTINES CALLED (NONE) C***END PROLOGUE ZSHCH C DOUBLE PRECISION CCHI, CCHR, CH, CN, CSHI, CSHR, SH, SN, ZI, ZR, * DCOSH, DSINH SH = DSINH(ZR) CH = DCOSH(ZR) SN = DSIN(ZI) CN = DCOS(ZI) CSHR = SH*CN CSHI = CH*SN CCHR = CH*CN CCHI = SH*SN RETURN END openspecfun-0.3/amos/zsqrt.f000066400000000000000000000022421232445310600161720ustar00rootroot00000000000000 SUBROUTINE ZSQRT(AR, AI, BR, BI) C***BEGIN PROLOGUE ZSQRT C***REFER TO ZBESH,ZBESI,ZBESJ,ZBESK,ZBESY,ZAIRY,ZBIRY C C DOUBLE PRECISION COMPLEX SQUARE ROOT, B=CSQRT(A) C C***ROUTINES CALLED ZABS C***END PROLOGUE ZSQRT DOUBLE PRECISION AR, AI, BR, BI, ZM, DTHETA, DPI, DRT DOUBLE PRECISION ZABS DATA DRT , DPI / 7.071067811865475244008443621D-1, 1 3.141592653589793238462643383D+0/ ZM = ZABS(COMPLEX(AR,AI)) ZM = DSQRT(ZM) IF (AR.EQ.0.0D+0) GO TO 10 IF (AI.EQ.0.0D+0) GO TO 20 DTHETA = DATAN(AI/AR) IF (DTHETA.LE.0.0D+0) GO TO 40 IF (AR.LT.0.0D+0) DTHETA = DTHETA - DPI GO TO 50 10 IF (AI.GT.0.0D+0) GO TO 60 IF (AI.LT.0.0D+0) GO TO 70 BR = 0.0D+0 BI = 0.0D+0 RETURN 20 IF (AR.GT.0.0D+0) GO TO 30 BR = 0.0D+0 BI = DSQRT(DABS(AR)) RETURN 30 BR = DSQRT(AR) BI = 0.0D+0 RETURN 40 IF (AR.LT.0.0D+0) DTHETA = DTHETA + DPI 50 DTHETA = DTHETA*0.5D+0 BR = ZM*DCOS(DTHETA) BI = ZM*DSIN(DTHETA) RETURN 60 BR = ZM*DRT BI = ZM*DRT RETURN 70 BR = ZM*DRT BI = -ZM*DRT RETURN END openspecfun-0.3/amos/zuchk.f000066400000000000000000000016661232445310600161440ustar00rootroot00000000000000 SUBROUTINE ZUCHK(YR, YI, NZ, ASCLE, TOL) C***BEGIN PROLOGUE ZUCHK C***REFER TO ZSERI,ZUOIK,ZUNK1,ZUNK2,ZUNI1,ZUNI2,ZKSCL C C Y ENTERS AS A SCALED QUANTITY WHOSE MAGNITUDE IS GREATER THAN C EXP(-ALIM)=ASCLE=1.0E+3*D1MACH(1)/TOL. THE TEST IS MADE TO SEE C IF THE MAGNITUDE OF THE REAL OR IMAGINARY PART WOULD UNDERFLOW C WHEN Y IS SCALED (BY TOL) TO ITS PROPER VALUE. Y IS ACCEPTED C IF THE UNDERFLOW IS AT LEAST ONE PRECISION BELOW THE MAGNITUDE C OF THE LARGEST COMPONENT; OTHERWISE THE PHASE ANGLE DOES NOT HAVE C ABSOLUTE ACCURACY AND AN UNDERFLOW IS ASSUMED. C C***ROUTINES CALLED (NONE) C***END PROLOGUE ZUCHK C C COMPLEX Y DOUBLE PRECISION ASCLE, SS, ST, TOL, WR, WI, YR, YI INTEGER NZ NZ = 0 WR = DABS(YR) WI = DABS(YI) ST = DMIN1(WR,WI) IF (ST.GT.ASCLE) RETURN SS = DMAX1(WR,WI) ST = ST/TOL IF (SS.LT.ST) NZ = 1 RETURN END openspecfun-0.3/amos/zunhj.f000066400000000000000000001050341232445310600161500ustar00rootroot00000000000000 SUBROUTINE ZUNHJ(ZR, ZI, FNU, IPMTR, TOL, PHIR, PHII, ARGR, ARGI, * ZETA1R, ZETA1I, ZETA2R, ZETA2I, ASUMR, ASUMI, BSUMR, BSUMI) C***BEGIN PROLOGUE ZUNHJ C***REFER TO ZBESI,ZBESK C C REFERENCES C HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ AND I.A. C STEGUN, AMS55, NATIONAL BUREAU OF STANDARDS, 1965, CHAPTER 9. C C ASYMPTOTICS AND SPECIAL FUNCTIONS BY F.W.J. OLVER, ACADEMIC C PRESS, N.Y., 1974, PAGE 420 C C ABSTRACT C ZUNHJ COMPUTES PARAMETERS FOR BESSEL FUNCTIONS C(FNU,Z) = C J(FNU,Z), Y(FNU,Z) OR H(I,FNU,Z) I=1,2 FOR LARGE ORDERS FNU C BY MEANS OF THE UNIFORM ASYMPTOTIC EXPANSION C C C(FNU,Z)=C1*PHI*( ASUM*AIRY(ARG) + C2*BSUM*DAIRY(ARG) ) C C FOR PROPER CHOICES OF C1, C2, AIRY AND DAIRY WHERE AIRY IS C AN AIRY FUNCTION AND DAIRY IS ITS DERIVATIVE. C C (2/3)*FNU*ZETA**1.5 = ZETA1-ZETA2, C C ZETA1=0.5*FNU*CLOG((1+W)/(1-W)), ZETA2=FNU*W FOR SCALING C PURPOSES IN AIRY FUNCTIONS FROM CAIRY OR CBIRY. C C MCONJ=SIGN OF AIMAG(Z), BUT IS AMBIGUOUS WHEN Z IS REAL AND C MUST BE SPECIFIED. IPMTR=0 RETURNS ALL PARAMETERS. IPMTR= C 1 COMPUTES ALL EXCEPT ASUM AND BSUM. C C***ROUTINES CALLED ZABS,ZDIV,ZLOG,ZSQRT,D1MACH C***END PROLOGUE ZUNHJ C COMPLEX ARG,ASUM,BSUM,CFNU,CONE,CR,CZERO,DR,P,PHI,PRZTH,PTFN, C *RFN13,RTZTA,RZTH,SUMA,SUMB,TFN,T2,UP,W,W2,Z,ZA,ZB,ZC,ZETA,ZETA1, C *ZETA2,ZTH DOUBLE PRECISION ALFA, ANG, AP, AR, ARGI, ARGR, ASUMI, ASUMR, * ATOL, AW2, AZTH, BETA, BR, BSUMI, BSUMR, BTOL, C, CONEI, CONER, * CRI, CRR, DRI, DRR, EX1, EX2, FNU, FN13, FN23, GAMA, GPI, HPI, * PHII, PHIR, PI, PP, PR, PRZTHI, PRZTHR, PTFNI, PTFNR, RAW, RAW2, * RAZTH, RFNU, RFNU2, RFN13, RTZTI, RTZTR, RZTHI, RZTHR, STI, STR, * SUMAI, SUMAR, SUMBI, SUMBR, TEST, TFNI, TFNR, THPI, TOL, TZAI, * TZAR, T2I, T2R, UPI, UPR, WI, WR, W2I, W2R, ZAI, ZAR, ZBI, ZBR, * ZCI, ZCR, ZEROI, ZEROR, ZETAI, ZETAR, ZETA1I, ZETA1R, ZETA2I, * ZETA2R, ZI, ZR, ZTHI, ZTHR, ZABS, AC, D1MACH INTEGER IAS, IBS, IPMTR, IS, J, JR, JU, K, KMAX, KP1, KS, L, LR, * LRP1, L1, L2, M, IDUM DIMENSION AR(14), BR(14), C(105), ALFA(180), BETA(210), GAMA(30), * AP(30), PR(30), PI(30), UPR(14), UPI(14), CRR(14), CRI(14), * DRR(14), DRI(14) DATA AR(1), AR(2), AR(3), AR(4), AR(5), AR(6), AR(7), AR(8), 1 AR(9), AR(10), AR(11), AR(12), AR(13), AR(14)/ 2 1.00000000000000000D+00, 1.04166666666666667D-01, 3 8.35503472222222222D-02, 1.28226574556327160D-01, 4 2.91849026464140464D-01, 8.81627267443757652D-01, 5 3.32140828186276754D+00, 1.49957629868625547D+01, 6 7.89230130115865181D+01, 4.74451538868264323D+02, 7 3.20749009089066193D+03, 2.40865496408740049D+04, 8 1.98923119169509794D+05, 1.79190200777534383D+06/ DATA BR(1), BR(2), BR(3), BR(4), BR(5), BR(6), BR(7), BR(8), 1 BR(9), BR(10), BR(11), BR(12), BR(13), BR(14)/ 2 1.00000000000000000D+00, -1.45833333333333333D-01, 3 -9.87413194444444444D-02, -1.43312053915895062D-01, 4 -3.17227202678413548D-01, -9.42429147957120249D-01, 5 -3.51120304082635426D+00, -1.57272636203680451D+01, 6 -8.22814390971859444D+01, -4.92355370523670524D+02, 7 -3.31621856854797251D+03, -2.48276742452085896D+04, 8 -2.04526587315129788D+05, -1.83844491706820990D+06/ DATA C(1), C(2), C(3), C(4), C(5), C(6), C(7), C(8), C(9), C(10), 1 C(11), C(12), C(13), C(14), C(15), C(16), C(17), C(18), 2 C(19), C(20), C(21), C(22), C(23), C(24)/ 3 1.00000000000000000D+00, -2.08333333333333333D-01, 4 1.25000000000000000D-01, 3.34201388888888889D-01, 5 -4.01041666666666667D-01, 7.03125000000000000D-02, 6 -1.02581259645061728D+00, 1.84646267361111111D+00, 7 -8.91210937500000000D-01, 7.32421875000000000D-02, 8 4.66958442342624743D+00, -1.12070026162229938D+01, 9 8.78912353515625000D+00, -2.36408691406250000D+00, A 1.12152099609375000D-01, -2.82120725582002449D+01, B 8.46362176746007346D+01, -9.18182415432400174D+01, C 4.25349987453884549D+01, -7.36879435947963170D+00, D 2.27108001708984375D-01, 2.12570130039217123D+02, E -7.65252468141181642D+02, 1.05999045252799988D+03/ DATA C(25), C(26), C(27), C(28), C(29), C(30), C(31), C(32), 1 C(33), C(34), C(35), C(36), C(37), C(38), C(39), C(40), 2 C(41), C(42), C(43), C(44), C(45), C(46), C(47), C(48)/ 3 -6.99579627376132541D+02, 2.18190511744211590D+02, 4 -2.64914304869515555D+01, 5.72501420974731445D-01, 5 -1.91945766231840700D+03, 8.06172218173730938D+03, 6 -1.35865500064341374D+04, 1.16553933368645332D+04, 7 -5.30564697861340311D+03, 1.20090291321635246D+03, 8 -1.08090919788394656D+02, 1.72772750258445740D+00, 9 2.02042913309661486D+04, -9.69805983886375135D+04, A 1.92547001232531532D+05, -2.03400177280415534D+05, B 1.22200464983017460D+05, -4.11926549688975513D+04, C 7.10951430248936372D+03, -4.93915304773088012D+02, D 6.07404200127348304D+00, -2.42919187900551333D+05, E 1.31176361466297720D+06, -2.99801591853810675D+06/ DATA C(49), C(50), C(51), C(52), C(53), C(54), C(55), C(56), 1 C(57), C(58), C(59), C(60), C(61), C(62), C(63), C(64), 2 C(65), C(66), C(67), C(68), C(69), C(70), C(71), C(72)/ 3 3.76327129765640400D+06, -2.81356322658653411D+06, 4 1.26836527332162478D+06, -3.31645172484563578D+05, 5 4.52187689813627263D+04, -2.49983048181120962D+03, 6 2.43805296995560639D+01, 3.28446985307203782D+06, 7 -1.97068191184322269D+07, 5.09526024926646422D+07, 8 -7.41051482115326577D+07, 6.63445122747290267D+07, 9 -3.75671766607633513D+07, 1.32887671664218183D+07, A -2.78561812808645469D+06, 3.08186404612662398D+05, B -1.38860897537170405D+04, 1.10017140269246738D+02, C -4.93292536645099620D+07, 3.25573074185765749D+08, D -9.39462359681578403D+08, 1.55359689957058006D+09, E -1.62108055210833708D+09, 1.10684281682301447D+09/ DATA C(73), C(74), C(75), C(76), C(77), C(78), C(79), C(80), 1 C(81), C(82), C(83), C(84), C(85), C(86), C(87), C(88), 2 C(89), C(90), C(91), C(92), C(93), C(94), C(95), C(96)/ 3 -4.95889784275030309D+08, 1.42062907797533095D+08, 4 -2.44740627257387285D+07, 2.24376817792244943D+06, 5 -8.40054336030240853D+04, 5.51335896122020586D+02, 6 8.14789096118312115D+08, -5.86648149205184723D+09, 7 1.86882075092958249D+10, -3.46320433881587779D+10, 8 4.12801855797539740D+10, -3.30265997498007231D+10, 9 1.79542137311556001D+10, -6.56329379261928433D+09, A 1.55927986487925751D+09, -2.25105661889415278D+08, B 1.73951075539781645D+07, -5.49842327572288687D+05, C 3.03809051092238427D+03, -1.46792612476956167D+10, D 1.14498237732025810D+11, -3.99096175224466498D+11, E 8.19218669548577329D+11, -1.09837515608122331D+12/ DATA C(97), C(98), C(99), C(100), C(101), C(102), C(103), C(104), 1 C(105)/ 2 1.00815810686538209D+12, -6.45364869245376503D+11, 3 2.87900649906150589D+11, -8.78670721780232657D+10, 4 1.76347306068349694D+10, -2.16716498322379509D+09, 5 1.43157876718888981D+08, -3.87183344257261262D+06, 6 1.82577554742931747D+04/ DATA ALFA(1), ALFA(2), ALFA(3), ALFA(4), ALFA(5), ALFA(6), 1 ALFA(7), ALFA(8), ALFA(9), ALFA(10), ALFA(11), ALFA(12), 2 ALFA(13), ALFA(14), ALFA(15), ALFA(16), ALFA(17), ALFA(18), 3 ALFA(19), ALFA(20), ALFA(21), ALFA(22)/ 4 -4.44444444444444444D-03, -9.22077922077922078D-04, 5 -8.84892884892884893D-05, 1.65927687832449737D-04, 6 2.46691372741792910D-04, 2.65995589346254780D-04, 7 2.61824297061500945D-04, 2.48730437344655609D-04, 8 2.32721040083232098D-04, 2.16362485712365082D-04, 9 2.00738858762752355D-04, 1.86267636637545172D-04, A 1.73060775917876493D-04, 1.61091705929015752D-04, B 1.50274774160908134D-04, 1.40503497391269794D-04, C 1.31668816545922806D-04, 1.23667445598253261D-04, D 1.16405271474737902D-04, 1.09798298372713369D-04, E 1.03772410422992823D-04, 9.82626078369363448D-05/ DATA ALFA(23), ALFA(24), ALFA(25), ALFA(26), ALFA(27), ALFA(28), 1 ALFA(29), ALFA(30), ALFA(31), ALFA(32), ALFA(33), ALFA(34), 2 ALFA(35), ALFA(36), ALFA(37), ALFA(38), ALFA(39), ALFA(40), 3 ALFA(41), ALFA(42), ALFA(43), ALFA(44)/ 4 9.32120517249503256D-05, 8.85710852478711718D-05, 5 8.42963105715700223D-05, 8.03497548407791151D-05, 6 7.66981345359207388D-05, 7.33122157481777809D-05, 7 7.01662625163141333D-05, 6.72375633790160292D-05, 8 6.93735541354588974D-04, 2.32241745182921654D-04, 9 -1.41986273556691197D-05, -1.16444931672048640D-04, A -1.50803558053048762D-04, -1.55121924918096223D-04, B -1.46809756646465549D-04, -1.33815503867491367D-04, C -1.19744975684254051D-04, -1.06184319207974020D-04, D -9.37699549891194492D-05, -8.26923045588193274D-05, E -7.29374348155221211D-05, -6.44042357721016283D-05/ DATA ALFA(45), ALFA(46), ALFA(47), ALFA(48), ALFA(49), ALFA(50), 1 ALFA(51), ALFA(52), ALFA(53), ALFA(54), ALFA(55), ALFA(56), 2 ALFA(57), ALFA(58), ALFA(59), ALFA(60), ALFA(61), ALFA(62), 3 ALFA(63), ALFA(64), ALFA(65), ALFA(66)/ 4 -5.69611566009369048D-05, -5.04731044303561628D-05, 5 -4.48134868008882786D-05, -3.98688727717598864D-05, 6 -3.55400532972042498D-05, -3.17414256609022480D-05, 7 -2.83996793904174811D-05, -2.54522720634870566D-05, 8 -2.28459297164724555D-05, -2.05352753106480604D-05, 9 -1.84816217627666085D-05, -1.66519330021393806D-05, A -1.50179412980119482D-05, -1.35554031379040526D-05, B -1.22434746473858131D-05, -1.10641884811308169D-05, C -3.54211971457743841D-04, -1.56161263945159416D-04, D 3.04465503594936410D-05, 1.30198655773242693D-04, E 1.67471106699712269D-04, 1.70222587683592569D-04/ DATA ALFA(67), ALFA(68), ALFA(69), ALFA(70), ALFA(71), ALFA(72), 1 ALFA(73), ALFA(74), ALFA(75), ALFA(76), ALFA(77), ALFA(78), 2 ALFA(79), ALFA(80), ALFA(81), ALFA(82), ALFA(83), ALFA(84), 3 ALFA(85), ALFA(86), ALFA(87), ALFA(88)/ 4 1.56501427608594704D-04, 1.36339170977445120D-04, 5 1.14886692029825128D-04, 9.45869093034688111D-05, 6 7.64498419250898258D-05, 6.07570334965197354D-05, 7 4.74394299290508799D-05, 3.62757512005344297D-05, 8 2.69939714979224901D-05, 1.93210938247939253D-05, 9 1.30056674793963203D-05, 7.82620866744496661D-06, A 3.59257485819351583D-06, 1.44040049814251817D-07, B -2.65396769697939116D-06, -4.91346867098485910D-06, C -6.72739296091248287D-06, -8.17269379678657923D-06, D -9.31304715093561232D-06, -1.02011418798016441D-05, E -1.08805962510592880D-05, -1.13875481509603555D-05/ DATA ALFA(89), ALFA(90), ALFA(91), ALFA(92), ALFA(93), ALFA(94), 1 ALFA(95), ALFA(96), ALFA(97), ALFA(98), ALFA(99), ALFA(100), 2 ALFA(101), ALFA(102), ALFA(103), ALFA(104), ALFA(105), 3 ALFA(106), ALFA(107), ALFA(108), ALFA(109), ALFA(110)/ 4 -1.17519675674556414D-05, -1.19987364870944141D-05, 5 3.78194199201772914D-04, 2.02471952761816167D-04, 6 -6.37938506318862408D-05, -2.38598230603005903D-04, 7 -3.10916256027361568D-04, -3.13680115247576316D-04, 8 -2.78950273791323387D-04, -2.28564082619141374D-04, 9 -1.75245280340846749D-04, -1.25544063060690348D-04, A -8.22982872820208365D-05, -4.62860730588116458D-05, B -1.72334302366962267D-05, 5.60690482304602267D-06, C 2.31395443148286800D-05, 3.62642745856793957D-05, D 4.58006124490188752D-05, 5.24595294959114050D-05, E 5.68396208545815266D-05, 5.94349820393104052D-05/ DATA ALFA(111), ALFA(112), ALFA(113), ALFA(114), ALFA(115), 1 ALFA(116), ALFA(117), ALFA(118), ALFA(119), ALFA(120), 2 ALFA(121), ALFA(122), ALFA(123), ALFA(124), ALFA(125), 3 ALFA(126), ALFA(127), ALFA(128), ALFA(129), ALFA(130)/ 4 6.06478527578421742D-05, 6.08023907788436497D-05, 5 6.01577894539460388D-05, 5.89199657344698500D-05, 6 5.72515823777593053D-05, 5.52804375585852577D-05, 7 5.31063773802880170D-05, 5.08069302012325706D-05, 8 4.84418647620094842D-05, 4.60568581607475370D-05, 9 -6.91141397288294174D-04, -4.29976633058871912D-04, A 1.83067735980039018D-04, 6.60088147542014144D-04, B 8.75964969951185931D-04, 8.77335235958235514D-04, C 7.49369585378990637D-04, 5.63832329756980918D-04, D 3.68059319971443156D-04, 1.88464535514455599D-04/ DATA ALFA(131), ALFA(132), ALFA(133), ALFA(134), ALFA(135), 1 ALFA(136), ALFA(137), ALFA(138), ALFA(139), ALFA(140), 2 ALFA(141), ALFA(142), ALFA(143), ALFA(144), ALFA(145), 3 ALFA(146), ALFA(147), ALFA(148), ALFA(149), ALFA(150)/ 4 3.70663057664904149D-05, -8.28520220232137023D-05, 5 -1.72751952869172998D-04, -2.36314873605872983D-04, 6 -2.77966150694906658D-04, -3.02079514155456919D-04, 7 -3.12594712643820127D-04, -3.12872558758067163D-04, 8 -3.05678038466324377D-04, -2.93226470614557331D-04, 9 -2.77255655582934777D-04, -2.59103928467031709D-04, A -2.39784014396480342D-04, -2.20048260045422848D-04, B -2.00443911094971498D-04, -1.81358692210970687D-04, C -1.63057674478657464D-04, -1.45712672175205844D-04, D -1.29425421983924587D-04, -1.14245691942445952D-04/ DATA ALFA(151), ALFA(152), ALFA(153), ALFA(154), ALFA(155), 1 ALFA(156), ALFA(157), ALFA(158), ALFA(159), ALFA(160), 2 ALFA(161), ALFA(162), ALFA(163), ALFA(164), ALFA(165), 3 ALFA(166), ALFA(167), ALFA(168), ALFA(169), ALFA(170)/ 4 1.92821964248775885D-03, 1.35592576302022234D-03, 5 -7.17858090421302995D-04, -2.58084802575270346D-03, 6 -3.49271130826168475D-03, -3.46986299340960628D-03, 7 -2.82285233351310182D-03, -1.88103076404891354D-03, 8 -8.89531718383947600D-04, 3.87912102631035228D-06, 9 7.28688540119691412D-04, 1.26566373053457758D-03, A 1.62518158372674427D-03, 1.83203153216373172D-03, B 1.91588388990527909D-03, 1.90588846755546138D-03, C 1.82798982421825727D-03, 1.70389506421121530D-03, D 1.55097127171097686D-03, 1.38261421852276159D-03/ DATA ALFA(171), ALFA(172), ALFA(173), ALFA(174), ALFA(175), 1 ALFA(176), ALFA(177), ALFA(178), ALFA(179), ALFA(180)/ 2 1.20881424230064774D-03, 1.03676532638344962D-03, 3 8.71437918068619115D-04, 7.16080155297701002D-04, 4 5.72637002558129372D-04, 4.42089819465802277D-04, 5 3.24724948503090564D-04, 2.20342042730246599D-04, 6 1.28412898401353882D-04, 4.82005924552095464D-05/ DATA BETA(1), BETA(2), BETA(3), BETA(4), BETA(5), BETA(6), 1 BETA(7), BETA(8), BETA(9), BETA(10), BETA(11), BETA(12), 2 BETA(13), BETA(14), BETA(15), BETA(16), BETA(17), BETA(18), 3 BETA(19), BETA(20), BETA(21), BETA(22)/ 4 1.79988721413553309D-02, 5.59964911064388073D-03, 5 2.88501402231132779D-03, 1.80096606761053941D-03, 6 1.24753110589199202D-03, 9.22878876572938311D-04, 7 7.14430421727287357D-04, 5.71787281789704872D-04, 8 4.69431007606481533D-04, 3.93232835462916638D-04, 9 3.34818889318297664D-04, 2.88952148495751517D-04, A 2.52211615549573284D-04, 2.22280580798883327D-04, B 1.97541838033062524D-04, 1.76836855019718004D-04, C 1.59316899661821081D-04, 1.44347930197333986D-04, D 1.31448068119965379D-04, 1.20245444949302884D-04, E 1.10449144504599392D-04, 1.01828770740567258D-04/ DATA BETA(23), BETA(24), BETA(25), BETA(26), BETA(27), BETA(28), 1 BETA(29), BETA(30), BETA(31), BETA(32), BETA(33), BETA(34), 2 BETA(35), BETA(36), BETA(37), BETA(38), BETA(39), BETA(40), 3 BETA(41), BETA(42), BETA(43), BETA(44)/ 4 9.41998224204237509D-05, 8.74130545753834437D-05, 5 8.13466262162801467D-05, 7.59002269646219339D-05, 6 7.09906300634153481D-05, 6.65482874842468183D-05, 7 6.25146958969275078D-05, 5.88403394426251749D-05, 8 -1.49282953213429172D-03, -8.78204709546389328D-04, 9 -5.02916549572034614D-04, -2.94822138512746025D-04, A -1.75463996970782828D-04, -1.04008550460816434D-04, B -5.96141953046457895D-05, -3.12038929076098340D-05, C -1.26089735980230047D-05, -2.42892608575730389D-07, D 8.05996165414273571D-06, 1.36507009262147391D-05, E 1.73964125472926261D-05, 1.98672978842133780D-05/ DATA BETA(45), BETA(46), BETA(47), BETA(48), BETA(49), BETA(50), 1 BETA(51), BETA(52), BETA(53), BETA(54), BETA(55), BETA(56), 2 BETA(57), BETA(58), BETA(59), BETA(60), BETA(61), BETA(62), 3 BETA(63), BETA(64), BETA(65), BETA(66)/ 4 2.14463263790822639D-05, 2.23954659232456514D-05, 5 2.28967783814712629D-05, 2.30785389811177817D-05, 6 2.30321976080909144D-05, 2.28236073720348722D-05, 7 2.25005881105292418D-05, 2.20981015361991429D-05, 8 2.16418427448103905D-05, 2.11507649256220843D-05, 9 2.06388749782170737D-05, 2.01165241997081666D-05, A 1.95913450141179244D-05, 1.90689367910436740D-05, B 1.85533719641636667D-05, 1.80475722259674218D-05, C 5.52213076721292790D-04, 4.47932581552384646D-04, D 2.79520653992020589D-04, 1.52468156198446602D-04, E 6.93271105657043598D-05, 1.76258683069991397D-05/ DATA BETA(67), BETA(68), BETA(69), BETA(70), BETA(71), BETA(72), 1 BETA(73), BETA(74), BETA(75), BETA(76), BETA(77), BETA(78), 2 BETA(79), BETA(80), BETA(81), BETA(82), BETA(83), BETA(84), 3 BETA(85), BETA(86), BETA(87), BETA(88)/ 4 -1.35744996343269136D-05, -3.17972413350427135D-05, 5 -4.18861861696693365D-05, -4.69004889379141029D-05, 6 -4.87665447413787352D-05, -4.87010031186735069D-05, 7 -4.74755620890086638D-05, -4.55813058138628452D-05, 8 -4.33309644511266036D-05, -4.09230193157750364D-05, 9 -3.84822638603221274D-05, -3.60857167535410501D-05, A -3.37793306123367417D-05, -3.15888560772109621D-05, B -2.95269561750807315D-05, -2.75978914828335759D-05, C -2.58006174666883713D-05, -2.41308356761280200D-05, D -2.25823509518346033D-05, -2.11479656768912971D-05, E -1.98200638885294927D-05, -1.85909870801065077D-05/ DATA BETA(89), BETA(90), BETA(91), BETA(92), BETA(93), BETA(94), 1 BETA(95), BETA(96), BETA(97), BETA(98), BETA(99), BETA(100), 2 BETA(101), BETA(102), BETA(103), BETA(104), BETA(105), 3 BETA(106), BETA(107), BETA(108), BETA(109), BETA(110)/ 4 -1.74532699844210224D-05, -1.63997823854497997D-05, 5 -4.74617796559959808D-04, -4.77864567147321487D-04, 6 -3.20390228067037603D-04, -1.61105016119962282D-04, 7 -4.25778101285435204D-05, 3.44571294294967503D-05, 8 7.97092684075674924D-05, 1.03138236708272200D-04, 9 1.12466775262204158D-04, 1.13103642108481389D-04, A 1.08651634848774268D-04, 1.01437951597661973D-04, B 9.29298396593363896D-05, 8.40293133016089978D-05, C 7.52727991349134062D-05, 6.69632521975730872D-05, D 5.92564547323194704D-05, 5.22169308826975567D-05, E 4.58539485165360646D-05, 4.01445513891486808D-05/ DATA BETA(111), BETA(112), BETA(113), BETA(114), BETA(115), 1 BETA(116), BETA(117), BETA(118), BETA(119), BETA(120), 2 BETA(121), BETA(122), BETA(123), BETA(124), BETA(125), 3 BETA(126), BETA(127), BETA(128), BETA(129), BETA(130)/ 4 3.50481730031328081D-05, 3.05157995034346659D-05, 5 2.64956119950516039D-05, 2.29363633690998152D-05, 6 1.97893056664021636D-05, 1.70091984636412623D-05, 7 1.45547428261524004D-05, 1.23886640995878413D-05, 8 1.04775876076583236D-05, 8.79179954978479373D-06, 9 7.36465810572578444D-04, 8.72790805146193976D-04, A 6.22614862573135066D-04, 2.85998154194304147D-04, B 3.84737672879366102D-06, -1.87906003636971558D-04, C -2.97603646594554535D-04, -3.45998126832656348D-04, D -3.53382470916037712D-04, -3.35715635775048757D-04/ DATA BETA(131), BETA(132), BETA(133), BETA(134), BETA(135), 1 BETA(136), BETA(137), BETA(138), BETA(139), BETA(140), 2 BETA(141), BETA(142), BETA(143), BETA(144), BETA(145), 3 BETA(146), BETA(147), BETA(148), BETA(149), BETA(150)/ 4 -3.04321124789039809D-04, -2.66722723047612821D-04, 5 -2.27654214122819527D-04, -1.89922611854562356D-04, 6 -1.55058918599093870D-04, -1.23778240761873630D-04, 7 -9.62926147717644187D-05, -7.25178327714425337D-05, 8 -5.22070028895633801D-05, -3.50347750511900522D-05, 9 -2.06489761035551757D-05, -8.70106096849767054D-06, A 1.13698686675100290D-06, 9.16426474122778849D-06, B 1.56477785428872620D-05, 2.08223629482466847D-05, C 2.48923381004595156D-05, 2.80340509574146325D-05, D 3.03987774629861915D-05, 3.21156731406700616D-05/ DATA BETA(151), BETA(152), BETA(153), BETA(154), BETA(155), 1 BETA(156), BETA(157), BETA(158), BETA(159), BETA(160), 2 BETA(161), BETA(162), BETA(163), BETA(164), BETA(165), 3 BETA(166), BETA(167), BETA(168), BETA(169), BETA(170)/ 4 -1.80182191963885708D-03, -2.43402962938042533D-03, 5 -1.83422663549856802D-03, -7.62204596354009765D-04, 6 2.39079475256927218D-04, 9.49266117176881141D-04, 7 1.34467449701540359D-03, 1.48457495259449178D-03, 8 1.44732339830617591D-03, 1.30268261285657186D-03, 9 1.10351597375642682D-03, 8.86047440419791759D-04, A 6.73073208165665473D-04, 4.77603872856582378D-04, B 3.05991926358789362D-04, 1.60315694594721630D-04, C 4.00749555270613286D-05, -5.66607461635251611D-05, D -1.32506186772982638D-04, -1.90296187989614057D-04/ DATA BETA(171), BETA(172), BETA(173), BETA(174), BETA(175), 1 BETA(176), BETA(177), BETA(178), BETA(179), BETA(180), 2 BETA(181), BETA(182), BETA(183), BETA(184), BETA(185), 3 BETA(186), BETA(187), BETA(188), BETA(189), BETA(190)/ 4 -2.32811450376937408D-04, -2.62628811464668841D-04, 5 -2.82050469867598672D-04, -2.93081563192861167D-04, 6 -2.97435962176316616D-04, -2.96557334239348078D-04, 7 -2.91647363312090861D-04, -2.83696203837734166D-04, 8 -2.73512317095673346D-04, -2.61750155806768580D-04, 9 6.38585891212050914D-03, 9.62374215806377941D-03, A 7.61878061207001043D-03, 2.83219055545628054D-03, B -2.09841352012720090D-03, -5.73826764216626498D-03, C -7.70804244495414620D-03, -8.21011692264844401D-03, D -7.65824520346905413D-03, -6.47209729391045177D-03/ DATA BETA(191), BETA(192), BETA(193), BETA(194), BETA(195), 1 BETA(196), BETA(197), BETA(198), BETA(199), BETA(200), 2 BETA(201), BETA(202), BETA(203), BETA(204), BETA(205), 3 BETA(206), BETA(207), BETA(208), BETA(209), BETA(210)/ 4 -4.99132412004966473D-03, -3.45612289713133280D-03, 5 -2.01785580014170775D-03, -7.59430686781961401D-04, 6 2.84173631523859138D-04, 1.10891667586337403D-03, 7 1.72901493872728771D-03, 2.16812590802684701D-03, 8 2.45357710494539735D-03, 2.61281821058334862D-03, 9 2.67141039656276912D-03, 2.65203073395980430D-03, A 2.57411652877287315D-03, 2.45389126236094427D-03, B 2.30460058071795494D-03, 2.13684837686712662D-03, C 1.95896528478870911D-03, 1.77737008679454412D-03, D 1.59690280765839059D-03, 1.42111975664438546D-03/ DATA GAMA(1), GAMA(2), GAMA(3), GAMA(4), GAMA(5), GAMA(6), 1 GAMA(7), GAMA(8), GAMA(9), GAMA(10), GAMA(11), GAMA(12), 2 GAMA(13), GAMA(14), GAMA(15), GAMA(16), GAMA(17), GAMA(18), 3 GAMA(19), GAMA(20), GAMA(21), GAMA(22)/ 4 6.29960524947436582D-01, 2.51984209978974633D-01, 5 1.54790300415655846D-01, 1.10713062416159013D-01, 6 8.57309395527394825D-02, 6.97161316958684292D-02, 7 5.86085671893713576D-02, 5.04698873536310685D-02, 8 4.42600580689154809D-02, 3.93720661543509966D-02, 9 3.54283195924455368D-02, 3.21818857502098231D-02, A 2.94646240791157679D-02, 2.71581677112934479D-02, B 2.51768272973861779D-02, 2.34570755306078891D-02, C 2.19508390134907203D-02, 2.06210828235646240D-02, D 1.94388240897880846D-02, 1.83810633800683158D-02, E 1.74293213231963172D-02, 1.65685837786612353D-02/ DATA GAMA(23), GAMA(24), GAMA(25), GAMA(26), GAMA(27), GAMA(28), 1 GAMA(29), GAMA(30)/ 2 1.57865285987918445D-02, 1.50729501494095594D-02, 3 1.44193250839954639D-02, 1.38184805735341786D-02, 4 1.32643378994276568D-02, 1.27517121970498651D-02, 5 1.22761545318762767D-02, 1.18338262398482403D-02/ DATA EX1, EX2, HPI, GPI, THPI / 1 3.33333333333333333D-01, 6.66666666666666667D-01, 2 1.57079632679489662D+00, 3.14159265358979324D+00, 3 4.71238898038468986D+00/ DATA ZEROR,ZEROI,CONER,CONEI / 0.0D0, 0.0D0, 1.0D0, 0.0D0 / C RFNU = 1.0D0/FNU C----------------------------------------------------------------------- C OVERFLOW TEST (Z/FNU TOO SMALL) C----------------------------------------------------------------------- TEST = D1MACH(1)*1.0D+3 AC = FNU*TEST IF (DABS(ZR).GT.AC .OR. DABS(ZI).GT.AC) GO TO 15 ZETA1R = 2.0D0*DABS(DLOG(TEST))+FNU ZETA1I = 0.0D0 ZETA2R = FNU ZETA2I = 0.0D0 PHIR = 1.0D0 PHII = 0.0D0 ARGR = 1.0D0 ARGI = 0.0D0 RETURN 15 CONTINUE ZBR = ZR*RFNU ZBI = ZI*RFNU RFNU2 = RFNU*RFNU C----------------------------------------------------------------------- C COMPUTE IN THE FOURTH QUADRANT C----------------------------------------------------------------------- FN13 = FNU**EX1 FN23 = FN13*FN13 RFN13 = 1.0D0/FN13 W2R = CONER - ZBR*ZBR + ZBI*ZBI W2I = CONEI - ZBR*ZBI - ZBR*ZBI AW2 = ZABS(COMPLEX(W2R,W2I)) IF (AW2.GT.0.25D0) GO TO 130 C----------------------------------------------------------------------- C POWER SERIES FOR CABS(W2).LE.0.25D0 C----------------------------------------------------------------------- K = 1 PR(1) = CONER PI(1) = CONEI SUMAR = GAMA(1) SUMAI = ZEROI AP(1) = 1.0D0 IF (AW2.LT.TOL) GO TO 20 DO 10 K=2,30 PR(K) = PR(K-1)*W2R - PI(K-1)*W2I PI(K) = PR(K-1)*W2I + PI(K-1)*W2R SUMAR = SUMAR + PR(K)*GAMA(K) SUMAI = SUMAI + PI(K)*GAMA(K) AP(K) = AP(K-1)*AW2 IF (AP(K).LT.TOL) GO TO 20 10 CONTINUE K = 30 20 CONTINUE KMAX = K ZETAR = W2R*SUMAR - W2I*SUMAI ZETAI = W2R*SUMAI + W2I*SUMAR ARGR = ZETAR*FN23 ARGI = ZETAI*FN23 CALL ZSQRT(SUMAR, SUMAI, ZAR, ZAI) CALL ZSQRT(W2R, W2I, STR, STI) ZETA2R = STR*FNU ZETA2I = STI*FNU STR = CONER + EX2*(ZETAR*ZAR-ZETAI*ZAI) STI = CONEI + EX2*(ZETAR*ZAI+ZETAI*ZAR) ZETA1R = STR*ZETA2R - STI*ZETA2I ZETA1I = STR*ZETA2I + STI*ZETA2R ZAR = ZAR + ZAR ZAI = ZAI + ZAI CALL ZSQRT(ZAR, ZAI, STR, STI) PHIR = STR*RFN13 PHII = STI*RFN13 IF (IPMTR.EQ.1) GO TO 120 C----------------------------------------------------------------------- C SUM SERIES FOR ASUM AND BSUM C----------------------------------------------------------------------- SUMBR = ZEROR SUMBI = ZEROI DO 30 K=1,KMAX SUMBR = SUMBR + PR(K)*BETA(K) SUMBI = SUMBI + PI(K)*BETA(K) 30 CONTINUE ASUMR = ZEROR ASUMI = ZEROI BSUMR = SUMBR BSUMI = SUMBI L1 = 0 L2 = 30 BTOL = TOL*(DABS(BSUMR)+DABS(BSUMI)) ATOL = TOL PP = 1.0D0 IAS = 0 IBS = 0 IF (RFNU2.LT.TOL) GO TO 110 DO 100 IS=2,7 ATOL = ATOL/RFNU2 PP = PP*RFNU2 IF (IAS.EQ.1) GO TO 60 SUMAR = ZEROR SUMAI = ZEROI DO 40 K=1,KMAX M = L1 + K SUMAR = SUMAR + PR(K)*ALFA(M) SUMAI = SUMAI + PI(K)*ALFA(M) IF (AP(K).LT.ATOL) GO TO 50 40 CONTINUE 50 CONTINUE ASUMR = ASUMR + SUMAR*PP ASUMI = ASUMI + SUMAI*PP IF (PP.LT.TOL) IAS = 1 60 CONTINUE IF (IBS.EQ.1) GO TO 90 SUMBR = ZEROR SUMBI = ZEROI DO 70 K=1,KMAX M = L2 + K SUMBR = SUMBR + PR(K)*BETA(M) SUMBI = SUMBI + PI(K)*BETA(M) IF (AP(K).LT.ATOL) GO TO 80 70 CONTINUE 80 CONTINUE BSUMR = BSUMR + SUMBR*PP BSUMI = BSUMI + SUMBI*PP IF (PP.LT.BTOL) IBS = 1 90 CONTINUE IF (IAS.EQ.1 .AND. IBS.EQ.1) GO TO 110 L1 = L1 + 30 L2 = L2 + 30 100 CONTINUE 110 CONTINUE ASUMR = ASUMR + CONER PP = RFNU*RFN13 BSUMR = BSUMR*PP BSUMI = BSUMI*PP 120 CONTINUE RETURN C----------------------------------------------------------------------- C CABS(W2).GT.0.25D0 C----------------------------------------------------------------------- 130 CONTINUE CALL ZSQRT(W2R, W2I, WR, WI) IF (WR.LT.0.0D0) WR = 0.0D0 IF (WI.LT.0.0D0) WI = 0.0D0 STR = CONER + WR STI = WI CALL ZDIV(STR, STI, ZBR, ZBI, ZAR, ZAI) CALL ZLOG(ZAR, ZAI, ZCR, ZCI, IDUM) IF (ZCI.LT.0.0D0) ZCI = 0.0D0 IF (ZCI.GT.HPI) ZCI = HPI IF (ZCR.LT.0.0D0) ZCR = 0.0D0 ZTHR = (ZCR-WR)*1.5D0 ZTHI = (ZCI-WI)*1.5D0 ZETA1R = ZCR*FNU ZETA1I = ZCI*FNU ZETA2R = WR*FNU ZETA2I = WI*FNU AZTH = ZABS(COMPLEX(ZTHR,ZTHI)) ANG = THPI IF (ZTHR.GE.0.0D0 .AND. ZTHI.LT.0.0D0) GO TO 140 ANG = HPI IF (ZTHR.EQ.0.0D0) GO TO 140 ANG = DATAN(ZTHI/ZTHR) IF (ZTHR.LT.0.0D0) ANG = ANG + GPI 140 CONTINUE PP = AZTH**EX2 ANG = ANG*EX2 ZETAR = PP*DCOS(ANG) ZETAI = PP*DSIN(ANG) IF (ZETAI.LT.0.0D0) ZETAI = 0.0D0 ARGR = ZETAR*FN23 ARGI = ZETAI*FN23 CALL ZDIV(ZTHR, ZTHI, ZETAR, ZETAI, RTZTR, RTZTI) CALL ZDIV(RTZTR, RTZTI, WR, WI, ZAR, ZAI) TZAR = ZAR + ZAR TZAI = ZAI + ZAI CALL ZSQRT(TZAR, TZAI, STR, STI) PHIR = STR*RFN13 PHII = STI*RFN13 IF (IPMTR.EQ.1) GO TO 120 RAW = 1.0D0/DSQRT(AW2) STR = WR*RAW STI = -WI*RAW TFNR = STR*RFNU*RAW TFNI = STI*RFNU*RAW RAZTH = 1.0D0/AZTH STR = ZTHR*RAZTH STI = -ZTHI*RAZTH RZTHR = STR*RAZTH*RFNU RZTHI = STI*RAZTH*RFNU ZCR = RZTHR*AR(2) ZCI = RZTHI*AR(2) RAW2 = 1.0D0/AW2 STR = W2R*RAW2 STI = -W2I*RAW2 T2R = STR*RAW2 T2I = STI*RAW2 STR = T2R*C(2) + C(3) STI = T2I*C(2) UPR(2) = STR*TFNR - STI*TFNI UPI(2) = STR*TFNI + STI*TFNR BSUMR = UPR(2) + ZCR BSUMI = UPI(2) + ZCI ASUMR = ZEROR ASUMI = ZEROI IF (RFNU.LT.TOL) GO TO 220 PRZTHR = RZTHR PRZTHI = RZTHI PTFNR = TFNR PTFNI = TFNI UPR(1) = CONER UPI(1) = CONEI PP = 1.0D0 BTOL = TOL*(DABS(BSUMR)+DABS(BSUMI)) KS = 0 KP1 = 2 L = 3 IAS = 0 IBS = 0 DO 210 LR=2,12,2 LRP1 = LR + 1 C----------------------------------------------------------------------- C COMPUTE TWO ADDITIONAL CR, DR, AND UP FOR TWO MORE TERMS IN C NEXT SUMA AND SUMB C----------------------------------------------------------------------- DO 160 K=LR,LRP1 KS = KS + 1 KP1 = KP1 + 1 L = L + 1 ZAR = C(L) ZAI = ZEROI DO 150 J=2,KP1 L = L + 1 STR = ZAR*T2R - T2I*ZAI + C(L) ZAI = ZAR*T2I + ZAI*T2R ZAR = STR 150 CONTINUE STR = PTFNR*TFNR - PTFNI*TFNI PTFNI = PTFNR*TFNI + PTFNI*TFNR PTFNR = STR UPR(KP1) = PTFNR*ZAR - PTFNI*ZAI UPI(KP1) = PTFNI*ZAR + PTFNR*ZAI CRR(KS) = PRZTHR*BR(KS+1) CRI(KS) = PRZTHI*BR(KS+1) STR = PRZTHR*RZTHR - PRZTHI*RZTHI PRZTHI = PRZTHR*RZTHI + PRZTHI*RZTHR PRZTHR = STR DRR(KS) = PRZTHR*AR(KS+2) DRI(KS) = PRZTHI*AR(KS+2) 160 CONTINUE PP = PP*RFNU2 IF (IAS.EQ.1) GO TO 180 SUMAR = UPR(LRP1) SUMAI = UPI(LRP1) JU = LRP1 DO 170 JR=1,LR JU = JU - 1 SUMAR = SUMAR + CRR(JR)*UPR(JU) - CRI(JR)*UPI(JU) SUMAI = SUMAI + CRR(JR)*UPI(JU) + CRI(JR)*UPR(JU) 170 CONTINUE ASUMR = ASUMR + SUMAR ASUMI = ASUMI + SUMAI TEST = DABS(SUMAR) + DABS(SUMAI) IF (PP.LT.TOL .AND. TEST.LT.TOL) IAS = 1 180 CONTINUE IF (IBS.EQ.1) GO TO 200 SUMBR = UPR(LR+2) + UPR(LRP1)*ZCR - UPI(LRP1)*ZCI SUMBI = UPI(LR+2) + UPR(LRP1)*ZCI + UPI(LRP1)*ZCR JU = LRP1 DO 190 JR=1,LR JU = JU - 1 SUMBR = SUMBR + DRR(JR)*UPR(JU) - DRI(JR)*UPI(JU) SUMBI = SUMBI + DRR(JR)*UPI(JU) + DRI(JR)*UPR(JU) 190 CONTINUE BSUMR = BSUMR + SUMBR BSUMI = BSUMI + SUMBI TEST = DABS(SUMBR) + DABS(SUMBI) IF (PP.LT.BTOL .AND. TEST.LT.BTOL) IBS = 1 200 CONTINUE IF (IAS.EQ.1 .AND. IBS.EQ.1) GO TO 220 210 CONTINUE 220 CONTINUE ASUMR = ASUMR + CONER STR = -BSUMR*RFN13 STI = -BSUMI*RFN13 CALL ZDIV(STR, STI, RTZTR, RTZTI, BSUMR, BSUMI) GO TO 120 END openspecfun-0.3/amos/zuni1.f000066400000000000000000000146611232445310600160650ustar00rootroot00000000000000 SUBROUTINE ZUNI1(ZR, ZI, FNU, KODE, N, YR, YI, NZ, NLAST, FNUL, * TOL, ELIM, ALIM) C***BEGIN PROLOGUE ZUNI1 C***REFER TO ZBESI,ZBESK C C ZUNI1 COMPUTES I(FNU,Z) BY MEANS OF THE UNIFORM ASYMPTOTIC C EXPANSION FOR I(FNU,Z) IN -PI/3.LE.ARG Z.LE.PI/3. C C FNUL IS THE SMALLEST ORDER PERMITTED FOR THE ASYMPTOTIC C EXPANSION. NLAST=0 MEANS ALL OF THE Y VALUES WERE SET. C NLAST.NE.0 IS THE NUMBER LEFT TO BE COMPUTED BY ANOTHER C FORMULA FOR ORDERS FNU TO FNU+NLAST-1 BECAUSE FNU+NLAST-1.LT.FNUL. C Y(I)=CZERO FOR I=NLAST+1,N C C***ROUTINES CALLED ZUCHK,ZUNIK,ZUOIK,D1MACH,ZABS C***END PROLOGUE ZUNI1 C COMPLEX CFN,CONE,CRSC,CSCL,CSR,CSS,CWRK,CZERO,C1,C2,PHI,RZ,SUM,S1, C *S2,Y,Z,ZETA1,ZETA2 DOUBLE PRECISION ALIM, APHI, ASCLE, BRY, CONER, CRSC, * CSCL, CSRR, CSSR, CWRKI, CWRKR, C1R, C2I, C2M, C2R, ELIM, FN, * FNU, FNUL, PHII, PHIR, RAST, RS1, RZI, RZR, STI, STR, SUMI, * SUMR, S1I, S1R, S2I, S2R, TOL, YI, YR, ZEROI, ZEROR, ZETA1I, * ZETA1R, ZETA2I, ZETA2R, ZI, ZR, CYR, CYI, D1MACH, ZABS INTEGER I, IFLAG, INIT, K, KODE, M, N, ND, NLAST, NN, NUF, NW, NZ DIMENSION BRY(3), YR(N), YI(N), CWRKR(16), CWRKI(16), CSSR(3), * CSRR(3), CYR(2), CYI(2) DATA ZEROR,ZEROI,CONER / 0.0D0, 0.0D0, 1.0D0 / C NZ = 0 ND = N NLAST = 0 C----------------------------------------------------------------------- C COMPUTED VALUES WITH EXPONENTS BETWEEN ALIM AND ELIM IN MAG- C NITUDE ARE SCALED TO KEEP INTERMEDIATE ARITHMETIC ON SCALE, C EXP(ALIM)=EXP(ELIM)*TOL C----------------------------------------------------------------------- CSCL = 1.0D0/TOL CRSC = TOL CSSR(1) = CSCL CSSR(2) = CONER CSSR(3) = CRSC CSRR(1) = CRSC CSRR(2) = CONER CSRR(3) = CSCL BRY(1) = 1.0D+3*D1MACH(1)/TOL C----------------------------------------------------------------------- C CHECK FOR UNDERFLOW AND OVERFLOW ON FIRST MEMBER C----------------------------------------------------------------------- FN = DMAX1(FNU,1.0D0) INIT = 0 CALL ZUNIK(ZR, ZI, FN, 1, 1, TOL, INIT, PHIR, PHII, ZETA1R, * ZETA1I, ZETA2R, ZETA2I, SUMR, SUMI, CWRKR, CWRKI) IF (KODE.EQ.1) GO TO 10 STR = ZR + ZETA2R STI = ZI + ZETA2I RAST = FN/ZABS(COMPLEX(STR,STI)) STR = STR*RAST*RAST STI = -STI*RAST*RAST S1R = -ZETA1R + STR S1I = -ZETA1I + STI GO TO 20 10 CONTINUE S1R = -ZETA1R + ZETA2R S1I = -ZETA1I + ZETA2I 20 CONTINUE RS1 = S1R IF (DABS(RS1).GT.ELIM) GO TO 130 30 CONTINUE NN = MIN0(2,ND) DO 80 I=1,NN FN = FNU + DBLE(FLOAT(ND-I)) INIT = 0 CALL ZUNIK(ZR, ZI, FN, 1, 0, TOL, INIT, PHIR, PHII, ZETA1R, * ZETA1I, ZETA2R, ZETA2I, SUMR, SUMI, CWRKR, CWRKI) IF (KODE.EQ.1) GO TO 40 STR = ZR + ZETA2R STI = ZI + ZETA2I RAST = FN/ZABS(COMPLEX(STR,STI)) STR = STR*RAST*RAST STI = -STI*RAST*RAST S1R = -ZETA1R + STR S1I = -ZETA1I + STI + ZI GO TO 50 40 CONTINUE S1R = -ZETA1R + ZETA2R S1I = -ZETA1I + ZETA2I 50 CONTINUE C----------------------------------------------------------------------- C TEST FOR UNDERFLOW AND OVERFLOW C----------------------------------------------------------------------- RS1 = S1R IF (DABS(RS1).GT.ELIM) GO TO 110 IF (I.EQ.1) IFLAG = 2 IF (DABS(RS1).LT.ALIM) GO TO 60 C----------------------------------------------------------------------- C REFINE TEST AND SCALE C----------------------------------------------------------------------- APHI = ZABS(COMPLEX(PHIR,PHII)) RS1 = RS1 + DLOG(APHI) IF (DABS(RS1).GT.ELIM) GO TO 110 IF (I.EQ.1) IFLAG = 1 IF (RS1.LT.0.0D0) GO TO 60 IF (I.EQ.1) IFLAG = 3 60 CONTINUE C----------------------------------------------------------------------- C SCALE S1 IF CABS(S1).LT.ASCLE C----------------------------------------------------------------------- S2R = PHIR*SUMR - PHII*SUMI S2I = PHIR*SUMI + PHII*SUMR STR = DEXP(S1R)*CSSR(IFLAG) S1R = STR*DCOS(S1I) S1I = STR*DSIN(S1I) STR = S2R*S1R - S2I*S1I S2I = S2R*S1I + S2I*S1R S2R = STR IF (IFLAG.NE.1) GO TO 70 CALL ZUCHK(S2R, S2I, NW, BRY(1), TOL) IF (NW.NE.0) GO TO 110 70 CONTINUE CYR(I) = S2R CYI(I) = S2I M = ND - I + 1 YR(M) = S2R*CSRR(IFLAG) YI(M) = S2I*CSRR(IFLAG) 80 CONTINUE IF (ND.LE.2) GO TO 100 RAST = 1.0D0/ZABS(COMPLEX(ZR,ZI)) STR = ZR*RAST STI = -ZI*RAST RZR = (STR+STR)*RAST RZI = (STI+STI)*RAST BRY(2) = 1.0D0/BRY(1) BRY(3) = D1MACH(2) S1R = CYR(1) S1I = CYI(1) S2R = CYR(2) S2I = CYI(2) C1R = CSRR(IFLAG) ASCLE = BRY(IFLAG) K = ND - 2 FN = DBLE(FLOAT(K)) DO 90 I=3,ND C2R = S2R C2I = S2I S2R = S1R + (FNU+FN)*(RZR*C2R-RZI*C2I) S2I = S1I + (FNU+FN)*(RZR*C2I+RZI*C2R) S1R = C2R S1I = C2I C2R = S2R*C1R C2I = S2I*C1R YR(K) = C2R YI(K) = C2I K = K - 1 FN = FN - 1.0D0 IF (IFLAG.GE.3) GO TO 90 STR = DABS(C2R) STI = DABS(C2I) C2M = DMAX1(STR,STI) IF (C2M.LE.ASCLE) GO TO 90 IFLAG = IFLAG + 1 ASCLE = BRY(IFLAG) S1R = S1R*C1R S1I = S1I*C1R S2R = C2R S2I = C2I S1R = S1R*CSSR(IFLAG) S1I = S1I*CSSR(IFLAG) S2R = S2R*CSSR(IFLAG) S2I = S2I*CSSR(IFLAG) C1R = CSRR(IFLAG) 90 CONTINUE 100 CONTINUE RETURN C----------------------------------------------------------------------- C SET UNDERFLOW AND UPDATE PARAMETERS C----------------------------------------------------------------------- 110 CONTINUE IF (RS1.GT.0.0D0) GO TO 120 YR(ND) = ZEROR YI(ND) = ZEROI NZ = NZ + 1 ND = ND - 1 IF (ND.EQ.0) GO TO 100 CALL ZUOIK(ZR, ZI, FNU, KODE, 1, ND, YR, YI, NUF, TOL, ELIM, ALIM) IF (NUF.LT.0) GO TO 120 ND = ND - NUF NZ = NZ + NUF IF (ND.EQ.0) GO TO 100 FN = FNU + DBLE(FLOAT(ND-1)) IF (FN.GE.FNUL) GO TO 30 NLAST = ND RETURN 120 CONTINUE NZ = -1 RETURN 130 CONTINUE IF (RS1.GT.0.0D0) GO TO 120 NZ = N DO 140 I=1,N YR(I) = ZEROR YI(I) = ZEROI 140 CONTINUE RETURN END openspecfun-0.3/amos/zuni2.f000066400000000000000000000211261232445310600160600ustar00rootroot00000000000000 SUBROUTINE ZUNI2(ZR, ZI, FNU, KODE, N, YR, YI, NZ, NLAST, FNUL, * TOL, ELIM, ALIM) C***BEGIN PROLOGUE ZUNI2 C***REFER TO ZBESI,ZBESK C C ZUNI2 COMPUTES I(FNU,Z) IN THE RIGHT HALF PLANE BY MEANS OF C UNIFORM ASYMPTOTIC EXPANSION FOR J(FNU,ZN) WHERE ZN IS Z*I C OR -Z*I AND ZN IS IN THE RIGHT HALF PLANE ALSO. C C FNUL IS THE SMALLEST ORDER PERMITTED FOR THE ASYMPTOTIC C EXPANSION. NLAST=0 MEANS ALL OF THE Y VALUES WERE SET. C NLAST.NE.0 IS THE NUMBER LEFT TO BE COMPUTED BY ANOTHER C FORMULA FOR ORDERS FNU TO FNU+NLAST-1 BECAUSE FNU+NLAST-1.LT.FNUL. C Y(I)=CZERO FOR I=NLAST+1,N C C***ROUTINES CALLED ZAIRY,ZUCHK,ZUNHJ,ZUOIK,D1MACH,ZABS C***END PROLOGUE ZUNI2 C COMPLEX AI,ARG,ASUM,BSUM,CFN,CI,CID,CIP,CONE,CRSC,CSCL,CSR,CSS, C *CZERO,C1,C2,DAI,PHI,RZ,S1,S2,Y,Z,ZB,ZETA1,ZETA2,ZN DOUBLE PRECISION AARG, AIC, AII, AIR, ALIM, ANG, APHI, ARGI, * ARGR, ASCLE, ASUMI, ASUMR, BRY, BSUMI, BSUMR, CIDI, CIPI, CIPR, * CONER, CRSC, CSCL, CSRR, CSSR, C1R, C2I, C2M, C2R, DAII, * DAIR, ELIM, FN, FNU, FNUL, HPI, PHII, PHIR, RAST, RAZ, RS1, RZI, * RZR, STI, STR, S1I, S1R, S2I, S2R, TOL, YI, YR, ZBI, ZBR, ZEROI, * ZEROR, ZETA1I, ZETA1R, ZETA2I, ZETA2R, ZI, ZNI, ZNR, ZR, CYR, * CYI, D1MACH, ZABS, CAR, SAR INTEGER I, IFLAG, IN, INU, J, K, KODE, N, NAI, ND, NDAI, NLAST, * NN, NUF, NW, NZ, IDUM DIMENSION BRY(3), YR(N), YI(N), CIPR(4), CIPI(4), CSSR(3), * CSRR(3), CYR(2), CYI(2) DATA ZEROR,ZEROI,CONER / 0.0D0, 0.0D0, 1.0D0 / DATA CIPR(1),CIPI(1),CIPR(2),CIPI(2),CIPR(3),CIPI(3),CIPR(4), * CIPI(4)/ 1.0D0,0.0D0, 0.0D0,1.0D0, -1.0D0,0.0D0, 0.0D0,-1.0D0/ DATA HPI, AIC / 1 1.57079632679489662D+00, 1.265512123484645396D+00/ C NZ = 0 ND = N NLAST = 0 C----------------------------------------------------------------------- C COMPUTED VALUES WITH EXPONENTS BETWEEN ALIM AND ELIM IN MAG- C NITUDE ARE SCALED TO KEEP INTERMEDIATE ARITHMETIC ON SCALE, C EXP(ALIM)=EXP(ELIM)*TOL C----------------------------------------------------------------------- CSCL = 1.0D0/TOL CRSC = TOL CSSR(1) = CSCL CSSR(2) = CONER CSSR(3) = CRSC CSRR(1) = CRSC CSRR(2) = CONER CSRR(3) = CSCL BRY(1) = 1.0D+3*D1MACH(1)/TOL C----------------------------------------------------------------------- C ZN IS IN THE RIGHT HALF PLANE AFTER ROTATION BY CI OR -CI C----------------------------------------------------------------------- ZNR = ZI ZNI = -ZR ZBR = ZR ZBI = ZI CIDI = -CONER INU = INT(SNGL(FNU)) ANG = HPI*(FNU-DBLE(FLOAT(INU))) C2R = DCOS(ANG) C2I = DSIN(ANG) CAR = C2R SAR = C2I IN = INU + N - 1 IN = MOD(IN,4) + 1 STR = C2R*CIPR(IN) - C2I*CIPI(IN) C2I = C2R*CIPI(IN) + C2I*CIPR(IN) C2R = STR IF (ZI.GT.0.0D0) GO TO 10 ZNR = -ZNR ZBI = -ZBI CIDI = -CIDI C2I = -C2I 10 CONTINUE C----------------------------------------------------------------------- C CHECK FOR UNDERFLOW AND OVERFLOW ON FIRST MEMBER C----------------------------------------------------------------------- FN = DMAX1(FNU,1.0D0) CALL ZUNHJ(ZNR, ZNI, FN, 1, TOL, PHIR, PHII, ARGR, ARGI, ZETA1R, * ZETA1I, ZETA2R, ZETA2I, ASUMR, ASUMI, BSUMR, BSUMI) IF (KODE.EQ.1) GO TO 20 STR = ZBR + ZETA2R STI = ZBI + ZETA2I RAST = FN/ZABS(COMPLEX(STR,STI)) STR = STR*RAST*RAST STI = -STI*RAST*RAST S1R = -ZETA1R + STR S1I = -ZETA1I + STI GO TO 30 20 CONTINUE S1R = -ZETA1R + ZETA2R S1I = -ZETA1I + ZETA2I 30 CONTINUE RS1 = S1R IF (DABS(RS1).GT.ELIM) GO TO 150 40 CONTINUE NN = MIN0(2,ND) DO 90 I=1,NN FN = FNU + DBLE(FLOAT(ND-I)) CALL ZUNHJ(ZNR, ZNI, FN, 0, TOL, PHIR, PHII, ARGR, ARGI, * ZETA1R, ZETA1I, ZETA2R, ZETA2I, ASUMR, ASUMI, BSUMR, BSUMI) IF (KODE.EQ.1) GO TO 50 STR = ZBR + ZETA2R STI = ZBI + ZETA2I RAST = FN/ZABS(COMPLEX(STR,STI)) STR = STR*RAST*RAST STI = -STI*RAST*RAST S1R = -ZETA1R + STR S1I = -ZETA1I + STI + DABS(ZI) GO TO 60 50 CONTINUE S1R = -ZETA1R + ZETA2R S1I = -ZETA1I + ZETA2I 60 CONTINUE C----------------------------------------------------------------------- C TEST FOR UNDERFLOW AND OVERFLOW C----------------------------------------------------------------------- RS1 = S1R IF (DABS(RS1).GT.ELIM) GO TO 120 IF (I.EQ.1) IFLAG = 2 IF (DABS(RS1).LT.ALIM) GO TO 70 C----------------------------------------------------------------------- C REFINE TEST AND SCALE C----------------------------------------------------------------------- C----------------------------------------------------------------------- APHI = ZABS(COMPLEX(PHIR,PHII)) AARG = ZABS(COMPLEX(ARGR,ARGI)) RS1 = RS1 + DLOG(APHI) - 0.25D0*DLOG(AARG) - AIC IF (DABS(RS1).GT.ELIM) GO TO 120 IF (I.EQ.1) IFLAG = 1 IF (RS1.LT.0.0D0) GO TO 70 IF (I.EQ.1) IFLAG = 3 70 CONTINUE C----------------------------------------------------------------------- C SCALE S1 TO KEEP INTERMEDIATE ARITHMETIC ON SCALE NEAR C EXPONENT EXTREMES C----------------------------------------------------------------------- CALL ZAIRY(ARGR, ARGI, 0, 2, AIR, AII, NAI, IDUM) CALL ZAIRY(ARGR, ARGI, 1, 2, DAIR, DAII, NDAI, IDUM) STR = DAIR*BSUMR - DAII*BSUMI STI = DAIR*BSUMI + DAII*BSUMR STR = STR + (AIR*ASUMR-AII*ASUMI) STI = STI + (AIR*ASUMI+AII*ASUMR) S2R = PHIR*STR - PHII*STI S2I = PHIR*STI + PHII*STR STR = DEXP(S1R)*CSSR(IFLAG) S1R = STR*DCOS(S1I) S1I = STR*DSIN(S1I) STR = S2R*S1R - S2I*S1I S2I = S2R*S1I + S2I*S1R S2R = STR IF (IFLAG.NE.1) GO TO 80 CALL ZUCHK(S2R, S2I, NW, BRY(1), TOL) IF (NW.NE.0) GO TO 120 80 CONTINUE IF (ZI.LE.0.0D0) S2I = -S2I STR = S2R*C2R - S2I*C2I S2I = S2R*C2I + S2I*C2R S2R = STR CYR(I) = S2R CYI(I) = S2I J = ND - I + 1 YR(J) = S2R*CSRR(IFLAG) YI(J) = S2I*CSRR(IFLAG) STR = -C2I*CIDI C2I = C2R*CIDI C2R = STR 90 CONTINUE IF (ND.LE.2) GO TO 110 RAZ = 1.0D0/ZABS(COMPLEX(ZR,ZI)) STR = ZR*RAZ STI = -ZI*RAZ RZR = (STR+STR)*RAZ RZI = (STI+STI)*RAZ BRY(2) = 1.0D0/BRY(1) BRY(3) = D1MACH(2) S1R = CYR(1) S1I = CYI(1) S2R = CYR(2) S2I = CYI(2) C1R = CSRR(IFLAG) ASCLE = BRY(IFLAG) K = ND - 2 FN = DBLE(FLOAT(K)) DO 100 I=3,ND C2R = S2R C2I = S2I S2R = S1R + (FNU+FN)*(RZR*C2R-RZI*C2I) S2I = S1I + (FNU+FN)*(RZR*C2I+RZI*C2R) S1R = C2R S1I = C2I C2R = S2R*C1R C2I = S2I*C1R YR(K) = C2R YI(K) = C2I K = K - 1 FN = FN - 1.0D0 IF (IFLAG.GE.3) GO TO 100 STR = DABS(C2R) STI = DABS(C2I) C2M = DMAX1(STR,STI) IF (C2M.LE.ASCLE) GO TO 100 IFLAG = IFLAG + 1 ASCLE = BRY(IFLAG) S1R = S1R*C1R S1I = S1I*C1R S2R = C2R S2I = C2I S1R = S1R*CSSR(IFLAG) S1I = S1I*CSSR(IFLAG) S2R = S2R*CSSR(IFLAG) S2I = S2I*CSSR(IFLAG) C1R = CSRR(IFLAG) 100 CONTINUE 110 CONTINUE RETURN 120 CONTINUE IF (RS1.GT.0.0D0) GO TO 140 C----------------------------------------------------------------------- C SET UNDERFLOW AND UPDATE PARAMETERS C----------------------------------------------------------------------- YR(ND) = ZEROR YI(ND) = ZEROI NZ = NZ + 1 ND = ND - 1 IF (ND.EQ.0) GO TO 110 CALL ZUOIK(ZR, ZI, FNU, KODE, 1, ND, YR, YI, NUF, TOL, ELIM, ALIM) IF (NUF.LT.0) GO TO 140 ND = ND - NUF NZ = NZ + NUF IF (ND.EQ.0) GO TO 110 FN = FNU + DBLE(FLOAT(ND-1)) IF (FN.LT.FNUL) GO TO 130 C FN = CIDI C J = NUF + 1 C K = MOD(J,4) + 1 C S1R = CIPR(K) C S1I = CIPI(K) C IF (FN.LT.0.0D0) S1I = -S1I C STR = C2R*S1R - C2I*S1I C C2I = C2R*S1I + C2I*S1R C C2R = STR IN = INU + ND - 1 IN = MOD(IN,4) + 1 C2R = CAR*CIPR(IN) - SAR*CIPI(IN) C2I = CAR*CIPI(IN) + SAR*CIPR(IN) IF (ZI.LE.0.0D0) C2I = -C2I GO TO 40 130 CONTINUE NLAST = ND RETURN 140 CONTINUE NZ = -1 RETURN 150 CONTINUE IF (RS1.GT.0.0D0) GO TO 140 NZ = N DO 160 I=1,N YR(I) = ZEROR YI(I) = ZEROI 160 CONTINUE RETURN END openspecfun-0.3/amos/zunik.f000066400000000000000000000221371232445310600161540ustar00rootroot00000000000000 SUBROUTINE ZUNIK(ZRR, ZRI, FNU, IKFLG, IPMTR, TOL, INIT, PHIR, * PHII, ZETA1R, ZETA1I, ZETA2R, ZETA2I, SUMR, SUMI, CWRKR, CWRKI) C***BEGIN PROLOGUE ZUNIK C***REFER TO ZBESI,ZBESK C C ZUNIK COMPUTES PARAMETERS FOR THE UNIFORM ASYMPTOTIC C EXPANSIONS OF THE I AND K FUNCTIONS ON IKFLG= 1 OR 2 C RESPECTIVELY BY C C W(FNU,ZR) = PHI*EXP(ZETA)*SUM C C WHERE ZETA=-ZETA1 + ZETA2 OR C ZETA1 - ZETA2 C C THE FIRST CALL MUST HAVE INIT=0. SUBSEQUENT CALLS WITH THE C SAME ZR AND FNU WILL RETURN THE I OR K FUNCTION ON IKFLG= C 1 OR 2 WITH NO CHANGE IN INIT. CWRK IS A COMPLEX WORK C ARRAY. IPMTR=0 COMPUTES ALL PARAMETERS. IPMTR=1 COMPUTES PHI, C ZETA1,ZETA2. C C***ROUTINES CALLED ZDIV,ZLOG,ZSQRT,D1MACH C***END PROLOGUE ZUNIK C COMPLEX CFN,CON,CONE,CRFN,CWRK,CZERO,PHI,S,SR,SUM,T,T2,ZETA1, C *ZETA2,ZN,ZR DOUBLE PRECISION AC, C, CON, CONEI, CONER, CRFNI, CRFNR, CWRKI, * CWRKR, FNU, PHII, PHIR, RFN, SI, SR, SRI, SRR, STI, STR, SUMI, * SUMR, TEST, TI, TOL, TR, T2I, T2R, ZEROI, ZEROR, ZETA1I, ZETA1R, * ZETA2I, ZETA2R, ZNI, ZNR, ZRI, ZRR, D1MACH INTEGER I, IDUM, IKFLG, INIT, IPMTR, J, K, L DIMENSION C(120), CWRKR(16), CWRKI(16), CON(2) DATA ZEROR,ZEROI,CONER,CONEI / 0.0D0, 0.0D0, 1.0D0, 0.0D0 / DATA CON(1), CON(2) / 1 3.98942280401432678D-01, 1.25331413731550025D+00 / DATA C(1), C(2), C(3), C(4), C(5), C(6), C(7), C(8), C(9), C(10), 1 C(11), C(12), C(13), C(14), C(15), C(16), C(17), C(18), 2 C(19), C(20), C(21), C(22), C(23), C(24)/ 3 1.00000000000000000D+00, -2.08333333333333333D-01, 4 1.25000000000000000D-01, 3.34201388888888889D-01, 5 -4.01041666666666667D-01, 7.03125000000000000D-02, 6 -1.02581259645061728D+00, 1.84646267361111111D+00, 7 -8.91210937500000000D-01, 7.32421875000000000D-02, 8 4.66958442342624743D+00, -1.12070026162229938D+01, 9 8.78912353515625000D+00, -2.36408691406250000D+00, A 1.12152099609375000D-01, -2.82120725582002449D+01, B 8.46362176746007346D+01, -9.18182415432400174D+01, C 4.25349987453884549D+01, -7.36879435947963170D+00, D 2.27108001708984375D-01, 2.12570130039217123D+02, E -7.65252468141181642D+02, 1.05999045252799988D+03/ DATA C(25), C(26), C(27), C(28), C(29), C(30), C(31), C(32), 1 C(33), C(34), C(35), C(36), C(37), C(38), C(39), C(40), 2 C(41), C(42), C(43), C(44), C(45), C(46), C(47), C(48)/ 3 -6.99579627376132541D+02, 2.18190511744211590D+02, 4 -2.64914304869515555D+01, 5.72501420974731445D-01, 5 -1.91945766231840700D+03, 8.06172218173730938D+03, 6 -1.35865500064341374D+04, 1.16553933368645332D+04, 7 -5.30564697861340311D+03, 1.20090291321635246D+03, 8 -1.08090919788394656D+02, 1.72772750258445740D+00, 9 2.02042913309661486D+04, -9.69805983886375135D+04, A 1.92547001232531532D+05, -2.03400177280415534D+05, B 1.22200464983017460D+05, -4.11926549688975513D+04, C 7.10951430248936372D+03, -4.93915304773088012D+02, D 6.07404200127348304D+00, -2.42919187900551333D+05, E 1.31176361466297720D+06, -2.99801591853810675D+06/ DATA C(49), C(50), C(51), C(52), C(53), C(54), C(55), C(56), 1 C(57), C(58), C(59), C(60), C(61), C(62), C(63), C(64), 2 C(65), C(66), C(67), C(68), C(69), C(70), C(71), C(72)/ 3 3.76327129765640400D+06, -2.81356322658653411D+06, 4 1.26836527332162478D+06, -3.31645172484563578D+05, 5 4.52187689813627263D+04, -2.49983048181120962D+03, 6 2.43805296995560639D+01, 3.28446985307203782D+06, 7 -1.97068191184322269D+07, 5.09526024926646422D+07, 8 -7.41051482115326577D+07, 6.63445122747290267D+07, 9 -3.75671766607633513D+07, 1.32887671664218183D+07, A -2.78561812808645469D+06, 3.08186404612662398D+05, B -1.38860897537170405D+04, 1.10017140269246738D+02, C -4.93292536645099620D+07, 3.25573074185765749D+08, D -9.39462359681578403D+08, 1.55359689957058006D+09, E -1.62108055210833708D+09, 1.10684281682301447D+09/ DATA C(73), C(74), C(75), C(76), C(77), C(78), C(79), C(80), 1 C(81), C(82), C(83), C(84), C(85), C(86), C(87), C(88), 2 C(89), C(90), C(91), C(92), C(93), C(94), C(95), C(96)/ 3 -4.95889784275030309D+08, 1.42062907797533095D+08, 4 -2.44740627257387285D+07, 2.24376817792244943D+06, 5 -8.40054336030240853D+04, 5.51335896122020586D+02, 6 8.14789096118312115D+08, -5.86648149205184723D+09, 7 1.86882075092958249D+10, -3.46320433881587779D+10, 8 4.12801855797539740D+10, -3.30265997498007231D+10, 9 1.79542137311556001D+10, -6.56329379261928433D+09, A 1.55927986487925751D+09, -2.25105661889415278D+08, B 1.73951075539781645D+07, -5.49842327572288687D+05, C 3.03809051092238427D+03, -1.46792612476956167D+10, D 1.14498237732025810D+11, -3.99096175224466498D+11, E 8.19218669548577329D+11, -1.09837515608122331D+12/ DATA C(97), C(98), C(99), C(100), C(101), C(102), C(103), C(104), 1 C(105), C(106), C(107), C(108), C(109), C(110), C(111), 2 C(112), C(113), C(114), C(115), C(116), C(117), C(118)/ 3 1.00815810686538209D+12, -6.45364869245376503D+11, 4 2.87900649906150589D+11, -8.78670721780232657D+10, 5 1.76347306068349694D+10, -2.16716498322379509D+09, 6 1.43157876718888981D+08, -3.87183344257261262D+06, 7 1.82577554742931747D+04, 2.86464035717679043D+11, 8 -2.40629790002850396D+12, 9.10934118523989896D+12, 9 -2.05168994109344374D+13, 3.05651255199353206D+13, A -3.16670885847851584D+13, 2.33483640445818409D+13, B -1.23204913055982872D+13, 4.61272578084913197D+12, C -1.19655288019618160D+12, 2.05914503232410016D+11, D -2.18229277575292237D+10, 1.24700929351271032D+09/ DATA C(119), C(120)/ 1 -2.91883881222208134D+07, 1.18838426256783253D+05/ C IF (INIT.NE.0) GO TO 40 C----------------------------------------------------------------------- C INITIALIZE ALL VARIABLES C----------------------------------------------------------------------- RFN = 1.0D0/FNU C----------------------------------------------------------------------- C OVERFLOW TEST (ZR/FNU TOO SMALL) C----------------------------------------------------------------------- TEST = D1MACH(1)*1.0D+3 AC = FNU*TEST IF (DABS(ZRR).GT.AC .OR. DABS(ZRI).GT.AC) GO TO 15 ZETA1R = 2.0D0*DABS(DLOG(TEST))+FNU ZETA1I = 0.0D0 ZETA2R = FNU ZETA2I = 0.0D0 PHIR = 1.0D0 PHII = 0.0D0 RETURN 15 CONTINUE TR = ZRR*RFN TI = ZRI*RFN SR = CONER + (TR*TR-TI*TI) SI = CONEI + (TR*TI+TI*TR) CALL ZSQRT(SR, SI, SRR, SRI) STR = CONER + SRR STI = CONEI + SRI CALL ZDIV(STR, STI, TR, TI, ZNR, ZNI) CALL ZLOG(ZNR, ZNI, STR, STI, IDUM) ZETA1R = FNU*STR ZETA1I = FNU*STI ZETA2R = FNU*SRR ZETA2I = FNU*SRI CALL ZDIV(CONER, CONEI, SRR, SRI, TR, TI) SRR = TR*RFN SRI = TI*RFN CALL ZSQRT(SRR, SRI, CWRKR(16), CWRKI(16)) PHIR = CWRKR(16)*CON(IKFLG) PHII = CWRKI(16)*CON(IKFLG) IF (IPMTR.NE.0) RETURN CALL ZDIV(CONER, CONEI, SR, SI, T2R, T2I) CWRKR(1) = CONER CWRKI(1) = CONEI CRFNR = CONER CRFNI = CONEI AC = 1.0D0 L = 1 DO 20 K=2,15 SR = ZEROR SI = ZEROI DO 10 J=1,K L = L + 1 STR = SR*T2R - SI*T2I + C(L) SI = SR*T2I + SI*T2R SR = STR 10 CONTINUE STR = CRFNR*SRR - CRFNI*SRI CRFNI = CRFNR*SRI + CRFNI*SRR CRFNR = STR CWRKR(K) = CRFNR*SR - CRFNI*SI CWRKI(K) = CRFNR*SI + CRFNI*SR AC = AC*RFN TEST = DABS(CWRKR(K)) + DABS(CWRKI(K)) IF (AC.LT.TOL .AND. TEST.LT.TOL) GO TO 30 20 CONTINUE K = 15 30 CONTINUE INIT = K 40 CONTINUE IF (IKFLG.EQ.2) GO TO 60 C----------------------------------------------------------------------- C COMPUTE SUM FOR THE I FUNCTION C----------------------------------------------------------------------- SR = ZEROR SI = ZEROI DO 50 I=1,INIT SR = SR + CWRKR(I) SI = SI + CWRKI(I) 50 CONTINUE SUMR = SR SUMI = SI PHIR = CWRKR(16)*CON(1) PHII = CWRKI(16)*CON(1) RETURN 60 CONTINUE C----------------------------------------------------------------------- C COMPUTE SUM FOR THE K FUNCTION C----------------------------------------------------------------------- SR = ZEROR SI = ZEROI TR = CONER DO 70 I=1,INIT SR = SR + TR*CWRKR(I) SI = SI + TR*CWRKI(I) TR = -TR 70 CONTINUE SUMR = SR SUMI = SI PHIR = CWRKR(16)*CON(2) PHII = CWRKI(16)*CON(2) RETURN END openspecfun-0.3/amos/zunk1.f000066400000000000000000000333471232445310600160710ustar00rootroot00000000000000 SUBROUTINE ZUNK1(ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, TOL, ELIM, * ALIM) C***BEGIN PROLOGUE ZUNK1 C***REFER TO ZBESK C C ZUNK1 COMPUTES K(FNU,Z) AND ITS ANALYTIC CONTINUATION FROM THE C RIGHT HALF PLANE TO THE LEFT HALF PLANE BY MEANS OF THE C UNIFORM ASYMPTOTIC EXPANSION. C MR INDICATES THE DIRECTION OF ROTATION FOR ANALYTIC CONTINUATION. C NZ=-1 MEANS AN OVERFLOW WILL OCCUR C C***ROUTINES CALLED ZKSCL,ZS1S2,ZUCHK,ZUNIK,D1MACH,ZABS C***END PROLOGUE ZUNK1 C COMPLEX CFN,CK,CONE,CRSC,CS,CSCL,CSGN,CSPN,CSR,CSS,CWRK,CY,CZERO, C *C1,C2,PHI,PHID,RZ,SUM,SUMD,S1,S2,Y,Z,ZETA1,ZETA1D,ZETA2,ZETA2D,ZR DOUBLE PRECISION ALIM, ANG, APHI, ASC, ASCLE, BRY, CKI, CKR, * CONER, CRSC, CSCL, CSGNI, CSPNI, CSPNR, CSR, CSRR, CSSR, * CWRKI, CWRKR, CYI, CYR, C1I, C1R, C2I, C2M, C2R, ELIM, FMR, FN, * FNF, FNU, PHIDI, PHIDR, PHII, PHIR, PI, RAST, RAZR, RS1, RZI, * RZR, SGN, STI, STR, SUMDI, SUMDR, SUMI, SUMR, S1I, S1R, S2I, * S2R, TOL, YI, YR, ZEROI, ZEROR, ZETA1I, ZETA1R, ZETA2I, ZETA2R, * ZET1DI, ZET1DR, ZET2DI, ZET2DR, ZI, ZR, ZRI, ZRR, D1MACH, ZABS INTEGER I, IB, IFLAG, IFN, IL, INIT, INU, IUF, K, KDFLG, KFLAG, * KK, KODE, MR, N, NW, NZ, INITD, IC, IPARD, J DIMENSION BRY(3), INIT(2), YR(N), YI(N), SUMR(2), SUMI(2), * ZETA1R(2), ZETA1I(2), ZETA2R(2), ZETA2I(2), CYR(2), CYI(2), * CWRKR(16,3), CWRKI(16,3), CSSR(3), CSRR(3), PHIR(2), PHII(2) DATA ZEROR,ZEROI,CONER / 0.0D0, 0.0D0, 1.0D0 / DATA PI / 3.14159265358979324D0 / C KDFLG = 1 NZ = 0 C----------------------------------------------------------------------- C EXP(-ALIM)=EXP(-ELIM)/TOL=APPROX. ONE PRECISION GREATER THAN C THE UNDERFLOW LIMIT C----------------------------------------------------------------------- CSCL = 1.0D0/TOL CRSC = TOL CSSR(1) = CSCL CSSR(2) = CONER CSSR(3) = CRSC CSRR(1) = CRSC CSRR(2) = CONER CSRR(3) = CSCL BRY(1) = 1.0D+3*D1MACH(1)/TOL BRY(2) = 1.0D0/BRY(1) BRY(3) = D1MACH(2) ZRR = ZR ZRI = ZI IF (ZR.GE.0.0D0) GO TO 10 ZRR = -ZR ZRI = -ZI 10 CONTINUE J = 2 DO 70 I=1,N C----------------------------------------------------------------------- C J FLIP FLOPS BETWEEN 1 AND 2 IN J = 3 - J C----------------------------------------------------------------------- J = 3 - J FN = FNU + DBLE(FLOAT(I-1)) INIT(J) = 0 CALL ZUNIK(ZRR, ZRI, FN, 2, 0, TOL, INIT(J), PHIR(J), PHII(J), * ZETA1R(J), ZETA1I(J), ZETA2R(J), ZETA2I(J), SUMR(J), SUMI(J), * CWRKR(1,J), CWRKI(1,J)) IF (KODE.EQ.1) GO TO 20 STR = ZRR + ZETA2R(J) STI = ZRI + ZETA2I(J) RAST = FN/ZABS(COMPLEX(STR,STI)) STR = STR*RAST*RAST STI = -STI*RAST*RAST S1R = ZETA1R(J) - STR S1I = ZETA1I(J) - STI GO TO 30 20 CONTINUE S1R = ZETA1R(J) - ZETA2R(J) S1I = ZETA1I(J) - ZETA2I(J) 30 CONTINUE RS1 = S1R C----------------------------------------------------------------------- C TEST FOR UNDERFLOW AND OVERFLOW C----------------------------------------------------------------------- IF (DABS(RS1).GT.ELIM) GO TO 60 IF (KDFLG.EQ.1) KFLAG = 2 IF (DABS(RS1).LT.ALIM) GO TO 40 C----------------------------------------------------------------------- C REFINE TEST AND SCALE C----------------------------------------------------------------------- APHI = ZABS(COMPLEX(PHIR(J),PHII(J))) RS1 = RS1 + DLOG(APHI) IF (DABS(RS1).GT.ELIM) GO TO 60 IF (KDFLG.EQ.1) KFLAG = 1 IF (RS1.LT.0.0D0) GO TO 40 IF (KDFLG.EQ.1) KFLAG = 3 40 CONTINUE C----------------------------------------------------------------------- C SCALE S1 TO KEEP INTERMEDIATE ARITHMETIC ON SCALE NEAR C EXPONENT EXTREMES C----------------------------------------------------------------------- S2R = PHIR(J)*SUMR(J) - PHII(J)*SUMI(J) S2I = PHIR(J)*SUMI(J) + PHII(J)*SUMR(J) STR = DEXP(S1R)*CSSR(KFLAG) S1R = STR*DCOS(S1I) S1I = STR*DSIN(S1I) STR = S2R*S1R - S2I*S1I S2I = S1R*S2I + S2R*S1I S2R = STR IF (KFLAG.NE.1) GO TO 50 CALL ZUCHK(S2R, S2I, NW, BRY(1), TOL) IF (NW.NE.0) GO TO 60 50 CONTINUE CYR(KDFLG) = S2R CYI(KDFLG) = S2I YR(I) = S2R*CSRR(KFLAG) YI(I) = S2I*CSRR(KFLAG) IF (KDFLG.EQ.2) GO TO 75 KDFLG = 2 GO TO 70 60 CONTINUE IF (RS1.GT.0.0D0) GO TO 300 C----------------------------------------------------------------------- C FOR ZR.LT.0.0, THE I FUNCTION TO BE ADDED WILL OVERFLOW C----------------------------------------------------------------------- IF (ZR.LT.0.0D0) GO TO 300 KDFLG = 1 YR(I)=ZEROR YI(I)=ZEROI NZ=NZ+1 IF (I.EQ.1) GO TO 70 IF ((YR(I-1).EQ.ZEROR).AND.(YI(I-1).EQ.ZEROI)) GO TO 70 YR(I-1)=ZEROR YI(I-1)=ZEROI NZ=NZ+1 70 CONTINUE I = N 75 CONTINUE RAZR = 1.0D0/ZABS(COMPLEX(ZRR,ZRI)) STR = ZRR*RAZR STI = -ZRI*RAZR RZR = (STR+STR)*RAZR RZI = (STI+STI)*RAZR CKR = FN*RZR CKI = FN*RZI IB = I + 1 IF (N.LT.IB) GO TO 160 C----------------------------------------------------------------------- C TEST LAST MEMBER FOR UNDERFLOW AND OVERFLOW. SET SEQUENCE TO ZERO C ON UNDERFLOW. C----------------------------------------------------------------------- FN = FNU + DBLE(FLOAT(N-1)) IPARD = 1 IF (MR.NE.0) IPARD = 0 INITD = 0 CALL ZUNIK(ZRR, ZRI, FN, 2, IPARD, TOL, INITD, PHIDR, PHIDI, * ZET1DR, ZET1DI, ZET2DR, ZET2DI, SUMDR, SUMDI, CWRKR(1,3), * CWRKI(1,3)) IF (KODE.EQ.1) GO TO 80 STR = ZRR + ZET2DR STI = ZRI + ZET2DI RAST = FN/ZABS(COMPLEX(STR,STI)) STR = STR*RAST*RAST STI = -STI*RAST*RAST S1R = ZET1DR - STR S1I = ZET1DI - STI GO TO 90 80 CONTINUE S1R = ZET1DR - ZET2DR S1I = ZET1DI - ZET2DI 90 CONTINUE RS1 = S1R IF (DABS(RS1).GT.ELIM) GO TO 95 IF (DABS(RS1).LT.ALIM) GO TO 100 C---------------------------------------------------------------------------- C REFINE ESTIMATE AND TEST C------------------------------------------------------------------------- APHI = ZABS(COMPLEX(PHIDR,PHIDI)) RS1 = RS1+DLOG(APHI) IF (DABS(RS1).LT.ELIM) GO TO 100 95 CONTINUE IF (DABS(RS1).GT.0.0D0) GO TO 300 C----------------------------------------------------------------------- C FOR ZR.LT.0.0, THE I FUNCTION TO BE ADDED WILL OVERFLOW C----------------------------------------------------------------------- IF (ZR.LT.0.0D0) GO TO 300 NZ = N DO 96 I=1,N YR(I) = ZEROR YI(I) = ZEROI 96 CONTINUE RETURN C--------------------------------------------------------------------------- C FORWARD RECUR FOR REMAINDER OF THE SEQUENCE C---------------------------------------------------------------------------- 100 CONTINUE S1R = CYR(1) S1I = CYI(1) S2R = CYR(2) S2I = CYI(2) C1R = CSRR(KFLAG) ASCLE = BRY(KFLAG) DO 120 I=IB,N C2R = S2R C2I = S2I S2R = CKR*C2R - CKI*C2I + S1R S2I = CKR*C2I + CKI*C2R + S1I S1R = C2R S1I = C2I CKR = CKR + RZR CKI = CKI + RZI C2R = S2R*C1R C2I = S2I*C1R YR(I) = C2R YI(I) = C2I IF (KFLAG.GE.3) GO TO 120 STR = DABS(C2R) STI = DABS(C2I) C2M = DMAX1(STR,STI) IF (C2M.LE.ASCLE) GO TO 120 KFLAG = KFLAG + 1 ASCLE = BRY(KFLAG) S1R = S1R*C1R S1I = S1I*C1R S2R = C2R S2I = C2I S1R = S1R*CSSR(KFLAG) S1I = S1I*CSSR(KFLAG) S2R = S2R*CSSR(KFLAG) S2I = S2I*CSSR(KFLAG) C1R = CSRR(KFLAG) 120 CONTINUE 160 CONTINUE IF (MR.EQ.0) RETURN C----------------------------------------------------------------------- C ANALYTIC CONTINUATION FOR RE(Z).LT.0.0D0 C----------------------------------------------------------------------- NZ = 0 FMR = DBLE(FLOAT(MR)) SGN = -DSIGN(PI,FMR) C----------------------------------------------------------------------- C CSPN AND CSGN ARE COEFF OF K AND I FUNCTIONS RESP. C----------------------------------------------------------------------- CSGNI = SGN INU = INT(SNGL(FNU)) FNF = FNU - DBLE(FLOAT(INU)) IFN = INU + N - 1 ANG = FNF*SGN CSPNR = DCOS(ANG) CSPNI = DSIN(ANG) IF (MOD(IFN,2).EQ.0) GO TO 170 CSPNR = -CSPNR CSPNI = -CSPNI 170 CONTINUE ASC = BRY(1) IUF = 0 KK = N KDFLG = 1 IB = IB - 1 IC = IB - 1 DO 270 K=1,N FN = FNU + DBLE(FLOAT(KK-1)) C----------------------------------------------------------------------- C LOGIC TO SORT OUT CASES WHOSE PARAMETERS WERE SET FOR THE K C FUNCTION ABOVE C----------------------------------------------------------------------- M=3 IF (N.GT.2) GO TO 175 172 CONTINUE INITD = INIT(J) PHIDR = PHIR(J) PHIDI = PHII(J) ZET1DR = ZETA1R(J) ZET1DI = ZETA1I(J) ZET2DR = ZETA2R(J) ZET2DI = ZETA2I(J) SUMDR = SUMR(J) SUMDI = SUMI(J) M = J J = 3 - J GO TO 180 175 CONTINUE IF ((KK.EQ.N).AND.(IB.LT.N)) GO TO 180 IF ((KK.EQ.IB).OR.(KK.EQ.IC)) GO TO 172 INITD = 0 180 CONTINUE CALL ZUNIK(ZRR, ZRI, FN, 1, 0, TOL, INITD, PHIDR, PHIDI, * ZET1DR, ZET1DI, ZET2DR, ZET2DI, SUMDR, SUMDI, * CWRKR(1,M), CWRKI(1,M)) IF (KODE.EQ.1) GO TO 200 STR = ZRR + ZET2DR STI = ZRI + ZET2DI RAST = FN/ZABS(COMPLEX(STR,STI)) STR = STR*RAST*RAST STI = -STI*RAST*RAST S1R = -ZET1DR + STR S1I = -ZET1DI + STI GO TO 210 200 CONTINUE S1R = -ZET1DR + ZET2DR S1I = -ZET1DI + ZET2DI 210 CONTINUE C----------------------------------------------------------------------- C TEST FOR UNDERFLOW AND OVERFLOW C----------------------------------------------------------------------- RS1 = S1R IF (DABS(RS1).GT.ELIM) GO TO 260 IF (KDFLG.EQ.1) IFLAG = 2 IF (DABS(RS1).LT.ALIM) GO TO 220 C----------------------------------------------------------------------- C REFINE TEST AND SCALE C----------------------------------------------------------------------- APHI = ZABS(COMPLEX(PHIDR,PHIDI)) RS1 = RS1 + DLOG(APHI) IF (DABS(RS1).GT.ELIM) GO TO 260 IF (KDFLG.EQ.1) IFLAG = 1 IF (RS1.LT.0.0D0) GO TO 220 IF (KDFLG.EQ.1) IFLAG = 3 220 CONTINUE STR = PHIDR*SUMDR - PHIDI*SUMDI STI = PHIDR*SUMDI + PHIDI*SUMDR S2R = -CSGNI*STI S2I = CSGNI*STR STR = DEXP(S1R)*CSSR(IFLAG) S1R = STR*DCOS(S1I) S1I = STR*DSIN(S1I) STR = S2R*S1R - S2I*S1I S2I = S2R*S1I + S2I*S1R S2R = STR IF (IFLAG.NE.1) GO TO 230 CALL ZUCHK(S2R, S2I, NW, BRY(1), TOL) IF (NW.EQ.0) GO TO 230 S2R = ZEROR S2I = ZEROI 230 CONTINUE CYR(KDFLG) = S2R CYI(KDFLG) = S2I C2R = S2R C2I = S2I S2R = S2R*CSRR(IFLAG) S2I = S2I*CSRR(IFLAG) C----------------------------------------------------------------------- C ADD I AND K FUNCTIONS, K SEQUENCE IN Y(I), I=1,N C----------------------------------------------------------------------- S1R = YR(KK) S1I = YI(KK) IF (KODE.EQ.1) GO TO 250 CALL ZS1S2(ZRR, ZRI, S1R, S1I, S2R, S2I, NW, ASC, ALIM, IUF) NZ = NZ + NW 250 CONTINUE YR(KK) = S1R*CSPNR - S1I*CSPNI + S2R YI(KK) = CSPNR*S1I + CSPNI*S1R + S2I KK = KK - 1 CSPNR = -CSPNR CSPNI = -CSPNI IF (C2R.NE.0.0D0 .OR. C2I.NE.0.0D0) GO TO 255 KDFLG = 1 GO TO 270 255 CONTINUE IF (KDFLG.EQ.2) GO TO 275 KDFLG = 2 GO TO 270 260 CONTINUE IF (RS1.GT.0.0D0) GO TO 300 S2R = ZEROR S2I = ZEROI GO TO 230 270 CONTINUE K = N 275 CONTINUE IL = N - K IF (IL.EQ.0) RETURN C----------------------------------------------------------------------- C RECUR BACKWARD FOR REMAINDER OF I SEQUENCE AND ADD IN THE C K FUNCTIONS, SCALING THE I SEQUENCE DURING RECURRENCE TO KEEP C INTERMEDIATE ARITHMETIC ON SCALE NEAR EXPONENT EXTREMES. C----------------------------------------------------------------------- S1R = CYR(1) S1I = CYI(1) S2R = CYR(2) S2I = CYI(2) CSR = CSRR(IFLAG) ASCLE = BRY(IFLAG) FN = DBLE(FLOAT(INU+IL)) DO 290 I=1,IL C2R = S2R C2I = S2I S2R = S1R + (FN+FNF)*(RZR*C2R-RZI*C2I) S2I = S1I + (FN+FNF)*(RZR*C2I+RZI*C2R) S1R = C2R S1I = C2I FN = FN - 1.0D0 C2R = S2R*CSR C2I = S2I*CSR CKR = C2R CKI = C2I C1R = YR(KK) C1I = YI(KK) IF (KODE.EQ.1) GO TO 280 CALL ZS1S2(ZRR, ZRI, C1R, C1I, C2R, C2I, NW, ASC, ALIM, IUF) NZ = NZ + NW 280 CONTINUE YR(KK) = C1R*CSPNR - C1I*CSPNI + C2R YI(KK) = C1R*CSPNI + C1I*CSPNR + C2I KK = KK - 1 CSPNR = -CSPNR CSPNI = -CSPNI IF (IFLAG.GE.3) GO TO 290 C2R = DABS(CKR) C2I = DABS(CKI) C2M = DMAX1(C2R,C2I) IF (C2M.LE.ASCLE) GO TO 290 IFLAG = IFLAG + 1 ASCLE = BRY(IFLAG) S1R = S1R*CSR S1I = S1I*CSR S2R = CKR S2I = CKI S1R = S1R*CSSR(IFLAG) S1I = S1I*CSSR(IFLAG) S2R = S2R*CSSR(IFLAG) S2I = S2I*CSSR(IFLAG) CSR = CSRR(IFLAG) 290 CONTINUE RETURN 300 CONTINUE NZ = -1 RETURN END openspecfun-0.3/amos/zunk2.f000066400000000000000000000416451232445310600160720ustar00rootroot00000000000000 SUBROUTINE ZUNK2(ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, TOL, ELIM, * ALIM) C***BEGIN PROLOGUE ZUNK2 C***REFER TO ZBESK C C ZUNK2 COMPUTES K(FNU,Z) AND ITS ANALYTIC CONTINUATION FROM THE C RIGHT HALF PLANE TO THE LEFT HALF PLANE BY MEANS OF THE C UNIFORM ASYMPTOTIC EXPANSIONS FOR H(KIND,FNU,ZN) AND J(FNU,ZN) C WHERE ZN IS IN THE RIGHT HALF PLANE, KIND=(3-MR)/2, MR=+1 OR C -1. HERE ZN=ZR*I OR -ZR*I WHERE ZR=Z IF Z IS IN THE RIGHT C HALF PLANE OR ZR=-Z IF Z IS IN THE LEFT HALF PLANE. MR INDIC- C ATES THE DIRECTION OF ROTATION FOR ANALYTIC CONTINUATION. C NZ=-1 MEANS AN OVERFLOW WILL OCCUR C C***ROUTINES CALLED ZAIRY,ZKSCL,ZS1S2,ZUCHK,ZUNHJ,D1MACH,ZABS C***END PROLOGUE ZUNK2 C COMPLEX AI,ARG,ARGD,ASUM,ASUMD,BSUM,BSUMD,CFN,CI,CIP,CK,CONE,CRSC, C *CR1,CR2,CS,CSCL,CSGN,CSPN,CSR,CSS,CY,CZERO,C1,C2,DAI,PHI,PHID,RZ, C *S1,S2,Y,Z,ZB,ZETA1,ZETA1D,ZETA2,ZETA2D,ZN,ZR DOUBLE PRECISION AARG, AIC, AII, AIR, ALIM, ANG, APHI, ARGDI, * ARGDR, ARGI, ARGR, ASC, ASCLE, ASUMDI, ASUMDR, ASUMI, ASUMR, * BRY, BSUMDI, BSUMDR, BSUMI, BSUMR, CAR, CIPI, CIPR, CKI, CKR, * CONER, CRSC, CR1I, CR1R, CR2I, CR2R, CSCL, CSGNI, CSI, * CSPNI, CSPNR, CSR, CSRR, CSSR, CYI, CYR, C1I, C1R, C2I, C2M, * C2R, DAII, DAIR, ELIM, FMR, FN, FNF, FNU, HPI, PHIDI, PHIDR, * PHII, PHIR, PI, PTI, PTR, RAST, RAZR, RS1, RZI, RZR, SAR, SGN, * STI, STR, S1I, S1R, S2I, S2R, TOL, YI, YR, YY, ZBI, ZBR, ZEROI, * ZEROR, ZETA1I, ZETA1R, ZETA2I, ZETA2R, ZET1DI, ZET1DR, ZET2DI, * ZET2DR, ZI, ZNI, ZNR, ZR, ZRI, ZRR, D1MACH, ZABS INTEGER I, IB, IFLAG, IFN, IL, IN, INU, IUF, K, KDFLG, KFLAG, KK, * KODE, MR, N, NAI, NDAI, NW, NZ, IDUM, J, IPARD, IC DIMENSION BRY(3), YR(N), YI(N), ASUMR(2), ASUMI(2), BSUMR(2), * BSUMI(2), PHIR(2), PHII(2), ARGR(2), ARGI(2), ZETA1R(2), * ZETA1I(2), ZETA2R(2), ZETA2I(2), CYR(2), CYI(2), CIPR(4), * CIPI(4), CSSR(3), CSRR(3) DATA ZEROR,ZEROI,CONER,CR1R,CR1I,CR2R,CR2I / 1 0.0D0, 0.0D0, 1.0D0, 1 1.0D0,1.73205080756887729D0 , -0.5D0,-8.66025403784438647D-01 / DATA HPI, PI, AIC / 1 1.57079632679489662D+00, 3.14159265358979324D+00, 1 1.26551212348464539D+00/ DATA CIPR(1),CIPI(1),CIPR(2),CIPI(2),CIPR(3),CIPI(3),CIPR(4), * CIPI(4) / 1 1.0D0,0.0D0 , 0.0D0,-1.0D0 , -1.0D0,0.0D0 , 0.0D0,1.0D0 / C KDFLG = 1 NZ = 0 C----------------------------------------------------------------------- C EXP(-ALIM)=EXP(-ELIM)/TOL=APPROX. ONE PRECISION GREATER THAN C THE UNDERFLOW LIMIT C----------------------------------------------------------------------- CSCL = 1.0D0/TOL CRSC = TOL CSSR(1) = CSCL CSSR(2) = CONER CSSR(3) = CRSC CSRR(1) = CRSC CSRR(2) = CONER CSRR(3) = CSCL BRY(1) = 1.0D+3*D1MACH(1)/TOL BRY(2) = 1.0D0/BRY(1) BRY(3) = D1MACH(2) ZRR = ZR ZRI = ZI IF (ZR.GE.0.0D0) GO TO 10 ZRR = -ZR ZRI = -ZI 10 CONTINUE YY = ZRI ZNR = ZRI ZNI = -ZRR ZBR = ZRR ZBI = ZRI INU = INT(SNGL(FNU)) FNF = FNU - DBLE(FLOAT(INU)) ANG = -HPI*FNF CAR = DCOS(ANG) SAR = DSIN(ANG) C2R = HPI*SAR C2I = -HPI*CAR KK = MOD(INU,4) + 1 STR = C2R*CIPR(KK) - C2I*CIPI(KK) STI = C2R*CIPI(KK) + C2I*CIPR(KK) CSR = CR1R*STR - CR1I*STI CSI = CR1R*STI + CR1I*STR IF (YY.GT.0.0D0) GO TO 20 ZNR = -ZNR ZBI = -ZBI 20 CONTINUE C----------------------------------------------------------------------- C K(FNU,Z) IS COMPUTED FROM H(2,FNU,-I*Z) WHERE Z IS IN THE FIRST C QUADRANT. FOURTH QUADRANT VALUES (YY.LE.0.0E0) ARE COMPUTED BY C CONJUGATION SINCE THE K FUNCTION IS REAL ON THE POSITIVE REAL AXIS C----------------------------------------------------------------------- J = 2 DO 80 I=1,N C----------------------------------------------------------------------- C J FLIP FLOPS BETWEEN 1 AND 2 IN J = 3 - J C----------------------------------------------------------------------- J = 3 - J FN = FNU + DBLE(FLOAT(I-1)) CALL ZUNHJ(ZNR, ZNI, FN, 0, TOL, PHIR(J), PHII(J), ARGR(J), * ARGI(J), ZETA1R(J), ZETA1I(J), ZETA2R(J), ZETA2I(J), ASUMR(J), * ASUMI(J), BSUMR(J), BSUMI(J)) IF (KODE.EQ.1) GO TO 30 STR = ZBR + ZETA2R(J) STI = ZBI + ZETA2I(J) RAST = FN/ZABS(COMPLEX(STR,STI)) STR = STR*RAST*RAST STI = -STI*RAST*RAST S1R = ZETA1R(J) - STR S1I = ZETA1I(J) - STI GO TO 40 30 CONTINUE S1R = ZETA1R(J) - ZETA2R(J) S1I = ZETA1I(J) - ZETA2I(J) 40 CONTINUE C----------------------------------------------------------------------- C TEST FOR UNDERFLOW AND OVERFLOW C----------------------------------------------------------------------- RS1 = S1R IF (DABS(RS1).GT.ELIM) GO TO 70 IF (KDFLG.EQ.1) KFLAG = 2 IF (DABS(RS1).LT.ALIM) GO TO 50 C----------------------------------------------------------------------- C REFINE TEST AND SCALE C----------------------------------------------------------------------- APHI = ZABS(COMPLEX(PHIR(J),PHII(J))) AARG = ZABS(COMPLEX(ARGR(J),ARGI(J))) RS1 = RS1 + DLOG(APHI) - 0.25D0*DLOG(AARG) - AIC IF (DABS(RS1).GT.ELIM) GO TO 70 IF (KDFLG.EQ.1) KFLAG = 1 IF (RS1.LT.0.0D0) GO TO 50 IF (KDFLG.EQ.1) KFLAG = 3 50 CONTINUE C----------------------------------------------------------------------- C SCALE S1 TO KEEP INTERMEDIATE ARITHMETIC ON SCALE NEAR C EXPONENT EXTREMES C----------------------------------------------------------------------- C2R = ARGR(J)*CR2R - ARGI(J)*CR2I C2I = ARGR(J)*CR2I + ARGI(J)*CR2R CALL ZAIRY(C2R, C2I, 0, 2, AIR, AII, NAI, IDUM) CALL ZAIRY(C2R, C2I, 1, 2, DAIR, DAII, NDAI, IDUM) STR = DAIR*BSUMR(J) - DAII*BSUMI(J) STI = DAIR*BSUMI(J) + DAII*BSUMR(J) PTR = STR*CR2R - STI*CR2I PTI = STR*CR2I + STI*CR2R STR = PTR + (AIR*ASUMR(J)-AII*ASUMI(J)) STI = PTI + (AIR*ASUMI(J)+AII*ASUMR(J)) PTR = STR*PHIR(J) - STI*PHII(J) PTI = STR*PHII(J) + STI*PHIR(J) S2R = PTR*CSR - PTI*CSI S2I = PTR*CSI + PTI*CSR STR = DEXP(S1R)*CSSR(KFLAG) S1R = STR*DCOS(S1I) S1I = STR*DSIN(S1I) STR = S2R*S1R - S2I*S1I S2I = S1R*S2I + S2R*S1I S2R = STR IF (KFLAG.NE.1) GO TO 60 CALL ZUCHK(S2R, S2I, NW, BRY(1), TOL) IF (NW.NE.0) GO TO 70 60 CONTINUE IF (YY.LE.0.0D0) S2I = -S2I CYR(KDFLG) = S2R CYI(KDFLG) = S2I YR(I) = S2R*CSRR(KFLAG) YI(I) = S2I*CSRR(KFLAG) STR = CSI CSI = -CSR CSR = STR IF (KDFLG.EQ.2) GO TO 85 KDFLG = 2 GO TO 80 70 CONTINUE IF (RS1.GT.0.0D0) GO TO 320 C----------------------------------------------------------------------- C FOR ZR.LT.0.0, THE I FUNCTION TO BE ADDED WILL OVERFLOW C----------------------------------------------------------------------- IF (ZR.LT.0.0D0) GO TO 320 KDFLG = 1 YR(I)=ZEROR YI(I)=ZEROI NZ=NZ+1 STR = CSI CSI =-CSR CSR = STR IF (I.EQ.1) GO TO 80 IF ((YR(I-1).EQ.ZEROR).AND.(YI(I-1).EQ.ZEROI)) GO TO 80 YR(I-1)=ZEROR YI(I-1)=ZEROI NZ=NZ+1 80 CONTINUE I = N 85 CONTINUE RAZR = 1.0D0/ZABS(COMPLEX(ZRR,ZRI)) STR = ZRR*RAZR STI = -ZRI*RAZR RZR = (STR+STR)*RAZR RZI = (STI+STI)*RAZR CKR = FN*RZR CKI = FN*RZI IB = I + 1 IF (N.LT.IB) GO TO 180 C----------------------------------------------------------------------- C TEST LAST MEMBER FOR UNDERFLOW AND OVERFLOW. SET SEQUENCE TO ZERO C ON UNDERFLOW. C----------------------------------------------------------------------- FN = FNU + DBLE(FLOAT(N-1)) IPARD = 1 IF (MR.NE.0) IPARD = 0 CALL ZUNHJ(ZNR, ZNI, FN, IPARD, TOL, PHIDR, PHIDI, ARGDR, ARGDI, * ZET1DR, ZET1DI, ZET2DR, ZET2DI, ASUMDR, ASUMDI, BSUMDR, BSUMDI) IF (KODE.EQ.1) GO TO 90 STR = ZBR + ZET2DR STI = ZBI + ZET2DI RAST = FN/ZABS(COMPLEX(STR,STI)) STR = STR*RAST*RAST STI = -STI*RAST*RAST S1R = ZET1DR - STR S1I = ZET1DI - STI GO TO 100 90 CONTINUE S1R = ZET1DR - ZET2DR S1I = ZET1DI - ZET2DI 100 CONTINUE RS1 = S1R IF (DABS(RS1).GT.ELIM) GO TO 105 IF (DABS(RS1).LT.ALIM) GO TO 120 C---------------------------------------------------------------------------- C REFINE ESTIMATE AND TEST C------------------------------------------------------------------------- APHI = ZABS(COMPLEX(PHIDR,PHIDI)) RS1 = RS1+DLOG(APHI) IF (DABS(RS1).LT.ELIM) GO TO 120 105 CONTINUE IF (RS1.GT.0.0D0) GO TO 320 C----------------------------------------------------------------------- C FOR ZR.LT.0.0, THE I FUNCTION TO BE ADDED WILL OVERFLOW C----------------------------------------------------------------------- IF (ZR.LT.0.0D0) GO TO 320 NZ = N DO 106 I=1,N YR(I) = ZEROR YI(I) = ZEROI 106 CONTINUE RETURN 120 CONTINUE S1R = CYR(1) S1I = CYI(1) S2R = CYR(2) S2I = CYI(2) C1R = CSRR(KFLAG) ASCLE = BRY(KFLAG) DO 130 I=IB,N C2R = S2R C2I = S2I S2R = CKR*C2R - CKI*C2I + S1R S2I = CKR*C2I + CKI*C2R + S1I S1R = C2R S1I = C2I CKR = CKR + RZR CKI = CKI + RZI C2R = S2R*C1R C2I = S2I*C1R YR(I) = C2R YI(I) = C2I IF (KFLAG.GE.3) GO TO 130 STR = DABS(C2R) STI = DABS(C2I) C2M = DMAX1(STR,STI) IF (C2M.LE.ASCLE) GO TO 130 KFLAG = KFLAG + 1 ASCLE = BRY(KFLAG) S1R = S1R*C1R S1I = S1I*C1R S2R = C2R S2I = C2I S1R = S1R*CSSR(KFLAG) S1I = S1I*CSSR(KFLAG) S2R = S2R*CSSR(KFLAG) S2I = S2I*CSSR(KFLAG) C1R = CSRR(KFLAG) 130 CONTINUE 180 CONTINUE IF (MR.EQ.0) RETURN C----------------------------------------------------------------------- C ANALYTIC CONTINUATION FOR RE(Z).LT.0.0D0 C----------------------------------------------------------------------- NZ = 0 FMR = DBLE(FLOAT(MR)) SGN = -DSIGN(PI,FMR) C----------------------------------------------------------------------- C CSPN AND CSGN ARE COEFF OF K AND I FUNCIONS RESP. C----------------------------------------------------------------------- CSGNI = SGN IF (YY.LE.0.0D0) CSGNI = -CSGNI IFN = INU + N - 1 ANG = FNF*SGN CSPNR = DCOS(ANG) CSPNI = DSIN(ANG) IF (MOD(IFN,2).EQ.0) GO TO 190 CSPNR = -CSPNR CSPNI = -CSPNI 190 CONTINUE C----------------------------------------------------------------------- C CS=COEFF OF THE J FUNCTION TO GET THE I FUNCTION. I(FNU,Z) IS C COMPUTED FROM EXP(I*FNU*HPI)*J(FNU,-I*Z) WHERE Z IS IN THE FIRST C QUADRANT. FOURTH QUADRANT VALUES (YY.LE.0.0E0) ARE COMPUTED BY C CONJUGATION SINCE THE I FUNCTION IS REAL ON THE POSITIVE REAL AXIS C----------------------------------------------------------------------- CSR = SAR*CSGNI CSI = CAR*CSGNI IN = MOD(IFN,4) + 1 C2R = CIPR(IN) C2I = CIPI(IN) STR = CSR*C2R + CSI*C2I CSI = -CSR*C2I + CSI*C2R CSR = STR ASC = BRY(1) IUF = 0 KK = N KDFLG = 1 IB = IB - 1 IC = IB - 1 DO 290 K=1,N FN = FNU + DBLE(FLOAT(KK-1)) C----------------------------------------------------------------------- C LOGIC TO SORT OUT CASES WHOSE PARAMETERS WERE SET FOR THE K C FUNCTION ABOVE C----------------------------------------------------------------------- IF (N.GT.2) GO TO 175 172 CONTINUE PHIDR = PHIR(J) PHIDI = PHII(J) ARGDR = ARGR(J) ARGDI = ARGI(J) ZET1DR = ZETA1R(J) ZET1DI = ZETA1I(J) ZET2DR = ZETA2R(J) ZET2DI = ZETA2I(J) ASUMDR = ASUMR(J) ASUMDI = ASUMI(J) BSUMDR = BSUMR(J) BSUMDI = BSUMI(J) J = 3 - J GO TO 210 175 CONTINUE IF ((KK.EQ.N).AND.(IB.LT.N)) GO TO 210 IF ((KK.EQ.IB).OR.(KK.EQ.IC)) GO TO 172 CALL ZUNHJ(ZNR, ZNI, FN, 0, TOL, PHIDR, PHIDI, ARGDR, * ARGDI, ZET1DR, ZET1DI, ZET2DR, ZET2DI, ASUMDR, * ASUMDI, BSUMDR, BSUMDI) 210 CONTINUE IF (KODE.EQ.1) GO TO 220 STR = ZBR + ZET2DR STI = ZBI + ZET2DI RAST = FN/ZABS(COMPLEX(STR,STI)) STR = STR*RAST*RAST STI = -STI*RAST*RAST S1R = -ZET1DR + STR S1I = -ZET1DI + STI GO TO 230 220 CONTINUE S1R = -ZET1DR + ZET2DR S1I = -ZET1DI + ZET2DI 230 CONTINUE C----------------------------------------------------------------------- C TEST FOR UNDERFLOW AND OVERFLOW C----------------------------------------------------------------------- RS1 = S1R IF (DABS(RS1).GT.ELIM) GO TO 280 IF (KDFLG.EQ.1) IFLAG = 2 IF (DABS(RS1).LT.ALIM) GO TO 240 C----------------------------------------------------------------------- C REFINE TEST AND SCALE C----------------------------------------------------------------------- APHI = ZABS(COMPLEX(PHIDR,PHIDI)) AARG = ZABS(COMPLEX(ARGDR,ARGDI)) RS1 = RS1 + DLOG(APHI) - 0.25D0*DLOG(AARG) - AIC IF (DABS(RS1).GT.ELIM) GO TO 280 IF (KDFLG.EQ.1) IFLAG = 1 IF (RS1.LT.0.0D0) GO TO 240 IF (KDFLG.EQ.1) IFLAG = 3 240 CONTINUE CALL ZAIRY(ARGDR, ARGDI, 0, 2, AIR, AII, NAI, IDUM) CALL ZAIRY(ARGDR, ARGDI, 1, 2, DAIR, DAII, NDAI, IDUM) STR = DAIR*BSUMDR - DAII*BSUMDI STI = DAIR*BSUMDI + DAII*BSUMDR STR = STR + (AIR*ASUMDR-AII*ASUMDI) STI = STI + (AIR*ASUMDI+AII*ASUMDR) PTR = STR*PHIDR - STI*PHIDI PTI = STR*PHIDI + STI*PHIDR S2R = PTR*CSR - PTI*CSI S2I = PTR*CSI + PTI*CSR STR = DEXP(S1R)*CSSR(IFLAG) S1R = STR*DCOS(S1I) S1I = STR*DSIN(S1I) STR = S2R*S1R - S2I*S1I S2I = S2R*S1I + S2I*S1R S2R = STR IF (IFLAG.NE.1) GO TO 250 CALL ZUCHK(S2R, S2I, NW, BRY(1), TOL) IF (NW.EQ.0) GO TO 250 S2R = ZEROR S2I = ZEROI 250 CONTINUE IF (YY.LE.0.0D0) S2I = -S2I CYR(KDFLG) = S2R CYI(KDFLG) = S2I C2R = S2R C2I = S2I S2R = S2R*CSRR(IFLAG) S2I = S2I*CSRR(IFLAG) C----------------------------------------------------------------------- C ADD I AND K FUNCTIONS, K SEQUENCE IN Y(I), I=1,N C----------------------------------------------------------------------- S1R = YR(KK) S1I = YI(KK) IF (KODE.EQ.1) GO TO 270 CALL ZS1S2(ZRR, ZRI, S1R, S1I, S2R, S2I, NW, ASC, ALIM, IUF) NZ = NZ + NW 270 CONTINUE YR(KK) = S1R*CSPNR - S1I*CSPNI + S2R YI(KK) = S1R*CSPNI + S1I*CSPNR + S2I KK = KK - 1 CSPNR = -CSPNR CSPNI = -CSPNI STR = CSI CSI = -CSR CSR = STR IF (C2R.NE.0.0D0 .OR. C2I.NE.0.0D0) GO TO 255 KDFLG = 1 GO TO 290 255 CONTINUE IF (KDFLG.EQ.2) GO TO 295 KDFLG = 2 GO TO 290 280 CONTINUE IF (RS1.GT.0.0D0) GO TO 320 S2R = ZEROR S2I = ZEROI GO TO 250 290 CONTINUE K = N 295 CONTINUE IL = N - K IF (IL.EQ.0) RETURN C----------------------------------------------------------------------- C RECUR BACKWARD FOR REMAINDER OF I SEQUENCE AND ADD IN THE C K FUNCTIONS, SCALING THE I SEQUENCE DURING RECURRENCE TO KEEP C INTERMEDIATE ARITHMETIC ON SCALE NEAR EXPONENT EXTREMES. C----------------------------------------------------------------------- S1R = CYR(1) S1I = CYI(1) S2R = CYR(2) S2I = CYI(2) CSR = CSRR(IFLAG) ASCLE = BRY(IFLAG) FN = DBLE(FLOAT(INU+IL)) DO 310 I=1,IL C2R = S2R C2I = S2I S2R = S1R + (FN+FNF)*(RZR*C2R-RZI*C2I) S2I = S1I + (FN+FNF)*(RZR*C2I+RZI*C2R) S1R = C2R S1I = C2I FN = FN - 1.0D0 C2R = S2R*CSR C2I = S2I*CSR CKR = C2R CKI = C2I C1R = YR(KK) C1I = YI(KK) IF (KODE.EQ.1) GO TO 300 CALL ZS1S2(ZRR, ZRI, C1R, C1I, C2R, C2I, NW, ASC, ALIM, IUF) NZ = NZ + NW 300 CONTINUE YR(KK) = C1R*CSPNR - C1I*CSPNI + C2R YI(KK) = C1R*CSPNI + C1I*CSPNR + C2I KK = KK - 1 CSPNR = -CSPNR CSPNI = -CSPNI IF (IFLAG.GE.3) GO TO 310 C2R = DABS(CKR) C2I = DABS(CKI) C2M = DMAX1(C2R,C2I) IF (C2M.LE.ASCLE) GO TO 310 IFLAG = IFLAG + 1 ASCLE = BRY(IFLAG) S1R = S1R*CSR S1I = S1I*CSR S2R = CKR S2I = CKI S1R = S1R*CSSR(IFLAG) S1I = S1I*CSSR(IFLAG) S2R = S2R*CSSR(IFLAG) S2I = S2I*CSSR(IFLAG) CSR = CSRR(IFLAG) 310 CONTINUE RETURN 320 CONTINUE NZ = -1 RETURN END openspecfun-0.3/amos/zuoik.f000066400000000000000000000146611232445310600161600ustar00rootroot00000000000000 SUBROUTINE ZUOIK(ZR, ZI, FNU, KODE, IKFLG, N, YR, YI, NUF, TOL, * ELIM, ALIM) C***BEGIN PROLOGUE ZUOIK C***REFER TO ZBESI,ZBESK,ZBESH C C ZUOIK COMPUTES THE LEADING TERMS OF THE UNIFORM ASYMPTOTIC C EXPANSIONS FOR THE I AND K FUNCTIONS AND COMPARES THEM C (IN LOGARITHMIC FORM) TO ALIM AND ELIM FOR OVER AND UNDERFLOW C WHERE ALIM.LT.ELIM. IF THE MAGNITUDE, BASED ON THE LEADING C EXPONENTIAL, IS LESS THAN ALIM OR GREATER THAN -ALIM, THEN C THE RESULT IS ON SCALE. IF NOT, THEN A REFINED TEST USING OTHER C MULTIPLIERS (IN LOGARITHMIC FORM) IS MADE BASED ON ELIM. HERE C EXP(-ELIM)=SMALLEST MACHINE NUMBER*1.0E+3 AND EXP(-ALIM)= C EXP(-ELIM)/TOL C C IKFLG=1 MEANS THE I SEQUENCE IS TESTED C =2 MEANS THE K SEQUENCE IS TESTED C NUF = 0 MEANS THE LAST MEMBER OF THE SEQUENCE IS ON SCALE C =-1 MEANS AN OVERFLOW WOULD OCCUR C IKFLG=1 AND NUF.GT.0 MEANS THE LAST NUF Y VALUES WERE SET TO ZERO C THE FIRST N-NUF VALUES MUST BE SET BY ANOTHER ROUTINE C IKFLG=2 AND NUF.EQ.N MEANS ALL Y VALUES WERE SET TO ZERO C IKFLG=2 AND 0.LT.NUF.LT.N NOT CONSIDERED. Y MUST BE SET BY C ANOTHER ROUTINE C C***ROUTINES CALLED ZUCHK,ZUNHJ,ZUNIK,D1MACH,ZABS,ZLOG C***END PROLOGUE ZUOIK C COMPLEX ARG,ASUM,BSUM,CWRK,CZ,CZERO,PHI,SUM,Y,Z,ZB,ZETA1,ZETA2,ZN, C *ZR DOUBLE PRECISION AARG, AIC, ALIM, APHI, ARGI, ARGR, ASUMI, ASUMR, * ASCLE, AX, AY, BSUMI, BSUMR, CWRKI, CWRKR, CZI, CZR, ELIM, FNN, * FNU, GNN, GNU, PHII, PHIR, RCZ, STR, STI, SUMI, SUMR, TOL, YI, * YR, ZBI, ZBR, ZEROI, ZEROR, ZETA1I, ZETA1R, ZETA2I, ZETA2R, ZI, * ZNI, ZNR, ZR, ZRI, ZRR, D1MACH, ZABS INTEGER I, IDUM, IFORM, IKFLG, INIT, KODE, N, NN, NUF, NW DIMENSION YR(N), YI(N), CWRKR(16), CWRKI(16) DATA ZEROR,ZEROI / 0.0D0, 0.0D0 / DATA AIC / 1.265512123484645396D+00 / NUF = 0 NN = N ZRR = ZR ZRI = ZI IF (ZR.GE.0.0D0) GO TO 10 ZRR = -ZR ZRI = -ZI 10 CONTINUE ZBR = ZRR ZBI = ZRI AX = DABS(ZR)*1.7321D0 AY = DABS(ZI) IFORM = 1 IF (AY.GT.AX) IFORM = 2 GNU = DMAX1(FNU,1.0D0) IF (IKFLG.EQ.1) GO TO 20 FNN = DBLE(FLOAT(NN)) GNN = FNU + FNN - 1.0D0 GNU = DMAX1(GNN,FNN) 20 CONTINUE C----------------------------------------------------------------------- C ONLY THE MAGNITUDE OF ARG AND PHI ARE NEEDED ALONG WITH THE C REAL PARTS OF ZETA1, ZETA2 AND ZB. NO ATTEMPT IS MADE TO GET C THE SIGN OF THE IMAGINARY PART CORRECT. C----------------------------------------------------------------------- IF (IFORM.EQ.2) GO TO 30 INIT = 0 CALL ZUNIK(ZRR, ZRI, GNU, IKFLG, 1, TOL, INIT, PHIR, PHII, * ZETA1R, ZETA1I, ZETA2R, ZETA2I, SUMR, SUMI, CWRKR, CWRKI) CZR = -ZETA1R + ZETA2R CZI = -ZETA1I + ZETA2I GO TO 50 30 CONTINUE ZNR = ZRI ZNI = -ZRR IF (ZI.GT.0.0D0) GO TO 40 ZNR = -ZNR 40 CONTINUE CALL ZUNHJ(ZNR, ZNI, GNU, 1, TOL, PHIR, PHII, ARGR, ARGI, ZETA1R, * ZETA1I, ZETA2R, ZETA2I, ASUMR, ASUMI, BSUMR, BSUMI) CZR = -ZETA1R + ZETA2R CZI = -ZETA1I + ZETA2I AARG = ZABS(COMPLEX(ARGR,ARGI)) 50 CONTINUE IF (KODE.EQ.1) GO TO 60 CZR = CZR - ZBR CZI = CZI - ZBI 60 CONTINUE IF (IKFLG.EQ.1) GO TO 70 CZR = -CZR CZI = -CZI 70 CONTINUE APHI = ZABS(COMPLEX(PHIR,PHII)) RCZ = CZR C----------------------------------------------------------------------- C OVERFLOW TEST C----------------------------------------------------------------------- IF (RCZ.GT.ELIM) GO TO 210 IF (RCZ.LT.ALIM) GO TO 80 RCZ = RCZ + DLOG(APHI) IF (IFORM.EQ.2) RCZ = RCZ - 0.25D0*DLOG(AARG) - AIC IF (RCZ.GT.ELIM) GO TO 210 GO TO 130 80 CONTINUE C----------------------------------------------------------------------- C UNDERFLOW TEST C----------------------------------------------------------------------- IF (RCZ.LT.(-ELIM)) GO TO 90 IF (RCZ.GT.(-ALIM)) GO TO 130 RCZ = RCZ + DLOG(APHI) IF (IFORM.EQ.2) RCZ = RCZ - 0.25D0*DLOG(AARG) - AIC IF (RCZ.GT.(-ELIM)) GO TO 110 90 CONTINUE DO 100 I=1,NN YR(I) = ZEROR YI(I) = ZEROI 100 CONTINUE NUF = NN RETURN 110 CONTINUE ASCLE = 1.0D+3*D1MACH(1)/TOL CALL ZLOG(PHIR, PHII, STR, STI, IDUM) CZR = CZR + STR CZI = CZI + STI IF (IFORM.EQ.1) GO TO 120 CALL ZLOG(ARGR, ARGI, STR, STI, IDUM) CZR = CZR - 0.25D0*STR - AIC CZI = CZI - 0.25D0*STI 120 CONTINUE AX = DEXP(RCZ)/TOL AY = CZI CZR = AX*DCOS(AY) CZI = AX*DSIN(AY) CALL ZUCHK(CZR, CZI, NW, ASCLE, TOL) IF (NW.NE.0) GO TO 90 130 CONTINUE IF (IKFLG.EQ.2) RETURN IF (N.EQ.1) RETURN C----------------------------------------------------------------------- C SET UNDERFLOWS ON I SEQUENCE C----------------------------------------------------------------------- 140 CONTINUE GNU = FNU + DBLE(FLOAT(NN-1)) IF (IFORM.EQ.2) GO TO 150 INIT = 0 CALL ZUNIK(ZRR, ZRI, GNU, IKFLG, 1, TOL, INIT, PHIR, PHII, * ZETA1R, ZETA1I, ZETA2R, ZETA2I, SUMR, SUMI, CWRKR, CWRKI) CZR = -ZETA1R + ZETA2R CZI = -ZETA1I + ZETA2I GO TO 160 150 CONTINUE CALL ZUNHJ(ZNR, ZNI, GNU, 1, TOL, PHIR, PHII, ARGR, ARGI, ZETA1R, * ZETA1I, ZETA2R, ZETA2I, ASUMR, ASUMI, BSUMR, BSUMI) CZR = -ZETA1R + ZETA2R CZI = -ZETA1I + ZETA2I AARG = ZABS(COMPLEX(ARGR,ARGI)) 160 CONTINUE IF (KODE.EQ.1) GO TO 170 CZR = CZR - ZBR CZI = CZI - ZBI 170 CONTINUE APHI = ZABS(COMPLEX(PHIR,PHII)) RCZ = CZR IF (RCZ.LT.(-ELIM)) GO TO 180 IF (RCZ.GT.(-ALIM)) RETURN RCZ = RCZ + DLOG(APHI) IF (IFORM.EQ.2) RCZ = RCZ - 0.25D0*DLOG(AARG) - AIC IF (RCZ.GT.(-ELIM)) GO TO 190 180 CONTINUE YR(NN) = ZEROR YI(NN) = ZEROI NN = NN - 1 NUF = NUF + 1 IF (NN.EQ.0) RETURN GO TO 140 190 CONTINUE ASCLE = 1.0D+3*D1MACH(1)/TOL CALL ZLOG(PHIR, PHII, STR, STI, IDUM) CZR = CZR + STR CZI = CZI + STI IF (IFORM.EQ.1) GO TO 200 CALL ZLOG(ARGR, ARGI, STR, STI, IDUM) CZR = CZR - 0.25D0*STR - AIC CZI = CZI - 0.25D0*STI 200 CONTINUE AX = DEXP(RCZ)/TOL AY = CZI CZR = AX*DCOS(AY) CZI = AX*DSIN(AY) CALL ZUCHK(CZR, CZI, NW, ASCLE, TOL) IF (NW.NE.0) GO TO 180 RETURN 210 CONTINUE NUF = -1 RETURN END openspecfun-0.3/amos/zwrsk.f000066400000000000000000000064171232445310600161770ustar00rootroot00000000000000 SUBROUTINE ZWRSK(ZRR, ZRI, FNU, KODE, N, YR, YI, NZ, CWR, CWI, * TOL, ELIM, ALIM) C***BEGIN PROLOGUE ZWRSK C***REFER TO ZBESI,ZBESK C C ZWRSK COMPUTES THE I BESSEL FUNCTION FOR RE(Z).GE.0.0 BY C NORMALIZING THE I FUNCTION RATIOS FROM ZRATI BY THE WRONSKIAN C C***ROUTINES CALLED D1MACH,ZBKNU,ZRATI,ZABS C***END PROLOGUE ZWRSK C COMPLEX CINU,CSCL,CT,CW,C1,C2,RCT,ST,Y,ZR DOUBLE PRECISION ACT, ACW, ALIM, ASCLE, CINUI, CINUR, CSCLR, CTI, * CTR, CWI, CWR, C1I, C1R, C2I, C2R, ELIM, FNU, PTI, PTR, RACT, * STI, STR, TOL, YI, YR, ZRI, ZRR, ZABS, D1MACH INTEGER I, KODE, N, NW, NZ DIMENSION YR(N), YI(N), CWR(2), CWI(2) C----------------------------------------------------------------------- C I(FNU+I-1,Z) BY BACKWARD RECURRENCE FOR RATIOS C Y(I)=I(FNU+I,Z)/I(FNU+I-1,Z) FROM CRATI NORMALIZED BY THE C WRONSKIAN WITH K(FNU,Z) AND K(FNU+1,Z) FROM CBKNU. C----------------------------------------------------------------------- NZ = 0 CALL ZBKNU(ZRR, ZRI, FNU, KODE, 2, CWR, CWI, NW, TOL, ELIM, ALIM) IF (NW.NE.0) GO TO 50 CALL ZRATI(ZRR, ZRI, FNU, N, YR, YI, TOL) C----------------------------------------------------------------------- C RECUR FORWARD ON I(FNU+1,Z) = R(FNU,Z)*I(FNU,Z), C R(FNU+J-1,Z)=Y(J), J=1,...,N C----------------------------------------------------------------------- CINUR = 1.0D0 CINUI = 0.0D0 IF (KODE.EQ.1) GO TO 10 CINUR = DCOS(ZRI) CINUI = DSIN(ZRI) 10 CONTINUE C----------------------------------------------------------------------- C ON LOW EXPONENT MACHINES THE K FUNCTIONS CAN BE CLOSE TO BOTH C THE UNDER AND OVERFLOW LIMITS AND THE NORMALIZATION MUST BE C SCALED TO PREVENT OVER OR UNDERFLOW. CUOIK HAS DETERMINED THAT C THE RESULT IS ON SCALE. C----------------------------------------------------------------------- ACW = ZABS(COMPLEX(CWR(2),CWI(2))) ASCLE = 1.0D+3*D1MACH(1)/TOL CSCLR = 1.0D0 IF (ACW.GT.ASCLE) GO TO 20 CSCLR = 1.0D0/TOL GO TO 30 20 CONTINUE ASCLE = 1.0D0/ASCLE IF (ACW.LT.ASCLE) GO TO 30 CSCLR = TOL 30 CONTINUE C1R = CWR(1)*CSCLR C1I = CWI(1)*CSCLR C2R = CWR(2)*CSCLR C2I = CWI(2)*CSCLR STR = YR(1) STI = YI(1) C----------------------------------------------------------------------- C CINU=CINU*(CONJG(CT)/CABS(CT))*(1.0D0/CABS(CT) PREVENTS C UNDER- OR OVERFLOW PREMATURELY BY SQUARING CABS(CT) C----------------------------------------------------------------------- PTR = STR*C1R - STI*C1I PTI = STR*C1I + STI*C1R PTR = PTR + C2R PTI = PTI + C2I CTR = ZRR*PTR - ZRI*PTI CTI = ZRR*PTI + ZRI*PTR ACT = ZABS(COMPLEX(CTR,CTI)) RACT = 1.0D0/ACT CTR = CTR*RACT CTI = -CTI*RACT PTR = CINUR*RACT PTI = CINUI*RACT CINUR = PTR*CTR - PTI*CTI CINUI = PTR*CTI + PTI*CTR YR(1) = CINUR*CSCLR YI(1) = CINUI*CSCLR IF (N.EQ.1) RETURN DO 40 I=2,N PTR = STR*CINUR - STI*CINUI CINUI = STR*CINUI + STI*CINUR CINUR = PTR STR = YR(I) STI = YI(I) YR(I) = CINUR*CSCLR YI(I) = CINUI*CSCLR 40 CONTINUE RETURN 50 CONTINUE NZ = -1 IF(NW.EQ.(-2)) NZ=-2 RETURN END openspecfun-0.3/debian/000077500000000000000000000000001232445310600151235ustar00rootroot00000000000000openspecfun-0.3/debian/changelog000066400000000000000000000004541232445310600170000ustar00rootroot00000000000000openspecfun (0.1+1) precise; urgency=low * Add gfortran build dependency -- Elliot Saba Thu, 26 Dec 2013 17:49:28 -0500 openspecfun (0.1) precise; urgency=low * Initial release of openspecfun -- Elliot Saba Thu, 26 Dec 2013 15:24:28 -0500 openspecfun-0.3/debian/compat000066400000000000000000000000021232445310600163210ustar00rootroot000000000000008 openspecfun-0.3/debian/control000066400000000000000000000020751232445310600165320ustar00rootroot00000000000000Source: openspecfun Priority: extra Maintainer: Elliot Saba Build-Depends: debhelper (>= 8.0.0), gfortran Standards-Version: 3.9.2 Section: libs Homepage: https://github.com/JuliaLang/openspecfun Vcs-Git: git://github.com/JuliaLang/openspecfun.git Package: libopenspecfun-base Section: libs Architecture: any Description: Openspecfun provides AMOS and Faddeeva. AMOS (from Netlib) is a portable package for Bessel Functions of a Complex Argument and Nonnegative Order; it contains subroutines for computing Bessel functions and Airy functions. Faddeeva allows computing the various error functions of arbitrary complex arguments (Faddeeva function, error function, complementary error function, scaled complementary error function, imaginary error function, and Dawson function); given these, one can also easily compute Voigt functions, Fresnel integrals, and similar related functions as well. Package: libopenspecfun-dev Section: libdevel Architecture: any Depends: openspecfun-base (= ${binary:Version}) Description: Development libraries for openspecfun openspecfun-0.3/debian/copyright000066400000000000000000000053251232445310600170630ustar00rootroot00000000000000Format: http://dep.debian.net/deps/dep5 Upstream-Name: openspecfun Source: https://github.com/JuliaLang/openspecfun Files: * Copyright: 2013 Viral Shah License: MIT Files: Faddeeva/* Copyright: 2012 Massachusetts Institute of Technology License: MIT Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. Files: amos/* License: Public Domain Based on the discussion at http://octave.1599824.n4.nabble.com/Can-we-freely-use-AMOS-in-Octave-td4642557.html, AMOS is included in openspecfun as public domain software The AMOS functions are included in SLATEC, and the SLATEC guide (http://www.netlib.org/slatec/guide) explicitly states: "The Library is in the public domain and distributed by the Energy Science and Technology Software Center." Mention of AMOS's inclusion in SLATEC goes back at least to this 1985 technical report from Sandia National Labs: http://infoserve.sandia.gov/sand_doc/1985/851018.pdf Files: debian/* Copyright: 2014 Elliot Saba License: GPL-2+ This package 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 package 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, see . On Debian systems, the complete text of the GNU General Public License version 2 can be found in "/usr/share/common-licenses/GPL-2". openspecfun-0.3/debian/docs000066400000000000000000000000121232445310600157670ustar00rootroot00000000000000README.md openspecfun-0.3/debian/libopenspecfun-base.dirs000066400000000000000000000000101232445310600217210ustar00rootroot00000000000000usr/lib openspecfun-0.3/debian/libopenspecfun-base.install000066400000000000000000000001301232445310600224310ustar00rootroot00000000000000usr/local/lib/libopenspecfun.so.0.1 usr/lib/ usr/local/lib/libopenspecfun.so.0 usr/lib/ openspecfun-0.3/debian/libopenspecfun-dev.dirs000066400000000000000000000000241232445310600215720ustar00rootroot00000000000000usr/lib usr/include openspecfun-0.3/debian/libopenspecfun-dev.install000066400000000000000000000001621232445310600223020ustar00rootroot00000000000000usr/local/include/* usr/include/ usr/local/lib/libopenspecfun.so usr/lib/ usr/local/lib/libopenspecfun.a usr/lib/ openspecfun-0.3/debian/rules000077500000000000000000000006721232445310600162100ustar00rootroot00000000000000#!/usr/bin/make -f # -*- makefile -*- # Sample debian/rules that uses debhelper. # This file was originally written by Joey Hess and Craig Small. # As a special exception, when this file is copied by dh-make into a # dh-make output file, you may use that output file without restriction. # This special exception was added by Craig Small in version 0.37 of dh-make. # Uncomment this to turn on verbose mode. #export DH_VERBOSE=1 %: dh $@ openspecfun-0.3/debian/source/000077500000000000000000000000001232445310600164235ustar00rootroot00000000000000openspecfun-0.3/debian/source/format000066400000000000000000000000141232445310600176310ustar00rootroot000000000000003.0 (quilt)