diff --git a/Faddeeva/Faddeeva.c b/Faddeeva/Faddeeva.c deleted file mode 100644 index 78f5714..0000000 --- a/Faddeeva/Faddeeva.c +++ /dev/null @@ -1,3 +0,0 @@ -/* 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" diff --git a/Faddeeva/Faddeeva.cc b/Faddeeva/Faddeeva.cc deleted file mode 100644 index 6dd6904..0000000 --- a/Faddeeva/Faddeeva.cc +++ /dev/null @@ -1,2524 +0,0 @@ -// -*- 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 - -// CHANGED for OPENLIBM: -# include - -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 - -// CHANGED for OPENLIBM: -# ifndef CMPLX -# include "math_private.h" -# define CMPLX(a,b) cpack(a,b) -# 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 diff --git a/Faddeeva/Faddeeva.h b/Faddeeva/Faddeeva.h deleted file mode 100644 index 4293861..0000000 --- a/Faddeeva/Faddeeva.h +++ /dev/null @@ -1,68 +0,0 @@ -/* 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 diff --git a/Faddeeva/Make.files b/Faddeeva/Make.files deleted file mode 100644 index faa3eac..0000000 --- a/Faddeeva/Make.files +++ /dev/null @@ -1,3 +0,0 @@ -# complex error functions from the Faddeeva package -# (http://ab-initio.mit.edu/Faddeeva) -$(CUR_SRCS) += Faddeeva.c diff --git a/Make.inc b/Make.inc index aef1708..bdb7cf4 100644 --- a/Make.inc +++ b/Make.inc @@ -44,9 +44,6 @@ default: all %.S.o: %.S $(CC) $(SFLAGS) $(filter -m% -B% -I% -D%,$(CFLAGS_add)) -c $< -o $@ -clean: - rm -fr *.o *.c.o *.S.o *~ test-double test-float test-double-system test-float-system *.dSYM - # OS-specific stuff ifeq ($(ARCH),i386) override ARCH := i387 diff --git a/Makefile b/Makefile index fa822af..fa22d37 100644 --- a/Makefile +++ b/Makefile @@ -28,6 +28,9 @@ libopenlibm.a: $(OBJS) libopenlibm.$(SHLIB_EXT): $(OBJS) $(FC) -shared $(OBJS) $(LDFLAGS) -o libopenlibm.$(SHLIB_EXT) +clean: + rm -fr {./,*}/*{.o,~} + distclean: rm -f $(OBJS) *.a *.$(SHLIB_EXT) $(MAKE) -C test clean diff --git a/amos/.gitignore b/amos/.gitignore deleted file mode 100644 index ccdd49c..0000000 --- a/amos/.gitignore +++ /dev/null @@ -1,3 +0,0 @@ -*.o -/libamos.dylib -/libamos.so diff --git a/amos/Make.files b/amos/Make.files deleted file mode 100644 index 81c7c71..0000000 --- a/amos/Make.files +++ /dev/null @@ -1,5 +0,0 @@ -$(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 - diff --git a/amos/d1mach.f b/amos/d1mach.f deleted file mode 100644 index 0d344de..0000000 --- a/amos/d1mach.f +++ /dev/null @@ -1,97 +0,0 @@ -*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 diff --git a/amos/dgamln.f b/amos/dgamln.f deleted file mode 100644 index 792014b..0000000 --- a/amos/dgamln.f +++ /dev/null @@ -1,189 +0,0 @@ - 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 diff --git a/amos/i1mach.f b/amos/i1mach.f deleted file mode 100644 index b968333..0000000 --- a/amos/i1mach.f +++ /dev/null @@ -1,113 +0,0 @@ -*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 diff --git a/amos/xerror.f b/amos/xerror.f deleted file mode 100644 index baa5506..0000000 --- a/amos/xerror.f +++ /dev/null @@ -1,22 +0,0 @@ - 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 diff --git a/amos/zabs.f b/amos/zabs.f deleted file mode 100644 index b25a7ad..0000000 --- a/amos/zabs.f +++ /dev/null @@ -1,29 +0,0 @@ - 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 diff --git a/amos/zacai.f b/amos/zacai.f deleted file mode 100644 index f78fa18..0000000 --- a/amos/zacai.f +++ /dev/null @@ -1,99 +0,0 @@ - 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 diff --git a/amos/zacon.f b/amos/zacon.f deleted file mode 100644 index 860e616..0000000 --- a/amos/zacon.f +++ /dev/null @@ -1,203 +0,0 @@ - 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 diff --git a/amos/zairy.f b/amos/zairy.f deleted file mode 100644 index 9627a79..0000000 --- a/amos/zairy.f +++ /dev/null @@ -1,393 +0,0 @@ - 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 diff --git a/amos/zasyi.f b/amos/zasyi.f deleted file mode 100644 index a0982fb..0000000 --- a/amos/zasyi.f +++ /dev/null @@ -1,165 +0,0 @@ - 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 diff --git a/amos/zbesh.f b/amos/zbesh.f deleted file mode 100644 index 2bde5ae..0000000 --- a/amos/zbesh.f +++ /dev/null @@ -1,348 +0,0 @@ - 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 diff --git a/amos/zbesi.f b/amos/zbesi.f deleted file mode 100644 index 2c4726f..0000000 --- a/amos/zbesi.f +++ /dev/null @@ -1,269 +0,0 @@ - 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 diff --git a/amos/zbesj.f b/amos/zbesj.f deleted file mode 100644 index e1b89c7..0000000 --- a/amos/zbesj.f +++ /dev/null @@ -1,266 +0,0 @@ - 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 diff --git a/amos/zbesk.f b/amos/zbesk.f deleted file mode 100644 index 4a0bd15..0000000 --- a/amos/zbesk.f +++ /dev/null @@ -1,281 +0,0 @@ - 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 diff --git a/amos/zbesy.f b/amos/zbesy.f deleted file mode 100644 index 05ec40b..0000000 --- a/amos/zbesy.f +++ /dev/null @@ -1,244 +0,0 @@ - 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 diff --git a/amos/zbinu.f b/amos/zbinu.f deleted file mode 100644 index 846b459..0000000 --- a/amos/zbinu.f +++ /dev/null @@ -1,110 +0,0 @@ - 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 diff --git a/amos/zbiry.f b/amos/zbiry.f deleted file mode 100644 index 56f96a6..0000000 --- a/amos/zbiry.f +++ /dev/null @@ -1,364 +0,0 @@ - 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 diff --git a/amos/zbknu.f b/amos/zbknu.f deleted file mode 100644 index d3ac1ab..0000000 --- a/amos/zbknu.f +++ /dev/null @@ -1,568 +0,0 @@ - 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 diff --git a/amos/zbuni.f b/amos/zbuni.f deleted file mode 100644 index 3d72912..0000000 --- a/amos/zbuni.f +++ /dev/null @@ -1,174 +0,0 @@ - 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 diff --git a/amos/zbunk.f b/amos/zbunk.f deleted file mode 100644 index b20b79f..0000000 --- a/amos/zbunk.f +++ /dev/null @@ -1,35 +0,0 @@ - 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 diff --git a/amos/zdiv.f b/amos/zdiv.f deleted file mode 100644 index ab3a64b..0000000 --- a/amos/zdiv.f +++ /dev/null @@ -1,19 +0,0 @@ - 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 diff --git a/amos/zexp.f b/amos/zexp.f deleted file mode 100644 index fcb553c..0000000 --- a/amos/zexp.f +++ /dev/null @@ -1,16 +0,0 @@ - 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 diff --git a/amos/zkscl.f b/amos/zkscl.f deleted file mode 100644 index 382adf4..0000000 --- a/amos/zkscl.f +++ /dev/null @@ -1,121 +0,0 @@ - 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 diff --git a/amos/zlog.f b/amos/zlog.f deleted file mode 100644 index 607e8ed..0000000 --- a/amos/zlog.f +++ /dev/null @@ -1,41 +0,0 @@ - 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 diff --git a/amos/zmlri.f b/amos/zmlri.f deleted file mode 100644 index 08babd8..0000000 --- a/amos/zmlri.f +++ /dev/null @@ -1,204 +0,0 @@ - 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 diff --git a/amos/zmlt.f b/amos/zmlt.f deleted file mode 100644 index 3bde7d3..0000000 --- a/amos/zmlt.f +++ /dev/null @@ -1,15 +0,0 @@ - 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 diff --git a/amos/zrati.f b/amos/zrati.f deleted file mode 100644 index ea8ae3d..0000000 --- a/amos/zrati.f +++ /dev/null @@ -1,132 +0,0 @@ - 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 diff --git a/amos/zs1s2.f b/amos/zs1s2.f deleted file mode 100644 index 5b77444..0000000 --- a/amos/zs1s2.f +++ /dev/null @@ -1,49 +0,0 @@ - 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 diff --git a/amos/zseri.f b/amos/zseri.f deleted file mode 100644 index 8a7b650..0000000 --- a/amos/zseri.f +++ /dev/null @@ -1,190 +0,0 @@ - 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 diff --git a/amos/zshch.f b/amos/zshch.f deleted file mode 100644 index 168e62e..0000000 --- a/amos/zshch.f +++ /dev/null @@ -1,22 +0,0 @@ - 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 diff --git a/amos/zsqrt.f b/amos/zsqrt.f deleted file mode 100644 index d37ba72..0000000 --- a/amos/zsqrt.f +++ /dev/null @@ -1,44 +0,0 @@ - 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 diff --git a/amos/zuchk.f b/amos/zuchk.f deleted file mode 100644 index d15dc84..0000000 --- a/amos/zuchk.f +++ /dev/null @@ -1,28 +0,0 @@ - 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 diff --git a/amos/zunhj.f b/amos/zunhj.f deleted file mode 100644 index ee13895..0000000 --- a/amos/zunhj.f +++ /dev/null @@ -1,714 +0,0 @@ - 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 diff --git a/amos/zuni1.f b/amos/zuni1.f deleted file mode 100644 index cfa2f0d..0000000 --- a/amos/zuni1.f +++ /dev/null @@ -1,204 +0,0 @@ - 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 diff --git a/amos/zuni2.f b/amos/zuni2.f deleted file mode 100644 index f7387a7..0000000 --- a/amos/zuni2.f +++ /dev/null @@ -1,267 +0,0 @@ - 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 diff --git a/amos/zunik.f b/amos/zunik.f deleted file mode 100644 index 3e8293e..0000000 --- a/amos/zunik.f +++ /dev/null @@ -1,211 +0,0 @@ - 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 diff --git a/amos/zunk1.f b/amos/zunk1.f deleted file mode 100644 index 94e13ae..0000000 --- a/amos/zunk1.f +++ /dev/null @@ -1,426 +0,0 @@ - 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 diff --git a/amos/zunk2.f b/amos/zunk2.f deleted file mode 100644 index 8758203..0000000 --- a/amos/zunk2.f +++ /dev/null @@ -1,505 +0,0 @@ - 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 diff --git a/amos/zuoik.f b/amos/zuoik.f deleted file mode 100644 index 699b416..0000000 --- a/amos/zuoik.f +++ /dev/null @@ -1,194 +0,0 @@ - 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 diff --git a/amos/zwrsk.f b/amos/zwrsk.f deleted file mode 100644 index a789e57..0000000 --- a/amos/zwrsk.f +++ /dev/null @@ -1,94 +0,0 @@ - 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