Mercurial > octave
changeset 23434:f4d4d83f15c5
maint: rename cruft/ directory to external/
* liboctave/external: Renamed from liboctave/cruft.
*
* configure.ac: Rename XTRA_CRUFT_SH_LDFLAGS to XTRA_EXTERNAL_SH_LDFLAGS.
Rename CRUFT_DLL_DEFS to EXTERNAL_DLL_DEFS.
* install.txi: Update documentation to refer to liboctave/external.
* HACKING: Update explanation of directory tree.
* liboctave/module.mk: Update build system to include liboctave/external
* liboctave/numeric/module.mk: Update CPPFLAGS to find Faddeeva in external/
directory.
* lo-blas-proto.h, lo-lapack-proto.h: Update comments which referred to cruft
directory.
line wrap: on
line diff
--- a/configure.ac Mon Apr 24 17:20:37 2017 -0700 +++ b/configure.ac Mon Apr 24 21:03:38 2017 -0700 @@ -582,12 +582,12 @@ fi AC_SUBST(STATIC_LIBS) -XTRA_CRUFT_SH_LDFLAGS= +XTRA_EXTERNAL_SH_LDFLAGS= if test $have_msvc = yes; then FLIBS="$FLIBS -lkernel32" - XTRA_CRUFT_SH_LDFLAGS="-Wl,cruft/cruft.def" + XTRA_EXTERNAL_SH_LDFLAGS="-Wl,external/external.def" fi -AC_SUBST(XTRA_CRUFT_SH_LDFLAGS) +AC_SUBST(XTRA_EXTERNAL_SH_LDFLAGS) ### Enable dynamic linking. --enable-shared implies this, so ### --enable-dl is only need if you are only building static libraries @@ -619,7 +619,7 @@ NO_OCT_FILE_STRIP=false TEMPLATE_AR="${AR}" TEMPLATE_ARFLAGS="$ARFLAGS" -CRUFT_DLL_DEFS= +EXTERNAL_DLL_DEFS= OCTAVE_DLL_DEFS= OCTINTERP_DLL_DEFS= OCTGUI_DLL_DEFS= @@ -681,7 +681,7 @@ NO_OCT_FILE_STRIP=true library_path_var=PATH ## Extra compilation flags. - CRUFT_DLL_DEFS="-DCRUFT_DLL" + EXTERNAL_DLL_DEFS="-DEXTERNAL_DLL" OCTAVE_DLL_DEFS="-DOCTAVE_DLL" OCTINTERP_DLL_DEFS="-DOCTINTERP_DLL" OCTGUI_DLL_DEFS="-DOCTGUI_DLL" @@ -709,7 +709,7 @@ NO_OCT_FILE_STRIP=true library_path_var=PATH ## Extra compilation flags. - CRUFT_DLL_DEFS="-DCRUFT_DLL" + EXTERNAL_DLL_DEFS="-DEXTERNAL_DLL" OCTAVE_DLL_DEFS="-DOCTAVE_DLL" OCTGUI_DLL_DEFS="-DOCTGUI_DLL" OCTGRAPHICS_DLL_DEFS="-DOCTGRAPHICS_DLL" @@ -794,7 +794,7 @@ AC_MSG_NOTICE([defining NO_OCT_FILE_STRIP to be $NO_OCT_FILE_STRIP]) AC_MSG_NOTICE([defining TEMPLATE_AR to be $TEMPLATE_AR]) AC_MSG_NOTICE([defining TEMPLATE_ARFLAGS to be $TEMPLATE_ARFLAGS]) -AC_MSG_NOTICE([defining CRUFT_DLL_DEFS to be $CRUFT_DLL_DEFS]) +AC_MSG_NOTICE([defining EXTERNAL_DLL_DEFS to be $EXTERNAL_DLL_DEFS]) AC_MSG_NOTICE([defining OCTAVE_DLL_DEFS to be $OCTAVE_DLL_DEFS]) AC_MSG_NOTICE([defining OCTINTERP_DLL_DEFS to be $OCTINTERP_DLL_DEFS]) AC_MSG_NOTICE([defining OCTGUI_DLL_DEFS to be $OCTGUI_DLL_DEFS]) @@ -811,7 +811,7 @@ AC_SUBST(NO_OCT_FILE_STRIP) AC_SUBST(TEMPLATE_AR) AC_SUBST(TEMPLATE_ARFLAGS) -AC_SUBST(CRUFT_DLL_DEFS) +AC_SUBST(EXTERNAL_DLL_DEFS) AC_SUBST(OCTAVE_DLL_DEFS) AC_SUBST(OCTINTERP_DLL_DEFS) AC_SUBST(OCTGUI_DLL_DEFS) @@ -1569,7 +1569,7 @@ AC_SUBST(FFTW_XLDFLAGS) AC_SUBST(FFTW_XLIBS) -## Subdirectory of liboctave/cruft to build if FFTW is not found. +## Subdirectory of liboctave/external to build if FFTW is not found. FFT_DIR="fftpack" AC_SUBST(FFT_DIR)
--- a/doc/interpreter/install.txi Mon Apr 24 17:20:37 2017 -0700 +++ b/doc/interpreter/install.txi Mon Apr 24 21:03:38 2017 -0700 @@ -778,12 +778,12 @@ @end example You must ensure that all Fortran sources except those in the -@file{liboctave/cruft/ranlib} directory are compiled such that INTEGERS are +@file{liboctave/external/ranlib} directory are compiled such that INTEGERS are 8-bytes wide. If you are using gfortran, the configure script should automatically set the Makefile variable @w{@env{F77_INTEGER_8_FLAG}} to @option{-fdefault-integer-8}. If you are using another compiler, you must set this variable yourself. You should NOT set this flag in -@env{FFLAGS}, otherwise the files in @file{liboctave/cruft/ranlib} will be +@env{FFLAGS}, otherwise the files in @file{liboctave/external/ranlib} will be miscompiled. @item Other dependencies @@ -958,7 +958,7 @@ @end example @noindent -when compiling the Fortran subroutines in the @file{liboctave/cruft} +when compiling the Fortran subroutines in the @file{liboctave/external} subdirectory, you should either upgrade your compiler or try compiling with optimization turned off.
--- a/etc/HACKING Mon Apr 24 17:20:37 2017 -0700 +++ b/etc/HACKING Mon Apr 24 21:03:38 2017 -0700 @@ -169,7 +169,7 @@ array the base Array, NDArray, Matrix, and Sparse classes - cruft various numerical libraries (mostly Fortran) + external various numerical libraries (mostly Fortran) amos bessel functions
--- a/liboctave/cruft/Faddeeva/Faddeeva.cc Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,2508 +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<double>, 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 <cmath> 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<x<26. Performance improvements. Prototype - now supplies default value for relerr. - 24 October 2012: Switch to continued-fraction expansion for - sufficiently large z, for performance reasons. - Also, avoid spurious overflow for |z| > 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). */ - -#if defined (HAVE_CONFIG_H) -# include "config.h" -#endif - -///////////////////////////////////////////////////////////////////////// -// macros to allow us to use either C++ or C (with C99 features) - -#if defined (__cplusplus) - -# include "lo-ieee.h" - -# include "Faddeeva.hh" - -# include <cfloat> -# include <cmath> -# include <limits> - -// use std::numeric_limits, since 1./0. and 0./0. fail with some compilers (MS) -# define Inf octave::numeric_limits<double>::Inf () -# define NaN octave::numeric_limits<double>::NaN () - -typedef std::complex<double> 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 defined (lo_ieee_isnan) && defined (lo_ieee_isinf) -# define isnan lo_ieee_isnan -# define isinf lo_ieee_isinf -# elif (__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 (__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 - -#else // !__cplusplus, i.e., pure C (requires C99 features) - -# include "Faddeeva.h" - -# define _GNU_SOURCE // enable GNU libc NAN extension if possible - -# include <float.h> -# include <math.h> - -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 - -# if defined (CMPLX) // C11 -# define C(a,b) CMPLX(a,b) -# define Inf INFINITY // C99 infinity -# if defined (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 (static_cast<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 (static_cast<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 -#if defined (TEST_FADDEEVA) - -#if defined (__cplusplus) -# include <cstdio> -#else -# include <stdio.h> -#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
--- a/liboctave/cruft/Faddeeva/Faddeeva.hh Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,62 +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.cc; see that file for more information. */ - -#ifndef FADDEEVA_HH -#define FADDEEVA_HH 1 - -#include <complex> - -namespace Faddeeva { - -// compute w(z) = exp(-z^2) erfc(-iz) [ Faddeeva / scaled complex error func ] -extern std::complex<double> w(std::complex<double> z,double relerr=0); -extern double 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 std::complex<double> erfcx(std::complex<double> z, double relerr=0); -extern double erfcx(double x); // special case for real x - -// compute erf(z), the error function of complex arguments -extern std::complex<double> erf(std::complex<double> z, double relerr=0); -extern double erf(double x); // special case for real x - -// compute erfi(z) = -i erf(iz), the imaginary error function -extern std::complex<double> erfi(std::complex<double> z, double relerr=0); -extern double erfi(double x); // special case for real x - -// compute erfc(z) = 1 - erf(z), the complementary error function -extern std::complex<double> erfc(std::complex<double> z, double relerr=0); -extern double erfc(double x); // special case for real x - -// compute Dawson(z) = sqrt(pi)/2 * exp(-z^2) * erfi(z) -extern std::complex<double> Dawson(std::complex<double> z, double relerr=0); -extern double Dawson(double x); // special case for real x - -} // namespace Faddeeva - -#endif // FADDEEVA_HH
--- a/liboctave/cruft/Faddeeva/module.mk Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,3 +0,0 @@ -CRUFT_SOURCES += \ - liboctave/cruft/Faddeeva/Faddeeva.cc \ - liboctave/cruft/Faddeeva/Faddeeva.hh
--- a/liboctave/cruft/amos/README Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,15 +0,0 @@ -The files in this directory have been modified from those found on -netlib by changing the following subroutine names - - zabs --> xzabs - zexp --> xzexp - zlog --> xzlog - zsqrt --> xzsqrt - -to avoid conflicts with non-standard but commonly used Fortran -intrinsic function names. - -John W. Eaton -jwe@octave.org - -Wed Nov 11 17:29:50 1998
--- a/liboctave/cruft/amos/cacai.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,90 +0,0 @@ - SUBROUTINE CACAI(Z, FNU, KODE, MR, N, Y, NZ, RL, TOL, ELIM, ALIM) -C***BEGIN PROLOGUE CACAI -C***REFER TO CAIRY -C -C CACAI 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 CAIRY WHERE FNU=1/3 OR 2/3 AND N=1. -C CACAI IS THE SAME AS CACON WITH THE PARTS FOR LARGER ORDERS AND -C RECURRENCE REMOVED. A RECURSIVE CALL TO CACON CAN RESULT IF CACON -C IS CALLED FROM CAIRY. -C -C***ROUTINES CALLED CASYI,CBKNU,CMLRI,CSERI,CS1S2,R1MACH -C***END PROLOGUE CACAI - COMPLEX CSGN, CSPN, C1, C2, Y, Z, ZN, CY - REAL ALIM, ARG, ASCLE, AZ, CPN, DFNU, ELIM, FMR, FNU, PI, RL, - * SGN, SPN, TOL, YY, R1MACH - INTEGER INU, IUF, KODE, MR, N, NN, NW, NZ - DIMENSION Y(N), CY(2) - DATA PI / 3.14159265358979324E0 / - NZ = 0 - ZN = -Z - AZ = CABS(Z) - NN = N - DFNU = FNU + FLOAT(N-1) - IF (AZ.LE.2.0E0) GO TO 10 - IF (AZ*AZ*0.25E0.GT.DFNU+1.0E0) GO TO 20 - 10 CONTINUE -C----------------------------------------------------------------------- -C POWER SERIES FOR THE I FUNCTION -C----------------------------------------------------------------------- - CALL CSERI(ZN, FNU, KODE, NN, Y, 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 CASYI(ZN, FNU, KODE, NN, Y, NW, RL, TOL, ELIM, ALIM) - IF (NW.LT.0) GO TO 70 - GO TO 40 - 30 CONTINUE -C----------------------------------------------------------------------- -C MILLER ALGORITHM NORMALIZED BY THE SERIES FOR THE I FUNCTION -C----------------------------------------------------------------------- - CALL CMLRI(ZN, FNU, KODE, NN, Y, NW, TOL) - IF(NW.LT.0) GO TO 70 - 40 CONTINUE -C----------------------------------------------------------------------- -C ANALYTIC CONTINUATION TO THE LEFT HALF PLANE FOR THE K FUNCTION -C----------------------------------------------------------------------- - CALL CBKNU(ZN, FNU, KODE, 1, CY, NW, TOL, ELIM, ALIM) - IF (NW.NE.0) GO TO 70 - FMR = FLOAT(MR) - SGN = -SIGN(PI,FMR) - CSGN = CMPLX(0.0E0,SGN) - IF (KODE.EQ.1) GO TO 50 - YY = -AIMAG(ZN) - CPN = COS(YY) - SPN = SIN(YY) - CSGN = CSGN*CMPLX(CPN,SPN) - 50 CONTINUE -C----------------------------------------------------------------------- -C CALCULATE CSPN=EXP(FNU*PI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE -C WHEN FNU IS LARGE -C----------------------------------------------------------------------- - INU = INT(FNU) - ARG = (FNU-FLOAT(INU))*SGN - CPN = COS(ARG) - SPN = SIN(ARG) - CSPN = CMPLX(CPN,SPN) - IF (MOD(INU,2).EQ.1) CSPN = -CSPN - C1 = CY(1) - C2 = Y(1) - IF (KODE.EQ.1) GO TO 60 - IUF = 0 - ASCLE = 1.0E+3*R1MACH(1)/TOL - CALL CS1S2(ZN, C1, C2, NW, ASCLE, ALIM, IUF) - NZ = NZ + NW - 60 CONTINUE - Y(1) = CSPN*C1 + CSGN*C2 - RETURN - 70 CONTINUE - NZ = -1 - IF(NW.EQ.(-2)) NZ=-2 - RETURN - END
--- a/liboctave/cruft/amos/cacon.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,149 +0,0 @@ - SUBROUTINE CACON(Z, FNU, KODE, MR, N, Y, NZ, RL, FNUL, TOL, ELIM, - * ALIM) -C***BEGIN PROLOGUE CACON -C***REFER TO CBESK,CBESH -C -C CACON 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 CBINU,CBKNU,CS1S2,R1MACH -C***END PROLOGUE CACON - COMPLEX CK, CONE, CS, CSCL, CSCR, CSGN, CSPN, CSS, CSR, C1, C2, - * RZ, SC1, SC2, ST, S1, S2, Y, Z, ZN, CY - REAL ALIM, ARG, ASCLE, AS2, BSCLE, BRY, CPN, C1I, C1M, C1R, ELIM, - * FMR, FNU, FNUL, PI, RL, SGN, SPN, TOL, YY, R1MACH - INTEGER I, INU, IUF, KFLAG, KODE, MR, N, NN, NW, NZ - DIMENSION Y(N), CY(2), CSS(3), CSR(3), BRY(3) - DATA PI / 3.14159265358979324E0 / - DATA CONE / (1.0E0,0.0E0) / - NZ = 0 - ZN = -Z - NN = N - CALL CBINU(ZN, FNU, KODE, NN, Y, NW, RL, FNUL, TOL, ELIM, ALIM) - IF (NW.LT.0) GO TO 80 -C----------------------------------------------------------------------- -C ANALYTIC CONTINUATION TO THE LEFT HALF PLANE FOR THE K FUNCTION -C----------------------------------------------------------------------- - NN = MIN0(2,N) - CALL CBKNU(ZN, FNU, KODE, NN, CY, NW, TOL, ELIM, ALIM) - IF (NW.NE.0) GO TO 80 - S1 = CY(1) - FMR = FLOAT(MR) - SGN = -SIGN(PI,FMR) - CSGN = CMPLX(0.0E0,SGN) - IF (KODE.EQ.1) GO TO 10 - YY = -AIMAG(ZN) - CPN = COS(YY) - SPN = SIN(YY) - CSGN = CSGN*CMPLX(CPN,SPN) - 10 CONTINUE -C----------------------------------------------------------------------- -C CALCULATE CSPN=EXP(FNU*PI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE -C WHEN FNU IS LARGE -C----------------------------------------------------------------------- - INU = INT(FNU) - ARG = (FNU-FLOAT(INU))*SGN - CPN = COS(ARG) - SPN = SIN(ARG) - CSPN = CMPLX(CPN,SPN) - IF (MOD(INU,2).EQ.1) CSPN = -CSPN - IUF = 0 - C1 = S1 - C2 = Y(1) - ASCLE = 1.0E+3*R1MACH(1)/TOL - IF (KODE.EQ.1) GO TO 20 - CALL CS1S2(ZN, C1, C2, NW, ASCLE, ALIM, IUF) - NZ = NZ + NW - SC1 = C1 - 20 CONTINUE - Y(1) = CSPN*C1 + CSGN*C2 - IF (N.EQ.1) RETURN - CSPN = -CSPN - S2 = CY(2) - C1 = S2 - C2 = Y(2) - IF (KODE.EQ.1) GO TO 30 - CALL CS1S2(ZN, C1, C2, NW, ASCLE, ALIM, IUF) - NZ = NZ + NW - SC2 = C1 - 30 CONTINUE - Y(2) = CSPN*C1 + CSGN*C2 - IF (N.EQ.2) RETURN - CSPN = -CSPN - RZ = CMPLX(2.0E0,0.0E0)/ZN - CK = CMPLX(FNU+1.0E0,0.0E0)*RZ -C----------------------------------------------------------------------- -C SCALE NEAR EXPONENT EXTREMES DURING RECURRENCE ON K FUNCTIONS -C----------------------------------------------------------------------- - CSCL = CMPLX(1.0E0/TOL,0.0E0) - CSCR = CMPLX(TOL,0.0E0) - CSS(1) = CSCL - CSS(2) = CONE - CSS(3) = CSCR - CSR(1) = CSCR - CSR(2) = CONE - CSR(3) = CSCL - BRY(1) = ASCLE - BRY(2) = 1.0E0/ASCLE - BRY(3) = R1MACH(2) - AS2 = CABS(S2) - KFLAG = 2 - IF (AS2.GT.BRY(1)) GO TO 40 - KFLAG = 1 - GO TO 50 - 40 CONTINUE - IF (AS2.LT.BRY(2)) GO TO 50 - KFLAG = 3 - 50 CONTINUE - BSCLE = BRY(KFLAG) - S1 = S1*CSS(KFLAG) - S2 = S2*CSS(KFLAG) - CS = CSR(KFLAG) - DO 70 I=3,N - ST = S2 - S2 = CK*S2 + S1 - S1 = ST - C1 = S2*CS - ST = C1 - C2 = Y(I) - IF (KODE.EQ.1) GO TO 60 - IF (IUF.LT.0) GO TO 60 - CALL CS1S2(ZN, C1, C2, NW, ASCLE, ALIM, IUF) - NZ = NZ + NW - SC1 = SC2 - SC2 = C1 - IF (IUF.NE.3) GO TO 60 - IUF = -4 - S1 = SC1*CSS(KFLAG) - S2 = SC2*CSS(KFLAG) - ST = SC2 - 60 CONTINUE - Y(I) = CSPN*C1 + CSGN*C2 - CK = CK + RZ - CSPN = -CSPN - IF (KFLAG.GE.3) GO TO 70 - C1R = REAL(C1) - C1I = AIMAG(C1) - C1R = ABS(C1R) - C1I = ABS(C1I) - C1M = AMAX1(C1R,C1I) - IF (C1M.LE.BSCLE) GO TO 70 - KFLAG = KFLAG + 1 - BSCLE = BRY(KFLAG) - S1 = S1*CS - S2 = ST - S1 = S1*CSS(KFLAG) - S2 = S2*CSS(KFLAG) - CS = CSR(KFLAG) - 70 CONTINUE - RETURN - 80 CONTINUE - NZ = -1 - IF(NW.EQ.(-2)) NZ=-2 - RETURN - END
--- a/liboctave/cruft/amos/cairy.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,336 +0,0 @@ - SUBROUTINE CAIRY(Z, ID, KODE, AI, NZ, IERR) -C***BEGIN PROLOGUE CAIRY -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 ON KODE=1, CAIRY 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 DEFINITIONS AND NOTATION ARE FOUND IN THE NBS HANDBOOK OF -C MATHEMATICAL FUNCTIONS (REF. 1). -C -C INPUT -C Z - Z=CMPLX(X,Y) -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 -C AI - 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.0,0.0) 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 WITH 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 -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=R1MACH(4)=UNIT ROUNDOFF. -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 CACAI,CBKNU,I1MACH,R1MACH -C***END PROLOGUE CAIRY - COMPLEX AI, CONE, CSQ, CY, S1, S2, TRM1, TRM2, Z, ZTA, Z3 - REAL AA, AD, AK, ALIM, ATRM, AZ, AZ3, BK, CK, COEF, C1, C2, DIG, - * DK, D1, D2, ELIM, FID, FNU, RL, R1M5, SFAC, TOL, TTH, ZI, ZR, - * Z3I, Z3R, R1MACH, BB, ALAZ - INTEGER ID, IERR, IFLAG, K, KODE, K1, K2, MR, NN, NZ, I1MACH - DIMENSION CY(1) - DATA TTH, C1, C2, COEF /6.66666666666666667E-01, - * 3.55028053887817240E-01,2.58819403792806799E-01, - * 1.83776298473930683E-01/ - DATA CONE / (1.0E0,0.0E0) / -C***FIRST EXECUTABLE STATEMENT CAIRY - 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 = CABS(Z) - TOL = AMAX1(R1MACH(4),1.0E-18) - FID = FLOAT(ID) - IF (AZ.GT.1.0E0) GO TO 60 -C----------------------------------------------------------------------- -C POWER SERIES FOR CABS(Z).LE.1. -C----------------------------------------------------------------------- - S1 = CONE - S2 = CONE - IF (AZ.LT.TOL) GO TO 160 - AA = AZ*AZ - IF (AA.LT.TOL/AZ) GO TO 40 - TRM1 = CONE - TRM2 = CONE - ATRM = 1.0E0 - Z3 = Z*Z*Z - AZ3 = AZ*AA - AK = 2.0E0 + FID - BK = 3.0E0 - FID - FID - CK = 4.0E0 - FID - DK = 3.0E0 + FID + FID - D1 = AK*DK - D2 = BK*CK - AD = AMIN1(D1,D2) - AK = 24.0E0 + 9.0E0*FID - BK = 30.0E0 - 9.0E0*FID - Z3R = REAL(Z3) - Z3I = AIMAG(Z3) - DO 30 K=1,25 - TRM1 = TRM1*CMPLX(Z3R/D1,Z3I/D1) - S1 = S1 + TRM1 - TRM2 = TRM2*CMPLX(Z3R/D2,Z3I/D2) - S2 = S2 + TRM2 - ATRM = ATRM*AZ3/AD - D1 = D1 + AK - D2 = D2 + BK - AD = AMIN1(D1,D2) - IF (ATRM.LT.TOL*AD) GO TO 40 - AK = AK + 18.0E0 - BK = BK + 18.0E0 - 30 CONTINUE - 40 CONTINUE - IF (ID.EQ.1) GO TO 50 - AI = S1*CMPLX(C1,0.0E0) - Z*S2*CMPLX(C2,0.0E0) - IF (KODE.EQ.1) RETURN - ZTA = Z*CSQRT(Z)*CMPLX(TTH,0.0E0) - AI = AI*CEXP(ZTA) - RETURN - 50 CONTINUE - AI = -S2*CMPLX(C2,0.0E0) - IF (AZ.GT.TOL) AI = AI + Z*Z*S1*CMPLX(C1/(1.0E0+FID),0.0E0) - IF (KODE.EQ.1) RETURN - ZTA = Z*CSQRT(Z)*CMPLX(TTH,0.0E0) - AI = AI*CEXP(ZTA) - RETURN -C----------------------------------------------------------------------- -C CASE FOR CABS(Z).GT.1.0 -C----------------------------------------------------------------------- - 60 CONTINUE - FNU = (1.0E0+FID)/3.0E0 -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----------------------------------------------------------------------- - K1 = I1MACH(12) - K2 = I1MACH(13) - R1M5 = R1MACH(5) - K = MIN0(IABS(K1),IABS(K2)) - ELIM = 2.303E0*(FLOAT(K)*R1M5-3.0E0) - K1 = I1MACH(11) - 1 - AA = R1M5*FLOAT(K1) - DIG = AMIN1(AA,18.0E0) - AA = AA*2.303E0 - ALIM = ELIM + AMAX1(-AA,-41.45E0) - RL = 1.2E0*DIG + 3.0E0 - ALAZ=ALOG(AZ) -C----------------------------------------------------------------------- -C TEST FOR RANGE -C----------------------------------------------------------------------- - AA=0.5E0/TOL - BB=FLOAT(I1MACH(9))*0.5E0 - AA=AMIN1(AA,BB) - AA=AA**TTH - IF (AZ.GT.AA) GO TO 260 - AA=SQRT(AA) - IF (AZ.GT.AA) IERR=3 - CSQ=CSQRT(Z) - ZTA=Z*CSQ*CMPLX(TTH,0.0E0) -C----------------------------------------------------------------------- -C RE(ZTA).LE.0 WHEN RE(Z).LT.0, ESPECIALLY WHEN IM(Z) IS SMALL -C----------------------------------------------------------------------- - IFLAG = 0 - SFAC = 1.0E0 - ZI = AIMAG(Z) - ZR = REAL(Z) - AK = AIMAG(ZTA) - IF (ZR.GE.0.0E0) GO TO 70 - BK = REAL(ZTA) - CK = -ABS(BK) - ZTA = CMPLX(CK,AK) - 70 CONTINUE - IF (ZI.NE.0.0E0) GO TO 80 - IF (ZR.GT.0.0E0) GO TO 80 - ZTA = CMPLX(0.0E0,AK) - 80 CONTINUE - AA = REAL(ZTA) - IF (AA.GE.0.0E0 .AND. ZR.GT.0.0E0) GO TO 100 - IF (KODE.EQ.2) GO TO 90 -C----------------------------------------------------------------------- -C OVERFLOW TEST -C----------------------------------------------------------------------- - IF (AA.GT.(-ALIM)) GO TO 90 - AA = -AA + 0.25E0*ALAZ - IFLAG = 1 - SFAC = TOL - IF (AA.GT.ELIM) GO TO 240 - 90 CONTINUE -C----------------------------------------------------------------------- -C CBKNU AND CACAI RETURN EXP(ZTA)*K(FNU,ZTA) ON KODE=2 -C----------------------------------------------------------------------- - MR = 1 - IF (ZI.LT.0.0E0) MR = -1 - CALL CACAI(ZTA, FNU, KODE, MR, 1, CY, NN, RL, TOL, ELIM, ALIM) - IF (NN.LT.0) GO TO 250 - NZ = NZ + NN - GO TO 120 - 100 CONTINUE - IF (KODE.EQ.2) GO TO 110 -C----------------------------------------------------------------------- -C UNDERFLOW TEST -C----------------------------------------------------------------------- - IF (AA.LT.ALIM) GO TO 110 - AA = -AA - 0.25E0*ALAZ - IFLAG = 2 - SFAC = 1.0E0/TOL - IF (AA.LT.(-ELIM)) GO TO 180 - 110 CONTINUE - CALL CBKNU(ZTA, FNU, KODE, 1, CY, NZ, TOL, ELIM, ALIM) - 120 CONTINUE - S1 = CY(1)*CMPLX(COEF,0.0E0) - IF (IFLAG.NE.0) GO TO 140 - IF (ID.EQ.1) GO TO 130 - AI = CSQ*S1 - RETURN - 130 AI = -Z*S1 - RETURN - 140 CONTINUE - S1 = S1*CMPLX(SFAC,0.0E0) - IF (ID.EQ.1) GO TO 150 - S1 = S1*CSQ - AI = S1*CMPLX(1.0E0/SFAC,0.0E0) - RETURN - 150 CONTINUE - S1 = -S1*Z - AI = S1*CMPLX(1.0E0/SFAC,0.0E0) - RETURN - 160 CONTINUE - AA = 1.0E+3*R1MACH(1) - S1 = CMPLX(0.0E0,0.0E0) - IF (ID.EQ.1) GO TO 170 - IF (AZ.GT.AA) S1 = CMPLX(C2,0.0E0)*Z - AI = CMPLX(C1,0.0E0) - S1 - RETURN - 170 CONTINUE - AI = -CMPLX(C2,0.0E0) - AA = SQRT(AA) - IF (AZ.GT.AA) S1 = Z*Z*CMPLX(0.5E0,0.0E0) - AI = AI + S1*CMPLX(C1,0.0E0) - RETURN - 180 CONTINUE - NZ = 1 - AI = CMPLX(0.0E0,0.0E0) - RETURN - 240 CONTINUE - NZ = 0 - IERR=2 - RETURN - 250 CONTINUE - IF(NN.EQ.(-1)) GO TO 240 - NZ=0 - IERR=5 - RETURN - 260 CONTINUE - IERR=4 - NZ=0 - RETURN - END
--- a/liboctave/cruft/amos/casyi.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,126 +0,0 @@ - SUBROUTINE CASYI(Z, FNU, KODE, N, Y, NZ, RL, TOL, ELIM, ALIM) -C***BEGIN PROLOGUE CASYI -C***REFER TO CBESI,CBESK -C -C CASYI 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 R1MACH -C***END PROLOGUE CASYI - COMPLEX AK1, CK, CONE, CS1, CS2, CZ, CZERO, DK, EZ, P1, RZ, S2, - * Y, Z - REAL AA, ACZ, AEZ, AK, ALIM, ARG, ARM, ATOL, AZ, BB, BK, DFNU, - * DNU2, ELIM, FDN, FNU, PI, RL, RTPI, RTR1, S, SGN, SQK, TOL, X, - * YY, R1MACH - INTEGER I, IB, IL, INU, J, JL, K, KODE, KODED, M, N, NN, NZ - DIMENSION Y(N) - DATA PI, RTPI /3.14159265358979324E0 , 0.159154943091895336E0 / - DATA CZERO, CONE / (0.0E0,0.0E0), (1.0E0,0.0E0) / -C - NZ = 0 - AZ = CABS(Z) - X = REAL(Z) - ARM = 1.0E+3*R1MACH(1) - RTR1 = SQRT(ARM) - IL = MIN0(2,N) - DFNU = FNU + FLOAT(N-IL) -C----------------------------------------------------------------------- -C OVERFLOW TEST -C----------------------------------------------------------------------- - AK1 = CMPLX(RTPI,0.0E0)/Z - AK1 = CSQRT(AK1) - CZ = Z - IF (KODE.EQ.2) CZ = Z - CMPLX(X,0.0E0) - ACZ = REAL(CZ) - IF (ABS(ACZ).GT.ELIM) GO TO 80 - DNU2 = DFNU + DFNU - KODED = 1 - IF ((ABS(ACZ).GT.ALIM) .AND. (N.GT.2)) GO TO 10 - KODED = 0 - AK1 = AK1*CEXP(CZ) - 10 CONTINUE - FDN = 0.0E0 - IF (DNU2.GT.RTR1) FDN = DNU2*DNU2 - EZ = Z*CMPLX(8.0E0,0.0E0) -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.0E0*AZ - S = TOL/AEZ - JL = INT(RL+RL) + 2 - YY = AIMAG(Z) - P1 = CZERO - IF (YY.EQ.0.0E0) GO TO 20 -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(FNU) - ARG = (FNU-FLOAT(INU))*PI - INU = INU + N - IL - AK = -SIN(ARG) - BK = COS(ARG) - IF (YY.LT.0.0E0) BK = -BK - P1 = CMPLX(AK,BK) - IF (MOD(INU,2).EQ.1) P1 = -P1 - 20 CONTINUE - DO 50 K=1,IL - SQK = FDN - 1.0E0 - ATOL = S*ABS(SQK) - SGN = 1.0E0 - CS1 = CONE - CS2 = CONE - CK = CONE - AK = 0.0E0 - AA = 1.0E0 - BB = AEZ - DK = EZ - DO 30 J=1,JL - CK = CK*CMPLX(SQK,0.0E0)/DK - CS2 = CS2 + CK - SGN = -SGN - CS1 = CS1 + CK*CMPLX(SGN,0.0E0) - DK = DK + EZ - AA = AA*ABS(SQK)/BB - BB = BB + AEZ - AK = AK + 8.0E0 - SQK = SQK - AK - IF (AA.LE.ATOL) GO TO 40 - 30 CONTINUE - GO TO 90 - 40 CONTINUE - S2 = CS1 - IF (X+X.LT.ELIM) S2 = S2 + P1*CS2*CEXP(-Z-Z) - FDN = FDN + 8.0E0*DFNU + 4.0E0 - P1 = -P1 - M = N - IL + K - Y(M) = S2*AK1 - 50 CONTINUE - IF (N.LE.2) RETURN - NN = N - K = NN - 2 - AK = FLOAT(K) - RZ = (CONE+CONE)/Z - IB = 3 - DO 60 I=IB,NN - Y(K) = CMPLX(AK+FNU,0.0E0)*RZ*Y(K+1) + Y(K+2) - AK = AK - 1.0E0 - K = K - 1 - 60 CONTINUE - IF (KODED.EQ.0) RETURN - CK = CEXP(CZ) - DO 70 I=1,NN - Y(I) = Y(I)*CK - 70 CONTINUE - RETURN - 80 CONTINUE - NZ = -1 - RETURN - 90 CONTINUE - NZ=-2 - RETURN - END
--- a/liboctave/cruft/amos/cbesh.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,331 +0,0 @@ - SUBROUTINE CBESH(Z, FNU, KODE, M, N, CY, NZ, IERR) -C***BEGIN PROLOGUE CBESH -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 ON KODE=1, CBESH 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.0E0,0.0E0) IN THE CUT PLANE -PI.LT.ARG(Z).LE.PI. -C ON KODE=2, CBESH COMPUTES THE SCALED HANKEL FUNCTIONS -C -C CY(I)=H(M,FNU+J-1,Z)*EXP(-MM*Z*I) MM=3-2M, I**2=-1. -C -C WHICH REMOVES THE EXPONENTIAL BEHAVIOR IN BOTH THE UPPER -C AND LOWER HALF PLANES. DEFINITIONS AND NOTATION ARE FOUND IN -C THE NBS HANDBOOK OF MATHEMATICAL FUNCTIONS (REF. 1). -C -C INPUT -C Z - Z=CMPLX(X,Y), Z.NE.CMPLX(0.,0.),-PI.LT.ARG(Z).LE.PI -C FNU - ORDER OF INITIAL H FUNCTION, FNU.GE.0.0E0 -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 OF THE SEQUENCE, N.GE.1 -C -C OUTPUT -C CY - A COMPLEX VECTOR WHOSE FIRST N COMPONENTS CONTAIN -C VALUES 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 -C DUE TO UNDERFLOW, CY(J)=CMPLX(0.0,0.0) -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+N-1 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=R1MACH(4)=UNIT ROUNDOFF. ALSO -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 CACON,CBKNU,CBUNK,CUOIK,I1MACH,R1MACH -C***END PROLOGUE CBESH -C - COMPLEX CY, Z, ZN, ZT, CSGN - REAL AA, ALIM, ALN, ARG, AZ, CPN, DIG, ELIM, FMM, FN, FNU, FNUL, - * HPI, RHPI, RL, R1M5, SGN, SPN, TOL, UFL, XN, XX, YN, YY, R1MACH, - * BB, ASCLE, RTOL, ATOL - INTEGER I, IERR, INU, INUH, IR, K, KODE, K1, K2, M, - * MM, MR, N, NN, NUF, NW, NZ, I1MACH - DIMENSION CY(N) -C - DATA HPI /1.57079632679489662E0/ -C -C***FIRST EXECUTABLE STATEMENT CBESH - NZ=0 - XX = REAL(Z) - YY = AIMAG(Z) - IERR = 0 - IF (XX.EQ.0.0E0 .AND. YY.EQ.0.0E0) IERR=1 - IF (FNU.LT.0.0E0) 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 = AMAX1(R1MACH(4),1.0E-18) - K1 = I1MACH(12) - K2 = I1MACH(13) - R1M5 = R1MACH(5) - K = MIN0(IABS(K1),IABS(K2)) - ELIM = 2.303E0*(FLOAT(K)*R1M5-3.0E0) - K1 = I1MACH(11) - 1 - AA = R1M5*FLOAT(K1) - DIG = AMIN1(AA,18.0E0) - AA = AA*2.303E0 - ALIM = ELIM + AMAX1(-AA,-41.45E0) - FNUL = 10.0E0 + 6.0E0*(DIG-3.0E0) - RL = 1.2E0*DIG + 3.0E0 - FN = FNU + FLOAT(NN-1) - MM = 3 - M - M - FMM = FLOAT(MM) - ZN = Z*CMPLX(0.0E0,-FMM) - XN = REAL(ZN) - YN = AIMAG(ZN) - AZ = CABS(Z) -C----------------------------------------------------------------------- -C TEST FOR RANGE -C----------------------------------------------------------------------- - AA = 0.5E0/TOL - BB=FLOAT(I1MACH(9))*0.5E0 - AA=AMIN1(AA,BB) - IF(AZ.GT.AA) GO TO 240 - IF(FN.GT.AA) GO TO 240 - AA=SQRT(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 = R1MACH(1)*1.0E+3 - IF (AZ.LT.UFL) GO TO 220 - IF (FNU.GT.FNUL) GO TO 90 - IF (FN.LE.1.0E0) GO TO 70 - IF (FN.GT.2.0E0) GO TO 60 - IF (AZ.GT.TOL) GO TO 70 - ARG = 0.5E0*AZ - ALN = -FN*ALOG(ARG) - IF (ALN.GT.ELIM) GO TO 220 - GO TO 70 - 60 CONTINUE - CALL CUOIK(ZN, FNU, KODE, 2, NN, CY, NUF, TOL, ELIM, ALIM) - IF (NUF.LT.0) GO TO 220 - 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 130 - 70 CONTINUE - IF ((XN.LT.0.0E0) .OR. (XN.EQ.0.0E0 .AND. YN.LT.0.0E0 .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 CBKNU(ZN, FNU, KODE, NN, CY, NZ, TOL, ELIM, ALIM) - GO TO 110 -C----------------------------------------------------------------------- -C LEFT HALF PLANE COMPUTATION -C----------------------------------------------------------------------- - 80 CONTINUE - MR = -MM - CALL CACON(ZN, FNU, KODE, MR, NN, CY, NW, RL, FNUL, TOL, ELIM, - * ALIM) - IF (NW.LT.0) GO TO 230 - NZ=NW - GO TO 110 - 90 CONTINUE -C----------------------------------------------------------------------- -C UNIFORM ASYMPTOTIC EXPANSIONS FOR FNU.GT.FNUL -C----------------------------------------------------------------------- - MR = 0 - IF ((XN.GE.0.0E0) .AND. (XN.NE.0.0E0 .OR. YN.GE.0.0E0 .OR. - * M.NE.2)) GO TO 100 - MR = -MM - IF (XN.EQ.0.0E0 .AND. YN.LT.0.0E0) ZN = -ZN - 100 CONTINUE - CALL CBUNK(ZN, FNU, KODE, MR, NN, CY, NW, TOL, ELIM, ALIM) - IF (NW.LT.0) GO TO 230 - 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 = SIGN(HPI,-FMM) -C----------------------------------------------------------------------- -C CALCULATE EXP(FNU*HPI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE -C WHEN FNU IS LARGE -C----------------------------------------------------------------------- - INU = INT(FNU) - INUH = INU/2 - IR = INU - 2*INUH - ARG = (FNU-FLOAT(INU-IR))*SGN - RHPI = 1.0E0/SGN - CPN = RHPI*COS(ARG) - SPN = RHPI*SIN(ARG) -C ZN = CMPLX(-SPN,CPN) - CSGN = CMPLX(-SPN,CPN) -C IF (MOD(INUH,2).EQ.1) ZN = -ZN - IF (MOD(INUH,2).EQ.1) CSGN = -CSGN - ZT = CMPLX(0.0E0,-FMM) - RTOL = 1.0E0/TOL - ASCLE = UFL*RTOL - DO 120 I=1,NN -C CY(I) = CY(I)*ZN -C ZN = ZN*ZT - ZN=CY(I) - AA=REAL(ZN) - BB=AIMAG(ZN) - ATOL=1.0E0 - IF (AMAX1(ABS(AA),ABS(BB)).GT.ASCLE) GO TO 125 - ZN = ZN*CMPLX(RTOL,0.0E0) - ATOL = TOL - 125 CONTINUE - ZN = ZN*CSGN - CY(I) = ZN*CMPLX(ATOL,0.0E0) - CSGN = CSGN*ZT - 120 CONTINUE - RETURN - 130 CONTINUE - IF (XN.LT.0.0E0) GO TO 220 - RETURN - 220 CONTINUE - IERR=2 - NZ=0 - RETURN - 230 CONTINUE - IF(NW.EQ.(-1)) GO TO 220 - NZ=0 - IERR=5 - RETURN - 240 CONTINUE - NZ=0 - IERR=4 - RETURN - END
--- a/liboctave/cruft/amos/cbesi.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,258 +0,0 @@ - SUBROUTINE CBESI(Z, FNU, KODE, N, CY, NZ, IERR) -C***BEGIN PROLOGUE CBESI -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 ON KODE=1, CBESI 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, CBESI 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 -C NOTATION ARE FOUND IN THE NBS HANDBOOK OF MATHEMATICAL -C FUNCTIONS (REF.1) -C -C INPUT -C Z - Z=CMPLX(X,Y), -PI.LT.ARG(Z).LE.PI -C FNU - ORDER OF INITIAL I FUNCTION, FNU.GE.0.0E0 -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 -C CY - A COMPLEX VECTOR WHOSE FIRST N COMPONENTS CONTAIN -C VALUES 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 DUE TO UNDERFLOW, CY(J)=CMPLX(0.0,0.0), -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=R1MACH(4)=UNIT ROUNDOFF. ALSO -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 CBINU,I1MACH,R1MACH -C***END PROLOGUE CBESI - COMPLEX CONE, CSGN, CY, Z, ZN - REAL AA, ALIM, ARG, DIG, ELIM, FNU, FNUL, PI, RL, R1M5, S1, S2, - * TOL, XX, YY, R1MACH, AZ, FN, BB, ASCLE, RTOL, ATOL - INTEGER I, IERR, INU, K, KODE, K1, K2, N, NN, NZ, I1MACH - DIMENSION CY(N) - DATA PI /3.14159265358979324E0/ - DATA CONE / (1.0E0,0.0E0) / -C -C***FIRST EXECUTABLE STATEMENT CBESI - IERR = 0 - NZ=0 - IF (FNU.LT.0.0E0) IERR=1 - IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1 - IF (N.LT.1) IERR=1 - IF (IERR.NE.0) RETURN - XX = REAL(Z) - YY = AIMAG(Z) -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 = AMAX1(R1MACH(4),1.0E-18) - K1 = I1MACH(12) - K2 = I1MACH(13) - R1M5 = R1MACH(5) - K = MIN0(IABS(K1),IABS(K2)) - ELIM = 2.303E0*(FLOAT(K)*R1M5-3.0E0) - K1 = I1MACH(11) - 1 - AA = R1M5*FLOAT(K1) - DIG = AMIN1(AA,18.0E0) - AA = AA*2.303E0 - ALIM = ELIM + AMAX1(-AA,-41.45E0) - RL = 1.2E0*DIG + 3.0E0 - FNUL = 10.0E0 + 6.0E0*(DIG-3.0E0) - AZ = CABS(Z) -C----------------------------------------------------------------------- -C TEST FOR RANGE -C----------------------------------------------------------------------- - AA = 0.5E0/TOL - BB=FLOAT(I1MACH(9))*0.5E0 - AA=AMIN1(AA,BB) - IF(AZ.GT.AA) GO TO 140 - FN=FNU+FLOAT(N-1) - IF(FN.GT.AA) GO TO 140 - AA=SQRT(AA) - IF(AZ.GT.AA) IERR=3 - IF(FN.GT.AA) IERR=3 - ZN = Z - CSGN = CONE - IF (XX.GE.0.0E0) GO TO 40 - ZN = -Z -C----------------------------------------------------------------------- -C CALCULATE CSGN=EXP(FNU*PI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE -C WHEN FNU IS LARGE -C----------------------------------------------------------------------- - INU = INT(FNU) - ARG = (FNU-FLOAT(INU))*PI - IF (YY.LT.0.0E0) ARG = -ARG - S1 = COS(ARG) - S2 = SIN(ARG) - CSGN = CMPLX(S1,S2) - IF (MOD(INU,2).EQ.1) CSGN = -CSGN - 40 CONTINUE - CALL CBINU(ZN, FNU, KODE, N, CY, NZ, RL, FNUL, TOL, ELIM, ALIM) - IF (NZ.LT.0) GO TO 120 - IF (XX.GE.0.0E0) RETURN -C----------------------------------------------------------------------- -C ANALYTIC CONTINUATION TO THE LEFT HALF PLANE -C----------------------------------------------------------------------- - NN = N - NZ - IF (NN.EQ.0) RETURN - RTOL = 1.0E0/TOL - ASCLE = R1MACH(1)*RTOL*1.0E+3 - DO 50 I=1,NN -C CY(I) = CY(I)*CSGN - ZN=CY(I) - AA=REAL(ZN) - BB=AIMAG(ZN) - ATOL=1.0E0 - IF (AMAX1(ABS(AA),ABS(BB)).GT.ASCLE) GO TO 55 - ZN = ZN*CMPLX(RTOL,0.0E0) - ATOL = TOL - 55 CONTINUE - ZN = ZN*CSGN - CY(I) = ZN*CMPLX(ATOL,0.0E0) - CSGN = -CSGN - 50 CONTINUE - RETURN - 120 CONTINUE - IF(NZ.EQ.(-2)) GO TO 130 - NZ = 0 - IERR=2 - RETURN - 130 CONTINUE - NZ=0 - IERR=5 - RETURN - 140 CONTINUE - NZ=0 - IERR=4 - RETURN - END
--- a/liboctave/cruft/amos/cbesj.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,253 +0,0 @@ - SUBROUTINE CBESJ(Z, FNU, KODE, N, CY, NZ, IERR) -C***BEGIN PROLOGUE CBESJ -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 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 -C Z - Z=CMPLX(X,Y), -PI.LT.ARG(Z).LE.PI -C FNU - ORDER OF INITIAL J FUNCTION, FNU.GE.0.0E0 -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,... -C N - NUMBER OF MEMBERS OF THE SEQUENCE, N.GE.1 -C -C OUTPUT -C CY - A COMPLEX VECTOR WHOSE FIRST N COMPONENTS CONTAIN -C VALUES 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 TO ZERO -C DUE TO UNDERFLOW, CY(I)=CMPLX(0.0,0.0), -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=R1MACH(4)=UNIT ROUNDOFF. ALSO -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 CBINU,I1MACH,R1MACH -C***END PROLOGUE CBESJ -C - COMPLEX CI, CSGN, CY, Z, ZN - REAL AA, ALIM, ARG, DIG, ELIM, FNU, FNUL, HPI, RL, R1, R1M5, R2, - * TOL, YY, R1MACH, AZ, FN, BB, ASCLE, RTOL, ATOL - INTEGER I, IERR, INU, INUH, IR, KODE, K1, K2, N, NL, NZ, I1MACH, K - DIMENSION CY(N) - DATA HPI /1.57079632679489662E0/ -C -C***FIRST EXECUTABLE STATEMENT CBESJ - IERR = 0 - NZ=0 - IF (FNU.LT.0.0E0) 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 = AMAX1(R1MACH(4),1.0E-18) - K1 = I1MACH(12) - K2 = I1MACH(13) - R1M5 = R1MACH(5) - K = MIN0(IABS(K1),IABS(K2)) - ELIM = 2.303E0*(FLOAT(K)*R1M5-3.0E0) - K1 = I1MACH(11) - 1 - AA = R1M5*FLOAT(K1) - DIG = AMIN1(AA,18.0E0) - AA = AA*2.303E0 - ALIM = ELIM + AMAX1(-AA,-41.45E0) - RL = 1.2E0*DIG + 3.0E0 - FNUL = 10.0E0 + 6.0E0*(DIG-3.0E0) - CI = CMPLX(0.0E0,1.0E0) - YY = AIMAG(Z) - AZ = CABS(Z) -C----------------------------------------------------------------------- -C TEST FOR RANGE -C----------------------------------------------------------------------- - AA = 0.5E0/TOL - BB=FLOAT(I1MACH(9))*0.5E0 - AA=AMIN1(AA,BB) - FN=FNU+FLOAT(N-1) - IF(AZ.GT.AA) GO TO 140 - IF(FN.GT.AA) GO TO 140 - AA=SQRT(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----------------------------------------------------------------------- - INU = INT(FNU) - INUH = INU/2 - IR = INU - 2*INUH - ARG = (FNU-FLOAT(INU-IR))*HPI - R1 = COS(ARG) - R2 = SIN(ARG) - CSGN = CMPLX(R1,R2) - IF (MOD(INUH,2).EQ.1) CSGN = -CSGN -C----------------------------------------------------------------------- -C ZN IS IN THE RIGHT HALF PLANE -C----------------------------------------------------------------------- - ZN = -Z*CI - IF (YY.GE.0.0E0) GO TO 40 - ZN = -ZN - CSGN = CONJG(CSGN) - CI = CONJG(CI) - 40 CONTINUE - CALL CBINU(ZN, FNU, KODE, N, CY, NZ, RL, FNUL, TOL, ELIM, ALIM) - IF (NZ.LT.0) GO TO 120 - NL = N - NZ - IF (NL.EQ.0) RETURN - RTOL = 1.0E0/TOL - ASCLE = R1MACH(1)*RTOL*1.0E+3 - DO 50 I=1,NL -C CY(I)=CY(I)*CSGN - ZN=CY(I) - AA=REAL(ZN) - BB=AIMAG(ZN) - ATOL=1.0E0 - IF (AMAX1(ABS(AA),ABS(BB)).GT.ASCLE) GO TO 55 - ZN = ZN*CMPLX(RTOL,0.0E0) - ATOL = TOL - 55 CONTINUE - ZN = ZN*CSGN - CY(I) = ZN*CMPLX(ATOL,0.0E0) - CSGN = CSGN*CI - 50 CONTINUE - RETURN - 120 CONTINUE - IF(NZ.EQ.(-2)) GO TO 130 - NZ = 0 - IERR = 2 - RETURN - 130 CONTINUE - NZ=0 - IERR=5 - RETURN - 140 CONTINUE - NZ=0 - IERR=4 - RETURN - END
--- a/liboctave/cruft/amos/cbesk.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,276 +0,0 @@ - SUBROUTINE CBESK(Z, FNU, KODE, N, CY, NZ, IERR) -C***BEGIN PROLOGUE CBESK -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 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 -C Z - Z=CMPLX(X,Y),Z.NE.CMPLX(0.,0.),-PI.LT.ARG(Z).LE.PI -C FNU - ORDER OF INITIAL K FUNCTION, FNU.GE.0.0E0 -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 -C CY - A COMPLEX VECTOR WHOSE FIRST N COMPONENTS CONTAIN -C VALUES 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 -C DUE TO UNDERFLOW, CY(I)=CMPLX(0.0,0.0), -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 IERR - ERROR FLAG -C IERR=0, NORMAL RETURN - COMPUTATION COMPLETED -C IERR=1, INPUT ERROR - NO COMPUTATION -C IERR=2, OVERFLOW - NO COMPUTATION, FNU+N-1 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=R1MACH(4)=UNIT ROUNDOFF. ALSO -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 CACON,CBKNU,CBUNK,CUOIK,I1MACH,R1MACH -C***END PROLOGUE CBESK -C - COMPLEX CY, Z - REAL AA, ALIM, ALN, ARG, AZ, DIG, ELIM, FN, FNU, FNUL, RL, R1M5, - * TOL, UFL, XX, YY, R1MACH, BB - INTEGER IERR, K, KODE, K1, K2, MR, N, NN, NUF, NW, NZ, I1MACH - DIMENSION CY(N) -C***FIRST EXECUTABLE STATEMENT CBESK - IERR = 0 - NZ=0 - XX = REAL(Z) - YY = AIMAG(Z) - IF (YY.EQ.0.0E0 .AND. XX.EQ.0.0E0) IERR=1 - IF (FNU.LT.0.0E0) 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 = AMAX1(R1MACH(4),1.0E-18) - K1 = I1MACH(12) - K2 = I1MACH(13) - R1M5 = R1MACH(5) - K = MIN0(IABS(K1),IABS(K2)) - ELIM = 2.303E0*(FLOAT(K)*R1M5-3.0E0) - K1 = I1MACH(11) - 1 - AA = R1M5*FLOAT(K1) - DIG = AMIN1(AA,18.0E0) - AA = AA*2.303E0 - ALIM = ELIM + AMAX1(-AA,-41.45E0) - FNUL = 10.0E0 + 6.0E0*(DIG-3.0E0) - RL = 1.2E0*DIG + 3.0E0 - AZ = CABS(Z) - FN = FNU + FLOAT(NN-1) -C----------------------------------------------------------------------- -C TEST FOR RANGE -C----------------------------------------------------------------------- - AA = 0.5E0/TOL - BB=FLOAT(I1MACH(9))*0.5E0 - AA=AMIN1(AA,BB) - IF(AZ.GT.AA) GO TO 210 - IF(FN.GT.AA) GO TO 210 - AA=SQRT(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 = EXP(-ELIM) - UFL = R1MACH(1)*1.0E+3 - IF (AZ.LT.UFL) GO TO 180 - IF (FNU.GT.FNUL) GO TO 80 - IF (FN.LE.1.0E0) GO TO 60 - IF (FN.GT.2.0E0) GO TO 50 - IF (AZ.GT.TOL) GO TO 60 - ARG = 0.5E0*AZ - ALN = -FN*ALOG(ARG) - IF (ALN.GT.ELIM) GO TO 180 - GO TO 60 - 50 CONTINUE - CALL CUOIK(Z, FNU, KODE, 2, NN, CY, 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 (XX.LT.0.0E0) GO TO 70 -C----------------------------------------------------------------------- -C RIGHT HALF PLANE COMPUTATION, REAL(Z).GE.0. -C----------------------------------------------------------------------- - CALL CBKNU(Z, FNU, KODE, NN, CY, 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 (YY.LT.0.0E0) MR = -1 - CALL CACON(Z, FNU, KODE, MR, NN, CY, 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 (XX.GE.0.0E0) GO TO 90 - MR = 1 - IF (YY.LT.0.0E0) MR = -1 - 90 CONTINUE - CALL CBUNK(Z, FNU, KODE, MR, NN, CY, NW, TOL, ELIM, ALIM) - IF (NW.LT.0) GO TO 200 - NZ = NZ + NW - RETURN - 100 CONTINUE - IF (XX.LT.0.0E0) 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 - 210 CONTINUE - NZ=0 - IERR=4 - RETURN - END
--- a/liboctave/cruft/amos/cbesy.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,226 +0,0 @@ - SUBROUTINE CBESY(Z, FNU, KODE, N, CY, NZ, CWRK, IERR) -C***BEGIN PROLOGUE CBESY -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 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 -C Z - Z=CMPLX(X,Y), Z.NE.CMPLX(0.,0.),-PI.LT.ARG(Z).LE.PI -C FNU - ORDER OF INITIAL Y FUNCTION, FNU.GE.0.0E0 -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 CWRK - A COMPLEX WORK VECTOR OF DIMENSION AT LEAST N -C -C OUTPUT -C CY - A COMPLEX VECTOR WHOSE FIRST N COMPONENTS CONTAIN -C VALUES 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+N-1 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=R1MACH(4)=UNIT ROUNDOFF. ALSO -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 CBESH,I1MACH,R1MACH -C***END PROLOGUE CBESY -C - COMPLEX CWRK, CY, C1, C2, EX, HCI, Z, ZU, ZV - REAL ELIM, EY, FNU, R1, R2, TAY, XX, YY, R1MACH, ASCLE, RTOL, - * ATOL, AA, BB - INTEGER I, IERR, K, KODE, K1, K2, N, NZ, NZ1, NZ2, I1MACH - DIMENSION CY(N), CWRK(N) -C***FIRST EXECUTABLE STATEMENT CBESY - XX = REAL(Z) - YY = AIMAG(Z) - IERR = 0 - NZ=0 - IF (XX.EQ.0.0E0 .AND. YY.EQ.0.0E0) IERR=1 - IF (FNU.LT.0.0E0) IERR=1 - IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1 - IF (N.LT.1) IERR=1 - IF (IERR.NE.0) RETURN - HCI = CMPLX(0.0E0,0.5E0) - CALL CBESH(Z, FNU, KODE, 1, N, CY, NZ1, IERR) - IF (IERR.NE.0.AND.IERR.NE.3) GO TO 170 - CALL CBESH(Z, FNU, KODE, 2, N, CWRK, 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 - CY(I) = HCI*(CWRK(I)-CY(I)) - 50 CONTINUE - RETURN - 60 CONTINUE - TOL = AMAX1(R1MACH(4),1.0E-18) - K1 = I1MACH(12) - K2 = I1MACH(13) - K = MIN0(IABS(K1),IABS(K2)) - R1M5 = R1MACH(5) -C----------------------------------------------------------------------- -C ELIM IS THE APPROXIMATE EXPONENTIAL UNDER- AND OVERFLOW LIMIT -C----------------------------------------------------------------------- - ELIM = 2.303E0*(FLOAT(K)*R1M5-3.0E0) - R1 = COS(XX) - R2 = SIN(XX) - EX = CMPLX(R1,R2) - EY = 0.0E0 - TAY = ABS(YY+YY) - IF (TAY.LT.ELIM) EY = EXP(-TAY) - IF (YY.LT.0.0E0) GO TO 90 - C1 = EX*CMPLX(EY,0.0E0) - C2 = CONJG(EX) - 70 CONTINUE - NZ = 0 - RTOL = 1.0E0/TOL - ASCLE = R1MACH(1)*RTOL*1.0E+3 - DO 80 I=1,N -C CY(I) = HCI*(C2*CWRK(I)-C1*CY(I)) - ZV = CWRK(I) - AA=REAL(ZV) - BB=AIMAG(ZV) - ATOL=1.0E0 - IF (AMAX1(ABS(AA),ABS(BB)).GT.ASCLE) GO TO 75 - ZV = ZV*CMPLX(RTOL,0.0E0) - ATOL = TOL - 75 CONTINUE - ZV = ZV*C2*HCI - ZV = ZV*CMPLX(ATOL,0.0E0) - ZU=CY(I) - AA=REAL(ZU) - BB=AIMAG(ZU) - ATOL=1.0E0 - IF (AMAX1(ABS(AA),ABS(BB)).GT.ASCLE) GO TO 85 - ZU = ZU*CMPLX(RTOL,0.0E0) - ATOL = TOL - 85 CONTINUE - ZU = ZU*C1*HCI - ZU = ZU*CMPLX(ATOL,0.0E0) - CY(I) = ZV - ZU - IF (CY(I).EQ.CMPLX(0.0E0,0.0E0) .AND. EY.EQ.0.0E0) NZ = NZ + 1 - 80 CONTINUE - RETURN - 90 CONTINUE - C1 = EX - C2 = CONJG(EX)*CMPLX(EY,0.0E0) - GO TO 70 - 170 CONTINUE - NZ = 0 - RETURN - END
--- a/liboctave/cruft/amos/cbinu.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,105 +0,0 @@ - SUBROUTINE CBINU(Z, FNU, KODE, N, CY, NZ, RL, FNUL, TOL, ELIM, - * ALIM) -C***BEGIN PROLOGUE CBINU -C***REFER TO CBESH,CBESI,CBESJ,CBESK,CAIRY,CBIRY -C -C CBINU COMPUTES THE I FUNCTION IN THE RIGHT HALF Z PLANE -C -C***ROUTINES CALLED CASYI,CBUNI,CMLRI,CSERI,CUOIK,CWRSK -C***END PROLOGUE CBINU - COMPLEX CW, CY, CZERO, Z - REAL ALIM, AZ, DFNU, ELIM, FNU, FNUL, RL, TOL - INTEGER I, INW, KODE, N, NLAST, NN, NUI, NW, NZ - DIMENSION CY(N), CW(2) - DATA CZERO / (0.0E0,0.0E0) / -C - NZ = 0 - AZ = CABS(Z) - NN = N - DFNU = FNU + FLOAT(N-1) - IF (AZ.LE.2.0E0) GO TO 10 - IF (AZ*AZ*0.25E0.GT.DFNU+1.0E0) GO TO 20 - 10 CONTINUE -C----------------------------------------------------------------------- -C POWER SERIES -C----------------------------------------------------------------------- - CALL CSERI(Z, FNU, KODE, NN, CY, 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 + FLOAT(NN-1) - 20 CONTINUE - IF (AZ.LT.RL) GO TO 40 - IF (DFNU.LE.1.0E0) GO TO 30 - IF (AZ+AZ.LT.DFNU*DFNU) GO TO 50 -C----------------------------------------------------------------------- -C ASYMPTOTIC EXPANSION FOR LARGE Z -C----------------------------------------------------------------------- - 30 CONTINUE - CALL CASYI(Z, FNU, KODE, NN, CY, NW, RL, TOL, ELIM, ALIM) - IF (NW.LT.0) GO TO 130 - GO TO 120 - 40 CONTINUE - IF (DFNU.LE.1.0E0) GO TO 70 - 50 CONTINUE -C----------------------------------------------------------------------- -C OVERFLOW AND UNDERFLOW TEST ON I SEQUENCE FOR MILLER ALGORITHM -C----------------------------------------------------------------------- - CALL CUOIK(Z, FNU, KODE, 1, NN, CY, NW, TOL, ELIM, ALIM) - IF (NW.LT.0) GO TO 130 - NZ = NZ + NW - NN = NN - NW - IF (NN.EQ.0) RETURN - DFNU = FNU+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 CMLRI(Z, FNU, KODE, NN, CY, 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 CUOIK(Z, FNU, KODE, 2, 2, CW, NW, TOL, ELIM, ALIM) - IF (NW.GE.0) GO TO 100 - NZ = NN - DO 90 I=1,NN - CY(I) = CZERO - 90 CONTINUE - RETURN - 100 CONTINUE - IF (NW.GT.0) GO TO 130 - CALL CWRSK(Z, FNU, KODE, NN, CY, NW, CW, 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(FNUL-DFNU) + 1 - NUI = MAX0(NUI,0) - CALL CBUNI(Z, FNU, KODE, NN, CY, 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
--- a/liboctave/cruft/amos/cbiry.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,309 +0,0 @@ - SUBROUTINE CBIRY(Z, ID, KODE, BI, IERR) -C***BEGIN PROLOGUE CBIRY -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 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 DEFINITIONS AND NOTATION ARE FOUND IN THE NBS HANDBOOK OF -C MATHEMATICAL FUNCTIONS (REF. 1). -C -C INPUT -C Z - Z=CMPLX(X,Y) -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 -C BI - 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 WITH 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=R1MACH(4)=UNIT ROUNDOFF. -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. -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 CBINU,I1MACH,R1MACH -C***END PROLOGUE CBIRY - COMPLEX BI, CONE, CSQ, CY, S1, S2, TRM1, TRM2, Z, ZTA, Z3 - REAL AA, AD, AK, ALIM, ATRM, AZ, AZ3, BB, BK, CK, COEF, C1, C2, - * DIG, DK, D1, D2, ELIM, FID, FMR, FNU, FNUL, PI, RL, R1M5, SFAC, - * TOL, TTH, ZI, ZR, Z3I, Z3R, R1MACH - INTEGER ID, IERR, K, KODE, K1, K2, NZ, I1MACH - DIMENSION CY(2) - DATA TTH, C1, C2, COEF, PI /6.66666666666666667E-01, - * 6.14926627446000736E-01,4.48288357353826359E-01, - * 5.77350269189625765E-01,3.14159265358979324E+00/ - DATA CONE / (1.0E0,0.0E0) / -C***FIRST EXECUTABLE STATEMENT CBIRY - 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 = CABS(Z) - TOL = AMAX1(R1MACH(4),1.0E-18) - FID = FLOAT(ID) - IF (AZ.GT.1.0E0) GO TO 60 -C----------------------------------------------------------------------- -C POWER SERIES FOR CABS(Z).LE.1. -C----------------------------------------------------------------------- - S1 = CONE - S2 = CONE - IF (AZ.LT.TOL) GO TO 110 - AA = AZ*AZ - IF (AA.LT.TOL/AZ) GO TO 40 - TRM1 = CONE - TRM2 = CONE - ATRM = 1.0E0 - Z3 = Z*Z*Z - AZ3 = AZ*AA - AK = 2.0E0 + FID - BK = 3.0E0 - FID - FID - CK = 4.0E0 - FID - DK = 3.0E0 + FID + FID - D1 = AK*DK - D2 = BK*CK - AD = AMIN1(D1,D2) - AK = 24.0E0 + 9.0E0*FID - BK = 30.0E0 - 9.0E0*FID - Z3R = REAL(Z3) - Z3I = AIMAG(Z3) - DO 30 K=1,25 - TRM1 = TRM1*CMPLX(Z3R/D1,Z3I/D1) - S1 = S1 + TRM1 - TRM2 = TRM2*CMPLX(Z3R/D2,Z3I/D2) - S2 = S2 + TRM2 - ATRM = ATRM*AZ3/AD - D1 = D1 + AK - D2 = D2 + BK - AD = AMIN1(D1,D2) - IF (ATRM.LT.TOL*AD) GO TO 40 - AK = AK + 18.0E0 - BK = BK + 18.0E0 - 30 CONTINUE - 40 CONTINUE - IF (ID.EQ.1) GO TO 50 - BI = S1*CMPLX(C1,0.0E0) + Z*S2*CMPLX(C2,0.0E0) - IF (KODE.EQ.1) RETURN - ZTA = Z*CSQRT(Z)*CMPLX(TTH,0.0E0) - AA = REAL(ZTA) - AA = -ABS(AA) - BI = BI*CMPLX(EXP(AA),0.0E0) - RETURN - 50 CONTINUE - BI = S2*CMPLX(C2,0.0E0) - IF (AZ.GT.TOL) BI = BI + Z*Z*S1*CMPLX(C1/(1.0E0+FID),0.0E0) - IF (KODE.EQ.1) RETURN - ZTA = Z*CSQRT(Z)*CMPLX(TTH,0.0E0) - AA = REAL(ZTA) - AA = -ABS(AA) - BI = BI*CMPLX(EXP(AA),0.0E0) - RETURN -C----------------------------------------------------------------------- -C CASE FOR CABS(Z).GT.1.0 -C----------------------------------------------------------------------- - 60 CONTINUE - FNU = (1.0E0+FID)/3.0E0 -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(12) - K2 = I1MACH(13) - R1M5 = R1MACH(5) - K = MIN0(IABS(K1),IABS(K2)) - ELIM = 2.303E0*(FLOAT(K)*R1M5-3.0E0) - K1 = I1MACH(11) - 1 - AA = R1M5*FLOAT(K1) - DIG = AMIN1(AA,18.0E0) - AA = AA*2.303E0 - ALIM = ELIM + AMAX1(-AA,-41.45E0) - RL = 1.2E0*DIG + 3.0E0 - FNUL = 10.0E0 + 6.0E0*(DIG-3.0E0) -C----------------------------------------------------------------------- -C TEST FOR RANGE -C----------------------------------------------------------------------- - AA=0.5E0/TOL - BB=FLOAT(I1MACH(9))*0.5E0 - AA=AMIN1(AA,BB) - AA=AA**TTH - IF (AZ.GT.AA) GO TO 190 - AA=SQRT(AA) - IF (AZ.GT.AA) IERR=3 - CSQ=CSQRT(Z) - ZTA=Z*CSQ*CMPLX(TTH,0.0E0) -C----------------------------------------------------------------------- -C RE(ZTA).LE.0 WHEN RE(Z).LT.0, ESPECIALLY WHEN IM(Z) IS SMALL -C----------------------------------------------------------------------- - SFAC = 1.0E0 - ZI = AIMAG(Z) - ZR = REAL(Z) - AK = AIMAG(ZTA) - IF (ZR.GE.0.0E0) GO TO 70 - BK = REAL(ZTA) - CK = -ABS(BK) - ZTA = CMPLX(CK,AK) - 70 CONTINUE - IF (ZI.EQ.0.0E0 .AND. ZR.LE.0.0E0) ZTA = CMPLX(0.0E0,AK) - AA = REAL(ZTA) - IF (KODE.EQ.2) GO TO 80 -C----------------------------------------------------------------------- -C OVERFLOW TEST -C----------------------------------------------------------------------- - BB = ABS(AA) - IF (BB.LT.ALIM) GO TO 80 - BB = BB + 0.25E0*ALOG(AZ) - SFAC = TOL - IF (BB.GT.ELIM) GO TO 170 - 80 CONTINUE - FMR = 0.0E0 - IF (AA.GE.0.0E0 .AND. ZR.GT.0.0E0) GO TO 90 - FMR = PI - IF (ZI.LT.0.0E0) FMR = -PI - ZTA = -ZTA - 90 CONTINUE -C----------------------------------------------------------------------- -C AA=FACTOR FOR ANALYTIC CONTINUATION OF I(FNU,ZTA) -C KODE=2 RETURNS EXP(-ABS(XZTA))*I(FNU,ZTA) FROM CBINU -C----------------------------------------------------------------------- - CALL CBINU(ZTA, FNU, KODE, 1, CY, NZ, RL, FNUL, TOL, ELIM, ALIM) - IF (NZ.LT.0) GO TO 180 - AA = FMR*FNU - Z3 = CMPLX(SFAC,0.0E0) - S1 = CY(1)*CMPLX(COS(AA),SIN(AA))*Z3 - FNU = (2.0E0-FID)/3.0E0 - CALL CBINU(ZTA, FNU, KODE, 2, CY, NZ, RL, FNUL, TOL, ELIM, ALIM) - CY(1) = CY(1)*Z3 - CY(2) = CY(2)*Z3 -C----------------------------------------------------------------------- -C BACKWARD RECUR ONE STEP FOR ORDERS -1/3 OR -2/3 -C----------------------------------------------------------------------- - S2 = CY(1)*CMPLX(FNU+FNU,0.0E0)/ZTA + CY(2) - AA = FMR*(FNU-1.0E0) - S1 = (S1+S2*CMPLX(COS(AA),SIN(AA)))*CMPLX(COEF,0.0E0) - IF (ID.EQ.1) GO TO 100 - S1 = CSQ*S1 - BI = S1*CMPLX(1.0E0/SFAC,0.0E0) - RETURN - 100 CONTINUE - S1 = Z*S1 - BI = S1*CMPLX(1.0E0/SFAC,0.0E0) - RETURN - 110 CONTINUE - AA = C1*(1.0E0-FID) + FID*C2 - BI = CMPLX(AA,0.0E0) - RETURN - 170 CONTINUE - NZ=0 - IERR=2 - RETURN - 180 CONTINUE - IF(NZ.EQ.(-1)) GO TO 170 - NZ=0 - IERR=5 - RETURN - 190 CONTINUE - IERR=4 - NZ=0 - RETURN - END
--- a/liboctave/cruft/amos/cbknu.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,455 +0,0 @@ - SUBROUTINE CBKNU(Z, FNU, KODE, N, Y, NZ, TOL, ELIM, ALIM) -C***BEGIN PROLOGUE CBKNU -C***REFER TO CBESI,CBESK,CAIRY,CBESH -C -C CBKNU COMPUTES THE K BESSEL FUNCTION IN THE RIGHT HALF Z PLANE -C -C***ROUTINES CALLED CKSCL,CSHCH,GAMLN,I1MACH,R1MACH,CUCHK -C***END PROLOGUE CBKNU -C - COMPLEX CCH, CK, COEF, CONE, CRSC, CS, CSCL, CSH, CSR, CSS, CTWO, - * CZ, CZERO, F, FMU, P, PT, P1, P2, Q, RZ, SMU, ST, S1, S2, Y, Z, - * ZD, CELM, CY - REAL AA, AK, ALIM, ASCLE, A1, A2, BB, BK, BRY, CAZ, CC, DNU, - * DNU2, ELIM, ETEST, FC, FHS, FK, FKS, FNU, FPI, G1, G2, HPI, PI, - * P2I, P2M, P2R, RK, RTHPI, R1, S, SPI, TM, TOL, TTH, T1, T2, XX, - * YY, GAMLN, R1MACH, HELIM, ELM, XD, YD, ALAS, AS - INTEGER I, IDUM, IFLAG, INU, K, KFLAG, KK, KMAX, KODE, KODED, N, - * NZ, I1MACH, NW, J, IC, INUB - DIMENSION BRY(3), CC(8), CSS(3), CSR(3), Y(N), CY(2) -C - DATA KMAX / 30 / - DATA R1 / 2.0E0 / - DATA CZERO,CONE,CTWO /(0.0E0,0.0E0),(1.0E0,0.0E0),(2.0E0,0.0E0)/ -C - DATA PI, RTHPI, SPI ,HPI, FPI, TTH / - 1 3.14159265358979324E0, 1.25331413731550025E0, - 2 1.90985931710274403E0, 1.57079632679489662E0, - 3 1.89769999331517738E0, 6.66666666666666666E-01/ -C - DATA CC(1), CC(2), CC(3), CC(4), CC(5), CC(6), CC(7), CC(8)/ - 1 5.77215664901532861E-01, -4.20026350340952355E-02, - 2 -4.21977345555443367E-02, 7.21894324666309954E-03, - 3 -2.15241674114950973E-04, -2.01348547807882387E-05, - 4 1.13302723198169588E-06, 6.11609510448141582E-09/ -C - XX = REAL(Z) - YY = AIMAG(Z) - CAZ = CABS(Z) - CSCL = CMPLX(1.0E0/TOL,0.0E0) - CRSC = CMPLX(TOL,0.0E0) - CSS(1) = CSCL - CSS(2) = CONE - CSS(3) = CRSC - CSR(1) = CRSC - CSR(2) = CONE - CSR(3) = CSCL - BRY(1) = 1.0E+3*R1MACH(1)/TOL - BRY(2) = 1.0E0/BRY(1) - BRY(3) = R1MACH(2) - NZ = 0 - IFLAG = 0 - KODED = KODE - RZ = CTWO/Z - INU = INT(FNU+0.5E0) - DNU = FNU - FLOAT(INU) - IF (ABS(DNU).EQ.0.5E0) GO TO 110 - DNU2 = 0.0E0 - IF (ABS(DNU).GT.TOL) DNU2 = DNU*DNU - IF (CAZ.GT.R1) GO TO 110 -C----------------------------------------------------------------------- -C SERIES FOR CABS(Z).LE.R1 -C----------------------------------------------------------------------- - FC = 1.0E0 - SMU = CLOG(RZ) - FMU = SMU*CMPLX(DNU,0.0E0) - CALL CSHCH(FMU, CSH, CCH) - IF (DNU.EQ.0.0E0) GO TO 10 - FC = DNU*PI - FC = FC/SIN(FC) - SMU = CSH*CMPLX(1.0E0/DNU,0.0E0) - 10 CONTINUE - A2 = 1.0E0 + 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 = EXP(-GAMLN(A2,IDUM)) - T1 = 1.0E0/(T2*FC) - IF (ABS(DNU).GT.0.1E0) GO TO 40 -C----------------------------------------------------------------------- -C SERIES FOR F0 TO RESOLVE INDETERMINACY FOR SMALL ABS(DNU) -C----------------------------------------------------------------------- - AK = 1.0E0 - S = CC(1) - DO 20 K=2,8 - AK = AK*DNU2 - TM = CC(K)*AK - S = S + TM - IF (ABS(TM).LT.TOL) GO TO 30 - 20 CONTINUE - 30 G1 = -S - GO TO 50 - 40 CONTINUE - G1 = (T1-T2)/(DNU+DNU) - 50 CONTINUE - G2 = 0.5E0*(T1+T2)*FC - G1 = G1*FC - F = CMPLX(G1,0.0E0)*CCH + SMU*CMPLX(G2,0.0E0) - PT = CEXP(FMU) - P = CMPLX(0.5E0/T2,0.0E0)*PT - Q = CMPLX(0.5E0/T1,0.0E0)/PT - S1 = F - S2 = P - AK = 1.0E0 - A1 = 1.0E0 - CK = CONE - BK = 1.0E0 - 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 - CZ = Z*Z*CMPLX(0.25E0,0.0E0) - T1 = 0.25E0*CAZ*CAZ - 60 CONTINUE - F = (F*CMPLX(AK,0.0E0)+P+Q)*CMPLX(1.0E0/BK,0.0E0) - P = P*CMPLX(1.0E0/(AK-DNU),0.0E0) - Q = Q*CMPLX(1.0E0/(AK+DNU),0.0E0) - RK = 1.0E0/AK - CK = CK*CZ*CMPLX(RK,0.0) - S1 = S1 + CK*F - A1 = A1*T1*RK - BK = BK + AK + AK + 1.0E0 - AK = AK + 1.0E0 - IF (A1.GT.TOL) GO TO 60 - 70 CONTINUE - Y(1) = S1 - IF (KODED.EQ.1) RETURN - Y(1) = S1*CEXP(Z) - 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 - CZ = Z*Z*CMPLX(0.25E0,0.0E0) - T1 = 0.25E0*CAZ*CAZ - 90 CONTINUE - F = (F*CMPLX(AK,0.0E0)+P+Q)*CMPLX(1.0E0/BK,0.0E0) - P = P*CMPLX(1.0E0/(AK-DNU),0.0E0) - Q = Q*CMPLX(1.0E0/(AK+DNU),0.0E0) - RK = 1.0E0/AK - CK = CK*CZ*CMPLX(RK,0.0E0) - S1 = S1 + CK*F - S2 = S2 + CK*(P-F*CMPLX(AK,0.0E0)) - A1 = A1*T1*RK - BK = BK + AK + AK + 1.0E0 - AK = AK + 1.0E0 - IF (A1.GT.TOL) GO TO 90 - 100 CONTINUE - KFLAG = 2 - BK = REAL(SMU) - A1 = FNU + 1.0E0 - AK = A1*ABS(BK) - IF (AK.GT.ALIM) KFLAG = 3 - P2 = S2*CSS(KFLAG) - S2 = P2*RZ - S1 = S1*CSS(KFLAG) - IF (KODED.EQ.1) GO TO 210 - F = CEXP(Z) - S1 = S1*F - S2 = S2*F - 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 - COEF = CMPLX(RTHPI,0.0E0)/CSQRT(Z) - KFLAG = 2 - IF (KODED.EQ.2) GO TO 120 - IF (XX.GT.ALIM) GO TO 290 -C BLANK LINE - A1 = EXP(-XX)*REAL(CSS(KFLAG)) - PT = CMPLX(A1,0.0E0)*CMPLX(COS(YY),-SIN(YY)) - COEF = COEF*PT - 120 CONTINUE - IF (ABS(DNU).EQ.0.5E0) GO TO 300 -C----------------------------------------------------------------------- -C MILLER ALGORITHM FOR CABS(Z).GT.R1 -C----------------------------------------------------------------------- - AK = COS(PI*DNU) - AK = ABS(AK) - IF (AK.EQ.0.0E0) GO TO 300 - FHS = ABS(0.25E0-DNU2) - IF (FHS.EQ.0.0E0) 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(11))= -C TOL WHERE B IS THE BASE OF THE ARITHMETIC. -C----------------------------------------------------------------------- - T1 = FLOAT(I1MACH(11)-1)*R1MACH(5)*3.321928094E0 - T1 = AMAX1(T1,12.0E0) - T1 = AMIN1(T1,60.0E0) - T2 = TTH*T1 - 6.0E0 - IF (XX.NE.0.0E0) GO TO 130 - T1 = HPI - GO TO 140 - 130 CONTINUE - T1 = ATAN(YY/XX) - T1 = ABS(T1) - 140 CONTINUE - IF (T2.GT.CAZ) GO TO 170 -C----------------------------------------------------------------------- -C FORWARD RECURRENCE LOOP WHEN CABS(Z).GE.R2 -C----------------------------------------------------------------------- - ETEST = AK/(PI*CAZ*TOL) - FK = 1.0E0 - IF (ETEST.LT.1.0E0) GO TO 180 - FKS = 2.0E0 - RK = CAZ + CAZ + 2.0E0 - A1 = 0.0E0 - A2 = 1.0E0 - DO 150 I=1,KMAX - AK = FHS/FKS - BK = RK/(FK+1.0E0) - TM = A2 - A2 = BK*A2 - AK*A1 - A1 = TM - RK = RK + 2.0E0 - FKS = FKS + FK + FK + 2.0E0 - FHS = FHS + FK + FK - FK = FK + 1.0E0 - TM = ABS(A2)*FK - IF (ETEST.LT.TM) GO TO 160 - 150 CONTINUE - GO TO 310 - 160 CONTINUE - FK = FK + SPI*T1*SQRT(T2/CAZ) - FHS = ABS(0.25E0-DNU2) - GO TO 180 - 170 CONTINUE -C----------------------------------------------------------------------- -C COMPUTE BACKWARD INDEX K FOR CABS(Z).LT.R2 -C----------------------------------------------------------------------- - A2 = SQRT(CAZ) - AK = FPI*AK/(TOL*SQRT(A2)) - AA = 3.0E0*T1/(1.0E0+CAZ) - BB = 14.7E0*T1/(28.0E0+CAZ) - AK = (ALOG(AK)+CAZ*COS(AA)/(1.0E0+0.008E0*CAZ))/COS(BB) - FK = 0.12125E0*AK*AK/CAZ + 1.5E0 - 180 CONTINUE - K = INT(FK) -C----------------------------------------------------------------------- -C BACKWARD RECURRENCE LOOP FOR MILLER ALGORITHM -C----------------------------------------------------------------------- - FK = FLOAT(K) - FKS = FK*FK - P1 = CZERO - P2 = CMPLX(TOL,0.0E0) - CS = P2 - DO 190 I=1,K - A1 = FKS - FK - A2 = (FKS+FK)/(A1+FHS) - RK = 2.0E0/(FK+1.0E0) - T1 = (FK+XX)*RK - T2 = YY*RK - PT = P2 - P2 = (P2*CMPLX(T1,T2)-P1)*CMPLX(A2,0.0E0) - P1 = PT - CS = CS + P2 - FKS = A1 - FK + 1.0E0 - FK = FK - 1.0E0 - 190 CONTINUE -C----------------------------------------------------------------------- -C COMPUTE (P2/CS)=(P2/CABS(CS))*(CONJG(CS)/CABS(CS)) FOR BETTER -C SCALING -C----------------------------------------------------------------------- - TM = CABS(CS) - PT = CMPLX(1.0E0/TM,0.0E0) - S1 = PT*P2 - CS = CONJG(CS)*PT - S1 = COEF*S1*CS - IF (INU.GT.0 .OR. N.GT.1) GO TO 200 - ZD = Z - 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 = CABS(P2) - PT = CMPLX(1.0E0/TM,0.0E0) - P1 = PT*P1 - P2 = CONJG(P2)*PT - PT = P1*P2 - S2 = S1*(CONE+(CMPLX(DNU+0.5E0,0.0E0)-PT)/Z) -C----------------------------------------------------------------------- -C FORWARD RECURSION ON THE THREE TERM RECURSION RELATION WITH -C SCALING NEAR EXPONENT EXTREMES ON KFLAG=1 OR KFLAG=3 -C----------------------------------------------------------------------- - 210 CONTINUE - CK = CMPLX(DNU+1.0E0,0.0E0)*RZ - IF (N.EQ.1) INU = INU - 1 - IF (INU.GT.0) GO TO 220 - IF (N.EQ.1) S1=S2 - ZD = Z - IF(IFLAG.EQ.1) GO TO 270 - GO TO 240 - 220 CONTINUE - INUB = 1 - IF (IFLAG.EQ.1) GO TO 261 - 225 CONTINUE - P1 = CSR(KFLAG) - ASCLE = BRY(KFLAG) - DO 230 I=INUB,INU - ST = S2 - S2 = CK*S2 + S1 - S1 = ST - CK = CK + RZ - IF (KFLAG.GE.3) GO TO 230 - P2 = S2*P1 - P2R = REAL(P2) - P2I = AIMAG(P2) - P2R = ABS(P2R) - P2I = ABS(P2I) - P2M = AMAX1(P2R,P2I) - IF (P2M.LE.ASCLE) GO TO 230 - KFLAG = KFLAG + 1 - ASCLE = BRY(KFLAG) - S1 = S1*P1 - S2 = P2 - S1 = S1*CSS(KFLAG) - S2 = S2*CSS(KFLAG) - P1 = CSR(KFLAG) - 230 CONTINUE - IF (N.EQ.1) S1 = S2 - 240 CONTINUE - Y(1) = S1*CSR(KFLAG) - IF (N.EQ.1) RETURN - Y(2) = S2*CSR(KFLAG) - IF (N.EQ.2) RETURN - KK = 2 - 250 CONTINUE - KK = KK + 1 - IF (KK.GT.N) RETURN - P1 = CSR(KFLAG) - ASCLE = BRY(KFLAG) - DO 260 I=KK,N - P2 = S2 - S2 = CK*S2 + S1 - S1 = P2 - CK = CK + RZ - P2 = S2*P1 - Y(I) = P2 - IF (KFLAG.GE.3) GO TO 260 - P2R = REAL(P2) - P2I = AIMAG(P2) - P2R = ABS(P2R) - P2I = ABS(P2I) - P2M = AMAX1(P2R,P2I) - IF (P2M.LE.ASCLE) GO TO 260 - KFLAG = KFLAG + 1 - ASCLE = BRY(KFLAG) - S1 = S1*P1 - S2 = P2 - S1 = S1*CSS(KFLAG) - S2 = S2*CSS(KFLAG) - P1 = CSR(KFLAG) - 260 CONTINUE - RETURN -C----------------------------------------------------------------------- -C IFLAG=1 CASES, FORWARD RECURRENCE ON SCALED VALUES ON UNDERFLOW -C----------------------------------------------------------------------- - 261 CONTINUE - HELIM = 0.5E0*ELIM - ELM = EXP(-ELIM) - CELM = CMPLX(ELM,0.0) - ASCLE = BRY(1) - ZD = Z - XD = XX - YD = YY - IC = -1 - J = 2 - DO 262 I=1,INU - ST = S2 - S2 = CK*S2+S1 - S1 = ST - CK = CK+RZ - AS = CABS(S2) - ALAS = ALOG(AS) - P2R = -XD+ALAS - IF(P2R.LT.(-ELIM)) GO TO 263 - P2 = -ZD+CLOG(S2) - P2R = REAL(P2) - P2I = AIMAG(P2) - P2M = EXP(P2R)/TOL - P1 = CMPLX(P2M,0.0E0)*CMPLX(COS(P2I),SIN(P2I)) - CALL CUCHK(P1,NW,ASCLE,TOL) - IF(NW.NE.0) GO TO 263 - J=3-J - CY(J) = P1 - IF(IC.EQ.(I-1)) GO TO 264 - IC = I - GO TO 262 - 263 CONTINUE - IF(ALAS.LT.HELIM) GO TO 262 - XD = XD-ELIM - S1 = S1*CELM - S2 = S2*CELM - ZD = CMPLX(XD,YD) - 262 CONTINUE - IF(N.EQ.1) S1 = S2 - GO TO 270 - 264 CONTINUE - KFLAG = 1 - INUB = I+1 - S2 = CY(J) - J = 3 - J - S1 = CY(J) - IF(INUB.LE.INU) GO TO 225 - IF(N.EQ.1) S1 = S2 - GO TO 240 - 270 CONTINUE - Y(1) = S1 - IF (N.EQ.1) GO TO 280 - Y(2) = S2 - 280 CONTINUE - ASCLE = BRY(1) - CALL CKSCL(ZD, FNU, N, Y, NZ, RZ, ASCLE, TOL, ELIM) - INU = N - NZ - IF (INU.LE.0) RETURN - KK = NZ + 1 - S1 = Y(KK) - Y(KK) = S1*CSR(1) - IF (INU.EQ.1) RETURN - KK = NZ + 2 - S2 = Y(KK) - Y(KK) = S2*CSR(1) - IF (INU.EQ.2) RETURN - T2 = FNU + FLOAT(KK-1) - CK = CMPLX(T2,0.0E0)*RZ - KFLAG = 1 - GO TO 250 - 290 CONTINUE -C----------------------------------------------------------------------- -C SCALE BY EXP(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 - S1 = COEF - S2 = COEF - GO TO 210 - 310 CONTINUE - NZ=-2 - RETURN - END
--- a/liboctave/cruft/amos/cbuni.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,158 +0,0 @@ - SUBROUTINE CBUNI(Z, FNU, KODE, N, Y, NZ, NUI, NLAST, FNUL, TOL, - * ELIM, ALIM) -C***BEGIN PROLOGUE CBUNI -C***REFER TO CBESI,CBESK -C -C CBUNI 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 CUNI1,CUNI2,R1MACH -C***END PROLOGUE CBUNI - COMPLEX CSCL, CSCR, CY, RZ, ST, S1, S2, Y, Z - REAL ALIM, AX, AY, DFNU, ELIM, FNU, FNUI, FNUL, GNU, TOL, XX, YY, - * ASCLE, BRY, STR, STI, STM, R1MACH - INTEGER I, IFLAG, IFORM, K, KODE, N, NL, NLAST, NUI, NW, NZ - DIMENSION Y(N), CY(2), BRY(3) - NZ = 0 - XX = REAL(Z) - YY = AIMAG(Z) - AX = ABS(XX)*1.7321E0 - AY = ABS(YY) - IFORM = 1 - IF (AY.GT.AX) IFORM = 2 - IF (NUI.EQ.0) GO TO 60 - FNUI = FLOAT(NUI) - DFNU = FNU + 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 CUNI1(Z, GNU, KODE, 2, CY, 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 CUNI2(Z, GNU, KODE, 2, CY, NW, NLAST, FNUL, TOL, ELIM, ALIM) - 20 CONTINUE - IF (NW.LT.0) GO TO 50 - IF (NW.NE.0) GO TO 90 - AY = CABS(CY(1)) -C---------------------------------------------------------------------- -C SCALE BACKWARD RECURRENCE, BRY(3) IS DEFINED BUT NEVER USED -C---------------------------------------------------------------------- - BRY(1) = 1.0E+3*R1MACH(1)/TOL - BRY(2) = 1.0E0/BRY(1) - BRY(3) = BRY(2) - IFLAG = 2 - ASCLE = BRY(2) - AX = 1.0E0 - CSCL = CMPLX(AX,0.0E0) - IF (AY.GT.BRY(1)) GO TO 21 - IFLAG = 1 - ASCLE = BRY(1) - AX = 1.0E0/TOL - CSCL = CMPLX(AX,0.0E0) - GO TO 25 - 21 CONTINUE - IF (AY.LT.BRY(2)) GO TO 25 - IFLAG = 3 - ASCLE = BRY(3) - AX = TOL - CSCL = CMPLX(AX,0.0E0) - 25 CONTINUE - AY = 1.0E0/AX - CSCR = CMPLX(AY,0.0E0) - S1 = CY(2)*CSCL - S2 = CY(1)*CSCL - RZ = CMPLX(2.0E0,0.0E0)/Z - DO 30 I=1,NUI - ST = S2 - S2 = CMPLX(DFNU+FNUI,0.0E0)*RZ*S2 + S1 - S1 = ST - FNUI = FNUI - 1.0E0 - IF (IFLAG.GE.3) GO TO 30 - ST = S2*CSCR - STR = REAL(ST) - STI = AIMAG(ST) - STR = ABS(STR) - STI = ABS(STI) - STM = AMAX1(STR,STI) - IF (STM.LE.ASCLE) GO TO 30 - IFLAG = IFLAG+1 - ASCLE = BRY(IFLAG) - S1 = S1*CSCR - S2 = ST - AX = AX*TOL - AY = 1.0E0/AX - CSCL = CMPLX(AX,0.0E0) - CSCR = CMPLX(AY,0.0E0) - S1 = S1*CSCL - S2 = S2*CSCL - 30 CONTINUE - Y(N) = S2*CSCR - IF (N.EQ.1) RETURN - NL = N - 1 - FNUI = FLOAT(NL) - K = NL - DO 40 I=1,NL - ST = S2 - S2 = CMPLX(FNU+FNUI,0.0E0)*RZ*S2 + S1 - S1 = ST - ST = S2*CSCR - Y(K) = ST - FNUI = FNUI - 1.0E0 - K = K - 1 - IF (IFLAG.GE.3) GO TO 40 - STR = REAL(ST) - STI = AIMAG(ST) - STR = ABS(STR) - STI = ABS(STI) - STM = AMAX1(STR,STI) - IF (STM.LE.ASCLE) GO TO 40 - IFLAG = IFLAG+1 - ASCLE = BRY(IFLAG) - S1 = S1*CSCR - S2 = ST - AX = AX*TOL - AY = 1.0E0/AX - CSCL = CMPLX(AX,0.0E0) - CSCR = CMPLX(AY,0.0E0) - S1 = S1*CSCL - S2 = S2*CSCL - 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 CUNI1(Z, FNU, KODE, N, Y, 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 CUNI2(Z, FNU, KODE, N, Y, NW, NLAST, FNUL, TOL, ELIM, ALIM) - 80 CONTINUE - IF (NW.LT.0) GO TO 50 - NZ = NW - RETURN - 90 CONTINUE - NLAST = N - RETURN - END
--- a/liboctave/cruft/amos/cbunk.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,36 +0,0 @@ - SUBROUTINE CBUNK(Z, FNU, KODE, MR, N, Y, NZ, TOL, ELIM, ALIM) -C***BEGIN PROLOGUE CBUNK -C***REFER TO CBESK,CBESH -C -C CBUNK COMPUTES THE K BESSEL FUNCTION FOR FNU.GT.FNUL. -C ACCORDING TO THE UNIFORM ASYMPTOTIC EXPANSION FOR K(FNU,Z) -C IN CUNK1 AND THE EXPANSION FOR H(2,FNU,Z) IN CUNK2 -C -C***ROUTINES CALLED CUNK1,CUNK2 -C***END PROLOGUE CBUNK - COMPLEX Y, Z - REAL ALIM, AX, AY, ELIM, FNU, TOL, XX, YY - INTEGER KODE, MR, N, NZ - DIMENSION Y(N) - NZ = 0 - XX = REAL(Z) - YY = AIMAG(Z) - AX = ABS(XX)*1.7321E0 - AY = ABS(YY) - 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 CUNK1(Z, FNU, KODE, MR, N, Y, 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 CUNK2(Z, FNU, KODE, MR, N, Y, NZ, TOL, ELIM, ALIM) - 20 CONTINUE - RETURN - END
--- a/liboctave/cruft/amos/ckscl.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,102 +0,0 @@ - SUBROUTINE CKSCL(ZR, FNU, N, Y, NZ, RZ, ASCLE, TOL, ELIM) -C***BEGIN PROLOGUE CKSCL -C***REFER TO CBKNU,CUNK1,CUNK2 -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 CUCHK -C***END PROLOGUE CKSCL - COMPLEX CK, CS, CY, CZERO, RZ, S1, S2, Y, ZR, ZD, CELM - REAL AA, ASCLE, ACS, AS, CSI, CSR, ELIM, FN, FNU, TOL, XX, ZRI, - * ELM, ALAS, HELIM - INTEGER I, IC, K, KK, N, NN, NW, NZ - DIMENSION Y(N), CY(2) - DATA CZERO / (0.0E0,0.0E0) / -C - NZ = 0 - IC = 0 - XX = REAL(ZR) - NN = MIN0(2,N) - DO 10 I=1,NN - S1 = Y(I) - CY(I) = S1 - AS = CABS(S1) - ACS = -XX + ALOG(AS) - NZ = NZ + 1 - Y(I) = CZERO - IF (ACS.LT.(-ELIM)) GO TO 10 - CS = -ZR + CLOG(S1) - CSR = REAL(CS) - CSI = AIMAG(CS) - AA = EXP(CSR)/TOL - CS = CMPLX(AA,0.0E0)*CMPLX(COS(CSI),SIN(CSI)) - CALL CUCHK(CS, NW, ASCLE, TOL) - IF (NW.NE.0) GO TO 10 - Y(I) = CS - NZ = NZ - 1 - IC = I - 10 CONTINUE - IF (N.EQ.1) RETURN - IF (IC.GT.1) GO TO 20 - Y(1) = CZERO - NZ = 2 - 20 CONTINUE - IF (N.EQ.2) RETURN - IF (NZ.EQ.0) RETURN - FN = FNU + 1.0E0 - CK = CMPLX(FN,0.0E0)*RZ - S1 = CY(1) - S2 = CY(2) - HELIM = 0.5E0*ELIM - ELM = EXP(-ELIM) - CELM = CMPLX(ELM,0.0E0) - ZRI =AIMAG(ZR) - ZD = ZR -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 - CS = S2 - S2 = CK*S2 + S1 - S1 = CS - CK = CK + RZ - AS = CABS(S2) - ALAS = ALOG(AS) - ACS = -XX + ALAS - NZ = NZ + 1 - Y(I) = CZERO - IF (ACS.LT.(-ELIM)) GO TO 25 - CS = -ZD + CLOG(S2) - CSR = REAL(CS) - CSI = AIMAG(CS) - AA = EXP(CSR)/TOL - CS = CMPLX(AA,0.0E0)*CMPLX(COS(CSI),SIN(CSI)) - CALL CUCHK(CS, NW, ASCLE, TOL) - IF (NW.NE.0) GO TO 25 - Y(I) = CS - 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 - XX = XX-ELIM - S1 = S1*CELM - S2 = S2*CELM - ZD = CMPLX(XX,ZRI) - 30 CONTINUE - NZ = N - IF(IC.EQ.N) NZ=N-1 - GO TO 45 - 40 CONTINUE - NZ = KK - 2 - 45 CONTINUE - DO 50 K=1,NZ - Y(K) = CZERO - 50 CONTINUE - RETURN - END
--- a/liboctave/cruft/amos/cmlri.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,155 +0,0 @@ - SUBROUTINE CMLRI(Z, FNU, KODE, N, Y, NZ, TOL) -C***BEGIN PROLOGUE CMLRI -C***REFER TO CBESI,CBESK -C -C CMLRI 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 GAMLN,R1MACH -C***END PROLOGUE CMLRI - COMPLEX CK, CNORM, CONE, CTWO, CZERO, PT, P1, P2, RZ, SUM, Y, Z - REAL ACK, AK, AP, AT, AZ, BK, FKAP, FKK, FLAM, FNF, FNU, RHO, - * RHO2, SCLE, TFNF, TOL, TST, X, GAMLN, R1MACH - INTEGER I, IAZ, IDUM, IFNU, INU, ITIME, K, KK, KM, KODE, M, N - DIMENSION Y(N) - DATA CZERO,CONE,CTWO /(0.0E0,0.0E0),(1.0E0,0.0E0),(2.0E0,0.0E0)/ - SCLE = 1.0E+3*R1MACH(1)/TOL - NZ=0 - AZ = CABS(Z) - X = REAL(Z) - IAZ = INT(AZ) - IFNU = INT(FNU) - INU = IFNU + N - 1 - AT = FLOAT(IAZ) + 1.0E0 - CK = CMPLX(AT,0.0E0)/Z - RZ = CTWO/Z - P1 = CZERO - P2 = CONE - ACK = (AT+1.0E0)/AZ - RHO = ACK + SQRT(ACK*ACK-1.0E0) - RHO2 = RHO*RHO - TST = (RHO2+RHO2)/((RHO2-1.0E0)*(RHO-1.0E0)) - TST = TST/TOL -C----------------------------------------------------------------------- -C COMPUTE RELATIVE TRUNCATION ERROR INDEX FOR SERIES -C----------------------------------------------------------------------- - AK = AT - DO 10 I=1,80 - PT = P2 - P2 = P1 - CK*P2 - P1 = PT - CK = CK + RZ - AP = CABS(P2) - IF (AP.GT.TST*AK*AK) GO TO 20 - AK = AK + 1.0E0 - 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----------------------------------------------------------------------- - P1 = CZERO - P2 = CONE - AT = FLOAT(INU) + 1.0E0 - CK = CMPLX(AT,0.0E0)/Z - ACK = AT/AZ - TST = SQRT(ACK/TOL) - ITIME = 1 - DO 30 K=1,80 - PT = P2 - P2 = P1 - CK*P2 - P1 = PT - CK = CK + RZ - AP = CABS(P2) - IF (AP.LT.TST) GO TO 30 - IF (ITIME.EQ.2) GO TO 40 - ACK = CABS(CK) - FLAM = ACK + SQRT(ACK*ACK-1.0E0) - FKAP = AP/CABS(P1) - RHO = AMIN1(FLAM,FKAP) - TST = TST*SQRT(RHO/(RHO*RHO-1.0E0)) - 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 = FLOAT(KK) - P1 = CZERO -C----------------------------------------------------------------------- -C SCALE P2 AND SUM BY SCLE -C----------------------------------------------------------------------- - P2 = CMPLX(SCLE,0.0E0) - FNF = FNU - FLOAT(IFNU) - TFNF = FNF + FNF - BK = GAMLN(FKK+TFNF+1.0E0,IDUM) - GAMLN(FKK+1.0E0,IDUM) - * -GAMLN(TFNF+1.0E0,IDUM) - BK = EXP(BK) - SUM = CZERO - KM = KK - INU - DO 50 I=1,KM - PT = P2 - P2 = P1 + CMPLX(FKK+FNF,0.0E0)*RZ*P2 - P1 = PT - AK = 1.0E0 - TFNF/(FKK+TFNF) - ACK = BK*AK - SUM = SUM + CMPLX(ACK+BK,0.0E0)*P1 - BK = ACK - FKK = FKK - 1.0E0 - 50 CONTINUE - Y(N) = P2 - IF (N.EQ.1) GO TO 70 - DO 60 I=2,N - PT = P2 - P2 = P1 + CMPLX(FKK+FNF,0.0E0)*RZ*P2 - P1 = PT - AK = 1.0E0 - TFNF/(FKK+TFNF) - ACK = BK*AK - SUM = SUM + CMPLX(ACK+BK,0.0E0)*P1 - BK = ACK - FKK = FKK - 1.0E0 - M = N - I + 1 - Y(M) = P2 - 60 CONTINUE - 70 CONTINUE - IF (IFNU.LE.0) GO TO 90 - DO 80 I=1,IFNU - PT = P2 - P2 = P1 + CMPLX(FKK+FNF,0.0E0)*RZ*P2 - P1 = PT - AK = 1.0E0 - TFNF/(FKK+TFNF) - ACK = BK*AK - SUM = SUM + CMPLX(ACK+BK,0.0E0)*P1 - BK = ACK - FKK = FKK - 1.0E0 - 80 CONTINUE - 90 CONTINUE - PT = Z - IF (KODE.EQ.2) PT = PT - CMPLX(X,0.0E0) - P1 = -CMPLX(FNF,0.0E0)*CLOG(RZ) + PT - AP = GAMLN(1.0E0+FNF,IDUM) - PT = P1 - CMPLX(AP,0.0E0) -C----------------------------------------------------------------------- -C THE DIVISION CEXP(PT)/(SUM+P2) IS ALTERED TO AVOID OVERFLOW -C IN THE DENOMINATOR BY SQUARING LARGE QUANTITIES -C----------------------------------------------------------------------- - P2 = P2 + SUM - AP = CABS(P2) - P1 = CMPLX(1.0E0/AP,0.0E0) - CK = CEXP(PT)*P1 - PT = CONJG(P2)*P1 - CNORM = CK*PT - DO 100 I=1,N - Y(I) = Y(I)*CNORM - 100 CONTINUE - RETURN - 110 CONTINUE - NZ=-2 - RETURN - END
--- a/liboctave/cruft/amos/crati.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,100 +0,0 @@ - SUBROUTINE CRATI(Z, FNU, N, CY, TOL) -C***BEGIN PROLOGUE CRATI -C***REFER TO CBESI,CBESK,CBESH -C -C CRATI 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 (NONE) -C***END PROLOGUE CRATI - COMPLEX CDFNU, CONE, CY, CZERO, PT, P1, P2, RZ, T1, Z - REAL AK, AMAGZ, AP1, AP2, ARG, AZ, DFNU, FDNU, FLAM, FNU, FNUP, - * RAP1, RHO, TEST, TEST1, TOL - INTEGER I, ID, IDNU, INU, ITIME, K, KK, MAGZ, N - DIMENSION CY(N) - DATA CZERO, CONE / (0.0E0,0.0E0), (1.0E0,0.0E0) / - AZ = CABS(Z) - INU = INT(FNU) - IDNU = INU + N - 1 - FDNU = FLOAT(IDNU) - MAGZ = INT(AZ) - AMAGZ = FLOAT(MAGZ+1) - FNUP = AMAX1(AMAGZ,FDNU) - ID = IDNU - MAGZ - 1 - ITIME = 1 - K = 1 - RZ = (CONE+CONE)/Z - T1 = CMPLX(FNUP,0.0E0)*RZ - P2 = -T1 - P1 = CONE - T1 = T1 + RZ - IF (ID.GT.0) ID = 0 - AP2 = CABS(P2) - AP1 = CABS(P1) -C----------------------------------------------------------------------- -C THE OVERFLOW TEST ON K(FNU+I-1,Z) BEFORE THE CALL TO CBKNX -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 = SQRT(ARG) - TEST = TEST1 - RAP1 = 1.0E0/AP1 - P1 = P1*CMPLX(RAP1,0.0E0) - P2 = P2*CMPLX(RAP1,0.0E0) - AP2 = AP2*RAP1 - 10 CONTINUE - K = K + 1 - AP1 = AP2 - PT = P2 - P2 = P1 - T1*P2 - P1 = PT - T1 = T1 + RZ - AP2 = CABS(P2) - IF (AP1.LE.TEST) GO TO 10 - IF (ITIME.EQ.2) GO TO 20 - AK = CABS(T1)*0.5E0 - FLAM = AK + SQRT(AK*AK-1.0E0) - RHO = AMIN1(AP2/AP1,FLAM) - TEST = TEST1*SQRT(RHO/(RHO*RHO-1.0E0)) - ITIME = 2 - GO TO 10 - 20 CONTINUE - KK = K + 1 - ID - AK = FLOAT(KK) - DFNU = FNU + FLOAT(N-1) - CDFNU = CMPLX(DFNU,0.0E0) - T1 = CMPLX(AK,0.0E0) - P1 = CMPLX(1.0E0/AP2,0.0E0) - P2 = CZERO - DO 30 I=1,KK - PT = P1 - P1 = RZ*(CDFNU+T1)*P1 + P2 - P2 = PT - T1 = T1 - CONE - 30 CONTINUE - IF (REAL(P1).NE.0.0E0 .OR. AIMAG(P1).NE.0.0E0) GO TO 40 - P1 = CMPLX(TOL,TOL) - 40 CONTINUE - CY(N) = P2/P1 - IF (N.EQ.1) RETURN - K = N - 1 - AK = FLOAT(K) - T1 = CMPLX(AK,0.0E0) - CDFNU = CMPLX(FNU,0.0E0)*RZ - DO 60 I=2,N - PT = CDFNU + T1*RZ + CY(K+1) - IF (REAL(PT).NE.0.0E0 .OR. AIMAG(PT).NE.0.0E0) GO TO 50 - PT = CMPLX(TOL,TOL) - 50 CONTINUE - CY(K) = CONE/PT - T1 = T1 - CONE - K = K - 1 - 60 CONTINUE - RETURN - END
--- a/liboctave/cruft/amos/cs1s2.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,44 +0,0 @@ - SUBROUTINE CS1S2(ZR, S1, S2, NZ, ASCLE, ALIM, IUF) -C***BEGIN PROLOGUE CS1S2 -C***REFER TO CBESK,CAIRY -C -C CS1S2 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 (NONE) -C***END PROLOGUE CS1S2 - COMPLEX CZERO, C1, S1, S1D, S2, ZR - REAL AA, ALIM, ALN, ASCLE, AS1, AS2, XX - INTEGER IUF, NZ - DATA CZERO / (0.0E0,0.0E0) / - NZ = 0 - AS1 = CABS(S1) - AS2 = CABS(S2) - AA = REAL(S1) - ALN = AIMAG(S1) - IF (AA.EQ.0.0E0 .AND. ALN.EQ.0.0E0) GO TO 10 - IF (AS1.EQ.0.0E0) GO TO 10 - XX = REAL(ZR) - ALN = -XX - XX + ALOG(AS1) - S1D = S1 - S1 = CZERO - AS1 = 0.0E0 - IF (ALN.LT.(-ALIM)) GO TO 10 - C1 = CLOG(S1D) - ZR - ZR - S1 = CEXP(C1) - AS1 = CABS(S1) - IUF = IUF + 1 - 10 CONTINUE - AA = AMAX1(AS1,AS2) - IF (AA.GT.ASCLE) RETURN - S1 = CZERO - S2 = CZERO - NZ = 1 - IUF = 0 - RETURN - END
--- a/liboctave/cruft/amos/cseri.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,154 +0,0 @@ - SUBROUTINE CSERI(Z, FNU, KODE, N, Y, NZ, TOL, ELIM, ALIM) -C***BEGIN PROLOGUE CSERI -C***REFER TO CBESI,CBESK -C -C CSERI 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 CUCHK,GAMLN,R1MACH -C***END PROLOGUE CSERI - COMPLEX AK1, CK, COEF, CONE, CRSC, CZ, CZERO, HZ, RZ, S1, S2, W, - * Y, Z - REAL AA, ACZ, AK, ALIM, ARM, ASCLE, ATOL, AZ, DFNU, ELIM, FNU, - * FNUP, RAK1, RS, RTR1, S, SS, TOL, X, GAMLN, R1MACH - INTEGER I, IB, IDUM, IFLAG, IL, K, KODE, L, M, N, NN, NW, NZ - DIMENSION Y(N), W(2) - DATA CZERO, CONE / (0.0E0,0.0E0), (1.0E0,0.0E0) / -C - NZ = 0 - AZ = CABS(Z) - IF (AZ.EQ.0.0E0) GO TO 150 - X = REAL(Z) - ARM = 1.0E+3*R1MACH(1) - RTR1 = SQRT(ARM) - CRSC = CMPLX(1.0E0,0.0E0) - IFLAG = 0 - IF (AZ.LT.ARM) GO TO 140 - HZ = Z*CMPLX(0.5E0,0.0E0) - CZ = CZERO - IF (AZ.GT.RTR1) CZ = HZ*HZ - ACZ = CABS(CZ) - NN = N - CK = CLOG(HZ) - 10 CONTINUE - DFNU = FNU + FLOAT(NN-1) - FNUP = DFNU + 1.0E0 -C----------------------------------------------------------------------- -C UNDERFLOW TEST -C----------------------------------------------------------------------- - AK1 = CK*CMPLX(DFNU,0.0E0) - AK = GAMLN(FNUP,IDUM) - AK1 = AK1 - CMPLX(AK,0.0E0) - IF (KODE.EQ.2) AK1 = AK1 - CMPLX(X,0.0E0) - RAK1 = REAL(AK1) - IF (RAK1.GT.(-ELIM)) GO TO 30 - 20 CONTINUE - NZ = NZ + 1 - Y(NN) = CZERO - IF (ACZ.GT.DFNU) GO TO 170 - NN = NN - 1 - IF (NN.EQ.0) RETURN - GO TO 10 - 30 CONTINUE - IF (RAK1.GT.(-ALIM)) GO TO 40 - IFLAG = 1 - SS = 1.0E0/TOL - CRSC = CMPLX(TOL,0.0E0) - ASCLE = ARM*SS - 40 CONTINUE - AK = AIMAG(AK1) - AA = EXP(RAK1) - IF (IFLAG.EQ.1) AA = AA*SS - COEF = CMPLX(AA,0.0E0)*CMPLX(COS(AK),SIN(AK)) - ATOL = TOL*ACZ/FNUP - IL = MIN0(2,NN) - DO 80 I=1,IL - DFNU = FNU + FLOAT(NN-I) - FNUP = DFNU + 1.0E0 - S1 = CONE - IF (ACZ.LT.TOL*FNUP) GO TO 60 - AK1 = CONE - AK = FNUP + 2.0E0 - S = FNUP - AA = 2.0E0 - 50 CONTINUE - RS = 1.0E0/S - AK1 = AK1*CZ*CMPLX(RS,0.0E0) - S1 = S1 + AK1 - S = S + AK - AK = AK + 2.0E0 - AA = AA*ACZ*RS - IF (AA.GT.ATOL) GO TO 50 - 60 CONTINUE - M = NN - I + 1 - S2 = S1*COEF - W(I) = S2 - IF (IFLAG.EQ.0) GO TO 70 - CALL CUCHK(S2, NW, ASCLE, TOL) - IF (NW.NE.0) GO TO 20 - 70 CONTINUE - Y(M) = S2*CRSC - IF (I.NE.IL) COEF = COEF*CMPLX(DFNU,0.0E0)/HZ - 80 CONTINUE - IF (NN.LE.2) RETURN - K = NN - 2 - AK = FLOAT(K) - RZ = (CONE+CONE)/Z - IF (IFLAG.EQ.1) GO TO 110 - IB = 3 - 90 CONTINUE - DO 100 I=IB,NN - Y(K) = CMPLX(AK+FNU,0.0E0)*RZ*Y(K+1) + Y(K+2) - AK = AK - 1.0E0 - K = K - 1 - 100 CONTINUE - RETURN -C----------------------------------------------------------------------- -C RECUR BACKWARD WITH SCALED VALUES -C----------------------------------------------------------------------- - 110 CONTINUE -C----------------------------------------------------------------------- -C EXP(-ALIM)=EXP(-ELIM)/TOL=APPROX. ONE PRECISION ABOVE THE -C UNDERFLOW LIMIT = ASCLE = R1MACH(1)*CSCL*1.0E+3 -C----------------------------------------------------------------------- - S1 = W(1) - S2 = W(2) - DO 120 L=3,NN - CK = S2 - S2 = S1 + CMPLX(AK+FNU,0.0E0)*RZ*S2 - S1 = CK - CK = S2*CRSC - Y(K) = CK - AK = AK - 1.0E0 - K = K - 1 - IF (CABS(CK).GT.ASCLE) GO TO 130 - 120 CONTINUE - RETURN - 130 CONTINUE - IB = L + 1 - IF (IB.GT.NN) RETURN - GO TO 90 - 140 CONTINUE - NZ = N - IF (FNU.EQ.0.0E0) NZ = NZ - 1 - 150 CONTINUE - Y(1) = CZERO - IF (FNU.EQ.0.0E0) Y(1) = CONE - IF (N.EQ.1) RETURN - DO 160 I=2,N - Y(I) = CZERO - 160 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----------------------------------------------------------------------- - 170 CONTINUE - NZ = -NZ - RETURN - END
--- a/liboctave/cruft/amos/cshch.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,25 +0,0 @@ - SUBROUTINE CSHCH(Z, CSH, CCH) -C***BEGIN PROLOGUE CSHCH -C***REFER TO CBESK,CBESH -C -C CSHCH 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 CSHCH - COMPLEX CCH, CSH, Z - REAL CCHI, CCHR, CH, CN, CSHI, CSHR, SH, SN, X, Y, COSH, SINH - X = REAL(Z) - Y = AIMAG(Z) - SH = SINH(X) - CH = COSH(X) - SN = SIN(Y) - CN = COS(Y) - CSHR = SH*CN - CSHI = CH*SN - CSH = CMPLX(CSHR,CSHI) - CCHR = CH*CN - CCHI = SH*SN - CCH = CMPLX(CCHR,CCHI) - RETURN - END
--- a/liboctave/cruft/amos/cuchk.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,30 +0,0 @@ - SUBROUTINE CUCHK(Y, NZ, ASCLE, TOL) -C***BEGIN PROLOGUE CUCHK -C***REFER TO CSERI,CUOIK,CUNK1,CUNK2,CUNI1,CUNI2,CKSCL -C -C Y ENTERS AS A SCALED QUANTITY WHOSE MAGNITUDE IS GREATER THAN -C EXP(-ALIM)=ASCLE=1.0E+3*R1MACH(1)/TOL. THE TEST IS MADE TO SEE -C IF THE MAGNITUDE OF THE REAL OR IMAGINARY PART WOULD UNDER FLOW -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 CUCHK -C - COMPLEX Y - REAL ASCLE, SS, ST, TOL, YR, YI - INTEGER NZ - NZ = 0 - YR = REAL(Y) - YI = AIMAG(Y) - YR = ABS(YR) - YI = ABS(YI) - ST = AMIN1(YR,YI) - IF (ST.GT.ASCLE) RETURN - SS = AMAX1(YR,YI) - ST=ST/TOL - IF (SS.LT.ST) NZ = 1 - RETURN - END
--- a/liboctave/cruft/amos/cunhj.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,648 +0,0 @@ - SUBROUTINE CUNHJ(Z, FNU, IPMTR, TOL, PHI, ARG, ZETA1, ZETA2, - * ASUM, BSUM) -C***BEGIN PROLOGUE CUNHJ -C***REFER TO CBESI,CBESK -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 CUNHJ 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 (NONE) -C***END PROLOGUE CUNHJ - COMPLEX ARG, ASUM, BSUM, CFNU, CONE, CR, CZERO, DR, P, PHI, - * PRZTH, PTFN, RFN13, RTZTA, RZTH, SUMA, SUMB, TFN, T2, UP, W, W2, - * Z, ZA, ZB, ZC, ZETA, ZETA1, ZETA2, ZTH - REAL ALFA, ANG, AP, AR, ATOL, AW2, AZTH, BETA, BR, BTOL, C, EX1, - * EX2, FNU, FN13, FN23, GAMA, HPI, PI, PP, RFNU, RFNU2, THPI, TOL, - * WI, WR, ZCI, ZCR, ZETAI, ZETAR, ZTHI, ZTHR, ASUMR, ASUMI, BSUMR, - * BSUMI, TEST, TSTR, TSTI, AC - INTEGER IAS, IBS, IPMTR, IS, J, JR, JU, K, KMAX, KP1, KS, L, LR, - * LRP1, L1, L2, M - DIMENSION AR(14), BR(14), C(105), ALFA(180), BETA(210), GAMA(30), - * AP(30), P(30), UP(14), CR(14), DR(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.00000000000000000E+00, 1.04166666666666667E-01, - 3 8.35503472222222222E-02, 1.28226574556327160E-01, - 4 2.91849026464140464E-01, 8.81627267443757652E-01, - 5 3.32140828186276754E+00, 1.49957629868625547E+01, - 6 7.89230130115865181E+01, 4.74451538868264323E+02, - 7 3.20749009089066193E+03, 2.40865496408740049E+04, - 8 1.98923119169509794E+05, 1.79190200777534383E+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.00000000000000000E+00, -1.45833333333333333E-01, - 3 -9.87413194444444444E-02, -1.43312053915895062E-01, - 4 -3.17227202678413548E-01, -9.42429147957120249E-01, - 5 -3.51120304082635426E+00, -1.57272636203680451E+01, - 6 -8.22814390971859444E+01, -4.92355370523670524E+02, - 7 -3.31621856854797251E+03, -2.48276742452085896E+04, - 8 -2.04526587315129788E+05, -1.83844491706820990E+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.00000000000000000E+00, -2.08333333333333333E-01, - 4 1.25000000000000000E-01, 3.34201388888888889E-01, - 5 -4.01041666666666667E-01, 7.03125000000000000E-02, - 6 -1.02581259645061728E+00, 1.84646267361111111E+00, - 7 -8.91210937500000000E-01, 7.32421875000000000E-02, - 8 4.66958442342624743E+00, -1.12070026162229938E+01, - 9 8.78912353515625000E+00, -2.36408691406250000E+00, - A 1.12152099609375000E-01, -2.82120725582002449E+01, - B 8.46362176746007346E+01, -9.18182415432400174E+01, - C 4.25349987453884549E+01, -7.36879435947963170E+00, - D 2.27108001708984375E-01, 2.12570130039217123E+02, - E -7.65252468141181642E+02, 1.05999045252799988E+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.99579627376132541E+02, 2.18190511744211590E+02, - 4 -2.64914304869515555E+01, 5.72501420974731445E-01, - 5 -1.91945766231840700E+03, 8.06172218173730938E+03, - 6 -1.35865500064341374E+04, 1.16553933368645332E+04, - 7 -5.30564697861340311E+03, 1.20090291321635246E+03, - 8 -1.08090919788394656E+02, 1.72772750258445740E+00, - 9 2.02042913309661486E+04, -9.69805983886375135E+04, - A 1.92547001232531532E+05, -2.03400177280415534E+05, - B 1.22200464983017460E+05, -4.11926549688975513E+04, - C 7.10951430248936372E+03, -4.93915304773088012E+02, - D 6.07404200127348304E+00, -2.42919187900551333E+05, - E 1.31176361466297720E+06, -2.99801591853810675E+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.76327129765640400E+06, -2.81356322658653411E+06, - 4 1.26836527332162478E+06, -3.31645172484563578E+05, - 5 4.52187689813627263E+04, -2.49983048181120962E+03, - 6 2.43805296995560639E+01, 3.28446985307203782E+06, - 7 -1.97068191184322269E+07, 5.09526024926646422E+07, - 8 -7.41051482115326577E+07, 6.63445122747290267E+07, - 9 -3.75671766607633513E+07, 1.32887671664218183E+07, - A -2.78561812808645469E+06, 3.08186404612662398E+05, - B -1.38860897537170405E+04, 1.10017140269246738E+02, - C -4.93292536645099620E+07, 3.25573074185765749E+08, - D -9.39462359681578403E+08, 1.55359689957058006E+09, - E -1.62108055210833708E+09, 1.10684281682301447E+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.95889784275030309E+08, 1.42062907797533095E+08, - 4 -2.44740627257387285E+07, 2.24376817792244943E+06, - 5 -8.40054336030240853E+04, 5.51335896122020586E+02, - 6 8.14789096118312115E+08, -5.86648149205184723E+09, - 7 1.86882075092958249E+10, -3.46320433881587779E+10, - 8 4.12801855797539740E+10, -3.30265997498007231E+10, - 9 1.79542137311556001E+10, -6.56329379261928433E+09, - A 1.55927986487925751E+09, -2.25105661889415278E+08, - B 1.73951075539781645E+07, -5.49842327572288687E+05, - C 3.03809051092238427E+03, -1.46792612476956167E+10, - D 1.14498237732025810E+11, -3.99096175224466498E+11, - E 8.19218669548577329E+11, -1.09837515608122331E+12/ - DATA C(97), C(98), C(99), C(100), C(101), C(102), C(103), C(104), - 1 C(105)/ - 2 1.00815810686538209E+12, -6.45364869245376503E+11, - 3 2.87900649906150589E+11, -8.78670721780232657E+10, - 4 1.76347306068349694E+10, -2.16716498322379509E+09, - 5 1.43157876718888981E+08, -3.87183344257261262E+06, - 6 1.82577554742931747E+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.44444444444444444E-03, -9.22077922077922078E-04, - 5 -8.84892884892884893E-05, 1.65927687832449737E-04, - 6 2.46691372741792910E-04, 2.65995589346254780E-04, - 7 2.61824297061500945E-04, 2.48730437344655609E-04, - 8 2.32721040083232098E-04, 2.16362485712365082E-04, - 9 2.00738858762752355E-04, 1.86267636637545172E-04, - A 1.73060775917876493E-04, 1.61091705929015752E-04, - B 1.50274774160908134E-04, 1.40503497391269794E-04, - C 1.31668816545922806E-04, 1.23667445598253261E-04, - D 1.16405271474737902E-04, 1.09798298372713369E-04, - E 1.03772410422992823E-04, 9.82626078369363448E-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.32120517249503256E-05, 8.85710852478711718E-05, - 5 8.42963105715700223E-05, 8.03497548407791151E-05, - 6 7.66981345359207388E-05, 7.33122157481777809E-05, - 7 7.01662625163141333E-05, 6.72375633790160292E-05, - 8 6.93735541354588974E-04, 2.32241745182921654E-04, - 9 -1.41986273556691197E-05, -1.16444931672048640E-04, - A -1.50803558053048762E-04, -1.55121924918096223E-04, - B -1.46809756646465549E-04, -1.33815503867491367E-04, - C -1.19744975684254051E-04, -1.06184319207974020E-04, - D -9.37699549891194492E-05, -8.26923045588193274E-05, - E -7.29374348155221211E-05, -6.44042357721016283E-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.69611566009369048E-05, -5.04731044303561628E-05, - 5 -4.48134868008882786E-05, -3.98688727717598864E-05, - 6 -3.55400532972042498E-05, -3.17414256609022480E-05, - 7 -2.83996793904174811E-05, -2.54522720634870566E-05, - 8 -2.28459297164724555E-05, -2.05352753106480604E-05, - 9 -1.84816217627666085E-05, -1.66519330021393806E-05, - A -1.50179412980119482E-05, -1.35554031379040526E-05, - B -1.22434746473858131E-05, -1.10641884811308169E-05, - C -3.54211971457743841E-04, -1.56161263945159416E-04, - D 3.04465503594936410E-05, 1.30198655773242693E-04, - E 1.67471106699712269E-04, 1.70222587683592569E-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.56501427608594704E-04, 1.36339170977445120E-04, - 5 1.14886692029825128E-04, 9.45869093034688111E-05, - 6 7.64498419250898258E-05, 6.07570334965197354E-05, - 7 4.74394299290508799E-05, 3.62757512005344297E-05, - 8 2.69939714979224901E-05, 1.93210938247939253E-05, - 9 1.30056674793963203E-05, 7.82620866744496661E-06, - A 3.59257485819351583E-06, 1.44040049814251817E-07, - B -2.65396769697939116E-06, -4.91346867098485910E-06, - C -6.72739296091248287E-06, -8.17269379678657923E-06, - D -9.31304715093561232E-06, -1.02011418798016441E-05, - E -1.08805962510592880E-05, -1.13875481509603555E-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.17519675674556414E-05, -1.19987364870944141E-05, - 5 3.78194199201772914E-04, 2.02471952761816167E-04, - 6 -6.37938506318862408E-05, -2.38598230603005903E-04, - 7 -3.10916256027361568E-04, -3.13680115247576316E-04, - 8 -2.78950273791323387E-04, -2.28564082619141374E-04, - 9 -1.75245280340846749E-04, -1.25544063060690348E-04, - A -8.22982872820208365E-05, -4.62860730588116458E-05, - B -1.72334302366962267E-05, 5.60690482304602267E-06, - C 2.31395443148286800E-05, 3.62642745856793957E-05, - D 4.58006124490188752E-05, 5.24595294959114050E-05, - E 5.68396208545815266E-05, 5.94349820393104052E-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.06478527578421742E-05, 6.08023907788436497E-05, - 5 6.01577894539460388E-05, 5.89199657344698500E-05, - 6 5.72515823777593053E-05, 5.52804375585852577E-05, - 7 5.31063773802880170E-05, 5.08069302012325706E-05, - 8 4.84418647620094842E-05, 4.60568581607475370E-05, - 9 -6.91141397288294174E-04, -4.29976633058871912E-04, - A 1.83067735980039018E-04, 6.60088147542014144E-04, - B 8.75964969951185931E-04, 8.77335235958235514E-04, - C 7.49369585378990637E-04, 5.63832329756980918E-04, - D 3.68059319971443156E-04, 1.88464535514455599E-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.70663057664904149E-05, -8.28520220232137023E-05, - 5 -1.72751952869172998E-04, -2.36314873605872983E-04, - 6 -2.77966150694906658E-04, -3.02079514155456919E-04, - 7 -3.12594712643820127E-04, -3.12872558758067163E-04, - 8 -3.05678038466324377E-04, -2.93226470614557331E-04, - 9 -2.77255655582934777E-04, -2.59103928467031709E-04, - A -2.39784014396480342E-04, -2.20048260045422848E-04, - B -2.00443911094971498E-04, -1.81358692210970687E-04, - C -1.63057674478657464E-04, -1.45712672175205844E-04, - D -1.29425421983924587E-04, -1.14245691942445952E-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.92821964248775885E-03, 1.35592576302022234E-03, - 5 -7.17858090421302995E-04, -2.58084802575270346E-03, - 6 -3.49271130826168475E-03, -3.46986299340960628E-03, - 7 -2.82285233351310182E-03, -1.88103076404891354E-03, - 8 -8.89531718383947600E-04, 3.87912102631035228E-06, - 9 7.28688540119691412E-04, 1.26566373053457758E-03, - A 1.62518158372674427E-03, 1.83203153216373172E-03, - B 1.91588388990527909E-03, 1.90588846755546138E-03, - C 1.82798982421825727E-03, 1.70389506421121530E-03, - D 1.55097127171097686E-03, 1.38261421852276159E-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.20881424230064774E-03, 1.03676532638344962E-03, - 3 8.71437918068619115E-04, 7.16080155297701002E-04, - 4 5.72637002558129372E-04, 4.42089819465802277E-04, - 5 3.24724948503090564E-04, 2.20342042730246599E-04, - 6 1.28412898401353882E-04, 4.82005924552095464E-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.79988721413553309E-02, 5.59964911064388073E-03, - 5 2.88501402231132779E-03, 1.80096606761053941E-03, - 6 1.24753110589199202E-03, 9.22878876572938311E-04, - 7 7.14430421727287357E-04, 5.71787281789704872E-04, - 8 4.69431007606481533E-04, 3.93232835462916638E-04, - 9 3.34818889318297664E-04, 2.88952148495751517E-04, - A 2.52211615549573284E-04, 2.22280580798883327E-04, - B 1.97541838033062524E-04, 1.76836855019718004E-04, - C 1.59316899661821081E-04, 1.44347930197333986E-04, - D 1.31448068119965379E-04, 1.20245444949302884E-04, - E 1.10449144504599392E-04, 1.01828770740567258E-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.41998224204237509E-05, 8.74130545753834437E-05, - 5 8.13466262162801467E-05, 7.59002269646219339E-05, - 6 7.09906300634153481E-05, 6.65482874842468183E-05, - 7 6.25146958969275078E-05, 5.88403394426251749E-05, - 8 -1.49282953213429172E-03, -8.78204709546389328E-04, - 9 -5.02916549572034614E-04, -2.94822138512746025E-04, - A -1.75463996970782828E-04, -1.04008550460816434E-04, - B -5.96141953046457895E-05, -3.12038929076098340E-05, - C -1.26089735980230047E-05, -2.42892608575730389E-07, - D 8.05996165414273571E-06, 1.36507009262147391E-05, - E 1.73964125472926261E-05, 1.98672978842133780E-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.14463263790822639E-05, 2.23954659232456514E-05, - 5 2.28967783814712629E-05, 2.30785389811177817E-05, - 6 2.30321976080909144E-05, 2.28236073720348722E-05, - 7 2.25005881105292418E-05, 2.20981015361991429E-05, - 8 2.16418427448103905E-05, 2.11507649256220843E-05, - 9 2.06388749782170737E-05, 2.01165241997081666E-05, - A 1.95913450141179244E-05, 1.90689367910436740E-05, - B 1.85533719641636667E-05, 1.80475722259674218E-05, - C 5.52213076721292790E-04, 4.47932581552384646E-04, - D 2.79520653992020589E-04, 1.52468156198446602E-04, - E 6.93271105657043598E-05, 1.76258683069991397E-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.35744996343269136E-05, -3.17972413350427135E-05, - 5 -4.18861861696693365E-05, -4.69004889379141029E-05, - 6 -4.87665447413787352E-05, -4.87010031186735069E-05, - 7 -4.74755620890086638E-05, -4.55813058138628452E-05, - 8 -4.33309644511266036E-05, -4.09230193157750364E-05, - 9 -3.84822638603221274E-05, -3.60857167535410501E-05, - A -3.37793306123367417E-05, -3.15888560772109621E-05, - B -2.95269561750807315E-05, -2.75978914828335759E-05, - C -2.58006174666883713E-05, -2.41308356761280200E-05, - D -2.25823509518346033E-05, -2.11479656768912971E-05, - E -1.98200638885294927E-05, -1.85909870801065077E-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.74532699844210224E-05, -1.63997823854497997E-05, - 5 -4.74617796559959808E-04, -4.77864567147321487E-04, - 6 -3.20390228067037603E-04, -1.61105016119962282E-04, - 7 -4.25778101285435204E-05, 3.44571294294967503E-05, - 8 7.97092684075674924E-05, 1.03138236708272200E-04, - 9 1.12466775262204158E-04, 1.13103642108481389E-04, - A 1.08651634848774268E-04, 1.01437951597661973E-04, - B 9.29298396593363896E-05, 8.40293133016089978E-05, - C 7.52727991349134062E-05, 6.69632521975730872E-05, - D 5.92564547323194704E-05, 5.22169308826975567E-05, - E 4.58539485165360646E-05, 4.01445513891486808E-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.50481730031328081E-05, 3.05157995034346659E-05, - 5 2.64956119950516039E-05, 2.29363633690998152E-05, - 6 1.97893056664021636E-05, 1.70091984636412623E-05, - 7 1.45547428261524004E-05, 1.23886640995878413E-05, - 8 1.04775876076583236E-05, 8.79179954978479373E-06, - 9 7.36465810572578444E-04, 8.72790805146193976E-04, - A 6.22614862573135066E-04, 2.85998154194304147E-04, - B 3.84737672879366102E-06, -1.87906003636971558E-04, - C -2.97603646594554535E-04, -3.45998126832656348E-04, - D -3.53382470916037712E-04, -3.35715635775048757E-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.04321124789039809E-04, -2.66722723047612821E-04, - 5 -2.27654214122819527E-04, -1.89922611854562356E-04, - 6 -1.55058918599093870E-04, -1.23778240761873630E-04, - 7 -9.62926147717644187E-05, -7.25178327714425337E-05, - 8 -5.22070028895633801E-05, -3.50347750511900522E-05, - 9 -2.06489761035551757E-05, -8.70106096849767054E-06, - A 1.13698686675100290E-06, 9.16426474122778849E-06, - B 1.56477785428872620E-05, 2.08223629482466847E-05, - C 2.48923381004595156E-05, 2.80340509574146325E-05, - D 3.03987774629861915E-05, 3.21156731406700616E-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.80182191963885708E-03, -2.43402962938042533E-03, - 5 -1.83422663549856802E-03, -7.62204596354009765E-04, - 6 2.39079475256927218E-04, 9.49266117176881141E-04, - 7 1.34467449701540359E-03, 1.48457495259449178E-03, - 8 1.44732339830617591E-03, 1.30268261285657186E-03, - 9 1.10351597375642682E-03, 8.86047440419791759E-04, - A 6.73073208165665473E-04, 4.77603872856582378E-04, - B 3.05991926358789362E-04, 1.60315694594721630E-04, - C 4.00749555270613286E-05, -5.66607461635251611E-05, - D -1.32506186772982638E-04, -1.90296187989614057E-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.32811450376937408E-04, -2.62628811464668841E-04, - 5 -2.82050469867598672E-04, -2.93081563192861167E-04, - 6 -2.97435962176316616E-04, -2.96557334239348078E-04, - 7 -2.91647363312090861E-04, -2.83696203837734166E-04, - 8 -2.73512317095673346E-04, -2.61750155806768580E-04, - 9 6.38585891212050914E-03, 9.62374215806377941E-03, - A 7.61878061207001043E-03, 2.83219055545628054E-03, - B -2.09841352012720090E-03, -5.73826764216626498E-03, - C -7.70804244495414620E-03, -8.21011692264844401E-03, - D -7.65824520346905413E-03, -6.47209729391045177E-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.99132412004966473E-03, -3.45612289713133280E-03, - 5 -2.01785580014170775E-03, -7.59430686781961401E-04, - 6 2.84173631523859138E-04, 1.10891667586337403E-03, - 7 1.72901493872728771E-03, 2.16812590802684701E-03, - 8 2.45357710494539735E-03, 2.61281821058334862E-03, - 9 2.67141039656276912E-03, 2.65203073395980430E-03, - A 2.57411652877287315E-03, 2.45389126236094427E-03, - B 2.30460058071795494E-03, 2.13684837686712662E-03, - C 1.95896528478870911E-03, 1.77737008679454412E-03, - D 1.59690280765839059E-03, 1.42111975664438546E-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.29960524947436582E-01, 2.51984209978974633E-01, - 5 1.54790300415655846E-01, 1.10713062416159013E-01, - 6 8.57309395527394825E-02, 6.97161316958684292E-02, - 7 5.86085671893713576E-02, 5.04698873536310685E-02, - 8 4.42600580689154809E-02, 3.93720661543509966E-02, - 9 3.54283195924455368E-02, 3.21818857502098231E-02, - A 2.94646240791157679E-02, 2.71581677112934479E-02, - B 2.51768272973861779E-02, 2.34570755306078891E-02, - C 2.19508390134907203E-02, 2.06210828235646240E-02, - D 1.94388240897880846E-02, 1.83810633800683158E-02, - E 1.74293213231963172E-02, 1.65685837786612353E-02/ - DATA GAMA(23), GAMA(24), GAMA(25), GAMA(26), GAMA(27), GAMA(28), - 1 GAMA(29), GAMA(30)/ - 2 1.57865285987918445E-02, 1.50729501494095594E-02, - 3 1.44193250839954639E-02, 1.38184805735341786E-02, - 4 1.32643378994276568E-02, 1.27517121970498651E-02, - 5 1.22761545318762767E-02, 1.18338262398482403E-02/ - DATA EX1, EX2, HPI, PI, THPI / - 1 3.33333333333333333E-01, 6.66666666666666667E-01, - 2 1.57079632679489662E+00, 3.14159265358979324E+00, - 3 4.71238898038468986E+00/ - DATA CZERO, CONE / (0.0E0,0.0E0), (1.0E0,0.0E0) / -C - RFNU = 1.0E0/FNU -C ZB = Z*CMPLX(RFNU,0.0E0) -C----------------------------------------------------------------------- -C OVERFLOW TEST (Z/FNU TOO SMALL) -C----------------------------------------------------------------------- - TSTR = REAL(Z) - TSTI = AIMAG(Z) - TEST = R1MACH(1)*1.0E+3 - AC = FNU*TEST - IF (ABS(TSTR).GT.AC .OR. ABS(TSTI).GT.AC) GO TO 15 - AC = 2.0E0*ABS(ALOG(TEST))+FNU - ZETA1 = CMPLX(AC,0.0E0) - ZETA2 = CMPLX(FNU,0.0E0) - PHI=CONE - ARG=CONE - RETURN - 15 CONTINUE - ZB = Z*CMPLX(RFNU,0.0E0) - RFNU2 = RFNU*RFNU -C----------------------------------------------------------------------- -C COMPUTE IN THE FOURTH QUADRANT -C----------------------------------------------------------------------- - FN13 = FNU**EX1 - FN23 = FN13*FN13 - RFN13 = CMPLX(1.0E0/FN13,0.0E0) - W2 = CONE - ZB*ZB - AW2 = CABS(W2) - IF (AW2.GT.0.25E0) GO TO 130 -C----------------------------------------------------------------------- -C POWER SERIES FOR CABS(W2).LE.0.25E0 -C----------------------------------------------------------------------- - K = 1 - P(1) = CONE - SUMA = CMPLX(GAMA(1),0.0E0) - AP(1) = 1.0E0 - IF (AW2.LT.TOL) GO TO 20 - DO 10 K=2,30 - P(K) = P(K-1)*W2 - SUMA = SUMA + P(K)*CMPLX(GAMA(K),0.0E0) - AP(K) = AP(K-1)*AW2 - IF (AP(K).LT.TOL) GO TO 20 - 10 CONTINUE - K = 30 - 20 CONTINUE - KMAX = K - ZETA = W2*SUMA - ARG = ZETA*CMPLX(FN23,0.0E0) - ZA = CSQRT(SUMA) - ZETA2 = CSQRT(W2)*CMPLX(FNU,0.0E0) - ZETA1 = ZETA2*(CONE+ZETA*ZA*CMPLX(EX2,0.0E0)) - ZA = ZA + ZA - PHI = CSQRT(ZA)*RFN13 - IF (IPMTR.EQ.1) GO TO 120 -C----------------------------------------------------------------------- -C SUM SERIES FOR ASUM AND BSUM -C----------------------------------------------------------------------- - SUMB = CZERO - DO 30 K=1,KMAX - SUMB = SUMB + P(K)*CMPLX(BETA(K),0.0E0) - 30 CONTINUE - ASUM = CZERO - BSUM = SUMB - L1 = 0 - L2 = 30 - BTOL = TOL*CABS(BSUM) - ATOL = TOL - PP = 1.0E0 - 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 - SUMA = CZERO - DO 40 K=1,KMAX - M = L1 + K - SUMA = SUMA + P(K)*CMPLX(ALFA(M),0.0E0) - IF (AP(K).LT.ATOL) GO TO 50 - 40 CONTINUE - 50 CONTINUE - ASUM = ASUM + SUMA*CMPLX(PP,0.0E0) - IF (PP.LT.TOL) IAS = 1 - 60 CONTINUE - IF (IBS.EQ.1) GO TO 90 - SUMB = CZERO - DO 70 K=1,KMAX - M = L2 + K - SUMB = SUMB + P(K)*CMPLX(BETA(M),0.0E0) - IF (AP(K).LT.ATOL) GO TO 80 - 70 CONTINUE - 80 CONTINUE - BSUM = BSUM + SUMB*CMPLX(PP,0.0E0) - 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 - ASUM = ASUM + CONE - PP = RFNU*REAL(RFN13) - BSUM = BSUM*CMPLX(PP,0.0E0) - 120 CONTINUE - RETURN -C----------------------------------------------------------------------- -C CABS(W2).GT.0.25E0 -C----------------------------------------------------------------------- - 130 CONTINUE - W = CSQRT(W2) - WR = REAL(W) - WI = AIMAG(W) - IF (WR.LT.0.0E0) WR = 0.0E0 - IF (WI.LT.0.0E0) WI = 0.0E0 - W = CMPLX(WR,WI) - ZA = (CONE+W)/ZB - ZC = CLOG(ZA) - ZCR = REAL(ZC) - ZCI = AIMAG(ZC) - IF (ZCI.LT.0.0E0) ZCI = 0.0E0 - IF (ZCI.GT.HPI) ZCI = HPI - IF (ZCR.LT.0.0E0) ZCR = 0.0E0 - ZC = CMPLX(ZCR,ZCI) - ZTH = (ZC-W)*CMPLX(1.5E0,0.0E0) - CFNU = CMPLX(FNU,0.0E0) - ZETA1 = ZC*CFNU - ZETA2 = W*CFNU - AZTH = CABS(ZTH) - ZTHR = REAL(ZTH) - ZTHI = AIMAG(ZTH) - ANG = THPI - IF (ZTHR.GE.0.0E0 .AND. ZTHI.LT.0.0E0) GO TO 140 - ANG = HPI - IF (ZTHR.EQ.0.0E0) GO TO 140 - ANG = ATAN(ZTHI/ZTHR) - IF (ZTHR.LT.0.0E0) ANG = ANG + PI - 140 CONTINUE - PP = AZTH**EX2 - ANG = ANG*EX2 - ZETAR = PP*COS(ANG) - ZETAI = PP*SIN(ANG) - IF (ZETAI.LT.0.0E0) ZETAI = 0.0E0 - ZETA = CMPLX(ZETAR,ZETAI) - ARG = ZETA*CMPLX(FN23,0.0E0) - RTZTA = ZTH/ZETA - ZA = RTZTA/W - PHI = CSQRT(ZA+ZA)*RFN13 - IF (IPMTR.EQ.1) GO TO 120 - TFN = CMPLX(RFNU,0.0E0)/W - RZTH = CMPLX(RFNU,0.0E0)/ZTH - ZC = RZTH*CMPLX(AR(2),0.0E0) - T2 = CONE/W2 - UP(2) = (T2*CMPLX(C(2),0.0E0)+CMPLX(C(3),0.0E0))*TFN - BSUM = UP(2) + ZC - ASUM = CZERO - IF (RFNU.LT.TOL) GO TO 220 - PRZTH = RZTH - PTFN = TFN - UP(1) = CONE - PP = 1.0E0 - BSUMR = REAL(BSUM) - BSUMI = AIMAG(BSUM) - BTOL = TOL*(ABS(BSUMR)+ABS(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 - ZA = CMPLX(C(L),0.0E0) - DO 150 J=2,KP1 - L = L + 1 - ZA = ZA*T2 + CMPLX(C(L),0.0E0) - 150 CONTINUE - PTFN = PTFN*TFN - UP(KP1) = PTFN*ZA - CR(KS) = PRZTH*CMPLX(BR(KS+1),0.0E0) - PRZTH = PRZTH*RZTH - DR(KS) = PRZTH*CMPLX(AR(KS+2),0.0E0) - 160 CONTINUE - PP = PP*RFNU2 - IF (IAS.EQ.1) GO TO 180 - SUMA = UP(LRP1) - JU = LRP1 - DO 170 JR=1,LR - JU = JU - 1 - SUMA = SUMA + CR(JR)*UP(JU) - 170 CONTINUE - ASUM = ASUM + SUMA - ASUMR = REAL(ASUM) - ASUMI = AIMAG(ASUM) - TEST = ABS(ASUMR) + ABS(ASUMI) - IF (PP.LT.TOL .AND. TEST.LT.TOL) IAS = 1 - 180 CONTINUE - IF (IBS.EQ.1) GO TO 200 - SUMB = UP(LR+2) + UP(LRP1)*ZC - JU = LRP1 - DO 190 JR=1,LR - JU = JU - 1 - SUMB = SUMB + DR(JR)*UP(JU) - 190 CONTINUE - BSUM = BSUM + SUMB - BSUMR = REAL(BSUM) - BSUMI = AIMAG(BSUM) - TEST = ABS(BSUMR) + ABS(BSUMI) - IF (PP.LT.BTOL .AND. TEST.LT.TOL) IBS = 1 - 200 CONTINUE - IF (IAS.EQ.1 .AND. IBS.EQ.1) GO TO 220 - 210 CONTINUE - 220 CONTINUE - ASUM = ASUM + CONE - BSUM = -BSUM*RFN13/RTZTA - GO TO 120 - END
--- a/liboctave/cruft/amos/cuni1.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,168 +0,0 @@ - SUBROUTINE CUNI1(Z, FNU, KODE, N, Y, NZ, NLAST, FNUL, TOL, ELIM, - * ALIM) -C***BEGIN PROLOGUE CUNI1 -C***REFER TO CBESI,CBESK -C -C CUNI1 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 CUCHK,CUNIK,CUOIK,R1MACH -C***END PROLOGUE CUNI1 - COMPLEX CFN, CONE, CRSC, CSCL, CSR, CSS, CWRK, CZERO, C1, C2, - * PHI, RZ, SUM, S1, S2, Y, Z, ZETA1, ZETA2, CY - REAL ALIM, APHI, ASCLE, BRY, C2I, C2M, C2R, ELIM, FN, FNU, FNUL, - * RS1, TOL, YY, R1MACH - INTEGER I, IFLAG, INIT, K, KODE, M, N, ND, NLAST, NN, NUF, NW, NZ - DIMENSION BRY(3), Y(N), CWRK(16), CSS(3), CSR(3), CY(2) - DATA CZERO, CONE / (0.0E0,0.0E0), (1.0E0,0.0E0) / -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 = CMPLX(1.0E0/TOL,0.0E0) - CRSC = CMPLX(TOL,0.0E0) - CSS(1) = CSCL - CSS(2) = CONE - CSS(3) = CRSC - CSR(1) = CRSC - CSR(2) = CONE - CSR(3) = CSCL - BRY(1) = 1.0E+3*R1MACH(1)/TOL -C----------------------------------------------------------------------- -C CHECK FOR UNDERFLOW AND OVERFLOW ON FIRST MEMBER -C----------------------------------------------------------------------- - FN = AMAX1(FNU,1.0E0) - INIT = 0 - CALL CUNIK(Z, FN, 1, 1, TOL, INIT, PHI, ZETA1, ZETA2, SUM, CWRK) - IF (KODE.EQ.1) GO TO 10 - CFN = CMPLX(FN,0.0E0) - S1 = -ZETA1 + CFN*(CFN/(Z+ZETA2)) - GO TO 20 - 10 CONTINUE - S1 = -ZETA1 + ZETA2 - 20 CONTINUE - RS1 = REAL(S1) - IF (ABS(RS1).GT.ELIM) GO TO 130 - 30 CONTINUE - NN = MIN0(2,ND) - DO 80 I=1,NN - FN = FNU + FLOAT(ND-I) - INIT = 0 - CALL CUNIK(Z, FN, 1, 0, TOL, INIT, PHI, ZETA1, ZETA2, SUM, CWRK) - IF (KODE.EQ.1) GO TO 40 - CFN = CMPLX(FN,0.0E0) - YY = AIMAG(Z) - S1 = -ZETA1 + CFN*(CFN/(Z+ZETA2)) + CMPLX(0.0E0,YY) - GO TO 50 - 40 CONTINUE - S1 = -ZETA1 + ZETA2 - 50 CONTINUE -C----------------------------------------------------------------------- -C TEST FOR UNDERFLOW AND OVERFLOW -C----------------------------------------------------------------------- - RS1 = REAL(S1) - IF (ABS(RS1).GT.ELIM) GO TO 110 - IF (I.EQ.1) IFLAG = 2 - IF (ABS(RS1).LT.ALIM) GO TO 60 -C----------------------------------------------------------------------- -C REFINE TEST AND SCALE -C----------------------------------------------------------------------- - APHI = CABS(PHI) - RS1 = RS1 + ALOG(APHI) - IF (ABS(RS1).GT.ELIM) GO TO 110 - IF (I.EQ.1) IFLAG = 1 - IF (RS1.LT.0.0E0) GO TO 60 - IF (I.EQ.1) IFLAG = 3 - 60 CONTINUE -C----------------------------------------------------------------------- -C SCALE S1 IF CABS(S1).LT.ASCLE -C----------------------------------------------------------------------- - S2 = PHI*SUM - C2R = REAL(S1) - C2I = AIMAG(S1) - C2M = EXP(C2R)*REAL(CSS(IFLAG)) - S1 = CMPLX(C2M,0.0E0)*CMPLX(COS(C2I),SIN(C2I)) - S2 = S2*S1 - IF (IFLAG.NE.1) GO TO 70 - CALL CUCHK(S2, NW, BRY(1), TOL) - IF (NW.NE.0) GO TO 110 - 70 CONTINUE - M = ND - I + 1 - CY(I) = S2 - Y(M) = S2*CSR(IFLAG) - 80 CONTINUE - IF (ND.LE.2) GO TO 100 - RZ = CMPLX(2.0E0,0.0E0)/Z - BRY(2) = 1.0E0/BRY(1) - BRY(3) = R1MACH(2) - S1 = CY(1) - S2 = CY(2) - C1 = CSR(IFLAG) - ASCLE = BRY(IFLAG) - K = ND - 2 - FN = FLOAT(K) - DO 90 I=3,ND - C2 = S2 - S2 = S1 + CMPLX(FNU+FN,0.0E0)*RZ*S2 - S1 = C2 - C2 = S2*C1 - Y(K) = C2 - K = K - 1 - FN = FN - 1.0E0 - IF (IFLAG.GE.3) GO TO 90 - C2R = REAL(C2) - C2I = AIMAG(C2) - C2R = ABS(C2R) - C2I = ABS(C2I) - C2M = AMAX1(C2R,C2I) - IF (C2M.LE.ASCLE) GO TO 90 - IFLAG = IFLAG + 1 - ASCLE = BRY(IFLAG) - S1 = S1*C1 - S2 = C2 - S1 = S1*CSS(IFLAG) - S2 = S2*CSS(IFLAG) - C1 = CSR(IFLAG) - 90 CONTINUE - 100 CONTINUE - RETURN -C----------------------------------------------------------------------- -C SET UNDERFLOW AND UPDATE PARAMETERS -C----------------------------------------------------------------------- - 110 CONTINUE - IF (RS1.GT.0.0E0) GO TO 120 - Y(ND) = CZERO - NZ = NZ + 1 - ND = ND - 1 - IF (ND.EQ.0) GO TO 100 - CALL CUOIK(Z, FNU, KODE, 1, ND, Y, 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 + FLOAT(ND-1) - IF (FN.GE.FNUL) GO TO 30 - NLAST = ND - RETURN - 120 CONTINUE - NZ = -1 - RETURN - 130 CONTINUE - IF (RS1.GT.0.0E0) GO TO 120 - NZ = N - DO 140 I=1,N - Y(I) = CZERO - 140 CONTINUE - RETURN - END
--- a/liboctave/cruft/amos/cuni2.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,215 +0,0 @@ - SUBROUTINE CUNI2(Z, FNU, KODE, N, Y, NZ, NLAST, FNUL, TOL, ELIM, - * ALIM) -C***BEGIN PROLOGUE CUNI2 -C***REFER TO CBESI,CBESK -C -C CUNI2 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 CAIRY,CUCHK,CUNHJ,CUOIK,R1MACH -C***END PROLOGUE CUNI2 - COMPLEX AI, ARG, ASUM, BSUM, CFN, CI, CID, CIP, CONE, CRSC, CSCL, - * CSR, CSS, CY, CZERO, C1, C2, DAI, PHI, RZ, S1, S2, Y, Z, ZB, - * ZETA1, ZETA2, ZN, ZAR - REAL AARG, AIC, ALIM, ANG, APHI, ASCLE, AY, BRY, CAR, C2I, C2M, - * C2R, ELIM, FN, FNU, FNUL, HPI, RS1, SAR, TOL, YY, R1MACH - INTEGER I, IFLAG, IN, INU, J, K, KODE, N, NAI, ND, NDAI, NLAST, - * NN, NUF, NW, NZ, IDUM - DIMENSION BRY(3), Y(N), CIP(4), CSS(3), CSR(3), CY(2) - DATA CZERO,CONE,CI/(0.0E0,0.0E0),(1.0E0,0.0E0),(0.0E0,1.0E0)/ - DATA CIP(1),CIP(2),CIP(3),CIP(4)/ - 1 (1.0E0,0.0E0), (0.0E0,1.0E0), (-1.0E0,0.0E0), (0.0E0,-1.0E0)/ - DATA HPI, AIC / - 1 1.57079632679489662E+00, 1.265512123484645396E+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 = CMPLX(1.0E0/TOL,0.0E0) - CRSC = CMPLX(TOL,0.0E0) - CSS(1) = CSCL - CSS(2) = CONE - CSS(3) = CRSC - CSR(1) = CRSC - CSR(2) = CONE - CSR(3) = CSCL - BRY(1) = 1.0E+3*R1MACH(1)/TOL - YY = AIMAG(Z) -C----------------------------------------------------------------------- -C ZN IS IN THE RIGHT HALF PLANE AFTER ROTATION BY CI OR -CI -C----------------------------------------------------------------------- - ZN = -Z*CI - ZB = Z - CID = -CI - INU = INT(FNU) - ANG = HPI*(FNU-FLOAT(INU)) - CAR = COS(ANG) - SAR = SIN(ANG) - C2 = CMPLX(CAR,SAR) - ZAR = C2 - IN = INU + N - 1 - IN = MOD(IN,4) - C2 = C2*CIP(IN+1) - IF (YY.GT.0.0E0) GO TO 10 - ZN = CONJG(-ZN) - ZB = CONJG(ZB) - CID = -CID - C2 = CONJG(C2) - 10 CONTINUE -C----------------------------------------------------------------------- -C CHECK FOR UNDERFLOW AND OVERFLOW ON FIRST MEMBER -C----------------------------------------------------------------------- - FN = AMAX1(FNU,1.0E0) - CALL CUNHJ(ZN, FN, 1, TOL, PHI, ARG, ZETA1, ZETA2, ASUM, BSUM) - IF (KODE.EQ.1) GO TO 20 - CFN = CMPLX(FNU,0.0E0) - S1 = -ZETA1 + CFN*(CFN/(ZB+ZETA2)) - GO TO 30 - 20 CONTINUE - S1 = -ZETA1 + ZETA2 - 30 CONTINUE - RS1 = REAL(S1) - IF (ABS(RS1).GT.ELIM) GO TO 150 - 40 CONTINUE - NN = MIN0(2,ND) - DO 90 I=1,NN - FN = FNU + FLOAT(ND-I) - CALL CUNHJ(ZN, FN, 0, TOL, PHI, ARG, ZETA1, ZETA2, ASUM, BSUM) - IF (KODE.EQ.1) GO TO 50 - CFN = CMPLX(FN,0.0E0) - AY = ABS(YY) - S1 = -ZETA1 + CFN*(CFN/(ZB+ZETA2)) + CMPLX(0.0E0,AY) - GO TO 60 - 50 CONTINUE - S1 = -ZETA1 + ZETA2 - 60 CONTINUE -C----------------------------------------------------------------------- -C TEST FOR UNDERFLOW AND OVERFLOW -C----------------------------------------------------------------------- - RS1 = REAL(S1) - IF (ABS(RS1).GT.ELIM) GO TO 120 - IF (I.EQ.1) IFLAG = 2 - IF (ABS(RS1).LT.ALIM) GO TO 70 -C----------------------------------------------------------------------- -C REFINE TEST AND SCALE -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - APHI = CABS(PHI) - AARG = CABS(ARG) - RS1 = RS1 + ALOG(APHI) - 0.25E0*ALOG(AARG) - AIC - IF (ABS(RS1).GT.ELIM) GO TO 120 - IF (I.EQ.1) IFLAG = 1 - IF (RS1.LT.0.0E0) 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 CAIRY(ARG, 0, 2, AI, NAI, IDUM) - CALL CAIRY(ARG, 1, 2, DAI, NDAI, IDUM) - S2 = PHI*(AI*ASUM+DAI*BSUM) - C2R = REAL(S1) - C2I = AIMAG(S1) - C2M = EXP(C2R)*REAL(CSS(IFLAG)) - S1 = CMPLX(C2M,0.0E0)*CMPLX(COS(C2I),SIN(C2I)) - S2 = S2*S1 - IF (IFLAG.NE.1) GO TO 80 - CALL CUCHK(S2, NW, BRY(1), TOL) - IF (NW.NE.0) GO TO 120 - 80 CONTINUE - IF (YY.LE.0.0E0) S2 = CONJG(S2) - J = ND - I + 1 - S2 = S2*C2 - CY(I) = S2 - Y(J) = S2*CSR(IFLAG) - C2 = C2*CID - 90 CONTINUE - IF (ND.LE.2) GO TO 110 - RZ = CMPLX(2.0E0,0.0E0)/Z - BRY(2) = 1.0E0/BRY(1) - BRY(3) = R1MACH(2) - S1 = CY(1) - S2 = CY(2) - C1 = CSR(IFLAG) - ASCLE = BRY(IFLAG) - K = ND - 2 - FN = FLOAT(K) - DO 100 I=3,ND - C2 = S2 - S2 = S1 + CMPLX(FNU+FN,0.0E0)*RZ*S2 - S1 = C2 - C2 = S2*C1 - Y(K) = C2 - K = K - 1 - FN = FN - 1.0E0 - IF (IFLAG.GE.3) GO TO 100 - C2R = REAL(C2) - C2I = AIMAG(C2) - C2R = ABS(C2R) - C2I = ABS(C2I) - C2M = AMAX1(C2R,C2I) - IF (C2M.LE.ASCLE) GO TO 100 - IFLAG = IFLAG + 1 - ASCLE = BRY(IFLAG) - S1 = S1*C1 - S2 = C2 - S1 = S1*CSS(IFLAG) - S2 = S2*CSS(IFLAG) - C1 = CSR(IFLAG) - 100 CONTINUE - 110 CONTINUE - RETURN - 120 CONTINUE - IF (RS1.GT.0.0E0) GO TO 140 -C----------------------------------------------------------------------- -C SET UNDERFLOW AND UPDATE PARAMETERS -C----------------------------------------------------------------------- - Y(ND) = CZERO - NZ = NZ + 1 - ND = ND - 1 - IF (ND.EQ.0) GO TO 110 - CALL CUOIK(Z, FNU, KODE, 1, ND, Y, 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 + FLOAT(ND-1) - IF (FN.LT.FNUL) GO TO 130 -C FN = AIMAG(CID) -C J = NUF + 1 -C K = MOD(J,4) + 1 -C S1 = CIP(K) -C IF (FN.LT.0.0E0) S1 = CONJG(S1) -C C2 = C2*S1 - IN = INU + ND - 1 - IN = MOD(IN,4) + 1 - C2 = ZAR*CIP(IN) - IF (YY.LE.0.0E0)C2=CONJG(C2) - GO TO 40 - 130 CONTINUE - NLAST = ND - RETURN - 140 CONTINUE - NZ = -1 - RETURN - 150 CONTINUE - IF (RS1.GT.0.0E0) GO TO 140 - NZ = N - DO 160 I=1,N - Y(I) = CZERO - 160 CONTINUE - RETURN - END
--- a/liboctave/cruft/amos/cunik.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,188 +0,0 @@ - SUBROUTINE CUNIK(ZR, FNU, IKFLG, IPMTR, TOL, INIT, PHI, ZETA1, - * ZETA2, SUM, CWRK) -C***BEGIN PROLOGUE CUNIK -C***REFER TO CBESI,CBESK -C -C CUNIK 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 (NONE) -C***END PROLOGUE CUNIK - COMPLEX CFN, CON, CONE, CRFN, CWRK, CZERO, PHI, S, SR, SUM, T, - * T2, ZETA1, ZETA2, ZN, ZR - REAL AC, C, FNU, RFN, TEST, TOL, TSTR, TSTI - INTEGER I, IKFLG, INIT, IPMTR, J, K, L - DIMENSION C(120), CWRK(16), CON(2) - DATA CZERO, CONE / (0.0E0,0.0E0), (1.0E0,0.0E0) / - DATA CON(1), CON(2) / - 1(3.98942280401432678E-01,0.0E0),(1.25331413731550025E+00,0.0E0)/ - 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.00000000000000000E+00, -2.08333333333333333E-01, - 4 1.25000000000000000E-01, 3.34201388888888889E-01, - 5 -4.01041666666666667E-01, 7.03125000000000000E-02, - 6 -1.02581259645061728E+00, 1.84646267361111111E+00, - 7 -8.91210937500000000E-01, 7.32421875000000000E-02, - 8 4.66958442342624743E+00, -1.12070026162229938E+01, - 9 8.78912353515625000E+00, -2.36408691406250000E+00, - A 1.12152099609375000E-01, -2.82120725582002449E+01, - B 8.46362176746007346E+01, -9.18182415432400174E+01, - C 4.25349987453884549E+01, -7.36879435947963170E+00, - D 2.27108001708984375E-01, 2.12570130039217123E+02, - E -7.65252468141181642E+02, 1.05999045252799988E+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.99579627376132541E+02, 2.18190511744211590E+02, - 4 -2.64914304869515555E+01, 5.72501420974731445E-01, - 5 -1.91945766231840700E+03, 8.06172218173730938E+03, - 6 -1.35865500064341374E+04, 1.16553933368645332E+04, - 7 -5.30564697861340311E+03, 1.20090291321635246E+03, - 8 -1.08090919788394656E+02, 1.72772750258445740E+00, - 9 2.02042913309661486E+04, -9.69805983886375135E+04, - A 1.92547001232531532E+05, -2.03400177280415534E+05, - B 1.22200464983017460E+05, -4.11926549688975513E+04, - C 7.10951430248936372E+03, -4.93915304773088012E+02, - D 6.07404200127348304E+00, -2.42919187900551333E+05, - E 1.31176361466297720E+06, -2.99801591853810675E+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.76327129765640400E+06, -2.81356322658653411E+06, - 4 1.26836527332162478E+06, -3.31645172484563578E+05, - 5 4.52187689813627263E+04, -2.49983048181120962E+03, - 6 2.43805296995560639E+01, 3.28446985307203782E+06, - 7 -1.97068191184322269E+07, 5.09526024926646422E+07, - 8 -7.41051482115326577E+07, 6.63445122747290267E+07, - 9 -3.75671766607633513E+07, 1.32887671664218183E+07, - A -2.78561812808645469E+06, 3.08186404612662398E+05, - B -1.38860897537170405E+04, 1.10017140269246738E+02, - C -4.93292536645099620E+07, 3.25573074185765749E+08, - D -9.39462359681578403E+08, 1.55359689957058006E+09, - E -1.62108055210833708E+09, 1.10684281682301447E+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.95889784275030309E+08, 1.42062907797533095E+08, - 4 -2.44740627257387285E+07, 2.24376817792244943E+06, - 5 -8.40054336030240853E+04, 5.51335896122020586E+02, - 6 8.14789096118312115E+08, -5.86648149205184723E+09, - 7 1.86882075092958249E+10, -3.46320433881587779E+10, - 8 4.12801855797539740E+10, -3.30265997498007231E+10, - 9 1.79542137311556001E+10, -6.56329379261928433E+09, - A 1.55927986487925751E+09, -2.25105661889415278E+08, - B 1.73951075539781645E+07, -5.49842327572288687E+05, - C 3.03809051092238427E+03, -1.46792612476956167E+10, - D 1.14498237732025810E+11, -3.99096175224466498E+11, - E 8.19218669548577329E+11, -1.09837515608122331E+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.00815810686538209E+12, -6.45364869245376503E+11, - 4 2.87900649906150589E+11, -8.78670721780232657E+10, - 5 1.76347306068349694E+10, -2.16716498322379509E+09, - 6 1.43157876718888981E+08, -3.87183344257261262E+06, - 7 1.82577554742931747E+04, 2.86464035717679043E+11, - 8 -2.40629790002850396E+12, 9.10934118523989896E+12, - 9 -2.05168994109344374E+13, 3.05651255199353206E+13, - A -3.16670885847851584E+13, 2.33483640445818409E+13, - B -1.23204913055982872E+13, 4.61272578084913197E+12, - C -1.19655288019618160E+12, 2.05914503232410016E+11, - D -2.18229277575292237E+10, 1.24700929351271032E+09/ - DATA C(119), C(120)/ - 1 -2.91883881222208134E+07, 1.18838426256783253E+05/ -C - IF (INIT.NE.0) GO TO 40 -C----------------------------------------------------------------------- -C INITIALIZE ALL VARIABLES -C----------------------------------------------------------------------- - RFN = 1.0E0/FNU - CRFN = CMPLX(RFN,0.0E0) -C T = ZR*CRFN -C----------------------------------------------------------------------- -C OVERFLOW TEST (ZR/FNU TOO SMALL) -C----------------------------------------------------------------------- - TSTR = REAL(ZR) - TSTI = AIMAG(ZR) - TEST = R1MACH(1)*1.0E+3 - AC = FNU*TEST - IF (ABS(TSTR).GT.AC .OR. ABS(TSTI).GT.AC) GO TO 15 - AC = 2.0E0*ABS(ALOG(TEST))+FNU - ZETA1 = CMPLX(AC,0.0E0) - ZETA2 = CMPLX(FNU,0.0E0) - PHI=CONE - RETURN - 15 CONTINUE - T=ZR*CRFN - S = CONE + T*T - SR = CSQRT(S) - CFN = CMPLX(FNU,0.0E0) - ZN = (CONE+SR)/T - ZETA1 = CFN*CLOG(ZN) - ZETA2 = CFN*SR - T = CONE/SR - SR = T*CRFN - CWRK(16) = CSQRT(SR) - PHI = CWRK(16)*CON(IKFLG) - IF (IPMTR.NE.0) RETURN - T2 = CONE/S - CWRK(1) = CONE - CRFN = CONE - AC = 1.0E0 - L = 1 - DO 20 K=2,15 - S = CZERO - DO 10 J=1,K - L = L + 1 - S = S*T2 + CMPLX(C(L),0.0E0) - 10 CONTINUE - CRFN = CRFN*SR - CWRK(K) = CRFN*S - AC = AC*RFN - TSTR = REAL(CWRK(K)) - TSTI = AIMAG(CWRK(K)) - TEST = ABS(TSTR) + ABS(TSTI) - 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----------------------------------------------------------------------- - S = CZERO - DO 50 I=1,INIT - S = S + CWRK(I) - 50 CONTINUE - SUM = S - PHI = CWRK(16)*CON(1) - RETURN - 60 CONTINUE -C----------------------------------------------------------------------- -C COMPUTE SUM FOR THE K FUNCTION -C----------------------------------------------------------------------- - S = CZERO - T = CONE - DO 70 I=1,INIT - S = S + T*CWRK(I) - T = -T - 70 CONTINUE - SUM = S - PHI = CWRK(16)*CON(2) - RETURN - END
--- a/liboctave/cruft/amos/cunk1.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,343 +0,0 @@ - SUBROUTINE CUNK1(Z, FNU, KODE, MR, N, Y, NZ, TOL, ELIM, ALIM) -C***BEGIN PROLOGUE CUNK1 -C***REFER TO CBESK -C -C CUNK1 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 CS1S2,CUCHK,CUNIK,R1MACH -C***END PROLOGUE CUNK1 - COMPLEX CFN, CK, CONE, CRSC, CS, CSCL, CSGN, CSPN, CSR, CSS, - * CWRK, CY, CZERO, C1, C2, PHI, RZ, SUM, S1, S2, Y, Z, - * ZETA1, ZETA2, ZR, PHID, ZETA1D, ZETA2D, SUMD - REAL ALIM, ANG, APHI, ASC, ASCLE, BRY, CPN, C2I, C2M, C2R, ELIM, - * FMR, FN, FNF, FNU, PI, RS1, SGN, SPN, TOL, X, R1MACH - INTEGER I, IB, IFLAG, IFN, IL, INIT, INU, IUF, K, KDFLG, KFLAG, - * KK, KODE, MR, N, NW, NZ, J, IPARD, INITD, IC - DIMENSION BRY(3), INIT(2), Y(N), SUM(2), PHI(2), ZETA1(2), - * ZETA2(2), CY(2), CWRK(16,3), CSS(3), CSR(3) - DATA CZERO, CONE / (0.0E0,0.0E0) , (1.0E0,0.0E0) / - DATA PI / 3.14159265358979324E0 / -C - KDFLG = 1 - NZ = 0 -C----------------------------------------------------------------------- -C EXP(-ALIM)=EXP(-ELIM)/TOL=APPROX. ONE PRECISION GREATER THAN -C THE UNDERFLOW LIMIT -C----------------------------------------------------------------------- - CSCL = CMPLX(1.0E0/TOL,0.0E0) - CRSC = CMPLX(TOL,0.0E0) - CSS(1) = CSCL - CSS(2) = CONE - CSS(3) = CRSC - CSR(1) = CRSC - CSR(2) = CONE - CSR(3) = CSCL - BRY(1) = 1.0E+3*R1MACH(1)/TOL - BRY(2) = 1.0E0/BRY(1) - BRY(3) = R1MACH(2) - X = REAL(Z) - ZR = Z - IF (X.LT.0.0E0) ZR = -Z - 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 + FLOAT(I-1) - INIT(J) = 0 - CALL CUNIK(ZR, FN, 2, 0, TOL, INIT(J), PHI(J), ZETA1(J), - * ZETA2(J), SUM(J), CWRK(1,J)) - IF (KODE.EQ.1) GO TO 20 - CFN = CMPLX(FN,0.0E0) - S1 = ZETA1(J) - CFN*(CFN/(ZR+ZETA2(J))) - GO TO 30 - 20 CONTINUE - S1 = ZETA1(J) - ZETA2(J) - 30 CONTINUE -C----------------------------------------------------------------------- -C TEST FOR UNDERFLOW AND OVERFLOW -C----------------------------------------------------------------------- - RS1 = REAL(S1) - IF (ABS(RS1).GT.ELIM) GO TO 60 - IF (KDFLG.EQ.1) KFLAG = 2 - IF (ABS(RS1).LT.ALIM) GO TO 40 -C----------------------------------------------------------------------- -C REFINE TEST AND SCALE -C----------------------------------------------------------------------- - APHI = CABS(PHI(J)) - RS1 = RS1 + ALOG(APHI) - IF (ABS(RS1).GT.ELIM) GO TO 60 - IF (KDFLG.EQ.1) KFLAG = 1 - IF (RS1.LT.0.0E0) 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----------------------------------------------------------------------- - S2 = PHI(J)*SUM(J) - C2R = REAL(S1) - C2I = AIMAG(S1) - C2M = EXP(C2R)*REAL(CSS(KFLAG)) - S1 = CMPLX(C2M,0.0E0)*CMPLX(COS(C2I),SIN(C2I)) - S2 = S2*S1 - IF (KFLAG.NE.1) GO TO 50 - CALL CUCHK(S2, NW, BRY(1), TOL) - IF (NW.NE.0) GO TO 60 - 50 CONTINUE - CY(KDFLG) = S2 - Y(I) = S2*CSR(KFLAG) - IF (KDFLG.EQ.2) GO TO 75 - KDFLG = 2 - GO TO 70 - 60 CONTINUE - IF (RS1.GT.0.0E0) GO TO 290 -C----------------------------------------------------------------------- -C FOR X.LT.0.0, THE I FUNCTION TO BE ADDED WILL OVERFLOW -C----------------------------------------------------------------------- - IF (X.LT.0.0E0) GO TO 290 - KDFLG = 1 - Y(I) = CZERO - NZ=NZ+1 - IF (I.EQ.1) GO TO 70 - IF (Y(I-1).EQ.CZERO) GO TO 70 - Y(I-1) = CZERO - NZ=NZ+1 - 70 CONTINUE - I=N - 75 CONTINUE - RZ = CMPLX(2.0E0,0.0E0)/ZR - CK = CMPLX(FN,0.0E0)*RZ - 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+FLOAT(N-1) - IPARD = 1 - IF (MR.NE.0) IPARD = 0 - INITD = 0 - CALL CUNIK(ZR,FN,2,IPARD,TOL,INITD,PHID,ZETA1D,ZETA2D,SUMD, - *CWRK(1,3)) - IF (KODE.EQ.1) GO TO 80 - CFN=CMPLX(FN,0.0E0) - S1=ZETA1D-CFN*(CFN/(ZR+ZETA2D)) - GO TO 90 - 80 CONTINUE - S1=ZETA1D-ZETA2D - 90 CONTINUE - RS1=REAL(S1) - IF (ABS(RS1).GT.ELIM) GO TO 95 - IF (ABS(RS1).LT.ALIM) GO TO 100 -C----------------------------------------------------------------------- -C REFINE ESTIMATE AND TEST -C----------------------------------------------------------------------- - APHI=CABS(PHID) - RS1=RS1+ALOG(APHI) - IF (ABS(RS1).LT.ELIM) GO TO 100 - 95 CONTINUE - IF (RS1.GT.0.0E0) GO TO 290 -C----------------------------------------------------------------------- -C FOR X.LT.0.0, THE I FUNCTION TO BE ADDED WILL OVERFLOW -C----------------------------------------------------------------------- - IF (X.LT.0.0E0) GO TO 290 - NZ=N - DO 96 I=1,N - Y(I) = CZERO - 96 CONTINUE - RETURN - 100 CONTINUE -C----------------------------------------------------------------------- -C RECUR FORWARD FOR REMAINDER OF THE SEQUENCE -C----------------------------------------------------------------------- - S1 = CY(1) - S2 = CY(2) - C1 = CSR(KFLAG) - ASCLE = BRY(KFLAG) - DO 120 I=IB,N - C2 = S2 - S2 = CK*S2 + S1 - S1 = C2 - CK = CK + RZ - C2 = S2*C1 - Y(I) = C2 - IF (KFLAG.GE.3) GO TO 120 - C2R = REAL(C2) - C2I = AIMAG(C2) - C2R = ABS(C2R) - C2I = ABS(C2I) - C2M = AMAX1(C2R,C2I) - IF (C2M.LE.ASCLE) GO TO 120 - KFLAG = KFLAG + 1 - ASCLE = BRY(KFLAG) - S1 = S1*C1 - S2 = C2 - S1 = S1*CSS(KFLAG) - S2 = S2*CSS(KFLAG) - C1 = CSR(KFLAG) - 120 CONTINUE - 160 CONTINUE - IF (MR.EQ.0) RETURN -C----------------------------------------------------------------------- -C ANALYTIC CONTINUATION FOR RE(Z).LT.0.0E0 -C----------------------------------------------------------------------- - NZ = 0 - FMR = FLOAT(MR) - SGN = -SIGN(PI,FMR) -C----------------------------------------------------------------------- -C CSPN AND CSGN ARE COEFF OF K AND I FUNCIONS RESP. -C----------------------------------------------------------------------- - CSGN = CMPLX(0.0E0,SGN) - INU = INT(FNU) - FNF = FNU - FLOAT(INU) - IFN = INU + N - 1 - ANG = FNF*SGN - CPN = COS(ANG) - SPN = SIN(ANG) - CSPN = CMPLX(CPN,SPN) - IF (MOD(IFN,2).EQ.1) CSPN = -CSPN - ASC = BRY(1) - KK = N - IUF = 0 - KDFLG = 1 - IB = IB-1 - IC = IB-1 - DO 260 K=1,N - FN = FNU + 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 - 170 CONTINUE - INITD = INIT(J) - PHID = PHI(J) - ZETA1D = ZETA1(J) - ZETA2D = ZETA2(J) - SUMD = SUM(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 170 - INITD = 0 - 180 CONTINUE - CALL CUNIK(ZR, FN, 1, 0, TOL, INITD, PHID, ZETA1D, - * ZETA2D, SUMD, CWRK(1,M)) - IF (KODE.EQ.1) GO TO 190 - CFN = CMPLX(FN,0.0E0) - S1 = -ZETA1D + CFN*(CFN/(ZR+ZETA2D)) - GO TO 200 - 190 CONTINUE - S1 = -ZETA1D + ZETA2D - 200 CONTINUE -C----------------------------------------------------------------------- -C TEST FOR UNDERFLOW AND OVERFLOW -C----------------------------------------------------------------------- - RS1 = REAL(S1) - IF (ABS(RS1).GT.ELIM) GO TO 250 - IF (KDFLG.EQ.1) IFLAG = 2 - IF (ABS(RS1).LT.ALIM) GO TO 210 -C----------------------------------------------------------------------- -C REFINE TEST AND SCALE -C----------------------------------------------------------------------- - APHI = CABS(PHID) - RS1 = RS1 + ALOG(APHI) - IF (ABS(RS1).GT.ELIM) GO TO 250 - IF (KDFLG.EQ.1) IFLAG = 1 - IF (RS1.LT.0.0E0) GO TO 210 - IF (KDFLG.EQ.1) IFLAG = 3 - 210 CONTINUE - S2 = CSGN*PHID*SUMD - C2R = REAL(S1) - C2I = AIMAG(S1) - C2M = EXP(C2R)*REAL(CSS(IFLAG)) - S1 = CMPLX(C2M,0.0E0)*CMPLX(COS(C2I),SIN(C2I)) - S2 = S2*S1 - IF (IFLAG.NE.1) GO TO 220 - CALL CUCHK(S2, NW, BRY(1), TOL) - IF (NW.NE.0) S2 = CMPLX(0.0E0,0.0E0) - 220 CONTINUE - CY(KDFLG) = S2 - C2 = S2 - S2 = S2*CSR(IFLAG) -C----------------------------------------------------------------------- -C ADD I AND K FUNCTIONS, K SEQUENCE IN Y(I), I=1,N -C----------------------------------------------------------------------- - S1 = Y(KK) - IF (KODE.EQ.1) GO TO 240 - CALL CS1S2(ZR, S1, S2, NW, ASC, ALIM, IUF) - NZ = NZ + NW - 240 CONTINUE - Y(KK) = S1*CSPN + S2 - KK = KK - 1 - CSPN = -CSPN - IF (C2.NE.CZERO) GO TO 245 - KDFLG = 1 - GO TO 260 - 245 CONTINUE - IF (KDFLG.EQ.2) GO TO 265 - KDFLG = 2 - GO TO 260 - 250 CONTINUE - IF (RS1.GT.0.0E0) GO TO 290 - S2 = CZERO - GO TO 220 - 260 CONTINUE - K = N - 265 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----------------------------------------------------------------------- - S1 = CY(1) - S2 = CY(2) - CS = CSR(IFLAG) - ASCLE = BRY(IFLAG) - FN = FLOAT(INU+IL) - DO 280 I=1,IL - C2 = S2 - S2 = S1 + CMPLX(FN+FNF,0.0E0)*RZ*S2 - S1 = C2 - FN = FN - 1.0E0 - C2 = S2*CS - CK = C2 - C1 = Y(KK) - IF (KODE.EQ.1) GO TO 270 - CALL CS1S2(ZR, C1, C2, NW, ASC, ALIM, IUF) - NZ = NZ + NW - 270 CONTINUE - Y(KK) = C1*CSPN + C2 - KK = KK - 1 - CSPN = -CSPN - IF (IFLAG.GE.3) GO TO 280 - C2R = REAL(CK) - C2I = AIMAG(CK) - C2R = ABS(C2R) - C2I = ABS(C2I) - C2M = AMAX1(C2R,C2I) - IF (C2M.LE.ASCLE) GO TO 280 - IFLAG = IFLAG + 1 - ASCLE = BRY(IFLAG) - S1 = S1*CS - S2 = CK - S1 = S1*CSS(IFLAG) - S2 = S2*CSS(IFLAG) - CS = CSR(IFLAG) - 280 CONTINUE - RETURN - 290 CONTINUE - NZ = -1 - RETURN - END
--- a/liboctave/cruft/amos/cunk2.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,393 +0,0 @@ - SUBROUTINE CUNK2(Z, FNU, KODE, MR, N, Y, NZ, TOL, ELIM, ALIM) -C***BEGIN PROLOGUE CUNK2 -C***REFER TO CBESK -C -C CUNK2 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 CAIRY,CS1S2,CUCHK,CUNHJ,R1MACH -C***END PROLOGUE CUNK2 - COMPLEX AI, ARG, ASUM, BSUM, CFN, CI, CIP, - * CK, CONE, CRSC, CR1, CR2, CS, CSCL, CSGN, CSPN, CSR, CSS, CY, - * CZERO, C1, C2, DAI, PHI, RZ, S1, S2, Y, Z, ZB, ZETA1, - * ZETA2, ZN, ZR, PHID, ARGD, ZETA1D, ZETA2D, ASUMD, BSUMD - REAL AARG, AIC, ALIM, ANG, APHI, ASC, ASCLE, BRY, CAR, CPN, C2I, - * C2M, C2R, ELIM, FMR, FN, FNF, FNU, HPI, PI, RS1, SAR, SGN, SPN, - * TOL, X, YY, R1MACH - 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), Y(N), ASUM(2), BSUM(2), PHI(2), ARG(2), - * ZETA1(2), ZETA2(2), CY(2), CIP(4), CSS(3), CSR(3) - DATA CZERO, CONE, CI, CR1, CR2 / - 1 (0.0E0,0.0E0),(1.0E0,0.0E0),(0.0E0,1.0E0), - 1(1.0E0,1.73205080756887729E0),(-0.5E0,-8.66025403784438647E-01)/ - DATA HPI, PI, AIC / - 1 1.57079632679489662E+00, 3.14159265358979324E+00, - 1 1.26551212348464539E+00/ - DATA CIP(1),CIP(2),CIP(3),CIP(4)/ - 1 (1.0E0,0.0E0), (0.0E0,-1.0E0), (-1.0E0,0.0E0), (0.0E0,1.0E0)/ -C - KDFLG = 1 - NZ = 0 -C----------------------------------------------------------------------- -C EXP(-ALIM)=EXP(-ELIM)/TOL=APPROX. ONE PRECISION GREATER THAN -C THE UNDERFLOW LIMIT -C----------------------------------------------------------------------- - CSCL = CMPLX(1.0E0/TOL,0.0E0) - CRSC = CMPLX(TOL,0.0E0) - CSS(1) = CSCL - CSS(2) = CONE - CSS(3) = CRSC - CSR(1) = CRSC - CSR(2) = CONE - CSR(3) = CSCL - BRY(1) = 1.0E+3*R1MACH(1)/TOL - BRY(2) = 1.0E0/BRY(1) - BRY(3) = R1MACH(2) - X = REAL(Z) - ZR = Z - IF (X.LT.0.0E0) ZR = -Z - YY = AIMAG(ZR) - ZN = -ZR*CI - ZB = ZR - INU = INT(FNU) - FNF = FNU - FLOAT(INU) - ANG = -HPI*FNF - CAR = COS(ANG) - SAR = SIN(ANG) - CPN = -HPI*CAR - SPN = -HPI*SAR - C2 = CMPLX(-SPN,CPN) - KK = MOD(INU,4) + 1 - CS = CR1*C2*CIP(KK) - IF (YY.GT.0.0E0) GO TO 10 - ZN = CONJG(-ZN) - ZB = CONJG(ZB) - 10 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 70 I=1,N -C----------------------------------------------------------------------- -C J FLIP FLOPS BETWEEN 1 AND 2 IN J = 3 - J -C----------------------------------------------------------------------- - J = 3 - J - FN = FNU + FLOAT(I-1) - CALL CUNHJ(ZN, FN, 0, TOL, PHI(J), ARG(J), ZETA1(J), ZETA2(J), - * ASUM(J), BSUM(J)) - IF (KODE.EQ.1) GO TO 20 - CFN = CMPLX(FN,0.0E0) - S1 = ZETA1(J) - CFN*(CFN/(ZB+ZETA2(J))) - GO TO 30 - 20 CONTINUE - S1 = ZETA1(J) - ZETA2(J) - 30 CONTINUE -C----------------------------------------------------------------------- -C TEST FOR UNDERFLOW AND OVERFLOW -C----------------------------------------------------------------------- - RS1 = REAL(S1) - IF (ABS(RS1).GT.ELIM) GO TO 60 - IF (KDFLG.EQ.1) KFLAG = 2 - IF (ABS(RS1).LT.ALIM) GO TO 40 -C----------------------------------------------------------------------- -C REFINE TEST AND SCALE -C----------------------------------------------------------------------- - APHI = CABS(PHI(J)) - AARG = CABS(ARG(J)) - RS1 = RS1 + ALOG(APHI) - 0.25E0*ALOG(AARG) - AIC - IF (ABS(RS1).GT.ELIM) GO TO 60 - IF (KDFLG.EQ.1) KFLAG = 1 - IF (RS1.LT.0.0E0) 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----------------------------------------------------------------------- - C2 = ARG(J)*CR2 - CALL CAIRY(C2, 0, 2, AI, NAI, IDUM) - CALL CAIRY(C2, 1, 2, DAI, NDAI, IDUM) - S2 = CS*PHI(J)*(AI*ASUM(J)+CR2*DAI*BSUM(J)) - C2R = REAL(S1) - C2I = AIMAG(S1) - C2M = EXP(C2R)*REAL(CSS(KFLAG)) - S1 = CMPLX(C2M,0.0E0)*CMPLX(COS(C2I),SIN(C2I)) - S2 = S2*S1 - IF (KFLAG.NE.1) GO TO 50 - CALL CUCHK(S2, NW, BRY(1), TOL) - IF (NW.NE.0) GO TO 60 - 50 CONTINUE - IF (YY.LE.0.0E0) S2 = CONJG(S2) - CY(KDFLG) = S2 - Y(I) = S2*CSR(KFLAG) - CS = -CI*CS - IF (KDFLG.EQ.2) GO TO 75 - KDFLG = 2 - GO TO 70 - 60 CONTINUE - IF (RS1.GT.0.0E0) GO TO 300 -C----------------------------------------------------------------------- -C FOR X.LT.0.0, THE I FUNCTION TO BE ADDED WILL OVERFLOW -C----------------------------------------------------------------------- - IF (X.LT.0.0E0) GO TO 300 - KDFLG = 1 - Y(I) = CZERO - CS = -CI*CS - NZ=NZ+1 - IF (I.EQ.1) GO TO 70 - IF (Y(I-1).EQ.CZERO) GO TO 70 - Y(I-1) = CZERO - NZ=NZ+1 - 70 CONTINUE - I=N - 75 CONTINUE - RZ = CMPLX(2.0E0,0.0E0)/ZR - CK = CMPLX(FN,0.0E0)*RZ - IB = I + 1 - IF (N.LT.IB) GO TO 170 -C----------------------------------------------------------------------- -C TEST LAST MEMBER FOR UNDERFLOW AND OVERFLOW, SET SEQUENCE TO ZERO -C ON UNDERFLOW -C----------------------------------------------------------------------- - FN = FNU+FLOAT(N-1) - IPARD = 1 - IF (MR.NE.0) IPARD = 0 - CALL CUNHJ(ZN,FN,IPARD,TOL,PHID,ARGD,ZETA1D,ZETA2D,ASUMD,BSUMD) - IF (KODE.EQ.1) GO TO 80 - CFN=CMPLX(FN,0.0E0) - S1=ZETA1D-CFN*(CFN/(ZB+ZETA2D)) - GO TO 90 - 80 CONTINUE - S1=ZETA1D-ZETA2D - 90 CONTINUE - RS1=REAL(S1) - IF (ABS(RS1).GT.ELIM) GO TO 95 - IF (ABS(RS1).LT.ALIM) GO TO 100 -C----------------------------------------------------------------------- -C REFINE ESTIMATE AND TEST -C----------------------------------------------------------------------- - APHI=CABS(PHID) - AARG = CABS(ARGD) - RS1=RS1+ALOG(APHI)-0.25E0*ALOG(AARG)-AIC - IF (ABS(RS1).LT.ELIM) GO TO 100 - 95 CONTINUE - IF (RS1.GT.0.0E0) GO TO 300 -C----------------------------------------------------------------------- -C FOR X.LT.0.0, THE I FUNCTION TO BE ADDED WILL OVERFLOW -C----------------------------------------------------------------------- - IF (X.LT.0.0E0) GO TO 300 - NZ=N - DO 96 I=1,N - Y(I) = CZERO - 96 CONTINUE - RETURN - 100 CONTINUE -C----------------------------------------------------------------------- -C SCALED FORWARD RECURRENCE FOR REMAINDER OF THE SEQUENCE -C----------------------------------------------------------------------- - S1 = CY(1) - S2 = CY(2) - C1 = CSR(KFLAG) - ASCLE = BRY(KFLAG) - DO 120 I=IB,N - C2 = S2 - S2 = CK*S2 + S1 - S1 = C2 - CK = CK + RZ - C2 = S2*C1 - Y(I) = C2 - IF (KFLAG.GE.3) GO TO 120 - C2R = REAL(C2) - C2I = AIMAG(C2) - C2R = ABS(C2R) - C2I = ABS(C2I) - C2M = AMAX1(C2R,C2I) - IF (C2M.LE.ASCLE) GO TO 120 - KFLAG = KFLAG + 1 - ASCLE = BRY(KFLAG) - S1 = S1*C1 - S2 = C2 - S1 = S1*CSS(KFLAG) - S2 = S2*CSS(KFLAG) - C1 = CSR(KFLAG) - 120 CONTINUE - 170 CONTINUE - IF (MR.EQ.0) RETURN -C----------------------------------------------------------------------- -C ANALYTIC CONTINUATION FOR RE(Z).LT.0.0E0 -C----------------------------------------------------------------------- - NZ = 0 - FMR = FLOAT(MR) - SGN = -SIGN(PI,FMR) -C----------------------------------------------------------------------- -C CSPN AND CSGN ARE COEFF OF K AND I FUNCTIONS RESP. -C----------------------------------------------------------------------- - CSGN = CMPLX(0.0E0,SGN) - IF (YY.LE.0.0E0) CSGN = CONJG(CSGN) - IFN = INU + N - 1 - ANG = FNF*SGN - CPN = COS(ANG) - SPN = SIN(ANG) - CSPN = CMPLX(CPN,SPN) - IF (MOD(IFN,2).EQ.1) CSPN = -CSPN -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----------------------------------------------------------------------- - CS = CMPLX(CAR,-SAR)*CSGN - IN = MOD(IFN,4) + 1 - C2 = CIP(IN) - CS = CS*CONJG(C2) - ASC = BRY(1) - KK = N - KDFLG = 1 - IB = IB-1 - IC = IB-1 - IUF = 0 - DO 270 K=1,N -C----------------------------------------------------------------------- -C LOGIC TO SORT OUT CASES WHOSE PARAMETERS WERE SET FOR THE K -C FUNCTION ABOVE -C----------------------------------------------------------------------- - FN = FNU+FLOAT(KK-1) - IF (N.GT.2) GO TO 180 - 175 CONTINUE - PHID = PHI(J) - ARGD = ARG(J) - ZETA1D = ZETA1(J) - ZETA2D = ZETA2(J) - ASUMD = ASUM(J) - BSUMD = BSUM(J) - J = 3 - J - GO TO 190 - 180 CONTINUE - IF ((KK.EQ.N).AND.(IB.LT.N)) GO TO 190 - IF ((KK.EQ.IB).OR.(KK.EQ.IC)) GO TO 175 - CALL CUNHJ(ZN, FN, 0, TOL, PHID, ARGD, ZETA1D, ZETA2D, - * ASUMD, BSUMD) - 190 CONTINUE - IF (KODE.EQ.1) GO TO 200 - CFN = CMPLX(FN,0.0E0) - S1 = -ZETA1D + CFN*(CFN/(ZB+ZETA2D)) - GO TO 210 - 200 CONTINUE - S1 = -ZETA1D + ZETA2D - 210 CONTINUE -C----------------------------------------------------------------------- -C TEST FOR UNDERFLOW AND OVERFLOW -C----------------------------------------------------------------------- - RS1 = REAL(S1) - IF (ABS(RS1).GT.ELIM) GO TO 260 - IF (KDFLG.EQ.1) IFLAG = 2 - IF (ABS(RS1).LT.ALIM) GO TO 220 -C----------------------------------------------------------------------- -C REFINE TEST AND SCALE -C----------------------------------------------------------------------- - APHI = CABS(PHID) - AARG = CABS(ARGD) - RS1 = RS1 + ALOG(APHI) - 0.25E0*ALOG(AARG) - AIC - IF (ABS(RS1).GT.ELIM) GO TO 260 - IF (KDFLG.EQ.1) IFLAG = 1 - IF (RS1.LT.0.0E0) GO TO 220 - IF (KDFLG.EQ.1) IFLAG = 3 - 220 CONTINUE - CALL CAIRY(ARGD, 0, 2, AI, NAI, IDUM) - CALL CAIRY(ARGD, 1, 2, DAI, NDAI, IDUM) - S2 = CS*PHID*(AI*ASUMD+DAI*BSUMD) - C2R = REAL(S1) - C2I = AIMAG(S1) - C2M = EXP(C2R)*REAL(CSS(IFLAG)) - S1 = CMPLX(C2M,0.0E0)*CMPLX(COS(C2I),SIN(C2I)) - S2 = S2*S1 - IF (IFLAG.NE.1) GO TO 230 - CALL CUCHK(S2, NW, BRY(1), TOL) - IF (NW.NE.0) S2 = CMPLX(0.0E0,0.0E0) - 230 CONTINUE - IF (YY.LE.0.0E0) S2 = CONJG(S2) - CY(KDFLG) = S2 - C2 = S2 - S2 = S2*CSR(IFLAG) -C----------------------------------------------------------------------- -C ADD I AND K FUNCTIONS, K SEQUENCE IN Y(I), I=1,N -C----------------------------------------------------------------------- - S1 = Y(KK) - IF (KODE.EQ.1) GO TO 250 - CALL CS1S2(ZR, S1, S2, NW, ASC, ALIM, IUF) - NZ = NZ + NW - 250 CONTINUE - Y(KK) = S1*CSPN + S2 - KK = KK - 1 - CSPN = -CSPN - CS = -CS*CI - IF (C2.NE.CZERO) 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.0E0) GO TO 300 - S2 = CZERO - 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----------------------------------------------------------------------- - S1 = CY(1) - S2 = CY(2) - CS = CSR(IFLAG) - ASCLE = BRY(IFLAG) - FN = FLOAT(INU+IL) - DO 290 I=1,IL - C2 = S2 - S2 = S1 + CMPLX(FN+FNF,0.0E0)*RZ*S2 - S1 = C2 - FN = FN - 1.0E0 - C2 = S2*CS - CK = C2 - C1 = Y(KK) - IF (KODE.EQ.1) GO TO 280 - CALL CS1S2(ZR, C1, C2, NW, ASC, ALIM, IUF) - NZ = NZ + NW - 280 CONTINUE - Y(KK) = C1*CSPN + C2 - KK = KK - 1 - CSPN = -CSPN - IF (IFLAG.GE.3) GO TO 290 - C2R = REAL(CK) - C2I = AIMAG(CK) - C2R = ABS(C2R) - C2I = ABS(C2I) - C2M = AMAX1(C2R,C2I) - IF (C2M.LE.ASCLE) GO TO 290 - IFLAG = IFLAG + 1 - ASCLE = BRY(IFLAG) - S1 = S1*CS - S2 = CK - S1 = S1*CSS(IFLAG) - S2 = S2*CSS(IFLAG) - CS = CSR(IFLAG) - 290 CONTINUE - RETURN - 300 CONTINUE - NZ = -1 - RETURN - END
--- a/liboctave/cruft/amos/cuoik.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,159 +0,0 @@ - SUBROUTINE CUOIK(Z, FNU, KODE, IKFLG, N, Y, NUF, TOL, ELIM, ALIM) -C***BEGIN PROLOGUE CUOIK -C***REFER TO CBESI,CBESK,CBESH -C -C CUOIK 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 CUCHK,CUNHJ,CUNIK,R1MACH -C***END PROLOGUE CUOIK - COMPLEX ARG, ASUM, BSUM, CWRK, CZ, CZERO, PHI, SUM, Y, Z, ZB, - * ZETA1, ZETA2, ZN, ZR - REAL AARG, AIC, ALIM, APHI, ASCLE, AX, AY, ELIM, FNN, FNU, GNN, - * GNU, RCZ, TOL, X, YY - INTEGER I, IFORM, IKFLG, INIT, KODE, N, NN, NUF, NW - DIMENSION Y(N), CWRK(16) - DATA CZERO / (0.0E0,0.0E0) / - DATA AIC / 1.265512123484645396E+00 / - NUF = 0 - NN = N - X = REAL(Z) - ZR = Z - IF (X.LT.0.0E0) ZR = -Z - ZB = ZR - YY = AIMAG(ZR) - AX = ABS(X)*1.7321E0 - AY = ABS(YY) - IFORM = 1 - IF (AY.GT.AX) IFORM = 2 - GNU = AMAX1(FNU,1.0E0) - IF (IKFLG.EQ.1) GO TO 10 - FNN = FLOAT(NN) - GNN = FNU + FNN - 1.0E0 - GNU = AMAX1(GNN,FNN) - 10 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 20 - INIT = 0 - CALL CUNIK(ZR, GNU, IKFLG, 1, TOL, INIT, PHI, ZETA1, ZETA2, SUM, - * CWRK) - CZ = -ZETA1 + ZETA2 - GO TO 40 - 20 CONTINUE - ZN = -ZR*CMPLX(0.0E0,1.0E0) - IF (YY.GT.0.0E0) GO TO 30 - ZN = CONJG(-ZN) - 30 CONTINUE - CALL CUNHJ(ZN, GNU, 1, TOL, PHI, ARG, ZETA1, ZETA2, ASUM, BSUM) - CZ = -ZETA1 + ZETA2 - AARG = CABS(ARG) - 40 CONTINUE - IF (KODE.EQ.2) CZ = CZ - ZB - IF (IKFLG.EQ.2) CZ = -CZ - APHI = CABS(PHI) - RCZ = REAL(CZ) -C----------------------------------------------------------------------- -C OVERFLOW TEST -C----------------------------------------------------------------------- - IF (RCZ.GT.ELIM) GO TO 170 - IF (RCZ.LT.ALIM) GO TO 50 - RCZ = RCZ + ALOG(APHI) - IF (IFORM.EQ.2) RCZ = RCZ - 0.25E0*ALOG(AARG) - AIC - IF (RCZ.GT.ELIM) GO TO 170 - GO TO 100 - 50 CONTINUE -C----------------------------------------------------------------------- -C UNDERFLOW TEST -C----------------------------------------------------------------------- - IF (RCZ.LT.(-ELIM)) GO TO 60 - IF (RCZ.GT.(-ALIM)) GO TO 100 - RCZ = RCZ + ALOG(APHI) - IF (IFORM.EQ.2) RCZ = RCZ - 0.25E0*ALOG(AARG) - AIC - IF (RCZ.GT.(-ELIM)) GO TO 80 - 60 CONTINUE - DO 70 I=1,NN - Y(I) = CZERO - 70 CONTINUE - NUF = NN - RETURN - 80 CONTINUE - ASCLE = 1.0E+3*R1MACH(1)/TOL - CZ = CZ + CLOG(PHI) - IF (IFORM.EQ.1) GO TO 90 - CZ = CZ - CMPLX(0.25E0,0.0E0)*CLOG(ARG) - CMPLX(AIC,0.0E0) - 90 CONTINUE - AX = EXP(RCZ)/TOL - AY = AIMAG(CZ) - CZ = CMPLX(AX,0.0E0)*CMPLX(COS(AY),SIN(AY)) - CALL CUCHK(CZ, NW, ASCLE, TOL) - IF (NW.EQ.1) GO TO 60 - 100 CONTINUE - IF (IKFLG.EQ.2) RETURN - IF (N.EQ.1) RETURN -C----------------------------------------------------------------------- -C SET UNDERFLOWS ON I SEQUENCE -C----------------------------------------------------------------------- - 110 CONTINUE - GNU = FNU + FLOAT(NN-1) - IF (IFORM.EQ.2) GO TO 120 - INIT = 0 - CALL CUNIK(ZR, GNU, IKFLG, 1, TOL, INIT, PHI, ZETA1, ZETA2, SUM, - * CWRK) - CZ = -ZETA1 + ZETA2 - GO TO 130 - 120 CONTINUE - CALL CUNHJ(ZN, GNU, 1, TOL, PHI, ARG, ZETA1, ZETA2, ASUM, BSUM) - CZ = -ZETA1 + ZETA2 - AARG = CABS(ARG) - 130 CONTINUE - IF (KODE.EQ.2) CZ = CZ - ZB - APHI = CABS(PHI) - RCZ = REAL(CZ) - IF (RCZ.LT.(-ELIM)) GO TO 140 - IF (RCZ.GT.(-ALIM)) RETURN - RCZ = RCZ + ALOG(APHI) - IF (IFORM.EQ.2) RCZ = RCZ - 0.25E0*ALOG(AARG) - AIC - IF (RCZ.GT.(-ELIM)) GO TO 150 - 140 CONTINUE - Y(NN) = CZERO - NN = NN - 1 - NUF = NUF + 1 - IF (NN.EQ.0) RETURN - GO TO 110 - 150 CONTINUE - ASCLE = 1.0E+3*R1MACH(1)/TOL - CZ = CZ + CLOG(PHI) - IF (IFORM.EQ.1) GO TO 160 - CZ = CZ - CMPLX(0.25E0,0.0E0)*CLOG(ARG) - CMPLX(AIC,0.0E0) - 160 CONTINUE - AX = EXP(RCZ)/TOL - AY = AIMAG(CZ) - CZ = CMPLX(AX,0.0E0)*CMPLX(COS(AY),SIN(AY)) - CALL CUCHK(CZ, NW, ASCLE, TOL) - IF (NW.EQ.1) GO TO 140 - RETURN - 170 CONTINUE - NUF = -1 - RETURN - END
--- a/liboctave/cruft/amos/cwrsk.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,75 +0,0 @@ - SUBROUTINE CWRSK(ZR, FNU, KODE, N, Y, NZ, CW, TOL, ELIM, ALIM) -C***BEGIN PROLOGUE CWRSK -C***REFER TO CBESI,CBESK -C -C CWRSK COMPUTES THE I BESSEL FUNCTION FOR RE(Z).GE.0.0 BY -C NORMALIZING THE I FUNCTION RATIOS FROM CRATI BY THE WRONSKIAN -C -C***ROUTINES CALLED CBKNU,CRATI,R1MACH -C***END PROLOGUE CWRSK - COMPLEX CINU, CSCL, CT, CW, C1, C2, RCT, ST, Y, ZR - REAL ACT, ACW, ALIM, ASCLE, ELIM, FNU, S1, S2, TOL, YY - INTEGER I, KODE, N, NW, NZ - DIMENSION Y(N), CW(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 CBKNU(ZR, FNU, KODE, 2, CW, NW, TOL, ELIM, ALIM) - IF (NW.NE.0) GO TO 50 - CALL CRATI(ZR, FNU, N, Y, 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----------------------------------------------------------------------- - CINU = CMPLX(1.0E0,0.0E0) - IF (KODE.EQ.1) GO TO 10 - YY = AIMAG(ZR) - S1 = COS(YY) - S2 = SIN(YY) - CINU = CMPLX(S1,S2) - 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 = CABS(CW(2)) - ASCLE = 1.0E+3*R1MACH(1)/TOL - CSCL = CMPLX(1.0E0,0.0E0) - IF (ACW.GT.ASCLE) GO TO 20 - CSCL = CMPLX(1.0E0/TOL,0.0E0) - GO TO 30 - 20 CONTINUE - ASCLE = 1.0E0/ASCLE - IF (ACW.LT.ASCLE) GO TO 30 - CSCL = CMPLX(TOL,0.0E0) - 30 CONTINUE - C1 = CW(1)*CSCL - C2 = CW(2)*CSCL - ST = Y(1) -C----------------------------------------------------------------------- -C CINU=CINU*(CONJG(CT)/CABS(CT))*(1.0E0/CABS(CT) PREVENTS -C UNDER- OR OVERFLOW PREMATURELY BY SQUARING CABS(CT) -C----------------------------------------------------------------------- - CT = ZR*(C2+ST*C1) - ACT = CABS(CT) - RCT = CMPLX(1.0E0/ACT,0.0E0) - CT = CONJG(CT)*RCT - CINU = CINU*RCT*CT - Y(1) = CINU*CSCL - IF (N.EQ.1) RETURN - DO 40 I=2,N - CINU = ST*CINU - ST = Y(I) - Y(I) = CINU*CSCL - 40 CONTINUE - RETURN - 50 CONTINUE - NZ = -1 - IF(NW.EQ.(-2)) NZ=-2 - RETURN - END
--- a/liboctave/cruft/amos/dgamln.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -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
--- a/liboctave/cruft/amos/gamln.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,189 +0,0 @@ - FUNCTION GAMLN(Z,IERR) -C***BEGIN PROLOGUE GAMLN -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 GAMLN 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 -C Z - REAL ARGUMENT, Z.GT.0.0E0 -C -C OUTPUT -C GAMLN - NATURAL LOG OF THE GAMMA FUNCTION AT Z -C IERR - ERROR FLAG -C IERR=0, NORMAL RETURN, COMPUTATION COMPLETED -C IERR=1, Z.LE.0.0E0, NO COMPUTATION -C -C***REFERENCES COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT -C BY D. E. AMOS, SAND83-0083, MAY, 1983. -C***ROUTINES CALLED I1MACH,R1MACH -C***END PROLOGUE GAMLN -C - INTEGER I, I1M, K, MZ, NZ, IERR, I1MACH - REAL CF, CON, FLN, FZ, GLN, RLN, S, TLG, TRM, TST, T1, WDTOL, Z, - * ZDMY, ZINC, ZM, ZMIN, ZP, ZSQ - REAL R1MACH - 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.00000000000000000E+00, 0.00000000000000000E+00, - 5 6.93147180559945309E-01, 1.79175946922805500E+00, - 6 3.17805383034794562E+00, 4.78749174278204599E+00, - 7 6.57925121201010100E+00, 8.52516136106541430E+00, - 8 1.06046029027452502E+01, 1.28018274800814696E+01, - 9 1.51044125730755153E+01, 1.75023078458738858E+01, - A 1.99872144956618861E+01, 2.25521638531234229E+01, - B 2.51912211827386815E+01, 2.78992713838408916E+01, - C 3.06718601060806728E+01, 3.35050734501368889E+01, - D 3.63954452080330536E+01, 3.93398841871994940E+01, - E 4.23356164607534850E+01, 4.53801388984769080E+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.84711813518352239E+01, 5.16066755677643736E+01, - 5 5.47847293981123192E+01, 5.80036052229805199E+01, - 6 6.12617017610020020E+01, 6.45575386270063311E+01, - 7 6.78897431371815350E+01, 7.12570389671680090E+01, - 8 7.46582363488301644E+01, 7.80922235533153106E+01, - 9 8.15579594561150372E+01, 8.50544670175815174E+01, - A 8.85808275421976788E+01, 9.21361756036870925E+01, - B 9.57196945421432025E+01, 9.93306124547874269E+01, - C 1.02968198614513813E+02, 1.06631760260643459E+02, - D 1.10320639714757395E+02, 1.14034211781461703E+02, - E 1.17771881399745072E+02, 1.21533081515438634E+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.25317271149356895E+02, 1.29123933639127215E+02, - 5 1.32952575035616310E+02, 1.36802722637326368E+02, - 6 1.40673923648234259E+02, 1.44565743946344886E+02, - 7 1.48477766951773032E+02, 1.52409592584497358E+02, - 8 1.56360836303078785E+02, 1.60331128216630907E+02, - 9 1.64320112263195181E+02, 1.68327445448427652E+02, - A 1.72352797139162802E+02, 1.76395848406997352E+02, - B 1.80456291417543771E+02, 1.84533828861449491E+02, - C 1.88628173423671591E+02, 1.92739047287844902E+02, - D 1.96866181672889994E+02, 2.01009316399281527E+02, - E 2.05168199482641199E+02, 2.09342586752536836E+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.13532241494563261E+02, 2.17736934113954227E+02, - 5 2.21956441819130334E+02, 2.26190548323727593E+02, - 6 2.30439043565776952E+02, 2.34701723442818268E+02, - 7 2.38978389561834323E+02, 2.43268849002982714E+02, - 8 2.47572914096186884E+02, 2.51890402209723194E+02, - 9 2.56221135550009525E+02, 2.60564940971863209E+02, - A 2.64921649798552801E+02, 2.69291097651019823E+02, - B 2.73673124285693704E+02, 2.78067573440366143E+02, - C 2.82474292687630396E+02, 2.86893133295426994E+02, - D 2.91323950094270308E+02, 2.95766601350760624E+02, - E 3.00220948647014132E+02, 3.04686856765668715E+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.09164193580146922E+02, 3.13652829949879062E+02, - 3 3.18152639620209327E+02, 3.22663499126726177E+02, - 4 3.27185287703775217E+02, 3.31717887196928473E+02, - 5 3.36261181979198477E+02, 3.40815058870799018E+02, - 6 3.45379407062266854E+02, 3.49954118040770237E+02, - 7 3.54539085519440809E+02, 3.59134205369575399E+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.33333333333333333E-02, -2.77777777777777778E-03, - 4 7.93650793650793651E-04, -5.95238095238095238E-04, - 5 8.41750841750841751E-04, -1.91752691752691753E-03, - 6 6.41025641025641026E-03, -2.95506535947712418E-02, - 7 1.79644372368830573E-01, -1.39243221690590112E+00, - 8 1.34028640441683920E+01, -1.56848284626002017E+02, - 9 2.19310333333333333E+03, -3.61087712537249894E+04, - A 6.91472268851313067E+05, -1.52382215394074162E+07, - B 3.82900751391414141E+08, -1.08822660357843911E+10, - C 3.47320283765002252E+11, -1.23696021422692745E+13, - D 4.88788064793079335E+14, -2.13203339609193739E+16/ -C -C LN(2*PI) - DATA CON / 1.83787706640934548E+00/ -C -C***FIRST EXECUTABLE STATEMENT GAMLN - IERR=0 - IF (Z.LE.0.0E0) GO TO 70 - IF (Z.GT.101.0E0) GO TO 10 - NZ = INT(Z) - FZ = Z - FLOAT(NZ) - IF (FZ.GT.0.0E0) GO TO 10 - IF (NZ.GT.100) GO TO 10 - GAMLN = GLN(NZ) - RETURN - 10 CONTINUE - WDTOL = R1MACH(4) - WDTOL = AMAX1(WDTOL,0.5E-18) - I1M = I1MACH(11) - RLN = R1MACH(5)*FLOAT(I1M) - FLN = AMIN1(RLN,20.0E0) - FLN = AMAX1(FLN,3.0E0) - FLN = FLN - 3.0E0 - ZM = 1.8000E0 + 0.3875E0*FLN - MZ = INT(ZM) + 1 - ZMIN = FLOAT(MZ) - ZDMY = Z - ZINC = 0.0E0 - IF (Z.GE.ZMIN) GO TO 20 - ZINC = ZMIN - FLOAT(NZ) - ZDMY = Z + ZINC - 20 CONTINUE - ZP = 1.0E0/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 (ABS(TRM).LT.TST) GO TO 40 - S = S + TRM - 30 CONTINUE - 40 CONTINUE - IF (ZINC.NE.0.0E0) GO TO 50 - TLG = ALOG(Z) - GAMLN = Z*(TLG-1.0E0) + 0.5E0*(CON-TLG) + S - RETURN - 50 CONTINUE - ZP = 1.0E0 - NZ = INT(ZINC) - DO 60 I=1,NZ - ZP = ZP*(Z+FLOAT(I-1)) - 60 CONTINUE - TLG = ALOG(ZDMY) - GAMLN = ZDMY*(TLG-1.0E0) - ALOG(ZP) + 0.5E0*(CON-TLG) + S - RETURN -C -C - 70 CONTINUE - IERR=1 - RETURN - END
--- a/liboctave/cruft/amos/module.mk Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,70 +0,0 @@ -CRUFT_SOURCES += \ - liboctave/cruft/amos/cacai.f \ - liboctave/cruft/amos/cacon.f \ - liboctave/cruft/amos/cbesh.f \ - liboctave/cruft/amos/cbesi.f \ - liboctave/cruft/amos/cbesj.f \ - liboctave/cruft/amos/cbesk.f \ - liboctave/cruft/amos/cbesy.f \ - liboctave/cruft/amos/cbinu.f \ - liboctave/cruft/amos/cbuni.f \ - liboctave/cruft/amos/cbunk.f \ - liboctave/cruft/amos/cunk1.f \ - liboctave/cruft/amos/cunk2.f \ - liboctave/cruft/amos/crati.f \ - liboctave/cruft/amos/cshch.f \ - liboctave/cruft/amos/cuni1.f \ - liboctave/cruft/amos/cuoik.f \ - liboctave/cruft/amos/cairy.f \ - liboctave/cruft/amos/cbiry.f \ - liboctave/cruft/amos/ckscl.f \ - liboctave/cruft/amos/cs1s2.f \ - liboctave/cruft/amos/cuchk.f \ - liboctave/cruft/amos/cuni2.f \ - liboctave/cruft/amos/cwrsk.f \ - liboctave/cruft/amos/casyi.f \ - liboctave/cruft/amos/cbknu.f \ - liboctave/cruft/amos/cmlri.f \ - liboctave/cruft/amos/cseri.f \ - liboctave/cruft/amos/cunhj.f \ - liboctave/cruft/amos/cunik.f \ - liboctave/cruft/amos/dgamln.f \ - liboctave/cruft/amos/gamln.f \ - liboctave/cruft/amos/xzabs.f \ - liboctave/cruft/amos/xzexp.f \ - liboctave/cruft/amos/xzlog.f \ - liboctave/cruft/amos/xzsqrt.f \ - liboctave/cruft/amos/zacai.f \ - liboctave/cruft/amos/zacon.f \ - liboctave/cruft/amos/zairy.f \ - liboctave/cruft/amos/zasyi.f \ - liboctave/cruft/amos/zbesh.f \ - liboctave/cruft/amos/zbesi.f \ - liboctave/cruft/amos/zbesj.f \ - liboctave/cruft/amos/zbesk.f \ - liboctave/cruft/amos/zbesy.f \ - liboctave/cruft/amos/zbinu.f \ - liboctave/cruft/amos/zbiry.f \ - liboctave/cruft/amos/zbknu.f \ - liboctave/cruft/amos/zbuni.f \ - liboctave/cruft/amos/zbunk.f \ - liboctave/cruft/amos/zdiv.f \ - liboctave/cruft/amos/zkscl.f \ - liboctave/cruft/amos/zmlri.f \ - liboctave/cruft/amos/zmlt.f \ - liboctave/cruft/amos/zrati.f \ - liboctave/cruft/amos/zs1s2.f \ - liboctave/cruft/amos/zseri.f \ - liboctave/cruft/amos/zshch.f \ - liboctave/cruft/amos/zuchk.f \ - liboctave/cruft/amos/zunhj.f \ - liboctave/cruft/amos/zuni1.f \ - liboctave/cruft/amos/zuni2.f \ - liboctave/cruft/amos/zunik.f \ - liboctave/cruft/amos/zunk1.f \ - liboctave/cruft/amos/zunk2.f \ - liboctave/cruft/amos/zuoik.f \ - liboctave/cruft/amos/zwrsk.f - -liboctave_EXTRA_DIST += \ - liboctave/cruft/amos/README
--- a/liboctave/cruft/amos/xzabs.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,29 +0,0 @@ - DOUBLE PRECISION FUNCTION XZABS(ZR, ZI) -C***BEGIN PROLOGUE XZABS -C***REFER TO ZBESH,ZBESI,ZBESJ,ZBESK,ZBESY,ZAIRY,ZBIRY -C -C XZABS COMPUTES THE ABSOLUTE VALUE OR MAGNITUDE OF A DOUBLE -C PRECISION COMPLEX VARIABLE CMPLX(ZR,ZI) -C -C***ROUTINES CALLED (NONE) -C***END PROLOGUE XZABS - 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 - XZABS = V*DSQRT(1.D+0+Q*Q) - RETURN - 10 Q = V/U - XZABS = U*DSQRT(1.D+0+Q*Q) - RETURN - 20 XZABS = 0.0D+0 - RETURN - END
--- a/liboctave/cruft/amos/xzexp.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,16 +0,0 @@ - SUBROUTINE XZEXP(AR, AI, BR, BI) -C***BEGIN PROLOGUE XZEXP -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 XZEXP - 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
--- a/liboctave/cruft/amos/xzlog.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,41 +0,0 @@ - SUBROUTINE XZLOG(AR, AI, BR, BI, IERR) -C***BEGIN PROLOGUE XZLOG -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 XZABS -C***END PROLOGUE XZLOG - DOUBLE PRECISION AR, AI, BR, BI, ZM, DTHETA, DPI, DHPI - DOUBLE PRECISION XZABS - 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 = XZABS(AR,AI) - BR = DLOG(ZM) - BI = DTHETA - RETURN - 60 CONTINUE - IERR=1 - RETURN - END
--- a/liboctave/cruft/amos/xzsqrt.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,44 +0,0 @@ - SUBROUTINE XZSQRT(AR, AI, BR, BI) -C***BEGIN PROLOGUE XZSQRT -C***REFER TO ZBESH,ZBESI,ZBESJ,ZBESK,ZBESY,ZAIRY,ZBIRY -C -C DOUBLE PRECISION COMPLEX SQUARE ROOT, B=CSQRT(A) -C -C***ROUTINES CALLED XZABS -C***END PROLOGUE XZSQRT - DOUBLE PRECISION AR, AI, BR, BI, ZM, DTHETA, DPI, DRT - DOUBLE PRECISION XZABS - DATA DRT , DPI / 7.071067811865475244008443621D-1, - 1 3.141592653589793238462643383D+0/ - ZM = XZABS(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
--- a/liboctave/cruft/amos/zacai.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -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,XZABS -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, XZABS - 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 = XZABS(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
--- a/liboctave/cruft/amos/zacon.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -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,XZABS,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, XZABS - 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 = XZABS(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 = XZABS(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
--- a/liboctave/cruft/amos/zairy.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -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,XZEXP,XZSQRT,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, XZABS, 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 = XZABS(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 XZSQRT(ZR, ZI, STR, STI) - ZTAR = TTH*(ZR*STR-ZI*STI) - ZTAI = TTH*(ZR*STI+ZI*STR) - CALL XZEXP(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 XZSQRT(ZR, ZI, STR, STI) - ZTAR = TTH*(ZR*STR-ZI*STI) - ZTAI = TTH*(ZR*STI+ZI*STR) - CALL XZEXP(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 XZSQRT(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
--- a/liboctave/cruft/amos/zasyi.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -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,XZABS,ZDIV,XZEXP,ZMLT,XZSQRT -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, XZABS - 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 = XZABS(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 XZSQRT(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 XZEXP(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 XZEXP(-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 XZEXP(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
--- a/liboctave/cruft/amos/zbesh.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -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,XZABS,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, XZABS, 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 = XZABS(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
--- a/liboctave/cruft/amos/zbesi.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -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, XZABS, 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 = XZABS(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
--- a/liboctave/cruft/amos/zbesj.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -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, XZABS, 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 = XZABS(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
--- a/liboctave/cruft/amos/zbesk.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -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,XZABS,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, XZABS, 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 = XZABS(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
--- a/liboctave/cruft/amos/zbesy.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -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
--- a/liboctave/cruft/amos/zbinu.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -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 XZABS,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, XZABS - 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 = XZABS(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
--- a/liboctave/cruft/amos/zbiry.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -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,XZABS,ZDIV,XZSQRT,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, XZABS - 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 = XZABS(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 XZSQRT(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 XZSQRT(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 XZSQRT(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
--- a/liboctave/cruft/amos/zbknu.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -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,XZABS,ZDIV, -C XZEXP,XZLOG,ZMLT,XZSQRT -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, XZABS, 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 = XZABS(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 XZLOG(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 XZEXP(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 XZEXP(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 XZEXP(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 XZSQRT(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 = XZABS(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 = XZABS(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 = XZABS(S2R,S2I) - ALAS = DLOG(AS) - P2R = -ZDR+ALAS - IF(P2R.LT.(-ELIM)) GO TO 263 - CALL XZLOG(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
--- a/liboctave/cruft/amos/zbuni.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -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,XZABS,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, XZABS, 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 = XZABS(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/XZABS(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
--- a/liboctave/cruft/amos/zbunk.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -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
--- a/liboctave/cruft/amos/zdiv.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -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 XZABS -C***END PROLOGUE ZDIV - DOUBLE PRECISION AR, AI, BR, BI, CR, CI, BM, CA, CB, CC, CD - DOUBLE PRECISION XZABS - BM = 1.0D0/XZABS(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
--- a/liboctave/cruft/amos/zkscl.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -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,XZABS,XZLOG -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, XZABS, - * 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 = XZABS(S1R,S1I) - ACS = -ZRR + DLOG(AS) - NZ = NZ + 1 - YR(I) = ZEROR - YI(I) = ZEROI - IF (ACS.LT.(-ELIM)) GO TO 10 - CALL XZLOG(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 = XZABS(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 XZLOG(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
--- a/liboctave/cruft/amos/zmlri.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -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,XZABS,XZEXP,XZLOG,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, XZABS - 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 = XZABS(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 = XZABS(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 = XZABS(P2R,P2I) - IF (AP.LT.TST) GO TO 30 - IF (ITIME.EQ.2) GO TO 40 - ACK = XZABS(CKR,CKI) - FLAM = ACK + DSQRT(ACK*ACK-1.0D0) - FKAP = AP/XZABS(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 XZLOG(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 = XZABS(P2R,P2I) - P1R = 1.0D0/AP - CALL XZEXP(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
--- a/liboctave/cruft/amos/zmlt.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -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
--- a/liboctave/cruft/amos/zrati.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -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 XZABS,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, XZABS - 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 = XZABS(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 = XZABS(P2R,P2I) - AP1 = XZABS(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 = XZABS(P2R,P2I) - IF (AP1.LE.TEST) GO TO 10 - IF (ITIME.EQ.2) GO TO 20 - AK = XZABS(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 = XZABS(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
--- a/liboctave/cruft/amos/zs1s2.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -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 XZABS,XZEXP,XZLOG -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, XZABS - INTEGER IUF, IDUM, NZ - DATA ZEROR,ZEROI / 0.0D0 , 0.0D0 / - NZ = 0 - AS1 = XZABS(S1R,S1I) - AS2 = XZABS(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 XZLOG(S1DR, S1DI, C1R, C1I, IDUM) - C1R = C1R - ZRR - ZRR - C1I = C1I - ZRI - ZRI - CALL XZEXP(C1R, C1I, S1R, S1I) - AS1 = XZABS(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
--- a/liboctave/cruft/amos/zseri.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -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,XZABS,ZDIV,XZLOG,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, XZABS - 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 = XZABS(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 = XZABS(CZR,CZI) - NN = N - CALL XZLOG(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 (XZABS(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
--- a/liboctave/cruft/amos/zshch.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -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
--- a/liboctave/cruft/amos/zuchk.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -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
--- a/liboctave/cruft/amos/zunhj.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -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 XZABS,ZDIV,XZLOG,XZSQRT,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, XZABS, 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 = XZABS(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 XZSQRT(SUMAR, SUMAI, ZAR, ZAI) - CALL XZSQRT(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 XZSQRT(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 XZSQRT(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 XZLOG(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 = XZABS(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 XZSQRT(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
--- a/liboctave/cruft/amos/zuni1.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -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,XZABS -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, XZABS - 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/XZABS(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/XZABS(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 = XZABS(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/XZABS(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
--- a/liboctave/cruft/amos/zuni2.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -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,XZABS -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, XZABS, 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/XZABS(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/XZABS(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 = XZABS(PHIR,PHII) - AARG = XZABS(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/XZABS(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
--- a/liboctave/cruft/amos/zunik.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -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,XZLOG,XZSQRT,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 XZSQRT(SR, SI, SRR, SRI) - STR = CONER + SRR - STI = CONEI + SRI - CALL ZDIV(STR, STI, TR, TI, ZNR, ZNI) - CALL XZLOG(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 XZSQRT(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
--- a/liboctave/cruft/amos/zunk1.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -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,XZABS -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, XZABS - 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/XZABS(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 = XZABS(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/XZABS(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/XZABS(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 = XZABS(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/XZABS(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 = XZABS(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
--- a/liboctave/cruft/amos/zunk2.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -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,XZABS -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, XZABS - 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/XZABS(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 = XZABS(PHIR(J),PHII(J)) - AARG = XZABS(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/XZABS(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/XZABS(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 = XZABS(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/XZABS(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 = XZABS(PHIDR,PHIDI) - AARG = XZABS(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
--- a/liboctave/cruft/amos/zuoik.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -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,XZABS,XZLOG -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, XZABS - 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 = XZABS(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 = XZABS(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 XZLOG(PHIR, PHII, STR, STI, IDUM) - CZR = CZR + STR - CZI = CZI + STI - IF (IFORM.EQ.1) GO TO 120 - CALL XZLOG(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 = XZABS(ARGR,ARGI) - 160 CONTINUE - IF (KODE.EQ.1) GO TO 170 - CZR = CZR - ZBR - CZI = CZI - ZBI - 170 CONTINUE - APHI = XZABS(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 XZLOG(PHIR, PHII, STR, STI, IDUM) - CZR = CZR + STR - CZI = CZI + STI - IF (IFORM.EQ.1) GO TO 200 - CALL XZLOG(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
--- a/liboctave/cruft/amos/zwrsk.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -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,XZABS -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, XZABS, 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 = XZABS(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 = XZABS(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
--- a/liboctave/cruft/blas-xtra/cconv2.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,77 +0,0 @@ -c Copyright (C) 2010-2017 VZLU Prague, a.s., Czech Republic -c -c Author: Jaroslav Hajek <highegg@gmail.com> -c -c This file is part of Octave. -c -c Octave is free software; you can redistribute it and/or modify it -c under the terms of the GNU General Public License as published by -c the Free Software Foundation; either version 3 of the License, or -c (at your option) any later version. -c -c Octave is distributed in the hope that it will be useful, but -c WITHOUT ANY WARRANTY; without even the implied warranty of -c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -c GNU General Public License for more details. -c -c You should have received a copy of the GNU General Public License -c along with Octave; see the file COPYING. If not, see -c <http://www.gnu.org/licenses/>. -c - subroutine cconv2o(ma,na,a,mb,nb,b,c) -c purpose: a 2-dimensional outer additive convolution. -c equivalent to the following: -c for i = 1:ma -c for j = 1:na -c c(i:i+mb-1,j:j+mb-1) += a(i,j)*b -c endfor -c endfor -c arguments: -c ma,na (in) dimensions of a -c a (in) 1st matrix -c mb,nb (in) dimensions of b -c b (in) 2nd matrix -c c (inout) accumulator matrix, size (ma+mb-1, na+nb-1) -c - integer ma,na,mb,nb - complex a(ma,na),b(mb,nb) - complex c(ma+mb-1,na+nb-1) - integer i,j,k - external caxpy - do k = 1,na - do j = 1,nb - do i = 1,mb - call caxpy(ma,b(i,j),a(1,k),1,c(i,j+k-1),1) - end do - end do - end do - end subroutine - - subroutine cconv2i(ma,na,a,mb,nb,b,c) -c purpose: a 2-dimensional inner additive convolution. -c equivalent to the following: -c for i = 1:ma-mb+1 -c for j = 1:na-nb+1 -c c(i,j) = sum (sum (a(i+mb-1:-1:i,j+nb-1:-1:j) .* b)) -c endfor -c endfor -c arguments: -c ma,na (in) dimensions of a -c a (in) 1st matrix -c mb,nb (in) dimensions of b -c b (in) 2nd matrix -c c (inout) accumulator matrix, size (ma+mb-1, na+nb-1) -c - integer ma,na,mb,nb - complex a(ma,na),b(mb,nb) - complex c(ma-mb+1,na-nb+1) - integer i,j,k - external caxpy - do k = 1,na-nb+1 - do j = 1,nb - do i = 1,mb - call caxpy(ma-mb+1,b(i,j),a(mb+1-i,k+nb-j),1,c(1,k),1) - end do - end do - end do - end subroutine
--- a/liboctave/cruft/blas-xtra/cdotc3.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,59 +0,0 @@ -c Copyright (C) 2009-2017 VZLU Prague, a.s., Czech Republic -c -c Author: Jaroslav Hajek <highegg@gmail.com> -c -c This file is part of Octave. -c -c Octave is free software; you can redistribute it and/or modify it -c under the terms of the GNU General Public License as published by -c the Free Software Foundation; either version 3 of the License, or -c (at your option) any later version. -c -c Octave is distributed in the hope that it will be useful, but -c WITHOUT ANY WARRANTY; without even the implied warranty of -c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -c GNU General Public License for more details. -c -c You should have received a copy of the GNU General Public License -c along with Octave; see the file COPYING. If not, see -c <http://www.gnu.org/licenses/>. -c - subroutine cdotc3(m,n,k,a,b,c) -c purpose: a 3-dimensional dot product. -c c = sum (conj (a) .* b, 2), where a and b are 3d arrays. -c arguments: -c m,n,k (in) the dimensions of a and b -c a,b (in) complex input arrays of size (m,k,n) -c c (out) complex output array, size (m,n) - integer m,n,k,i,j,l - complex a(m,k,n),b(m,k,n) - complex c(m,n) - - complex cdotc - external cdotc - -c quick return if possible. - if (m <= 0 .or. n <= 0) return - - if (m == 1) then -c the column-major case. - do j = 1,n - c(1,j) = cdotc(k,a(1,1,j),1,b(1,1,j),1) - end do - else -c We prefer performance here, because that's what we generally -c do by default in reduction functions. Besides, the accuracy -c of xDOT is questionable. Hence, do a cache-aligned nested loop. - do j = 1,n - do i = 1,m - c(i,j) = 0e0 - end do - do l = 1,k - do i = 1,m - c(i,j) = c(i,j) + conjg(a(i,l,j))*b(i,l,j) - end do - end do - end do - end if - - end subroutine
--- a/liboctave/cruft/blas-xtra/cmatm3.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,69 +0,0 @@ -c Copyright (C) 2009-2017 VZLU Prague, a.s., Czech Republic -c -c Author: Jaroslav Hajek <highegg@gmail.com> -c -c This file is part of Octave. -c -c Octave is free software; you can redistribute it and/or modify it -c under the terms of the GNU General Public License as published by -c the Free Software Foundation; either version 3 of the License, or -c (at your option) any later version. -c -c Octave is distributed in the hope that it will be useful, but -c WITHOUT ANY WARRANTY; without even the implied warranty of -c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -c GNU General Public License for more details. -c -c You should have received a copy of the GNU General Public License -c along with Octave; see the file COPYING. If not, see -c <http://www.gnu.org/licenses/>. -c - subroutine cmatm3(m,n,k,np,a,b,c) -c purpose: a 3-dimensional matrix product. -c given a (m,k,np) array a and (k,n,np) array b, -c calculates a (m,n,np) array c such that -c for i = 1:np -c c(:,:,i) = a(:,:,i) * b(:,:,i) -c -c arguments: -c m,n,k (in) the dimensions -c np (in) number of multiplications -c a (in) a complex input array, size (m,k,np) -c b (in) a complex input array, size (k,n,np) -c c (out) a complex output array, size (m,n,np) - integer m,n,k,np - complex a(m*k,np),b(k*n,np) - complex c(m*n,np) - - complex cdotu,one,zero - parameter (one = 1e0, zero = 0e0) - external cdotu,cgemv,cgemm - integer i - -c quick return if possible. - if (np <= 0) return - - if (m == 1) then - if (n == 1) then - do i = 1,np - c(1,i) = cdotu(k,a(1,i),1,b(1,i),1) - end do - else - do i = 1,np - call cgemv("T",k,n,one,b(1,i),k,a(1,i),1,zero,c(1,i),1) - end do - end if - else - if (n == 1) then - do i = 1,np - call cgemv("N",m,k,one,a(1,i),m,b(1,i),1,zero,c(1,i),1) - end do - else - do i = 1,np - call cgemm("N","N",m,n,k, - + one,a(1,i),m,b(1,i),k,zero,c(1,i),m) - end do - end if - end if - - end subroutine
--- a/liboctave/cruft/blas-xtra/csconv2.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,83 +0,0 @@ -c Copyright (C) 2010-2017 VZLU Prague, a.s., Czech Republic -c -c Author: Jaroslav Hajek <highegg@gmail.com> -c -c This file is part of Octave. -c -c Octave is free software; you can redistribute it and/or modify it -c under the terms of the GNU General Public License as published by -c the Free Software Foundation; either version 3 of the License, or -c (at your option) any later version. -c -c Octave is distributed in the hope that it will be useful, but -c WITHOUT ANY WARRANTY; without even the implied warranty of -c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -c GNU General Public License for more details. -c -c You should have received a copy of the GNU General Public License -c along with Octave; see the file COPYING. If not, see -c <http://www.gnu.org/licenses/>. -c - subroutine csconv2o(ma,na,a,mb,nb,b,c) -c purpose: a 2-dimensional outer additive convolution. -c equivalent to the following: -c for i = 1:ma -c for j = 1:na -c c(i:i+mb-1,j:j+mb-1) += a(i,j)*b -c endfor -c endfor -c arguments: -c ma,na (in) dimensions of a -c a (in) 1st matrix -c mb,nb (in) dimensions of b -c b (in) 2nd matrix -c c (inout) accumulator matrix, size (ma+mb-1, na+nb-1) -c - integer ma,na,mb,nb - complex a(ma,na) - real b(mb,nb) - complex c(ma+mb-1,na+nb-1) - complex btmp - integer i,j,k - external caxpy - do k = 1,na - do j = 1,nb - do i = 1,mb - btmp = b(i,j) - call caxpy(ma,btmp,a(1,k),1,c(i,j+k-1),1) - end do - end do - end do - end subroutine - - subroutine csconv2i(ma,na,a,mb,nb,b,c) -c purpose: a 2-dimensional inner additive convolution. -c equivalent to the following: -c for i = 1:ma-mb+1 -c for j = 1:na-nb+1 -c c(i,j) = sum (sum (a(i:i+mb-1,j:j+nb-1) .* b)) -c endfor -c endfor -c arguments: -c ma,na (in) dimensions of a -c a (in) 1st matrix -c mb,nb (in) dimensions of b -c b (in) 2nd matrix -c c (inout) accumulator matrix, size (ma+mb-1, na+nb-1) -c - integer ma,na,mb,nb - complex a(ma,na) - real b(mb,nb) - complex c(ma-mb+1,na-nb+1) - complex btmp - integer i,j,k - external caxpy - do k = 1,na-nb+1 - do j = 1,nb - do i = 1,mb - btmp = b(i,j) - call caxpy(ma-mb+1,btmp,a(mb+1-i,k+nb-j),1,c(1,k),1) - end do - end do - end do - end subroutine
--- a/liboctave/cruft/blas-xtra/dconv2.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,77 +0,0 @@ -c Copyright (C) 2010-2017 VZLU Prague, a.s., Czech Republic -c -c Author: Jaroslav Hajek <highegg@gmail.com> -c -c This file is part of Octave. -c -c Octave is free software; you can redistribute it and/or modify it -c under the terms of the GNU General Public License as published by -c the Free Software Foundation; either version 3 of the License, or -c (at your option) any later version. -c -c Octave is distributed in the hope that it will be useful, but -c WITHOUT ANY WARRANTY; without even the implied warranty of -c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -c GNU General Public License for more details. -c -c You should have received a copy of the GNU General Public License -c along with Octave; see the file COPYING. If not, see -c <http://www.gnu.org/licenses/>. -c - subroutine dconv2o(ma,na,a,mb,nb,b,c) -c purpose: a 2-dimensional outer additive convolution. -c equivalent to the following: -c for i = 1:ma -c for j = 1:na -c c(i:i+mb-1,j:j+mb-1) += a(i,j)*b -c endfor -c endfor -c arguments: -c ma,na (in) dimensions of a -c a (in) 1st matrix -c mb,nb (in) dimensions of b -c b (in) 2nd matrix -c c (inout) accumulator matrix, size (ma+mb-1, na+nb-1) -c - integer ma,na,mb,nb - double precision a(ma,na),b(mb,nb) - double precision c(ma+mb-1,na+nb-1) - integer i,j,k - external daxpy - do k = 1,na - do j = 1,nb - do i = 1,mb - call daxpy(ma,b(i,j),a(1,k),1,c(i,j+k-1),1) - end do - end do - end do - end subroutine - - subroutine dconv2i(ma,na,a,mb,nb,b,c) -c purpose: a 2-dimensional inner additive convolution. -c equivalent to the following: -c for i = 1:ma-mb+1 -c for j = 1:na-nb+1 -c c(i,j) = sum (sum (a(i+mb-1:-1:i,j+nb-1:-1:j) .* b)) -c endfor -c endfor -c arguments: -c ma,na (in) dimensions of a -c a (in) 1st matrix -c mb,nb (in) dimensions of b -c b (in) 2nd matrix -c c (inout) accumulator matrix, size (ma+mb-1, na+nb-1) -c - integer ma,na,mb,nb - double precision a(ma,na),b(mb,nb) - double precision c(ma-mb+1,na-nb+1) - integer i,j,k - external daxpy - do k = 1,na-nb+1 - do j = 1,nb - do i = 1,mb - call daxpy(ma-mb+1,b(i,j),a(mb+1-i,k+nb-j),1,c(1,k),1) - end do - end do - end do - end subroutine
--- a/liboctave/cruft/blas-xtra/ddot3.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,60 +0,0 @@ -c Copyright (C) 2009-2017 VZLU Prague, a.s., Czech Republic -c -c Author: Jaroslav Hajek <highegg@gmail.com> -c -c This file is part of Octave. -c -c Octave is free software; you can redistribute it and/or modify it -c under the terms of the GNU General Public License as published by -c the Free Software Foundation; either version 3 of the License, or -c (at your option) any later version. -c -c Octave is distributed in the hope that it will be useful, but -c WITHOUT ANY WARRANTY; without even the implied warranty of -c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -c GNU General Public License for more details. -c -c You should have received a copy of the GNU General Public License -c along with Octave; see the file COPYING. If not, see -c <http://www.gnu.org/licenses/>. -c - subroutine ddot3(m,n,k,a,b,c) -c purpose: a 3-dimensional dot product. -c c = sum (a .* b, 2), where a and b are 3d arrays. -c arguments: -c m,n,k (in) the dimensions of a and b -c a,b (in) double prec. input arrays of size (m,k,n) -c c (out) double prec. output array, size (m,n) - integer m,n,k,i,j,l - double precision a(m,k,n),b(m,k,n) - double precision c(m,n) - - double precision ddot - external ddot - - -c quick return if possible. - if (m <= 0 .or. n <= 0) return - - if (m == 1) then -c the column-major case. - do j = 1,n - c(1,j) = ddot(k,a(1,1,j),1,b(1,1,j),1) - end do - else -c We prefer performance here, because that's what we generally -c do by default in reduction functions. Besides, the accuracy -c of xDOT is questionable. Hence, do a cache-aligned nested loop. - do j = 1,n - do i = 1,m - c(i,j) = 0d0 - end do - do l = 1,k - do i = 1,m - c(i,j) = c(i,j) + a(i,l,j)*b(i,l,j) - end do - end do - end do - end if - - end subroutine
--- a/liboctave/cruft/blas-xtra/dmatm3.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,69 +0,0 @@ -c Copyright (C) 2009-2017 VZLU Prague, a.s., Czech Republic -c -c Author: Jaroslav Hajek <highegg@gmail.com> -c -c This file is part of Octave. -c -c Octave is free software; you can redistribute it and/or modify it -c under the terms of the GNU General Public License as published by -c the Free Software Foundation; either version 3 of the License, or -c (at your option) any later version. -c -c Octave is distributed in the hope that it will be useful, but -c WITHOUT ANY WARRANTY; without even the implied warranty of -c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -c GNU General Public License for more details. -c -c You should have received a copy of the GNU General Public License -c along with Octave; see the file COPYING. If not, see -c <http://www.gnu.org/licenses/>. -c - subroutine dmatm3(m,n,k,np,a,b,c) -c purpose: a 3-dimensional matrix product. -c given a (m,k,np) array a and (k,n,np) array b, -c calculates a (m,n,np) array c such that -c for i = 1:np -c c(:,:,i) = a(:,:,i) * b(:,:,i) -c -c arguments: -c m,n,k (in) the dimensions -c np (in) number of multiplications -c a (in) a double prec. input array, size (m,k,np) -c b (in) a double prec. input array, size (k,n,np) -c c (out) a double prec. output array, size (m,n,np) - integer m,n,k,np - double precision a(m*k,np),b(k*n,np) - double precision c(m*n,np) - - double precision ddot,one,zero - parameter (one = 1d0, zero = 0d0) - external ddot,dgemv,dgemm - integer i - -c quick return if possible. - if (np <= 0) return - - if (m == 1) then - if (n == 1) then - do i = 1,np - c(1,i) = ddot(k,a(1,i),1,b(1,i),1) - end do - else - do i = 1,np - call dgemv("T",k,n,one,b(1,i),k,a(1,i),1,zero,c(1,i),1) - end do - end if - else - if (n == 1) then - do i = 1,np - call dgemv("N",m,k,one,a(1,i),m,b(1,i),1,zero,c(1,i),1) - end do - else - do i = 1,np - call dgemm("N","N",m,n,k, - + one,a(1,i),m,b(1,i),k,zero,c(1,i),m) - end do - end if - end if - - end subroutine
--- a/liboctave/cruft/blas-xtra/module.mk Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -CRUFT_SOURCES += \ - liboctave/cruft/blas-xtra/ddot3.f \ - liboctave/cruft/blas-xtra/zdotc3.f \ - liboctave/cruft/blas-xtra/sdot3.f \ - liboctave/cruft/blas-xtra/cdotc3.f \ - liboctave/cruft/blas-xtra/dmatm3.f \ - liboctave/cruft/blas-xtra/zmatm3.f \ - liboctave/cruft/blas-xtra/smatm3.f \ - liboctave/cruft/blas-xtra/cmatm3.f \ - liboctave/cruft/blas-xtra/xddot.f \ - liboctave/cruft/blas-xtra/xdnrm2.f \ - liboctave/cruft/blas-xtra/xdznrm2.f \ - liboctave/cruft/blas-xtra/xzdotc.f \ - liboctave/cruft/blas-xtra/xzdotu.f \ - liboctave/cruft/blas-xtra/xsdot.f \ - liboctave/cruft/blas-xtra/xsnrm2.f \ - liboctave/cruft/blas-xtra/xscnrm2.f \ - liboctave/cruft/blas-xtra/xcdotc.f \ - liboctave/cruft/blas-xtra/xcdotu.f \ - liboctave/cruft/blas-xtra/xerbla.f \ - liboctave/cruft/blas-xtra/cconv2.f \ - liboctave/cruft/blas-xtra/csconv2.f \ - liboctave/cruft/blas-xtra/dconv2.f \ - liboctave/cruft/blas-xtra/sconv2.f \ - liboctave/cruft/blas-xtra/zconv2.f \ - liboctave/cruft/blas-xtra/zdconv2.f
--- a/liboctave/cruft/blas-xtra/sconv2.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,77 +0,0 @@ -c Copyright (C) 2010-2017 VZLU Prague, a.s., Czech Republic -c -c Author: Jaroslav Hajek <highegg@gmail.com> -c -c This file is part of Octave. -c -c Octave is free software; you can redistribute it and/or modify it -c under the terms of the GNU General Public License as published by -c the Free Software Foundation; either version 3 of the License, or -c (at your option) any later version. -c -c Octave is distributed in the hope that it will be useful, but -c WITHOUT ANY WARRANTY; without even the implied warranty of -c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -c GNU General Public License for more details. -c -c You should have received a copy of the GNU General Public License -c along with Octave; see the file COPYING. If not, see -c <http://www.gnu.org/licenses/>. -c - subroutine sconv2o(ma,na,a,mb,nb,b,c) -c purpose: a 2-dimensional outer additive convolution. -c equivalent to the following: -c for i = 1:ma -c for j = 1:na -c c(i:i+mb-1,j:j+mb-1) += a(i,j)*b -c endfor -c endfor -c arguments: -c ma,na (in) dimensions of a -c a (in) 1st matrix -c mb,nb (in) dimensions of b -c b (in) 2nd matrix -c c (inout) accumulator matrix, size (ma+mb-1, na+nb-1) -c - integer ma,na,mb,nb - real a(ma,na),b(mb,nb) - real c(ma+mb-1,na+nb-1) - integer i,j,k - external saxpy - do k = 1,na - do j = 1,nb - do i = 1,mb - call saxpy(ma,b(i,j),a(1,k),1,c(i,j+k-1),1) - end do - end do - end do - end subroutine - - subroutine sconv2i(ma,na,a,mb,nb,b,c) -c purpose: a 2-dimensional inner additive convolution. -c equivalent to the following: -c for i = 1:ma-mb+1 -c for j = 1:na-nb+1 -c c(i,j) = sum (sum (a(i+mb-1:-1:i,j+nb-1:-1:j) .* b)) -c endfor -c endfor -c arguments: -c ma,na (in) dimensions of a -c a (in) 1st matrix -c mb,nb (in) dimensions of b -c b (in) 2nd matrix -c c (inout) accumulator matrix, size (ma+mb-1, na+nb-1) -c - integer ma,na,mb,nb - real a(ma,na),b(mb,nb) - real c(ma-mb+1,na-nb+1) - integer i,j,k - external saxpy - do k = 1,na-nb+1 - do j = 1,nb - do i = 1,mb - call saxpy(ma-mb+1,b(i,j),a(mb+1-i,k+nb-j),1,c(1,k),1) - end do - end do - end do - end subroutine
--- a/liboctave/cruft/blas-xtra/sdot3.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,59 +0,0 @@ -c Copyright (C) 2009-2017 VZLU Prague, a.s., Czech Republic -c -c Author: Jaroslav Hajek <highegg@gmail.com> -c -c This file is part of Octave. -c -c Octave is free software; you can redistribute it and/or modify it -c under the terms of the GNU General Public License as published by -c the Free Software Foundation; either version 3 of the License, or -c (at your option) any later version. -c -c Octave is distributed in the hope that it will be useful, but -c WITHOUT ANY WARRANTY; without even the implied warranty of -c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -c GNU General Public License for more details. -c -c You should have received a copy of the GNU General Public License -c along with Octave; see the file COPYING. If not, see -c <http://www.gnu.org/licenses/>. -c - subroutine sdot3(m,n,k,a,b,c) -c purpose: a 3-dimensional dot product. -c c = sum (a .* b, 2), where a and b are 3d arrays. -c arguments: -c m,n,k (in) the dimensions of a and b -c a,b (in) real input arrays of size (m,k,n) -c c (out) real output array, size (m,n) - integer m,n,k,i,j,l - real a(m,k,n),b(m,k,n) - real c(m,n) - - real sdot - external sdot - -c quick return if possible. - if (m <= 0 .or. n <= 0) return - - if (m == 1) then -c the column-major case. - do j = 1,n - c(1,j) = sdot(k,a(1,1,j),1,b(1,1,j),1) - end do - else -c We prefer performance here, because that's what we generally -c do by default in reduction functions. Besides, the accuracy -c of xDOT is questionable. Hence, do a cache-aligned nested loop. - do j = 1,n - do i = 1,m - c(i,j) = 0d0 - end do - do l = 1,k - do i = 1,m - c(i,j) = c(i,j) + a(i,l,j)*b(i,l,j) - end do - end do - end do - end if - - end subroutine
--- a/liboctave/cruft/blas-xtra/smatm3.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,69 +0,0 @@ -c Copyright (C) 2009-2017 VZLU Prague, a.s., Czech Republic -c -c Author: Jaroslav Hajek <highegg@gmail.com> -c -c This file is part of Octave. -c -c Octave is free software; you can redistribute it and/or modify it -c under the terms of the GNU General Public License as published by -c the Free Software Foundation; either version 3 of the License, or -c (at your option) any later version. -c -c Octave is distributed in the hope that it will be useful, but -c WITHOUT ANY WARRANTY; without even the implied warranty of -c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -c GNU General Public License for more details. -c -c You should have received a copy of the GNU General Public License -c along with Octave; see the file COPYING. If not, see -c <http://www.gnu.org/licenses/>. -c - subroutine smatm3(m,n,k,np,a,b,c) -c purpose: a 3-dimensional matrix product. -c given a (m,k,np) array a and (k,n,np) array b, -c calculates a (m,n,np) array c such that -c for i = 1:np -c c(:,:,i) = a(:,:,i) * b(:,:,i) -c -c arguments: -c m,n,k (in) the dimensions -c np (in) number of multiplications -c a (in) a real input array, size (m,k,np) -c b (in) a real input array, size (k,n,np) -c c (out) a real output array, size (m,n,np) - integer m,n,k,np - real a(m*k,np),b(k*n,np) - real c(m*n,np) - - real sdot,one,zero - parameter (one = 1e0, zero = 0e0) - external sdot,sgemv,sgemm - integer i - -c quick return if possible. - if (np <= 0) return - - if (m == 1) then - if (n == 1) then - do i = 1,np - c(1,i) = sdot(k,a(1,i),1,b(1,i),1) - end do - else - do i = 1,np - call sgemv("T",k,n,one,b(1,i),k,a(1,i),1,zero,c(1,i),1) - end do - end if - else - if (n == 1) then - do i = 1,np - call sgemv("N",m,k,one,a(1,i),m,b(1,i),1,zero,c(1,i),1) - end do - else - do i = 1,np - call sgemm("N","N",m,n,k, - + one,a(1,i),m,b(1,i),k,zero,c(1,i),m) - end do - end if - end if - - end subroutine
--- a/liboctave/cruft/blas-xtra/xcdotc.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,7 +0,0 @@ - subroutine xcdotc (n, zx, incx, zy, incy, retval) - complex cdotc, zx(*), zy(*), retval - integer n, incx, incy - external cdotc - retval = cdotc (n, zx, incx, zy, incy) - return - end
--- a/liboctave/cruft/blas-xtra/xcdotu.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,7 +0,0 @@ - subroutine xcdotu (n, zx, incx, zy, incy, retval) - complex cdotu, zx(*), zy(*), retval - integer n, incx, incy - external cdotu - retval = cdotu (n, zx, incx, zy, incy) - return - end
--- a/liboctave/cruft/blas-xtra/xddot.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,6 +0,0 @@ - subroutine xddot (n, dx, incx, dy, incy, retval) - double precision ddot, dx(*), dy(*), retval - integer n, incx, incy - retval = ddot (n, dx, incx, dy, incy) - return - end
--- a/liboctave/cruft/blas-xtra/xdnrm2.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,6 +0,0 @@ - subroutine xdnrm2 (n, x, incx, retval) - double precision dnrm2, x(*), retval - integer n, incx - retval = dnrm2 (n, x, incx) - return - end
--- a/liboctave/cruft/blas-xtra/xdznrm2.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,7 +0,0 @@ - subroutine xdznrm2 (n, x, incx, retval) - double precision dznrm2, retval - double complex x(*) - integer n, incx - retval = dznrm2 (n, x, incx) - return - end
--- a/liboctave/cruft/blas-xtra/xerbla.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,43 +0,0 @@ - SUBROUTINE XERBLA( SRNAME, INFO ) -* -* -- LAPACK auxiliary routine (preliminary version) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 -* -* .. Scalar Arguments .. - CHARACTER*6 SRNAME - INTEGER INFO -* .. -* -* Purpose -* ======= -* -* XERBLA is an error handler for the LAPACK routines. -* It is called by an LAPACK routine if an input parameter has an -* invalid value. A message is printed and execution stops. -* -* Installers may consider modifying the STOP statement in order to -* call system-specific exception-handling facilities. -* -* Arguments -* ========= -* -* SRNAME (input) CHARACTER*6 -* The name of the routine which called XERBLA. -* -* INFO (input) INTEGER -* The position of the invalid parameter in the parameter list -* of the calling routine. -* -* - WRITE( *, FMT = 9999 )SRNAME, INFO -* - CALL XSTOPX (' ') -* - 9999 FORMAT( ' ** On entry to ', A6, ' parameter number ', I2, ' had ', - $ 'an illegal value' ) -* -* End of XERBLA -* - END
--- a/liboctave/cruft/blas-xtra/xscnrm2.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,7 +0,0 @@ - subroutine xscnrm2 (n, x, incx, retval) - real scnrm2, retval - complex x(*) - integer n, incx - retval = scnrm2 (n, x, incx) - return - end
--- a/liboctave/cruft/blas-xtra/xsdot.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,6 +0,0 @@ - subroutine xsdot (n, dx, incx, dy, incy, retval) - real ddot, dx(*), dy(*), retval, sdot - integer n, incx, incy - retval = sdot (n, dx, incx, dy, incy) - return - end
--- a/liboctave/cruft/blas-xtra/xsnrm2.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,6 +0,0 @@ - subroutine xsnrm2 (n, x, incx, retval) - real snrm2, x(*), retval - integer n, incx - retval = snrm2 (n, x, incx) - return - end
--- a/liboctave/cruft/blas-xtra/xzdotc.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,7 +0,0 @@ - subroutine xzdotc (n, zx, incx, zy, incy, retval) - double complex zdotc, zx(*), zy(*), retval - integer n, incx, incy - external zdotc - retval = zdotc (n, zx, incx, zy, incy) - return - end
--- a/liboctave/cruft/blas-xtra/xzdotu.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,7 +0,0 @@ - subroutine xzdotu (n, zx, incx, zy, incy, retval) - double complex zdotu, zx(*), zy(*), retval - integer n, incx, incy - external zdotu - retval = zdotu (n, zx, incx, zy, incy) - return - end
--- a/liboctave/cruft/blas-xtra/zconv2.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,77 +0,0 @@ -c Copyright (C) 2010-2017 VZLU Prague, a.s., Czech Republic -c -c Author: Jaroslav Hajek <highegg@gmail.com> -c -c This file is part of Octave. -c -c Octave is free software; you can redistribute it and/or modify it -c under the terms of the GNU General Public License as published by -c the Free Software Foundation; either version 3 of the License, or -c (at your option) any later version. -c -c Octave is distributed in the hope that it will be useful, but -c WITHOUT ANY WARRANTY; without even the implied warranty of -c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -c GNU General Public License for more details. -c -c You should have received a copy of the GNU General Public License -c along with Octave; see the file COPYING. If not, see -c <http://www.gnu.org/licenses/>. -c - subroutine zconv2o(ma,na,a,mb,nb,b,c) -c purpose: a 2-dimensional outer additive convolution. -c equivalent to the following: -c for i = 1:ma -c for j = 1:na -c c(i:i+mb-1,j:j+mb-1) += a(i,j)*b -c endfor -c endfor -c arguments: -c ma,na (in) dimensions of a -c a (in) 1st matrix -c mb,nb (in) dimensions of b -c b (in) 2nd matrix -c c (inout) accumulator matrix, size (ma+mb-1, na+nb-1) -c - integer ma,na,mb,nb - double complex a(ma,na),b(mb,nb) - double complex c(ma+mb-1,na+nb-1) - integer i,j,k - external zaxpy - do k = 1,na - do j = 1,nb - do i = 1,mb - call zaxpy(ma,b(i,j),a(1,k),1,c(i,j+k-1),1) - end do - end do - end do - end subroutine - - subroutine zconv2i(ma,na,a,mb,nb,b,c) -c purpose: a 2-dimensional inner additive convolution. -c equivalent to the following: -c for i = 1:ma-mb+1 -c for j = 1:na-nb+1 -c c(i,j) = sum (sum (a(i+mb-1:-1:i,j+nb-1:-1:j) .* b)) -c endfor -c endfor -c arguments: -c ma,na (in) dimensions of a -c a (in) 1st matrix -c mb,nb (in) dimensions of b -c b (in) 2nd matrix -c c (inout) accumulator matrix, size (ma+mb-1, na+nb-1) -c - integer ma,na,mb,nb - double complex a(ma,na),b(mb,nb) - double complex c(ma-mb+1,na-nb+1) - integer i,j,k - external zaxpy - do k = 1,na-nb+1 - do j = 1,nb - do i = 1,mb - call zaxpy(ma-mb+1,b(i,j),a(mb+1-i,k+nb-j),1,c(1,k),1) - end do - end do - end do - end subroutine
--- a/liboctave/cruft/blas-xtra/zdconv2.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,83 +0,0 @@ -c Copyright (C) 2010-2017 VZLU Prague, a.s., Czech Republic -c -c Author: Jaroslav Hajek <highegg@gmail.com> -c -c This file is part of Octave. -c -c Octave is free software; you can redistribute it and/or modify it -c under the terms of the GNU General Public License as published by -c the Free Software Foundation; either version 3 of the License, or -c (at your option) any later version. -c -c Octave is distributed in the hope that it will be useful, but -c WITHOUT ANY WARRANTY; without even the implied warranty of -c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -c GNU General Public License for more details. -c -c You should have received a copy of the GNU General Public License -c along with Octave; see the file COPYING. If not, see -c <http://www.gnu.org/licenses/>. -c - subroutine zdconv2o(ma,na,a,mb,nb,b,c) -c purpose: a 2-dimensional outer additive convolution. -c equivalent to the following: -c for i = 1:ma -c for j = 1:na -c c(i:i+mb-1,j:j+mb-1) += a(i,j)*b -c endfor -c endfor -c arguments: -c ma,na (in) dimensions of a -c a (in) 1st matrix -c mb,nb (in) dimensions of b -c b (in) 2nd matrix -c c (inout) accumulator matrix, size (ma+mb-1, na+nb-1) -c - integer ma,na,mb,nb - double complex a(ma,na) - double precision b(mb,nb) - double complex c(ma+mb-1,na+nb-1) - double complex btmp - integer i,j,k - external zaxpy - do k = 1,na - do j = 1,nb - do i = 1,mb - btmp = b(i,j) - call zaxpy(ma,btmp,a(1,k),1,c(i,j+k-1),1) - end do - end do - end do - end subroutine - - subroutine zdconv2i(ma,na,a,mb,nb,b,c) -c purpose: a 2-dimensional inner additive convolution. -c equivalent to the following: -c for i = 1:ma-mb+1 -c for j = 1:na-nb+1 -c c(i,j) = sum (sum (a(i:i+mb-1,j:j+nb-1) .* b)) -c endfor -c endfor -c arguments: -c ma,na (in) dimensions of a -c a (in) 1st matrix -c mb,nb (in) dimensions of b -c b (in) 2nd matrix -c c (inout) accumulator matrix, size (ma+mb-1, na+nb-1) -c - integer ma,na,mb,nb - double complex a(ma,na) - double precision b(mb,nb) - double complex c(ma-mb+1,na-nb+1) - double complex btmp - integer i,j,k - external zaxpy - do k = 1,na-nb+1 - do j = 1,nb - do i = 1,mb - btmp = b(i,j) - call zaxpy(ma-mb+1,btmp,a(mb+1-i,k+nb-j),1,c(1,k),1) - end do - end do - end do - end subroutine
--- a/liboctave/cruft/blas-xtra/zdotc3.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,59 +0,0 @@ -c Copyright (C) 2009-2017 VZLU Prague, a.s., Czech Republic -c -c Author: Jaroslav Hajek <highegg@gmail.com> -c -c This file is part of Octave. -c -c Octave is free software; you can redistribute it and/or modify it -c under the terms of the GNU General Public License as published by -c the Free Software Foundation; either version 3 of the License, or -c (at your option) any later version. -c -c Octave is distributed in the hope that it will be useful, but -c WITHOUT ANY WARRANTY; without even the implied warranty of -c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -c GNU General Public License for more details. -c -c You should have received a copy of the GNU General Public License -c along with Octave; see the file COPYING. If not, see -c <http://www.gnu.org/licenses/>. -c - subroutine zdotc3(m,n,k,a,b,c) -c purpose: a 3-dimensional dot product. -c c = sum (conj (a) .* b, 2), where a and b are 3d arrays. -c arguments: -c m,n,k (in) the dimensions of a and b -c a,b (in) double complex input arrays of size (m,k,n) -c c (out) double complex output array, size (m,n) - integer m,n,k,i,j,l - double complex a(m,k,n),b(m,k,n) - double complex c(m,n) - - double complex zdotc - external zdotc - -c quick return if possible. - if (m <= 0 .or. n <= 0) return - - if (m == 1) then -c the column-major case. - do j = 1,n - c(1,j) = zdotc(k,a(1,1,j),1,b(1,1,j),1) - end do - else -c We prefer performance here, because that's what we generally -c do by default in reduction functions. Besides, the accuracy -c of xDOT is questionable. Hence, do a cache-aligned nested loop. - do j = 1,n - do i = 1,m - c(i,j) = 0d0 - end do - do l = 1,k - do i = 1,m - c(i,j) = c(i,j) + conjg(a(i,l,j))*b(i,l,j) - end do - end do - end do - end if - - end subroutine
--- a/liboctave/cruft/blas-xtra/zmatm3.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,69 +0,0 @@ -c Copyright (C) 2009-2017 VZLU Prague, a.s., Czech Republic -c -c Author: Jaroslav Hajek <highegg@gmail.com> -c -c This file is part of Octave. -c -c Octave is free software; you can redistribute it and/or modify it -c under the terms of the GNU General Public License as published by -c the Free Software Foundation; either version 3 of the License, or -c (at your option) any later version. -c -c Octave is distributed in the hope that it will be useful, but -c WITHOUT ANY WARRANTY; without even the implied warranty of -c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -c GNU General Public License for more details. -c -c You should have received a copy of the GNU General Public License -c along with Octave; see the file COPYING. If not, see -c <http://www.gnu.org/licenses/>. -c - subroutine zmatm3(m,n,k,np,a,b,c) -c purpose: a 3-dimensional matrix product. -c given a (m,k,np) array a and (k,n,np) array b, -c calculates a (m,n,np) array c such that -c for i = 1:np -c c(:,:,i) = a(:,:,i) * b(:,:,i) -c -c arguments: -c m,n,k (in) the dimensions -c np (in) number of multiplications -c a (in) a double complex input array, size (m,k,np) -c b (in) a double complex input array, size (k,n,np) -c c (out) a double complex output array, size (m,n,np) - integer m,n,k,np - double complex a(m*k,np),b(k*n,np) - double complex c(m*n,np) - - double complex zdotu,one,zero - parameter (one = 1d0, zero = 0d0) - external zdotu,zgemv,zgemm - integer i - -c quick return if possible. - if (np <= 0) return - - if (m == 1) then - if (n == 1) then - do i = 1,np - c(1,i) = zdotu(k,a(1,i),1,b(1,i),1) - end do - else - do i = 1,np - call zgemv("T",k,n,one,b(1,i),k,a(1,i),1,zero,c(1,i),1) - end do - end if - else - if (n == 1) then - do i = 1,np - call zgemv("N",m,k,one,a(1,i),m,b(1,i),1,zero,c(1,i),1) - end do - else - do i = 1,np - call zgemm("N","N",m,n,k, - + one,a(1,i),m,b(1,i),k,zero,c(1,i),m) - end do - end if - end if - - end subroutine
--- a/liboctave/cruft/daspk/datv.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,130 +0,0 @@ -C Work performed under the auspices of the U.S. Department of Energy -C by Lawrence Livermore National Laboratory under contract number -C W-7405-Eng-48. -C - SUBROUTINE DATV (NEQ, Y, TN, YPRIME, SAVR, V, WGHT, YPTEM, RES, - * IRES, PSOL, Z, VTEM, WP, IWP, CJ, EPLIN, IER, NRE, NPSL, - * RPAR,IPAR) -C -C***BEGIN PROLOGUE DATV -C***DATE WRITTEN 890101 (YYMMDD) -C***REVISION DATE 900926 (YYMMDD) -C -C -C----------------------------------------------------------------------- -C***DESCRIPTION -C -C This routine computes the product -C -C Z = (D-inverse)*(P-inverse)*(dF/dY)*(D*V), -C -C where F(Y) = G(T, Y, CJ*(Y-A)), CJ is a scalar proportional to 1/H, -C and A involves the past history of Y. The quantity CJ*(Y-A) is -C an approximation to the first derivative of Y and is stored -C in the array YPRIME. Note that dF/dY = dG/dY + CJ*dG/dYPRIME. -C -C D is a diagonal scaling matrix, and P is the left preconditioning -C matrix. V is assumed to have L2 norm equal to 1. -C The product is stored in Z and is computed by means of a -C difference quotient, a call to RES, and one call to PSOL. -C -C On entry -C -C NEQ = Problem size, passed to RES and PSOL. -C -C Y = Array containing current dependent variable vector. -C -C YPRIME = Array containing current first derivative of y. -C -C SAVR = Array containing current value of G(T,Y,YPRIME). -C -C V = Real array of length NEQ (can be the same array as Z). -C -C WGHT = Array of length NEQ containing scale factors. -C 1/WGHT(I) are the diagonal elements of the matrix D. -C -C YPTEM = Work array of length NEQ. -C -C VTEM = Work array of length NEQ used to store the -C unscaled version of V. -C -C WP = Real work array used by preconditioner PSOL. -C -C IWP = Integer work array used by preconditioner PSOL. -C -C CJ = Scalar proportional to current value of -C 1/(step size H). -C -C -C On return -C -C Z = Array of length NEQ containing desired scaled -C matrix-vector product. -C -C IRES = Error flag from RES. -C -C IER = Error flag from PSOL. -C -C NRE = The number of calls to RES. -C -C NPSL = The number of calls to PSOL. -C -C----------------------------------------------------------------------- -C***ROUTINES CALLED -C RES, PSOL -C -C***END PROLOGUE DATV -C - INTEGER NEQ, IRES, IWP, IER, NRE, NPSL, IPAR - DOUBLE PRECISION Y, TN, YPRIME, SAVR, V, WGHT, YPTEM, Z, VTEM, - 1 WP, CJ, RPAR - DIMENSION Y(*), YPRIME(*), SAVR(*), V(*), WGHT(*), YPTEM(*), - 1 Z(*), VTEM(*), WP(*), IWP(*), RPAR(*), IPAR(*) - INTEGER I - DOUBLE PRECISION EPLIN - EXTERNAL RES, PSOL -C - IRES = 0 -C----------------------------------------------------------------------- -C Set VTEM = D * V. -C----------------------------------------------------------------------- - DO 10 I = 1,NEQ - 10 VTEM(I) = V(I)/WGHT(I) - IER = 0 -C----------------------------------------------------------------------- -C Store Y in Z and increment Z by VTEM. -C Store YPRIME in YPTEM and increment YPTEM by VTEM*CJ. -C----------------------------------------------------------------------- - DO 20 I = 1,NEQ - YPTEM(I) = YPRIME(I) + VTEM(I)*CJ - 20 Z(I) = Y(I) + VTEM(I) -C----------------------------------------------------------------------- -C Call RES with incremented Y, YPRIME arguments -C stored in Z, YPTEM. VTEM is overwritten with new residual. -C----------------------------------------------------------------------- - CONTINUE - CALL RES(TN,Z,YPTEM,CJ,VTEM,IRES,RPAR,IPAR) - NRE = NRE + 1 - IF (IRES .LT. 0) RETURN -C----------------------------------------------------------------------- -C Set Z = (dF/dY) * VBAR using difference quotient. -C (VBAR is old value of VTEM before calling RES) -C----------------------------------------------------------------------- - DO 70 I = 1,NEQ - 70 Z(I) = VTEM(I) - SAVR(I) -C----------------------------------------------------------------------- -C Apply inverse of left preconditioner to Z. -C----------------------------------------------------------------------- - CALL PSOL (NEQ, TN, Y, YPRIME, SAVR, YPTEM, CJ, WGHT, WP, IWP, - 1 Z, EPLIN, IER, RPAR, IPAR) - NPSL = NPSL + 1 - IF (IER .NE. 0) RETURN -C----------------------------------------------------------------------- -C Apply D-inverse to Z and return. -C----------------------------------------------------------------------- - DO 90 I = 1,NEQ - 90 Z(I) = Z(I)*WGHT(I) - RETURN -C -C------END OF SUBROUTINE DATV------------------------------------------- - END
--- a/liboctave/cruft/daspk/dcnst0.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,75 +0,0 @@ -C Work performed under the auspices of the U.S. Department of Energy -C by Lawrence Livermore National Laboratory under contract number -C W-7405-Eng-48. -C - SUBROUTINE DCNST0 (NEQ, Y, ICNSTR, IRET) -C -C***BEGIN PROLOGUE DCNST0 -C***DATE WRITTEN 950808 (YYMMDD) -C***REVISION DATE 950808 (YYMMDD) -C -C -C----------------------------------------------------------------------- -C***DESCRIPTION -C -C This subroutine checks for constraint violations in the initial -C approximate solution u. -C -C On entry -C -C NEQ -- size of the nonlinear system, and the length of arrays -C Y and ICNSTR. -C -C Y -- real array containing the initial approximate root. -C -C ICNSTR -- INTEGER array of length NEQ containing flags indicating -C which entries in Y are to be constrained. -C if ICNSTR(I) = 2, then Y(I) must be .GT. 0, -C if ICNSTR(I) = 1, then Y(I) must be .GE. 0, -C if ICNSTR(I) = -1, then Y(I) must be .LE. 0, while -C if ICNSTR(I) = -2, then Y(I) must be .LT. 0, while -C if ICNSTR(I) = 0, then Y(I) is not constrained. -C -C On return -C -C IRET -- output flag. -C IRET=0 means that u satisfied all constraints. -C IRET.NE.0 means that Y(IRET) failed to satisfy its -C constraint. -C -C----------------------------------------------------------------------- - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - DIMENSION Y(NEQ), ICNSTR(NEQ) - SAVE ZERO - DATA ZERO/0.D0/ -C----------------------------------------------------------------------- -C Check constraints for initial Y. If a constraint has been violated, -C set IRET = I to signal an error return to calling routine. -C----------------------------------------------------------------------- - IRET = 0 - DO 100 I = 1,NEQ - IF (ICNSTR(I) .EQ. 2) THEN - IF (Y(I) .LE. ZERO) THEN - IRET = I - RETURN - ENDIF - ELSEIF (ICNSTR(I) .EQ. 1) THEN - IF (Y(I) .LT. ZERO) THEN - IRET = I - RETURN - ENDIF - ELSEIF (ICNSTR(I) .EQ. -1) THEN - IF (Y(I) .GT. ZERO) THEN - IRET = I - RETURN - ENDIF - ELSEIF (ICNSTR(I) .EQ. -2) THEN - IF (Y(I) .GE. ZERO) THEN - IRET = I - RETURN - ENDIF - ENDIF - 100 CONTINUE - RETURN -C----------------------- END OF SUBROUTINE DCNST0 ---------------------- - END
--- a/liboctave/cruft/daspk/dcnstr.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,124 +0,0 @@ -C Work performed under the auspices of the U.S. Department of Energy -C by Lawrence Livermore National Laboratory under contract number -C W-7405-Eng-48. -C - SUBROUTINE DCNSTR (NEQ, Y, YNEW, ICNSTR, TAU, RLX, IRET, IVAR) -C -C***BEGIN PROLOGUE DCNSTR -C***DATE WRITTEN 950808 (YYMMDD) -C***REVISION DATE 950814 (YYMMDD) -C -C -C----------------------------------------------------------------------- -C***DESCRIPTION -C -C This subroutine checks for constraint violations in the proposed -C new approximate solution YNEW. -C If a constraint violation occurs, then a new step length, TAU, -C is calculated, and this value is to be given to the linesearch routine -C to calculate a new approximate solution YNEW. -C -C On entry: -C -C NEQ -- size of the nonlinear system, and the length of arrays -C Y, YNEW and ICNSTR. -C -C Y -- real array containing the current approximate y. -C -C YNEW -- real array containing the new approximate y. -C -C ICNSTR -- INTEGER array of length NEQ containing flags indicating -C which entries in YNEW are to be constrained. -C if ICNSTR(I) = 2, then YNEW(I) must be .GT. 0, -C if ICNSTR(I) = 1, then YNEW(I) must be .GE. 0, -C if ICNSTR(I) = -1, then YNEW(I) must be .LE. 0, while -C if ICNSTR(I) = -2, then YNEW(I) must be .LT. 0, while -C if ICNSTR(I) = 0, then YNEW(I) is not constrained. -C -C RLX -- real scalar restricting update, if ICNSTR(I) = 2 or -2, -C to ABS( (YNEW-Y)/Y ) < FAC2*RLX in component I. -C -C TAU -- the current size of the step length for the linesearch. -C -C On return -C -C TAU -- the adjusted size of the step length if a constraint -C violation occurred (otherwise, it is unchanged). it is -C the step length to give to the linesearch routine. -C -C IRET -- output flag. -C IRET=0 means that YNEW satisfied all constraints. -C IRET=1 means that YNEW failed to satisfy all the -C constraints, and a new linesearch step -C must be computed. -C -C IVAR -- index of variable causing constraint to be violated. -C -C----------------------------------------------------------------------- - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - DIMENSION Y(NEQ), YNEW(NEQ), ICNSTR(NEQ) - SAVE FAC, FAC2, ZERO - DATA FAC /0.6D0/, FAC2 /0.9D0/, ZERO/0.0D0/ -C----------------------------------------------------------------------- -C Check constraints for proposed new step YNEW. If a constraint has -C been violated, then calculate a new step length, TAU, to be -C used in the linesearch routine. -C----------------------------------------------------------------------- - IRET = 0 - RDYMX = ZERO - IVAR = 0 - DO 100 I = 1,NEQ -C - IF (ICNSTR(I) .EQ. 2) THEN - RDY = ABS( (YNEW(I)-Y(I))/Y(I) ) - IF (RDY .GT. RDYMX) THEN - RDYMX = RDY - IVAR = I - ENDIF - IF (YNEW(I) .LE. ZERO) THEN - TAU = FAC*TAU - IVAR = I - IRET = 1 - RETURN - ENDIF -C - ELSEIF (ICNSTR(I) .EQ. 1) THEN - IF (YNEW(I) .LT. ZERO) THEN - TAU = FAC*TAU - IVAR = I - IRET = 1 - RETURN - ENDIF -C - ELSEIF (ICNSTR(I) .EQ. -1) THEN - IF (YNEW(I) .GT. ZERO) THEN - TAU = FAC*TAU - IVAR = I - IRET = 1 - RETURN - ENDIF -C - ELSEIF (ICNSTR(I) .EQ. -2) THEN - RDY = ABS( (YNEW(I)-Y(I))/Y(I) ) - IF (RDY .GT. RDYMX) THEN - RDYMX = RDY - IVAR = I - ENDIF - IF (YNEW(I) .GE. ZERO) THEN - TAU = FAC*TAU - IVAR = I - IRET = 1 - RETURN - ENDIF -C - ENDIF - 100 CONTINUE - - IF(RDYMX .GE. RLX) THEN - TAU = FAC2*TAU*RLX/RDYMX - IRET = 1 - ENDIF -C - RETURN -C----------------------- END OF SUBROUTINE DCNSTR ---------------------- - END
--- a/liboctave/cruft/daspk/ddasic.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,169 +0,0 @@ -C Work performed under the auspices of the U.S. Department of Energy -C by Lawrence Livermore National Laboratory under contract number -C W-7405-Eng-48. -C - SUBROUTINE DDASIC (X, Y, YPRIME, NEQ, ICOPT, ID, RES, JAC, PSOL, - * H, WT, NIC, IDID, RPAR, IPAR, PHI, SAVR, DELTA, E, YIC, YPIC, - * PWK, WM, IWM, HMIN, UROUND, EPLI, SQRTN, RSQRTN, EPCONI, - * STPTOL, JFLG, ICNFLG, ICNSTR, NLSIC) -C -C***BEGIN PROLOGUE DDASIC -C***REFER TO DDASPK -C***DATE WRITTEN 940628 (YYMMDD) -C***REVISION DATE 941206 (YYMMDD) -C***REVISION DATE 950714 (YYMMDD) -C -C----------------------------------------------------------------------- -C***DESCRIPTION -C -C DDASIC is a driver routine to compute consistent initial values -C for Y and YPRIME. There are two different options: -C Denoting the differential variables in Y by Y_d, and -C the algebraic variables by Y_a, the problem solved is either: -C 1. Given Y_d, calculate Y_a and Y_d', or -C 2. Given Y', calculate Y. -C In either case, initial values for the given components -C are input, and initial guesses for the unknown components -C must also be provided as input. -C -C The external routine NLSIC solves the resulting nonlinear system. -C -C The parameters represent -C -C X -- Independent variable. -C Y -- Solution vector at X. -C YPRIME -- Derivative of solution vector. -C NEQ -- Number of equations to be integrated. -C ICOPT -- Flag indicating initial condition option chosen. -C ICOPT = 1 for option 1 above. -C ICOPT = 2 for option 2. -C ID -- Array of dimension NEQ, which must be initialized -C if option 1 is chosen. -C ID(i) = +1 if Y_i is a differential variable, -C ID(i) = -1 if Y_i is an algebraic variable. -C RES -- External user-supplied subroutine to evaluate the -C residual. See RES description in DDASPK prologue. -C JAC -- External user-supplied routine to update Jacobian -C or preconditioner information in the nonlinear solver -C (optional). See JAC description in DDASPK prologue. -C PSOL -- External user-supplied routine to solve -C a linear system using preconditioning. -C See PSOL in DDASPK prologue. -C H -- Scaling factor in iteration matrix. DDASIC may -C reduce H to achieve convergence. -C WT -- Vector of weights for error criterion. -C NIC -- Input number of initial condition calculation call -C (= 1 or 2). -C IDID -- Completion code. See IDID in DDASPK prologue. -C RPAR,IPAR -- Real and integer parameter arrays that -C are used for communication between the -C calling program and external user routines. -C They are not altered by DNSK -C PHI -- Work space for DDASIC of length at least 2*NEQ. -C SAVR -- Work vector for DDASIC of length NEQ. -C DELTA -- Work vector for DDASIC of length NEQ. -C E -- Work vector for DDASIC of length NEQ. -C YIC,YPIC -- Work vectors for DDASIC, each of length NEQ. -C PWK -- Work vector for DDASIC of length NEQ. -C WM,IWM -- Real and integer arrays storing -C information required by the linear solver. -C EPCONI -- Test constant for Newton iteration convergence. -C ICNFLG -- Flag showing whether constraints on Y are to apply. -C ICNSTR -- Integer array of length NEQ with constraint types. -C -C The other parameters are for use internally by DDASIC. -C -C----------------------------------------------------------------------- -C***ROUTINES CALLED -C DCOPY, NLSIC -C -C***END PROLOGUE DDASIC -C -C - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - DIMENSION Y(*),YPRIME(*),ID(*),WT(*),PHI(NEQ,*) - DIMENSION SAVR(*),DELTA(*),E(*),YIC(*),YPIC(*),PWK(*) - DIMENSION WM(*),IWM(*), RPAR(*),IPAR(*), ICNSTR(*) - EXTERNAL RES, JAC, PSOL, NLSIC -C - PARAMETER (LCFN=15) - PARAMETER (LMXNH=34) -C -C The following parameters are data-loaded here: -C RHCUT = factor by which H is reduced on retry of Newton solve. -C RATEMX = maximum convergence rate for which Newton iteration -C is considered converging. -C - SAVE RHCUT, RATEMX - DATA RHCUT/0.1D0/, RATEMX/0.8D0/ -C -C -C----------------------------------------------------------------------- -C BLOCK 1. -C Initializations. -C JSKIP is a flag set to 1 when NIC = 2 and NH = 1, to signal that -C the initial call to the JAC routine is to be skipped then. -C Save Y and YPRIME in PHI. Initialize IDID, NH, and CJ. -C----------------------------------------------------------------------- -C - MXNH = IWM(LMXNH) - IDID = 1 - NH = 1 - JSKIP = 0 - IF (NIC .EQ. 2) JSKIP = 1 - CALL DCOPY (NEQ, Y, 1, PHI(1,1), 1) - CALL DCOPY (NEQ, YPRIME, 1, PHI(1,2), 1) -C - IF (ICOPT .EQ. 2) THEN - CJ = 0.0D0 - ELSE - CJ = 1.0D0/H - ENDIF -C -C----------------------------------------------------------------------- -C BLOCK 2 -C Call the nonlinear system solver to obtain -C consistent initial values for Y and YPRIME. -C----------------------------------------------------------------------- -C - 200 CONTINUE - CALL NLSIC(X,Y,YPRIME,NEQ,ICOPT,ID,RES,JAC,PSOL,H,WT,JSKIP, - * RPAR,IPAR,SAVR,DELTA,E,YIC,YPIC,PWK,WM,IWM,CJ,UROUND, - * EPLI,SQRTN,RSQRTN,EPCONI,RATEMX,STPTOL,JFLG,ICNFLG,ICNSTR, - * IERNLS) -C - IF (IERNLS .EQ. 0) RETURN -C -C----------------------------------------------------------------------- -C BLOCK 3 -C The nonlinear solver was unsuccessful. Increment NCFN. -C Return with IDID = -12 if either -C IERNLS = -1: error is considered unrecoverable, -C ICOPT = 2: we are doing initialization problem type 2, or -C NH = MXNH: the maximum number of H values has been tried. -C Otherwise (problem 1 with IERNLS .GE. 1), reduce H and try again. -C If IERNLS > 1, restore Y and YPRIME to their original values. -C----------------------------------------------------------------------- -C - IWM(LCFN) = IWM(LCFN) + 1 - JSKIP = 0 -C - IF (IERNLS .EQ. -1) GO TO 350 - IF (ICOPT .EQ. 2) GO TO 350 - IF (NH .EQ. MXNH) GO TO 350 -C - NH = NH + 1 - H = H*RHCUT - CJ = 1.0D0/H -C - IF (IERNLS .EQ. 1) GO TO 200 -C - CALL DCOPY (NEQ, PHI(1,1), 1, Y, 1) - CALL DCOPY (NEQ, PHI(1,2), 1, YPRIME, 1) - GO TO 200 -C - 350 IDID = -12 - RETURN -C -C------END OF SUBROUTINE DDASIC----------------------------------------- - END
--- a/liboctave/cruft/daspk/ddasid.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,168 +0,0 @@ -C Work performed under the auspices of the U.S. Department of Energy -C by Lawrence Livermore National Laboratory under contract number -C W-7405-Eng-48. -C - SUBROUTINE DDASID(X,Y,YPRIME,NEQ,ICOPT,ID,RES,JACD,PDUM,H,WT, - * JSDUM,RPAR,IPAR,DUMSVR,DELTA,R,YIC,YPIC,DUMPWK,WM,IWM,CJ,UROUND, - * DUME,DUMS,DUMR,EPCON,RATEMX,STPTOL,JFDUM, - * ICNFLG,ICNSTR,IERNLS) -C -C***BEGIN PROLOGUE DDASID -C***REFER TO DDASPK -C***DATE WRITTEN 940701 (YYMMDD) -C***REVISION DATE 950808 (YYMMDD) -C***REVISION DATE 951110 Removed unreachable block 390. -C -C -C----------------------------------------------------------------------- -C***DESCRIPTION -C -C -C DDASID solves a nonlinear system of algebraic equations of the -C form G(X,Y,YPRIME) = 0 for the unknown parts of Y and YPRIME in -C the initial conditions. -C -C The method used is a modified Newton scheme. -C -C The parameters represent -C -C X -- Independent variable. -C Y -- Solution vector. -C YPRIME -- Derivative of solution vector. -C NEQ -- Number of unknowns. -C ICOPT -- Initial condition option chosen (1 or 2). -C ID -- Array of dimension NEQ, which must be initialized -C if ICOPT = 1. See DDASIC. -C RES -- External user-supplied subroutine to evaluate the -C residual. See RES description in DDASPK prologue. -C JACD -- External user-supplied routine to evaluate the -C Jacobian. See JAC description for the case -C INFO(12) = 0 in the DDASPK prologue. -C PDUM -- Dummy argument. -C H -- Scaling factor for this initial condition calc. -C WT -- Vector of weights for error criterion. -C JSDUM -- Dummy argument. -C RPAR,IPAR -- Real and integer arrays used for communication -C between the calling program and external user -C routines. They are not altered within DASPK. -C DUMSVR -- Dummy argument. -C DELTA -- Work vector for NLS of length NEQ. -C R -- Work vector for NLS of length NEQ. -C YIC,YPIC -- Work vectors for NLS, each of length NEQ. -C DUMPWK -- Dummy argument. -C WM,IWM -- Real and integer arrays storing matrix information -C such as the matrix of partial derivatives, -C permutation vector, and various other information. -C CJ -- Matrix parameter = 1/H (ICOPT = 1) or 0 (ICOPT = 2). -C UROUND -- Unit roundoff. -C DUME -- Dummy argument. -C DUMS -- Dummy argument. -C DUMR -- Dummy argument. -C EPCON -- Tolerance to test for convergence of the Newton -C iteration. -C RATEMX -- Maximum convergence rate for which Newton iteration -C is considered converging. -C JFDUM -- Dummy argument. -C STPTOL -- Tolerance used in calculating the minimum lambda -C value allowed. -C ICNFLG -- Integer scalar. If nonzero, then constraint -C violations in the proposed new approximate solution -C will be checked for, and the maximum step length -C will be adjusted accordingly. -C ICNSTR -- Integer array of length NEQ containing flags for -C checking constraints. -C IERNLS -- Error flag for nonlinear solver. -C 0 ==> nonlinear solver converged. -C 1,2 ==> recoverable error inside nonlinear solver. -C 1 => retry with current Y, YPRIME -C 2 => retry with original Y, YPRIME -C -1 ==> unrecoverable error in nonlinear solver. -C -C All variables with "DUM" in their names are dummy variables -C which are not used in this routine. -C -C----------------------------------------------------------------------- -C -C***ROUTINES CALLED -C RES, DMATD, DNSID -C -C***END PROLOGUE DDASID -C -C - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - DIMENSION Y(*),YPRIME(*),ID(*),WT(*),ICNSTR(*) - DIMENSION DELTA(*),R(*),YIC(*),YPIC(*) - DIMENSION WM(*),IWM(*), RPAR(*),IPAR(*) - EXTERNAL RES, JACD -C - PARAMETER (LNRE=12, LNJE=13, LMXNIT=32, LMXNJ=33) -C -C -C Perform initializations. -C - MXNIT = IWM(LMXNIT) - MXNJ = IWM(LMXNJ) - IERNLS = 0 - NJ = 0 -C -C Call RES to initialize DELTA. -C - IRES = 0 - IWM(LNRE) = IWM(LNRE) + 1 - CALL RES(X,Y,YPRIME,CJ,DELTA,IRES,RPAR,IPAR) - IF (IRES .LT. 0) GO TO 370 -C -C Looping point for updating the Jacobian. -C -300 CONTINUE -C -C Initialize all error flags to zero. -C - IERJ = 0 - IRES = 0 - IERNEW = 0 -C -C Reevaluate the iteration matrix, J = dG/dY + CJ*dG/dYPRIME, -C where G(X,Y,YPRIME) = 0. -C - NJ = NJ + 1 - IWM(LNJE)=IWM(LNJE)+1 - CALL DMATD(NEQ,X,Y,YPRIME,DELTA,CJ,H,IERJ,WT,R, - * WM,IWM,RES,IRES,UROUND,JACD,RPAR,IPAR) - IF (IRES .LT. 0 .OR. IERJ .NE. 0) GO TO 370 -C -C Call the nonlinear Newton solver for up to MXNIT iterations. -C - CALL DNSID(X,Y,YPRIME,NEQ,ICOPT,ID,RES,WT,RPAR,IPAR,DELTA,R, - * YIC,YPIC,WM,IWM,CJ,EPCON,RATEMX,MXNIT,STPTOL, - * ICNFLG,ICNSTR,IERNEW) -C - IF (IERNEW .EQ. 1 .AND. NJ .LT. MXNJ) THEN -C -C MXNIT iterations were done, the convergence rate is < 1, -C and the number of Jacobian evaluations is less than MXNJ. -C Call RES, reevaluate the Jacobian, and try again. -C - IWM(LNRE)=IWM(LNRE)+1 - CALL RES(X,Y,YPRIME,CJ,DELTA,IRES,RPAR,IPAR) - IF (IRES .LT. 0) GO TO 370 - GO TO 300 - ENDIF -C - IF (IERNEW .NE. 0) GO TO 380 - - RETURN -C -C -C Unsuccessful exits from nonlinear solver. -C Compute IERNLS accordingly. -C -370 IERNLS = 2 - IF (IRES .LE. -2) IERNLS = -1 - RETURN -C -380 IERNLS = MIN(IERNEW,2) - RETURN -C -C------END OF SUBROUTINE DDASID----------------------------------------- - END
--- a/liboctave/cruft/daspk/ddasik.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,176 +0,0 @@ -C Work perfored under the auspices of the U.S. Department of Energy -C by Lawrence Livermore National Laboratory under contract number -C W-7405-Eng-48. -C - SUBROUTINE DDASIK(X,Y,YPRIME,NEQ,ICOPT,ID,RES,JACK,PSOL,H,WT, - * JSKIP,RPAR,IPAR,SAVR,DELTA,R,YIC,YPIC,PWK,WM,IWM,CJ,UROUND, - * EPLI,SQRTN,RSQRTN,EPCON,RATEMX,STPTOL,JFLG, - * ICNFLG,ICNSTR,IERNLS) -C -C***BEGIN PROLOGUE DDASIK -C***REFER TO DDASPK -C***DATE WRITTEN 941026 (YYMMDD) -C***REVISION DATE 950808 (YYMMDD) -C***REVISION DATE 951110 Removed unreachable block 390. -C -C -C----------------------------------------------------------------------- -C***DESCRIPTION -C -C -C DDASIK solves a nonlinear system of algebraic equations of the -C form G(X,Y,YPRIME) = 0 for the unknown parts of Y and YPRIME in -C the initial conditions. -C -C An initial value for Y and initial guess for YPRIME are input. -C -C The method used is a Newton scheme with Krylov iteration and a -C linesearch algorithm. -C -C The parameters represent -C -C X -- Independent variable. -C Y -- Solution vector at x. -C YPRIME -- Derivative of solution vector. -C NEQ -- Number of equations to be integrated. -C ICOPT -- Initial condition option chosen (1 or 2). -C ID -- Array of dimension NEQ, which must be initialized -C if ICOPT = 1. See DDASIC. -C RES -- External user-supplied subroutine -C to evaluate the residual. See RES description -C in DDASPK prologue. -C JACK -- External user-supplied routine to update -C the preconditioner. (This is optional). -C See JAC description for the case -C INFO(12) = 1 in the DDASPK prologue. -C PSOL -- External user-supplied routine to solve -C a linear system using preconditioning. -C (This is optional). See explanation inside DDASPK. -C H -- Scaling factor for this initial condition calc. -C WT -- Vector of weights for error criterion. -C JSKIP -- input flag to signal if initial JAC call is to be -C skipped. 1 => skip the call, 0 => do not skip call. -C RPAR,IPAR -- Real and integer arrays used for communication -C between the calling program and external user -C routines. They are not altered within DASPK. -C SAVR -- Work vector for DDASIK of length NEQ. -C DELTA -- Work vector for DDASIK of length NEQ. -C R -- Work vector for DDASIK of length NEQ. -C YIC,YPIC -- Work vectors for DDASIK, each of length NEQ. -C PWK -- Work vector for DDASIK of length NEQ. -C WM,IWM -- Real and integer arrays storing -C matrix information for linear system -C solvers, and various other information. -C CJ -- Matrix parameter = 1/H (ICOPT = 1) or 0 (ICOPT = 2). -C UROUND -- Unit roundoff. -C EPLI -- convergence test constant. -C See DDASPK prologue for more details. -C SQRTN -- Square root of NEQ. -C RSQRTN -- reciprical of square root of NEQ. -C EPCON -- Tolerance to test for convergence of the Newton -C iteration. -C RATEMX -- Maximum convergence rate for which Newton iteration -C is considered converging. -C JFLG -- Flag showing whether a Jacobian routine is supplied. -C ICNFLG -- Integer scalar. If nonzero, then constraint -C violations in the proposed new approximate solution -C will be checked for, and the maximum step length -C will be adjusted accordingly. -C ICNSTR -- Integer array of length NEQ containing flags for -C checking constraints. -C IERNLS -- Error flag for nonlinear solver. -C 0 ==> nonlinear solver converged. -C 1,2 ==> recoverable error inside nonlinear solver. -C 1 => retry with current Y, YPRIME -C 2 => retry with original Y, YPRIME -C -1 ==> unrecoverable error in nonlinear solver. -C -C----------------------------------------------------------------------- -C -C***ROUTINES CALLED -C RES, JACK, DNSIK, DCOPY -C -C***END PROLOGUE DDASIK -C -C - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - DIMENSION Y(*),YPRIME(*),ID(*),WT(*),ICNSTR(*) - DIMENSION SAVR(*),DELTA(*),R(*),YIC(*),YPIC(*),PWK(*) - DIMENSION WM(*),IWM(*), RPAR(*),IPAR(*) - EXTERNAL RES, JACK, PSOL -C - PARAMETER (LNRE=12, LNJE=13, LLOCWP=29, LLCIWP=30) - PARAMETER (LMXNIT=32, LMXNJ=33) -C -C -C Perform initializations. -C - LWP = IWM(LLOCWP) - LIWP = IWM(LLCIWP) - MXNIT = IWM(LMXNIT) - MXNJ = IWM(LMXNJ) - IERNLS = 0 - NJ = 0 - EPLIN = EPLI*EPCON -C -C Call RES to initialize DELTA. -C - IRES = 0 - IWM(LNRE) = IWM(LNRE) + 1 - CALL RES(X,Y,YPRIME,CJ,DELTA,IRES,RPAR,IPAR) - IF (IRES .LT. 0) GO TO 370 -C -C Looping point for updating the preconditioner. -C - 300 CONTINUE -C -C Initialize all error flags to zero. -C - IERPJ = 0 - IRES = 0 - IERNEW = 0 -C -C If a Jacobian routine was supplied, call it. -C - IF (JFLG .EQ. 1 .AND. JSKIP .EQ. 0) THEN - NJ = NJ + 1 - IWM(LNJE)=IWM(LNJE)+1 - CALL JACK (RES, IRES, NEQ, X, Y, YPRIME, WT, DELTA, R, H, CJ, - * WM(LWP), IWM(LIWP), IERPJ, RPAR, IPAR) - IF (IRES .LT. 0 .OR. IERPJ .NE. 0) GO TO 370 - ENDIF - JSKIP = 0 -C -C Call the nonlinear Newton solver for up to MXNIT iterations. -C - CALL DNSIK(X,Y,YPRIME,NEQ,ICOPT,ID,RES,PSOL,WT,RPAR,IPAR, - * SAVR,DELTA,R,YIC,YPIC,PWK,WM,IWM,CJ,SQRTN,RSQRTN, - * EPLIN,EPCON,RATEMX,MXNIT,STPTOL,ICNFLG,ICNSTR,IERNEW) -C - IF (IERNEW .EQ. 1 .AND. NJ .LT. MXNJ .AND. JFLG .EQ. 1) THEN -C -C Up to MXNIT iterations were done, the convergence rate is < 1, -C a Jacobian routine is supplied, and the number of JACK calls -C is less than MXNJ. -C Copy the residual SAVR to DELTA, call JACK, and try again. -C - CALL DCOPY (NEQ, SAVR, 1, DELTA, 1) - GO TO 300 - ENDIF -C - IF (IERNEW .NE. 0) GO TO 380 - RETURN -C -C -C Unsuccessful exits from nonlinear solver. -C Set IERNLS accordingly. -C - 370 IERNLS = 2 - IF (IRES .LE. -2) IERNLS = -1 - RETURN -C - 380 IERNLS = MIN(IERNEW,2) - RETURN -C -C----------------------- END OF SUBROUTINE DDASIK----------------------- - END
--- a/liboctave/cruft/daspk/ddaspk.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,2360 +0,0 @@ -C Work performed under the auspices of the U.S. Department of Energy -C by Lawrence Livermore National Laboratory under contract number -C W-7405-Eng-48. -C - SUBROUTINE DDASPK (RES, NEQ, T, Y, YPRIME, TOUT, INFO, RTOL, ATOL, - * IDID, RWORK, LRW, IWORK, LIW, RPAR, IPAR, JAC, PSOL) -C -C***BEGIN PROLOGUE DDASPK -C***DATE WRITTEN 890101 (YYMMDD) -C***REVISION DATE 910624 -C***REVISION DATE 920929 (CJ in RES call, RES counter fix.) -C***REVISION DATE 921215 (Warnings on poor iteration performance) -C***REVISION DATE 921216 (NRMAX as optional input) -C***REVISION DATE 930315 (Name change: DDINI to DDINIT) -C***REVISION DATE 940822 (Replaced initial condition calculation) -C***REVISION DATE 941101 (Added linesearch in I.C. calculations) -C***REVISION DATE 941220 (Misc. corrections throughout) -C***REVISION DATE 950125 (Added DINVWT routine) -C***REVISION DATE 950714 (Misc. corrections throughout) -C***REVISION DATE 950802 (Default NRMAX = 5, based on tests.) -C***REVISION DATE 950808 (Optional error test added.) -C***REVISION DATE 950814 (Added I.C. constraints and INFO(14)) -C***REVISION DATE 950828 (Various minor corrections.) -C***REVISION DATE 951006 (Corrected WT scaling in DFNRMK.) -C***REVISION DATE 960129 (Corrected RL bug in DLINSD, DLINSK.) -C***REVISION DATE 960301 (Added NONNEG to SAVE statement.) -C***CATEGORY NO. I1A2 -C***KEYWORDS DIFFERENTIAL/ALGEBRAIC, BACKWARD DIFFERENTIATION FORMULAS, -C IMPLICIT DIFFERENTIAL SYSTEMS, KRYLOV ITERATION -C***AUTHORS Linda R. Petzold, Peter N. Brown, Alan C. Hindmarsh, and -C Clement W. Ulrich -C Center for Computational Sciences & Engineering, L-316 -C Lawrence Livermore National Laboratory -C P.O. Box 808, -C Livermore, CA 94551 -C***PURPOSE This code solves a system of differential/algebraic -C equations of the form -C G(t,y,y') = 0 , -C using a combination of Backward Differentiation Formula -C (BDF) methods and a choice of two linear system solution -C methods: direct (dense or band) or Krylov (iterative). -C This version is in double precision. -C----------------------------------------------------------------------- -C***DESCRIPTION -C -C *Usage: -C -C IMPLICIT DOUBLE PRECISION(A-H,O-Z) -C INTEGER NEQ, INFO(N), IDID, LRW, LIW, IWORK(LIW), IPAR(*) -C DOUBLE PRECISION T, Y(*), YPRIME(*), TOUT, RTOL(*), ATOL(*), -C RWORK(LRW), RPAR(*) -C EXTERNAL RES, JAC, PSOL -C -C CALL DDASPK (RES, NEQ, T, Y, YPRIME, TOUT, INFO, RTOL, ATOL, -C * IDID, RWORK, LRW, IWORK, LIW, RPAR, IPAR, JAC, PSOL) -C -C Quantities which may be altered by the code are: -C T, Y(*), YPRIME(*), INFO(*), RTOL, ATOL, IDID, RWORK(*), IWORK(*) -C -C -C *Arguments: -C -C RES:EXT This is the name of a subroutine which you -C provide to define the residual function G(t,y,y') -C of the differential/algebraic system. -C -C NEQ:IN This is the number of equations in the system. -C -C T:INOUT This is the current value of the independent -C variable. -C -C Y(*):INOUT This array contains the solution components at T. -C -C YPRIME(*):INOUT This array contains the derivatives of the solution -C components at T. -C -C TOUT:IN This is a point at which a solution is desired. -C -C INFO(N):IN This is an integer array used to communicate details -C of how the solution is to be carried out, such as -C tolerance type, matrix structure, step size and -C order limits, and choice of nonlinear system method. -C N must be at least 20. -C -C RTOL,ATOL:INOUT These quantities represent absolute and relative -C error tolerances (on local error) which you provide -C to indicate how accurately you wish the solution to -C be computed. You may choose them to be both scalars -C or else both arrays of length NEQ. -C -C IDID:OUT This integer scalar is an indicator reporting what -C the code did. You must monitor this variable to -C decide what action to take next. -C -C RWORK:WORK A real work array of length LRW which provides the -C code with needed storage space. -C -C LRW:IN The length of RWORK. -C -C IWORK:WORK An integer work array of length LIW which provides -C the code with needed storage space. -C -C LIW:IN The length of IWORK. -C -C RPAR,IPAR:IN These are real and integer parameter arrays which -C you can use for communication between your calling -C program and the RES, JAC, and PSOL subroutines. -C -C JAC:EXT This is the name of a subroutine which you may -C provide (optionally) for calculating Jacobian -C (partial derivative) data involved in solving linear -C systems within DDASPK. -C -C PSOL:EXT This is the name of a subroutine which you must -C provide for solving linear systems if you selected -C a Krylov method. The purpose of PSOL is to solve -C linear systems involving a left preconditioner P. -C -C *Overview -C -C The DDASPK solver uses the backward differentiation formulas of -C orders one through five to solve a system of the form G(t,y,y') = 0 -C for y = Y and y' = YPRIME. Values for Y and YPRIME at the initial -C time must be given as input. These values should be consistent, -C that is, if T, Y, YPRIME are the given initial values, they should -C satisfy G(T,Y,YPRIME) = 0. However, if consistent values are not -C known, in many cases you can have DDASPK solve for them -- see INFO(11). -C (This and other options are described in more detail below.) -C -C Normally, DDASPK solves the system from T to TOUT. It is easy to -C continue the solution to get results at additional TOUT. This is -C the interval mode of operation. Intermediate results can also be -C obtained easily by specifying INFO(3). -C -C On each step taken by DDASPK, a sequence of nonlinear algebraic -C systems arises. These are solved by one of two types of -C methods: -C * a Newton iteration with a direct method for the linear -C systems involved (INFO(12) = 0), or -C * a Newton iteration with a preconditioned Krylov iterative -C method for the linear systems involved (INFO(12) = 1). -C -C The direct method choices are dense and band matrix solvers, -C with either a user-supplied or an internal difference quotient -C Jacobian matrix, as specified by INFO(5) and INFO(6). -C In the band case, INFO(6) = 1, you must supply half-bandwidths -C in IWORK(1) and IWORK(2). -C -C The Krylov method is the Generalized Minimum Residual (GMRES) -C method, in either complete or incomplete form, and with -C scaling and preconditioning. The method is implemented -C in an algorithm called SPIGMR. Certain options in the Krylov -C method case are specified by INFO(13) and INFO(15). -C -C If the Krylov method is chosen, you may supply a pair of routines, -C JAC and PSOL, to apply preconditioning to the linear system. -C If the system is A*x = b, the matrix is A = dG/dY + CJ*dG/dYPRIME -C (of order NEQ). This system can then be preconditioned in the form -C (P-inverse)*A*x = (P-inverse)*b, with left preconditioner P. -C (DDASPK does not allow right preconditioning.) -C Then the Krylov method is applied to this altered, but equivalent, -C linear system, hopefully with much better performance than without -C preconditioning. (In addition, a diagonal scaling matrix based on -C the tolerances is also introduced into the altered system.) -C -C The JAC routine evaluates any data needed for solving systems -C with coefficient matrix P, and PSOL carries out that solution. -C In any case, in order to improve convergence, you should try to -C make P approximate the matrix A as much as possible, while keeping -C the system P*x = b reasonably easy and inexpensive to solve for x, -C given a vector b. -C -C -C *Description -C -C------INPUT - WHAT TO DO ON THE FIRST CALL TO DDASPK------------------- -C -C -C The first call of the code is defined to be the start of each new -C problem. Read through the descriptions of all the following items, -C provide sufficient storage space for designated arrays, set -C appropriate variables for the initialization of the problem, and -C give information about how you want the problem to be solved. -C -C -C RES -- Provide a subroutine of the form -C -C SUBROUTINE RES (T, Y, YPRIME, CJ, DELTA, IRES, RPAR, IPAR) -C -C to define the system of differential/algebraic -C equations which is to be solved. For the given values -C of T, Y and YPRIME, the subroutine should return -C the residual of the differential/algebraic system -C DELTA = G(T,Y,YPRIME) -C DELTA is a vector of length NEQ which is output from RES. -C -C Subroutine RES must not alter T, Y, YPRIME, or CJ. -C You must declare the name RES in an EXTERNAL -C statement in your program that calls DDASPK. -C You must dimension Y, YPRIME, and DELTA in RES. -C -C The input argument CJ can be ignored, or used to rescale -C constraint equations in the system (see Ref. 2, p. 145). -C Note: In this respect, DDASPK is not downward-compatible -C with DDASSL, which does not have the RES argument CJ. -C -C IRES is an integer flag which is always equal to zero -C on input. Subroutine RES should alter IRES only if it -C encounters an illegal value of Y or a stop condition. -C Set IRES = -1 if an input value is illegal, and DDASPK -C will try to solve the problem without getting IRES = -1. -C If IRES = -2, DDASPK will return control to the calling -C program with IDID = -11. -C -C RPAR and IPAR are real and integer parameter arrays which -C you can use for communication between your calling program -C and subroutine RES. They are not altered by DDASPK. If you -C do not need RPAR or IPAR, ignore these parameters by treat- -C ing them as dummy arguments. If you do choose to use them, -C dimension them in your calling program and in RES as arrays -C of appropriate length. -C -C NEQ -- Set it to the number of equations in the system (NEQ .GE. 1). -C -C T -- Set it to the initial point of the integration. (T must be -C a variable.) -C -C Y(*) -- Set this array to the initial values of the NEQ solution -C components at the initial point. You must dimension Y of -C length at least NEQ in your calling program. -C -C YPRIME(*) -- Set this array to the initial values of the NEQ first -C derivatives of the solution components at the initial -C point. You must dimension YPRIME at least NEQ in your -C calling program. -C -C TOUT - Set it to the first point at which a solution is desired. -C You cannot take TOUT = T. Integration either forward in T -C (TOUT .GT. T) or backward in T (TOUT .LT. T) is permitted. -C -C The code advances the solution from T to TOUT using step -C sizes which are automatically selected so as to achieve the -C desired accuracy. If you wish, the code will return with the -C solution and its derivative at intermediate steps (the -C intermediate-output mode) so that you can monitor them, -C but you still must provide TOUT in accord with the basic -C aim of the code. -C -C The first step taken by the code is a critical one because -C it must reflect how fast the solution changes near the -C initial point. The code automatically selects an initial -C step size which is practically always suitable for the -C problem. By using the fact that the code will not step past -C TOUT in the first step, you could, if necessary, restrict the -C length of the initial step. -C -C For some problems it may not be permissible to integrate -C past a point TSTOP, because a discontinuity occurs there -C or the solution or its derivative is not defined beyond -C TSTOP. When you have declared a TSTOP point (see INFO(4) -C and RWORK(1)), you have told the code not to integrate past -C TSTOP. In this case any tout beyond TSTOP is invalid input. -C -C INFO(*) - Use the INFO array to give the code more details about -C how you want your problem solved. This array should be -C dimensioned of length 20, though DDASPK uses only the -C first 15 entries. You must respond to all of the following -C items, which are arranged as questions. The simplest use -C of DDASPK corresponds to setting all entries of INFO to 0. -C -C INFO(1) - This parameter enables the code to initialize itself. -C You must set it to indicate the start of every new -C problem. -C -C **** Is this the first call for this problem ... -C yes - set INFO(1) = 0 -C no - not applicable here. -C See below for continuation calls. **** -C -C INFO(2) - How much accuracy you want of your solution -C is specified by the error tolerances RTOL and ATOL. -C The simplest use is to take them both to be scalars. -C To obtain more flexibility, they can both be arrays. -C The code must be told your choice. -C -C **** Are both error tolerances RTOL, ATOL scalars ... -C yes - set INFO(2) = 0 -C and input scalars for both RTOL and ATOL -C no - set INFO(2) = 1 -C and input arrays for both RTOL and ATOL **** -C -C INFO(3) - The code integrates from T in the direction of TOUT -C by steps. If you wish, it will return the computed -C solution and derivative at the next intermediate step -C (the intermediate-output mode) or TOUT, whichever comes -C first. This is a good way to proceed if you want to -C see the behavior of the solution. If you must have -C solutions at a great many specific TOUT points, this -C code will compute them efficiently. -C -C **** Do you want the solution only at -C TOUT (and not at the next intermediate step) ... -C yes - set INFO(3) = 0 -C no - set INFO(3) = 1 **** -C -C INFO(4) - To handle solutions at a great many specific -C values TOUT efficiently, this code may integrate past -C TOUT and interpolate to obtain the result at TOUT. -C Sometimes it is not possible to integrate beyond some -C point TSTOP because the equation changes there or it is -C not defined past TSTOP. Then you must tell the code -C this stop condition. -C -C **** Can the integration be carried out without any -C restrictions on the independent variable T ... -C yes - set INFO(4) = 0 -C no - set INFO(4) = 1 -C and define the stopping point TSTOP by -C setting RWORK(1) = TSTOP **** -C -C INFO(5) - used only when INFO(12) = 0 (direct methods). -C To solve differential/algebraic systems you may wish -C to use a matrix of partial derivatives of the -C system of differential equations. If you do not -C provide a subroutine to evaluate it analytically (see -C description of the item JAC in the call list), it will -C be approximated by numerical differencing in this code. -C Although it is less trouble for you to have the code -C compute partial derivatives by numerical differencing, -C the solution will be more reliable if you provide the -C derivatives via JAC. Usually numerical differencing is -C more costly than evaluating derivatives in JAC, but -C sometimes it is not - this depends on your problem. -C -C **** Do you want the code to evaluate the partial deriv- -C atives automatically by numerical differences ... -C yes - set INFO(5) = 0 -C no - set INFO(5) = 1 -C and provide subroutine JAC for evaluating the -C matrix of partial derivatives **** -C -C INFO(6) - used only when INFO(12) = 0 (direct methods). -C DDASPK will perform much better if the matrix of -C partial derivatives, dG/dY + CJ*dG/dYPRIME (here CJ is -C a scalar determined by DDASPK), is banded and the code -C is told this. In this case, the storage needed will be -C greatly reduced, numerical differencing will be performed -C much cheaper, and a number of important algorithms will -C execute much faster. The differential equation is said -C to have half-bandwidths ML (lower) and MU (upper) if -C equation i involves only unknowns Y(j) with -C i-ML .le. j .le. i+MU . -C For all i=1,2,...,NEQ. Thus, ML and MU are the widths -C of the lower and upper parts of the band, respectively, -C with the main diagonal being excluded. If you do not -C indicate that the equation has a banded matrix of partial -C derivatives the code works with a full matrix of NEQ**2 -C elements (stored in the conventional way). Computations -C with banded matrices cost less time and storage than with -C full matrices if 2*ML+MU .lt. NEQ. If you tell the -C code that the matrix of partial derivatives has a banded -C structure and you want to provide subroutine JAC to -C compute the partial derivatives, then you must be careful -C to store the elements of the matrix in the special form -C indicated in the description of JAC. -C -C **** Do you want to solve the problem using a full (dense) -C matrix (and not a special banded structure) ... -C yes - set INFO(6) = 0 -C no - set INFO(6) = 1 -C and provide the lower (ML) and upper (MU) -C bandwidths by setting -C IWORK(1)=ML -C IWORK(2)=MU **** -C -C INFO(7) - You can specify a maximum (absolute value of) -C stepsize, so that the code will avoid passing over very -C large regions. -C -C **** Do you want the code to decide on its own the maximum -C stepsize ... -C yes - set INFO(7) = 0 -C no - set INFO(7) = 1 -C and define HMAX by setting -C RWORK(2) = HMAX **** -C -C INFO(8) - Differential/algebraic problems may occasionally -C suffer from severe scaling difficulties on the first -C step. If you know a great deal about the scaling of -C your problem, you can help to alleviate this problem -C by specifying an initial stepsize H0. -C -C **** Do you want the code to define its own initial -C stepsize ... -C yes - set INFO(8) = 0 -C no - set INFO(8) = 1 -C and define H0 by setting -C RWORK(3) = H0 **** -C -C INFO(9) - If storage is a severe problem, you can save some -C storage by restricting the maximum method order MAXORD. -C The default value is 5. For each order decrease below 5, -C the code requires NEQ fewer locations, but it is likely -C to be slower. In any case, you must have -C 1 .le. MAXORD .le. 5. -C **** Do you want the maximum order to default to 5 ... -C yes - set INFO(9) = 0 -C no - set INFO(9) = 1 -C and define MAXORD by setting -C IWORK(3) = MAXORD **** -C -C INFO(10) - If you know that certain components of the -C solutions to your equations are always nonnegative -C (or nonpositive), it may help to set this -C parameter. There are three options that are -C available: -C 1. To have constraint checking only in the initial -C condition calculation. -C 2. To enforce nonnegativity in Y during the integration. -C 3. To enforce both options 1 and 2. -C -C When selecting option 2 or 3, it is probably best to try the -C code without using this option first, and only use -C this option if that does not work very well. -C -C **** Do you want the code to solve the problem without -C invoking any special inequality constraints ... -C yes - set INFO(10) = 0 -C no - set INFO(10) = 1 to have option 1 enforced -C no - set INFO(10) = 2 to have option 2 enforced -C no - set INFO(10) = 3 to have option 3 enforced **** -C -C If you have specified INFO(10) = 1 or 3, then you -C will also need to identify how each component of Y -C in the initial condition calculation is constrained. -C You must set: -C IWORK(40+I) = +1 if Y(I) must be .GE. 0, -C IWORK(40+I) = +2 if Y(I) must be .GT. 0, -C IWORK(40+I) = -1 if Y(I) must be .LE. 0, while -C IWORK(40+I) = -2 if Y(I) must be .LT. 0, while -C IWORK(40+I) = 0 if Y(I) is not constrained. -C -C INFO(11) - DDASPK normally requires the initial T, Y, and -C YPRIME to be consistent. That is, you must have -C G(T,Y,YPRIME) = 0 at the initial T. If you do not know -C the initial conditions precisely, in some cases -C DDASPK may be able to compute it. -C -C Denoting the differential variables in Y by Y_d -C and the algebraic variables by Y_a, DDASPK can solve -C one of two initialization problems: -C 1. Given Y_d, calculate Y_a and Y'_d, or -C 2. Given Y', calculate Y. -C In either case, initial values for the given -C components are input, and initial guesses for -C the unknown components must also be provided as input. -C -C **** Are the initial T, Y, YPRIME consistent ... -C -C yes - set INFO(11) = 0 -C no - set INFO(11) = 1 to calculate option 1 above, -C or set INFO(11) = 2 to calculate option 2 **** -C -C If you have specified INFO(11) = 1, then you -C will also need to identify which are the -C differential and which are the algebraic -C components (algebraic components are components -C whose derivatives do not appear explicitly -C in the function G(T,Y,YPRIME)). You must set: -C IWORK(LID+I) = +1 if Y(I) is a differential variable -C IWORK(LID+I) = -1 if Y(I) is an algebraic variable, -C where LID = 40 if INFO(10) = 0 or 2 and LID = 40+NEQ -C if INFO(10) = 1 or 3. -C -C INFO(12) - Except for the addition of the RES argument CJ, -C DDASPK by default is downward-compatible with DDASSL, -C which uses only direct (dense or band) methods to solve -C the linear systems involved. You must set INFO(12) to -C indicate whether you want the direct methods or the -C Krylov iterative method. -C **** Do you want DDASPK to use standard direct methods -C (dense or band) or the Krylov (iterative) method ... -C direct methods - set INFO(12) = 0. -C Krylov method - set INFO(12) = 1, -C and check the settings of INFO(13) and INFO(15). -C -C INFO(13) - used when INFO(12) = 1 (Krylov methods). -C DDASPK uses scalars MAXL, KMP, NRMAX, and EPLI for the -C iterative solution of linear systems. INFO(13) allows -C you to override the default values of these parameters. -C These parameters and their defaults are as follows: -C MAXL = maximum number of iterations in the SPIGMR -C algorithm (MAXL .le. NEQ). The default is -C MAXL = MIN(5,NEQ). -C KMP = number of vectors on which orthogonalization is -C done in the SPIGMR algorithm. The default is -C KMP = MAXL, which corresponds to complete GMRES -C iteration, as opposed to the incomplete form. -C NRMAX = maximum number of restarts of the SPIGMR -C algorithm per nonlinear iteration. The default is -C NRMAX = 5. -C EPLI = convergence test constant in SPIGMR algorithm. -C The default is EPLI = 0.05. -C Note that the length of RWORK depends on both MAXL -C and KMP. See the definition of LRW below. -C **** Are MAXL, KMP, and EPLI to be given their -C default values ... -C yes - set INFO(13) = 0 -C no - set INFO(13) = 1, -C and set all of the following: -C IWORK(24) = MAXL (1 .le. MAXL .le. NEQ) -C IWORK(25) = KMP (1 .le. KMP .le. MAXL) -C IWORK(26) = NRMAX (NRMAX .ge. 0) -C RWORK(10) = EPLI (0 .lt. EPLI .lt. 1.0) **** -C -C INFO(14) - used with INFO(11) > 0 (initial condition -C calculation is requested). In this case, you may -C request control to be returned to the calling program -C immediately after the initial condition calculation, -C before proceeding to the integration of the system -C (e.g. to examine the computed Y and YPRIME). -C If this is done, and if the initialization succeeded -C (IDID = 4), you should reset INFO(11) to 0 for the -C next call, to prevent the solver from repeating the -C initialization (and to avoid an infinite loop). -C **** Do you want to proceed to the integration after -C the initial condition calculation is done ... -C yes - set INFO(14) = 0 -C no - set INFO(14) = 1 **** -C -C INFO(15) - used when INFO(12) = 1 (Krylov methods). -C When using preconditioning in the Krylov method, -C you must supply a subroutine, PSOL, which solves the -C associated linear systems using P. -C The usage of DDASPK is simpler if PSOL can carry out -C the solution without any prior calculation of data. -C However, if some partial derivative data is to be -C calculated in advance and used repeatedly in PSOL, -C then you must supply a JAC routine to do this, -C and set INFO(15) to indicate that JAC is to be called -C for this purpose. For example, P might be an -C approximation to a part of the matrix A which can be -C calculated and LU-factored for repeated solutions of -C the preconditioner system. The arrays WP and IWP -C (described under JAC and PSOL) can be used to -C communicate data between JAC and PSOL. -C **** Does PSOL operate with no prior preparation ... -C yes - set INFO(15) = 0 (no JAC routine) -C no - set INFO(15) = 1 -C and supply a JAC routine to evaluate and -C preprocess any required Jacobian data. **** -C -C INFO(16) - option to exclude algebraic variables from -C the error test. -C **** Do you wish to control errors locally on -C all the variables... -C yes - set INFO(16) = 0 -C no - set INFO(16) = 1 -C If you have specified INFO(16) = 1, then you -C will also need to identify which are the -C differential and which are the algebraic -C components (algebraic components are components -C whose derivatives do not appear explicitly -C in the function G(T,Y,YPRIME)). You must set: -C IWORK(LID+I) = +1 if Y(I) is a differential -C variable, and -C IWORK(LID+I) = -1 if Y(I) is an algebraic -C variable, -C where LID = 40 if INFO(10) = 0 or 2 and -C LID = 40 + NEQ if INFO(10) = 1 or 3. -C -C INFO(17) - used when INFO(11) > 0 (DDASPK is to do an -C initial condition calculation). -C DDASPK uses several heuristic control quantities in the -C initial condition calculation. They have default values, -C but can also be set by the user using INFO(17). -C These parameters and their defaults are as follows: -C MXNIT = maximum number of Newton iterations -C per Jacobian or preconditioner evaluation. -C The default is: -C MXNIT = 5 in the direct case (INFO(12) = 0), and -C MXNIT = 15 in the Krylov case (INFO(12) = 1). -C MXNJ = maximum number of Jacobian or preconditioner -C evaluations. The default is: -C MXNJ = 6 in the direct case (INFO(12) = 0), and -C MXNJ = 2 in the Krylov case (INFO(12) = 1). -C MXNH = maximum number of values of the artificial -C stepsize parameter H to be tried if INFO(11) = 1. -C The default is MXNH = 5. -C NOTE: the maximum number of Newton iterations -C allowed in all is MXNIT*MXNJ*MXNH if INFO(11) = 1, -C and MXNIT*MXNJ if INFO(11) = 2. -C LSOFF = flag to turn off the linesearch algorithm -C (LSOFF = 0 means linesearch is on, LSOFF = 1 means -C it is turned off). The default is LSOFF = 0. -C STPTOL = minimum scaled step in linesearch algorithm. -C The default is STPTOL = (unit roundoff)**(2/3). -C EPINIT = swing factor in the Newton iteration convergence -C test. The test is applied to the residual vector, -C premultiplied by the approximate Jacobian (in the -C direct case) or the preconditioner (in the Krylov -C case). For convergence, the weighted RMS norm of -C this vector (scaled by the error weights) must be -C less than EPINIT*EPCON, where EPCON = .33 is the -C analogous test constant used in the time steps. -C The default is EPINIT = .01. -C **** Are the initial condition heuristic controls to be -C given their default values... -C yes - set INFO(17) = 0 -C no - set INFO(17) = 1, -C and set all of the following: -C IWORK(32) = MXNIT (.GT. 0) -C IWORK(33) = MXNJ (.GT. 0) -C IWORK(34) = MXNH (.GT. 0) -C IWORK(35) = LSOFF ( = 0 or 1) -C RWORK(14) = STPTOL (.GT. 0.0) -C RWORK(15) = EPINIT (.GT. 0.0) **** -C -C INFO(18) - option to get extra printing in initial condition -C calculation. -C **** Do you wish to have extra printing... -C no - set INFO(18) = 0 -C yes - set INFO(18) = 1 for minimal printing, or -C set INFO(18) = 2 for full printing. -C If you have specified INFO(18) .ge. 1, data -C will be printed with the error handler routines. -C To print to a non-default unit number L, include -C the line CALL XSETUN(L) in your program. **** -C -C RTOL, ATOL -- You must assign relative (RTOL) and absolute (ATOL) -C error tolerances to tell the code how accurately you -C want the solution to be computed. They must be defined -C as variables because the code may change them. -C you have two choices -- -C Both RTOL and ATOL are scalars (INFO(2) = 0), or -C both RTOL and ATOL are vectors (INFO(2) = 1). -C In either case all components must be non-negative. -C -C The tolerances are used by the code in a local error -C test at each step which requires roughly that -C abs(local error in Y(i)) .le. EWT(i) , -C where EWT(i) = RTOL*abs(Y(i)) + ATOL is an error weight -C quantity, for each vector component. -C (More specifically, a root-mean-square norm is used to -C measure the size of vectors, and the error test uses the -C magnitude of the solution at the beginning of the step.) -C -C The true (global) error is the difference between the -C true solution of the initial value problem and the -C computed approximation. Practically all present day -C codes, including this one, control the local error at -C each step and do not even attempt to control the global -C error directly. -C -C Usually, but not always, the true accuracy of -C the computed Y is comparable to the error tolerances. -C This code will usually, but not always, deliver a more -C accurate solution if you reduce the tolerances and -C integrate again. By comparing two such solutions you -C can get a fairly reliable idea of the true error in the -C solution at the larger tolerances. -C -C Setting ATOL = 0. results in a pure relative error test -C on that component. Setting RTOL = 0. results in a pure -C absolute error test on that component. A mixed test -C with non-zero RTOL and ATOL corresponds roughly to a -C relative error test when the solution component is -C much bigger than ATOL and to an absolute error test -C when the solution component is smaller than the -C threshold ATOL. -C -C The code will not attempt to compute a solution at an -C accuracy unreasonable for the machine being used. It -C will advise you if you ask for too much accuracy and -C inform you as to the maximum accuracy it believes -C possible. -C -C RWORK(*) -- a real work array, which should be dimensioned in your -C calling program with a length equal to the value of -C LRW (or greater). -C -C LRW -- Set it to the declared length of the RWORK array. The -C minimum length depends on the options you have selected, -C given by a base value plus additional storage as described -C below. -C -C If INFO(12) = 0 (standard direct method), the base value is -C base = 50 + max(MAXORD+4,7)*NEQ. -C The default value is MAXORD = 5 (see INFO(9)). With the -C default MAXORD, base = 50 + 9*NEQ. -C Additional storage must be added to the base value for -C any or all of the following options: -C if INFO(6) = 0 (dense matrix), add NEQ**2 -C if INFO(6) = 1 (banded matrix), then -C if INFO(5) = 0, add (2*ML+MU+1)*NEQ + 2*(NEQ/(ML+MU+1)+1), -C if INFO(5) = 1, add (2*ML+MU+1)*NEQ, -C if INFO(16) = 1, add NEQ. -C -C If INFO(12) = 1 (Krylov method), the base value is -C base = 50 + (MAXORD+5)*NEQ + (MAXL+3+MIN0(1,MAXL-KMP))*NEQ + -C + (MAXL+3)*MAXL + 1 + LENWP. -C See PSOL for description of LENWP. The default values are: -C MAXORD = 5 (see INFO(9)), MAXL = min(5,NEQ) and KMP = MAXL -C (see INFO(13)). -C With the default values for MAXORD, MAXL and KMP, -C base = 91 + 18*NEQ + LENWP. -C Additional storage must be added to the base value for -C any or all of the following options: -C if INFO(16) = 1, add NEQ. -C -C -C IWORK(*) -- an integer work array, which should be dimensioned in -C your calling program with a length equal to the value -C of LIW (or greater). -C -C LIW -- Set it to the declared length of the IWORK array. The -C minimum length depends on the options you have selected, -C given by a base value plus additional storage as described -C below. -C -C If INFO(12) = 0 (standard direct method), the base value is -C base = 40 + NEQ. -C IF INFO(10) = 1 or 3, add NEQ to the base value. -C If INFO(11) = 1 or INFO(16) =1, add NEQ to the base value. -C -C If INFO(12) = 1 (Krylov method), the base value is -C base = 40 + LENIWP. -C See PSOL for description of LENIWP. -C IF INFO(10) = 1 or 3, add NEQ to the base value. -C If INFO(11) = 1 or INFO(16) = 1, add NEQ to the base value. -C -C -C RPAR, IPAR -- These are arrays of double precision and integer type, -C respectively, which are available for you to use -C for communication between your program that calls -C DDASPK and the RES subroutine (and the JAC and PSOL -C subroutines). They are not altered by DDASPK. -C If you do not need RPAR or IPAR, ignore these -C parameters by treating them as dummy arguments. -C If you do choose to use them, dimension them in -C your calling program and in RES (and in JAC and PSOL) -C as arrays of appropriate length. -C -C JAC -- This is the name of a routine that you may supply -C (optionally) that relates to the Jacobian matrix of the -C nonlinear system that the code must solve at each T step. -C The role of JAC (and its call sequence) depends on whether -C a direct (INFO(12) = 0) or Krylov (INFO(12) = 1) method -C is selected. -C -C **** INFO(12) = 0 (direct methods): -C If you are letting the code generate partial derivatives -C numerically (INFO(5) = 0), then JAC can be absent -C (or perhaps a dummy routine to satisfy the loader). -C Otherwise you must supply a JAC routine to compute -C the matrix A = dG/dY + CJ*dG/dYPRIME. It must have -C the form -C -C SUBROUTINE JAC (T, Y, YPRIME, PD, CJ, RPAR, IPAR) -C -C The JAC routine must dimension Y, YPRIME, and PD (and RPAR -C and IPAR if used). CJ is a scalar which is input to JAC. -C For the given values of T, Y, and YPRIME, the JAC routine -C must evaluate the nonzero elements of the matrix A, and -C store these values in the array PD. The elements of PD are -C set to zero before each call to JAC, so that only nonzero -C elements need to be defined. -C The way you store the elements into the PD array depends -C on the structure of the matrix indicated by INFO(6). -C *** INFO(6) = 0 (full or dense matrix) *** -C Give PD a first dimension of NEQ. When you evaluate the -C nonzero partial derivatives of equation i (i.e. of G(i)) -C with respect to component j (of Y and YPRIME), you must -C store the element in PD according to -C PD(i,j) = dG(i)/dY(j) + CJ*dG(i)/dYPRIME(j). -C *** INFO(6) = 1 (banded matrix with half-bandwidths ML, MU -C as described under INFO(6)) *** -C Give PD a first dimension of 2*ML+MU+1. When you -C evaluate the nonzero partial derivatives of equation i -C (i.e. of G(i)) with respect to component j (of Y and -C YPRIME), you must store the element in PD according to -C IROW = i - j + ML + MU + 1 -C PD(IROW,j) = dG(i)/dY(j) + CJ*dG(i)/dYPRIME(j). -C -C **** INFO(12) = 1 (Krylov method): -C If you are not calculating Jacobian data in advance for use -C in PSOL (INFO(15) = 0), JAC can be absent (or perhaps a -C dummy routine to satisfy the loader). Otherwise, you may -C supply a JAC routine to compute and preprocess any parts of -C of the Jacobian matrix A = dG/dY + CJ*dG/dYPRIME that are -C involved in the preconditioner matrix P. -C It is to have the form -C -C SUBROUTINE JAC (RES, IRES, NEQ, T, Y, YPRIME, REWT, SAVR, -C WK, H, CJ, WP, IWP, IER, RPAR, IPAR) -C -C The JAC routine must dimension Y, YPRIME, REWT, SAVR, WK, -C and (if used) WP, IWP, RPAR, and IPAR. -C The Y, YPRIME, and SAVR arrays contain the current values -C of Y, YPRIME, and the residual G, respectively. -C The array WK is work space of length NEQ. -C H is the step size. CJ is a scalar, input to JAC, that is -C normally proportional to 1/H. REWT is an array of -C reciprocal error weights, 1/EWT(i), where EWT(i) is -C RTOL*abs(Y(i)) + ATOL (unless you supplied routine DDAWTS -C instead), for use in JAC if needed. For example, if JAC -C computes difference quotient approximations to partial -C derivatives, the REWT array may be useful in setting the -C increments used. The JAC routine should do any -C factorization operations called for, in preparation for -C solving linear systems in PSOL. The matrix P should -C be an approximation to the Jacobian, -C A = dG/dY + CJ*dG/dYPRIME. -C -C WP and IWP are real and integer work arrays which you may -C use for communication between your JAC routine and your -C PSOL routine. These may be used to store elements of the -C preconditioner P, or related matrix data (such as factored -C forms). They are not altered by DDASPK. -C If you do not need WP or IWP, ignore these parameters by -C treating them as dummy arguments. If you do use them, -C dimension them appropriately in your JAC and PSOL routines. -C See the PSOL description for instructions on setting -C the lengths of WP and IWP. -C -C On return, JAC should set the error flag IER as follows.. -C IER = 0 if JAC was successful, -C IER .ne. 0 if JAC was unsuccessful (e.g. if Y or YPRIME -C was illegal, or a singular matrix is found). -C (If IER .ne. 0, a smaller stepsize will be tried.) -C IER = 0 on entry to JAC, so need be reset only on a failure. -C If RES is used within JAC, then a nonzero value of IRES will -C override any nonzero value of IER (see the RES description). -C -C Regardless of the method type, subroutine JAC must not -C alter T, Y(*), YPRIME(*), H, CJ, or REWT(*). -C You must declare the name JAC in an EXTERNAL statement in -C your program that calls DDASPK. -C -C PSOL -- This is the name of a routine you must supply if you have -C selected a Krylov method (INFO(12) = 1) with preconditioning. -C In the direct case (INFO(12) = 0), PSOL can be absent -C (a dummy routine may have to be supplied to satisfy the -C loader). Otherwise, you must provide a PSOL routine to -C solve linear systems arising from preconditioning. -C When supplied with INFO(12) = 1, the PSOL routine is to -C have the form -C -C SUBROUTINE PSOL (NEQ, T, Y, YPRIME, SAVR, WK, CJ, WGHT, -C WP, IWP, B, EPLIN, IER, RPAR, IPAR) -C -C The PSOL routine must solve linear systems of the form -C P*x = b where P is the left preconditioner matrix. -C -C The right-hand side vector b is in the B array on input, and -C PSOL must return the solution vector x in B. -C The Y, YPRIME, and SAVR arrays contain the current values -C of Y, YPRIME, and the residual G, respectively. -C -C Work space required by JAC and/or PSOL, and space for data to -C be communicated from JAC to PSOL is made available in the form -C of arrays WP and IWP, which are parts of the RWORK and IWORK -C arrays, respectively. The lengths of these real and integer -C work spaces WP and IWP must be supplied in LENWP and LENIWP, -C respectively, as follows.. -C IWORK(27) = LENWP = length of real work space WP -C IWORK(28) = LENIWP = length of integer work space IWP. -C -C WK is a work array of length NEQ for use by PSOL. -C CJ is a scalar, input to PSOL, that is normally proportional -C to 1/H (H = stepsize). If the old value of CJ -C (at the time of the last JAC call) is needed, it must have -C been saved by JAC in WP. -C -C WGHT is an array of weights, to be used if PSOL uses an -C iterative method and performs a convergence test. (In terms -C of the argument REWT to JAC, WGHT is REWT/sqrt(NEQ).) -C If PSOL uses an iterative method, it should use EPLIN -C (a heuristic parameter) as the bound on the weighted norm of -C the residual for the computed solution. Specifically, the -C residual vector R should satisfy -C SQRT (SUM ( (R(i)*WGHT(i))**2 ) ) .le. EPLIN -C -C PSOL must not alter NEQ, T, Y, YPRIME, SAVR, CJ, WGHT, EPLIN. -C -C On return, PSOL should set the error flag IER as follows.. -C IER = 0 if PSOL was successful, -C IER .lt. 0 if an unrecoverable error occurred, meaning -C control will be passed to the calling routine, -C IER .gt. 0 if a recoverable error occurred, meaning that -C the step will be retried with the same step size -C but with a call to JAC to update necessary data, -C unless the Jacobian data is current, in which case -C the step will be retried with a smaller step size. -C IER = 0 on entry to PSOL so need be reset only on a failure. -C -C You must declare the name PSOL in an EXTERNAL statement in -C your program that calls DDASPK. -C -C -C OPTIONALLY REPLACEABLE SUBROUTINE: -C -C DDASPK uses a weighted root-mean-square norm to measure the -C size of various error vectors. The weights used in this norm -C are set in the following subroutine: -C -C SUBROUTINE DDAWTS (NEQ, IWT, RTOL, ATOL, Y, EWT, RPAR, IPAR) -C DIMENSION RTOL(*), ATOL(*), Y(*), EWT(*), RPAR(*), IPAR(*) -C -C A DDAWTS routine has been included with DDASPK which sets the -C weights according to -C EWT(I) = RTOL*ABS(Y(I)) + ATOL -C in the case of scalar tolerances (IWT = 0) or -C EWT(I) = RTOL(I)*ABS(Y(I)) + ATOL(I) -C in the case of array tolerances (IWT = 1). (IWT is INFO(2).) -C In some special cases, it may be appropriate for you to define -C your own error weights by writing a subroutine DDAWTS to be -C called instead of the version supplied. However, this should -C be attempted only after careful thought and consideration. -C If you supply this routine, you may use the tolerances and Y -C as appropriate, but do not overwrite these variables. You -C may also use RPAR and IPAR to communicate data as appropriate. -C ***Note: Aside from the values of the weights, the choice of -C norm used in DDASPK (weighted root-mean-square) is not subject -C to replacement by the user. In this respect, DDASPK is not -C downward-compatible with the original DDASSL solver (in which -C the norm routine was optionally user-replaceable). -C -C -C------OUTPUT - AFTER ANY RETURN FROM DDASPK---------------------------- -C -C The principal aim of the code is to return a computed solution at -C T = TOUT, although it is also possible to obtain intermediate -C results along the way. To find out whether the code achieved its -C goal or if the integration process was interrupted before the task -C was completed, you must check the IDID parameter. -C -C -C T -- The output value of T is the point to which the solution -C was successfully advanced. -C -C Y(*) -- contains the computed solution approximation at T. -C -C YPRIME(*) -- contains the computed derivative approximation at T. -C -C IDID -- reports what the code did, described as follows: -C -C *** TASK COMPLETED *** -C Reported by positive values of IDID -C -C IDID = 1 -- a step was successfully taken in the -C intermediate-output mode. The code has not -C yet reached TOUT. -C -C IDID = 2 -- the integration to TSTOP was successfully -C completed (T = TSTOP) by stepping exactly to TSTOP. -C -C IDID = 3 -- the integration to TOUT was successfully -C completed (T = TOUT) by stepping past TOUT. -C Y(*) and YPRIME(*) are obtained by interpolation. -C -C IDID = 4 -- the initial condition calculation, with -C INFO(11) > 0, was successful, and INFO(14) = 1. -C No integration steps were taken, and the solution -C is not considered to have been started. -C -C *** TASK INTERRUPTED *** -C Reported by negative values of IDID -C -C IDID = -1 -- a large amount of work has been expended -C (about 500 steps). -C -C IDID = -2 -- the error tolerances are too stringent. -C -C IDID = -3 -- the local error test cannot be satisfied -C because you specified a zero component in ATOL -C and the corresponding computed solution component -C is zero. Thus, a pure relative error test is -C impossible for this component. -C -C IDID = -5 -- there were repeated failures in the evaluation -C or processing of the preconditioner (in JAC). -C -C IDID = -6 -- DDASPK had repeated error test failures on the -C last attempted step. -C -C IDID = -7 -- the nonlinear system solver in the time integration -C could not converge. -C -C IDID = -8 -- the matrix of partial derivatives appears -C to be singular (direct method). -C -C IDID = -9 -- the nonlinear system solver in the time integration -C failed to achieve convergence, and there were repeated -C error test failures in this step. -C -C IDID =-10 -- the nonlinear system solver in the time integration -C failed to achieve convergence because IRES was equal -C to -1. -C -C IDID =-11 -- IRES = -2 was encountered and control is -C being returned to the calling program. -C -C IDID =-12 -- DDASPK failed to compute the initial Y, YPRIME. -C -C IDID =-13 -- unrecoverable error encountered inside user's -C PSOL routine, and control is being returned to -C the calling program. -C -C IDID =-14 -- the Krylov linear system solver could not -C achieve convergence. -C -C IDID =-15,..,-32 -- Not applicable for this code. -C -C *** TASK TERMINATED *** -C reported by the value of IDID=-33 -C -C IDID = -33 -- the code has encountered trouble from which -C it cannot recover. A message is printed -C explaining the trouble and control is returned -C to the calling program. For example, this occurs -C when invalid input is detected. -C -C RTOL, ATOL -- these quantities remain unchanged except when -C IDID = -2. In this case, the error tolerances have been -C increased by the code to values which are estimated to -C be appropriate for continuing the integration. However, -C the reported solution at T was obtained using the input -C values of RTOL and ATOL. -C -C RWORK, IWORK -- contain information which is usually of no interest -C to the user but necessary for subsequent calls. -C However, you may be interested in the performance data -C listed below. These quantities are accessed in RWORK -C and IWORK but have internal mnemonic names, as follows.. -C -C RWORK(3)--contains H, the step size h to be attempted -C on the next step. -C -C RWORK(4)--contains TN, the current value of the -C independent variable, i.e. the farthest point -C integration has reached. This will differ -C from T if interpolation has been performed -C (IDID = 3). -C -C RWORK(7)--contains HOLD, the stepsize used on the last -C successful step. If INFO(11) = INFO(14) = 1, -C this contains the value of H used in the -C initial condition calculation. -C -C IWORK(7)--contains K, the order of the method to be -C attempted on the next step. -C -C IWORK(8)--contains KOLD, the order of the method used -C on the last step. -C -C IWORK(11)--contains NST, the number of steps (in T) -C taken so far. -C -C IWORK(12)--contains NRE, the number of calls to RES -C so far. -C -C IWORK(13)--contains NJE, the number of calls to JAC so -C far (Jacobian or preconditioner evaluations). -C -C IWORK(14)--contains NETF, the total number of error test -C failures so far. -C -C IWORK(15)--contains NCFN, the total number of nonlinear -C convergence failures so far (includes counts -C of singular iteration matrix or singular -C preconditioners). -C -C IWORK(16)--contains NCFL, the number of convergence -C failures of the linear iteration so far. -C -C IWORK(17)--contains LENIW, the length of IWORK actually -C required. This is defined on normal returns -C and on an illegal input return for -C insufficient storage. -C -C IWORK(18)--contains LENRW, the length of RWORK actually -C required. This is defined on normal returns -C and on an illegal input return for -C insufficient storage. -C -C IWORK(19)--contains NNI, the total number of nonlinear -C iterations so far (each of which calls a -C linear solver). -C -C IWORK(20)--contains NLI, the total number of linear -C (Krylov) iterations so far. -C -C IWORK(21)--contains NPS, the number of PSOL calls so -C far, for preconditioning solve operations or -C for solutions with the user-supplied method. -C -C Note: The various counters in IWORK do not include -C counts during a call made with INFO(11) > 0 and -C INFO(14) = 1. -C -C -C------INPUT - WHAT TO DO TO CONTINUE THE INTEGRATION ----------------- -C (CALLS AFTER THE FIRST) -C -C This code is organized so that subsequent calls to continue the -C integration involve little (if any) additional effort on your -C part. You must monitor the IDID parameter in order to determine -C what to do next. -C -C Recalling that the principal task of the code is to integrate -C from T to TOUT (the interval mode), usually all you will need -C to do is specify a new TOUT upon reaching the current TOUT. -C -C Do not alter any quantity not specifically permitted below. In -C particular do not alter NEQ, T, Y(*), YPRIME(*), RWORK(*), -C IWORK(*), or the differential equation in subroutine RES. Any -C such alteration constitutes a new problem and must be treated -C as such, i.e. you must start afresh. -C -C You cannot change from array to scalar error control or vice -C versa (INFO(2)), but you can change the size of the entries of -C RTOL or ATOL. Increasing a tolerance makes the equation easier -C to integrate. Decreasing a tolerance will make the equation -C harder to integrate and should generally be avoided. -C -C You can switch from the intermediate-output mode to the -C interval mode (INFO(3)) or vice versa at any time. -C -C If it has been necessary to prevent the integration from going -C past a point TSTOP (INFO(4), RWORK(1)), keep in mind that the -C code will not integrate to any TOUT beyond the currently -C specified TSTOP. Once TSTOP has been reached, you must change -C the value of TSTOP or set INFO(4) = 0. You may change INFO(4) -C or TSTOP at any time but you must supply the value of TSTOP in -C RWORK(1) whenever you set INFO(4) = 1. -C -C Do not change INFO(5), INFO(6), INFO(12-17) or their associated -C IWORK/RWORK locations unless you are going to restart the code. -C -C *** FOLLOWING A COMPLETED TASK *** -C -C If.. -C IDID = 1, call the code again to continue the integration -C another step in the direction of TOUT. -C -C IDID = 2 or 3, define a new TOUT and call the code again. -C TOUT must be different from T. You cannot change -C the direction of integration without restarting. -C -C IDID = 4, reset INFO(11) = 0 and call the code again to begin -C the integration. (If you leave INFO(11) > 0 and -C INFO(14) = 1, you may generate an infinite loop.) -C In this situation, the next call to DASPK is -C considered to be the first call for the problem, -C in that all initializations are done. -C -C *** FOLLOWING AN INTERRUPTED TASK *** -C -C To show the code that you realize the task was interrupted and -C that you want to continue, you must take appropriate action and -C set INFO(1) = 1. -C -C If.. -C IDID = -1, the code has taken about 500 steps. If you want to -C continue, set INFO(1) = 1 and call the code again. -C An additional 500 steps will be allowed. -C -C -C IDID = -2, the error tolerances RTOL, ATOL have been increased -C to values the code estimates appropriate for -C continuing. You may want to change them yourself. -C If you are sure you want to continue with relaxed -C error tolerances, set INFO(1) = 1 and call the code -C again. -C -C IDID = -3, a solution component is zero and you set the -C corresponding component of ATOL to zero. If you -C are sure you want to continue, you must first alter -C the error criterion to use positive values of ATOL -C for those components corresponding to zero solution -C components, then set INFO(1) = 1 and call the code -C again. -C -C IDID = -4 --- cannot occur with this code. -C -C IDID = -5, your JAC routine failed with the Krylov method. Check -C for errors in JAC and restart the integration. -C -C IDID = -6, repeated error test failures occurred on the last -C attempted step in DDASPK. A singularity in the -C solution may be present. If you are absolutely -C certain you want to continue, you should restart -C the integration. (Provide initial values of Y and -C YPRIME which are consistent.) -C -C IDID = -7, repeated convergence test failures occurred on the last -C attempted step in DDASPK. An inaccurate or ill- -C conditioned Jacobian or preconditioner may be the -C problem. If you are absolutely certain you want -C to continue, you should restart the integration. -C -C -C IDID = -8, the matrix of partial derivatives is singular, with -C the use of direct methods. Some of your equations -C may be redundant. DDASPK cannot solve the problem -C as stated. It is possible that the redundant -C equations could be removed, and then DDASPK could -C solve the problem. It is also possible that a -C solution to your problem either does not exist -C or is not unique. -C -C IDID = -9, DDASPK had multiple convergence test failures, preceded -C by multiple error test failures, on the last -C attempted step. It is possible that your problem is -C ill-posed and cannot be solved using this code. Or, -C there may be a discontinuity or a singularity in the -C solution. If you are absolutely certain you want to -C continue, you should restart the integration. -C -C IDID = -10, DDASPK had multiple convergence test failures -C because IRES was equal to -1. If you are -C absolutely certain you want to continue, you -C should restart the integration. -C -C IDID = -11, there was an unrecoverable error (IRES = -2) from RES -C inside the nonlinear system solver. Determine the -C cause before trying again. -C -C IDID = -12, DDASPK failed to compute the initial Y and YPRIME -C vectors. This could happen because the initial -C approximation to Y or YPRIME was not very good, or -C because no consistent values of these vectors exist. -C The problem could also be caused by an inaccurate or -C singular iteration matrix, or a poor preconditioner. -C -C IDID = -13, there was an unrecoverable error encountered inside -C your PSOL routine. Determine the cause before -C trying again. -C -C IDID = -14, the Krylov linear system solver failed to achieve -C convergence. This may be due to ill-conditioning -C in the iteration matrix, or a singularity in the -C preconditioner (if one is being used). -C Another possibility is that there is a better -C choice of Krylov parameters (see INFO(13)). -C Possibly the failure is caused by redundant equations -C in the system, or by inconsistent equations. -C In that case, reformulate the system to make it -C consistent and non-redundant. -C -C IDID = -15,..,-32 --- Cannot occur with this code. -C -C *** FOLLOWING A TERMINATED TASK *** -C -C If IDID = -33, you cannot continue the solution of this problem. -C An attempt to do so will result in your run being -C terminated. -C -C --------------------------------------------------------------------- -C -C***REFERENCES -C 1. L. R. Petzold, A Description of DASSL: A Differential/Algebraic -C System Solver, in Scientific Computing, R. S. Stepleman et al. -C (Eds.), North-Holland, Amsterdam, 1983, pp. 65-68. -C 2. K. E. Brenan, S. L. Campbell, and L. R. Petzold, Numerical -C Solution of Initial-Value Problems in Differential-Algebraic -C Equations, Elsevier, New York, 1989. -C 3. P. N. Brown and A. C. Hindmarsh, Reduced Storage Matrix Methods -C in Stiff ODE Systems, J. Applied Mathematics and Computation, -C 31 (1989), pp. 40-91. -C 4. P. N. Brown, A. C. Hindmarsh, and L. R. Petzold, Using Krylov -C Methods in the Solution of Large-Scale Differential-Algebraic -C Systems, SIAM J. Sci. Comp., 15 (1994), pp. 1467-1488. -C 5. P. N. Brown, A. C. Hindmarsh, and L. R. Petzold, Consistent -C Initial Condition Calculation for Differential-Algebraic -C Systems, LLNL Report UCRL-JC-122175, August 1995; submitted to -C SIAM J. Sci. Comp. -C -C***ROUTINES CALLED -C -C The following are all the subordinate routines used by DDASPK. -C -C DDASIC computes consistent initial conditions. -C DYYPNW updates Y and YPRIME in linesearch for initial condition -C calculation. -C DDSTP carries out one step of the integration. -C DCNSTR/DCNST0 check the current solution for constraint violations. -C DDAWTS sets error weight quantities. -C DINVWT tests and inverts the error weights. -C DDATRP performs interpolation to get an output solution. -C DDWNRM computes the weighted root-mean-square norm of a vector. -C D1MACH provides the unit roundoff of the computer. -C XERRWD/XSETF/XSETUN/IXSAV is a package to handle error messages. -C DDASID nonlinear equation driver to initialize Y and YPRIME using -C direct linear system solver methods. Interfaces to Newton -C solver (direct case). -C DNSID solves the nonlinear system for unknown initial values by -C modified Newton iteration and direct linear system methods. -C DLINSD carries out linesearch algorithm for initial condition -C calculation (direct case). -C DFNRMD calculates weighted norm of preconditioned residual in -C initial condition calculation (direct case). -C DNEDD nonlinear equation driver for direct linear system solver -C methods. Interfaces to Newton solver (direct case). -C DMATD assembles the iteration matrix (direct case). -C DNSD solves the associated nonlinear system by modified -C Newton iteration and direct linear system methods. -C DSLVD interfaces to linear system solver (direct case). -C DDASIK nonlinear equation driver to initialize Y and YPRIME using -C Krylov iterative linear system methods. Interfaces to -C Newton solver (Krylov case). -C DNSIK solves the nonlinear system for unknown initial values by -C Newton iteration and Krylov iterative linear system methods. -C DLINSK carries out linesearch algorithm for initial condition -C calculation (Krylov case). -C DFNRMK calculates weighted norm of preconditioned residual in -C initial condition calculation (Krylov case). -C DNEDK nonlinear equation driver for iterative linear system solver -C methods. Interfaces to Newton solver (Krylov case). -C DNSK solves the associated nonlinear system by Inexact Newton -C iteration and (linear) Krylov iteration. -C DSLVK interfaces to linear system solver (Krylov case). -C DSPIGM solves a linear system by SPIGMR algorithm. -C DATV computes matrix-vector product in Krylov algorithm. -C DORTH performs orthogonalization of Krylov basis vectors. -C DHEQR performs QR factorization of Hessenberg matrix. -C DHELS finds least-squares solution of Hessenberg linear system. -C DGETRF, DGETRS, DGBTRF, DGBTRS are LAPACK routines for solving -C linear systems (dense or band direct methods). -C DAXPY, DCOPY, DDOT, DNRM2, DSCAL are Basic Linear Algebra (BLAS) -C routines. -C -C The routines called directly by DDASPK are: -C DCNST0, DDAWTS, DINVWT, D1MACH, DDWNRM, DDASIC, DDATRP, DDSTP, -C XERRWD -C -C***END PROLOGUE DDASPK -C -C - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - LOGICAL DONE, LAVL, LCFN, LCFL, LWARN - DIMENSION Y(*),YPRIME(*) - DIMENSION INFO(20) - DIMENSION RWORK(LRW),IWORK(LIW) - DIMENSION RTOL(*),ATOL(*) - DIMENSION RPAR(*),IPAR(*) - CHARACTER MSG*80 - EXTERNAL RES, JAC, PSOL, DDASID, DDASIK, DNEDD, DNEDK -C -C Set pointers into IWORK. -C - PARAMETER (LML=1, LMU=2, LMTYPE=4, - * LIWM=1, LMXORD=3, LJCALC=5, LPHASE=6, LK=7, LKOLD=8, - * LNS=9, LNSTL=10, LNST=11, LNRE=12, LNJE=13, LETF=14, LNCFN=15, - * LNCFL=16, LNIW=17, LNRW=18, LNNI=19, LNLI=20, LNPS=21, - * LNPD=22, LMITER=23, LMAXL=24, LKMP=25, LNRMAX=26, LLNWP=27, - * LLNIWP=28, LLOCWP=29, LLCIWP=30, LKPRIN=31, - * LMXNIT=32, LMXNJ=33, LMXNH=34, LLSOFF=35, LICNS=41) -C -C Set pointers into RWORK. -C - PARAMETER (LTSTOP=1, LHMAX=2, LH=3, LTN=4, LCJ=5, LCJOLD=6, - * LHOLD=7, LS=8, LROUND=9, LEPLI=10, LSQRN=11, LRSQRN=12, - * LEPCON=13, LSTOL=14, LEPIN=15, - * LALPHA=21, LBETA=27, LGAMMA=33, LPSI=39, LSIGMA=45, LDELTA=51) -C - SAVE LID, LENID, NONNEG -C -C -C***FIRST EXECUTABLE STATEMENT DDASPK -C -C - IF(INFO(1).NE.0) GO TO 100 -C -C----------------------------------------------------------------------- -C This block is executed for the initial call only. -C It contains checking of inputs and initializations. -C----------------------------------------------------------------------- -C -C First check INFO array to make sure all elements of INFO -C Are within the proper range. (INFO(1) is checked later, because -C it must be tested on every call.) ITEMP holds the location -C within INFO which may be out of range. -C - DO 10 I=2,9 - ITEMP = I - IF (INFO(I) .NE. 0 .AND. INFO(I) .NE. 1) GO TO 701 - 10 CONTINUE - ITEMP = 10 - IF(INFO(10).LT.0 .OR. INFO(10).GT.3) GO TO 701 - ITEMP = 11 - IF(INFO(11).LT.0 .OR. INFO(11).GT.2) GO TO 701 - DO 15 I=12,17 - ITEMP = I - IF (INFO(I) .NE. 0 .AND. INFO(I) .NE. 1) GO TO 701 - 15 CONTINUE - ITEMP = 18 - IF(INFO(18).LT.0 .OR. INFO(18).GT.2) GO TO 701 - -C -C Check NEQ to see if it is positive. -C - IF (NEQ .LE. 0) GO TO 702 -C -C Check and compute maximum order. -C - MXORD=5 - IF (INFO(9) .NE. 0) THEN - MXORD=IWORK(LMXORD) - IF (MXORD .LT. 1 .OR. MXORD .GT. 5) GO TO 703 - ENDIF - IWORK(LMXORD)=MXORD -C -C Set and/or check inputs for constraint checking (INFO(10) .NE. 0). -C Set values for ICNFLG, NONNEG, and pointer LID. -C - ICNFLG = 0 - NONNEG = 0 - LID = LICNS - IF (INFO(10) .EQ. 0) GO TO 20 - IF (INFO(10) .EQ. 1) THEN - ICNFLG = 1 - NONNEG = 0 - LID = LICNS + NEQ - ELSEIF (INFO(10) .EQ. 2) THEN - ICNFLG = 0 - NONNEG = 1 - ELSE - ICNFLG = 1 - NONNEG = 1 - LID = LICNS + NEQ - ENDIF -C - 20 CONTINUE -C -C Set and/or check inputs for Krylov solver (INFO(12) .NE. 0). -C If indicated, set default values for MAXL, KMP, NRMAX, and EPLI. -C Otherwise, verify inputs required for iterative solver. -C - IF (INFO(12) .EQ. 0) GO TO 25 -C - IWORK(LMITER) = INFO(12) - IF (INFO(13) .EQ. 0) THEN - IWORK(LMAXL) = MIN(5,NEQ) - IWORK(LKMP) = IWORK(LMAXL) - IWORK(LNRMAX) = 5 - RWORK(LEPLI) = 0.05D0 - ELSE - IF(IWORK(LMAXL) .LT. 1 .OR. IWORK(LMAXL) .GT. NEQ) GO TO 720 - IF(IWORK(LKMP) .LT. 1 .OR. IWORK(LKMP) .GT. IWORK(LMAXL)) - 1 GO TO 721 - IF(IWORK(LNRMAX) .LT. 0) GO TO 722 - IF(RWORK(LEPLI).LE.0.0D0 .OR. RWORK(LEPLI).GE.1.0D0)GO TO 723 - ENDIF -C - 25 CONTINUE -C -C Set and/or check controls for the initial condition calculation -C (INFO(11) .GT. 0). If indicated, set default values. -C Otherwise, verify inputs required for iterative solver. -C - IF (INFO(11) .EQ. 0) GO TO 30 - IF (INFO(17) .EQ. 0) THEN - IWORK(LMXNIT) = 5 - IF (INFO(12) .GT. 0) IWORK(LMXNIT) = 15 - IWORK(LMXNJ) = 6 - IF (INFO(12) .GT. 0) IWORK(LMXNJ) = 2 - IWORK(LMXNH) = 5 - IWORK(LLSOFF) = 0 - RWORK(LEPIN) = 0.01D0 - ELSE - IF (IWORK(LMXNIT) .LE. 0) GO TO 725 - IF (IWORK(LMXNJ) .LE. 0) GO TO 725 - IF (IWORK(LMXNH) .LE. 0) GO TO 725 - LSOFF = IWORK(LLSOFF) - IF (LSOFF .LT. 0 .OR. LSOFF .GT. 1) GO TO 725 - IF (RWORK(LEPIN) .LE. 0.0D0) GO TO 725 - ENDIF -C - 30 CONTINUE -C -C Below is the computation and checking of the work array lengths -C LENIW and LENRW, using direct methods (INFO(12) = 0) or -C the Krylov methods (INFO(12) = 1). -C - LENIC = 0 - IF (INFO(10) .EQ. 1 .OR. INFO(10) .EQ. 3) LENIC = NEQ - LENID = 0 - IF (INFO(11) .EQ. 1 .OR. INFO(16) .EQ. 1) LENID = NEQ - IF (INFO(12) .EQ. 0) THEN -C -C Compute MTYPE, etc. Check ML and MU. -C - NCPHI = MAX(MXORD + 1, 4) - IF(INFO(6).EQ.0) THEN - LENPD = NEQ**2 - LENRW = 50 + (NCPHI+3)*NEQ + LENPD - IF(INFO(5).EQ.0) THEN - IWORK(LMTYPE)=2 - ELSE - IWORK(LMTYPE)=1 - ENDIF - ELSE - IF(IWORK(LML).LT.0.OR.IWORK(LML).GE.NEQ)GO TO 717 - IF(IWORK(LMU).LT.0.OR.IWORK(LMU).GE.NEQ)GO TO 718 - LENPD=(2*IWORK(LML)+IWORK(LMU)+1)*NEQ - IF(INFO(5).EQ.0) THEN - IWORK(LMTYPE)=5 - MBAND=IWORK(LML)+IWORK(LMU)+1 - MSAVE=(NEQ/MBAND)+1 - LENRW = 50 + (NCPHI+3)*NEQ + LENPD + 2*MSAVE - ELSE - IWORK(LMTYPE)=4 - LENRW = 50 + (NCPHI+3)*NEQ + LENPD - ENDIF - ENDIF -C -C Compute LENIW, LENWP, LENIWP. -C - LENIW = 40 + LENIC + LENID + NEQ - LENWP = 0 - LENIWP = 0 -C - ELSE IF (INFO(12) .EQ. 1) THEN - MAXL = IWORK(LMAXL) - LENWP = IWORK(LLNWP) - LENIWP = IWORK(LLNIWP) - LENPD = (MAXL+3+MIN0(1,MAXL-IWORK(LKMP)))*NEQ - 1 + (MAXL+3)*MAXL + 1 + LENWP - LENRW = 50 + (IWORK(LMXORD)+5)*NEQ + LENPD - LENIW = 40 + LENIC + LENID + LENIWP -C - ENDIF - IF(INFO(16) .NE. 0) LENRW = LENRW + NEQ -C -C Check lengths of RWORK and IWORK. -C - IWORK(LNIW)=LENIW - IWORK(LNRW)=LENRW - IWORK(LNPD)=LENPD - IWORK(LLOCWP) = LENPD-LENWP+1 - IF(LRW.LT.LENRW)GO TO 704 - IF(LIW.LT.LENIW)GO TO 705 -C -C Check ICNSTR for legality. -C - IF (LENIC .GT. 0) THEN - DO 40 I = 1,NEQ - ICI = IWORK(LICNS-1+I) - IF (ICI .LT. -2 .OR. ICI .GT. 2) GO TO 726 - 40 CONTINUE - ENDIF -C -C Check Y for consistency with constraints. -C - IF (LENIC .GT. 0) THEN - CALL DCNST0(NEQ,Y,IWORK(LICNS),IRET) - IF (IRET .NE. 0) GO TO 727 - ENDIF -C -C Check ID for legality. -C - IF (LENID .GT. 0) THEN - DO 50 I = 1,NEQ - IDI = IWORK(LID-1+I) - IF (IDI .NE. 1 .AND. IDI .NE. -1) GO TO 724 - 50 CONTINUE - ENDIF -C -C Check to see that TOUT is different from T. -C - IF(TOUT .EQ. T)GO TO 719 -C -C Check HMAX. -C - IF(INFO(7) .NE. 0) THEN - HMAX = RWORK(LHMAX) - IF (HMAX .LE. 0.0D0) GO TO 710 - ENDIF -C -C Initialize counters and other flags. -C - IWORK(LNST)=0 - IWORK(LNRE)=0 - IWORK(LNJE)=0 - IWORK(LETF)=0 - IWORK(LNCFN)=0 - IWORK(LNNI)=0 - IWORK(LNLI)=0 - IWORK(LNPS)=0 - IWORK(LNCFL)=0 - IWORK(LKPRIN)=INFO(18) - IDID=1 - GO TO 200 -C -C----------------------------------------------------------------------- -C This block is for continuation calls only. -C Here we check INFO(1), and if the last step was interrupted, -C we check whether appropriate action was taken. -C----------------------------------------------------------------------- -C -100 CONTINUE - IF(INFO(1).EQ.1)GO TO 110 - ITEMP = 1 - IF(INFO(1).NE.-1)GO TO 701 -C -C If we are here, the last step was interrupted by an error -C condition from DDSTP, and appropriate action was not taken. -C This is a fatal error. -C - MSG = 'DASPK-- THE LAST STEP TERMINATED WITH A NEGATIVE' - CALL XERRWD(MSG,49,201,0,0,0,0,0,0.0D0,0.0D0) - MSG = 'DASPK-- VALUE (=I1) OF IDID AND NO APPROPRIATE' - CALL XERRWD(MSG,47,202,0,1,IDID,0,0,0.0D0,0.0D0) - MSG = 'DASPK-- ACTION WAS TAKEN. RUN TERMINATED' - CALL XERRWD(MSG,41,203,1,0,0,0,0,0.0D0,0.0D0) - RETURN -110 CONTINUE -C -C----------------------------------------------------------------------- -C This block is executed on all calls. -C -C Counters are saved for later checks of performance. -C Then the error tolerance parameters are checked, and the -C work array pointers are set. -C----------------------------------------------------------------------- -C -200 CONTINUE -C -C Save counters for use later. -C - IWORK(LNSTL)=IWORK(LNST) - NLI0 = IWORK(LNLI) - NNI0 = IWORK(LNNI) - NCFN0 = IWORK(LNCFN) - NCFL0 = IWORK(LNCFL) - NWARN = 0 -C -C Check RTOL and ATOL. -C - NZFLG = 0 - RTOLI = RTOL(1) - ATOLI = ATOL(1) - DO 210 I=1,NEQ - IF (INFO(2) .EQ. 1) RTOLI = RTOL(I) - IF (INFO(2) .EQ. 1) ATOLI = ATOL(I) - IF (RTOLI .GT. 0.0D0 .OR. ATOLI .GT. 0.0D0) NZFLG = 1 - IF (RTOLI .LT. 0.0D0) GO TO 706 - IF (ATOLI .LT. 0.0D0) GO TO 707 -210 CONTINUE - IF (NZFLG .EQ. 0) GO TO 708 -C -C Set pointers to RWORK and IWORK segments. -C For direct methods, SAVR is not used. -C - IWORK(LLCIWP) = LID + LENID - LSAVR = LDELTA - IF (INFO(12) .NE. 0) LSAVR = LDELTA + NEQ - LE = LSAVR + NEQ - LWT = LE + NEQ - LVT = LWT - IF (INFO(16) .NE. 0) LVT = LWT + NEQ - LPHI = LVT + NEQ - LWM = LPHI + (IWORK(LMXORD)+1)*NEQ - IF (INFO(1) .EQ. 1) GO TO 400 -C -C----------------------------------------------------------------------- -C This block is executed on the initial call only. -C Set the initial step size, the error weight vector, and PHI. -C Compute unknown initial components of Y and YPRIME, if requested. -C----------------------------------------------------------------------- -C -300 CONTINUE - TN=T - IDID=1 -C -C Set error weight array WT and altered weight array VT. -C - CALL DDAWTS(NEQ,INFO(2),RTOL,ATOL,Y,RWORK(LWT),RPAR,IPAR) - CALL DINVWT(NEQ,RWORK(LWT),IER) - IF (IER .NE. 0) GO TO 713 - IF (INFO(16) .NE. 0) THEN - DO 305 I = 1, NEQ - 305 RWORK(LVT+I-1) = MAX(IWORK(LID+I-1),0)*RWORK(LWT+I-1) - ENDIF -C -C Compute unit roundoff and HMIN. -C - UROUND = D1MACH(4) - RWORK(LROUND) = UROUND - HMIN = 4.0D0*UROUND*MAX(ABS(T),ABS(TOUT)) -C -C Set/check STPTOL control for initial condition calculation. -C - IF (INFO(11) .NE. 0) THEN - IF( INFO(17) .EQ. 0) THEN - RWORK(LSTOL) = UROUND**.6667D0 - ELSE - IF (RWORK(LSTOL) .LE. 0.0D0) GO TO 725 - ENDIF - ENDIF -C -C Compute EPCON and square root of NEQ and its reciprocal, used -C inside iterative solver. -C - RWORK(LEPCON) = 0.33D0 - FLOATN = NEQ - RWORK(LSQRN) = SQRT(FLOATN) - RWORK(LRSQRN) = 1.D0/RWORK(LSQRN) -C -C Check initial interval to see that it is long enough. -C - TDIST = ABS(TOUT - T) - IF(TDIST .LT. HMIN) GO TO 714 -C -C Check H0, if this was input. -C - IF (INFO(8) .EQ. 0) GO TO 310 - H0 = RWORK(LH) - IF ((TOUT - T)*H0 .LT. 0.0D0) GO TO 711 - IF (H0 .EQ. 0.0D0) GO TO 712 - GO TO 320 -310 CONTINUE -C -C Compute initial stepsize, to be used by either -C DDSTP or DDASIC, depending on INFO(11). -C - H0 = 0.001D0*TDIST - YPNORM = DDWNRM(NEQ,YPRIME,RWORK(LVT),RPAR,IPAR) - IF (YPNORM .GT. 0.5D0/H0) H0 = 0.5D0/YPNORM - H0 = SIGN(H0,TOUT-T) -C -C Adjust H0 if necessary to meet HMAX bound. -C -320 IF (INFO(7) .EQ. 0) GO TO 330 - RH = ABS(H0)/RWORK(LHMAX) - IF (RH .GT. 1.0D0) H0 = H0/RH -C -C Check against TSTOP, if applicable. -C -330 IF (INFO(4) .EQ. 0) GO TO 340 - TSTOP = RWORK(LTSTOP) - IF ((TSTOP - T)*H0 .LT. 0.0D0) GO TO 715 - IF ((T + H0 - TSTOP)*H0 .GT. 0.0D0) H0 = TSTOP - T - IF ((TSTOP - TOUT)*H0 .LT. 0.0D0) GO TO 709 -C -340 IF (INFO(11) .EQ. 0) GO TO 370 -C -C Compute unknown components of initial Y and YPRIME, depending -C on INFO(11) and INFO(12). INFO(12) represents the nonlinear -C solver type (direct/Krylov). Pass the name of the specific -C nonlinear solver, depending on INFO(12). The location of the work -C arrays SAVR, YIC, YPIC, PWK also differ in the two cases. -C - NWT = 1 - EPCONI = RWORK(LEPIN)*RWORK(LEPCON) -350 IF (INFO(12) .EQ. 0) THEN - LYIC = LPHI + 2*NEQ - LYPIC = LYIC + NEQ - LPWK = LYPIC - CALL DDASIC(TN,Y,YPRIME,NEQ,INFO(11),IWORK(LID), - * RES,JAC,PSOL,H0,RWORK(LWT),NWT,IDID,RPAR,IPAR, - * RWORK(LPHI),RWORK(LSAVR),RWORK(LDELTA),RWORK(LE), - * RWORK(LYIC),RWORK(LYPIC),RWORK(LPWK),RWORK(LWM),IWORK(LIWM), - * HMIN,RWORK(LROUND),RWORK(LEPLI),RWORK(LSQRN),RWORK(LRSQRN), - * EPCONI,RWORK(LSTOL),INFO(15),ICNFLG,IWORK(LICNS),DDASID) - ELSE IF (INFO(12) .EQ. 1) THEN - LYIC = LWM - LYPIC = LYIC + NEQ - LPWK = LYPIC + NEQ - CALL DDASIC(TN,Y,YPRIME,NEQ,INFO(11),IWORK(LID), - * RES,JAC,PSOL,H0,RWORK(LWT),NWT,IDID,RPAR,IPAR, - * RWORK(LPHI),RWORK(LSAVR),RWORK(LDELTA),RWORK(LE), - * RWORK(LYIC),RWORK(LYPIC),RWORK(LPWK),RWORK(LWM),IWORK(LIWM), - * HMIN,RWORK(LROUND),RWORK(LEPLI),RWORK(LSQRN),RWORK(LRSQRN), - * EPCONI,RWORK(LSTOL),INFO(15),ICNFLG,IWORK(LICNS),DDASIK) - ENDIF -C - IF (IDID .LT. 0) GO TO 600 -C -C DDASIC was successful. If this was the first call to DDASIC, -C update the WT array (with the current Y) and call it again. -C - IF (NWT .EQ. 2) GO TO 355 - NWT = 2 - CALL DDAWTS(NEQ,INFO(2),RTOL,ATOL,Y,RWORK(LWT),RPAR,IPAR) - CALL DINVWT(NEQ,RWORK(LWT),IER) - IF (IER .NE. 0) GO TO 713 - GO TO 350 -C -C If INFO(14) = 1, return now with IDID = 4. -C -355 IF (INFO(14) .EQ. 1) THEN - IDID = 4 - H = H0 - IF (INFO(11) .EQ. 1) RWORK(LHOLD) = H0 - GO TO 590 - ENDIF -C -C Update the WT and VT arrays one more time, with the new Y. -C - CALL DDAWTS(NEQ,INFO(2),RTOL,ATOL,Y,RWORK(LWT),RPAR,IPAR) - CALL DINVWT(NEQ,RWORK(LWT),IER) - IF (IER .NE. 0) GO TO 713 - IF (INFO(16) .NE. 0) THEN - DO 357 I = 1, NEQ - 357 RWORK(LVT+I-1) = MAX(IWORK(LID+I-1),0)*RWORK(LWT+I-1) - ENDIF -C -C Reset the initial stepsize to be used by DDSTP. -C Use H0, if this was input. Otherwise, recompute H0, -C and adjust it if necessary to meet HMAX bound. -C - IF (INFO(8) .NE. 0) THEN - H0 = RWORK(LH) - GO TO 360 - ENDIF -C - H0 = 0.001D0*TDIST - YPNORM = DDWNRM(NEQ,YPRIME,RWORK(LVT),RPAR,IPAR) - IF (YPNORM .GT. 0.5D0/H0) H0 = 0.5D0/YPNORM - H0 = SIGN(H0,TOUT-T) -C -360 IF (INFO(7) .NE. 0) THEN - RH = ABS(H0)/RWORK(LHMAX) - IF (RH .GT. 1.0D0) H0 = H0/RH - ENDIF -C -C Check against TSTOP, if applicable. -C - IF (INFO(4) .NE. 0) THEN - TSTOP = RWORK(LTSTOP) - IF ((T + H0 - TSTOP)*H0 .GT. 0.0D0) H0 = TSTOP - T - ENDIF -C -C Load H and RWORK(LH) with H0. -C -370 H = H0 - RWORK(LH) = H -C -C Load Y and H*YPRIME into PHI(*,1) and PHI(*,2). -C - ITEMP = LPHI + NEQ - DO 380 I = 1,NEQ - RWORK(LPHI + I - 1) = Y(I) -380 RWORK(ITEMP + I - 1) = H*YPRIME(I) -C - GO TO 500 -C -C----------------------------------------------------------------------- -C This block is for continuation calls only. -C Its purpose is to check stop conditions before taking a step. -C Adjust H if necessary to meet HMAX bound. -C----------------------------------------------------------------------- -C -400 CONTINUE - UROUND=RWORK(LROUND) - DONE = .FALSE. - TN=RWORK(LTN) - H=RWORK(LH) - IF(INFO(7) .EQ. 0) GO TO 410 - RH = ABS(H)/RWORK(LHMAX) - IF(RH .GT. 1.0D0) H = H/RH -410 CONTINUE - IF(T .EQ. TOUT) GO TO 719 - IF((T - TOUT)*H .GT. 0.0D0) GO TO 711 - IF(INFO(4) .EQ. 1) GO TO 430 - IF(INFO(3) .EQ. 1) GO TO 420 - IF((TN-TOUT)*H.LT.0.0D0)GO TO 490 - CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD), - * RWORK(LPHI),RWORK(LPSI)) - T=TOUT - IDID = 3 - DONE = .TRUE. - GO TO 490 -420 IF((TN-T)*H .LE. 0.0D0) GO TO 490 - IF((TN - TOUT)*H .GT. 0.0D0) GO TO 425 - CALL DDATRP(TN,TN,Y,YPRIME,NEQ,IWORK(LKOLD), - * RWORK(LPHI),RWORK(LPSI)) - T = TN - IDID = 1 - DONE = .TRUE. - GO TO 490 -425 CONTINUE - CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD), - * RWORK(LPHI),RWORK(LPSI)) - T = TOUT - IDID = 3 - DONE = .TRUE. - GO TO 490 -430 IF(INFO(3) .EQ. 1) GO TO 440 - TSTOP=RWORK(LTSTOP) - IF((TN-TSTOP)*H.GT.0.0D0) GO TO 715 - IF((TSTOP-TOUT)*H.LT.0.0D0)GO TO 709 - IF((TN-TOUT)*H.LT.0.0D0)GO TO 450 - CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD), - * RWORK(LPHI),RWORK(LPSI)) - T=TOUT - IDID = 3 - DONE = .TRUE. - GO TO 490 -440 TSTOP = RWORK(LTSTOP) - IF((TN-TSTOP)*H .GT. 0.0D0) GO TO 715 - IF((TSTOP-TOUT)*H .LT. 0.0D0) GO TO 709 - IF((TN-T)*H .LE. 0.0D0) GO TO 450 - IF((TN - TOUT)*H .GT. 0.0D0) GO TO 445 - CALL DDATRP(TN,TN,Y,YPRIME,NEQ,IWORK(LKOLD), - * RWORK(LPHI),RWORK(LPSI)) - T = TN - IDID = 1 - DONE = .TRUE. - GO TO 490 -445 CONTINUE - CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD), - * RWORK(LPHI),RWORK(LPSI)) - T = TOUT - IDID = 3 - DONE = .TRUE. - GO TO 490 -450 CONTINUE -C -C Check whether we are within roundoff of TSTOP. -C - IF(ABS(TN-TSTOP).GT.100.0D0*UROUND* - * (ABS(TN)+ABS(H)))GO TO 460 - CALL DDATRP(TN,TSTOP,Y,YPRIME,NEQ,IWORK(LKOLD), - * RWORK(LPHI),RWORK(LPSI)) - IDID=2 - T=TSTOP - DONE = .TRUE. - GO TO 490 -460 TNEXT=TN+H - IF((TNEXT-TSTOP)*H.LE.0.0D0)GO TO 490 - H=TSTOP-TN - RWORK(LH)=H -C -490 IF (DONE) GO TO 590 -C -C----------------------------------------------------------------------- -C The next block contains the call to the one-step integrator DDSTP. -C This is a looping point for the integration steps. -C Check for too many steps. -C Check for poor Newton/Krylov performance. -C Update WT. Check for too much accuracy requested. -C Compute minimum stepsize. -C----------------------------------------------------------------------- -C -500 CONTINUE -C -C Check for too many steps. -C - IF((IWORK(LNST)-IWORK(LNSTL)).LT.500) GO TO 505 - IDID=-1 - GO TO 527 -C -C Check for poor Newton/Krylov performance. -C -505 IF (INFO(12) .EQ. 0) GO TO 510 - NSTD = IWORK(LNST) - IWORK(LNSTL) - NNID = IWORK(LNNI) - NNI0 - IF (NSTD .LT. 10 .OR. NNID .EQ. 0) GO TO 510 - AVLIN = REAL(IWORK(LNLI) - NLI0)/REAL(NNID) - RCFN = REAL(IWORK(LNCFN) - NCFN0)/REAL(NSTD) - RCFL = REAL(IWORK(LNCFL) - NCFL0)/REAL(NNID) - FMAXL = IWORK(LMAXL) - LAVL = AVLIN .GT. FMAXL - LCFN = RCFN .GT. 0.9D0 - LCFL = RCFL .GT. 0.9D0 - LWARN = LAVL .OR. LCFN .OR. LCFL - IF (.NOT.LWARN) GO TO 510 - NWARN = NWARN + 1 - IF (NWARN .GT. 10) GO TO 510 - IF (LAVL) THEN - MSG = 'DASPK-- Warning. Poor iterative algorithm performance ' - CALL XERRWD (MSG, 56, 501, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) - MSG = ' at T = R1. Average no. of linear iterations = R2 ' - CALL XERRWD (MSG, 56, 501, 0, 0, 0, 0, 2, TN, AVLIN) - ENDIF - IF (LCFN) THEN - MSG = 'DASPK-- Warning. Poor iterative algorithm performance ' - CALL XERRWD (MSG, 56, 502, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) - MSG = ' at T = R1. Nonlinear convergence failure rate = R2' - CALL XERRWD (MSG, 56, 502, 0, 0, 0, 0, 2, TN, RCFN) - ENDIF - IF (LCFL) THEN - MSG = 'DASPK-- Warning. Poor iterative algorithm performance ' - CALL XERRWD (MSG, 56, 503, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) - MSG = ' at T = R1. Linear convergence failure rate = R2 ' - CALL XERRWD (MSG, 56, 503, 0, 0, 0, 0, 2, TN, RCFL) - ENDIF -C -C Update WT and VT, if this is not the first call. -C -510 CALL DDAWTS(NEQ,INFO(2),RTOL,ATOL,RWORK(LPHI),RWORK(LWT), - * RPAR,IPAR) - CALL DINVWT(NEQ,RWORK(LWT),IER) - IF (IER .NE. 0) THEN - IDID = -3 - GO TO 527 - ENDIF - IF (INFO(16) .NE. 0) THEN - DO 515 I = 1, NEQ - 515 RWORK(LVT+I-1) = MAX(IWORK(LID+I-1),0)*RWORK(LWT+I-1) - ENDIF -C -C Test for too much accuracy requested. -C - R = DDWNRM(NEQ,RWORK(LPHI),RWORK(LWT),RPAR,IPAR)*100.0D0*UROUND - IF (R .LE. 1.0D0) GO TO 525 -C -C Multiply RTOL and ATOL by R and return. -C - IF(INFO(2).EQ.1)GO TO 523 - RTOL(1)=R*RTOL(1) - ATOL(1)=R*ATOL(1) - IDID=-2 - GO TO 527 -523 DO 524 I=1,NEQ - RTOL(I)=R*RTOL(I) -524 ATOL(I)=R*ATOL(I) - IDID=-2 - GO TO 527 -525 CONTINUE -C -C Compute minimum stepsize. -C - HMIN=4.0D0*UROUND*MAX(ABS(TN),ABS(TOUT)) -C -C Test H vs. HMAX - IF (INFO(7) .NE. 0) THEN - RH = ABS(H)/RWORK(LHMAX) - IF (RH .GT. 1.0D0) H = H/RH - ENDIF -C -C Call the one-step integrator. -C Note that INFO(12) represents the nonlinear solver type. -C Pass the required nonlinear solver, depending upon INFO(12). -C - IF (INFO(12) .EQ. 0) THEN - CALL DDSTP(TN,Y,YPRIME,NEQ, - * RES,JAC,PSOL,H,RWORK(LWT),RWORK(LVT),INFO(1),IDID,RPAR,IPAR, - * RWORK(LPHI),RWORK(LSAVR),RWORK(LDELTA),RWORK(LE), - * RWORK(LWM),IWORK(LIWM), - * RWORK(LALPHA),RWORK(LBETA),RWORK(LGAMMA), - * RWORK(LPSI),RWORK(LSIGMA), - * RWORK(LCJ),RWORK(LCJOLD),RWORK(LHOLD),RWORK(LS),HMIN, - * RWORK(LROUND), RWORK(LEPLI),RWORK(LSQRN),RWORK(LRSQRN), - * RWORK(LEPCON), IWORK(LPHASE),IWORK(LJCALC),INFO(15), - * IWORK(LK), IWORK(LKOLD),IWORK(LNS),NONNEG,INFO(12), - * DNEDD) - ELSE IF (INFO(12) .EQ. 1) THEN - CALL DDSTP(TN,Y,YPRIME,NEQ, - * RES,JAC,PSOL,H,RWORK(LWT),RWORK(LVT),INFO(1),IDID,RPAR,IPAR, - * RWORK(LPHI),RWORK(LSAVR),RWORK(LDELTA),RWORK(LE), - * RWORK(LWM),IWORK(LIWM), - * RWORK(LALPHA),RWORK(LBETA),RWORK(LGAMMA), - * RWORK(LPSI),RWORK(LSIGMA), - * RWORK(LCJ),RWORK(LCJOLD),RWORK(LHOLD),RWORK(LS),HMIN, - * RWORK(LROUND), RWORK(LEPLI),RWORK(LSQRN),RWORK(LRSQRN), - * RWORK(LEPCON), IWORK(LPHASE),IWORK(LJCALC),INFO(15), - * IWORK(LK), IWORK(LKOLD),IWORK(LNS),NONNEG,INFO(12), - * DNEDK) - ENDIF -C -527 IF(IDID.LT.0)GO TO 600 -C -C----------------------------------------------------------------------- -C This block handles the case of a successful return from DDSTP -C (IDID=1). Test for stop conditions. -C----------------------------------------------------------------------- -C - IF(INFO(4).NE.0)GO TO 540 - IF(INFO(3).NE.0)GO TO 530 - IF((TN-TOUT)*H.LT.0.0D0)GO TO 500 - CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ, - * IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) - IDID=3 - T=TOUT - GO TO 580 -530 IF((TN-TOUT)*H.GE.0.0D0)GO TO 535 - T=TN - IDID=1 - GO TO 580 -535 CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ, - * IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) - IDID=3 - T=TOUT - GO TO 580 -540 IF(INFO(3).NE.0)GO TO 550 - IF((TN-TOUT)*H.LT.0.0D0)GO TO 542 - CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ, - * IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) - T=TOUT - IDID=3 - GO TO 580 -542 IF(ABS(TN-TSTOP).LE.100.0D0*UROUND* - * (ABS(TN)+ABS(H)))GO TO 545 - TNEXT=TN+H - IF((TNEXT-TSTOP)*H.LE.0.0D0)GO TO 500 - H=TSTOP-TN - GO TO 500 -545 CALL DDATRP(TN,TSTOP,Y,YPRIME,NEQ, - * IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) - IDID=2 - T=TSTOP - GO TO 580 -550 IF((TN-TOUT)*H.GE.0.0D0)GO TO 555 - IF(ABS(TN-TSTOP).LE.100.0D0*UROUND*(ABS(TN)+ABS(H)))GO TO 552 - T=TN - IDID=1 - GO TO 580 -552 CALL DDATRP(TN,TSTOP,Y,YPRIME,NEQ, - * IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) - IDID=2 - T=TSTOP - GO TO 580 -555 CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ, - * IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) - T=TOUT - IDID=3 -580 CONTINUE -C -C----------------------------------------------------------------------- -C All successful returns from DDASPK are made from this block. -C----------------------------------------------------------------------- -C -590 CONTINUE - RWORK(LTN)=TN - RWORK(LH)=H - RETURN -C -C----------------------------------------------------------------------- -C This block handles all unsuccessful returns other than for -C illegal input. -C----------------------------------------------------------------------- -C -600 CONTINUE - ITEMP = -IDID - GO TO (610,620,630,700,655,640,650,660,670,675, - * 680,685,690,695), ITEMP -C -C The maximum number of steps was taken before -C reaching tout. -C -610 MSG = 'DASPK-- AT CURRENT T (=R1) 500 STEPS' - CALL XERRWD(MSG,38,610,0,0,0,0,1,TN,0.0D0) - MSG = 'DASPK-- TAKEN ON THIS CALL BEFORE REACHING TOUT' - CALL XERRWD(MSG,48,611,0,0,0,0,0,0.0D0,0.0D0) - GO TO 700 -C -C Too much accuracy for machine precision. -C -620 MSG = 'DASPK-- AT T (=R1) TOO MUCH ACCURACY REQUESTED' - CALL XERRWD(MSG,47,620,0,0,0,0,1,TN,0.0D0) - MSG = 'DASPK-- FOR PRECISION OF MACHINE. RTOL AND ATOL' - CALL XERRWD(MSG,48,621,0,0,0,0,0,0.0D0,0.0D0) - MSG = 'DASPK-- WERE INCREASED TO APPROPRIATE VALUES' - CALL XERRWD(MSG,45,622,0,0,0,0,0,0.0D0,0.0D0) - GO TO 700 -C -C WT(I) .LE. 0.0D0 for some I (not at start of problem). -C -630 MSG = 'DASPK-- AT T (=R1) SOME ELEMENT OF WT' - CALL XERRWD(MSG,38,630,0,0,0,0,1,TN,0.0D0) - MSG = 'DASPK-- HAS BECOME .LE. 0.0' - CALL XERRWD(MSG,28,631,0,0,0,0,0,0.0D0,0.0D0) - GO TO 700 -C -C Error test failed repeatedly or with H=HMIN. -C -640 MSG = 'DASPK-- AT T (=R1) AND STEPSIZE H (=R2) THE' - CALL XERRWD(MSG,44,640,0,0,0,0,2,TN,H) - MSG='DASPK-- ERROR TEST FAILED REPEATEDLY OR WITH ABS(H)=HMIN' - CALL XERRWD(MSG,57,641,0,0,0,0,0,0.0D0,0.0D0) - GO TO 700 -C -C Nonlinear solver failed to converge repeatedly or with H=HMIN. -C -650 MSG = 'DASPK-- AT T (=R1) AND STEPSIZE H (=R2) THE' - CALL XERRWD(MSG,44,650,0,0,0,0,2,TN,H) - MSG = 'DASPK-- NONLINEAR SOLVER FAILED TO CONVERGE' - CALL XERRWD(MSG,44,651,0,0,0,0,0,0.0D0,0.0D0) - MSG = 'DASPK-- REPEATEDLY OR WITH ABS(H)=HMIN' - CALL XERRWD(MSG,40,652,0,0,0,0,0,0.0D0,0.0D0) - GO TO 700 -C -C The preconditioner had repeated failures. -C -655 MSG = 'DASPK-- AT T (=R1) AND STEPSIZE H (=R2) THE' - CALL XERRWD(MSG,44,655,0,0,0,0,2,TN,H) - MSG = 'DASPK-- PRECONDITIONER HAD REPEATED FAILURES.' - CALL XERRWD(MSG,46,656,0,0,0,0,0,0.0D0,0.0D0) - GO TO 700 -C -C The iteration matrix is singular. -C -660 MSG = 'DASPK-- AT T (=R1) AND STEPSIZE H (=R2) THE' - CALL XERRWD(MSG,44,660,0,0,0,0,2,TN,H) - MSG = 'DASPK-- ITERATION MATRIX IS SINGULAR.' - CALL XERRWD(MSG,38,661,0,0,0,0,0,0.0D0,0.0D0) - GO TO 700 -C -C Nonlinear system failure preceded by error test failures. -C -670 MSG = 'DASPK-- AT T (=R1) AND STEPSIZE H (=R2) THE' - CALL XERRWD(MSG,44,670,0,0,0,0,2,TN,H) - MSG = 'DASPK-- NONLINEAR SOLVER COULD NOT CONVERGE.' - CALL XERRWD(MSG,45,671,0,0,0,0,0,0.0D0,0.0D0) - MSG = 'DASPK-- ALSO, THE ERROR TEST FAILED REPEATEDLY.' - CALL XERRWD(MSG,49,672,0,0,0,0,0,0.0D0,0.0D0) - GO TO 700 -C -C Nonlinear system failure because IRES = -1. -C -675 MSG = 'DASPK-- AT T (=R1) AND STEPSIZE H (=R2) THE' - CALL XERRWD(MSG,44,675,0,0,0,0,2,TN,H) - MSG = 'DASPK-- NONLINEAR SYSTEM SOLVER COULD NOT CONVERGE' - CALL XERRWD(MSG,51,676,0,0,0,0,0,0.0D0,0.0D0) - MSG = 'DASPK-- BECAUSE IRES WAS EQUAL TO MINUS ONE' - CALL XERRWD(MSG,44,677,0,0,0,0,0,0.0D0,0.0D0) - GO TO 700 -C -C Failure because IRES = -2. -C -680 MSG = 'DASPK-- AT T (=R1) AND STEPSIZE H (=R2)' - CALL XERRWD(MSG,40,680,0,0,0,0,2,TN,H) - MSG = 'DASPK-- IRES WAS EQUAL TO MINUS TWO' - CALL XERRWD(MSG,36,681,0,0,0,0,0,0.0D0,0.0D0) - GO TO 700 -C -C Failed to compute initial YPRIME. -C -685 MSG = 'DASPK-- AT T (=R1) AND STEPSIZE H (=R2) THE' - CALL XERRWD(MSG,44,685,0,0,0,0,0,0.0D0,0.0D0) - MSG = 'DASPK-- INITIAL (Y,YPRIME) COULD NOT BE COMPUTED' - CALL XERRWD(MSG,49,686,0,0,0,0,2,TN,H0) - GO TO 700 -C -C Failure because IER was negative from PSOL. -C -690 MSG = 'DASPK-- AT T (=R1) AND STEPSIZE H (=R2)' - CALL XERRWD(MSG,40,690,0,0,0,0,2,TN,H) - MSG = 'DASPK-- IER WAS NEGATIVE FROM PSOL' - CALL XERRWD(MSG,35,691,0,0,0,0,0,0.0D0,0.0D0) - GO TO 700 -C -C Failure because the linear system solver could not converge. -C -695 MSG = 'DASPK-- AT T (=R1) AND STEPSIZE H (=R2) THE' - CALL XERRWD(MSG,44,695,0,0,0,0,2,TN,H) - MSG = 'DASPK-- LINEAR SYSTEM SOLVER COULD NOT CONVERGE.' - CALL XERRWD(MSG,50,696,0,0,0,0,0,0.0D0,0.0D0) - GO TO 700 -C -C -700 CONTINUE - INFO(1)=-1 - T=TN - RWORK(LTN)=TN - RWORK(LH)=H - RETURN -C -C----------------------------------------------------------------------- -C This block handles all error returns due to illegal input, -C as detected before calling DDSTP. -C First the error message routine is called. If this happens -C twice in succession, execution is terminated. -C----------------------------------------------------------------------- -C -701 MSG = 'DASPK-- ELEMENT (=I1) OF INFO VECTOR IS NOT VALID' - CALL XERRWD(MSG,50,1,0,1,ITEMP,0,0,0.0D0,0.0D0) - GO TO 750 -702 MSG = 'DASPK-- NEQ (=I1) .LE. 0' - CALL XERRWD(MSG,25,2,0,1,NEQ,0,0,0.0D0,0.0D0) - GO TO 750 -703 MSG = 'DASPK-- MAXORD (=I1) NOT IN RANGE' - CALL XERRWD(MSG,34,3,0,1,MXORD,0,0,0.0D0,0.0D0) - GO TO 750 -704 MSG='DASPK-- RWORK LENGTH NEEDED, LENRW (=I1), EXCEEDS LRW (=I2)' - CALL XERRWD(MSG,60,4,0,2,LENRW,LRW,0,0.0D0,0.0D0) - GO TO 750 -705 MSG='DASPK-- IWORK LENGTH NEEDED, LENIW (=I1), EXCEEDS LIW (=I2)' - CALL XERRWD(MSG,60,5,0,2,LENIW,LIW,0,0.0D0,0.0D0) - GO TO 750 -706 MSG = 'DASPK-- SOME ELEMENT OF RTOL IS .LT. 0' - CALL XERRWD(MSG,39,6,0,0,0,0,0,0.0D0,0.0D0) - GO TO 750 -707 MSG = 'DASPK-- SOME ELEMENT OF ATOL IS .LT. 0' - CALL XERRWD(MSG,39,7,0,0,0,0,0,0.0D0,0.0D0) - GO TO 750 -708 MSG = 'DASPK-- ALL ELEMENTS OF RTOL AND ATOL ARE ZERO' - CALL XERRWD(MSG,47,8,0,0,0,0,0,0.0D0,0.0D0) - GO TO 750 -709 MSG='DASPK-- INFO(4) = 1 AND TSTOP (=R1) BEHIND TOUT (=R2)' - CALL XERRWD(MSG,54,9,0,0,0,0,2,TSTOP,TOUT) - GO TO 750 -710 MSG = 'DASPK-- HMAX (=R1) .LT. 0.0' - CALL XERRWD(MSG,28,10,0,0,0,0,1,HMAX,0.0D0) - GO TO 750 -711 MSG = 'DASPK-- TOUT (=R1) BEHIND T (=R2)' - CALL XERRWD(MSG,34,11,0,0,0,0,2,TOUT,T) - GO TO 750 -712 MSG = 'DASPK-- INFO(8)=1 AND H0=0.0' - CALL XERRWD(MSG,29,12,0,0,0,0,0,0.0D0,0.0D0) - GO TO 750 -713 MSG = 'DASPK-- SOME ELEMENT OF WT IS .LE. 0.0' - CALL XERRWD(MSG,39,13,0,0,0,0,0,0.0D0,0.0D0) - GO TO 750 -714 MSG='DASPK-- TOUT (=R1) TOO CLOSE TO T (=R2) TO START INTEGRATION' - CALL XERRWD(MSG,60,14,0,0,0,0,2,TOUT,T) - GO TO 750 -715 MSG = 'DASPK-- INFO(4)=1 AND TSTOP (=R1) BEHIND T (=R2)' - CALL XERRWD(MSG,49,15,0,0,0,0,2,TSTOP,T) - GO TO 750 -717 MSG = 'DASPK-- ML (=I1) ILLEGAL. EITHER .LT. 0 OR .GT. NEQ' - CALL XERRWD(MSG,52,17,0,1,IWORK(LML),0,0,0.0D0,0.0D0) - GO TO 750 -718 MSG = 'DASPK-- MU (=I1) ILLEGAL. EITHER .LT. 0 OR .GT. NEQ' - CALL XERRWD(MSG,52,18,0,1,IWORK(LMU),0,0,0.0D0,0.0D0) - GO TO 750 -719 MSG = 'DASPK-- TOUT (=R1) IS EQUAL TO T (=R2)' - CALL XERRWD(MSG,39,19,0,0,0,0,2,TOUT,T) - GO TO 750 -720 MSG = 'DASPK-- MAXL (=I1) ILLEGAL. EITHER .LT. 1 OR .GT. NEQ' - CALL XERRWD(MSG,54,20,0,1,IWORK(LMAXL),0,0,0.0D0,0.0D0) - GO TO 750 -721 MSG = 'DASPK-- KMP (=I1) ILLEGAL. EITHER .LT. 1 OR .GT. MAXL' - CALL XERRWD(MSG,54,21,0,1,IWORK(LKMP),0,0,0.0D0,0.0D0) - GO TO 750 -722 MSG = 'DASPK-- NRMAX (=I1) ILLEGAL. .LT. 0' - CALL XERRWD(MSG,36,22,0,1,IWORK(LNRMAX),0,0,0.0D0,0.0D0) - GO TO 750 -723 MSG = 'DASPK-- EPLI (=R1) ILLEGAL. EITHER .LE. 0.D0 OR .GE. 1.D0' - CALL XERRWD(MSG,58,23,0,0,0,0,1,RWORK(LEPLI),0.0D0) - GO TO 750 -724 MSG = 'DASPK-- ILLEGAL IWORK VALUE FOR INFO(11) .NE. 0' - CALL XERRWD(MSG,48,24,0,0,0,0,0,0.0D0,0.0D0) - GO TO 750 -725 MSG = 'DASPK-- ONE OF THE INPUTS FOR INFO(17) = 1 IS ILLEGAL' - CALL XERRWD(MSG,54,25,0,0,0,0,0,0.0D0,0.0D0) - GO TO 750 -726 MSG = 'DASPK-- ILLEGAL IWORK VALUE FOR INFO(10) .NE. 0' - CALL XERRWD(MSG,48,26,0,0,0,0,0,0.0D0,0.0D0) - GO TO 750 -727 MSG = 'DASPK-- Y(I) AND IWORK(40+I) (I=I1) INCONSISTENT' - CALL XERRWD(MSG,49,27,0,1,IRET,0,0,0.0D0,0.0D0) - GO TO 750 -750 IF(INFO(1).EQ.-1) GO TO 760 - INFO(1)=-1 - IDID=-33 - RETURN -760 MSG = 'DASPK-- REPEATED OCCURRENCES OF ILLEGAL INPUT' - CALL XERRWD(MSG,46,701,0,0,0,0,0,0.0D0,0.0D0) -770 MSG = 'DASPK-- RUN TERMINATED. APPARENT INFINITE LOOP' - CALL XERRWD(MSG,47,702,1,0,0,0,0,0.0D0,0.0D0) - RETURN -C -C------END OF SUBROUTINE DDASPK----------------------------------------- - END
--- a/liboctave/cruft/daspk/ddstp.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,465 +0,0 @@ -C Work performed under the auspices of the U.S. Department of Energy -C by Lawrence Livermore National Laboratory under contract number -C W-7405-Eng-48. -C - SUBROUTINE DDSTP(X,Y,YPRIME,NEQ,RES,JAC,PSOL,H,WT,VT, - * JSTART,IDID,RPAR,IPAR,PHI,SAVR,DELTA,E,WM,IWM, - * ALPHA,BETA,GAMMA,PSI,SIGMA,CJ,CJOLD,HOLD,S,HMIN,UROUND, - * EPLI,SQRTN,RSQRTN,EPCON,IPHASE,JCALC,JFLG,K,KOLD,NS,NONNEG, - * NTYPE,NLS) -C -C***BEGIN PROLOGUE DDSTP -C***REFER TO DDASPK -C***DATE WRITTEN 890101 (YYMMDD) -C***REVISION DATE 900926 (YYMMDD) -C***REVISION DATE 940909 (YYMMDD) (Reset PSI(1), PHI(*,2) at 690) -C -C -C----------------------------------------------------------------------- -C***DESCRIPTION -C -C DDSTP solves a system of differential/algebraic equations of -C the form G(X,Y,YPRIME) = 0, for one step (normally from X to X+H). -C -C The methods used are modified divided difference, fixed leading -C coefficient forms of backward differentiation formulas. -C The code adjusts the stepsize and order to control the local error -C per step. -C -C -C The parameters represent -C X -- Independent variable. -C Y -- Solution vector at X. -C YPRIME -- Derivative of solution vector -C after successful step. -C NEQ -- Number of equations to be integrated. -C RES -- External user-supplied subroutine -C to evaluate the residual. See RES description -C in DDASPK prologue. -C JAC -- External user-supplied routine to update -C Jacobian or preconditioner information in the -C nonlinear solver. See JAC description in DDASPK -C prologue. -C PSOL -- External user-supplied routine to solve -C a linear system using preconditioning. -C (This is optional). See PSOL in DDASPK prologue. -C H -- Appropriate step size for next step. -C Normally determined by the code. -C WT -- Vector of weights for error criterion used in Newton test. -C VT -- Masked vector of weights used in error test. -C JSTART -- Integer variable set 0 for -C first step, 1 otherwise. -C IDID -- Completion code returned from the nonlinear solver. -C See IDID description in DDASPK prologue. -C RPAR,IPAR -- Real and integer parameter arrays that -C are used for communication between the -C calling program and external user routines. -C They are not altered by DNSK -C PHI -- Array of divided differences used by -C DDSTP. The length is NEQ*(K+1), where -C K is the maximum order. -C SAVR -- Work vector for DDSTP of length NEQ. -C DELTA,E -- Work vectors for DDSTP of length NEQ. -C WM,IWM -- Real and integer arrays storing -C information required by the linear solver. -C -C The other parameters are information -C which is needed internally by DDSTP to -C continue from step to step. -C -C----------------------------------------------------------------------- -C***ROUTINES CALLED -C NLS, DDWNRM, DDATRP -C -C***END PROLOGUE DDSTP -C -C - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - DIMENSION Y(*),YPRIME(*),WT(*),VT(*) - DIMENSION PHI(NEQ,*),SAVR(*),DELTA(*),E(*) - DIMENSION WM(*),IWM(*) - DIMENSION PSI(*),ALPHA(*),BETA(*),GAMMA(*),SIGMA(*) - DIMENSION RPAR(*),IPAR(*) - EXTERNAL RES, JAC, PSOL, NLS -C - PARAMETER (LMXORD=3) - PARAMETER (LNST=11, LETF=14, LCFN=15) -C -C -C----------------------------------------------------------------------- -C BLOCK 1. -C Initialize. On the first call, set -C the order to 1 and initialize -C other variables. -C----------------------------------------------------------------------- -C -C Initializations for all calls -C - XOLD=X - NCF=0 - NEF=0 - IF(JSTART .NE. 0) GO TO 120 -C -C If this is the first step, perform -C other initializations -C - K=1 - KOLD=0 - HOLD=0.0D0 - PSI(1)=H - CJ = 1.D0/H - IPHASE = 0 - NS=0 -120 CONTINUE -C -C -C -C -C -C----------------------------------------------------------------------- -C BLOCK 2 -C Compute coefficients of formulas for -C this step. -C----------------------------------------------------------------------- -200 CONTINUE - KP1=K+1 - KP2=K+2 - KM1=K-1 - IF(H.NE.HOLD.OR.K .NE. KOLD) NS = 0 - NS=MIN0(NS+1,KOLD+2) - NSP1=NS+1 - IF(KP1 .LT. NS)GO TO 230 -C - BETA(1)=1.0D0 - ALPHA(1)=1.0D0 - TEMP1=H - GAMMA(1)=0.0D0 - SIGMA(1)=1.0D0 - DO 210 I=2,KP1 - TEMP2=PSI(I-1) - PSI(I-1)=TEMP1 - BETA(I)=BETA(I-1)*PSI(I-1)/TEMP2 - TEMP1=TEMP2+H - ALPHA(I)=H/TEMP1 - SIGMA(I)=(I-1)*SIGMA(I-1)*ALPHA(I) - GAMMA(I)=GAMMA(I-1)+ALPHA(I-1)/H -210 CONTINUE - PSI(KP1)=TEMP1 -230 CONTINUE -C -C Compute ALPHAS, ALPHA0 -C - ALPHAS = 0.0D0 - ALPHA0 = 0.0D0 - DO 240 I = 1,K - ALPHAS = ALPHAS - 1.0D0/I - ALPHA0 = ALPHA0 - ALPHA(I) -240 CONTINUE -C -C Compute leading coefficient CJ -C - CJLAST = CJ - CJ = -ALPHAS/H -C -C Compute variable stepsize error coefficient CK -C - CK = ABS(ALPHA(KP1) + ALPHAS - ALPHA0) - CK = MAX(CK,ALPHA(KP1)) -C -C Change PHI to PHI STAR -C - IF(KP1 .LT. NSP1) GO TO 280 - DO 270 J=NSP1,KP1 - DO 260 I=1,NEQ -260 PHI(I,J)=BETA(J)*PHI(I,J) -270 CONTINUE -280 CONTINUE -C -C Update time -C - X=X+H -C -C Initialize IDID to 1 -C - IDID = 1 -C -C -C -C -C -C----------------------------------------------------------------------- -C BLOCK 3 -C Call the nonlinear system solver to obtain the solution and -C derivative. -C----------------------------------------------------------------------- -C - CALL NLS(X,Y,YPRIME,NEQ, - * RES,JAC,PSOL,H,WT,JSTART,IDID,RPAR,IPAR,PHI,GAMMA, - * SAVR,DELTA,E,WM,IWM,CJ,CJOLD,CJLAST,S, - * UROUND,EPLI,SQRTN,RSQRTN,EPCON,JCALC,JFLG,KP1, - * NONNEG,NTYPE,IERNLS) -C - IF(IERNLS .NE. 0)GO TO 600 -C -C -C -C -C -C----------------------------------------------------------------------- -C BLOCK 4 -C Estimate the errors at orders K,K-1,K-2 -C as if constant stepsize was used. Estimate -C the local error at order K and test -C whether the current step is successful. -C----------------------------------------------------------------------- -C -C Estimate errors at orders K,K-1,K-2 -C - ENORM = DDWNRM(NEQ,E,VT,RPAR,IPAR) - ERK = SIGMA(K+1)*ENORM - TERK = (K+1)*ERK - EST = ERK - KNEW=K - IF(K .EQ. 1)GO TO 430 - DO 405 I = 1,NEQ -405 DELTA(I) = PHI(I,KP1) + E(I) - ERKM1=SIGMA(K)*DDWNRM(NEQ,DELTA,VT,RPAR,IPAR) - TERKM1 = K*ERKM1 - IF(K .GT. 2)GO TO 410 - IF(TERKM1 .LE. 0.5*TERK)GO TO 420 - GO TO 430 -410 CONTINUE - DO 415 I = 1,NEQ -415 DELTA(I) = PHI(I,K) + DELTA(I) - ERKM2=SIGMA(K-1)*DDWNRM(NEQ,DELTA,VT,RPAR,IPAR) - TERKM2 = (K-1)*ERKM2 - IF(MAX(TERKM1,TERKM2).GT.TERK)GO TO 430 -C -C Lower the order -C -420 CONTINUE - KNEW=K-1 - EST = ERKM1 -C -C -C Calculate the local error for the current step -C to see if the step was successful -C -430 CONTINUE - ERR = CK * ENORM - IF(ERR .GT. 1.0D0)GO TO 600 -C -C -C -C -C -C----------------------------------------------------------------------- -C BLOCK 5 -C The step is successful. Determine -C the best order and stepsize for -C the next step. Update the differences -C for the next step. -C----------------------------------------------------------------------- - IDID=1 - IWM(LNST)=IWM(LNST)+1 - KDIFF=K-KOLD - KOLD=K - HOLD=H -C -C -C Estimate the error at order K+1 unless -C already decided to lower order, or -C already using maximum order, or -C stepsize not constant, or -C order raised in previous step -C - IF(KNEW.EQ.KM1.OR.K.EQ.IWM(LMXORD))IPHASE=1 - IF(IPHASE .EQ. 0)GO TO 545 - IF(KNEW.EQ.KM1)GO TO 540 - IF(K.EQ.IWM(LMXORD)) GO TO 550 - IF(KP1.GE.NS.OR.KDIFF.EQ.1)GO TO 550 - DO 510 I=1,NEQ -510 DELTA(I)=E(I)-PHI(I,KP2) - ERKP1 = (1.0D0/(K+2))*DDWNRM(NEQ,DELTA,VT,RPAR,IPAR) - TERKP1 = (K+2)*ERKP1 - IF(K.GT.1)GO TO 520 - IF(TERKP1.GE.0.5D0*TERK)GO TO 550 - GO TO 530 -520 IF(TERKM1.LE.MIN(TERK,TERKP1))GO TO 540 - IF(TERKP1.GE.TERK.OR.K.EQ.IWM(LMXORD))GO TO 550 -C -C Raise order -C -530 K=KP1 - EST = ERKP1 - GO TO 550 -C -C Lower order -C -540 K=KM1 - EST = ERKM1 - GO TO 550 -C -C If IPHASE = 0, increase order by one and multiply stepsize by -C factor two -C -545 K = KP1 - HNEW = H*2.0D0 - H = HNEW - GO TO 575 -C -C -C Determine the appropriate stepsize for -C the next step. -C -550 HNEW=H - TEMP2=K+1 - R=(2.0D0*EST+0.0001D0)**(-1.0D0/TEMP2) - IF(R .LT. 2.0D0) GO TO 555 - HNEW = 2.0D0*H - GO TO 560 -555 IF(R .GT. 1.0D0) GO TO 560 - R = MAX(0.5D0,MIN(0.9D0,R)) - HNEW = H*R -560 H=HNEW -C -C -C Update differences for next step -C -575 CONTINUE - IF(KOLD.EQ.IWM(LMXORD))GO TO 585 - DO 580 I=1,NEQ -580 PHI(I,KP2)=E(I) -585 CONTINUE - DO 590 I=1,NEQ -590 PHI(I,KP1)=PHI(I,KP1)+E(I) - DO 595 J1=2,KP1 - J=KP1-J1+1 - DO 595 I=1,NEQ -595 PHI(I,J)=PHI(I,J)+PHI(I,J+1) - JSTART = 1 - RETURN -C -C -C -C -C -C----------------------------------------------------------------------- -C BLOCK 6 -C The step is unsuccessful. Restore X,PSI,PHI -C Determine appropriate stepsize for -C continuing the integration, or exit with -C an error flag if there have been many -C failures. -C----------------------------------------------------------------------- -600 IPHASE = 1 -C -C Restore X,PHI,PSI -C - X=XOLD - IF(KP1.LT.NSP1)GO TO 630 - DO 620 J=NSP1,KP1 - TEMP1=1.0D0/BETA(J) - DO 610 I=1,NEQ -610 PHI(I,J)=TEMP1*PHI(I,J) -620 CONTINUE -630 CONTINUE - DO 640 I=2,KP1 -640 PSI(I-1)=PSI(I)-H -C -C -C Test whether failure is due to nonlinear solver -C or error test -C - IF(IERNLS .EQ. 0)GO TO 660 - IWM(LCFN)=IWM(LCFN)+1 -C -C -C The nonlinear solver failed to converge. -C Determine the cause of the failure and take appropriate action. -C If IERNLS .LT. 0, then return. Otherwise, reduce the stepsize -C and try again, unless too many failures have occurred. -C - IF (IERNLS .LT. 0) GO TO 675 - NCF = NCF + 1 - R = 0.25D0 - H = H*R - IF (NCF .LT. 10 .AND. ABS(H) .GE. HMIN) GO TO 690 - IF (IDID .EQ. 1) IDID = -7 - IF (NEF .GE. 3) IDID = -9 - GO TO 675 -C -C -C The nonlinear solver converged, and the cause -C of the failure was the error estimate -C exceeding the tolerance. -C -660 NEF=NEF+1 - IWM(LETF)=IWM(LETF)+1 - IF (NEF .GT. 1) GO TO 665 -C -C On first error test failure, keep current order or lower -C order by one. Compute new stepsize based on differences -C of the solution. -C - K = KNEW - TEMP2 = K + 1 - R = 0.90D0*(2.0D0*EST+0.0001D0)**(-1.0D0/TEMP2) - R = MAX(0.25D0,MIN(0.9D0,R)) - H = H*R - IF (ABS(H) .GE. HMIN) GO TO 690 - IDID = -6 - GO TO 675 -C -C On second error test failure, use the current order or -C decrease order by one. Reduce the stepsize by a factor of -C one quarter. -C -665 IF (NEF .GT. 2) GO TO 670 - K = KNEW - R = 0.25D0 - H = R*H - IF (ABS(H) .GE. HMIN) GO TO 690 - IDID = -6 - GO TO 675 -C -C On third and subsequent error test failures, set the order to -C one, and reduce the stepsize by a factor of one quarter. -C -670 K = 1 - R = 0.25D0 - H = R*H - IF (ABS(H) .GE. HMIN) GO TO 690 - IDID = -6 - GO TO 675 -C -C -C -C -C For all crashes, restore Y to its last value, -C interpolate to find YPRIME at last X, and return. -C -C Before returning, verify that the user has not set -C IDID to a nonnegative value. If the user has set IDID -C to a nonnegative value, then reset IDID to be -7, indicating -C a failure in the nonlinear system solver. -C -675 CONTINUE - CALL DDATRP(X,X,Y,YPRIME,NEQ,K,PHI,PSI) - JSTART = 1 - IF (IDID .GE. 0) IDID = -7 - RETURN -C -C -C Go back and try this step again. -C If this is the first step, reset PSI(1) and rescale PHI(*,2). -C -690 IF (KOLD .EQ. 0) THEN - PSI(1) = H - DO 695 I = 1,NEQ -695 PHI(I,2) = R*PHI(I,2) - ENDIF - GO TO 200 -C -C------END OF SUBROUTINE DDSTP------------------------------------------ - END
--- a/liboctave/cruft/daspk/ddwnrm.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,37 +0,0 @@ -C Work performed under the auspices of the U.S. Department of Energy -C by Lawrence Livermore National Laboratory under contract number -C W-7405-Eng-48. -C - DOUBLE PRECISION FUNCTION DDWNRM(NEQ,V,RWT,RPAR,IPAR) -C -C***BEGIN PROLOGUE DDWNRM -C***ROUTINES CALLED (NONE) -C***DATE WRITTEN 890101 (YYMMDD) -C***REVISION DATE 900926 (YYMMDD) -C***END PROLOGUE DDWNRM -C----------------------------------------------------------------------- -C This function routine computes the weighted -C root-mean-square norm of the vector of length -C NEQ contained in the array V, with reciprocal weights -C contained in the array RWT of length NEQ. -C DDWNRM=SQRT((1/NEQ)*SUM(V(I)*RWT(I))**2) -C----------------------------------------------------------------------- -C - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - DIMENSION V(*),RWT(*) - DIMENSION RPAR(*),IPAR(*) - DDWNRM = 0.0D0 - VMAX = 0.0D0 - DO 10 I = 1,NEQ - IF(ABS(V(I)*RWT(I)) .GT. VMAX) VMAX = ABS(V(I)*RWT(I)) -10 CONTINUE - IF(VMAX .LE. 0.0D0) GO TO 30 - SUM = 0.0D0 - DO 20 I = 1,NEQ -20 SUM = SUM + ((V(I)*RWT(I))/VMAX)**2 - DDWNRM = VMAX*SQRT(SUM/NEQ) -30 CONTINUE - RETURN -C -C------END OF FUNCTION DDWNRM------------------------------------------- - END
--- a/liboctave/cruft/daspk/dfnrmd.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,57 +0,0 @@ -C Work performed under the auspices of the U.S. Department of Energy -C by Lawrence Livermore National Laboratory under contract number -C W-7405-Eng-48. -C - SUBROUTINE DFNRMD (NEQ, Y, T, YPRIME, R, CJ, WT, RES, IRES, - * FNORM, WM, IWM, RPAR, IPAR) -C -C***BEGIN PROLOGUE DFNRMD -C***REFER TO DLINSD -C***DATE WRITTEN 941025 (YYMMDD) -C -C -C----------------------------------------------------------------------- -C***DESCRIPTION -C -C DFNRMD calculates the scaled preconditioned norm of the nonlinear -C function used in the nonlinear iteration for obtaining consistent -C initial conditions. Specifically, DFNRMD calculates the weighted -C root-mean-square norm of the vector (J-inverse)*G(T,Y,YPRIME), -C where J is the Jacobian matrix. -C -C In addition to the parameters described in the calling program -C DLINSD, the parameters represent -C -C R -- Array of length NEQ that contains -C (J-inverse)*G(T,Y,YPRIME) on return. -C FNORM -- Scalar containing the weighted norm of R on return. -C----------------------------------------------------------------------- -C -C***ROUTINES CALLED -C RES, DSLVD, DDWNRM -C -C***END PROLOGUE DFNRMD -C -C - IMPLICIT DOUBLE PRECISION (A-H,O-Z) - EXTERNAL RES - DIMENSION Y(*), YPRIME(*), WT(*), R(*) - DIMENSION WM(*),IWM(*), RPAR(*),IPAR(*) -C----------------------------------------------------------------------- -C Call RES routine. -C----------------------------------------------------------------------- - IRES = 0 - CALL RES(T,Y,YPRIME,CJ,R,IRES,RPAR,IPAR) - IF (IRES .LT. 0) RETURN -C----------------------------------------------------------------------- -C Apply inverse of Jacobian to vector R. -C----------------------------------------------------------------------- - CALL DSLVD(NEQ,R,WM,IWM) -C----------------------------------------------------------------------- -C Calculate norm of R. -C----------------------------------------------------------------------- - FNORM = DDWNRM(NEQ,R,WT,RPAR,IPAR) -C - RETURN -C----------------------- END OF SUBROUTINE DFNRMD ---------------------- - END
--- a/liboctave/cruft/daspk/dfnrmk.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,70 +0,0 @@ -C Work performed under the auspices of the U.S. Department of Energy -C by Lawrence Livermore National Laboratory under contract number -C W-7405-Eng-48. -C - SUBROUTINE DFNRMK (NEQ, Y, T, YPRIME, SAVR, R, CJ, WT, - * SQRTN, RSQRTN, RES, IRES, PSOL, IRIN, IER, - * FNORM, EPLIN, WP, IWP, PWK, RPAR, IPAR) -C -C***BEGIN PROLOGUE DFNRMK -C***REFER TO DLINSK -C***DATE WRITTEN 940830 (YYMMDD) -C***REVISION DATE 951006 (SQRTN, RSQRTN, and scaling of WT added.) -C -C -C----------------------------------------------------------------------- -C***DESCRIPTION -C -C DFNRMK calculates the scaled preconditioned norm of the nonlinear -C function used in the nonlinear iteration for obtaining consistent -C initial conditions. Specifically, DFNRMK calculates the weighted -C root-mean-square norm of the vector (P-inverse)*G(T,Y,YPRIME), -C where P is the preconditioner matrix. -C -C In addition to the parameters described in the calling program -C DLINSK, the parameters represent -C -C IRIN -- Flag showing whether the current residual vector is -C input in SAVR. 1 means it is, 0 means it is not. -C R -- Array of length NEQ that contains -C (P-inverse)*G(T,Y,YPRIME) on return. -C FNORM -- Scalar containing the weighted norm of R on return. -C----------------------------------------------------------------------- -C -C***ROUTINES CALLED -C RES, DCOPY, DSCAL, PSOL, DDWNRM -C -C***END PROLOGUE DFNRMK -C -C - IMPLICIT DOUBLE PRECISION (A-H,O-Z) - EXTERNAL RES, PSOL - DIMENSION Y(*), YPRIME(*), WT(*), SAVR(*), R(*), PWK(*) - DIMENSION WP(*), IWP(*), RPAR(*), IPAR(*) -C----------------------------------------------------------------------- -C Call RES routine if IRIN = 0. -C----------------------------------------------------------------------- - IF (IRIN .EQ. 0) THEN - IRES = 0 - CALL RES (T, Y, YPRIME, CJ, SAVR, IRES, RPAR, IPAR) - IF (IRES .LT. 0) RETURN - ENDIF -C----------------------------------------------------------------------- -C Apply inverse of left preconditioner to vector R. -C First scale WT array by 1/sqrt(N), and undo scaling afterward. -C----------------------------------------------------------------------- - CALL DCOPY(NEQ, SAVR, 1, R, 1) - CALL DSCAL (NEQ, RSQRTN, WT, 1) - IER = 0 - CALL PSOL (NEQ, T, Y, YPRIME, SAVR, PWK, CJ, WT, WP, IWP, - * R, EPLIN, IER, RPAR, IPAR) - CALL DSCAL (NEQ, SQRTN, WT, 1) - IF (IER .NE. 0) RETURN -C----------------------------------------------------------------------- -C Calculate norm of R. -C----------------------------------------------------------------------- - FNORM = DDWNRM (NEQ, R, WT, RPAR, IPAR) -C - RETURN -C----------------------- END OF SUBROUTINE DFNRMK ---------------------- - END
--- a/liboctave/cruft/daspk/dhels.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,88 +0,0 @@ -C Work performed under the auspices of the U.S. Department of Energy -C by Lawrence Livermore National Laboratory under contract number -C W-7405-Eng-48. -C - SUBROUTINE DHELS (A, LDA, N, Q, B) -C -C***BEGIN PROLOGUE DHELS -C***DATE WRITTEN 890101 (YYMMDD) -C***REVISION DATE 900926 (YYMMDD) -C -C -C----------------------------------------------------------------------- -C***DESCRIPTION -C -C This is similar to the LINPACK routine DGESL except that -C A is an upper Hessenberg matrix. -C -C DHELS solves the least squares problem -C -C MIN (B-A*X,B-A*X) -C -C using the factors computed by DHEQR. -C -C On entry -C -C A DOUBLE PRECISION (LDA, N) -C The output from DHEQR which contains the upper -C triangular factor R in the QR decomposition of A. -C -C LDA INTEGER -C The leading dimension of the array A . -C -C N INTEGER -C A is originally an (N+1) by N matrix. -C -C Q DOUBLE PRECISION(2*N) -C The coefficients of the N givens rotations -C used in the QR factorization of A. -C -C B DOUBLE PRECISION(N+1) -C The right hand side vector. -C -C -C On return -C -C B The solution vector X. -C -C -C Modification of LINPACK. -C Peter Brown, Lawrence Livermore Natl. Lab. -C -C----------------------------------------------------------------------- -C***ROUTINES CALLED -C DAXPY -C -C***END PROLOGUE DHELS -C - INTEGER LDA, N - DOUBLE PRECISION A(LDA,*), B(*), Q(*) - INTEGER IQ, K, KB, KP1 - DOUBLE PRECISION C, S, T, T1, T2 -C -C Minimize (B-A*X,B-A*X). -C First form Q*B. -C - DO 20 K = 1, N - KP1 = K + 1 - IQ = 2*(K-1) + 1 - C = Q(IQ) - S = Q(IQ+1) - T1 = B(K) - T2 = B(KP1) - B(K) = C*T1 - S*T2 - B(KP1) = S*T1 + C*T2 - 20 CONTINUE -C -C Now solve R*X = Q*B. -C - DO 40 KB = 1, N - K = N + 1 - KB - B(K) = B(K)/A(K,K) - T = -B(K) - CALL DAXPY (K-1, T, A(1,K), 1, B(1), 1) - 40 CONTINUE - RETURN -C -C------END OF SUBROUTINE DHELS------------------------------------------ - END
--- a/liboctave/cruft/daspk/dheqr.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,175 +0,0 @@ -C Work performed under the auspices of the U.S. Department of Energy -C by Lawrence Livermore National Laboratory under contract number -C W-7405-Eng-48. -C - SUBROUTINE DHEQR (A, LDA, N, Q, INFO, IJOB) -C -C***BEGIN PROLOGUE DHEQR -C***DATE WRITTEN 890101 (YYMMDD) -C***REVISION DATE 900926 (YYMMDD) -C -C----------------------------------------------------------------------- -C***DESCRIPTION -C -C This routine performs a QR decomposition of an upper -C Hessenberg matrix A. There are two options available: -C -C (1) performing a fresh decomposition -C (2) updating the QR factors by adding a row and A -C column to the matrix A. -C -C DHEQR decomposes an upper Hessenberg matrix by using Givens -C rotations. -C -C On entry -C -C A DOUBLE PRECISION(LDA, N) -C The matrix to be decomposed. -C -C LDA INTEGER -C The leading dimension of the array A. -C -C N INTEGER -C A is an (N+1) by N Hessenberg matrix. -C -C IJOB INTEGER -C = 1 Means that a fresh decomposition of the -C matrix A is desired. -C .GE. 2 Means that the current decomposition of A -C will be updated by the addition of a row -C and a column. -C On return -C -C A The upper triangular matrix R. -C The factorization can be written Q*A = R, where -C Q is a product of Givens rotations and R is upper -C triangular. -C -C Q DOUBLE PRECISION(2*N) -C The factors C and S of each Givens rotation used -C in decomposing A. -C -C INFO INTEGER -C = 0 normal value. -C = K If A(K,K) .EQ. 0.0. This is not an error -C condition for this subroutine, but it does -C indicate that DHELS will divide by zero -C if called. -C -C Modification of LINPACK. -C Peter Brown, Lawrence Livermore Natl. Lab. -C -C----------------------------------------------------------------------- -C***ROUTINES CALLED (NONE) -C -C***END PROLOGUE DHEQR -C - INTEGER LDA, N, INFO, IJOB - DOUBLE PRECISION A(LDA,*), Q(*) - INTEGER I, IQ, J, K, KM1, KP1, NM1 - DOUBLE PRECISION C, S, T, T1, T2 -C - IF (IJOB .GT. 1) GO TO 70 -C----------------------------------------------------------------------- -C A new factorization is desired. -C----------------------------------------------------------------------- -C -C QR decomposition without pivoting. -C - INFO = 0 - DO 60 K = 1, N - KM1 = K - 1 - KP1 = K + 1 -C -C Compute Kth column of R. -C First, multiply the Kth column of A by the previous -C K-1 Givens rotations. -C - IF (KM1 .LT. 1) GO TO 20 - DO 10 J = 1, KM1 - I = 2*(J-1) + 1 - T1 = A(J,K) - T2 = A(J+1,K) - C = Q(I) - S = Q(I+1) - A(J,K) = C*T1 - S*T2 - A(J+1,K) = S*T1 + C*T2 - 10 CONTINUE -C -C Compute Givens components C and S. -C - 20 CONTINUE - IQ = 2*KM1 + 1 - T1 = A(K,K) - T2 = A(KP1,K) - IF (T2 .NE. 0.0D0) GO TO 30 - C = 1.0D0 - S = 0.0D0 - GO TO 50 - 30 CONTINUE - IF (ABS(T2) .LT. ABS(T1)) GO TO 40 - T = T1/T2 - S = -1.0D0/SQRT(1.0D0+T*T) - C = -S*T - GO TO 50 - 40 CONTINUE - T = T2/T1 - C = 1.0D0/SQRT(1.0D0+T*T) - S = -C*T - 50 CONTINUE - Q(IQ) = C - Q(IQ+1) = S - A(K,K) = C*T1 - S*T2 - IF (A(K,K) .EQ. 0.0D0) INFO = K - 60 CONTINUE - RETURN -C----------------------------------------------------------------------- -C The old factorization of A will be updated. A row and a column -C has been added to the matrix A. -C N by N-1 is now the old size of the matrix. -C----------------------------------------------------------------------- - 70 CONTINUE - NM1 = N - 1 -C----------------------------------------------------------------------- -C Multiply the new column by the N previous Givens rotations. -C----------------------------------------------------------------------- - DO 100 K = 1,NM1 - I = 2*(K-1) + 1 - T1 = A(K,N) - T2 = A(K+1,N) - C = Q(I) - S = Q(I+1) - A(K,N) = C*T1 - S*T2 - A(K+1,N) = S*T1 + C*T2 - 100 CONTINUE -C----------------------------------------------------------------------- -C Complete update of decomposition by forming last Givens rotation, -C and multiplying it times the column vector (A(N,N),A(NP1,N)). -C----------------------------------------------------------------------- - INFO = 0 - T1 = A(N,N) - T2 = A(N+1,N) - IF (T2 .NE. 0.0D0) GO TO 110 - C = 1.0D0 - S = 0.0D0 - GO TO 130 - 110 CONTINUE - IF (ABS(T2) .LT. ABS(T1)) GO TO 120 - T = T1/T2 - S = -1.0D0/SQRT(1.0D0+T*T) - C = -S*T - GO TO 130 - 120 CONTINUE - T = T2/T1 - C = 1.0D0/SQRT(1.0D0+T*T) - S = -C*T - 130 CONTINUE - IQ = 2*N - 1 - Q(IQ) = C - Q(IQ+1) = S - A(N,N) = C*T1 - S*T2 - IF (A(N,N) .EQ. 0.0D0) INFO = N - RETURN -C -C------END OF SUBROUTINE DHEQR------------------------------------------ - END
--- a/liboctave/cruft/daspk/dinvwt.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,36 +0,0 @@ -C Work performed under the auspices of the U.S. Department of Energy -C by Lawrence Livermore National Laboratory under contract number -C W-7405-Eng-48. -C - SUBROUTINE DINVWT(NEQ,WT,IER) -C -C***BEGIN PROLOGUE DINVWT -C***REFER TO DDASPK -C***ROUTINES CALLED (NONE) -C***DATE WRITTEN 950125 (YYMMDD) -C***END PROLOGUE DINVWT -C----------------------------------------------------------------------- -C This subroutine checks the error weight vector WT, of length NEQ, -C for components that are .le. 0, and if none are found, it -C inverts the WT(I) in place. This replaces division operations -C with multiplications in all norm evaluations. -C IER is returned as 0 if all WT(I) were found positive, -C and the first I with WT(I) .le. 0.0 otherwise. -C----------------------------------------------------------------------- -C - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - DIMENSION WT(*) -C - DO 10 I = 1,NEQ - IF (WT(I) .LE. 0.0D0) GO TO 30 - 10 CONTINUE - DO 20 I = 1,NEQ - 20 WT(I) = 1.0D0/WT(I) - IER = 0 - RETURN -C - 30 IER = I - RETURN -C -C------END OF SUBROUTINE DINVWT----------------------------------------- - END
--- a/liboctave/cruft/daspk/dlinsd.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,182 +0,0 @@ -C Work performed under the auspices of the U.S. Department of Energy -C by Lawrence Livermore National Laboratory under contract number -C W-7405-Eng-48. -C - SUBROUTINE DLINSD (NEQ, Y, T, YPRIME, CJ, P, PNRM, WT, LSOFF, - * STPTOL, IRET, RES, IRES, WM, IWM, - * FNRM, ICOPT, ID, R, YNEW, YPNEW, ICNFLG, - * ICNSTR, RLX, RPAR, IPAR) -C -C***BEGIN PROLOGUE DLINSD -C***REFER TO DNSID -C***DATE WRITTEN 941025 (YYMMDD) -C***REVISION DATE 941215 (YYMMDD) -C***REVISION DATE 960129 Moved line RL = ONE to top block. -C -C -C----------------------------------------------------------------------- -C***DESCRIPTION -C -C DLINSD uses a linesearch algorithm to calculate a new (Y,YPRIME) -C pair (YNEW,YPNEW) such that -C -C f(YNEW,YPNEW) .le. (1 - 2*ALPHA*RL)*f(Y,YPRIME) , -C -C where 0 < RL <= 1. Here, f(y,y') is defined as -C -C f(y,y') = (1/2)*norm( (J-inverse)*G(t,y,y') )**2 , -C -C where norm() is the weighted RMS vector norm, G is the DAE -C system residual function, and J is the system iteration matrix -C (Jacobian). -C -C In addition to the parameters defined elsewhere, we have -C -C P -- Approximate Newton step used in backtracking. -C PNRM -- Weighted RMS norm of P. -C LSOFF -- Flag showing whether the linesearch algorithm is -C to be invoked. 0 means do the linesearch, and -C 1 means turn off linesearch. -C STPTOL -- Tolerance used in calculating the minimum lambda -C value allowed. -C ICNFLG -- Integer scalar. If nonzero, then constraint violations -C in the proposed new approximate solution will be -C checked for, and the maximum step length will be -C adjusted accordingly. -C ICNSTR -- Integer array of length NEQ containing flags for -C checking constraints. -C RLX -- Real scalar restricting update size in DCNSTR. -C YNEW -- Array of length NEQ used to hold the new Y in -C performing the linesearch. -C YPNEW -- Array of length NEQ used to hold the new YPRIME in -C performing the linesearch. -C Y -- Array of length NEQ containing the new Y (i.e.,=YNEW). -C YPRIME -- Array of length NEQ containing the new YPRIME -C (i.e.,=YPNEW). -C FNRM -- Real scalar containing SQRT(2*f(Y,YPRIME)) for the -C current (Y,YPRIME) on input and output. -C R -- Work array of length NEQ, containing the scaled -C residual (J-inverse)*G(t,y,y') on return. -C IRET -- Return flag. -C IRET=0 means that a satisfactory (Y,YPRIME) was found. -C IRET=1 means that the routine failed to find a new -C (Y,YPRIME) that was sufficiently distinct from -C the current (Y,YPRIME) pair. -C IRET=2 means IRES .ne. 0 from RES. -C----------------------------------------------------------------------- -C -C***ROUTINES CALLED -C DFNRMD, DYYPNW, DCOPY -C -C***END PROLOGUE DLINSD -C - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - EXTERNAL RES - DIMENSION Y(*), YPRIME(*), WT(*), R(*), ID(*) - DIMENSION WM(*), IWM(*) - DIMENSION YNEW(*), YPNEW(*), P(*), ICNSTR(*) - DIMENSION RPAR(*), IPAR(*) - CHARACTER MSG*80 -C - PARAMETER (LNRE=12, LKPRIN=31) -C - SAVE ALPHA, ONE, TWO - DATA ALPHA/1.0D-4/, ONE/1.0D0/, TWO/2.0D0/ -C - KPRIN=IWM(LKPRIN) -C - F1NRM = (FNRM*FNRM)/TWO - RATIO = ONE - IF (KPRIN .GE. 2) THEN - MSG = '------ IN ROUTINE DLINSD-- PNRM = (R1) )' - CALL XERRWD(MSG, 40, 901, 0, 0, 0, 0, 1, PNRM, 0.0D0) - ENDIF - TAU = PNRM - IVIO = 0 - RL = ONE -C----------------------------------------------------------------------- -C Check for violations of the constraints, if any are imposed. -C If any violations are found, the step vector P is rescaled, and the -C constraint check is repeated, until no violations are found. -C----------------------------------------------------------------------- - IF (ICNFLG .NE. 0) THEN - 10 CONTINUE - CALL DYYPNW (NEQ,Y,YPRIME,CJ,RL,P,ICOPT,ID,YNEW,YPNEW) - CALL DCNSTR (NEQ, Y, YNEW, ICNSTR, TAU, RLX, IRET, IVAR) - IF (IRET .EQ. 1) THEN - IVIO = 1 - RATIO1 = TAU/PNRM - RATIO = RATIO*RATIO1 - DO 20 I = 1,NEQ - 20 P(I) = P(I)*RATIO1 - PNRM = TAU - IF (KPRIN .GE. 2) THEN - MSG = '------ CONSTRAINT VIOL., PNRM = (R1), INDEX = (I1)' - CALL XERRWD(MSG, 50, 902, 0, 1, IVAR, 0, 1, PNRM, 0.0D0) - ENDIF - IF (PNRM .LE. STPTOL) THEN - IRET = 1 - RETURN - ENDIF - GO TO 10 - ENDIF - ENDIF -C - SLPI = (-TWO*F1NRM)*RATIO - RLMIN = STPTOL/PNRM - IF (LSOFF .EQ. 0 .AND. KPRIN .GE. 2) THEN - MSG = '------ MIN. LAMBDA = (R1)' - CALL XERRWD(MSG, 25, 903, 0, 0, 0, 0, 1, RLMIN, 0.0D0) - ENDIF -C----------------------------------------------------------------------- -C Begin iteration to find RL value satisfying alpha-condition. -C If RL becomes less than RLMIN, then terminate with IRET = 1. -C----------------------------------------------------------------------- - 100 CONTINUE - CALL DYYPNW (NEQ,Y,YPRIME,CJ,RL,P,ICOPT,ID,YNEW,YPNEW) - CALL DFNRMD (NEQ, YNEW, T, YPNEW, R, CJ, WT, RES, IRES, - * FNRMP, WM, IWM, RPAR, IPAR) - IWM(LNRE) = IWM(LNRE) + 1 - IF (IRES .NE. 0) THEN - IRET = 2 - RETURN - ENDIF - IF (LSOFF .EQ. 1) GO TO 150 -C - F1NRMP = FNRMP*FNRMP/TWO - IF (KPRIN .GE. 2) THEN - MSG = '------ LAMBDA = (R1)' - CALL XERRWD(MSG, 20, 904, 0, 0, 0, 0, 1, RL, 0.0D0) - MSG = '------ NORM(F1) = (R1), NORM(F1NEW) = (R2)' - CALL XERRWD(MSG, 43, 905, 0, 0, 0, 0, 2, F1NRM, F1NRMP) - ENDIF - IF (F1NRMP .GT. F1NRM + ALPHA*SLPI*RL) GO TO 200 -C----------------------------------------------------------------------- -C Alpha-condition is satisfied, or linesearch is turned off. -C Copy YNEW,YPNEW to Y,YPRIME and return. -C----------------------------------------------------------------------- - 150 IRET = 0 - CALL DCOPY (NEQ, YNEW, 1, Y, 1) - CALL DCOPY (NEQ, YPNEW, 1, YPRIME, 1) - FNRM = FNRMP - IF (KPRIN .GE. 1) THEN - MSG = '------ LEAVING ROUTINE DLINSD, FNRM = (R1)' - CALL XERRWD(MSG, 42, 906, 0, 0, 0, 0, 1, FNRM, 0.0D0) - ENDIF - RETURN -C----------------------------------------------------------------------- -C Alpha-condition not satisfied. Perform backtrack to compute new RL -C value. If no satisfactory YNEW,YPNEW can be found sufficiently -C distinct from Y,YPRIME, then return IRET = 1. -C----------------------------------------------------------------------- - 200 CONTINUE - IF (RL .LT. RLMIN) THEN - IRET = 1 - RETURN - ENDIF -C - RL = RL/TWO - GO TO 100 -C -C----------------------- END OF SUBROUTINE DLINSD ---------------------- - END
--- a/liboctave/cruft/daspk/dlinsk.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,189 +0,0 @@ -C Work performed under the auspices of the U.S. Department of Energy -C by Lawrence Livermore National Laboratory under contract number -C W-7405-Eng-48. -C - SUBROUTINE DLINSK (NEQ, Y, T, YPRIME, SAVR, CJ, P, PNRM, WT, - * SQRTN, RSQRTN, LSOFF, STPTOL, IRET, RES, IRES, PSOL, WM, IWM, - * RHOK, FNRM, ICOPT, ID, WP, IWP, R, EPLIN, YNEW, YPNEW, PWK, - * ICNFLG, ICNSTR, RLX, RPAR, IPAR) -C -C***BEGIN PROLOGUE DLINSK -C***REFER TO DNSIK -C***DATE WRITTEN 940830 (YYMMDD) -C***REVISION DATE 951006 (Arguments SQRTN, RSQRTN added.) -C***REVISION DATE 960129 Moved line RL = ONE to top block. -C -C -C----------------------------------------------------------------------- -C***DESCRIPTION -C -C DLINSK uses a linesearch algorithm to calculate a new (Y,YPRIME) -C pair (YNEW,YPNEW) such that -C -C f(YNEW,YPNEW) .le. (1 - 2*ALPHA*RL)*f(Y,YPRIME) + -C ALPHA*RL*RHOK*RHOK , -C -C where 0 < RL <= 1, and RHOK is the scaled preconditioned norm of -C the final residual vector in the Krylov iteration. -C Here, f(y,y') is defined as -C -C f(y,y') = (1/2)*norm( (P-inverse)*G(t,y,y') )**2 , -C -C where norm() is the weighted RMS vector norm, G is the DAE -C system residual function, and P is the preconditioner used -C in the Krylov iteration. -C -C In addition to the parameters defined elsewhere, we have -C -C SAVR -- Work array of length NEQ, containing the residual -C vector G(t,y,y') on return. -C P -- Approximate Newton step used in backtracking. -C PNRM -- Weighted RMS norm of P. -C LSOFF -- Flag showing whether the linesearch algorithm is -C to be invoked. 0 means do the linesearch, -C 1 means turn off linesearch. -C STPTOL -- Tolerance used in calculating the minimum lambda -C value allowed. -C ICNFLG -- Integer scalar. If nonzero, then constraint violations -C in the proposed new approximate solution will be -C checked for, and the maximum step length will be -C adjusted accordingly. -C ICNSTR -- Integer array of length NEQ containing flags for -C checking constraints. -C RHOK -- Weighted norm of preconditioned Krylov residual. -C RLX -- Real scalar restricting update size in DCNSTR. -C YNEW -- Array of length NEQ used to hold the new Y in -C performing the linesearch. -C YPNEW -- Array of length NEQ used to hold the new YPRIME in -C performing the linesearch. -C PWK -- Work vector of length NEQ for use in PSOL. -C Y -- Array of length NEQ containing the new Y (i.e.,=YNEW). -C YPRIME -- Array of length NEQ containing the new YPRIME -C (i.e.,=YPNEW). -C FNRM -- Real scalar containing SQRT(2*f(Y,YPRIME)) for the -C current (Y,YPRIME) on input and output. -C R -- Work space length NEQ for residual vector. -C IRET -- Return flag. -C IRET=0 means that a satisfactory (Y,YPRIME) was found. -C IRET=1 means that the routine failed to find a new -C (Y,YPRIME) that was sufficiently distinct from -C the current (Y,YPRIME) pair. -C IRET=2 means a failure in RES or PSOL. -C----------------------------------------------------------------------- -C -C***ROUTINES CALLED -C DFNRMK, DYYPNW, DCOPY -C -C***END PROLOGUE DLINSK -C - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - EXTERNAL RES, PSOL - DIMENSION Y(*), YPRIME(*), P(*), WT(*), SAVR(*), R(*), ID(*) - DIMENSION WM(*), IWM(*), YNEW(*), YPNEW(*), PWK(*), ICNSTR(*) - DIMENSION WP(*), IWP(*), RPAR(*), IPAR(*) - CHARACTER MSG*80 -C - PARAMETER (LNRE=12, LNPS=21, LKPRIN=31) -C - SAVE ALPHA, ONE, TWO - DATA ALPHA/1.0D-4/, ONE/1.0D0/, TWO/2.0D0/ -C - KPRIN=IWM(LKPRIN) - F1NRM = (FNRM*FNRM)/TWO - RATIO = ONE -C - IF (KPRIN .GE. 2) THEN - MSG = '------ IN ROUTINE DLINSK-- PNRM = (R1) )' - CALL XERRWD(MSG, 40, 921, 0, 0, 0, 0, 1, PNRM, 0.0D0) - ENDIF - TAU = PNRM - IVIO = 0 - RL = ONE -C----------------------------------------------------------------------- -C Check for violations of the constraints, if any are imposed. -C If any violations are found, the step vector P is rescaled, and the -C constraint check is repeated, until no violations are found. -C----------------------------------------------------------------------- - IF (ICNFLG .NE. 0) THEN - 10 CONTINUE - CALL DYYPNW (NEQ,Y,YPRIME,CJ,RL,P,ICOPT,ID,YNEW,YPNEW) - CALL DCNSTR (NEQ, Y, YNEW, ICNSTR, TAU, RLX, IRET, IVAR) - IF (IRET .EQ. 1) THEN - IVIO = 1 - RATIO1 = TAU/PNRM - RATIO = RATIO*RATIO1 - DO 20 I = 1,NEQ - 20 P(I) = P(I)*RATIO1 - PNRM = TAU - IF (KPRIN .GE. 2) THEN - MSG = '------ CONSTRAINT VIOL., PNRM = (R1), INDEX = (I1)' - CALL XERRWD(MSG, 50, 922, 0, 1, IVAR, 0, 1, PNRM, 0.0D0) - ENDIF - IF (PNRM .LE. STPTOL) THEN - IRET = 1 - RETURN - ENDIF - GO TO 10 - ENDIF - ENDIF -C - SLPI = (-TWO*F1NRM + RHOK*RHOK)*RATIO - RLMIN = STPTOL/PNRM - IF (LSOFF .EQ. 0 .AND. KPRIN .GE. 2) THEN - MSG = '------ MIN. LAMBDA = (R1)' - CALL XERRWD(MSG, 25, 923, 0, 0, 0, 0, 1, RLMIN, 0.0D0) - ENDIF -C----------------------------------------------------------------------- -C Begin iteration to find RL value satisfying alpha-condition. -C Update YNEW and YPNEW, then compute norm of new scaled residual and -C perform alpha condition test. -C----------------------------------------------------------------------- - 100 CONTINUE - CALL DYYPNW (NEQ,Y,YPRIME,CJ,RL,P,ICOPT,ID,YNEW,YPNEW) - CALL DFNRMK (NEQ, YNEW, T, YPNEW, SAVR, R, CJ, WT, SQRTN, RSQRTN, - * RES, IRES, PSOL, 0, IER, FNRMP, EPLIN, WP, IWP, PWK, RPAR, IPAR) - IWM(LNRE) = IWM(LNRE) + 1 - IF (IRES .GE. 0) IWM(LNPS) = IWM(LNPS) + 1 - IF (IRES .NE. 0 .OR. IER .NE. 0) THEN - IRET = 2 - RETURN - ENDIF - IF (LSOFF .EQ. 1) GO TO 150 -C - F1NRMP = FNRMP*FNRMP/TWO - IF (KPRIN .GE. 2) THEN - MSG = '------ LAMBDA = (R1)' - CALL XERRWD(MSG, 20, 924, 0, 0, 0, 0, 1, RL, 0.0D0) - MSG = '------ NORM(F1) = (R1), NORM(F1NEW) = (R2)' - CALL XERRWD(MSG, 43, 925, 0, 0, 0, 0, 2, F1NRM, F1NRMP) - ENDIF - IF (F1NRMP .GT. F1NRM + ALPHA*SLPI*RL) GO TO 200 -C----------------------------------------------------------------------- -C Alpha-condition is satisfied, or linesearch is turned off. -C Copy YNEW,YPNEW to Y,YPRIME and return. -C----------------------------------------------------------------------- - 150 IRET = 0 - CALL DCOPY(NEQ, YNEW, 1, Y, 1) - CALL DCOPY(NEQ, YPNEW, 1, YPRIME, 1) - FNRM = FNRMP - IF (KPRIN .GE. 1) THEN - MSG = '------ LEAVING ROUTINE DLINSK, FNRM = (R1)' - CALL XERRWD(MSG, 42, 926, 0, 0, 0, 0, 1, FNRM, 0.0D0) - ENDIF - RETURN -C----------------------------------------------------------------------- -C Alpha-condition not satisfied. Perform backtrack to compute new RL -C value. If RL is less than RLMIN, i.e. no satisfactory YNEW,YPNEW can -C be found sufficiently distinct from Y,YPRIME, then return IRET = 1. -C----------------------------------------------------------------------- - 200 CONTINUE - IF (RL .LT. RLMIN) THEN - IRET = 1 - RETURN - ENDIF -C - RL = RL/TWO - GO TO 100 -C -C----------------------- END OF SUBROUTINE DLINSK ---------------------- - END
--- a/liboctave/cruft/daspk/dmatd.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,183 +0,0 @@ -C Work performed under the auspices of the U.S. Department of Energy -C by Lawrence Livermore National Laboratory under contract number -C W-7405-Eng-48. -C - SUBROUTINE DMATD(NEQ,X,Y,YPRIME,DELTA,CJ,H,IER,EWT,E, - * WM,IWM,RES,IRES,UROUND,JACD,RPAR,IPAR) -C -C***BEGIN PROLOGUE DMATD -C***REFER TO DDASPK -C***DATE WRITTEN 890101 (YYMMDD) -C***REVISION DATE 900926 (YYMMDD) -C***REVISION DATE 940701 (YYMMDD) (new LIPVT) -C -C----------------------------------------------------------------------- -C***DESCRIPTION -C -C This routine computes the iteration matrix -C J = dG/dY+CJ*dG/dYPRIME (where G(X,Y,YPRIME)=0). -C Here J is computed by: -C the user-supplied routine JACD if IWM(MTYPE) is 1 or 4, or -C by numerical difference quotients if IWM(MTYPE) is 2 or 5. -C -C The parameters have the following meanings. -C X = Independent variable. -C Y = Array containing predicted values. -C YPRIME = Array containing predicted derivatives. -C DELTA = Residual evaluated at (X,Y,YPRIME). -C (Used only if IWM(MTYPE)=2 or 5). -C CJ = Scalar parameter defining iteration matrix. -C H = Current stepsize in integration. -C IER = Variable which is .NE. 0 if iteration matrix -C is singular, and 0 otherwise. -C EWT = Vector of error weights for computing norms. -C E = Work space (temporary) of length NEQ. -C WM = Real work space for matrices. On output -C it contains the LU decomposition -C of the iteration matrix. -C IWM = Integer work space containing -C matrix information. -C RES = External user-supplied subroutine -C to evaluate the residual. See RES description -C in DDASPK prologue. -C IRES = Flag which is equal to zero if no illegal values -C in RES, and less than zero otherwise. (If IRES -C is less than zero, the matrix was not completed). -C In this case (if IRES .LT. 0), then IER = 0. -C UROUND = The unit roundoff error of the machine being used. -C JACD = Name of the external user-supplied routine -C to evaluate the iteration matrix. (This routine -C is only used if IWM(MTYPE) is 1 or 4) -C See JAC description for the case INFO(12) = 0 -C in DDASPK prologue. -C RPAR,IPAR= Real and integer parameter arrays that -C are used for communication between the -C calling program and external user routines. -C They are not altered by DMATD. -C----------------------------------------------------------------------- -C***ROUTINES CALLED -C JACD, RES, DGETRF, DGBTRF -C -C***END PROLOGUE DMATD -C -C - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - DIMENSION Y(*),YPRIME(*),DELTA(*),EWT(*),E(*) - DIMENSION WM(*),IWM(*), RPAR(*),IPAR(*) - EXTERNAL RES, JACD -C - PARAMETER (LML=1, LMU=2, LMTYPE=4, LNRE=12, LNPD=22, LLCIWP=30) -C - LIPVT = IWM(LLCIWP) - IER = 0 - MTYPE=IWM(LMTYPE) - GO TO (100,200,300,400,500),MTYPE -C -C -C Dense user-supplied matrix. -C -100 LENPD=IWM(LNPD) - DO 110 I=1,LENPD -110 WM(I)=0.0D0 - CALL JACD(X,Y,YPRIME,WM,CJ,RPAR,IPAR) - GO TO 230 -C -C -C Dense finite-difference-generated matrix. -C -200 IRES=0 - NROW=0 - SQUR = SQRT(UROUND) - DO 210 I=1,NEQ - DEL=SQUR*MAX(ABS(Y(I)),ABS(H*YPRIME(I)), - * ABS(1.D0/EWT(I))) - DEL=SIGN(DEL,H*YPRIME(I)) - DEL=(Y(I)+DEL)-Y(I) - YSAVE=Y(I) - YPSAVE=YPRIME(I) - Y(I)=Y(I)+DEL - YPRIME(I)=YPRIME(I)+CJ*DEL - IWM(LNRE)=IWM(LNRE)+1 - CALL RES(X,Y,YPRIME,CJ,E,IRES,RPAR,IPAR) - IF (IRES .LT. 0) RETURN - DELINV=1.0D0/DEL - DO 220 L=1,NEQ -220 WM(NROW+L)=(E(L)-DELTA(L))*DELINV - NROW=NROW+NEQ - Y(I)=YSAVE - YPRIME(I)=YPSAVE -210 CONTINUE -C -C -C Do dense-matrix LU decomposition on J. -C -230 CALL DGETRF( NEQ, NEQ, WM, NEQ, IWM(LIPVT), IER) - RETURN -C -C -C Dummy section for IWM(MTYPE)=3. -C -300 RETURN -C -C -C Banded user-supplied matrix. -C -400 LENPD=IWM(LNPD) - DO 410 I=1,LENPD -410 WM(I)=0.0D0 - CALL JACD(X,Y,YPRIME,WM,CJ,RPAR,IPAR) - MEBAND=2*IWM(LML)+IWM(LMU)+1 - GO TO 550 -C -C -C Banded finite-difference-generated matrix. -C -500 MBAND=IWM(LML)+IWM(LMU)+1 - MBA=MIN0(MBAND,NEQ) - MEBAND=MBAND+IWM(LML) - MEB1=MEBAND-1 - MSAVE=(NEQ/MBAND)+1 - ISAVE=IWM(LNPD) - IPSAVE=ISAVE+MSAVE - IRES=0 - SQUR=SQRT(UROUND) - DO 540 J=1,MBA - DO 510 N=J,NEQ,MBAND - K= (N-J)/MBAND + 1 - WM(ISAVE+K)=Y(N) - WM(IPSAVE+K)=YPRIME(N) - DEL=SQUR*MAX(ABS(Y(N)),ABS(H*YPRIME(N)), - * ABS(1.D0/EWT(N))) - DEL=SIGN(DEL,H*YPRIME(N)) - DEL=(Y(N)+DEL)-Y(N) - Y(N)=Y(N)+DEL -510 YPRIME(N)=YPRIME(N)+CJ*DEL - IWM(LNRE)=IWM(LNRE)+1 - CALL RES(X,Y,YPRIME,CJ,E,IRES,RPAR,IPAR) - IF (IRES .LT. 0) RETURN - DO 530 N=J,NEQ,MBAND - K= (N-J)/MBAND + 1 - Y(N)=WM(ISAVE+K) - YPRIME(N)=WM(IPSAVE+K) - DEL=SQUR*MAX(ABS(Y(N)),ABS(H*YPRIME(N)), - * ABS(1.D0/EWT(N))) - DEL=SIGN(DEL,H*YPRIME(N)) - DEL=(Y(N)+DEL)-Y(N) - DELINV=1.0D0/DEL - I1=MAX0(1,(N-IWM(LMU))) - I2=MIN0(NEQ,(N+IWM(LML))) - II=N*MEB1-IWM(LML) - DO 520 I=I1,I2 -520 WM(II+I)=(E(I)-DELTA(I))*DELINV -530 CONTINUE -540 CONTINUE -C -C -C Do LU decomposition of banded J. -C -550 CALL DGBTRF(NEQ, NEQ, IWM(LML), IWM(LMU), WM, MEBAND, - * IWM(LIPVT), IER) - RETURN -C -C------END OF SUBROUTINE DMATD------------------------------------------ - END
--- a/liboctave/cruft/daspk/dnedd.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,270 +0,0 @@ -C Work performed under the auspices of the U.S. Department of Energy -C by Lawrence Livermore National Laboratory under contract number -C W-7405-Eng-48. -C - SUBROUTINE DNEDD(X,Y,YPRIME,NEQ,RES,JACD,PDUM,H,WT, - * JSTART,IDID,RPAR,IPAR,PHI,GAMMA,DUMSVR,DELTA,E, - * WM,IWM,CJ,CJOLD,CJLAST,S,UROUND,DUME,DUMS,DUMR, - * EPCON,JCALC,JFDUM,KP1,NONNEG,NTYPE,IERNLS) -C -C***BEGIN PROLOGUE DNEDD -C***REFER TO DDASPK -C***DATE WRITTEN 891219 (YYMMDD) -C***REVISION DATE 900926 (YYMMDD) -C -C -C----------------------------------------------------------------------- -C***DESCRIPTION -C -C DNEDD solves a nonlinear system of -C algebraic equations of the form -C G(X,Y,YPRIME) = 0 for the unknown Y. -C -C The method used is a modified Newton scheme. -C -C The parameters represent -C -C X -- Independent variable. -C Y -- Solution vector. -C YPRIME -- Derivative of solution vector. -C NEQ -- Number of unknowns. -C RES -- External user-supplied subroutine -C to evaluate the residual. See RES description -C in DDASPK prologue. -C JACD -- External user-supplied routine to evaluate the -C Jacobian. See JAC description for the case -C INFO(12) = 0 in the DDASPK prologue. -C PDUM -- Dummy argument. -C H -- Appropriate step size for next step. -C WT -- Vector of weights for error criterion. -C JSTART -- Indicates first call to this routine. -C If JSTART = 0, then this is the first call, -C otherwise it is not. -C IDID -- Completion flag, output by DNEDD. -C See IDID description in DDASPK prologue. -C RPAR,IPAR -- Real and integer arrays used for communication -C between the calling program and external user -C routines. They are not altered within DASPK. -C PHI -- Array of divided differences used by -C DNEDD. The length is NEQ*(K+1),where -C K is the maximum order. -C GAMMA -- Array used to predict Y and YPRIME. The length -C is MAXORD+1 where MAXORD is the maximum order. -C DUMSVR -- Dummy argument. -C DELTA -- Work vector for NLS of length NEQ. -C E -- Error accumulation vector for NLS of length NEQ. -C WM,IWM -- Real and integer arrays storing -C matrix information such as the matrix -C of partial derivatives, permutation -C vector, and various other information. -C CJ -- Parameter always proportional to 1/H. -C CJOLD -- Saves the value of CJ as of the last call to DMATD. -C Accounts for changes in CJ needed to -C decide whether to call DMATD. -C CJLAST -- Previous value of CJ. -C S -- A scalar determined by the approximate rate -C of convergence of the Newton iteration and used -C in the convergence test for the Newton iteration. -C -C If RATE is defined to be an estimate of the -C rate of convergence of the Newton iteration, -C then S = RATE/(1.D0-RATE). -C -C The closer RATE is to 0., the faster the Newton -C iteration is converging; the closer RATE is to 1., -C the slower the Newton iteration is converging. -C -C On the first Newton iteration with an up-dated -C preconditioner S = 100.D0, Thus the initial -C RATE of convergence is approximately 1. -C -C S is preserved from call to call so that the rate -C estimate from a previous step can be applied to -C the current step. -C UROUND -- Unit roundoff. -C DUME -- Dummy argument. -C DUMS -- Dummy argument. -C DUMR -- Dummy argument. -C EPCON -- Tolerance to test for convergence of the Newton -C iteration. -C JCALC -- Flag used to determine when to update -C the Jacobian matrix. In general: -C -C JCALC = -1 ==> Call the DMATD routine to update -C the Jacobian matrix. -C JCALC = 0 ==> Jacobian matrix is up-to-date. -C JCALC = 1 ==> Jacobian matrix is out-dated, -C but DMATD will not be called unless -C JCALC is set to -1. -C JFDUM -- Dummy argument. -C KP1 -- The current order(K) + 1; updated across calls. -C NONNEG -- Flag to determine nonnegativity constraints. -C NTYPE -- Identification code for the NLS routine. -C 0 ==> modified Newton; direct solver. -C IERNLS -- Error flag for nonlinear solver. -C 0 ==> nonlinear solver converged. -C 1 ==> recoverable error inside nonlinear solver. -C -1 ==> unrecoverable error inside nonlinear solver. -C -C All variables with "DUM" in their names are dummy variables -C which are not used in this routine. -C -C Following is a list and description of local variables which -C may not have an obvious usage. They are listed in roughly the -C order they occur in this subroutine. -C -C The following group of variables are passed as arguments to -C the Newton iteration solver. They are explained in greater detail -C in DNSD: -C TOLNEW, MULDEL, MAXIT, IERNEW -C -C IERTYP -- Flag which tells whether this subroutine is correct. -C 0 ==> correct subroutine. -C 1 ==> incorrect subroutine. -C -C----------------------------------------------------------------------- -C***ROUTINES CALLED -C DDWNRM, RES, DMATD, DNSD -C -C***END PROLOGUE DNEDD -C -C - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - DIMENSION Y(*),YPRIME(*),WT(*) - DIMENSION DELTA(*),E(*) - DIMENSION WM(*),IWM(*), RPAR(*),IPAR(*) - DIMENSION PHI(NEQ,*),GAMMA(*) - EXTERNAL RES, JACD -C - PARAMETER (LNRE=12, LNJE=13) -C - SAVE MULDEL, MAXIT, XRATE - DATA MULDEL/1/, MAXIT/4/, XRATE/0.25D0/ -C -C Verify that this is the correct subroutine. -C - IERTYP = 0 - IF (NTYPE .NE. 0) THEN - IERTYP = 1 - GO TO 380 - ENDIF -C -C If this is the first step, perform initializations. -C - IF (JSTART .EQ. 0) THEN - CJOLD = CJ - JCALC = -1 - ENDIF -C -C Perform all other initializations. -C - IERNLS = 0 -C -C Decide whether new Jacobian is needed. -C - TEMP1 = (1.0D0 - XRATE)/(1.0D0 + XRATE) - TEMP2 = 1.0D0/TEMP1 - IF (CJ/CJOLD .LT. TEMP1 .OR. CJ/CJOLD .GT. TEMP2) JCALC = -1 - IF (CJ .NE. CJLAST) S = 100.D0 -C -C----------------------------------------------------------------------- -C Entry point for updating the Jacobian with current -C stepsize. -C----------------------------------------------------------------------- -300 CONTINUE -C -C Initialize all error flags to zero. -C - IERJ = 0 - IRES = 0 - IERNEW = 0 -C -C Predict the solution and derivative and compute the tolerance -C for the Newton iteration. -C - DO 310 I=1,NEQ - Y(I)=PHI(I,1) -310 YPRIME(I)=0.0D0 - DO 330 J=2,KP1 - DO 320 I=1,NEQ - Y(I)=Y(I)+PHI(I,J) -320 YPRIME(I)=YPRIME(I)+GAMMA(J)*PHI(I,J) -330 CONTINUE - PNORM = DDWNRM (NEQ,Y,WT,RPAR,IPAR) - TOLNEW = 100.D0*UROUND*PNORM -C -C Call RES to initialize DELTA. -C - IWM(LNRE)=IWM(LNRE)+1 - CALL RES(X,Y,YPRIME,CJ,DELTA,IRES,RPAR,IPAR) - IF (IRES .LT. 0) GO TO 380 -C -C If indicated, reevaluate the iteration matrix -C J = dG/dY + CJ*dG/dYPRIME (where G(X,Y,YPRIME)=0). -C Set JCALC to 0 as an indicator that this has been done. -C - IF(JCALC .EQ. -1) THEN - IWM(LNJE)=IWM(LNJE)+1 - JCALC=0 - CALL DMATD(NEQ,X,Y,YPRIME,DELTA,CJ,H,IERJ,WT,E,WM,IWM, - * RES,IRES,UROUND,JACD,RPAR,IPAR) - CJOLD=CJ - S = 100.D0 - IF (IRES .LT. 0) GO TO 380 - IF(IERJ .NE. 0)GO TO 380 - ENDIF -C -C Call the nonlinear Newton solver. -C - TEMP1 = 2.0D0/(1.0D0 + CJ/CJOLD) - CALL DNSD(X,Y,YPRIME,NEQ,RES,PDUM,WT,RPAR,IPAR,DUMSVR, - * DELTA,E,WM,IWM,CJ,DUMS,DUMR,DUME,EPCON,S,TEMP1, - * TOLNEW,MULDEL,MAXIT,IRES,IDUM,IERNEW) -C - IF (IERNEW .GT. 0 .AND. JCALC .NE. 0) THEN -C -C The Newton iteration had a recoverable failure with an old -C iteration matrix. Retry the step with a new iteration matrix. -C - JCALC = -1 - GO TO 300 - ENDIF -C - IF (IERNEW .NE. 0) GO TO 380 -C -C The Newton iteration has converged. If nonnegativity of -C solution is required, set the solution nonnegative, if the -C perturbation to do it is small enough. If the change is too -C large, then consider the corrector iteration to have failed. -C -375 IF(NONNEG .EQ. 0) GO TO 390 - DO 377 I = 1,NEQ -377 DELTA(I) = MIN(Y(I),0.0D0) - DELNRM = DDWNRM(NEQ,DELTA,WT,RPAR,IPAR) - IF(DELNRM .GT. EPCON) GO TO 380 - DO 378 I = 1,NEQ -378 E(I) = E(I) - DELTA(I) - GO TO 390 -C -C -C Exits from nonlinear solver. -C No convergence with current iteration -C matrix, or singular iteration matrix. -C Compute IERNLS and IDID accordingly. -C -380 CONTINUE - IF (IRES .LE. -2 .OR. IERTYP .NE. 0) THEN - IERNLS = -1 - IF (IRES .LE. -2) IDID = -11 - IF (IERTYP .NE. 0) IDID = -15 - ELSE - IERNLS = 1 - IF (IRES .LT. 0) IDID = -10 - IF (IERJ .NE. 0) IDID = -8 - ENDIF -C -390 JCALC = 1 - RETURN -C -C------END OF SUBROUTINE DNEDD------------------------------------------ - END
--- a/liboctave/cruft/daspk/dnedk.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,275 +0,0 @@ -C Work performed under the auspices of the U.S. Department of Energy -C by Lawrence Livermore National Laboratory under contract number -C W-7405-Eng-48. -C - SUBROUTINE DNEDK(X,Y,YPRIME,NEQ,RES,JACK,PSOL, - * H,WT,JSTART,IDID,RPAR,IPAR,PHI,GAMMA,SAVR,DELTA,E, - * WM,IWM,CJ,CJOLD,CJLAST,S,UROUND,EPLI,SQRTN,RSQRTN, - * EPCON,JCALC,JFLG,KP1,NONNEG,NTYPE,IERNLS) -C -C***BEGIN PROLOGUE DNEDK -C***REFER TO DDASPK -C***DATE WRITTEN 891219 (YYMMDD) -C***REVISION DATE 900926 (YYMMDD) -C***REVISION DATE 940701 (YYMMDD) -C -C -C----------------------------------------------------------------------- -C***DESCRIPTION -C -C DNEDK solves a nonlinear system of -C algebraic equations of the form -C G(X,Y,YPRIME) = 0 for the unknown Y. -C -C The method used is a matrix-free Newton scheme. -C -C The parameters represent -C X -- Independent variable. -C Y -- Solution vector at x. -C YPRIME -- Derivative of solution vector -C after successful step. -C NEQ -- Number of equations to be integrated. -C RES -- External user-supplied subroutine -C to evaluate the residual. See RES description -C in DDASPK prologue. -C JACK -- External user-supplied routine to update -C the preconditioner. (This is optional). -C See JAC description for the case -C INFO(12) = 1 in the DDASPK prologue. -C PSOL -- External user-supplied routine to solve -C a linear system using preconditioning. -C (This is optional). See explanation inside DDASPK. -C H -- Appropriate step size for this step. -C WT -- Vector of weights for error criterion. -C JSTART -- Indicates first call to this routine. -C If JSTART = 0, then this is the first call, -C otherwise it is not. -C IDID -- Completion flag, output by DNEDK. -C See IDID description in DDASPK prologue. -C RPAR,IPAR -- Real and integer arrays used for communication -C between the calling program and external user -C routines. They are not altered within DASPK. -C PHI -- Array of divided differences used by -C DNEDK. The length is NEQ*(K+1), where -C K is the maximum order. -C GAMMA -- Array used to predict Y and YPRIME. The length -C is K+1, where K is the maximum order. -C SAVR -- Work vector for DNEDK of length NEQ. -C DELTA -- Work vector for DNEDK of length NEQ. -C E -- Error accumulation vector for DNEDK of length NEQ. -C WM,IWM -- Real and integer arrays storing -C matrix information for linear system -C solvers, and various other information. -C CJ -- Parameter always proportional to 1/H. -C CJOLD -- Saves the value of CJ as of the last call to DITMD. -C Accounts for changes in CJ needed to -C decide whether to call DITMD. -C CJLAST -- Previous value of CJ. -C S -- A scalar determined by the approximate rate -C of convergence of the Newton iteration and used -C in the convergence test for the Newton iteration. -C -C If RATE is defined to be an estimate of the -C rate of convergence of the Newton iteration, -C then S = RATE/(1.D0-RATE). -C -C The closer RATE is to 0., the faster the Newton -C iteration is converging; the closer RATE is to 1., -C the slower the Newton iteration is converging. -C -C On the first Newton iteration with an up-dated -C preconditioner S = 100.D0, Thus the initial -C RATE of convergence is approximately 1. -C -C S is preserved from call to call so that the rate -C estimate from a previous step can be applied to -C the current step. -C UROUND -- Unit roundoff. -C EPLI -- convergence test constant. -C See DDASPK prologue for more details. -C SQRTN -- Square root of NEQ. -C RSQRTN -- reciprical of square root of NEQ. -C EPCON -- Tolerance to test for convergence of the Newton -C iteration. -C JCALC -- Flag used to determine when to update -C the Jacobian matrix. In general: -C -C JCALC = -1 ==> Call the DITMD routine to update -C the Jacobian matrix. -C JCALC = 0 ==> Jacobian matrix is up-to-date. -C JCALC = 1 ==> Jacobian matrix is out-dated, -C but DITMD will not be called unless -C JCALC is set to -1. -C JFLG -- Flag showing whether a Jacobian routine is supplied. -C KP1 -- The current order + 1; updated across calls. -C NONNEG -- Flag to determine nonnegativity constraints. -C NTYPE -- Identification code for the DNEDK routine. -C 1 ==> modified Newton; iterative linear solver. -C 2 ==> modified Newton; user-supplied linear solver. -C IERNLS -- Error flag for nonlinear solver. -C 0 ==> nonlinear solver converged. -C 1 ==> recoverable error inside non-linear solver. -C -1 ==> unrecoverable error inside non-linear solver. -C -C The following group of variables are passed as arguments to -C the Newton iteration solver. They are explained in greater detail -C in DNSK: -C TOLNEW, MULDEL, MAXIT, IERNEW -C -C IERTYP -- Flag which tells whether this subroutine is correct. -C 0 ==> correct subroutine. -C 1 ==> incorrect subroutine. -C -C----------------------------------------------------------------------- -C***ROUTINES CALLED -C RES, JACK, DDWNRM, DNSK -C -C***END PROLOGUE DNEDK -C -C - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - DIMENSION Y(*),YPRIME(*),WT(*) - DIMENSION PHI(NEQ,*),SAVR(*),DELTA(*),E(*) - DIMENSION WM(*),IWM(*) - DIMENSION GAMMA(*),RPAR(*),IPAR(*) - EXTERNAL RES, JACK, PSOL -C - PARAMETER (LNRE=12, LNJE=13, LLOCWP=29, LLCIWP=30) -C - SAVE MULDEL, MAXIT, XRATE - DATA MULDEL/0/, MAXIT/4/, XRATE/0.25D0/ -C -C Verify that this is the correct subroutine. -C - IERTYP = 0 - IF (NTYPE .NE. 1) THEN - IERTYP = 1 - GO TO 380 - ENDIF -C -C If this is the first step, perform initializations. -C - IF (JSTART .EQ. 0) THEN - CJOLD = CJ - JCALC = -1 - S = 100.D0 - ENDIF -C -C Perform all other initializations. -C - IERNLS = 0 - LWP = IWM(LLOCWP) - LIWP = IWM(LLCIWP) -C -C Decide whether to update the preconditioner. -C - IF (JFLG .NE. 0) THEN - TEMP1 = (1.0D0 - XRATE)/(1.0D0 + XRATE) - TEMP2 = 1.0D0/TEMP1 - IF (CJ/CJOLD .LT. TEMP1 .OR. CJ/CJOLD .GT. TEMP2) JCALC = -1 - IF (CJ .NE. CJLAST) S = 100.D0 - ELSE - JCALC = 0 - ENDIF -C -C Looping point for updating preconditioner with current stepsize. -C -300 CONTINUE -C -C Initialize all error flags to zero. -C - IERPJ = 0 - IRES = 0 - IERSL = 0 - IERNEW = 0 -C -C Predict the solution and derivative and compute the tolerance -C for the Newton iteration. -C - DO 310 I=1,NEQ - Y(I)=PHI(I,1) -310 YPRIME(I)=0.0D0 - DO 330 J=2,KP1 - DO 320 I=1,NEQ - Y(I)=Y(I)+PHI(I,J) -320 YPRIME(I)=YPRIME(I)+GAMMA(J)*PHI(I,J) -330 CONTINUE - EPLIN = EPLI*EPCON - TOLNEW = EPLIN -C -C Call RES to initialize DELTA. -C - IWM(LNRE)=IWM(LNRE)+1 - CALL RES(X,Y,YPRIME,CJ,DELTA,IRES,RPAR,IPAR) - IF (IRES .LT. 0) GO TO 380 -C -C -C If indicated, update the preconditioner. -C Set JCALC to 0 as an indicator that this has been done. -C - IF(JCALC .EQ. -1)THEN - IWM(LNJE) = IWM(LNJE) + 1 - JCALC=0 - CALL JACK (RES, IRES, NEQ, X, Y, YPRIME, WT, DELTA, E, H, CJ, - * WM(LWP), IWM(LIWP), IERPJ, RPAR, IPAR) - CJOLD=CJ - S = 100.D0 - IF (IRES .LT. 0) GO TO 380 - IF (IERPJ .NE. 0) GO TO 380 - ENDIF -C -C Call the nonlinear Newton solver. -C - CALL DNSK(X,Y,YPRIME,NEQ,RES,PSOL,WT,RPAR,IPAR,SAVR, - * DELTA,E,WM,IWM,CJ,SQRTN,RSQRTN,EPLIN,EPCON, - * S,TEMP1,TOLNEW,MULDEL,MAXIT,IRES,IERSL,IERNEW) -C - IF (IERNEW .GT. 0 .AND. JCALC .NE. 0) THEN -C -C The Newton iteration had a recoverable failure with an old -C preconditioner. Retry the step with a new preconditioner. -C - JCALC = -1 - GO TO 300 - ENDIF -C - IF (IERNEW .NE. 0) GO TO 380 -C -C The Newton iteration has converged. If nonnegativity of -C solution is required, set the solution nonnegative, if the -C perturbation to do it is small enough. If the change is too -C large, then consider the corrector iteration to have failed. -C - IF(NONNEG .EQ. 0) GO TO 390 - DO 360 I = 1,NEQ - 360 DELTA(I) = MIN(Y(I),0.0D0) - DELNRM = DDWNRM(NEQ,DELTA,WT,RPAR,IPAR) - IF(DELNRM .GT. EPCON) GO TO 380 - DO 370 I = 1,NEQ - 370 E(I) = E(I) - DELTA(I) - GO TO 390 -C -C -C Exits from nonlinear solver. -C No convergence with current preconditioner. -C Compute IERNLS and IDID accordingly. -C -380 CONTINUE - IF (IRES .LE. -2 .OR. IERSL .LT. 0 .OR. IERTYP .NE. 0) THEN - IERNLS = -1 - IF (IRES .LE. -2) IDID = -11 - IF (IERSL .LT. 0) IDID = -13 - IF (IERTYP .NE. 0) IDID = -15 - ELSE - IERNLS = 1 - IF (IRES .EQ. -1) IDID = -10 - IF (IERPJ .NE. 0) IDID = -5 - IF (IERSL .GT. 0) IDID = -14 - ENDIF -C -C -390 JCALC = 1 - RETURN -C -C------END OF SUBROUTINE DNEDK------------------------------------------ - END
--- a/liboctave/cruft/daspk/dnsd.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,168 +0,0 @@ -C Work performed under the auspices of the U.S. Department of Energy -C by Lawrence Livermore National Laboratory under contract number -C W-7405-Eng-48. -C - SUBROUTINE DNSD(X,Y,YPRIME,NEQ,RES,PDUM,WT,RPAR,IPAR, - * DUMSVR,DELTA,E,WM,IWM,CJ,DUMS,DUMR,DUME,EPCON, - * S,CONFAC,TOLNEW,MULDEL,MAXIT,IRES,IDUM,IERNEW) -C -C***BEGIN PROLOGUE DNSD -C***REFER TO DDASPK -C***DATE WRITTEN 891219 (YYMMDD) -C***REVISION DATE 900926 (YYMMDD) -C***REVISION DATE 950126 (YYMMDD) -C -C -C----------------------------------------------------------------------- -C***DESCRIPTION -C -C DNSD solves a nonlinear system of -C algebraic equations of the form -C G(X,Y,YPRIME) = 0 for the unknown Y. -C -C The method used is a modified Newton scheme. -C -C The parameters represent -C -C X -- Independent variable. -C Y -- Solution vector. -C YPRIME -- Derivative of solution vector. -C NEQ -- Number of unknowns. -C RES -- External user-supplied subroutine -C to evaluate the residual. See RES description -C in DDASPK prologue. -C PDUM -- Dummy argument. -C WT -- Vector of weights for error criterion. -C RPAR,IPAR -- Real and integer arrays used for communication -C between the calling program and external user -C routines. They are not altered within DASPK. -C DUMSVR -- Dummy argument. -C DELTA -- Work vector for DNSD of length NEQ. -C E -- Error accumulation vector for DNSD of length NEQ. -C WM,IWM -- Real and integer arrays storing -C matrix information such as the matrix -C of partial derivatives, permutation -C vector, and various other information. -C CJ -- Parameter always proportional to 1/H (step size). -C DUMS -- Dummy argument. -C DUMR -- Dummy argument. -C DUME -- Dummy argument. -C EPCON -- Tolerance to test for convergence of the Newton -C iteration. -C S -- Used for error convergence tests. -C In the Newton iteration: S = RATE/(1 - RATE), -C where RATE is the estimated rate of convergence -C of the Newton iteration. -C The calling routine passes the initial value -C of S to the Newton iteration. -C CONFAC -- A residual scale factor to improve convergence. -C TOLNEW -- Tolerance on the norm of Newton correction in -C alternative Newton convergence test. -C MULDEL -- A flag indicating whether or not to multiply -C DELTA by CONFAC. -C 0 ==> do not scale DELTA by CONFAC. -C 1 ==> scale DELTA by CONFAC. -C MAXIT -- Maximum allowed number of Newton iterations. -C IRES -- Error flag returned from RES. See RES description -C in DDASPK prologue. If IRES = -1, then IERNEW -C will be set to 1. -C If IRES < -1, then IERNEW will be set to -1. -C IDUM -- Dummy argument. -C IERNEW -- Error flag for Newton iteration. -C 0 ==> Newton iteration converged. -C 1 ==> recoverable error inside Newton iteration. -C -1 ==> unrecoverable error inside Newton iteration. -C -C All arguments with "DUM" in their names are dummy arguments -C which are not used in this routine. -C----------------------------------------------------------------------- -C -C***ROUTINES CALLED -C DSLVD, DDWNRM, RES -C -C***END PROLOGUE DNSD -C -C - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - DIMENSION Y(*),YPRIME(*),WT(*),DELTA(*),E(*) - DIMENSION WM(*),IWM(*), RPAR(*),IPAR(*) - EXTERNAL RES -C - PARAMETER (LNRE=12, LNNI=19) -C -C Initialize Newton counter M and accumulation vector E. -C - M = 0 - DO 100 I=1,NEQ -100 E(I)=0.0D0 -C -C Corrector loop. -C -300 CONTINUE - IWM(LNNI) = IWM(LNNI) + 1 -C -C If necessary, multiply residual by convergence factor. -C - IF (MULDEL .EQ. 1) THEN - DO 320 I = 1,NEQ -320 DELTA(I) = DELTA(I) * CONFAC - ENDIF -C -C Compute a new iterate (back-substitution). -C Store the correction in DELTA. -C - CALL DSLVD(NEQ,DELTA,WM,IWM) -C -C Update Y, E, and YPRIME. -C - DO 340 I=1,NEQ - Y(I)=Y(I)-DELTA(I) - E(I)=E(I)-DELTA(I) -340 YPRIME(I)=YPRIME(I)-CJ*DELTA(I) -C -C Test for convergence of the iteration. -C - DELNRM=DDWNRM(NEQ,DELTA,WT,RPAR,IPAR) - IF (DELNRM .LE. TOLNEW) GO TO 370 - IF (M .EQ. 0) THEN - OLDNRM = DELNRM - ELSE - RATE = (DELNRM/OLDNRM)**(1.0D0/M) - IF (RATE .GT. 0.9D0) GO TO 380 - S = RATE/(1.0D0 - RATE) - ENDIF - IF (S*DELNRM .LE. EPCON) GO TO 370 -C -C The corrector has not yet converged. -C Update M and test whether the -C maximum number of iterations have -C been tried. -C - M=M+1 - IF(M.GE.MAXIT) GO TO 380 -C -C Evaluate the residual, -C and go back to do another iteration. -C - IWM(LNRE)=IWM(LNRE)+1 - CALL RES(X,Y,YPRIME,CJ,DELTA,IRES,RPAR,IPAR) - IF (IRES .LT. 0) GO TO 380 - GO TO 300 -C -C The iteration has converged. -C -370 RETURN -C -C The iteration has not converged. Set IERNEW appropriately. -C -380 CONTINUE - IF (IRES .LE. -2 ) THEN - IERNEW = -1 - ELSE - IERNEW = 1 - ENDIF - RETURN -C -C -C------END OF SUBROUTINE DNSD------------------------------------------- - END
--- a/liboctave/cruft/daspk/dnsid.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,157 +0,0 @@ -C Work performed under the auspices of the U.S. Department of Energy -C by Lawrence Livermore National Laboratory under contract number -C W-7405-Eng-48. -C - SUBROUTINE DNSID(X,Y,YPRIME,NEQ,ICOPT,ID,RES,WT,RPAR,IPAR, - * DELTA,R,YIC,YPIC,WM,IWM,CJ,EPCON,RATEMX,MAXIT,STPTOL, - * ICNFLG,ICNSTR,IERNEW) -C -C***BEGIN PROLOGUE DNSID -C***REFER TO DDASPK -C***DATE WRITTEN 940701 (YYMMDD) -C***REVISION DATE 950713 (YYMMDD) -C -C -C----------------------------------------------------------------------- -C***DESCRIPTION -C -C DNSID solves a nonlinear system of algebraic equations of the -C form G(X,Y,YPRIME) = 0 for the unknown parts of Y and YPRIME -C in the initial conditions. -C -C The method used is a modified Newton scheme. -C -C The parameters represent -C -C X -- Independent variable. -C Y -- Solution vector. -C YPRIME -- Derivative of solution vector. -C NEQ -- Number of unknowns. -C ICOPT -- Initial condition option chosen (1 or 2). -C ID -- Array of dimension NEQ, which must be initialized -C if ICOPT = 1. See DDASIC. -C RES -- External user-supplied subroutine to evaluate the -C residual. See RES description in DDASPK prologue. -C WT -- Vector of weights for error criterion. -C RPAR,IPAR -- Real and integer arrays used for communication -C between the calling program and external user -C routines. They are not altered within DASPK. -C DELTA -- Residual vector on entry, and work vector of -C length NEQ for DNSID. -C WM,IWM -- Real and integer arrays storing matrix information -C such as the matrix of partial derivatives, -C permutation vector, and various other information. -C CJ -- Matrix parameter = 1/H (ICOPT = 1) or 0 (ICOPT = 2). -C R -- Array of length NEQ used as workspace by the -C linesearch routine DLINSD. -C YIC,YPIC -- Work vectors for DLINSD, each of length NEQ. -C EPCON -- Tolerance to test for convergence of the Newton -C iteration. -C RATEMX -- Maximum convergence rate for which Newton iteration -C is considered converging. -C MAXIT -- Maximum allowed number of Newton iterations. -C STPTOL -- Tolerance used in calculating the minimum lambda -C value allowed. -C ICNFLG -- Integer scalar. If nonzero, then constraint -C violations in the proposed new approximate solution -C will be checked for, and the maximum step length -C will be adjusted accordingly. -C ICNSTR -- Integer array of length NEQ containing flags for -C checking constraints. -C IERNEW -- Error flag for Newton iteration. -C 0 ==> Newton iteration converged. -C 1 ==> failed to converge, but RATE .le. RATEMX. -C 2 ==> failed to converge, RATE .gt. RATEMX. -C 3 ==> other recoverable error (IRES = -1, or -C linesearch failed). -C -1 ==> unrecoverable error (IRES = -2). -C -C----------------------------------------------------------------------- -C -C***ROUTINES CALLED -C DSLVD, DDWNRM, DLINSD, DCOPY -C -C***END PROLOGUE DNSID -C -C - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - DIMENSION Y(*),YPRIME(*),WT(*),R(*) - DIMENSION ID(*),DELTA(*), YIC(*), YPIC(*) - DIMENSION WM(*),IWM(*), RPAR(*),IPAR(*) - DIMENSION ICNSTR(*) - EXTERNAL RES -C - PARAMETER (LNNI=19, LLSOFF=35) -C -C -C Initializations. M is the Newton iteration counter. -C - LSOFF = IWM(LLSOFF) - M = 0 - RATE = 1.0D0 - RLX = 0.4D0 -C -C Compute a new step vector DELTA by back-substitution. -C - CALL DSLVD (NEQ, DELTA, WM, IWM) -C -C Get norm of DELTA. Return now if norm(DELTA) .le. EPCON. -C - DELNRM = DDWNRM(NEQ,DELTA,WT,RPAR,IPAR) - FNRM = DELNRM - IF (FNRM .LE. EPCON) RETURN -C -C Newton iteration loop. -C - 300 CONTINUE - IWM(LNNI) = IWM(LNNI) + 1 -C -C Call linesearch routine for global strategy and set RATE -C - OLDFNM = FNRM -C - CALL DLINSD (NEQ, Y, X, YPRIME, CJ, DELTA, DELNRM, WT, LSOFF, - * STPTOL, IRET, RES, IRES, WM, IWM, FNRM, ICOPT, ID, - * R, YIC, YPIC, ICNFLG, ICNSTR, RLX, RPAR, IPAR) -C - RATE = FNRM/OLDFNM -C -C Check for error condition from linesearch. - IF (IRET .NE. 0) GO TO 390 -C -C Test for convergence of the iteration, and return or loop. -C - IF (FNRM .LE. EPCON) RETURN -C -C The iteration has not yet converged. Update M. -C Test whether the maximum number of iterations have been tried. -C - M = M + 1 - IF (M .GE. MAXIT) GO TO 380 -C -C Copy the residual to DELTA and its norm to DELNRM, and loop for -C another iteration. -C - CALL DCOPY (NEQ, R, 1, DELTA, 1) - DELNRM = FNRM - GO TO 300 -C -C The maximum number of iterations was done. Set IERNEW and return. -C - 380 IF (RATE .LE. RATEMX) THEN - IERNEW = 1 - ELSE - IERNEW = 2 - ENDIF - RETURN -C - 390 IF (IRES .LE. -2) THEN - IERNEW = -1 - ELSE - IERNEW = 3 - ENDIF - RETURN -C -C -C------END OF SUBROUTINE DNSID------------------------------------------ - END
--- a/liboctave/cruft/daspk/dnsik.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,189 +0,0 @@ -C Work performed under the auspices of the U.S. Department of Energy -C by Lawrence Livermore National Laboratory under contract number -C W-7405-Eng-48. -C - SUBROUTINE DNSIK(X,Y,YPRIME,NEQ,ICOPT,ID,RES,PSOL,WT,RPAR,IPAR, - * SAVR,DELTA,R,YIC,YPIC,PWK,WM,IWM,CJ,SQRTN,RSQRTN,EPLIN,EPCON, - * RATEMX,MAXIT,STPTOL,ICNFLG,ICNSTR,IERNEW) -C -C***BEGIN PROLOGUE DNSIK -C***REFER TO DDASPK -C***DATE WRITTEN 940701 (YYMMDD) -C***REVISION DATE 950714 (YYMMDD) -C -C -C----------------------------------------------------------------------- -C***DESCRIPTION -C -C DNSIK solves a nonlinear system of algebraic equations of the -C form G(X,Y,YPRIME) = 0 for the unknown parts of Y and YPRIME in -C the initial conditions. -C -C The method used is a Newton scheme combined with a linesearch -C algorithm, using Krylov iterative linear system methods. -C -C The parameters represent -C -C X -- Independent variable. -C Y -- Solution vector. -C YPRIME -- Derivative of solution vector. -C NEQ -- Number of unknowns. -C ICOPT -- Initial condition option chosen (1 or 2). -C ID -- Array of dimension NEQ, which must be initialized -C if ICOPT = 1. See DDASIC. -C RES -- External user-supplied subroutine -C to evaluate the residual. See RES description -C in DDASPK prologue. -C PSOL -- External user-supplied routine to solve -C a linear system using preconditioning. -C See explanation inside DDASPK. -C WT -- Vector of weights for error criterion. -C RPAR,IPAR -- Real and integer arrays used for communication -C between the calling program and external user -C routines. They are not altered within DASPK. -C SAVR -- Work vector for DNSIK of length NEQ. -C DELTA -- Residual vector on entry, and work vector of -C length NEQ for DNSIK. -C R -- Work vector for DNSIK of length NEQ. -C YIC,YPIC -- Work vectors for DNSIK, each of length NEQ. -C PWK -- Work vector for DNSIK of length NEQ. -C WM,IWM -- Real and integer arrays storing -C matrix information such as the matrix -C of partial derivatives, permutation -C vector, and various other information. -C CJ -- Matrix parameter = 1/H (ICOPT = 1) or 0 (ICOPT = 2). -C SQRTN -- Square root of NEQ. -C RSQRTN -- reciprical of square root of NEQ. -C EPLIN -- Tolerance for linear system solver. -C EPCON -- Tolerance to test for convergence of the Newton -C iteration. -C RATEMX -- Maximum convergence rate for which Newton iteration -C is considered converging. -C MAXIT -- Maximum allowed number of Newton iterations. -C STPTOL -- Tolerance used in calculating the minimum lambda -C value allowed. -C ICNFLG -- Integer scalar. If nonzero, then constraint -C violations in the proposed new approximate solution -C will be checked for, and the maximum step length -C will be adjusted accordingly. -C ICNSTR -- Integer array of length NEQ containing flags for -C checking constraints. -C IERNEW -- Error flag for Newton iteration. -C 0 ==> Newton iteration converged. -C 1 ==> failed to converge, but RATE .lt. 1. -C 2 ==> failed to converge, RATE .gt. RATEMX. -C 3 ==> other recoverable error. -C -1 ==> unrecoverable error inside Newton iteration. -C----------------------------------------------------------------------- -C -C***ROUTINES CALLED -C DFNRMK, DSLVK, DDWNRM, DLINSK, DCOPY -C -C***END PROLOGUE DNSIK -C -C - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - DIMENSION Y(*),YPRIME(*),WT(*),ID(*),DELTA(*),R(*),SAVR(*) - DIMENSION YIC(*),YPIC(*),PWK(*),WM(*),IWM(*), RPAR(*),IPAR(*) - DIMENSION ICNSTR(*) - EXTERNAL RES, PSOL -C - PARAMETER (LNNI=19, LNPS=21, LLOCWP=29, LLCIWP=30) - PARAMETER (LLSOFF=35, LSTOL=14) -C -C -C Initializations. M is the Newton iteration counter. -C - LSOFF = IWM(LLSOFF) - M = 0 - RATE = 1.0D0 - LWP = IWM(LLOCWP) - LIWP = IWM(LLCIWP) - RLX = 0.4D0 -C -C Save residual in SAVR. -C - CALL DCOPY (NEQ, DELTA, 1, SAVR, 1) -C -C Compute norm of (P-inverse)*(residual). -C - CALL DFNRMK (NEQ, Y, X, YPRIME, SAVR, R, CJ, WT, SQRTN, RSQRTN, - * RES, IRES, PSOL, 1, IER, FNRM, EPLIN, WM(LWP), IWM(LIWP), - * PWK, RPAR, IPAR) - IWM(LNPS) = IWM(LNPS) + 1 - IF (IER .NE. 0) THEN - IERNEW = 3 - RETURN - ENDIF -C -C Return now if residual norm is .le. EPCON. -C - IF (FNRM .LE. EPCON) RETURN -C -C Newton iteration loop. -C -300 CONTINUE - IWM(LNNI) = IWM(LNNI) + 1 -C -C Compute a new step vector DELTA. -C - CALL DSLVK (NEQ, Y, X, YPRIME, SAVR, DELTA, WT, WM, IWM, - * RES, IRES, PSOL, IERSL, CJ, EPLIN, SQRTN, RSQRTN, RHOK, - * RPAR, IPAR) - IF (IRES .NE. 0 .OR. IERSL .NE. 0) GO TO 390 -C -C Get norm of DELTA. Return now if DELTA is zero. -C - DELNRM = DDWNRM(NEQ,DELTA,WT,RPAR,IPAR) - IF (DELNRM .EQ. 0.0D0) RETURN -C -C Call linesearch routine for global strategy and set RATE. -C - OLDFNM = FNRM -C - CALL DLINSK (NEQ, Y, X, YPRIME, SAVR, CJ, DELTA, DELNRM, WT, - * SQRTN, RSQRTN, LSOFF, STPTOL, IRET, RES, IRES, PSOL, WM, IWM, - * RHOK, FNRM, ICOPT, ID, WM(LWP), IWM(LIWP), R, EPLIN, YIC, YPIC, - * PWK, ICNFLG, ICNSTR, RLX, RPAR, IPAR) -C - RATE = FNRM/OLDFNM -C -C Check for error condition from linesearch. - IF (IRET .NE. 0) GO TO 390 -C -C Test for convergence of the iteration, and return or loop. -C - IF (FNRM .LE. EPCON) RETURN -C -C The iteration has not yet converged. Update M. -C Test whether the maximum number of iterations have been tried. -C - M=M+1 - IF(M .GE. MAXIT) GO TO 380 -C -C Copy the residual SAVR to DELTA and loop for another iteration. -C - CALL DCOPY (NEQ, SAVR, 1, DELTA, 1) - GO TO 300 -C -C The maximum number of iterations was done. Set IERNEW and return. -C -380 IF (RATE .LE. RATEMX) THEN - IERNEW = 1 - ELSE - IERNEW = 2 - ENDIF - RETURN -C -390 IF (IRES .LE. -2 .OR. IERSL .LT. 0) THEN - IERNEW = -1 - ELSE - IERNEW = 3 - IF (IRES .EQ. 0 .AND. IERSL .EQ. 1 .AND. M .GE. 2 - 1 .AND. RATE .LT. 1.0D0) IERNEW = 1 - ENDIF - RETURN -C -C -C----------------------- END OF SUBROUTINE DNSIK------------------------ - END
--- a/liboctave/cruft/daspk/dnsk.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,179 +0,0 @@ -C Work performed under the auspices of the U.S. Department of Energy -C by Lawrence Livermore National Laboratory under contract number -C W-7405-Eng-48. -C - SUBROUTINE DNSK(X,Y,YPRIME,NEQ,RES,PSOL,WT,RPAR,IPAR, - * SAVR,DELTA,E,WM,IWM,CJ,SQRTN,RSQRTN,EPLIN,EPCON, - * S,CONFAC,TOLNEW,MULDEL,MAXIT,IRES,IERSL,IERNEW) -C -C***BEGIN PROLOGUE DNSK -C***REFER TO DDASPK -C***DATE WRITTEN 891219 (YYMMDD) -C***REVISION DATE 900926 (YYMMDD) -C***REVISION DATE 950126 (YYMMDD) -C -C -C----------------------------------------------------------------------- -C***DESCRIPTION -C -C DNSK solves a nonlinear system of -C algebraic equations of the form -C G(X,Y,YPRIME) = 0 for the unknown Y. -C -C The method used is a modified Newton scheme. -C -C The parameters represent -C -C X -- Independent variable. -C Y -- Solution vector. -C YPRIME -- Derivative of solution vector. -C NEQ -- Number of unknowns. -C RES -- External user-supplied subroutine -C to evaluate the residual. See RES description -C in DDASPK prologue. -C PSOL -- External user-supplied routine to solve -C a linear system using preconditioning. -C See explanation inside DDASPK. -C WT -- Vector of weights for error criterion. -C RPAR,IPAR -- Real and integer arrays used for communication -C between the calling program and external user -C routines. They are not altered within DASPK. -C SAVR -- Work vector for DNSK of length NEQ. -C DELTA -- Work vector for DNSK of length NEQ. -C E -- Error accumulation vector for DNSK of length NEQ. -C WM,IWM -- Real and integer arrays storing -C matrix information such as the matrix -C of partial derivatives, permutation -C vector, and various other information. -C CJ -- Parameter always proportional to 1/H (step size). -C SQRTN -- Square root of NEQ. -C RSQRTN -- reciprical of square root of NEQ. -C EPLIN -- Tolerance for linear system solver. -C EPCON -- Tolerance to test for convergence of the Newton -C iteration. -C S -- Used for error convergence tests. -C In the Newton iteration: S = RATE/(1.D0-RATE), -C where RATE is the estimated rate of convergence -C of the Newton iteration. -C -C The closer RATE is to 0., the faster the Newton -C iteration is converging; the closer RATE is to 1., -C the slower the Newton iteration is converging. -C -C The calling routine sends the initial value -C of S to the Newton iteration. -C CONFAC -- A residual scale factor to improve convergence. -C TOLNEW -- Tolerance on the norm of Newton correction in -C alternative Newton convergence test. -C MULDEL -- A flag indicating whether or not to multiply -C DELTA by CONFAC. -C 0 ==> do not scale DELTA by CONFAC. -C 1 ==> scale DELTA by CONFAC. -C MAXIT -- Maximum allowed number of Newton iterations. -C IRES -- Error flag returned from RES. See RES description -C in DDASPK prologue. If IRES = -1, then IERNEW -C will be set to 1. -C If IRES < -1, then IERNEW will be set to -1. -C IERSL -- Error flag for linear system solver. -C See IERSL description in subroutine DSLVK. -C If IERSL = 1, then IERNEW will be set to 1. -C If IERSL < 0, then IERNEW will be set to -1. -C IERNEW -- Error flag for Newton iteration. -C 0 ==> Newton iteration converged. -C 1 ==> recoverable error inside Newton iteration. -C -1 ==> unrecoverable error inside Newton iteration. -C----------------------------------------------------------------------- -C -C***ROUTINES CALLED -C RES, DSLVK, DDWNRM -C -C***END PROLOGUE DNSK -C -C - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - DIMENSION Y(*),YPRIME(*),WT(*),DELTA(*),E(*),SAVR(*) - DIMENSION WM(*),IWM(*), RPAR(*),IPAR(*) - EXTERNAL RES, PSOL -C - PARAMETER (LNNI=19, LNRE=12) -C -C Initialize Newton counter M and accumulation vector E. -C - M = 0 - DO 100 I=1,NEQ -100 E(I) = 0.0D0 -C -C Corrector loop. -C -300 CONTINUE - IWM(LNNI) = IWM(LNNI) + 1 -C -C If necessary, multiply residual by convergence factor. -C - IF (MULDEL .EQ. 1) THEN - DO 320 I = 1,NEQ -320 DELTA(I) = DELTA(I) * CONFAC - ENDIF -C -C Save residual in SAVR. -C - DO 340 I = 1,NEQ -340 SAVR(I) = DELTA(I) -C -C Compute a new iterate. Store the correction in DELTA. -C - CALL DSLVK (NEQ, Y, X, YPRIME, SAVR, DELTA, WT, WM, IWM, - * RES, IRES, PSOL, IERSL, CJ, EPLIN, SQRTN, RSQRTN, RHOK, - * RPAR, IPAR) - IF (IRES .NE. 0 .OR. IERSL .NE. 0) GO TO 380 -C -C Update Y, E, and YPRIME. -C - DO 360 I=1,NEQ - Y(I) = Y(I) - DELTA(I) - E(I) = E(I) - DELTA(I) -360 YPRIME(I) = YPRIME(I) - CJ*DELTA(I) -C -C Test for convergence of the iteration. -C - DELNRM = DDWNRM(NEQ,DELTA,WT,RPAR,IPAR) - IF (DELNRM .LE. TOLNEW) GO TO 370 - IF (M .EQ. 0) THEN - OLDNRM = DELNRM - ELSE - RATE = (DELNRM/OLDNRM)**(1.0D0/M) - IF (RATE .GT. 0.9D0) GO TO 380 - S = RATE/(1.0D0 - RATE) - ENDIF - IF (S*DELNRM .LE. EPCON) GO TO 370 -C -C The corrector has not yet converged. Update M and test whether -C the maximum number of iterations have been tried. -C - M = M + 1 - IF (M .GE. MAXIT) GO TO 380 -C -C Evaluate the residual, and go back to do another iteration. -C - IWM(LNRE) = IWM(LNRE) + 1 - CALL RES(X,Y,YPRIME,CJ,DELTA,IRES,RPAR,IPAR) - IF (IRES .LT. 0) GO TO 380 - GO TO 300 -C -C The iteration has converged. -C -370 RETURN -C -C The iteration has not converged. Set IERNEW appropriately. -C -380 CONTINUE - IF (IRES .LE. -2 .OR. IERSL .LT. 0) THEN - IERNEW = -1 - ELSE - IERNEW = 1 - ENDIF - RETURN -C -C -C------END OF SUBROUTINE DNSK------------------------------------------- - END
--- a/liboctave/cruft/daspk/dorth.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,101 +0,0 @@ -C Work performed under the auspices of the U.S. Department of Energy -C by Lawrence Livermore National Laboratory under contract number -C W-7405-Eng-48. -C - SUBROUTINE DORTH (VNEW, V, HES, N, LL, LDHES, KMP, SNORMW) -C -C***BEGIN PROLOGUE DORTH -C***DATE WRITTEN 890101 (YYMMDD) -C***REVISION DATE 900926 (YYMMDD) -C -C -C----------------------------------------------------------------------- -C***DESCRIPTION -C -C This routine orthogonalizes the vector VNEW against the previous -C KMP vectors in the V array. It uses a modified Gram-Schmidt -C orthogonalization procedure with conditional reorthogonalization. -C -C On entry -C -C VNEW = The vector of length N containing a scaled product -C OF The Jacobian and the vector V(*,LL). -C -C V = The N x LL array containing the previous LL -C orthogonal vectors V(*,1) to V(*,LL). -C -C HES = An LL x LL upper Hessenberg matrix containing, -C in HES(I,K), K.LT.LL, scaled inner products of -C A*V(*,K) and V(*,I). -C -C LDHES = The leading dimension of the HES array. -C -C N = The order of the matrix A, and the length of VNEW. -C -C LL = The current order of the matrix HES. -C -C KMP = The number of previous vectors the new vector VNEW -C must be made orthogonal to (KMP .LE. MAXL). -C -C -C On return -C -C VNEW = The new vector orthogonal to V(*,I0), -C where I0 = MAX(1, LL-KMP+1). -C -C HES = Upper Hessenberg matrix with column LL filled in with -C scaled inner products of A*V(*,LL) and V(*,I). -C -C SNORMW = L-2 norm of VNEW. -C -C----------------------------------------------------------------------- -C***ROUTINES CALLED -C DDOT, DNRM2, DAXPY -C -C***END PROLOGUE DORTH -C - INTEGER N, LL, LDHES, KMP - DOUBLE PRECISION VNEW, V, HES, SNORMW - DIMENSION VNEW(*), V(N,*), HES(LDHES,*) - INTEGER I, I0 - DOUBLE PRECISION ARG, DDOT, DNRM2, SUMDSQ, TEM, VNRM -C -C----------------------------------------------------------------------- -C Get norm of unaltered VNEW for later use. -C----------------------------------------------------------------------- - VNRM = DNRM2 (N, VNEW, 1) -C----------------------------------------------------------------------- -C Do Modified Gram-Schmidt on VNEW = A*V(LL). -C Scaled inner products give new column of HES. -C Projections of earlier vectors are subtracted from VNEW. -C----------------------------------------------------------------------- - I0 = MAX0(1,LL-KMP+1) - DO 10 I = I0,LL - HES(I,LL) = DDOT (N, V(1,I), 1, VNEW, 1) - TEM = -HES(I,LL) - CALL DAXPY (N, TEM, V(1,I), 1, VNEW, 1) - 10 CONTINUE -C----------------------------------------------------------------------- -C Compute SNORMW = norm of VNEW. -C If VNEW is small compared to its input value (in norm), then -C Reorthogonalize VNEW to V(*,1) through V(*,LL). -C Correct if relative correction exceeds 1000*(unit roundoff). -C Finally, correct SNORMW using the dot products involved. -C----------------------------------------------------------------------- - SNORMW = DNRM2 (N, VNEW, 1) - IF (VNRM + 0.001D0*SNORMW .NE. VNRM) RETURN - SUMDSQ = 0.0D0 - DO 30 I = I0,LL - TEM = -DDOT (N, V(1,I), 1, VNEW, 1) - IF (HES(I,LL) + 0.001D0*TEM .EQ. HES(I,LL)) GO TO 30 - HES(I,LL) = HES(I,LL) - TEM - CALL DAXPY (N, TEM, V(1,I), 1, VNEW, 1) - SUMDSQ = SUMDSQ + TEM**2 - 30 CONTINUE - IF (SUMDSQ .EQ. 0.0D0) RETURN - ARG = MAX(0.0D0,SNORMW**2 - SUMDSQ) - SNORMW = SQRT(ARG) - RETURN -C -C------END OF SUBROUTINE DORTH------------------------------------------ - END
--- a/liboctave/cruft/daspk/dslvd.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,57 +0,0 @@ -C Work performed under the auspices of the U.S. Department of Energy -C by Lawrence Livermore National Laboratory under contract number -C W-7405-Eng-48. -C - SUBROUTINE DSLVD(NEQ,DELTA,WM,IWM) -C -C***BEGIN PROLOGUE DSLVD -C***REFER TO DDASPK -C***DATE WRITTEN 890101 (YYMMDD) -C***REVISION DATE 900926 (YYMMDD) -C***REVISION DATE 940701 (YYMMDD) (new LIPVT) -C -C----------------------------------------------------------------------- -C***DESCRIPTION -C -C This routine manages the solution of the linear -C system arising in the Newton iteration. -C Real matrix information and real temporary storage -C is stored in the array WM. -C Integer matrix information is stored in the array IWM. -C For a dense matrix, the LAPACK routine DGETRS is called. -C For a banded matrix, the LAPACK routine DGBTRS is called. -C----------------------------------------------------------------------- -C***ROUTINES CALLED -C DGETRS, DGBTRS -C -C***END PROLOGUE DSLVD -C -C - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - DIMENSION DELTA(*),WM(*),IWM(*) -C - PARAMETER (LML=1, LMU=2, LMTYPE=4, LLCIWP=30) -C - LIPVT = IWM(LLCIWP) - MTYPE=IWM(LMTYPE) - GO TO(100,100,300,400,400),MTYPE -C -C Dense matrix. -C -100 CALL DGETRS('N', NEQ, 1, WM, NEQ, IWM(LIPVT), DELTA, NEQ, INLPCK) - RETURN -C -C Dummy section for MTYPE=3. -C -300 CONTINUE - RETURN -C -C Banded matrix. -C -400 MEBAND=2*IWM(LML)+IWM(LMU)+1 - CALL DGBTRS('N', NEQ, IWM(LML), IWM(LMU), 1, WM, MEBAND, - * IWM(LIPVT), DELTA, NEQ, INLPCK) - RETURN -C -C------END OF SUBROUTINE DSLVD------------------------------------------ - END
--- a/liboctave/cruft/daspk/dslvk.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,141 +0,0 @@ -C Work performed under the auspices of the U.S. Department of Energy -C by Lawrence Livermore National Laboratory under contract number -C W-7405-Eng-48. -C - SUBROUTINE DSLVK (NEQ, Y, TN, YPRIME, SAVR, X, EWT, WM, IWM, - * RES, IRES, PSOL, IERSL, CJ, EPLIN, SQRTN, RSQRTN, RHOK, - * RPAR, IPAR) -C -C***BEGIN PROLOGUE DSLVK -C***REFER TO DDASPK -C***DATE WRITTEN 890101 (YYMMDD) -C***REVISION DATE 900926 (YYMMDD) -C***REVISION DATE 940928 Removed MNEWT and added RHOK in call list. -C -C -C----------------------------------------------------------------------- -C***DESCRIPTION -C -C DSLVK uses a restart algorithm and interfaces to DSPIGM for -C the solution of the linear system arising from a Newton iteration. -C -C In addition to variables described elsewhere, -C communication with DSLVK uses the following variables.. -C WM = Real work space containing data for the algorithm -C (Krylov basis vectors, Hessenberg matrix, etc.). -C IWM = Integer work space containing data for the algorithm. -C X = The right-hand side vector on input, and the solution vector -C on output, of length NEQ. -C IRES = Error flag from RES. -C IERSL = Output flag .. -C IERSL = 0 means no trouble occurred (or user RES routine -C returned IRES < 0) -C IERSL = 1 means the iterative method failed to converge -C (DSPIGM returned IFLAG > 0.) -C IERSL = -1 means there was a nonrecoverable error in the -C iterative solver, and an error exit will occur. -C----------------------------------------------------------------------- -C***ROUTINES CALLED -C DSCAL, DCOPY, DSPIGM -C -C***END PROLOGUE DSLVK -C - INTEGER NEQ, IWM, IRES, IERSL, IPAR - DOUBLE PRECISION Y, TN, YPRIME, SAVR, X, EWT, WM, CJ, EPLIN, - 1 SQRTN, RSQRTN, RHOK, RPAR - DIMENSION Y(*), YPRIME(*), SAVR(*), X(*), EWT(*), - 1 WM(*), IWM(*), RPAR(*), IPAR(*) -C - INTEGER IFLAG, IRST, NRSTS, NRMAX, LR, LDL, LHES, LGMR, LQ, LV, - 1 LWK, LZ, MAXLP1, NPSL - INTEGER NLI, NPS, NCFL, NRE, MAXL, KMP, MITER - EXTERNAL RES, PSOL -C - PARAMETER (LNRE=12, LNCFL=16, LNLI=20, LNPS=21) - PARAMETER (LLOCWP=29, LLCIWP=30) - PARAMETER (LMITER=23, LMAXL=24, LKMP=25, LNRMAX=26) -C -C----------------------------------------------------------------------- -C IRST is set to 1, to indicate restarting is in effect. -C NRMAX is the maximum number of restarts. -C----------------------------------------------------------------------- - DATA IRST/1/ -C - LIWP = IWM(LLCIWP) - NLI = IWM(LNLI) - NPS = IWM(LNPS) - NCFL = IWM(LNCFL) - NRE = IWM(LNRE) - LWP = IWM(LLOCWP) - MAXL = IWM(LMAXL) - KMP = IWM(LKMP) - NRMAX = IWM(LNRMAX) - MITER = IWM(LMITER) - IERSL = 0 - IRES = 0 -C----------------------------------------------------------------------- -C Use a restarting strategy to solve the linear system -C P*X = -F. Parse the work vector, and perform initializations. -C Note that zero is the initial guess for X. -C----------------------------------------------------------------------- - MAXLP1 = MAXL + 1 - LV = 1 - LR = LV + NEQ*MAXL - LHES = LR + NEQ + 1 - LQ = LHES + MAXL*MAXLP1 - LWK = LQ + 2*MAXL - LDL = LWK + MIN0(1,MAXL-KMP)*NEQ - LZ = LDL + NEQ - CALL DSCAL (NEQ, RSQRTN, EWT, 1) - CALL DCOPY (NEQ, X, 1, WM(LR), 1) - DO 110 I = 1,NEQ - 110 X(I) = 0.D0 -C----------------------------------------------------------------------- -C Top of loop for the restart algorithm. Initial pass approximates -C X and sets up a transformed system to perform subsequent restarts -C to update X. NRSTS is initialized to -1, because restarting -C does not occur until after the first pass. -C Update NRSTS; conditionally copy DL to R; call the DSPIGM -C algorithm to solve A*Z = R; updated counters; update X with -C the residual solution. -C Note: if convergence is not achieved after NRMAX restarts, -C then the linear solver is considered to have failed. -C----------------------------------------------------------------------- - NRSTS = -1 - 115 CONTINUE - NRSTS = NRSTS + 1 - IF (NRSTS .GT. 0) CALL DCOPY (NEQ, WM(LDL), 1, WM(LR),1) - CALL DSPIGM (NEQ, TN, Y, YPRIME, SAVR, WM(LR), EWT, MAXL, MAXLP1, - 1 KMP, EPLIN, CJ, RES, IRES, NRES, PSOL, NPSL, WM(LZ), WM(LV), - 2 WM(LHES), WM(LQ), LGMR, WM(LWP), IWM(LIWP), WM(LWK), - 3 WM(LDL), RHOK, IFLAG, IRST, NRSTS, RPAR, IPAR) - NLI = NLI + LGMR - NPS = NPS + NPSL - NRE = NRE + NRES - DO 120 I = 1,NEQ - 120 X(I) = X(I) + WM(LZ+I-1) - IF ((IFLAG .EQ. 1) .AND. (NRSTS .LT. NRMAX) .AND. (IRES .EQ. 0)) - 1 GO TO 115 -C----------------------------------------------------------------------- -C The restart scheme is finished. Test IRES and IFLAG to see if -C convergence was not achieved, and set flags accordingly. -C----------------------------------------------------------------------- - IF (IRES .LT. 0) THEN - NCFL = NCFL + 1 - ELSE IF (IFLAG .NE. 0) THEN - NCFL = NCFL + 1 - IF (IFLAG .GT. 0) IERSL = 1 - IF (IFLAG .LT. 0) IERSL = -1 - ENDIF -C----------------------------------------------------------------------- -C Update IWM with counters, rescale EWT, and return. -C----------------------------------------------------------------------- - IWM(LNLI) = NLI - IWM(LNPS) = NPS - IWM(LNCFL) = NCFL - IWM(LNRE) = NRE - CALL DSCAL (NEQ, SQRTN, EWT, 1) - RETURN -C -C------END OF SUBROUTINE DSLVK------------------------------------------ - END
--- a/liboctave/cruft/daspk/dspigm.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,319 +0,0 @@ -C Work performed under the auspices of the U.S. Department of Energy -C by Lawrence Livermore National Laboratory under contract number -C W-7405-Eng-48. -C - SUBROUTINE DSPIGM (NEQ, TN, Y, YPRIME, SAVR, R, WGHT, MAXL, - * MAXLP1, KMP, EPLIN, CJ, RES, IRES, NRE, PSOL, NPSL, Z, V, - * HES, Q, LGMR, WP, IWP, WK, DL, RHOK, IFLAG, IRST, NRSTS, - * RPAR, IPAR) -C -C***BEGIN PROLOGUE DSPIGM -C***DATE WRITTEN 890101 (YYMMDD) -C***REVISION DATE 900926 (YYMMDD) -C***REVISION DATE 940927 Removed MNEWT and added RHOK in call list. -C -C -C----------------------------------------------------------------------- -C***DESCRIPTION -C -C This routine solves the linear system A * Z = R using a scaled -C preconditioned version of the generalized minimum residual method. -C An initial guess of Z = 0 is assumed. -C -C On entry -C -C NEQ = Problem size, passed to PSOL. -C -C TN = Current Value of T. -C -C Y = Array Containing current dependent variable vector. -C -C YPRIME = Array Containing current first derivative of Y. -C -C SAVR = Array containing current value of G(T,Y,YPRIME). -C -C R = The right hand side of the system A*Z = R. -C R is also used as work space when computing -C the final approximation and will therefore be -C destroyed. -C (R is the same as V(*,MAXL+1) in the call to DSPIGM.) -C -C WGHT = The vector of length NEQ containing the nonzero -C elements of the diagonal scaling matrix. -C -C MAXL = The maximum allowable order of the matrix H. -C -C MAXLP1 = MAXL + 1, used for dynamic dimensioning of HES. -C -C KMP = The number of previous vectors the new vector, VNEW, -C must be made orthogonal to. (KMP .LE. MAXL.) -C -C EPLIN = Tolerance on residuals R-A*Z in weighted rms norm. -C -C CJ = Scalar proportional to current value of -C 1/(step size H). -C -C WK = Real work array used by routine DATV and PSOL. -C -C DL = Real work array used for calculation of the residual -C norm RHO when the method is incomplete (KMP.LT.MAXL) -C and/or when using restarting. -C -C WP = Real work array used by preconditioner PSOL. -C -C IWP = Integer work array used by preconditioner PSOL. -C -C IRST = Method flag indicating if restarting is being -C performed. IRST .GT. 0 means restarting is active, -C while IRST = 0 means restarting is not being used. -C -C NRSTS = Counter for the number of restarts on the current -C call to DSPIGM. If NRSTS .GT. 0, then the residual -C R is already scaled, and so scaling of R is not -C necessary. -C -C -C On Return -C -C Z = The final computed approximation to the solution -C of the system A*Z = R. -C -C LGMR = The number of iterations performed and -C the current order of the upper Hessenberg -C matrix HES. -C -C NRE = The number of calls to RES (i.e. DATV) -C -C NPSL = The number of calls to PSOL. -C -C V = The neq by (LGMR+1) array containing the LGMR -C orthogonal vectors V(*,1) to V(*,LGMR). -C -C HES = The upper triangular factor of the QR decomposition -C of the (LGMR+1) by LGMR upper Hessenberg matrix whose -C entries are the scaled inner-products of A*V(*,I) -C and V(*,K). -C -C Q = Real array of length 2*MAXL containing the components -C of the givens rotations used in the QR decomposition -C of HES. It is loaded in DHEQR and used in DHELS. -C -C IRES = Error flag from RES. -C -C DL = Scaled preconditioned residual, -C (D-inverse)*(P-inverse)*(R-A*Z). Only loaded when -C performing restarts of the Krylov iteration. -C -C RHOK = Weighted norm of final preconditioned residual. -C -C IFLAG = Integer error flag.. -C 0 Means convergence in LGMR iterations, LGMR.LE.MAXL. -C 1 Means the convergence test did not pass in MAXL -C iterations, but the new residual norm (RHO) is -C .LT. the old residual norm (RNRM), and so Z is -C computed. -C 2 Means the convergence test did not pass in MAXL -C iterations, new residual norm (RHO) .GE. old residual -C norm (RNRM), and the initial guess, Z = 0, is -C returned. -C 3 Means there was a recoverable error in PSOL -C caused by the preconditioner being out of date. -C -1 Means there was an unrecoverable error in PSOL. -C -C----------------------------------------------------------------------- -C***ROUTINES CALLED -C PSOL, DNRM2, DSCAL, DATV, DORTH, DHEQR, DCOPY, DHELS, DAXPY -C -C***END PROLOGUE DSPIGM -C - INTEGER NEQ,MAXL,MAXLP1,KMP,IRES,NRE,NPSL,LGMR,IWP, - 1 IFLAG,IRST,NRSTS,IPAR - DOUBLE PRECISION TN,Y,YPRIME,SAVR,R,WGHT,EPLIN,CJ,Z,V,HES,Q,WP,WK, - 1 DL,RHOK,RPAR - DIMENSION Y(*), YPRIME(*), SAVR(*), R(*), WGHT(*), Z(*), - 1 V(NEQ,*), HES(MAXLP1,*), Q(*), WP(*), IWP(*), WK(*), DL(*), - 2 RPAR(*), IPAR(*) - INTEGER I, IER, INFO, IP1, I2, J, K, LL, LLP1 - DOUBLE PRECISION RNRM,C,DLNRM,PROD,RHO,S,SNORMW,DNRM2,TEM - EXTERNAL RES, PSOL -C - IER = 0 - IFLAG = 0 - LGMR = 0 - NPSL = 0 - NRE = 0 -C----------------------------------------------------------------------- -C The initial guess for Z is 0. The initial residual is therefore -C the vector R. Initialize Z to 0. -C----------------------------------------------------------------------- - DO 10 I = 1,NEQ - 10 Z(I) = 0.0D0 -C----------------------------------------------------------------------- -C Apply inverse of left preconditioner to vector R if NRSTS .EQ. 0. -C Form V(*,1), the scaled preconditioned right hand side. -C----------------------------------------------------------------------- - IF (NRSTS .EQ. 0) THEN - CALL PSOL (NEQ, TN, Y, YPRIME, SAVR, WK, CJ, WGHT, WP, IWP, - 1 R, EPLIN, IER, RPAR, IPAR) - NPSL = 1 - IF (IER .NE. 0) GO TO 300 - DO 30 I = 1,NEQ - 30 V(I,1) = R(I)*WGHT(I) - ELSE - DO 35 I = 1,NEQ - 35 V(I,1) = R(I) - ENDIF -C----------------------------------------------------------------------- -C Calculate norm of scaled vector V(*,1) and normalize it -C If, however, the norm of V(*,1) (i.e. the norm of the preconditioned -C residual) is .le. EPLIN, then return with Z=0. -C----------------------------------------------------------------------- - RNRM = DNRM2 (NEQ, V, 1) - IF (RNRM .LE. EPLIN) THEN - RHOK = RNRM - RETURN - ENDIF - TEM = 1.0D0/RNRM - CALL DSCAL (NEQ, TEM, V(1,1), 1) -C----------------------------------------------------------------------- -C Zero out the HES array. -C----------------------------------------------------------------------- - DO 65 J = 1,MAXL - DO 60 I = 1,MAXLP1 - 60 HES(I,J) = 0.0D0 - 65 CONTINUE -C----------------------------------------------------------------------- -C Main loop to compute the vectors V(*,2) to V(*,MAXL). -C The running product PROD is needed for the convergence test. -C----------------------------------------------------------------------- - PROD = 1.0D0 - DO 90 LL = 1,MAXL - LGMR = LL -C----------------------------------------------------------------------- -C Call routine DATV to compute VNEW = ABAR*V(LL), where ABAR is -C the matrix A with scaling and inverse preconditioner factors applied. -C Call routine DORTH to orthogonalize the new vector VNEW = V(*,LL+1). -C call routine DHEQR to update the factors of HES. -C----------------------------------------------------------------------- - CALL DATV (NEQ, Y, TN, YPRIME, SAVR, V(1,LL), WGHT, Z, - 1 RES, IRES, PSOL, V(1,LL+1), WK, WP, IWP, CJ, EPLIN, - 1 IER, NRE, NPSL, RPAR, IPAR) - IF (IRES .LT. 0) RETURN - IF (IER .NE. 0) GO TO 300 - CALL DORTH (V(1,LL+1), V, HES, NEQ, LL, MAXLP1, KMP, SNORMW) - HES(LL+1,LL) = SNORMW - CALL DHEQR (HES, MAXLP1, LL, Q, INFO, LL) - IF (INFO .EQ. LL) GO TO 120 -C----------------------------------------------------------------------- -C Update RHO, the estimate of the norm of the residual R - A*ZL. -C If KMP .LT. MAXL, then the vectors V(*,1),...,V(*,LL+1) are not -C necessarily orthogonal for LL .GT. KMP. The vector DL must then -C be computed, and its norm used in the calculation of RHO. -C----------------------------------------------------------------------- - PROD = PROD*Q(2*LL) - RHO = ABS(PROD*RNRM) - IF ((LL.GT.KMP) .AND. (KMP.LT.MAXL)) THEN - IF (LL .EQ. KMP+1) THEN - CALL DCOPY (NEQ, V(1,1), 1, DL, 1) - DO 75 I = 1,KMP - IP1 = I + 1 - I2 = I*2 - S = Q(I2) - C = Q(I2-1) - DO 70 K = 1,NEQ - 70 DL(K) = S*DL(K) + C*V(K,IP1) - 75 CONTINUE - ENDIF - S = Q(2*LL) - C = Q(2*LL-1)/SNORMW - LLP1 = LL + 1 - DO 80 K = 1,NEQ - 80 DL(K) = S*DL(K) + C*V(K,LLP1) - DLNRM = DNRM2 (NEQ, DL, 1) - RHO = RHO*DLNRM - ENDIF -C----------------------------------------------------------------------- -C Test for convergence. If passed, compute approximation ZL. -C If failed and LL .LT. MAXL, then continue iterating. -C----------------------------------------------------------------------- - IF (RHO .LE. EPLIN) GO TO 200 - IF (LL .EQ. MAXL) GO TO 100 -C----------------------------------------------------------------------- -C Rescale so that the norm of V(1,LL+1) is one. -C----------------------------------------------------------------------- - TEM = 1.0D0/SNORMW - CALL DSCAL (NEQ, TEM, V(1,LL+1), 1) - 90 CONTINUE - 100 CONTINUE - IF (RHO .LT. RNRM) GO TO 150 - 120 CONTINUE - IFLAG = 2 - DO 130 I = 1,NEQ - 130 Z(I) = 0.D0 - RETURN - 150 IFLAG = 1 -C----------------------------------------------------------------------- -C The tolerance was not met, but the residual norm was reduced. -C If performing restarting (IRST .gt. 0) calculate the residual vector -C RL and store it in the DL array. If the incomplete version is -C being used (KMP .lt. MAXL) then DL has already been calculated. -C----------------------------------------------------------------------- - IF (IRST .GT. 0) THEN - IF (KMP .EQ. MAXL) THEN -C -C Calculate DL from the V(I)'s. -C - CALL DCOPY (NEQ, V(1,1), 1, DL, 1) - MAXLM1 = MAXL - 1 - DO 175 I = 1,MAXLM1 - IP1 = I + 1 - I2 = I*2 - S = Q(I2) - C = Q(I2-1) - DO 170 K = 1,NEQ - 170 DL(K) = S*DL(K) + C*V(K,IP1) - 175 CONTINUE - S = Q(2*MAXL) - C = Q(2*MAXL-1)/SNORMW - DO 180 K = 1,NEQ - 180 DL(K) = S*DL(K) + C*V(K,MAXLP1) - ENDIF -C -C Scale DL by RNRM*PROD to obtain the residual RL. -C - TEM = RNRM*PROD - CALL DSCAL(NEQ, TEM, DL, 1) - ENDIF -C----------------------------------------------------------------------- -C Compute the approximation ZL to the solution. -C Since the vector Z was used as work space, and the initial guess -C of the Newton correction is zero, Z must be reset to zero. -C----------------------------------------------------------------------- - 200 CONTINUE - LL = LGMR - LLP1 = LL + 1 - DO 210 K = 1,LLP1 - 210 R(K) = 0.0D0 - R(1) = RNRM - CALL DHELS (HES, MAXLP1, LL, Q, R) - DO 220 K = 1,NEQ - 220 Z(K) = 0.0D0 - DO 230 I = 1,LL - CALL DAXPY (NEQ, R(I), V(1,I), 1, Z, 1) - 230 CONTINUE - DO 240 I = 1,NEQ - 240 Z(I) = Z(I)/WGHT(I) -C Load RHO into RHOK. - RHOK = RHO - RETURN -C----------------------------------------------------------------------- -C This block handles error returns forced by routine PSOL. -C----------------------------------------------------------------------- - 300 CONTINUE - IF (IER .LT. 0) IFLAG = -1 - IF (IER .GT. 0) IFLAG = 3 -C - RETURN -C -C------END OF SUBROUTINE DSPIGM----------------------------------------- - END
--- a/liboctave/cruft/daspk/dyypnw.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,58 +0,0 @@ -C Work performed under the auspices of the U.S. Department of Energy -C by Lawrence Livermore National Laboratory under contract number -C W-7405-Eng-48. -C - SUBROUTINE DYYPNW (NEQ, Y, YPRIME, CJ, RL, P, ICOPT, ID, - * YNEW, YPNEW) -C -C***BEGIN PROLOGUE DYYPNW -C***REFER TO DLINSK -C***DATE WRITTEN 940830 (YYMMDD) -C -C -C----------------------------------------------------------------------- -C***DESCRIPTION -C -C DYYPNW calculates the new (Y,YPRIME) pair needed in the -C linesearch algorithm based on the current lambda value. It is -C called by DLINSK and DLINSD. Based on the ICOPT and ID values, -C the corresponding entry in Y or YPRIME is updated. -C -C In addition to the parameters described in the calling programs, -C the parameters represent -C -C P -- Array of length NEQ that contains the current -C approximate Newton step. -C RL -- Scalar containing the current lambda value. -C YNEW -- Array of length NEQ containing the updated Y vector. -C YPNEW -- Array of length NEQ containing the updated YPRIME -C vector. -C----------------------------------------------------------------------- -C -C***ROUTINES CALLED (NONE) -C -C***END PROLOGUE DYYPNW -C -C - IMPLICIT DOUBLE PRECISION (A-H,O-Z) - DIMENSION Y(*), YPRIME(*), YNEW(*), YPNEW(*), ID(*), P(*) -C - IF (ICOPT .EQ. 1) THEN - DO 10 I=1,NEQ - IF(ID(I) .LT. 0) THEN - YNEW(I) = Y(I) - RL*P(I) - YPNEW(I) = YPRIME(I) - ELSE - YNEW(I) = Y(I) - YPNEW(I) = YPRIME(I) - RL*CJ*P(I) - ENDIF - 10 CONTINUE - ELSE - DO 20 I = 1,NEQ - YNEW(I) = Y(I) - RL*P(I) - YPNEW(I) = YPRIME(I) - 20 CONTINUE - ENDIF - RETURN -C----------------------- END OF SUBROUTINE DYYPNW ---------------------- - END
--- a/liboctave/cruft/daspk/module.mk Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,29 +0,0 @@ -CRUFT_SOURCES += \ - liboctave/cruft/daspk/datv.f \ - liboctave/cruft/daspk/dcnst0.f \ - liboctave/cruft/daspk/dcnstr.f \ - liboctave/cruft/daspk/ddasic.f \ - liboctave/cruft/daspk/ddasid.f \ - liboctave/cruft/daspk/ddasik.f \ - liboctave/cruft/daspk/ddaspk.f \ - liboctave/cruft/daspk/ddstp.f \ - liboctave/cruft/daspk/ddwnrm.f \ - liboctave/cruft/daspk/dfnrmd.f \ - liboctave/cruft/daspk/dfnrmk.f \ - liboctave/cruft/daspk/dhels.f \ - liboctave/cruft/daspk/dheqr.f \ - liboctave/cruft/daspk/dinvwt.f \ - liboctave/cruft/daspk/dlinsd.f \ - liboctave/cruft/daspk/dlinsk.f \ - liboctave/cruft/daspk/dmatd.f \ - liboctave/cruft/daspk/dnedd.f \ - liboctave/cruft/daspk/dnedk.f \ - liboctave/cruft/daspk/dnsd.f \ - liboctave/cruft/daspk/dnsid.f \ - liboctave/cruft/daspk/dnsik.f \ - liboctave/cruft/daspk/dnsk.f \ - liboctave/cruft/daspk/dorth.f \ - liboctave/cruft/daspk/dslvd.f \ - liboctave/cruft/daspk/dslvk.f \ - liboctave/cruft/daspk/dspigm.f \ - liboctave/cruft/daspk/dyypnw.f
--- a/liboctave/cruft/dasrt/ddasrt.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1559 +0,0 @@ - SUBROUTINE DDASRT (RES,NEQ,T,Y,YPRIME,TOUT, - * INFO,RTOL,ATOL,IDID,RWORK,LRW,IWORK,LIW,RPAR,IPAR,JAC, - * G,NG,JROOT) -C -C***BEGIN PROLOGUE DDASRT -C***DATE WRITTEN 821001 (YYMMDD) -C***REVISION DATE 910624 (YYMMDD) -C***KEYWORDS DIFFERENTIAL/ALGEBRAIC,BACKWARD DIFFERENTIATION FORMULAS -C IMPLICIT DIFFERENTIAL SYSTEMS -C***AUTHOR PETZOLD,LINDA R.,COMPUTING AND MATHEMATICS RESEARCH DIVISION -C LAWRENCE LIVERMORE NATIONAL LABORATORY -C L - 316, P.O. Box 808, -C LIVERMORE, CA. 94550 -C***PURPOSE This code solves a system of differential/algebraic -C equations of the form F(T,Y,YPRIME) = 0. -C***DESCRIPTION -C -C *Usage: -C -C IMPLICIT DOUBLE PRECISION (A-H,O-Z) -C EXTERNAL RES, JAC, G -C INTEGER NEQ, INFO(N), IDID, LRW, LIW, IWORK(LIW), IPAR, NG, -C * JROOT(NG) -C DOUBLE PRECISION T, Y(NEQ), YPRIME(NEQ), TOUT, RTOL, ATOL, -C * RWORK(LRW), RPAR -C -C CALL DDASRT (RES, NEQ, T, Y, YPRIME, TOUT, INFO, RTOL, ATOL, -C * IDID, RWORK, LRW, IWORK, LIW, RPAR, IPAR, JAC) -C -C -C -C *Arguments: -C -C RES:EXT This is a subroutine which you provide to define the -C differential/algebraic system. -C -C NEQ:IN This is the number of equations to be solved. -C -C T:INOUT This is the current value of the independent variable. -C -C Y(*):INOUT This array contains the solution components at T. -C -C YPRIME(*):INOUT This array contains the derivatives of the solution -C components at T. -C -C TOUT:IN This is a point at which a solution is desired. -C -C INFO(N):IN The basic task of the code is to solve the system from T -C to TOUT and return an answer at TOUT. INFO is an integer -C array which is used to communicate exactly how you want -C this task to be carried out. N must be greater than or -C equal to 15. -C -C RTOL,ATOL:INOUT These quantities represent absolute and relative -C error tolerances which you provide to indicate how -C accurately you wish the solution to be computed. -C You may choose them to be both scalars or else -C both vectors. -C -C IDID:OUT This scalar quantity is an indicator reporting what the -C code did. You must monitor this integer variable to decide -C what action to take next. -C -C RWORK:WORK A real work array of length LRW which provides the -C code with needed storage space. -C -C LRW:IN The length of RWORK. -C -C IWORK:WORK An integer work array of length LIW which probides the -C code with needed storage space. -C -C LIW:IN The length of IWORK. -C -C RPAR,IPAR:IN These are real and integer parameter arrays which -C you can use for communication between your calling -C program and the RES subroutine (and the JAC subroutine) -C -C JAC:EXT This is the name of a subroutine which you may choose to -C provide for defining a matrix of partial derivatives -C described below. -C -C G This is the name of the subroutine for defining -C constraint functions, G(T,Y), whose roots are desired -C during the integration. This name must be declared -C external in the calling program. -C -C NG This is the number of constraint functions G(I). -C If there are none, set NG=0, and pass a dummy name -C for G. -C -C JROOT This is an integer array of length NG for output -C of root information. -C -C -C *Description -C -C QUANTITIES WHICH MAY BE ALTERED BY THE CODE ARE -C T,Y(*),YPRIME(*),INFO(1),RTOL,ATOL, -C IDID,RWORK(*) AND IWORK(*). -C -C Subroutine DDASRT uses the backward differentiation formulas of -C orders one through five to solve a system of the above form for Y and -C YPRIME. Values for Y and YPRIME at the initial time must be given as -C input. These values must be consistent, (that is, if T,Y,YPRIME are -C the given initial values, they must satisfy F(T,Y,YPRIME) = 0.). The -C subroutine solves the system from T to TOUT. -C It is easy to continue the solution to get results at additional -C TOUT. This is the interval mode of operation. Intermediate results -C can also be obtained easily by using the intermediate-output -C capability. If DDASRT detects a sign-change in G(T,Y), then -C it will return the intermediate value of T and Y for which -C G(T,Y) = 0. -C -C ---------INPUT-WHAT TO DO ON THE FIRST CALL TO DDASRT--------------- -C -C -C The first call of the code is defined to be the start of each new -C problem. Read through the descriptions of all the following items, -C provide sufficient storage space for designated arrays, set -C appropriate variables for the initialization of the problem, and -C give information about how you want the problem to be solved. -C -C -C RES -- Provide a subroutine of the form -C SUBROUTINE RES(T,Y,YPRIME,DELTA,IRES,RPAR,IPAR) -C to define the system of differential/algebraic -C equations which is to be solved. For the given values -C of T,Y and YPRIME, the subroutine should -C return the residual of the defferential/algebraic -C system -C DELTA = F(T,Y,YPRIME) -C (DELTA(*) is a vector of length NEQ which is -C output for RES.) -C -C Subroutine RES must not alter T,Y or YPRIME. -C You must declare the name RES in an external -C statement in your program that calls DDASRT. -C You must dimension Y,YPRIME and DELTA in RES. -C -C IRES is an integer flag which is always equal to -C zero on input. Subroutine RES should alter IRES -C only if it encounters an illegal value of Y or -C a stop condition. Set IRES = -1 if an input value -C is illegal, and DDASRT will try to solve the problem -C without getting IRES = -1. If IRES = -2, DDASRT -C will return control to the calling program -C with IDID = -11. -C -C RPAR and IPAR are real and integer parameter arrays which -C you can use for communication between your calling program -C and subroutine RES. They are not altered by DDASRT. If you -C do not need RPAR or IPAR, ignore these parameters by treat- -C ing them as dummy arguments. If you do choose to use them, -C dimension them in your calling program and in RES as arrays -C of appropriate length. -C -C NEQ -- Set it to the number of differential equations. -C (NEQ .GE. 1) -C -C T -- Set it to the initial point of the integration. -C T must be defined as a variable. -C -C Y(*) -- Set this vector to the initial values of the NEQ solution -C components at the initial point. You must dimension Y of -C length at least NEQ in your calling program. -C -C YPRIME(*) -- Set this vector to the initial values of -C the NEQ first derivatives of the solution -C components at the initial point. You -C must dimension YPRIME at least NEQ -C in your calling program. If you do not -C know initial values of some of the solution -C components, see the explanation of INFO(11). -C -C TOUT - Set it to the first point at which a solution -C is desired. You can not take TOUT = T. -C integration either forward in T (TOUT .GT. T) or -C backward in T (TOUT .LT. T) is permitted. -C -C The code advances the solution from T to TOUT using -C step sizes which are automatically selected so as to -C achieve the desired accuracy. If you wish, the code will -C return with the solution and its derivative at -C intermediate steps (intermediate-output mode) so that -C you can monitor them, but you still must provide TOUT in -C accord with the basic aim of the code. -C -C the first step taken by the code is a critical one -C because it must reflect how fast the solution changes near -C the initial point. The code automatically selects an -C initial step size which is practically always suitable for -C the problem. By using the fact that the code will not step -C past TOUT in the first step, you could, if necessary, -C restrict the length of the initial step size. -C -C For some problems it may not be permissable to integrate -C past a point TSTOP because a discontinuity occurs there -C or the solution or its derivative is not defined beyond -C TSTOP. When you have declared a TSTOP point (SEE INFO(4) -C and RWORK(1)), you have told the code not to integrate -C past TSTOP. In this case any TOUT beyond TSTOP is invalid -C input. -C -C INFO(*) - Use the INFO array to give the code more details about -C how you want your problem solved. This array should be -C dimensioned of length 15, though DDASRT uses -C only the first twelve entries. You must respond to all of -C the following items which are arranged as questions. The -C simplest use of the code corresponds to answering all -C questions as yes, i.e. setting all entries of INFO to 0. -C -C INFO(1) - This parameter enables the code to initialize -C itself. You must set it to indicate the start of every -C new problem. -C -C **** Is this the first call for this problem ... -C Yes - Set INFO(1) = 0 -C No - Not applicable here. -C See below for continuation calls. **** -C -C INFO(2) - How much accuracy you want of your solution -C is specified by the error tolerances RTOL and ATOL. -C The simplest use is to take them both to be scalars. -C To obtain more flexibility, they can both be vectors. -C The code must be told your choice. -C -C **** Are both error tolerances RTOL, ATOL scalars ... -C Yes - Set INFO(2) = 0 -C and input scalars for both RTOL and ATOL -C No - Set INFO(2) = 1 -C and input arrays for both RTOL and ATOL **** -C -C INFO(3) - The code integrates from T in the direction -C of TOUT by steps. If you wish, it will return the -C computed solution and derivative at the next -C intermediate step (the intermediate-output mode) or -C TOUT, whichever comes first. This is a good way to -C proceed if you want to see the behavior of the solution. -C If you must have solutions at a great many specific -C TOUT points, this code will compute them efficiently. -C -C **** Do you want the solution only at -C TOUT (and not at the next intermediate step) ... -C Yes - Set INFO(3) = 0 -C No - Set INFO(3) = 1 **** -C -C INFO(4) - To handle solutions at a great many specific -C values TOUT efficiently, this code may integrate past -C TOUT and interpolate to obtain the result at TOUT. -C Sometimes it is not possible to integrate beyond some -C point TSTOP because the equation changes there or it is -C not defined past TSTOP. Then you must tell the code -C not to go past. -C -C **** Can the integration be carried out without any -C restrictions on the independent variable T ... -C Yes - Set INFO(4)=0 -C No - Set INFO(4)=1 -C and define the stopping point TSTOP by -C setting RWORK(1)=TSTOP **** -C -C INFO(5) - To solve differential/algebraic problems it is -C necessary to use a matrix of partial derivatives of the -C system of differential equations. If you do not -C provide a subroutine to evaluate it analytically (see -C description of the item JAC in the call list), it will -C be approximated by numerical differencing in this code. -C although it is less trouble for you to have the code -C compute partial derivatives by numerical differencing, -C the solution will be more reliable if you provide the -C derivatives via JAC. Sometimes numerical differencing -C is cheaper than evaluating derivatives in JAC and -C sometimes it is not - this depends on your problem. -C -C **** Do you want the code to evaluate the partial -C derivatives automatically by numerical differences ... -C Yes - Set INFO(5)=0 -C No - Set INFO(5)=1 -C and provide subroutine JAC for evaluating the -C matrix of partial derivatives **** -C -C INFO(6) - DDASRT will perform much better if the matrix of -C partial derivatives, DG/DY + CJ*DG/DYPRIME, -C (here CJ is a scalar determined by DDASRT) -C is banded and the code is told this. In this -C case, the storage needed will be greatly reduced, -C numerical differencing will be performed much cheaper, -C and a number of important algorithms will execute much -C faster. The differential equation is said to have -C half-bandwidths ML (lower) and MU (upper) if equation i -C involves only unknowns Y(J) with -C I-ML .LE. J .LE. I+MU -C for all I=1,2,...,NEQ. Thus, ML and MU are the widths -C of the lower and upper parts of the band, respectively, -C with the main diagonal being excluded. If you do not -C indicate that the equation has a banded matrix of partial -C derivatives, the code works with a full matrix of NEQ**2 -C elements (stored in the conventional way). Computations -C with banded matrices cost less time and storage than with -C full matrices if 2*ML+MU .LT. NEQ. If you tell the -C code that the matrix of partial derivatives has a banded -C structure and you want to provide subroutine JAC to -C compute the partial derivatives, then you must be careful -C to store the elements of the matrix in the special form -C indicated in the description of JAC. -C -C **** Do you want to solve the problem using a full -C (dense) matrix (and not a special banded -C structure) ... -C Yes - Set INFO(6)=0 -C No - Set INFO(6)=1 -C and provide the lower (ML) and upper (MU) -C bandwidths by setting -C IWORK(1)=ML -C IWORK(2)=MU **** -C -C -C INFO(7) -- You can specify a maximum (absolute value of) -C stepsize, so that the code -C will avoid passing over very -C large regions. -C -C **** Do you want the code to decide -C on its own maximum stepsize? -C Yes - Set INFO(7)=0 -C No - Set INFO(7)=1 -C and define HMAX by setting -C RWORK(2)=HMAX **** -C -C INFO(8) -- Differential/algebraic problems -C may occaisionally suffer from -C severe scaling difficulties on the -C first step. If you know a great deal -C about the scaling of your problem, you can -C help to alleviate this problem by -C specifying an initial stepsize H0. -C -C **** Do you want the code to define -C its own initial stepsize? -C Yes - Set INFO(8)=0 -C No - Set INFO(8)=1 -C and define H0 by setting -C RWORK(3)=H0 **** -C -C INFO(9) -- If storage is a severe problem, -C you can save some locations by -C restricting the maximum order MAXORD. -C the default value is 5. for each -C order decrease below 5, the code -C requires NEQ fewer locations, however -C it is likely to be slower. In any -C case, you must have 1 .LE. MAXORD .LE. 5 -C **** Do you want the maximum order to -C default to 5? -C Yes - Set INFO(9)=0 -C No - Set INFO(9)=1 -C and define MAXORD by setting -C IWORK(3)=MAXORD **** -C -C INFO(10) --If you know that the solutions to your equations -C will always be nonnegative, it may help to set this -C parameter. However, it is probably best to -C try the code without using this option first, -C and only to use this option if that doesn't -C work very well. -C **** Do you want the code to solve the problem without -C invoking any special nonnegativity constraints? -C Yes - Set INFO(10)=0 -C No - Set INFO(10)=1 -C -C INFO(11) --DDASRT normally requires the initial T, -C Y, and YPRIME to be consistent. That is, -C you must have F(T,Y,YPRIME) = 0 at the initial -C time. If you do not know the initial -C derivative precisely, you can let DDASRT try -C to compute it. -C **** Are the initial T, Y, YPRIME consistent? -C Yes - Set INFO(11) = 0 -C No - Set INFO(11) = 1, -C and set YPRIME to an initial approximation -C to YPRIME. (If you have no idea what -C YPRIME should be, set it to zero. Note -C that the initial Y should be such -C that there must exist a YPRIME so that -C F(T,Y,YPRIME) = 0.) -C -C INFO(12) --Maximum number of steps. -C **** Do you want to let DDASRT use the default limit for -C the number of steps? -C Yes - Set INFO(12) = 0 -C No - Set INFO(12) = 1, -C and define the maximum number of steps -C by setting IWORK(21)=MXSTEP -C -C RTOL, ATOL -- You must assign relative (RTOL) and absolute (ATOL -C error tolerances to tell the code how accurately you -C want the solution to be computed. They must be defined -C as variables because the code may change them. You -C have two choices -- -C Both RTOL and ATOL are scalars. (INFO(2)=0) -C Both RTOL and ATOL are vectors. (INFO(2)=1) -C in either case all components must be non-negative. -C -C The tolerances are used by the code in a local error -C test at each step which requires roughly that -C ABS(LOCAL ERROR) .LE. RTOL*ABS(Y)+ATOL -C for each vector component. -C (More specifically, a root-mean-square norm is used to -C measure the size of vectors, and the error test uses the -C magnitude of the solution at the beginning of the step.) -C -C The true (global) error is the difference between the -C true solution of the initial value problem and the -C computed approximation. Practically all present day -C codes, including this one, control the local error at -C each step and do not even attempt to control the global -C error directly. -C Usually, but not always, the true accuracy of the -C computed Y is comparable to the error tolerances. This -C code will usually, but not always, deliver a more -C accurate solution if you reduce the tolerances and -C integrate again. By comparing two such solutions you -C can get a fairly reliable idea of the true error in the -C solution at the bigger tolerances. -C -C Setting ATOL=0. results in a pure relative error test on -C that component. Setting RTOL=0. results in a pure -C absolute error test on that component. A mixed test -C with non-zero RTOL and ATOL corresponds roughly to a -C relative error test when the solution component is much -C bigger than ATOL and to an absolute error test when the -C solution component is smaller than the threshhold ATOL. -C -C The code will not attempt to compute a solution at an -C accuracy unreasonable for the machine being used. It -C will advise you if you ask for too much accuracy and -C inform you as to the maximum accuracy it believes -C possible. -C -C RWORK(*) -- Dimension this real work array of length LRW in your -C calling program. -C -C LRW -- Set it to the declared length of the RWORK array. -C You must have -C LRW .GE. 50+(MAXORD+4)*NEQ+NEQ**2+3*NG -C for the full (dense) JACOBIAN case (when INFO(6)=0), or -C LRW .GE. 50+(MAXORD+4)*NEQ+(2*ML+MU+1)*NEQ+3*NG -C for the banded user-defined JACOBIAN case -C (when INFO(5)=1 and INFO(6)=1), or -C LRW .GE. 50+(MAXORD+4)*NEQ+(2*ML+MU+1)*NEQ -C +2*(NEQ/(ML+MU+1)+1)+3*NG -C for the banded finite-difference-generated JACOBIAN case -C (when INFO(5)=0 and INFO(6)=1) -C -C IWORK(*) -- Dimension this integer work array of length LIW in -C your calling program. -C -C LIW -- Set it to the declared length of the IWORK array. -C you must have LIW .GE. 21+NEQ -C -C RPAR, IPAR -- These are parameter arrays, of real and integer -C type, respectively. You can use them for communication -C between your program that calls DDASRT and the -C RES subroutine (and the JAC subroutine). They are not -C altered by DDASRT. If you do not need RPAR or IPAR, -C ignore these parameters by treating them as dummy -C arguments. If you do choose to use them, dimension -C them in your calling program and in RES (and in JAC) -C as arrays of appropriate length. -C -C JAC -- If you have set INFO(5)=0, you can ignore this parameter -C by treating it as a dummy argument. Otherwise, you must -C provide a subroutine of the form -C JAC(T,Y,YPRIME,PD,CJ,RPAR,IPAR) -C to define the matrix of partial derivatives -C PD=DG/DY+CJ*DG/DYPRIME -C CJ is a scalar which is input to JAC. -C For the given values of T,Y,YPRIME, the -C subroutine must evaluate the non-zero partial -C derivatives for each equation and each solution -C component, and store these values in the -C matrix PD. The elements of PD are set to zero -C before each call to JAC so only non-zero elements -C need to be defined. -C -C Subroutine JAC must not alter T,Y,(*),YPRIME(*), or CJ. -C You must declare the name JAC in an -C EXTERNAL STATEMENT in your program that calls -C DDASRT. You must dimension Y, YPRIME and PD -C in JAC. -C -C The way you must store the elements into the PD matrix -C depends on the structure of the matrix which you -C indicated by INFO(6). -C *** INFO(6)=0 -- Full (dense) matrix *** -C Give PD a first dimension of NEQ. -C When you evaluate the (non-zero) partial derivative -C of equation I with respect to variable J, you must -C store it in PD according to -C PD(I,J) = * DF(I)/DY(J)+CJ*DF(I)/DYPRIME(J)* -C *** INFO(6)=1 -- Banded JACOBIAN with ML lower and MU -C upper diagonal bands (refer to INFO(6) description -C of ML and MU) *** -C Give PD a first dimension of 2*ML+MU+1. -C when you evaluate the (non-zero) partial derivative -C of equation I with respect to variable J, you must -C store it in PD according to -C IROW = I - J + ML + MU + 1 -C PD(IROW,J) = *DF(I)/DY(J)+CJ*DF(I)/DYPRIME(J)* -C RPAR and IPAR are real and integer parameter arrays -C which you can use for communication between your calling -C program and your JACOBIAN subroutine JAC. They are not -C altered by DDASRT. If you do not need RPAR or IPAR, -C ignore these parameters by treating them as dummy -C arguments. If you do choose to use them, dimension -C them in your calling program and in JAC as arrays of -C appropriate length. -C -C G -- This is the name of the subroutine for defining constraint -C functions, whose roots are desired during the -C integration. It is to have the form -C SUBROUTINE G(NEQ,T,Y,NG,GOUT,RPAR,IPAR) -C DIMENSION Y(NEQ),GOUT(NG), -C where NEQ, T, Y and NG are INPUT, and the array GOUT is -C output. NEQ, T, and Y have the same meaning as in the -C RES routine, and GOUT is an array of length NG. -C For I=1,...,NG, this routine is to load into GOUT(I) -C the value at (T,Y) of the I-th constraint function G(I). -C DDASRT will find roots of the G(I) of odd multiplicity -C (that is, sign changes) as they occur during -C the integration. G must be declared EXTERNAL in the -C calling program. -C -C CAUTION..because of numerical errors in the functions -C G(I) due to roundoff and integration error, DDASRT -C may return false roots, or return the same root at two -C or more nearly equal values of T. If such false roots -C are suspected, the user should consider smaller error -C tolerances and/or higher precision in the evaluation of -C the G(I). -C -C If a root of some G(I) defines the end of the problem, -C the input to DDASRT should nevertheless allow -C integration to a point slightly past that ROOT, so -C that DDASRT can locate the root by interpolation. -C -C NG -- The number of constraint functions G(I). If there are none, -C set NG = 0, and pass a dummy name for G. -C -C JROOT -- This is an integer array of length NG. It is used only for -C output. On a return where one or more roots have been -C found, JROOT(I)=1 If G(I) has a root at T, -C or JROOT(I)=0 if not. -C -C -C -C OPTIONALLY REPLACEABLE NORM ROUTINE: -C DDASRT uses a weighted norm DDANRM to measure the size -C of vectors such as the estimated error in each step. -C A FUNCTION subprogram -C DOUBLE PRECISION FUNCTION DDANRM(NEQ,V,WT,RPAR,IPAR) -C DIMENSION V(NEQ),WT(NEQ) -C is used to define this norm. Here, V is the vector -C whose norm is to be computed, and WT is a vector of -C weights. A DDANRM routine has been included with DDASRT -C which computes the weighted root-mean-square norm -C given by -C DDANRM=SQRT((1/NEQ)*SUM(V(I)/WT(I))**2) -C this norm is suitable for most problems. In some -C special cases, it may be more convenient and/or -C efficient to define your own norm by writing a function -C subprogram to be called instead of DDANRM. This should -C ,however, be attempted only after careful thought and -C consideration. -C -C -C------OUTPUT-AFTER ANY RETURN FROM DDASRT---- -C -C The principal aim of the code is to return a computed solution at -C TOUT, although it is also possible to obtain intermediate results -C along the way. To find out whether the code achieved its goal -C or if the integration process was interrupted before the task was -C completed, you must check the IDID parameter. -C -C -C T -- The solution was successfully advanced to the -C output value of T. -C -C Y(*) -- Contains the computed solution approximation at T. -C -C YPRIME(*) -- Contains the computed derivative -C approximation at T. -C -C IDID -- Reports what the code did. -C -C *** Task completed *** -C Reported by positive values of IDID -C -C IDID = 1 -- A step was successfully taken in the -C intermediate-output mode. The code has not -C yet reached TOUT. -C -C IDID = 2 -- The integration to TSTOP was successfully -C completed (T=TSTOP) by stepping exactly to TSTOP. -C -C IDID = 3 -- The integration to TOUT was successfully -C completed (T=TOUT) by stepping past TOUT. -C Y(*) is obtained by interpolation. -C YPRIME(*) is obtained by interpolation. -C -C IDID = 4 -- The integration was successfully completed -C by finding one or more roots of G at T. -C -C *** Task interrupted *** -C Reported by negative values of IDID -C -C IDID = -1 -- A large amount of work has been expended. -C (About INFO(12) steps) -C -C IDID = -2 -- The error tolerances are too stringent. -C -C IDID = -3 -- The local error test cannot be satisfied -C because you specified a zero component in ATOL -C and the corresponding computed solution -C component is zero. Thus, a pure relative error -C test is impossible for this component. -C -C IDID = -6 -- DDASRT had repeated error test -C failures on the last attempted step. -C -C IDID = -7 -- The corrector could not converge. -C -C IDID = -8 -- The matrix of partial derivatives -C is singular. -C -C IDID = -9 -- The corrector could not converge. -C there were repeated error test failures -C in this step. -C -C IDID =-10 -- The corrector could not converge -C because IRES was equal to minus one. -C -C IDID =-11 -- IRES equal to -2 was encountered -C and control is being returned to the -C calling program. -C -C IDID =-12 -- DDASRT failed to compute the initial -C YPRIME. -C -C -C -C IDID = -13,..,-32 -- Not applicable for this code -C -C *** Task terminated *** -C Reported by the value of IDID=-33 -C -C IDID = -33 -- The code has encountered trouble from which -C it cannot recover. A message is printed -C explaining the trouble and control is returned -C to the calling program. For example, this occurs -C when invalid input is detected. -C -C RTOL, ATOL -- These quantities remain unchanged except when -C IDID = -2. In this case, the error tolerances have been -C increased by the code to values which are estimated to -C be appropriate for continuing the integration. However, -C the reported solution at T was obtained using the input -C values of RTOL and ATOL. -C -C RWORK, IWORK -- Contain information which is usually of no -C interest to the user but necessary for subsequent calls. -C However, you may find use for -C -C RWORK(3)--Which contains the step size H to be -C attempted on the next step. -C -C RWORK(4)--Which contains the current value of the -C independent variable, i.e., the farthest point -C integration has reached. This will be different -C from T only when interpolation has been -C performed (IDID=3). -C -C RWORK(7)--Which contains the stepsize used -C on the last successful step. -C -C IWORK(7)--Which contains the order of the method to -C be attempted on the next step. -C -C IWORK(8)--Which contains the order of the method used -C on the last step. -C -C IWORK(11)--Which contains the number of steps taken so -C far. -C -C IWORK(12)--Which contains the number of calls to RES -C so far. -C -C IWORK(13)--Which contains the number of evaluations of -C the matrix of partial derivatives needed so -C far. -C -C IWORK(14)--Which contains the total number -C of error test failures so far. -C -C IWORK(15)--Which contains the total number -C of convergence test failures so far. -C (includes singular iteration matrix -C failures.) -C -C IWORK(16)--Which contains the total number of calls -C to the constraint function g so far -C -C -C -C INPUT -- What to do to continue the integration -C (calls after the first) ** -C -C This code is organized so that subsequent calls to continue the -C integration involve little (if any) additional effort on your -C part. You must monitor the IDID parameter in order to determine -C what to do next. -C -C Recalling that the principal task of the code is to integrate -C from T to TOUT (the interval mode), usually all you will need -C to do is specify a new TOUT upon reaching the current TOUT. -C -C Do not alter any quantity not specifically permitted below, -C in particular do not alter NEQ,T,Y(*),YPRIME(*),RWORK(*),IWORK(*) -C or the differential equation in subroutine RES. Any such -C alteration constitutes a new problem and must be treated as such, -C i.e., you must start afresh. -C -C You cannot change from vector to scalar error control or vice -C versa (INFO(2)), but you can change the size of the entries of -C RTOL, ATOL. Increasing a tolerance makes the equation easier -C to integrate. Decreasing a tolerance will make the equation -C harder to integrate and should generally be avoided. -C -C You can switch from the intermediate-output mode to the -C interval mode (INFO(3)) or vice versa at any time. -C -C If it has been necessary to prevent the integration from going -C past a point TSTOP (INFO(4), RWORK(1)), keep in mind that the -C code will not integrate to any TOUT beyond the currently -C specified TSTOP. Once TSTOP has been reached you must change -C the value of TSTOP or set INFO(4)=0. You may change INFO(4) -C or TSTOP at any time but you must supply the value of TSTOP in -C RWORK(1) whenever you set INFO(4)=1. -C -C Do not change INFO(5), INFO(6), IWORK(1), or IWORK(2) -C unless you are going to restart the code. -C -C *** Following a completed task *** -C If -C IDID = 1, call the code again to continue the integration -C another step in the direction of TOUT. -C -C IDID = 2 or 3, define a new TOUT and call the code again. -C TOUT must be different from T. You cannot change -C the direction of integration without restarting. -C -C IDID = 4, call the code again to continue the integration -C another step in the direction of TOUT. You may -C change the functions in G after a return with IDID=4, -C but the number of constraint functions NG must remain -C the same. If you wish to change -C the functions in RES or in G, then you -C must restart the code. -C -C *** Following an interrupted task *** -C To show the code that you realize the task was -C interrupted and that you want to continue, you -C must take appropriate action and set INFO(1) = 1 -C If -C IDID = -1, The code has reached the step iteration. -C If you want to continue, set INFO(1) = 1 and -C call the code again. See also INFO(12). -C -C IDID = -2, The error tolerances RTOL, ATOL have been -C increased to values the code estimates appropriate -C for continuing. You may want to change them -C yourself. If you are sure you want to continue -C with relaxed error tolerances, set INFO(1)=1 and -C call the code again. -C -C IDID = -3, A solution component is zero and you set the -C corresponding component of ATOL to zero. If you -C are sure you want to continue, you must first -C alter the error criterion to use positive values -C for those components of ATOL corresponding to zero -C solution components, then set INFO(1)=1 and call -C the code again. -C -C IDID = -4,-5 --- Cannot occur with this code. -C -C IDID = -6, Repeated error test failures occurred on the -C last attempted step in DDASRT. A singularity in the -C solution may be present. If you are absolutely -C certain you want to continue, you should restart -C the integration. (Provide initial values of Y and -C YPRIME which are consistent) -C -C IDID = -7, Repeated convergence test failures occurred -C on the last attempted step in DDASRT. An inaccurate -C or ill-conditioned JACOBIAN may be the problem. If -C you are absolutely certain you want to continue, you -C should restart the integration. -C -C IDID = -8, The matrix of partial derivatives is singular. -C Some of your equations may be redundant. -C DDASRT cannot solve the problem as stated. -C It is possible that the redundant equations -C could be removed, and then DDASRT could -C solve the problem. It is also possible -C that a solution to your problem either -C does not exist or is not unique. -C -C IDID = -9, DDASRT had multiple convergence test -C failures, preceeded by multiple error -C test failures, on the last attempted step. -C It is possible that your problem -C is ill-posed, and cannot be solved -C using this code. Or, there may be a -C discontinuity or a singularity in the -C solution. If you are absolutely certain -C you want to continue, you should restart -C the integration. -C -C IDID =-10, DDASRT had multiple convergence test failures -C because IRES was equal to minus one. -C If you are absolutely certain you want -C to continue, you should restart the -C integration. -C -C IDID =-11, IRES=-2 was encountered, and control is being -C returned to the calling program. -C -C IDID =-12, DDASRT failed to compute the initial YPRIME. -C This could happen because the initial -C approximation to YPRIME was not very good, or -C if a YPRIME consistent with the initial Y -C does not exist. The problem could also be caused -C by an inaccurate or singular iteration matrix. -C -C -C -C IDID = -13,..,-32 --- Cannot occur with this code. -C -C *** Following a terminated task *** -C If IDID= -33, you cannot continue the solution of this -C problem. An attempt to do so will result in your -C run being terminated. -C -C --------------------------------------------------------------------- -C -C***REFERENCE -C K. E. Brenan, S. L. Campbell, and L. R. Petzold, Numerical -C Solution of Initial-Value Problems in Differential-Algebraic -C Equations, Elsevier, New York, 1989. -C -C***ROUTINES CALLED DDASTP,DDAINI,DDANRM,DDAWTS,DDATRP,DRCHEK,DROOTS, -C XERRWD,D1MACH -C***END PROLOGUE DDASRT -C -C**End -C - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - LOGICAL DONE - EXTERNAL RES, JAC, G - DIMENSION Y(*),YPRIME(*) - DIMENSION INFO(15) - DIMENSION RWORK(*),IWORK(*) - DIMENSION RTOL(*),ATOL(*) - DIMENSION RPAR(*),IPAR(*) - CHARACTER MSG*80 -C -C SET POINTERS INTO IWORK - PARAMETER (LML=1, LMU=2, LMXORD=3, LMTYPE=4, LNST=11, - * LNRE=12, LNJE=13, LETF=14, LCTF=15, LNGE=16, LNPD=17, - * LIRFND=18, LMXSTP=21, LIPVT=22, LJCALC=5, LPHASE=6, LK=7, - * LKOLD=8, LNS=9, LNSTL=10, LIWM=1) -C -C SET RELATIVE OFFSET INTO RWORK - PARAMETER (NPD=1) -C -C SET POINTERS INTO RWORK - PARAMETER (LTSTOP=1, LHMAX=2, LH=3, LTN=4, - * LCJ=5, LCJOLD=6, LHOLD=7, LS=8, LROUND=9, - * LALPHA=11, LBETA=17, LGAMMA=23, - * LPSI=29, LSIGMA=35, LT0=41, LTLAST=42, LALPHR=43, LX2=44, - * LDELTA=51) -C -C***FIRST EXECUTABLE STATEMENT DDASRT - IF(INFO(1).NE.0)GO TO 100 -C -C----------------------------------------------------------------------- -C THIS BLOCK IS EXECUTED FOR THE INITIAL CALL ONLY. -C IT CONTAINS CHECKING OF INPUTS AND INITIALIZATIONS. -C----------------------------------------------------------------------- -C -C FIRST CHECK INFO ARRAY TO MAKE SURE ALL ELEMENTS OF INFO -C ARE EITHER ZERO OR ONE. - DO 10 I=2,12 - IF(INFO(I).NE.0.AND.INFO(I).NE.1)GO TO 701 -10 CONTINUE -C - IF(NEQ.LE.0)GO TO 702 -C -C CHECK AND COMPUTE MAXIMUM ORDER - MXORD=5 - IF(INFO(9).EQ.0)GO TO 20 - MXORD=IWORK(LMXORD) - IF(MXORD.LT.1.OR.MXORD.GT.5)GO TO 703 -20 IWORK(LMXORD)=MXORD -C -C COMPUTE MTYPE,LENPD,LENRW.CHECK ML AND MU. - IF(INFO(6).NE.0)GO TO 40 - LENPD=NEQ**2 - LENRW=50+(IWORK(LMXORD)+4)*NEQ+LENPD+3*NG - IF(INFO(5).NE.0)GO TO 30 - IWORK(LMTYPE)=2 - GO TO 60 -30 IWORK(LMTYPE)=1 - GO TO 60 -40 IF(IWORK(LML).LT.0.OR.IWORK(LML).GE.NEQ)GO TO 717 - IF(IWORK(LMU).LT.0.OR.IWORK(LMU).GE.NEQ)GO TO 718 - LENPD=(2*IWORK(LML)+IWORK(LMU)+1)*NEQ - IF(INFO(5).NE.0)GO TO 50 - IWORK(LMTYPE)=5 - MBAND=IWORK(LML)+IWORK(LMU)+1 - MSAVE=(NEQ/MBAND)+1 - LENRW=50+(IWORK(LMXORD)+4)*NEQ+LENPD+2*MSAVE+3*NG - GO TO 60 -50 IWORK(LMTYPE)=4 - LENRW=50+(IWORK(LMXORD)+4)*NEQ+LENPD+3*NG -C -C CHECK LENGTHS OF RWORK AND IWORK -60 LENIW=21+NEQ - IWORK(LNPD)=LENPD - IF(LRW.LT.LENRW)GO TO 704 - IF(LIW.LT.LENIW)GO TO 705 -C -C CHECK TO SEE THAT TOUT IS DIFFERENT FROM T -C Also check to see that NG is larger than 0. - IF(TOUT .EQ. T)GO TO 719 - IF(NG .LT. 0) GO TO 730 -C -C CHECK HMAX - IF(INFO(7).EQ.0)GO TO 70 - HMAX=RWORK(LHMAX) - IF(HMAX.LE.0.0D0)GO TO 710 -70 CONTINUE -C -C CHECK AND COMPUTE MAXIMUM STEPS - MXSTP=500 - IF(INFO(12).EQ.0)GO TO 80 - MXSTP=IWORK(LMXSTP) - IF(MXSTP.LT.0)GO TO 716 -80 IWORK(LMXSTP)=MXSTP -C -C INITIALIZE COUNTERS - IWORK(LNST)=0 - IWORK(LNRE)=0 - IWORK(LNJE)=0 - IWORK(LNGE)=0 -C - IWORK(LNSTL)=0 - IDID=1 - GO TO 200 -C -C----------------------------------------------------------------------- -C THIS BLOCK IS FOR CONTINUATION CALLS -C ONLY. HERE WE CHECK INFO(1),AND IF THE -C LAST STEP WAS INTERRUPTED WE CHECK WHETHER -C APPROPRIATE ACTION WAS TAKEN. -C----------------------------------------------------------------------- -C -100 CONTINUE - IF(INFO(1).EQ.1)GO TO 110 - IF(INFO(1).NE.-1)GO TO 701 -C IF WE ARE HERE, THE LAST STEP WAS INTERRUPTED -C BY AN ERROR CONDITION FROM DDASTP,AND -C APPROPRIATE ACTION WAS NOT TAKEN. THIS -C IS A FATAL ERROR. - MSG = 'DASRT-- THE LAST STEP TERMINATED WITH A NEGATIVE' - CALL XERRWD(MSG,49,201,0,0,0,0,0,0.0D0,0.0D0) - MSG = 'DASRT-- VALUE (=I1) OF IDID AND NO APPROPRIATE' - CALL XERRWD(MSG,47,202,0,1,IDID,0,0,0.0D0,0.0D0) - MSG = 'DASRT-- ACTION WAS TAKEN. RUN TERMINATED' - CALL XERRWD(MSG,41,203,1,0,0,0,0,0.0D0,0.0D0) - RETURN -110 CONTINUE - IWORK(LNSTL)=IWORK(LNST) -C -C----------------------------------------------------------------------- -C THIS BLOCK IS EXECUTED ON ALL CALLS. -C THE ERROR TOLERANCE PARAMETERS ARE -C CHECKED, AND THE WORK ARRAY POINTERS -C ARE SET. -C----------------------------------------------------------------------- -C -200 CONTINUE -C CHECK RTOL,ATOL - NZFLG=0 - RTOLI=RTOL(1) - ATOLI=ATOL(1) - DO 210 I=1,NEQ - IF(INFO(2).EQ.1)RTOLI=RTOL(I) - IF(INFO(2).EQ.1)ATOLI=ATOL(I) - IF(RTOLI.GT.0.0D0.OR.ATOLI.GT.0.0D0)NZFLG=1 - IF(RTOLI.LT.0.0D0)GO TO 706 - IF(ATOLI.LT.0.0D0)GO TO 707 -210 CONTINUE - IF(NZFLG.EQ.0)GO TO 708 -C -C SET UP RWORK STORAGE.IWORK STORAGE IS FIXED -C IN DATA STATEMENT. - LG0=LDELTA+NEQ - LG1=LG0+NG - LGX=LG1+NG - LE=LGX+NG - LWT=LE+NEQ - LPHI=LWT+NEQ - LPD=LPHI+(IWORK(LMXORD)+1)*NEQ - LWM=LPD - NTEMP=NPD+IWORK(LNPD) - IF(INFO(1).EQ.1)GO TO 400 -C -C----------------------------------------------------------------------- -C THIS BLOCK IS EXECUTED ON THE INITIAL CALL -C ONLY. SET THE INITIAL STEP SIZE, AND -C THE ERROR WEIGHT VECTOR, AND PHI. -C COMPUTE INITIAL YPRIME, IF NECESSARY. -C----------------------------------------------------------------------- -C -300 CONTINUE - TN=T - IDID=1 -C -C SET ERROR WEIGHT VECTOR WT - CALL DDAWTS(NEQ,INFO(2),RTOL,ATOL,Y,RWORK(LWT),RPAR,IPAR) - DO 305 I = 1,NEQ - IF(RWORK(LWT+I-1).LE.0.0D0) GO TO 713 -305 CONTINUE -C -C COMPUTE UNIT ROUNDOFF AND HMIN - UROUND = D1MACH(4) - RWORK(LROUND) = UROUND - HMIN = 4.0D0*UROUND*DMAX1(DABS(T),DABS(TOUT)) -C -C CHECK INITIAL INTERVAL TO SEE THAT IT IS LONG ENOUGH - TDIST = DABS(TOUT - T) - IF(TDIST .LT. HMIN) GO TO 714 -C -C CHECK H0, IF THIS WAS INPUT - IF (INFO(8) .EQ. 0) GO TO 310 - HO = RWORK(LH) - IF ((TOUT - T)*HO .LT. 0.0D0) GO TO 711 - IF (HO .EQ. 0.0D0) GO TO 712 - GO TO 320 -310 CONTINUE -C -C COMPUTE INITIAL STEPSIZE, TO BE USED BY EITHER -C DDASTP OR DDAINI, DEPENDING ON INFO(11) - HO = 0.001D0*TDIST - YPNORM = DDANRM(NEQ,YPRIME,RWORK(LWT),RPAR,IPAR) - IF (YPNORM .GT. 0.5D0/HO) HO = 0.5D0/YPNORM - HO = DSIGN(HO,TOUT-T) -C ADJUST HO IF NECESSARY TO MEET HMAX BOUND -320 IF (INFO(7) .EQ. 0) GO TO 330 - RH = DABS(HO)/RWORK(LHMAX) - IF (RH .GT. 1.0D0) HO = HO/RH -C COMPUTE TSTOP, IF APPLICABLE -330 IF (INFO(4) .EQ. 0) GO TO 340 - TSTOP = RWORK(LTSTOP) - IF ((TSTOP - T)*HO .LT. 0.0D0) GO TO 715 - IF ((T + HO - TSTOP)*HO .GT. 0.0D0) HO = TSTOP - T - IF ((TSTOP - TOUT)*HO .LT. 0.0D0) GO TO 709 -C -C COMPUTE INITIAL DERIVATIVE, UPDATING TN AND Y, IF APPLICABLE -340 IF (INFO(11) .EQ. 0) GO TO 350 - CALL DDAINI(TN,Y,YPRIME,NEQ, - * RES,JAC,HO,RWORK(LWT),IDID,RPAR,IPAR, - * RWORK(LPHI),RWORK(LDELTA),RWORK(LE), - * RWORK(LWM),IWORK(LIWM),HMIN,RWORK(LROUND), - * INFO(10),NTEMP) - IF (IDID .LT. 0) GO TO 390 -C -C LOAD H WITH H0. STORE H IN RWORK(LH) -350 H = HO - RWORK(LH) = H -C -C LOAD Y AND H*YPRIME INTO PHI(*,1) AND PHI(*,2) -360 ITEMP = LPHI + NEQ - DO 370 I = 1,NEQ - RWORK(LPHI + I - 1) = Y(I) -370 RWORK(ITEMP + I - 1) = H*YPRIME(I) -C -C INITIALIZE T0 IN RWORK AND CHECK FOR A ZERO OF G NEAR THE -C INITIAL T. -C - RWORK(LT0) = T - IWORK(LIRFND) = 0 - RWORK(LPSI)=H - RWORK(LPSI+1)=2.0D0*H - IWORK(LKOLD)=1 - IF(NG .EQ. 0) GO TO 390 - CALL DRCHEK(1,G,NG,NEQ,T,TOUT,Y,RWORK(LE),RWORK(LPHI), - * RWORK(LPSI),IWORK(LKOLD),RWORK(LG0),RWORK(LG1), - * RWORK(LGX),JROOT,IRT,RWORK(LROUND),INFO(3), - * RWORK,IWORK,RPAR,IPAR) - IF(IRT .NE. 0) GO TO 732 -C -C Check for a root in the interval (T0,TN], unless DDASRT -C did not have to initialize YPRIME. -C - IF(NG .EQ. 0 .OR. INFO(11) .EQ. 0) GO TO 390 - CALL DRCHEK(3,G,NG,NEQ,TN,TOUT,Y,RWORK(LE),RWORK(LPHI), - * RWORK(LPSI),IWORK(LKOLD),RWORK(LG0),RWORK(LG1), - * RWORK(LGX),JROOT,IRT,RWORK(LROUND),INFO(3), - * RWORK,IWORK,RPAR,IPAR) - IF(IRT .NE. 1) GO TO 390 - IWORK(LIRFND) = 1 - IDID = 4 - T = RWORK(LT0) - GO TO 580 -C -390 GO TO 500 -C -C------------------------------------------------------- -C THIS BLOCK IS FOR CONTINUATION CALLS ONLY. ITS -C PURPOSE IS TO CHECK STOP CONDITIONS BEFORE -C TAKING A STEP. -C ADJUST H IF NECESSARY TO MEET HMAX BOUND -C------------------------------------------------------- -C -400 CONTINUE - UROUND=RWORK(LROUND) - DONE = .FALSE. - TN=RWORK(LTN) - H=RWORK(LH) - IF(NG .EQ. 0) GO TO 405 -C -C Check for a zero of G near TN. -C - CALL DRCHEK(2,G,NG,NEQ,TN,TOUT,Y,RWORK(LE),RWORK(LPHI), - * RWORK(LPSI),IWORK(LKOLD),RWORK(LG0),RWORK(LG1), - * RWORK(LGX),JROOT,IRT,RWORK(LROUND),INFO(3), - * RWORK,IWORK,RPAR,IPAR) - IF(IRT .NE. 1) GO TO 405 - IWORK(LIRFND) = 1 - IDID = 4 - T = RWORK(LT0) - DONE = .TRUE. - GO TO 490 -C -405 CONTINUE - IF(INFO(7) .EQ. 0) GO TO 410 - RH = DABS(H)/RWORK(LHMAX) - IF(RH .GT. 1.0D0) H = H/RH -410 CONTINUE - IF(T .EQ. TOUT) GO TO 719 - IF((T - TOUT)*H .GT. 0.0D0) GO TO 711 - IF(INFO(4) .EQ. 1) GO TO 430 - IF(INFO(3) .EQ. 1) GO TO 420 - IF((TN-TOUT)*H.LT.0.0D0)GO TO 490 - CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD), - * RWORK(LPHI),RWORK(LPSI)) - T=TOUT - IDID = 3 - DONE = .TRUE. - GO TO 490 -420 IF((TN-T)*H .LE. 0.0D0) GO TO 490 - IF((TN - TOUT)*H .GT. 0.0D0) GO TO 425 - CALL DDATRP(TN,TN,Y,YPRIME,NEQ,IWORK(LKOLD), - * RWORK(LPHI),RWORK(LPSI)) - T = TN - IDID = 1 - DONE = .TRUE. - GO TO 490 -425 CONTINUE - CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD), - * RWORK(LPHI),RWORK(LPSI)) - T = TOUT - IDID = 3 - DONE = .TRUE. - GO TO 490 -430 IF(INFO(3) .EQ. 1) GO TO 440 - TSTOP=RWORK(LTSTOP) - IF((TN-TSTOP)*H.GT.0.0D0) GO TO 715 - IF((TSTOP-TOUT)*H.LT.0.0D0)GO TO 709 - IF((TN-TOUT)*H.LT.0.0D0)GO TO 450 - CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD), - * RWORK(LPHI),RWORK(LPSI)) - T=TOUT - IDID = 3 - DONE = .TRUE. - GO TO 490 -440 TSTOP = RWORK(LTSTOP) - IF((TN-TSTOP)*H .GT. 0.0D0) GO TO 715 - IF((TSTOP-TOUT)*H .LT. 0.0D0) GO TO 709 - IF((TN-T)*H .LE. 0.0D0) GO TO 450 - IF((TN - TOUT)*H .GT. 0.0D0) GO TO 445 - CALL DDATRP(TN,TN,Y,YPRIME,NEQ,IWORK(LKOLD), - * RWORK(LPHI),RWORK(LPSI)) - T = TN - IDID = 1 - DONE = .TRUE. - GO TO 490 -445 CONTINUE - CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD), - * RWORK(LPHI),RWORK(LPSI)) - T = TOUT - IDID = 3 - DONE = .TRUE. - GO TO 490 -450 CONTINUE -C CHECK WHETHER WE ARE WITH IN ROUNDOFF OF TSTOP - IF(DABS(TN-TSTOP).GT.100.0D0*UROUND* - * (DABS(TN)+DABS(H)))GO TO 460 - CALL DDATRP(TN,TSTOP,Y,YPRIME,NEQ,IWORK(LKOLD), - * RWORK(LPHI),RWORK(LPSI)) - IDID=2 - T=TSTOP - DONE = .TRUE. - GO TO 490 -460 TNEXT=TN+H - IF((TNEXT-TSTOP)*H.LE.0.0D0)GO TO 490 - H=TSTOP-TN - RWORK(LH)=H -C -490 IF (DONE) GO TO 590 -C -C------------------------------------------------------- -C THE NEXT BLOCK CONTAINS THE CALL TO THE -C ONE-STEP INTEGRATOR DDASTP. -C THIS IS A LOOPING POINT FOR THE INTEGRATION STEPS. -C CHECK FOR TOO MANY STEPS. -C UPDATE WT. -C CHECK FOR TOO MUCH ACCURACY REQUESTED. -C COMPUTE MINIMUM STEPSIZE. -C------------------------------------------------------- -C -500 CONTINUE -C CHECK FOR FAILURE TO COMPUTE INITIAL YPRIME - IF (IDID .EQ. -12) GO TO 527 -C -C CHECK FOR TOO MANY STEPS - IF((IWORK(LNST)-IWORK(LNSTL)).LT.IWORK(LMXSTP)) - * GO TO 510 - IDID=-1 - GO TO 527 -C -C UPDATE WT -510 CALL DDAWTS(NEQ,INFO(2),RTOL,ATOL,RWORK(LPHI), - * RWORK(LWT),RPAR,IPAR) - DO 520 I=1,NEQ - IF(RWORK(I+LWT-1).GT.0.0D0)GO TO 520 - IDID=-3 - GO TO 527 -520 CONTINUE -C -C TEST FOR TOO MUCH ACCURACY REQUESTED. - R=DDANRM(NEQ,RWORK(LPHI),RWORK(LWT),RPAR,IPAR)* - * 100.0D0*UROUND - IF(R.LE.1.0D0)GO TO 525 -C MULTIPLY RTOL AND ATOL BY R AND RETURN - IF(INFO(2).EQ.1)GO TO 523 - RTOL(1)=R*RTOL(1) - ATOL(1)=R*ATOL(1) - IDID=-2 - GO TO 527 -523 DO 524 I=1,NEQ - RTOL(I)=R*RTOL(I) -524 ATOL(I)=R*ATOL(I) - IDID=-2 - GO TO 527 -525 CONTINUE -C -C COMPUTE MINIMUM STEPSIZE - HMIN=4.0D0*UROUND*DMAX1(DABS(TN),DABS(TOUT)) -C -C TEST H VS. HMAX - IF (INFO(7) .EQ. 0) GO TO 526 - RH = ABS(H)/RWORK(LHMAX) - IF (RH .GT. 1.0D0) H = H/RH -526 CONTINUE -C - CALL DDASTP(TN,Y,YPRIME,NEQ, - * RES,JAC,H,RWORK(LWT),INFO(1),IDID,RPAR,IPAR, - * RWORK(LPHI),RWORK(LDELTA),RWORK(LE), - * RWORK(LWM),IWORK(LIWM), - * RWORK(LALPHA),RWORK(LBETA),RWORK(LGAMMA), - * RWORK(LPSI),RWORK(LSIGMA), - * RWORK(LCJ),RWORK(LCJOLD),RWORK(LHOLD), - * RWORK(LS),HMIN,RWORK(LROUND), - * IWORK(LPHASE),IWORK(LJCALC),IWORK(LK), - * IWORK(LKOLD),IWORK(LNS),INFO(10),NTEMP) -527 IF(IDID.LT.0)GO TO 600 -C -C-------------------------------------------------------- -C THIS BLOCK HANDLES THE CASE OF A SUCCESSFUL RETURN -C FROM DDASTP (IDID=1). TEST FOR STOP CONDITIONS. -C-------------------------------------------------------- -C - IF(NG .EQ. 0) GO TO 529 -C -C Check for a zero of G near TN. -C - CALL DRCHEK(3,G,NG,NEQ,TN,TOUT,Y,RWORK(LE),RWORK(LPHI), - * RWORK(LPSI),IWORK(LKOLD),RWORK(LG0),RWORK(LG1), - * RWORK(LGX),JROOT,IRT,RWORK(LROUND),INFO(3), - * RWORK,IWORK,RPAR,IPAR) - IF(IRT .NE. 1) GO TO 529 - IWORK(LIRFND) = 1 - IDID = 4 - T = RWORK(LT0) - GO TO 580 -C -529 CONTINUE - IF(INFO(4).NE.0)GO TO 540 - IF(INFO(3).NE.0)GO TO 530 - IF((TN-TOUT)*H.LT.0.0D0)GO TO 500 - CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ, - * IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) - IDID=3 - T=TOUT - GO TO 580 -530 IF((TN-TOUT)*H.GE.0.0D0)GO TO 535 - T=TN - IDID=1 - GO TO 580 -535 CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ, - * IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) - IDID=3 - T=TOUT - GO TO 580 -540 IF(INFO(3).NE.0)GO TO 550 - IF((TN-TOUT)*H.LT.0.0D0)GO TO 542 - CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ, - * IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) - T=TOUT - IDID=3 - GO TO 580 -542 IF(DABS(TN-TSTOP).LE.100.0D0*UROUND* - * (DABS(TN)+DABS(H)))GO TO 545 - TNEXT=TN+H - IF((TNEXT-TSTOP)*H.LE.0.0D0)GO TO 500 - H=TSTOP-TN - GO TO 500 -545 CALL DDATRP(TN,TSTOP,Y,YPRIME,NEQ, - * IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) - IDID=2 - T=TSTOP - GO TO 580 -550 IF((TN-TOUT)*H.GE.0.0D0)GO TO 555 - IF(DABS(TN-TSTOP).LE.100.0D0*UROUND*(DABS(TN)+DABS(H)))GO TO 552 - T=TN - IDID=1 - GO TO 580 -552 CALL DDATRP(TN,TSTOP,Y,YPRIME,NEQ, - * IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) - IDID=2 - T=TSTOP - GO TO 580 -555 CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ, - * IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) - T=TOUT - IDID=3 -580 CONTINUE -C -C-------------------------------------------------------- -C ALL SUCCESSFUL RETURNS FROM DDASRT ARE MADE FROM -C THIS BLOCK. -C-------------------------------------------------------- -C -590 CONTINUE - RWORK(LTN)=TN - RWORK(LH)=H - RWORK(LTLAST) = T - RETURN -C -C----------------------------------------------------------------------- -C THIS BLOCK HANDLES ALL UNSUCCESSFUL -C RETURNS OTHER THAN FOR ILLEGAL INPUT. -C----------------------------------------------------------------------- -C -600 CONTINUE - ITEMP=-IDID - GO TO (610,620,630,690,690,640,650,660,670,675, - * 680,685), ITEMP -C -C THE MAXIMUM NUMBER OF STEPS WAS TAKEN BEFORE -C REACHING TOUT -610 MSG = 'DASRT-- AT CURRENT T (=R1) 500 STEPS' - CALL XERRWD(MSG,38,610,0,0,0,0,1,TN,0.0D0) - MSG = 'DASRT-- TAKEN ON THIS CALL BEFORE REACHING TOUT' - CALL XERRWD(MSG,48,611,0,0,0,0,0,0.0D0,0.0D0) - GO TO 690 -C -C TOO MUCH ACCURACY FOR MACHINE PRECISION -620 MSG = 'DASRT-- AT T (=R1) TOO MUCH ACCURACY REQUESTED' - CALL XERRWD(MSG,47,620,0,0,0,0,1,TN,0.0D0) - MSG = 'DASRT-- FOR PRECISION OF MACHINE. RTOL AND ATOL' - CALL XERRWD(MSG,48,621,0,0,0,0,0,0.0D0,0.0D0) - MSG = 'DASRT-- WERE INCREASED TO APPROPRIATE VALUES' - CALL XERRWD(MSG,45,622,0,0,0,0,0,0.0D0,0.0D0) -C - GO TO 690 -C WT(I) .LE. 0.0D0 FOR SOME I (NOT AT START OF PROBLEM) -630 MSG = 'DASRT-- AT T (=R1) SOME ELEMENT OF WT' - CALL XERRWD(MSG,38,630,0,0,0,0,1,TN,0.0D0) - MSG = 'DASRT-- HAS BECOME .LE. 0.0' - CALL XERRWD(MSG,28,631,0,0,0,0,0,0.0D0,0.0D0) - GO TO 690 -C -C ERROR TEST FAILED REPEATEDLY OR WITH H=HMIN -640 MSG = 'DASRT-- AT T (=R1) AND STEPSIZE H (=R2) THE' - CALL XERRWD(MSG,44,640,0,0,0,0,2,TN,H) - MSG='DASRT-- ERROR TEST FAILED REPEATEDLY OR WITH ABS(H)=HMIN' - CALL XERRWD(MSG,57,641,0,0,0,0,0,0.0D0,0.0D0) - GO TO 690 -C -C CORRECTOR CONVERGENCE FAILED REPEATEDLY OR WITH H=HMIN -650 MSG = 'DASRT-- AT T (=R1) AND STEPSIZE H (=R2) THE' - CALL XERRWD(MSG,44,650,0,0,0,0,2,TN,H) - MSG = 'DASRT-- CORRECTOR FAILED TO CONVERGE REPEATEDLY' - CALL XERRWD(MSG,48,651,0,0,0,0,0,0.0D0,0.0D0) - MSG = 'DASRT-- OR WITH ABS(H)=HMIN' - CALL XERRWD(MSG,28,652,0,0,0,0,0,0.0D0,0.0D0) - GO TO 690 -C -C THE ITERATION MATRIX IS SINGULAR -660 MSG = 'DASRT-- AT T (=R1) AND STEPSIZE H (=R2) THE' - CALL XERRWD(MSG,44,660,0,0,0,0,2,TN,H) - MSG = 'DASRT-- ITERATION MATRIX IS SINGULAR' - CALL XERRWD(MSG,37,661,0,0,0,0,0,0.0D0,0.0D0) - GO TO 690 -C -C CORRECTOR FAILURE PRECEEDED BY ERROR TEST FAILURES. -670 MSG = 'DASRT-- AT T (=R1) AND STEPSIZE H (=R2) THE' - CALL XERRWD(MSG,44,670,0,0,0,0,2,TN,H) - MSG = 'DASRT-- CORRECTOR COULD NOT CONVERGE. ALSO, THE' - CALL XERRWD(MSG,49,671,0,0,0,0,0,0.0D0,0.0D0) - MSG = 'DASRT-- ERROR TEST FAILED REPEATEDLY.' - CALL XERRWD(MSG,38,672,0,0,0,0,0,0.0D0,0.0D0) - GO TO 690 -C -C CORRECTOR FAILURE BECAUSE IRES = -1 -675 MSG = 'DASRT-- AT T (=R1) AND STEPSIZE H (=R2) THE' - CALL XERRWD(MSG,44,675,0,0,0,0,2,TN,H) - MSG = 'DASRT-- CORRECTOR COULD NOT CONVERGE BECAUSE' - CALL XERRWD(MSG,45,676,0,0,0,0,0,0.0D0,0.0D0) - MSG = 'DASRT-- IRES WAS EQUAL TO MINUS ONE' - CALL XERRWD(MSG,36,677,0,0,0,0,0,0.0D0,0.0D0) - GO TO 690 -C -C FAILURE BECAUSE IRES = -2 -680 MSG = 'DASRT-- AT T (=R1) AND STEPSIZE H (=R2)' - CALL XERRWD(MSG,40,680,0,0,0,0,2,TN,H) - MSG = 'DASRT-- IRES WAS EQUAL TO MINUS TWO' - CALL XERRWD(MSG,36,681,0,0,0,0,0,0.0D0,0.0D0) - GO TO 690 -C -C FAILED TO COMPUTE INITIAL YPRIME -685 MSG = 'DASRT-- AT T (=R1) AND STEPSIZE H (=R2) THE' - CALL XERRWD(MSG,44,685,0,0,0,0,2,TN,HO) - MSG = 'DASRT-- INITIAL YPRIME COULD NOT BE COMPUTED' - CALL XERRWD(MSG,45,686,0,0,0,0,0,0.0D0,0.0D0) - GO TO 690 -690 CONTINUE - INFO(1)=-1 - T=TN - RWORK(LTN)=TN - RWORK(LH)=H - RETURN -C----------------------------------------------------------------------- -C THIS BLOCK HANDLES ALL ERROR RETURNS DUE -C TO ILLEGAL INPUT, AS DETECTED BEFORE CALLING -C DDASTP. FIRST THE ERROR MESSAGE ROUTINE IS -C CALLED. IF THIS HAPPENS TWICE IN -C SUCCESSION, EXECUTION IS TERMINATED -C -C----------------------------------------------------------------------- -701 MSG = 'DASRT-- SOME ELEMENT OF INFO VECTOR IS NOT ZERO OR ONE' - CALL XERRWD(MSG,55,1,0,0,0,0,0,0.0D0,0.0D0) - GO TO 750 -702 MSG = 'DASRT-- NEQ (=I1) .LE. 0' - CALL XERRWD(MSG,25,2,0,1,NEQ,0,0,0.0D0,0.0D0) - GO TO 750 -703 MSG = 'DASRT-- MAXORD (=I1) NOT IN RANGE' - CALL XERRWD(MSG,34,3,0,1,MXORD,0,0,0.0D0,0.0D0) - GO TO 750 -704 MSG='DASRT-- RWORK LENGTH NEEDED, LENRW (=I1), EXCEEDS LRW (=I2)' - CALL XERRWD(MSG,60,4,0,2,LENRW,LRW,0,0.0D0,0.0D0) - GO TO 750 -705 MSG='DASRT-- IWORK LENGTH NEEDED, LENIW (=I1), EXCEEDS LIW (=I2)' - CALL XERRWD(MSG,60,5,0,2,LENIW,LIW,0,0.0D0,0.0D0) - GO TO 750 -706 MSG = 'DASRT-- SOME ELEMENT OF RTOL IS .LT. 0' - CALL XERRWD(MSG,39,6,0,0,0,0,0,0.0D0,0.0D0) - GO TO 750 -707 MSG = 'DASRT-- SOME ELEMENT OF ATOL IS .LT. 0' - CALL XERRWD(MSG,39,7,0,0,0,0,0,0.0D0,0.0D0) - GO TO 750 -708 MSG = 'DASRT-- ALL ELEMENTS OF RTOL AND ATOL ARE ZERO' - CALL XERRWD(MSG,47,8,0,0,0,0,0,0.0D0,0.0D0) - GO TO 750 -709 MSG='DASRT-- INFO(4) = 1 AND TSTOP (=R1) BEHIND TOUT (=R2)' - CALL XERRWD(MSG,54,9,0,0,0,0,2,TSTOP,TOUT) - GO TO 750 -710 MSG = 'DASRT-- HMAX (=R1) .LT. 0.0' - CALL XERRWD(MSG,28,10,0,0,0,0,1,HMAX,0.0D0) - GO TO 750 -711 MSG = 'DASRT-- TOUT (=R1) BEHIND T (=R2)' - CALL XERRWD(MSG,34,11,0,0,0,0,2,TOUT,T) - GO TO 750 -712 MSG = 'DASRT-- INFO(8)=1 AND H0=0.0' - CALL XERRWD(MSG,29,12,0,0,0,0,0,0.0D0,0.0D0) - GO TO 750 -713 MSG = 'DASRT-- SOME ELEMENT OF WT IS .LE. 0.0' - CALL XERRWD(MSG,39,13,0,0,0,0,0,0.0D0,0.0D0) - GO TO 750 -714 MSG='DASRT-- TOUT (=R1) TOO CLOSE TO T (=R2) TO START INTEGRATION' - CALL XERRWD(MSG,60,14,0,0,0,0,2,TOUT,T) - GO TO 750 -715 MSG = 'DASRT-- INFO(4)=1 AND TSTOP (=R1) BEHIND T (=R2)' - CALL XERRWD(MSG,49,15,0,0,0,0,2,TSTOP,T) - GO TO 750 -716 MSG = 'DASRT-- INFO(12)=1 AND MXSTP (=I1) .LT. 0' - CALL XERRWD(MSG,42,16,0,1,IWORK(LMXSTP),0,0,0.0D0,0.0D0) - GO TO 750 -717 MSG = 'DASRT-- ML (=I1) ILLEGAL. EITHER .LT. 0 OR .GT. NEQ' - CALL XERRWD(MSG,52,17,0,1,IWORK(LML),0,0,0.0D0,0.0D0) - GO TO 750 -718 MSG = 'DASRT-- MU (=I1) ILLEGAL. EITHER .LT. 0 OR .GT. NEQ' - CALL XERRWD(MSG,52,18,0,1,IWORK(LMU),0,0,0.0D0,0.0D0) - GO TO 750 -719 MSG = 'DASRT-- TOUT (=R1) IS EQUAL TO T (=R2)' - CALL XERRWD(MSG,39,19,0,0,0,0,2,TOUT,T) - GO TO 750 -730 MSG = 'DASRT-- NG (=I1) .LT. 0' - CALL XERRWD(MSG,24,30,1,1,NG,0,0,0.0D0,0.0D0) - GO TO 750 -732 MSG = 'DASRT-- ONE OR MORE COMPONENTS OF G HAS A ROOT' - CALL XERRWD(MSG,47,32,1,0,0,0,0,0.0D0,0.0D0) - MSG = ' TOO NEAR TO THE INITIAL POINT' - CALL XERRWD(MSG,38,32,1,0,0,0,0,0.0D0,0.0D0) -750 IF(INFO(1).EQ.-1) GO TO 760 - INFO(1)=-1 - IDID=-33 - RETURN -760 MSG = 'DASRT-- REPEATED OCCURRENCES OF ILLEGAL INPUT' - CALL XERRWD(MSG,46,801,0,0,0,0,0,0.0D0,0.0D0) -770 MSG = 'DASRT-- RUN TERMINATED. APPARENT INFINITE LOOP' - CALL XERRWD(MSG,47,802,1,0,0,0,0,0.0D0,0.0D0) - RETURN -C-----------END OF SUBROUTINE DDASRT------------------------------------ - END
--- a/liboctave/cruft/dasrt/drchek.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,172 +0,0 @@ - SUBROUTINE DRCHEK (JOB, G, NG, NEQ, TN, TOUT, Y, YP, PHI, PSI, - * KOLD, G0, G1, GX, JROOT, IRT, UROUND, INFO3, RWORK, IWORK, - * RPAR, IPAR) -C -C***BEGIN PROLOGUE DRCHEK -C***REFER TO DDASRT -C***ROUTINES CALLED DDATRP, DROOTS, DCOPY -C***DATE WRITTEN 821001 (YYMMDD) -C***REVISION DATE 900926 (YYMMDD) -C***END PROLOGUE DRCHEK -C - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - PARAMETER (LNGE=16, LIRFND=18, LLAST=19, LIMAX=20, - * LT0=41, LTLAST=42, LALPHR=43, LX2=44) - EXTERNAL G - INTEGER JOB, NG, NEQ, KOLD, JROOT, IRT, INFO3, IWORK, IPAR - DOUBLE PRECISION TN, TOUT, Y, YP, PHI, PSI, G0, G1, GX, UROUND, - * RWORK, RPAR - DIMENSION Y(*), YP(*), PHI(NEQ,*), PSI(*), - 1 G0(*), G1(*), GX(*), JROOT(*), RWORK(*), IWORK(*) - INTEGER I, JFLAG - DOUBLE PRECISION H - DOUBLE PRECISION HMING, T1, TEMP1, TEMP2, X - LOGICAL ZROOT -C----------------------------------------------------------------------- -C THIS ROUTINE CHECKS FOR THE PRESENCE OF A ROOT IN THE -C VICINITY OF THE CURRENT T, IN A MANNER DEPENDING ON THE -C INPUT FLAG JOB. IT CALLS SUBROUTINE DROOTS TO LOCATE THE ROOT -C AS PRECISELY AS POSSIBLE. -C -C IN ADDITION TO VARIABLES DESCRIBED PREVIOUSLY, DRCHEK -C USES THE FOLLOWING FOR COMMUNICATION.. -C JOB = INTEGER FLAG INDICATING TYPE OF CALL.. -C JOB = 1 MEANS THE PROBLEM IS BEING INITIALIZED, AND DRCHEK -C IS TO LOOK FOR A ROOT AT OR VERY NEAR THE INITIAL T. -C JOB = 2 MEANS A CONTINUATION CALL TO THE SOLVER WAS JUST -C MADE, AND DRCHEK IS TO CHECK FOR A ROOT IN THE -C RELEVANT PART OF THE STEP LAST TAKEN. -C JOB = 3 MEANS A SUCCESSFUL STEP WAS JUST TAKEN, AND DRCHEK -C IS TO LOOK FOR A ROOT IN THE INTERVAL OF THE STEP. -C G0 = ARRAY OF LENGTH NG, CONTAINING THE VALUE OF G AT T = T0. -C G0 IS INPUT FOR JOB .GE. 2 AND ON OUTPUT IN ALL CASES. -C G1,GX = ARRAYS OF LENGTH NG FOR WORK SPACE. -C IRT = COMPLETION FLAG.. -C IRT = 0 MEANS NO ROOT WAS FOUND. -C IRT = -1 MEANS JOB = 1 AND A ROOT WAS FOUND TOO NEAR TO T. -C IRT = 1 MEANS A LEGITIMATE ROOT WAS FOUND (JOB = 2 OR 3). -C ON RETURN, T0 IS THE ROOT LOCATION, AND Y IS THE -C CORRESPONDING SOLUTION VECTOR. -C T0 = VALUE OF T AT ONE ENDPOINT OF INTERVAL OF INTEREST. ONLY -C ROOTS BEYOND T0 IN THE DIRECTION OF INTEGRATION ARE SOUGHT. -C T0 IS INPUT IF JOB .GE. 2, AND OUTPUT IN ALL CASES. -C T0 IS UPDATED BY DRCHEK, WHETHER A ROOT IS FOUND OR NOT. -C STORED IN THE GLOBAL ARRAY RWORK. -C TLAST = LAST VALUE OF T RETURNED BY THE SOLVER (INPUT ONLY). -C STORED IN THE GLOBAL ARRAY RWORK. -C TOUT = FINAL OUTPUT TIME FOR THE SOLVER. -C IRFND = INPUT FLAG SHOWING WHETHER THE LAST STEP TAKEN HAD A ROOT. -C IRFND = 1 IF IT DID, = 0 IF NOT. -C STORED IN THE GLOBAL ARRAY IWORK. -C INFO3 = COPY OF INFO(3) (INPUT ONLY). -C----------------------------------------------------------------------- -C - H = PSI(1) - IRT = 0 - DO 10 I = 1,NG - 10 JROOT(I) = 0 - HMING = (DABS(TN) + DABS(H))*UROUND*100.0D0 -C - GO TO (100, 200, 300), JOB -C -C EVALUATE G AT INITIAL T (STORED IN RWORK(LT0)), AND CHECK FOR -C ZERO VALUES.---------------------------------------------------------- - 100 CONTINUE - CALL DDATRP(TN,RWORK(LT0),Y,YP,NEQ,KOLD,PHI,PSI) - CALL G (NEQ, RWORK(LT0), Y, NG, G0, RPAR, IPAR) - IWORK(LNGE) = 1 - ZROOT = .FALSE. - DO 110 I = 1,NG - 110 IF (DABS(G0(I)) .LE. 0.0D0) ZROOT = .TRUE. - IF (.NOT. ZROOT) GO TO 190 -C G HAS A ZERO AT T. LOOK AT G AT T + (SMALL INCREMENT). -------------- - TEMP1 = DSIGN(HMING,H) - RWORK(LT0) = RWORK(LT0) + TEMP1 - TEMP2 = TEMP1/H - DO 120 I = 1,NEQ - 120 Y(I) = Y(I) + TEMP2*PHI(I,2) - CALL G (NEQ, RWORK(LT0), Y, NG, G0, RPAR, IPAR) - IWORK(LNGE) = IWORK(LNGE) + 1 - ZROOT = .FALSE. - DO 130 I = 1,NG - 130 IF (DABS(G0(I)) .LE. 0.0D0) ZROOT = .TRUE. - IF (.NOT. ZROOT) GO TO 190 -C G HAS A ZERO AT T AND ALSO CLOSE TO T. TAKE ERROR RETURN. ----------- - IRT = -1 - RETURN -C - 190 CONTINUE - RETURN -C -C - 200 CONTINUE - IF (IWORK(LIRFND) .EQ. 0) GO TO 260 -C IF A ROOT WAS FOUND ON THE PREVIOUS STEP, EVALUATE G0 = G(T0). ------- - CALL DDATRP (TN, RWORK(LT0), Y, YP, NEQ, KOLD, PHI, PSI) - CALL G (NEQ, RWORK(LT0), Y, NG, G0, RPAR, IPAR) - IWORK(LNGE) = IWORK(LNGE) + 1 - ZROOT = .FALSE. - DO 210 I = 1,NG - 210 IF (DABS(G0(I)) .LE. 0.0D0) ZROOT = .TRUE. - IF (.NOT. ZROOT) GO TO 260 -C G HAS A ZERO AT T0. LOOK AT G AT T + (SMALL INCREMENT). ------------- - TEMP1 = DSIGN(HMING,H) - RWORK(LT0) = RWORK(LT0) + TEMP1 - IF ((RWORK(LT0) - TN)*H .LT. 0.0D0) GO TO 230 - TEMP2 = TEMP1/H - DO 220 I = 1,NEQ - 220 Y(I) = Y(I) + TEMP2*PHI(I,2) - GO TO 240 - 230 CALL DDATRP (TN, RWORK(LT0), Y, YP, NEQ, KOLD, PHI, PSI) - 240 CALL G (NEQ, RWORK(LT0), Y, NG, G0, RPAR, IPAR) - IWORK(LNGE) = IWORK(LNGE) + 1 - ZROOT = .FALSE. - DO 250 I = 1,NG - IF (DABS(G0(I)) .GT. 0.0D0) GO TO 250 - JROOT(I) = 1 - ZROOT = .TRUE. - 250 CONTINUE - IF (.NOT. ZROOT) GO TO 260 -C G HAS A ZERO AT T0 AND ALSO CLOSE TO T0. RETURN ROOT. --------------- - IRT = 1 - RETURN -C HERE, G0 DOES NOT HAVE A ROOT -C G0 HAS NO ZERO COMPONENTS. PROCEED TO CHECK RELEVANT INTERVAL. ------ - 260 IF (TN .EQ. RWORK(LTLAST)) GO TO 390 -C - 300 CONTINUE -C SET T1 TO TN OR TOUT, WHICHEVER COMES FIRST, AND GET G AT T1. -------- - IF (INFO3 .EQ. 1) GO TO 310 - IF ((TOUT - TN)*H .GE. 0.0D0) GO TO 310 - T1 = TOUT - IF ((T1 - RWORK(LT0))*H .LE. 0.0D0) GO TO 390 - CALL DDATRP (TN, T1, Y, YP, NEQ, KOLD, PHI, PSI) - GO TO 330 - 310 T1 = TN - DO 320 I = 1,NEQ - 320 Y(I) = PHI(I,1) - 330 CALL G (NEQ, T1, Y, NG, G1, RPAR, IPAR) - IWORK(LNGE) = IWORK(LNGE) + 1 -C CALL DROOTS TO SEARCH FOR ROOT IN INTERVAL FROM T0 TO T1. ------------ - JFLAG = 0 - 350 CONTINUE - CALL DROOTS (NG, HMING, JFLAG, RWORK(LT0), T1, G0, G1, GX, X, - * JROOT, IWORK(LIMAX), IWORK(LLAST), RWORK(LALPHR), - * RWORK(LX2)) - IF (JFLAG .GT. 1) GO TO 360 - CALL DDATRP (TN, X, Y, YP, NEQ, KOLD, PHI, PSI) - CALL G (NEQ, X, Y, NG, GX, RPAR, IPAR) - IWORK(LNGE) = IWORK(LNGE) + 1 - GO TO 350 - 360 RWORK(LT0) = X - CALL DCOPY (NG, GX, 1, G0, 1) - IF (JFLAG .EQ. 4) GO TO 390 -C FOUND A ROOT. INTERPOLATE TO X AND RETURN. -------------------------- - CALL DDATRP (TN, X, Y, YP, NEQ, KOLD, PHI, PSI) - IRT = 1 - RETURN -C - 390 CONTINUE - RETURN -C---------------------- END OF SUBROUTINE DRCHEK ----------------------- - END
--- a/liboctave/cruft/dasrt/droots.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,217 +0,0 @@ - SUBROUTINE DROOTS (NG, HMIN, JFLAG, X0, X1, G0, G1, GX, X, JROOT, - * IMAX, LAST, ALPHA, X2) -C -C***BEGIN PROLOGUE DROOTS -C***REFER TO DDASRT -C***ROUTINES CALLED DCOPY -C***DATE WRITTEN 821001 (YYMMDD) -C***REVISION DATE 900926 (YYMMDD) -C***END PROLOGUE DROOTS -C - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - INTEGER NG, JFLAG, JROOT, IMAX, LAST - DOUBLE PRECISION HMIN, X0, X1, G0, G1, GX, X, ALPHA, X2 - DIMENSION G0(NG), G1(NG), GX(NG), JROOT(NG) -C----------------------------------------------------------------------- -C THIS SUBROUTINE FINDS THE LEFTMOST ROOT OF A SET OF ARBITRARY -C FUNCTIONS GI(X) (I = 1,...,NG) IN AN INTERVAL (X0,X1). ONLY ROOTS -C OF ODD MULTIPLICITY (I.E. CHANGES OF SIGN OF THE GI) ARE FOUND. -C HERE THE SIGN OF X1 - X0 IS ARBITRARY, BUT IS CONSTANT FOR A GIVEN -C PROBLEM, AND -LEFTMOST- MEANS NEAREST TO X0. -C THE VALUES OF THE VECTOR-VALUED FUNCTION G(X) = (GI, I=1...NG) -C ARE COMMUNICATED THROUGH THE CALL SEQUENCE OF DROOTS. -C THE METHOD USED IS THE ILLINOIS ALGORITHM. -C -C REFERENCE.. -C KATHIE L. HIEBERT AND LAWRENCE F. SHAMPINE, IMPLICITLY DEFINED -C OUTPUT POINTS FOR SOLUTIONS OF ODE-S, SANDIA REPORT SAND80-0180, -C FEBRUARY, 1980. -C -C DESCRIPTION OF PARAMETERS. -C -C NG = NUMBER OF FUNCTIONS GI, OR THE NUMBER OF COMPONENTS OF -C THE VECTOR VALUED FUNCTION G(X). INPUT ONLY. -C -C HMIN = RESOLUTION PARAMETER IN X. INPUT ONLY. WHEN A ROOT IS -C FOUND, IT IS LOCATED ONLY TO WITHIN AN ERROR OF HMIN IN X. -C TYPICALLY, HMIN SHOULD BE SET TO SOMETHING ON THE ORDER OF -C 100 * UROUND * MAX(ABS(X0),ABS(X1)), -C WHERE UROUND IS THE UNIT ROUNDOFF OF THE MACHINE. -C -C JFLAG = INTEGER FLAG FOR INPUT AND OUTPUT COMMUNICATION. -C -C ON INPUT, SET JFLAG = 0 ON THE FIRST CALL FOR THE PROBLEM, -C AND LEAVE IT UNCHANGED UNTIL THE PROBLEM IS COMPLETED. -C (THE PROBLEM IS COMPLETED WHEN JFLAG .GE. 2 ON RETURN.) -C -C ON OUTPUT, JFLAG HAS THE FOLLOWING VALUES AND MEANINGS.. -C JFLAG = 1 MEANS DROOTS NEEDS A VALUE OF G(X). SET GX = G(X) -C AND CALL DROOTS AGAIN. -C JFLAG = 2 MEANS A ROOT HAS BEEN FOUND. THE ROOT IS -C AT X, AND GX CONTAINS G(X). (ACTUALLY, X IS THE -C RIGHTMOST APPROXIMATION TO THE ROOT ON AN INTERVAL -C (X0,X1) OF SIZE HMIN OR LESS.) -C JFLAG = 3 MEANS X = X1 IS A ROOT, WITH ONE OR MORE OF THE GI -C BEING ZERO AT X1 AND NO SIGN CHANGES IN (X0,X1). -C GX CONTAINS G(X) ON OUTPUT. -C JFLAG = 4 MEANS NO ROOTS (OF ODD MULTIPLICITY) WERE -C FOUND IN (X0,X1) (NO SIGN CHANGES). -C -C X0,X1 = ENDPOINTS OF THE INTERVAL WHERE ROOTS ARE SOUGHT. -C X1 AND X0 ARE INPUT WHEN JFLAG = 0 (FIRST CALL), AND -C MUST BE LEFT UNCHANGED BETWEEN CALLS UNTIL THE PROBLEM IS -C COMPLETED. X0 AND X1 MUST BE DISTINCT, BUT X1 - X0 MAY BE -C OF EITHER SIGN. HOWEVER, THE NOTION OF -LEFT- AND -RIGHT- -C WILL BE USED TO MEAN NEARER TO X0 OR X1, RESPECTIVELY. -C WHEN JFLAG .GE. 2 ON RETURN, X0 AND X1 ARE OUTPUT, AND -C ARE THE ENDPOINTS OF THE RELEVANT INTERVAL. -C -C G0,G1 = ARRAYS OF LENGTH NG CONTAINING THE VECTORS G(X0) AND G(X1), -C RESPECTIVELY. WHEN JFLAG = 0, G0 AND G1 ARE INPUT AND -C NONE OF THE G0(I) SHOULD BE BE ZERO. -C WHEN JFLAG .GE. 2 ON RETURN, G0 AND G1 ARE OUTPUT. -C -C GX = ARRAY OF LENGTH NG CONTAINING G(X). GX IS INPUT -C WHEN JFLAG = 1, AND OUTPUT WHEN JFLAG .GE. 2. -C -C X = INDEPENDENT VARIABLE VALUE. OUTPUT ONLY. -C WHEN JFLAG = 1 ON OUTPUT, X IS THE POINT AT WHICH G(X) -C IS TO BE EVALUATED AND LOADED INTO GX. -C WHEN JFLAG = 2 OR 3, X IS THE ROOT. -C WHEN JFLAG = 4, X IS THE RIGHT ENDPOINT OF THE INTERVAL, X1. -C -C JROOT = INTEGER ARRAY OF LENGTH NG. OUTPUT ONLY. -C WHEN JFLAG = 2 OR 3, JROOT INDICATES WHICH COMPONENTS -C OF G(X) HAVE A ROOT AT X. JROOT(I) IS 1 IF THE I-TH -C COMPONENT HAS A ROOT, AND JROOT(I) = 0 OTHERWISE. -C -C IMAX, LAST, ALPHA, X2 = -C BOOKKEEPING VARIABLES WHICH MUST BE SAVED FROM CALL -C TO CALL. THEY ARE SAVED INSIDE THE CALLING ROUTINE, -C BUT THEY ARE USED ONLY WITHIN THIS ROUTINE. -C----------------------------------------------------------------------- - INTEGER I, IMXOLD, NXLAST - DOUBLE PRECISION T2, TMAX, ZERO - LOGICAL ZROOT, SGNCHG, XROOT - DATA ZERO/0.0D0/ -C - IF (JFLAG .EQ. 1) GO TO 200 -C JFLAG .NE. 1. CHECK FOR CHANGE IN SIGN OF G OR ZERO AT X1. ---------- - IMAX = 0 - TMAX = ZERO - ZROOT = .FALSE. - DO 120 I = 1,NG - IF (DABS(G1(I)) .GT. ZERO) GO TO 110 - ZROOT = .TRUE. - GO TO 120 -C AT THIS POINT, G0(I) HAS BEEN CHECKED AND CANNOT BE ZERO. ------------ - 110 IF (DSIGN(1.0D0,G0(I)) .EQ. DSIGN(1.0D0,G1(I))) GO TO 120 - T2 = DABS(G1(I)/(G1(I)-G0(I))) - IF (T2 .LE. TMAX) GO TO 120 - TMAX = T2 - IMAX = I - 120 CONTINUE - IF (IMAX .GT. 0) GO TO 130 - SGNCHG = .FALSE. - GO TO 140 - 130 SGNCHG = .TRUE. - 140 IF (.NOT. SGNCHG) GO TO 400 -C THERE IS A SIGN CHANGE. FIND THE FIRST ROOT IN THE INTERVAL. -------- - XROOT = .FALSE. - NXLAST = 0 - LAST = 1 -C -C REPEAT UNTIL THE FIRST ROOT IN THE INTERVAL IS FOUND. LOOP POINT. --- - 150 CONTINUE - IF (XROOT) GO TO 300 - IF (NXLAST .EQ. LAST) GO TO 160 - ALPHA = 1.0D0 - GO TO 180 - 160 IF (LAST .EQ. 0) GO TO 170 - ALPHA = 0.5D0*ALPHA - GO TO 180 - 170 ALPHA = 2.0D0*ALPHA - 180 X2 = X1 - (X1-X0)*G1(IMAX)/(G1(IMAX) - ALPHA*G0(IMAX)) - IF ((DABS(X2-X0) .LT. HMIN) .AND. - 1 (DABS(X1-X0) .GT. 10.0D0*HMIN)) X2 = X0 + 0.1D0*(X1-X0) - JFLAG = 1 - X = X2 -C RETURN TO THE CALLING ROUTINE TO GET A VALUE OF GX = G(X). ----------- - RETURN -C CHECK TO SEE IN WHICH INTERVAL G CHANGES SIGN. ----------------------- - 200 IMXOLD = IMAX - IMAX = 0 - TMAX = ZERO - ZROOT = .FALSE. - DO 220 I = 1,NG - IF (DABS(GX(I)) .GT. ZERO) GO TO 210 - ZROOT = .TRUE. - GO TO 220 -C NEITHER G0(I) NOR GX(I) CAN BE ZERO AT THIS POINT. ------------------- - 210 IF (DSIGN(1.0D0,G0(I)) .EQ. DSIGN(1.0D0,GX(I))) GO TO 220 - T2 = DABS(GX(I)/(GX(I) - G0(I))) - IF (T2 .LE. TMAX) GO TO 220 - TMAX = T2 - IMAX = I - 220 CONTINUE - IF (IMAX .GT. 0) GO TO 230 - SGNCHG = .FALSE. - IMAX = IMXOLD - GO TO 240 - 230 SGNCHG = .TRUE. - 240 NXLAST = LAST - IF (.NOT. SGNCHG) GO TO 250 -C SIGN CHANGE BETWEEN X0 AND X2, SO REPLACE X1 WITH X2. ---------------- - X1 = X2 - CALL DCOPY (NG, GX, 1, G1, 1) - LAST = 1 - XROOT = .FALSE. - GO TO 270 - 250 IF (.NOT. ZROOT) GO TO 260 -C ZERO VALUE AT X2 AND NO SIGN CHANGE IN (X0,X2), SO X2 IS A ROOT. ----- - X1 = X2 - CALL DCOPY (NG, GX, 1, G1, 1) - XROOT = .TRUE. - GO TO 270 -C NO SIGN CHANGE BETWEEN X0 AND X2. REPLACE X0 WITH X2. --------------- - 260 CONTINUE - CALL DCOPY (NG, GX, 1, G0, 1) - X0 = X2 - LAST = 0 - XROOT = .FALSE. - 270 IF (DABS(X1-X0) .LE. HMIN) XROOT = .TRUE. - GO TO 150 -C -C RETURN WITH X1 AS THE ROOT. SET JROOT. SET X = X1 AND GX = G1. ----- - 300 JFLAG = 2 - X = X1 - CALL DCOPY (NG, G1, 1, GX, 1) - DO 320 I = 1,NG - JROOT(I) = 0 - IF (DABS(G1(I)) .GT. ZERO) GO TO 310 - JROOT(I) = 1 - GO TO 320 - 310 IF (DSIGN(1.0D0,G0(I)) .NE. DSIGN(1.0D0,G1(I))) JROOT(I) = 1 - 320 CONTINUE - RETURN -C -C NO SIGN CHANGE IN THE INTERVAL. CHECK FOR ZERO AT RIGHT ENDPOINT. --- - 400 IF (.NOT. ZROOT) GO TO 420 -C -C ZERO VALUE AT X1 AND NO SIGN CHANGE IN (X0,X1). RETURN JFLAG = 3. --- - X = X1 - CALL DCOPY (NG, G1, 1, GX, 1) - DO 410 I = 1,NG - JROOT(I) = 0 - IF (DABS(G1(I)) .LE. ZERO) JROOT (I) = 1 - 410 CONTINUE - JFLAG = 3 - RETURN -C -C NO SIGN CHANGES IN THIS INTERVAL. SET X = X1, RETURN JFLAG = 4. ----- - 420 CALL DCOPY (NG, G1, 1, GX, 1) - X = X1 - JFLAG = 4 - RETURN -C---------------------- END OF SUBROUTINE DROOTS ----------------------- - END
--- a/liboctave/cruft/dasrt/module.mk Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,4 +0,0 @@ -CRUFT_SOURCES += \ - liboctave/cruft/dasrt/ddasrt.f \ - liboctave/cruft/dasrt/drchek.f \ - liboctave/cruft/dasrt/droots.f
--- a/liboctave/cruft/dassl/ddaini.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,257 +0,0 @@ - SUBROUTINE DDAINI (X, Y, YPRIME, NEQ, RES, JAC, H, WT, IDID, RPAR, - + IPAR, PHI, DELTA, E, WM, IWM, HMIN, UROUND, NONNEG, NTEMP) -C***BEGIN PROLOGUE DDAINI -C***SUBSIDIARY -C***PURPOSE Initialization routine for DDASSL. -C***LIBRARY SLATEC (DASSL) -C***TYPE DOUBLE PRECISION (SDAINI-S, DDAINI-D) -C***AUTHOR PETZOLD, LINDA R., (LLNL) -C***DESCRIPTION -C----------------------------------------------------------------- -C DDAINI TAKES ONE STEP OF SIZE H OR SMALLER -C WITH THE BACKWARD EULER METHOD, TO -C FIND YPRIME. X AND Y ARE UPDATED TO BE CONSISTENT WITH THE -C NEW STEP. A MODIFIED DAMPED NEWTON ITERATION IS USED TO -C SOLVE THE CORRECTOR ITERATION. -C -C THE INITIAL GUESS FOR YPRIME IS USED IN THE -C PREDICTION, AND IN FORMING THE ITERATION -C MATRIX, BUT IS NOT INVOLVED IN THE -C ERROR TEST. THIS MAY HAVE TROUBLE -C CONVERGING IF THE INITIAL GUESS IS NO -C GOOD, OR IF G(X,Y,YPRIME) DEPENDS -C NONLINEARLY ON YPRIME. -C -C THE PARAMETERS REPRESENT: -C X -- INDEPENDENT VARIABLE -C Y -- SOLUTION VECTOR AT X -C YPRIME -- DERIVATIVE OF SOLUTION VECTOR -C NEQ -- NUMBER OF EQUATIONS -C H -- STEPSIZE. IMDER MAY USE A STEPSIZE -C SMALLER THAN H. -C WT -- VECTOR OF WEIGHTS FOR ERROR -C CRITERION -C IDID -- COMPLETION CODE WITH THE FOLLOWING MEANINGS -C IDID= 1 -- YPRIME WAS FOUND SUCCESSFULLY -C IDID=-12 -- DDAINI FAILED TO FIND YPRIME -C RPAR,IPAR -- REAL AND INTEGER PARAMETER ARRAYS -C THAT ARE NOT ALTERED BY DDAINI -C PHI -- WORK SPACE FOR DDAINI -C DELTA,E -- WORK SPACE FOR DDAINI -C WM,IWM -- REAL AND INTEGER ARRAYS STORING -C MATRIX INFORMATION -C -C----------------------------------------------------------------- -C***ROUTINES CALLED DDAJAC, DDANRM, DDASLV -C***REVISION HISTORY (YYMMDD) -C 830315 DATE WRITTEN -C 901009 Finished conversion to SLATEC 4.0 format (F.N.Fritsch) -C 901019 Merged changes made by C. Ulrich with SLATEC 4.0 format. -C 901026 Added explicit declarations for all variables and minor -C cosmetic changes to prologue. (FNF) -C 901030 Minor corrections to declarations. (FNF) -C***END PROLOGUE DDAINI -C - INTEGER NEQ, IDID, IPAR(*), IWM(*), NONNEG, NTEMP - DOUBLE PRECISION - * X, Y(*), YPRIME(*), H, WT(*), RPAR(*), PHI(NEQ,*), DELTA(*), - * E(*), WM(*), HMIN, UROUND - EXTERNAL RES, JAC -C - EXTERNAL DDAJAC, DDANRM, DDASLV - DOUBLE PRECISION DDANRM -C - INTEGER I, IER, IRES, JCALC, LNJE, LNRE, M, MAXIT, MJAC, NCF, - * NEF, NSF - DOUBLE PRECISION - * CJ, DAMP, DELNRM, ERR, OLDNRM, R, RATE, S, XOLD, YNORM - LOGICAL CONVGD -C - PARAMETER (LNRE=12) - PARAMETER (LNJE=13) -C - DATA MAXIT/10/,MJAC/5/ - DATA DAMP/0.75D0/ -C -C -C--------------------------------------------------- -C BLOCK 1. -C INITIALIZATIONS. -C--------------------------------------------------- -C -C***FIRST EXECUTABLE STATEMENT DDAINI - IDID=1 - NEF=0 - NCF=0 - NSF=0 - XOLD=X - YNORM=DDANRM(NEQ,Y,WT,RPAR,IPAR) -C -C SAVE Y AND YPRIME IN PHI - DO 100 I=1,NEQ - PHI(I,1)=Y(I) -100 PHI(I,2)=YPRIME(I) -C -C -C---------------------------------------------------- -C BLOCK 2. -C DO ONE BACKWARD EULER STEP. -C---------------------------------------------------- -C -C SET UP FOR START OF CORRECTOR ITERATION -200 CJ=1.0D0/H - X=X+H -C -C PREDICT SOLUTION AND DERIVATIVE - DO 250 I=1,NEQ -250 Y(I)=Y(I)+H*YPRIME(I) -C - JCALC=-1 - M=0 - CONVGD=.TRUE. -C -C -C CORRECTOR LOOP. -300 IWM(LNRE)=IWM(LNRE)+1 - IRES=0 -C - CALL RES(X,Y,YPRIME,DELTA,IRES,RPAR,IPAR) - IF (IRES.LT.0) GO TO 430 -C -C -C EVALUATE THE ITERATION MATRIX - IF (JCALC.NE.-1) GO TO 310 - IWM(LNJE)=IWM(LNJE)+1 - JCALC=0 - CALL DDAJAC(NEQ,X,Y,YPRIME,DELTA,CJ,H, - * IER,WT,E,WM,IWM,RES,IRES, - * UROUND,JAC,RPAR,IPAR,NTEMP) -C - S=1000000.D0 - IF (IRES.LT.0) GO TO 430 - IF (IER.NE.0) GO TO 430 - NSF=0 -C -C -C -C MULTIPLY RESIDUAL BY DAMPING FACTOR -310 CONTINUE - DO 320 I=1,NEQ -320 DELTA(I)=DELTA(I)*DAMP -C -C COMPUTE A NEW ITERATE (BACK SUBSTITUTION) -C STORE THE CORRECTION IN DELTA -C - CALL DDASLV(NEQ,DELTA,WM,IWM) -C -C UPDATE Y AND YPRIME - DO 330 I=1,NEQ - Y(I)=Y(I)-DELTA(I) -330 YPRIME(I)=YPRIME(I)-CJ*DELTA(I) -C -C TEST FOR CONVERGENCE OF THE ITERATION. -C - DELNRM=DDANRM(NEQ,DELTA,WT,RPAR,IPAR) - IF (DELNRM.LE.100.D0*UROUND*YNORM) - * GO TO 400 -C - IF (M.GT.0) GO TO 340 - OLDNRM=DELNRM - GO TO 350 -C -340 RATE=(DELNRM/OLDNRM)**(1.0D0/M) - IF (RATE.GT.0.90D0) GO TO 430 - S=RATE/(1.0D0-RATE) -C -350 IF (S*DELNRM .LE. 0.33D0) GO TO 400 -C -C -C THE CORRECTOR HAS NOT YET CONVERGED. UPDATE -C M AND AND TEST WHETHER THE MAXIMUM -C NUMBER OF ITERATIONS HAVE BEEN TRIED. -C EVERY MJAC ITERATIONS, GET A NEW -C ITERATION MATRIX. -C - M=M+1 - IF (M.GE.MAXIT) GO TO 430 -C - IF ((M/MJAC)*MJAC.EQ.M) JCALC=-1 - GO TO 300 -C -C -C THE ITERATION HAS CONVERGED. -C CHECK NONNEGATIVITY CONSTRAINTS -400 IF (NONNEG.EQ.0) GO TO 450 - DO 410 I=1,NEQ -410 DELTA(I)=MIN(Y(I),0.0D0) -C - DELNRM=DDANRM(NEQ,DELTA,WT,RPAR,IPAR) - IF (DELNRM.GT.0.33D0) GO TO 430 -C - DO 420 I=1,NEQ - Y(I)=Y(I)-DELTA(I) -420 YPRIME(I)=YPRIME(I)-CJ*DELTA(I) - GO TO 450 -C -C -C EXITS FROM CORRECTOR LOOP. -430 CONVGD=.FALSE. -450 IF (.NOT.CONVGD) GO TO 600 -C -C -C -C----------------------------------------------------- -C BLOCK 3. -C THE CORRECTOR ITERATION CONVERGED. -C DO ERROR TEST. -C----------------------------------------------------- -C - DO 510 I=1,NEQ -510 E(I)=Y(I)-PHI(I,1) - ERR=DDANRM(NEQ,E,WT,RPAR,IPAR) -C - IF (ERR.LE.1.0D0) RETURN -C -C -C -C-------------------------------------------------------- -C BLOCK 4. -C THE BACKWARD EULER STEP FAILED. RESTORE X, Y -C AND YPRIME TO THEIR ORIGINAL VALUES. -C REDUCE STEPSIZE AND TRY AGAIN, IF -C POSSIBLE. -C--------------------------------------------------------- -C -600 CONTINUE - X = XOLD - DO 610 I=1,NEQ - Y(I)=PHI(I,1) -610 YPRIME(I)=PHI(I,2) -C - IF (CONVGD) GO TO 640 - IF (IER.EQ.0) GO TO 620 - NSF=NSF+1 - H=H*0.25D0 - IF (NSF.LT.3.AND.ABS(H).GE.HMIN) GO TO 690 - IDID=-12 - RETURN -620 IF (IRES.GT.-2) GO TO 630 - IDID=-12 - RETURN -630 NCF=NCF+1 - H=H*0.25D0 - IF (NCF.LT.10.AND.ABS(H).GE.HMIN) GO TO 690 - IDID=-12 - RETURN -C -640 NEF=NEF+1 - R=0.90D0/(2.0D0*ERR+0.0001D0) - R=MAX(0.1D0,MIN(0.5D0,R)) - H=H*R - IF (ABS(H).GE.HMIN.AND.NEF.LT.10) GO TO 690 - IDID=-12 - RETURN -690 GO TO 200 -C -C-------------END OF SUBROUTINE DDAINI---------------------- - END
--- a/liboctave/cruft/dassl/ddajac.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,178 +0,0 @@ - SUBROUTINE DDAJAC (NEQ, X, Y, YPRIME, DELTA, CJ, H, - + IER, WT, E, WM, IWM, RES, IRES, UROUND, JAC, RPAR, - + IPAR, NTEMP) -C***BEGIN PROLOGUE DDAJAC -C***SUBSIDIARY -C***PURPOSE Compute the iteration matrix for DDASSL and form the -C LU-decomposition. -C***LIBRARY SLATEC (DASSL) -C***TYPE DOUBLE PRECISION (SDAJAC-S, DDAJAC-D) -C***AUTHOR PETZOLD, LINDA R., (LLNL) -C***DESCRIPTION -C----------------------------------------------------------------------- -C THIS ROUTINE COMPUTES THE ITERATION MATRIX -C PD=DG/DY+CJ*DG/DYPRIME (WHERE G(X,Y,YPRIME)=0). -C HERE PD IS COMPUTED BY THE USER-SUPPLIED -C ROUTINE JAC IF IWM(MTYPE) IS 1 OR 4, AND -C IT IS COMPUTED BY NUMERICAL FINITE DIFFERENCING -C IF IWM(MTYPE)IS 2 OR 5 -C THE PARAMETERS HAVE THE FOLLOWING MEANINGS. -C Y = ARRAY CONTAINING PREDICTED VALUES -C YPRIME = ARRAY CONTAINING PREDICTED DERIVATIVES -C DELTA = RESIDUAL EVALUATED AT (X,Y,YPRIME) -C (USED ONLY IF IWM(MTYPE)=2 OR 5) -C CJ = SCALAR PARAMETER DEFINING ITERATION MATRIX -C H = CURRENT STEPSIZE IN INTEGRATION -C IER = VARIABLE WHICH IS .NE. 0 -C IF ITERATION MATRIX IS SINGULAR, -C AND 0 OTHERWISE. -C WT = VECTOR OF WEIGHTS FOR COMPUTING NORMS -C E = WORK SPACE (TEMPORARY) OF LENGTH NEQ -C WM = REAL WORK SPACE FOR MATRICES. ON -C OUTPUT IT CONTAINS THE LU DECOMPOSITION -C OF THE ITERATION MATRIX. -C IWM = INTEGER WORK SPACE CONTAINING -C MATRIX INFORMATION -C RES = NAME OF THE EXTERNAL USER-SUPPLIED ROUTINE -C TO EVALUATE THE RESIDUAL FUNCTION G(X,Y,YPRIME) -C IRES = FLAG WHICH IS EQUAL TO ZERO IF NO ILLEGAL VALUES -C IN RES, AND LESS THAN ZERO OTHERWISE. (IF IRES -C IS LESS THAN ZERO, THE MATRIX WAS NOT COMPLETED) -C IN THIS CASE (IF IRES .LT. 0), THEN IER = 0. -C UROUND = THE UNIT ROUNDOFF ERROR OF THE MACHINE BEING USED. -C JAC = NAME OF THE EXTERNAL USER-SUPPLIED ROUTINE -C TO EVALUATE THE ITERATION MATRIX (THIS ROUTINE -C IS ONLY USED IF IWM(MTYPE) IS 1 OR 4) -C----------------------------------------------------------------------- -C***ROUTINES CALLED DGBTRF, DGETRF -C***REVISION HISTORY (YYMMDD) -C 830315 DATE WRITTEN -C 901009 Finished conversion to SLATEC 4.0 format (F.N.Fritsch) -C 901010 Modified three MAX calls to be all on one line. (FNF) -C 901019 Merged changes made by C. Ulrich with SLATEC 4.0 format. -C 901026 Added explicit declarations for all variables and minor -C cosmetic changes to prologue. (FNF) -C 901101 Corrected PURPOSE. (FNF) -C 020204 Convert to use LAPACK -C***END PROLOGUE DDAJAC -C - INTEGER NEQ, IER, IWM(*), IRES, IPAR(*), NTEMP - DOUBLE PRECISION - * X, Y(*), YPRIME(*), DELTA(*), CJ, H, WT(*), E(*), WM(*), - * UROUND, RPAR(*) - EXTERNAL RES, JAC -C - EXTERNAL DGBTRF, DGETRF -C - INTEGER I, I1, I2, II, IPSAVE, ISAVE, J, K, L, LENPD, LIPVT, - * LML, LMTYPE, LMU, MBA, MBAND, MEB1, MEBAND, MSAVE, MTYPE, N, - * NPD, NPDM1, NROW - DOUBLE PRECISION DEL, DELINV, SQUR, YPSAVE, YSAVE -C - PARAMETER (NPD=1) - PARAMETER (LML=1) - PARAMETER (LMU=2) - PARAMETER (LMTYPE=4) - PARAMETER (LIPVT=22) -C -C***FIRST EXECUTABLE STATEMENT DDAJAC - IER = 0 - NPDM1=NPD-1 - MTYPE=IWM(LMTYPE) - GO TO (100,200,300,400,500),MTYPE -C -C -C DENSE USER-SUPPLIED MATRIX -100 LENPD=NEQ*NEQ - DO 110 I=1,LENPD -110 WM(NPDM1+I)=0.0D0 - CALL JAC(X,Y,YPRIME,WM(NPD),CJ,RPAR,IPAR) - GO TO 230 -C -C -C DENSE FINITE-DIFFERENCE-GENERATED MATRIX -200 IRES=0 - NROW=NPDM1 - SQUR = SQRT(UROUND) - DO 210 I=1,NEQ - DEL=SQUR*MAX(ABS(Y(I)),ABS(H*YPRIME(I)),ABS(WT(I))) - DEL=SIGN(DEL,H*YPRIME(I)) - DEL=(Y(I)+DEL)-Y(I) - YSAVE=Y(I) - YPSAVE=YPRIME(I) - Y(I)=Y(I)+DEL - YPRIME(I)=YPRIME(I)+CJ*DEL - CALL RES(X,Y,YPRIME,E,IRES,RPAR,IPAR) - IF (IRES .LT. 0) RETURN - DELINV=1.0D0/DEL - DO 220 L=1,NEQ -220 WM(NROW+L)=(E(L)-DELTA(L))*DELINV - NROW=NROW+NEQ - Y(I)=YSAVE - YPRIME(I)=YPSAVE -210 CONTINUE -C -C -C DO DENSE-MATRIX LU DECOMPOSITION ON PD -230 CALL DGETRF( NEQ, NEQ, WM(NPD), NEQ, IWM(LIPVT), IER) - RETURN -C -C -C DUMMY SECTION FOR IWM(MTYPE)=3 -300 RETURN -C -C -C BANDED USER-SUPPLIED MATRIX -400 LENPD=(2*IWM(LML)+IWM(LMU)+1)*NEQ - DO 410 I=1,LENPD -410 WM(NPDM1+I)=0.0D0 - CALL JAC(X,Y,YPRIME,WM(NPD),CJ,RPAR,IPAR) - MEBAND=2*IWM(LML)+IWM(LMU)+1 - GO TO 550 -C -C -C BANDED FINITE-DIFFERENCE-GENERATED MATRIX -500 MBAND=IWM(LML)+IWM(LMU)+1 - MBA=MIN(MBAND,NEQ) - MEBAND=MBAND+IWM(LML) - MEB1=MEBAND-1 - MSAVE=(NEQ/MBAND)+1 - ISAVE=NTEMP-1 - IPSAVE=ISAVE+MSAVE - IRES=0 - SQUR=SQRT(UROUND) - DO 540 J=1,MBA - DO 510 N=J,NEQ,MBAND - K= (N-J)/MBAND + 1 - WM(ISAVE+K)=Y(N) - WM(IPSAVE+K)=YPRIME(N) - DEL=SQUR*MAX(ABS(Y(N)),ABS(H*YPRIME(N)),ABS(WT(N))) - DEL=SIGN(DEL,H*YPRIME(N)) - DEL=(Y(N)+DEL)-Y(N) - Y(N)=Y(N)+DEL -510 YPRIME(N)=YPRIME(N)+CJ*DEL - CALL RES(X,Y,YPRIME,E,IRES,RPAR,IPAR) - IF (IRES .LT. 0) RETURN - DO 530 N=J,NEQ,MBAND - K= (N-J)/MBAND + 1 - Y(N)=WM(ISAVE+K) - YPRIME(N)=WM(IPSAVE+K) - DEL=SQUR*MAX(ABS(Y(N)),ABS(H*YPRIME(N)),ABS(WT(N))) - DEL=SIGN(DEL,H*YPRIME(N)) - DEL=(Y(N)+DEL)-Y(N) - DELINV=1.0D0/DEL - I1=MAX(1,(N-IWM(LMU))) - I2=MIN(NEQ,(N+IWM(LML))) - II=N*MEB1-IWM(LML)+NPDM1 - DO 520 I=I1,I2 -520 WM(II+I)=(E(I)-DELTA(I))*DELINV -530 CONTINUE -540 CONTINUE -C -C -C DO LU DECOMPOSITION OF BANDED PD -550 CALL DGBTRF(NEQ, NEQ, IWM(LML), IWM(LMU), WM(NPD), MEBAND, - * IWM(LIPVT), IER) - RETURN -C------END OF SUBROUTINE DDAJAC------ - END
--- a/liboctave/cruft/dassl/ddanrm.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,45 +0,0 @@ - DOUBLE PRECISION FUNCTION DDANRM (NEQ, V, WT, RPAR, IPAR) -C***BEGIN PROLOGUE DDANRM -C***SUBSIDIARY -C***PURPOSE Compute vector norm for DDASSL. -C***LIBRARY SLATEC (DASSL) -C***TYPE DOUBLE PRECISION (SDANRM-S, DDANRM-D) -C***AUTHOR PETZOLD, LINDA R., (LLNL) -C***DESCRIPTION -C----------------------------------------------------------------------- -C THIS FUNCTION ROUTINE COMPUTES THE WEIGHTED -C ROOT-MEAN-SQUARE NORM OF THE VECTOR OF LENGTH -C NEQ CONTAINED IN THE ARRAY V,WITH WEIGHTS -C CONTAINED IN THE ARRAY WT OF LENGTH NEQ. -C DDANRM=SQRT((1/NEQ)*SUM(V(I)/WT(I))**2) -C----------------------------------------------------------------------- -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 830315 DATE WRITTEN -C 901009 Finished conversion to SLATEC 4.0 format (F.N.Fritsch) -C 901019 Merged changes made by C. Ulrich with SLATEC 4.0 format. -C 901026 Added explicit declarations for all variables and minor -C cosmetic changes to prologue. (FNF) -C***END PROLOGUE DDANRM -C - INTEGER NEQ, IPAR(*) - DOUBLE PRECISION V(NEQ), WT(NEQ), RPAR(*) -C - INTEGER I - DOUBLE PRECISION SUM, VMAX -C -C***FIRST EXECUTABLE STATEMENT DDANRM - DDANRM = 0.0D0 - VMAX = 0.0D0 - DO 10 I = 1,NEQ - IF(ABS(V(I)/WT(I)) .GT. VMAX) VMAX = ABS(V(I)/WT(I)) -10 CONTINUE - IF(VMAX .LE. 0.0D0) GO TO 30 - SUM = 0.0D0 - DO 20 I = 1,NEQ -20 SUM = SUM + ((V(I)/WT(I))/VMAX)**2 - DDANRM = VMAX*SQRT(SUM/NEQ) -30 CONTINUE - RETURN -C------END OF FUNCTION DDANRM------ - END
--- a/liboctave/cruft/dassl/ddaslv.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,62 +0,0 @@ - SUBROUTINE DDASLV (NEQ, DELTA, WM, IWM) -C***BEGIN PROLOGUE DDASLV -C***SUBSIDIARY -C***PURPOSE Linear system solver for DDASSL. -C***LIBRARY SLATEC (DASSL) -C***TYPE DOUBLE PRECISION (SDASLV-S, DDASLV-D) -C***AUTHOR PETZOLD, LINDA R., (LLNL) -C***DESCRIPTION -C----------------------------------------------------------------------- -C THIS ROUTINE MANAGES THE SOLUTION OF THE LINEAR -C SYSTEM ARISING IN THE NEWTON ITERATION. -C MATRICES AND REAL TEMPORARY STORAGE AND -C REAL INFORMATION ARE STORED IN THE ARRAY WM. -C INTEGER MATRIX INFORMATION IS STORED IN -C THE ARRAY IWM. -C FOR A DENSE MATRIX, THE LAPACK ROUTINE -C DGETRS IS CALLED. -C FOR A BANDED MATRIX,THE LAPACK ROUTINE -C DGBTRS IS CALLED. -C----------------------------------------------------------------------- -C***ROUTINES CALLED DGBTRS, DGETRF -C***REVISION HISTORY (YYMMDD) -C 830315 DATE WRITTEN -C 901009 Finished conversion to SLATEC 4.0 format (F.N.Fritsch) -C 901019 Merged changes made by C. Ulrich with SLATEC 4.0 format. -C 901026 Added explicit declarations for all variables and minor -C cosmetic changes to prologue. (FNF) -C 020204 Convert to use LAPACK -C***END PROLOGUE DDASLV -C - INTEGER NEQ, IWM(*) - DOUBLE PRECISION DELTA(*), WM(*) -C - EXTERNAL DGBTRS, DGETRS -C - INTEGER LIPVT, LML, LMU, LMTYPE, MEBAND, MTYPE, NPD, INFO - PARAMETER (NPD=1) - PARAMETER (LML=1) - PARAMETER (LMU=2) - PARAMETER (LMTYPE=4) - PARAMETER (LIPVT=22) -C -C***FIRST EXECUTABLE STATEMENT DDASLV - MTYPE=IWM(LMTYPE) - GO TO(100,100,300,400,400),MTYPE -C -C DENSE MATRIX -100 CALL DGETRS('N', NEQ, 1, WM(NPD), NEQ, IWM(LIPVT), DELTA, NEQ, - * INFO) - RETURN -C -C DUMMY SECTION FOR MTYPE=3 -300 CONTINUE - RETURN -C -C BANDED MATRIX -400 MEBAND=2*IWM(LML)+IWM(LMU)+1 - CALL DGBTRS ('N', NEQ, IWM(LML), IWM(LMU), 1, WM(NPD), MEBAND, - * IWM(LIPVT), DELTA, NEQ, INLPCK) - RETURN -C------END OF SUBROUTINE DDASLV------ - END
--- a/liboctave/cruft/dassl/ddassl.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1617 +0,0 @@ - SUBROUTINE DDASSL (RES, NEQ, T, Y, YPRIME, TOUT, INFO, RTOL, ATOL, - + IDID, RWORK, LRW, IWORK, LIW, RPAR, IPAR, JAC) -C***BEGIN PROLOGUE DDASSL -C***PURPOSE This code solves a system of differential/algebraic -C equations of the form G(T,Y,YPRIME) = 0. -C***LIBRARY SLATEC (DASSL) -C***CATEGORY I1A2 -C***TYPE DOUBLE PRECISION (SDASSL-S, DDASSL-D) -C***KEYWORDS DIFFERENTIAL/ALGEBRAIC, BACKWARD DIFFERENTIATION FORMULAS, -C IMPLICIT DIFFERENTIAL SYSTEMS -C***AUTHOR PETZOLD, LINDA R., (LLNL) -C COMPUTING AND MATHEMATICS RESEARCH DIVISION -C LAWRENCE LIVERMORE NATIONAL LABORATORY -C L - 316, P.O. BOX 808, -C LIVERMORE, CA. 94550 -C***DESCRIPTION -C -C *Usage: -C -C EXTERNAL RES, JAC -C INTEGER NEQ, INFO(N), IDID, LRW, LIW, IWORK(LIW), IPAR -C DOUBLE PRECISION T, Y(NEQ), YPRIME(NEQ), TOUT, RTOL, ATOL, -C * RWORK(LRW), RPAR -C -C CALL DDASSL (RES, NEQ, T, Y, YPRIME, TOUT, INFO, RTOL, ATOL, -C * IDID, RWORK, LRW, IWORK, LIW, RPAR, IPAR, JAC) -C -C -C *Arguments: -C (In the following, all real arrays should be type DOUBLE PRECISION.) -C -C RES:EXT This is a subroutine which you provide to define the -C differential/algebraic system. -C -C NEQ:IN This is the number of equations to be solved. -C -C T:INOUT This is the current value of the independent variable. -C -C Y(*):INOUT This array contains the solution components at T. -C -C YPRIME(*):INOUT This array contains the derivatives of the solution -C components at T. -C -C TOUT:IN This is a point at which a solution is desired. -C -C INFO(N):IN The basic task of the code is to solve the system from T -C to TOUT and return an answer at TOUT. INFO is an integer -C array which is used to communicate exactly how you want -C this task to be carried out. (See below for details.) -C N must be greater than or equal to 15. -C -C RTOL,ATOL:INOUT These quantities represent relative and absolute -C error tolerances which you provide to indicate how -C accurately you wish the solution to be computed. You -C may choose them to be both scalars or else both vectors. -C Caution: In Fortran 77, a scalar is not the same as an -C array of length 1. Some compilers may object -C to using scalars for RTOL,ATOL. -C -C IDID:OUT This scalar quantity is an indicator reporting what the -C code did. You must monitor this integer variable to -C decide what action to take next. -C -C RWORK:WORK A real work array of length LRW which provides the -C code with needed storage space. -C -C LRW:IN The length of RWORK. (See below for required length.) -C -C IWORK:WORK An integer work array of length LIW which probides the -C code with needed storage space. -C -C LIW:IN The length of IWORK. (See below for required length.) -C -C RPAR,IPAR:IN These are real and integer parameter arrays which -C you can use for communication between your calling -C program and the RES subroutine (and the JAC subroutine) -C -C JAC:EXT This is the name of a subroutine which you may choose -C to provide for defining a matrix of partial derivatives -C described below. -C -C Quantities which may be altered by DDASSL are: -C T, Y(*), YPRIME(*), INFO(1), RTOL, ATOL, -C IDID, RWORK(*) AND IWORK(*) -C -C *Description -C -C Subroutine DDASSL uses the backward differentiation formulas of -C orders one through five to solve a system of the above form for Y and -C YPRIME. Values for Y and YPRIME at the initial time must be given as -C input. These values must be consistent, (that is, if T,Y,YPRIME are -C the given initial values, they must satisfy G(T,Y,YPRIME) = 0.). The -C subroutine solves the system from T to TOUT. It is easy to continue -C the solution to get results at additional TOUT. This is the interval -C mode of operation. Intermediate results can also be obtained easily -C by using the intermediate-output capability. -C -C The following detailed description is divided into subsections: -C 1. Input required for the first call to DDASSL. -C 2. Output after any return from DDASSL. -C 3. What to do to continue the integration. -C 4. Error messages. -C -C -C -------- INPUT -- WHAT TO DO ON THE FIRST CALL TO DDASSL ------------ -C -C The first call of the code is defined to be the start of each new -C problem. Read through the descriptions of all the following items, -C provide sufficient storage space for designated arrays, set -C appropriate variables for the initialization of the problem, and -C give information about how you want the problem to be solved. -C -C -C RES -- Provide a subroutine of the form -C SUBROUTINE RES(T,Y,YPRIME,DELTA,IRES,RPAR,IPAR) -C to define the system of differential/algebraic -C equations which is to be solved. For the given values -C of T,Y and YPRIME, the subroutine should -C return the residual of the defferential/algebraic -C system -C DELTA = G(T,Y,YPRIME) -C (DELTA(*) is a vector of length NEQ which is -C output for RES.) -C -C Subroutine RES must not alter T,Y or YPRIME. -C You must declare the name RES in an external -C statement in your program that calls DDASSL. -C You must dimension Y,YPRIME and DELTA in RES. -C -C IRES is an integer flag which is always equal to -C zero on input. Subroutine RES should alter IRES -C only if it encounters an illegal value of Y or -C a stop condition. Set IRES = -1 if an input value -C is illegal, and DDASSL will try to solve the problem -C without getting IRES = -1. If IRES = -2, DDASSL -C will return control to the calling program -C with IDID = -11. -C -C RPAR and IPAR are real and integer parameter arrays which -C you can use for communication between your calling program -C and subroutine RES. They are not altered by DDASSL. If you -C do not need RPAR or IPAR, ignore these parameters by treat- -C ing them as dummy arguments. If you do choose to use them, -C dimension them in your calling program and in RES as arrays -C of appropriate length. -C -C NEQ -- Set it to the number of differential equations. -C (NEQ .GE. 1) -C -C T -- Set it to the initial point of the integration. -C T must be defined as a variable. -C -C Y(*) -- Set this vector to the initial values of the NEQ solution -C components at the initial point. You must dimension Y of -C length at least NEQ in your calling program. -C -C YPRIME(*) -- Set this vector to the initial values of the NEQ -C first derivatives of the solution components at the initial -C point. You must dimension YPRIME at least NEQ in your -C calling program. If you do not know initial values of some -C of the solution components, see the explanation of INFO(11). -C -C TOUT -- Set it to the first point at which a solution -C is desired. You can not take TOUT = T. -C integration either forward in T (TOUT .GT. T) or -C backward in T (TOUT .LT. T) is permitted. -C -C The code advances the solution from T to TOUT using -C step sizes which are automatically selected so as to -C achieve the desired accuracy. If you wish, the code will -C return with the solution and its derivative at -C intermediate steps (intermediate-output mode) so that -C you can monitor them, but you still must provide TOUT in -C accord with the basic aim of the code. -C -C The first step taken by the code is a critical one -C because it must reflect how fast the solution changes near -C the initial point. The code automatically selects an -C initial step size which is practically always suitable for -C the problem. By using the fact that the code will not step -C past TOUT in the first step, you could, if necessary, -C restrict the length of the initial step size. -C -C For some problems it may not be permissible to integrate -C past a point TSTOP because a discontinuity occurs there -C or the solution or its derivative is not defined beyond -C TSTOP. When you have declared a TSTOP point (SEE INFO(4) -C and RWORK(1)), you have told the code not to integrate -C past TSTOP. In this case any TOUT beyond TSTOP is invalid -C input. -C -C INFO(*) -- Use the INFO array to give the code more details about -C how you want your problem solved. This array should be -C dimensioned of length 15, though DDASSL uses only the first -C eleven entries. You must respond to all of the following -C items, which are arranged as questions. The simplest use -C of the code corresponds to answering all questions as yes, -C i.e. setting all entries of INFO to 0. -C -C INFO(1) - This parameter enables the code to initialize -C itself. You must set it to indicate the start of every -C new problem. -C -C **** Is this the first call for this problem ... -C Yes - Set INFO(1) = 0 -C No - Not applicable here. -C See below for continuation calls. **** -C -C INFO(2) - How much accuracy you want of your solution -C is specified by the error tolerances RTOL and ATOL. -C The simplest use is to take them both to be scalars. -C To obtain more flexibility, they can both be vectors. -C The code must be told your choice. -C -C **** Are both error tolerances RTOL, ATOL scalars ... -C Yes - Set INFO(2) = 0 -C and input scalars for both RTOL and ATOL -C No - Set INFO(2) = 1 -C and input arrays for both RTOL and ATOL **** -C -C INFO(3) - The code integrates from T in the direction -C of TOUT by steps. If you wish, it will return the -C computed solution and derivative at the next -C intermediate step (the intermediate-output mode) or -C TOUT, whichever comes first. This is a good way to -C proceed if you want to see the behavior of the solution. -C If you must have solutions at a great many specific -C TOUT points, this code will compute them efficiently. -C -C **** Do you want the solution only at -C TOUT (and not at the next intermediate step) ... -C Yes - Set INFO(3) = 0 -C No - Set INFO(3) = 1 **** -C -C INFO(4) - To handle solutions at a great many specific -C values TOUT efficiently, this code may integrate past -C TOUT and interpolate to obtain the result at TOUT. -C Sometimes it is not possible to integrate beyond some -C point TSTOP because the equation changes there or it is -C not defined past TSTOP. Then you must tell the code -C not to go past. -C -C **** Can the integration be carried out without any -C restrictions on the independent variable T ... -C Yes - Set INFO(4)=0 -C No - Set INFO(4)=1 -C and define the stopping point TSTOP by -C setting RWORK(1)=TSTOP **** -C -C INFO(5) - To solve differential/algebraic problems it is -C necessary to use a matrix of partial derivatives of the -C system of differential equations. If you do not -C provide a subroutine to evaluate it analytically (see -C description of the item JAC in the call list), it will -C be approximated by numerical differencing in this code. -C although it is less trouble for you to have the code -C compute partial derivatives by numerical differencing, -C the solution will be more reliable if you provide the -C derivatives via JAC. Sometimes numerical differencing -C is cheaper than evaluating derivatives in JAC and -C sometimes it is not - this depends on your problem. -C -C **** Do you want the code to evaluate the partial -C derivatives automatically by numerical differences ... -C Yes - Set INFO(5)=0 -C No - Set INFO(5)=1 -C and provide subroutine JAC for evaluating the -C matrix of partial derivatives **** -C -C INFO(6) - DDASSL will perform much better if the matrix of -C partial derivatives, DG/DY + CJ*DG/DYPRIME, -C (here CJ is a scalar determined by DDASSL) -C is banded and the code is told this. In this -C case, the storage needed will be greatly reduced, -C numerical differencing will be performed much cheaper, -C and a number of important algorithms will execute much -C faster. The differential equation is said to have -C half-bandwidths ML (lower) and MU (upper) if equation i -C involves only unknowns Y(J) with -C I-ML .LE. J .LE. I+MU -C for all I=1,2,...,NEQ. Thus, ML and MU are the widths -C of the lower and upper parts of the band, respectively, -C with the main diagonal being excluded. If you do not -C indicate that the equation has a banded matrix of partial -C derivatives, the code works with a full matrix of NEQ**2 -C elements (stored in the conventional way). Computations -C with banded matrices cost less time and storage than with -C full matrices if 2*ML+MU .LT. NEQ. If you tell the -C code that the matrix of partial derivatives has a banded -C structure and you want to provide subroutine JAC to -C compute the partial derivatives, then you must be careful -C to store the elements of the matrix in the special form -C indicated in the description of JAC. -C -C **** Do you want to solve the problem using a full -C (dense) matrix (and not a special banded -C structure) ... -C Yes - Set INFO(6)=0 -C No - Set INFO(6)=1 -C and provide the lower (ML) and upper (MU) -C bandwidths by setting -C IWORK(1)=ML -C IWORK(2)=MU **** -C -C -C INFO(7) -- You can specify a maximum (absolute value of) -C stepsize, so that the code -C will avoid passing over very -C large regions. -C -C **** Do you want the code to decide -C on its own maximum stepsize? -C Yes - Set INFO(7)=0 -C No - Set INFO(7)=1 -C and define HMAX by setting -C RWORK(2)=HMAX **** -C -C INFO(8) -- Differential/algebraic problems -C may occaisionally suffer from -C severe scaling difficulties on the -C first step. If you know a great deal -C about the scaling of your problem, you can -C help to alleviate this problem by -C specifying an initial stepsize HO. -C -C **** Do you want the code to define -C its own initial stepsize? -C Yes - Set INFO(8)=0 -C No - Set INFO(8)=1 -C and define HO by setting -C RWORK(3)=HO **** -C -C INFO(9) -- If storage is a severe problem, -C you can save some locations by -C restricting the maximum order MAXORD. -C the default value is 5. for each -C order decrease below 5, the code -C requires NEQ fewer locations, however -C it is likely to be slower. In any -C case, you must have 1 .LE. MAXORD .LE. 5 -C **** Do you want the maximum order to -C default to 5? -C Yes - Set INFO(9)=0 -C No - Set INFO(9)=1 -C and define MAXORD by setting -C IWORK(3)=MAXORD **** -C -C INFO(10) --If you know that the solutions to your equations -C will always be nonnegative, it may help to set this -C parameter. However, it is probably best to -C try the code without using this option first, -C and only to use this option if that doesn't -C work very well. -C **** Do you want the code to solve the problem without -C invoking any special nonnegativity constraints? -C Yes - Set INFO(10)=0 -C No - Set INFO(10)=1 -C -C INFO(11) --DDASSL normally requires the initial T, -C Y, and YPRIME to be consistent. That is, -C you must have G(T,Y,YPRIME) = 0 at the initial -C time. If you do not know the initial -C derivative precisely, you can let DDASSL try -C to compute it. -C **** Are the initialHE INITIAL T, Y, YPRIME consistent? -C Yes - Set INFO(11) = 0 -C No - Set INFO(11) = 1, -C and set YPRIME to an initial approximation -C to YPRIME. (If you have no idea what -C YPRIME should be, set it to zero. Note -C that the initial Y should be such -C that there must exist a YPRIME so that -C G(T,Y,YPRIME) = 0.) -C -C RTOL, ATOL -- You must assign relative (RTOL) and absolute (ATOL -C error tolerances to tell the code how accurately you -C want the solution to be computed. They must be defined -C as variables because the code may change them. You -C have two choices -- -C Both RTOL and ATOL are scalars. (INFO(2)=0) -C Both RTOL and ATOL are vectors. (INFO(2)=1) -C in either case all components must be non-negative. -C -C The tolerances are used by the code in a local error -C test at each step which requires roughly that -C ABS(LOCAL ERROR) .LE. RTOL*ABS(Y)+ATOL -C for each vector component. -C (More specifically, a root-mean-square norm is used to -C measure the size of vectors, and the error test uses the -C magnitude of the solution at the beginning of the step.) -C -C The true (global) error is the difference between the -C true solution of the initial value problem and the -C computed approximation. Practically all present day -C codes, including this one, control the local error at -C each step and do not even attempt to control the global -C error directly. -C Usually, but not always, the true accuracy of the -C computed Y is comparable to the error tolerances. This -C code will usually, but not always, deliver a more -C accurate solution if you reduce the tolerances and -C integrate again. By comparing two such solutions you -C can get a fairly reliable idea of the true error in the -C solution at the bigger tolerances. -C -C Setting ATOL=0. results in a pure relative error test on -C that component. Setting RTOL=0. results in a pure -C absolute error test on that component. A mixed test -C with non-zero RTOL and ATOL corresponds roughly to a -C relative error test when the solution component is much -C bigger than ATOL and to an absolute error test when the -C solution component is smaller than the threshhold ATOL. -C -C The code will not attempt to compute a solution at an -C accuracy unreasonable for the machine being used. It will -C advise you if you ask for too much accuracy and inform -C you as to the maximum accuracy it believes possible. -C -C RWORK(*) -- Dimension this real work array of length LRW in your -C calling program. -C -C LRW -- Set it to the declared length of the RWORK array. -C You must have -C LRW .GE. 40+(MAXORD+4)*NEQ+NEQ**2 -C for the full (dense) JACOBIAN case (when INFO(6)=0), or -C LRW .GE. 40+(MAXORD+4)*NEQ+(2*ML+MU+1)*NEQ -C for the banded user-defined JACOBIAN case -C (when INFO(5)=1 and INFO(6)=1), or -C LRW .GE. 40+(MAXORD+4)*NEQ+(2*ML+MU+1)*NEQ -C +2*(NEQ/(ML+MU+1)+1) -C for the banded finite-difference-generated JACOBIAN case -C (when INFO(5)=0 and INFO(6)=1) -C -C IWORK(*) -- Dimension this integer work array of length LIW in -C your calling program. -C -C LIW -- Set it to the declared length of the IWORK array. -C You must have LIW .GE. 21+NEQ -C -C RPAR, IPAR -- These are parameter arrays, of real and integer -C type, respectively. You can use them for communication -C between your program that calls DDASSL and the -C RES subroutine (and the JAC subroutine). They are not -C altered by DDASSL. If you do not need RPAR or IPAR, -C ignore these parameters by treating them as dummy -C arguments. If you do choose to use them, dimension -C them in your calling program and in RES (and in JAC) -C as arrays of appropriate length. -C -C JAC -- If you have set INFO(5)=0, you can ignore this parameter -C by treating it as a dummy argument. Otherwise, you must -C provide a subroutine of the form -C SUBROUTINE JAC(T,Y,YPRIME,PD,CJ,RPAR,IPAR) -C to define the matrix of partial derivatives -C PD=DG/DY+CJ*DG/DYPRIME -C CJ is a scalar which is input to JAC. -C For the given values of T,Y,YPRIME, the -C subroutine must evaluate the non-zero partial -C derivatives for each equation and each solution -C component, and store these values in the -C matrix PD. The elements of PD are set to zero -C before each call to JAC so only non-zero elements -C need to be defined. -C -C Subroutine JAC must not alter T,Y,(*),YPRIME(*), or CJ. -C You must declare the name JAC in an EXTERNAL statement in -C your program that calls DDASSL. You must dimension Y, -C YPRIME and PD in JAC. -C -C The way you must store the elements into the PD matrix -C depends on the structure of the matrix which you -C indicated by INFO(6). -C *** INFO(6)=0 -- Full (dense) matrix *** -C Give PD a first dimension of NEQ. -C When you evaluate the (non-zero) partial derivative -C of equation I with respect to variable J, you must -C store it in PD according to -C PD(I,J) = "DG(I)/DY(J)+CJ*DG(I)/DYPRIME(J)" -C *** INFO(6)=1 -- Banded JACOBIAN with ML lower and MU -C upper diagonal bands (refer to INFO(6) description -C of ML and MU) *** -C Give PD a first dimension of 2*ML+MU+1. -C when you evaluate the (non-zero) partial derivative -C of equation I with respect to variable J, you must -C store it in PD according to -C IROW = I - J + ML + MU + 1 -C PD(IROW,J) = "DG(I)/DY(J)+CJ*DG(I)/DYPRIME(J)" -C -C RPAR and IPAR are real and integer parameter arrays -C which you can use for communication between your calling -C program and your JACOBIAN subroutine JAC. They are not -C altered by DDASSL. If you do not need RPAR or IPAR, -C ignore these parameters by treating them as dummy -C arguments. If you do choose to use them, dimension -C them in your calling program and in JAC as arrays of -C appropriate length. -C -C -C OPTIONALLY REPLACEABLE NORM ROUTINE: -C -C DDASSL uses a weighted norm DDANRM to measure the size -C of vectors such as the estimated error in each step. -C A FUNCTION subprogram -C DOUBLE PRECISION FUNCTION DDANRM(NEQ,V,WT,RPAR,IPAR) -C DIMENSION V(NEQ),WT(NEQ) -C is used to define this norm. Here, V is the vector -C whose norm is to be computed, and WT is a vector of -C weights. A DDANRM routine has been included with DDASSL -C which computes the weighted root-mean-square norm -C given by -C DDANRM=SQRT((1/NEQ)*SUM(V(I)/WT(I))**2) -C this norm is suitable for most problems. In some -C special cases, it may be more convenient and/or -C efficient to define your own norm by writing a function -C subprogram to be called instead of DDANRM. This should, -C however, be attempted only after careful thought and -C consideration. -C -C -C -------- OUTPUT -- AFTER ANY RETURN FROM DDASSL --------------------- -C -C The principal aim of the code is to return a computed solution at -C TOUT, although it is also possible to obtain intermediate results -C along the way. To find out whether the code achieved its goal -C or if the integration process was interrupted before the task was -C completed, you must check the IDID parameter. -C -C -C T -- The solution was successfully advanced to the -C output value of T. -C -C Y(*) -- Contains the computed solution approximation at T. -C -C YPRIME(*) -- Contains the computed derivative -C approximation at T. -C -C IDID -- Reports what the code did. -C -C *** Task completed *** -C Reported by positive values of IDID -C -C IDID = 1 -- A step was successfully taken in the -C intermediate-output mode. The code has not -C yet reached TOUT. -C -C IDID = 2 -- The integration to TSTOP was successfully -C completed (T=TSTOP) by stepping exactly to TSTOP. -C -C IDID = 3 -- The integration to TOUT was successfully -C completed (T=TOUT) by stepping past TOUT. -C Y(*) is obtained by interpolation. -C YPRIME(*) is obtained by interpolation. -C -C *** Task interrupted *** -C Reported by negative values of IDID -C -C IDID = -1 -- A large amount of work has been expended. -C (About 500 steps) -C -C IDID = -2 -- The error tolerances are too stringent. -C -C IDID = -3 -- The local error test cannot be satisfied -C because you specified a zero component in ATOL -C and the corresponding computed solution -C component is zero. Thus, a pure relative error -C test is impossible for this component. -C -C IDID = -6 -- DDASSL had repeated error test -C failures on the last attempted step. -C -C IDID = -7 -- The corrector could not converge. -C -C IDID = -8 -- The matrix of partial derivatives -C is singular. -C -C IDID = -9 -- The corrector could not converge. -C there were repeated error test failures -C in this step. -C -C IDID =-10 -- The corrector could not converge -C because IRES was equal to minus one. -C -C IDID =-11 -- IRES equal to -2 was encountered -C and control is being returned to the -C calling program. -C -C IDID =-12 -- DDASSL failed to compute the initial -C YPRIME. -C -C -C -C IDID = -13,..,-32 -- Not applicable for this code -C -C *** Task terminated *** -C Reported by the value of IDID=-33 -C -C IDID = -33 -- The code has encountered trouble from which -C it cannot recover. A message is printed -C explaining the trouble and control is returned -C to the calling program. For example, this occurs -C when invalid input is detected. -C -C RTOL, ATOL -- These quantities remain unchanged except when -C IDID = -2. In this case, the error tolerances have been -C increased by the code to values which are estimated to -C be appropriate for continuing the integration. However, -C the reported solution at T was obtained using the input -C values of RTOL and ATOL. -C -C RWORK, IWORK -- Contain information which is usually of no -C interest to the user but necessary for subsequent calls. -C However, you may find use for -C -C RWORK(3)--Which contains the step size H to be -C attempted on the next step. -C -C RWORK(4)--Which contains the current value of the -C independent variable, i.e., the farthest point -C integration has reached. This will be different -C from T only when interpolation has been -C performed (IDID=3). -C -C RWORK(7)--Which contains the stepsize used -C on the last successful step. -C -C IWORK(7)--Which contains the order of the method to -C be attempted on the next step. -C -C IWORK(8)--Which contains the order of the method used -C on the last step. -C -C IWORK(11)--Which contains the number of steps taken so -C far. -C -C IWORK(12)--Which contains the number of calls to RES -C so far. -C -C IWORK(13)--Which contains the number of evaluations of -C the matrix of partial derivatives needed so -C far. -C -C IWORK(14)--Which contains the total number -C of error test failures so far. -C -C IWORK(15)--Which contains the total number -C of convergence test failures so far. -C (includes singular iteration matrix -C failures.) -C -C -C -------- INPUT -- WHAT TO DO TO CONTINUE THE INTEGRATION ------------ -C (CALLS AFTER THE FIRST) -C -C This code is organized so that subsequent calls to continue the -C integration involve little (if any) additional effort on your -C part. You must monitor the IDID parameter in order to determine -C what to do next. -C -C Recalling that the principal task of the code is to integrate -C from T to TOUT (the interval mode), usually all you will need -C to do is specify a new TOUT upon reaching the current TOUT. -C -C Do not alter any quantity not specifically permitted below, -C in particular do not alter NEQ,T,Y(*),YPRIME(*),RWORK(*),IWORK(*) -C or the differential equation in subroutine RES. Any such -C alteration constitutes a new problem and must be treated as such, -C i.e., you must start afresh. -C -C You cannot change from vector to scalar error control or vice -C versa (INFO(2)), but you can change the size of the entries of -C RTOL, ATOL. Increasing a tolerance makes the equation easier -C to integrate. Decreasing a tolerance will make the equation -C harder to integrate and should generally be avoided. -C -C You can switch from the intermediate-output mode to the -C interval mode (INFO(3)) or vice versa at any time. -C -C If it has been necessary to prevent the integration from going -C past a point TSTOP (INFO(4), RWORK(1)), keep in mind that the -C code will not integrate to any TOUT beyond the currently -C specified TSTOP. Once TSTOP has been reached you must change -C the value of TSTOP or set INFO(4)=0. You may change INFO(4) -C or TSTOP at any time but you must supply the value of TSTOP in -C RWORK(1) whenever you set INFO(4)=1. -C -C Do not change INFO(5), INFO(6), IWORK(1), or IWORK(2) -C unless you are going to restart the code. -C -C *** Following a completed task *** -C If -C IDID = 1, call the code again to continue the integration -C another step in the direction of TOUT. -C -C IDID = 2 or 3, define a new TOUT and call the code again. -C TOUT must be different from T. You cannot change -C the direction of integration without restarting. -C -C *** Following an interrupted task *** -C To show the code that you realize the task was -C interrupted and that you want to continue, you -C must take appropriate action and set INFO(1) = 1 -C If -C IDID = -1, The code has taken about 500 steps. -C If you want to continue, set INFO(1) = 1 and -C call the code again. An additional 500 steps -C will be allowed. -C -C IDID = -2, The error tolerances RTOL, ATOL have been -C increased to values the code estimates appropriate -C for continuing. You may want to change them -C yourself. If you are sure you want to continue -C with relaxed error tolerances, set INFO(1)=1 and -C call the code again. -C -C IDID = -3, A solution component is zero and you set the -C corresponding component of ATOL to zero. If you -C are sure you want to continue, you must first -C alter the error criterion to use positive values -C for those components of ATOL corresponding to zero -C solution components, then set INFO(1)=1 and call -C the code again. -C -C IDID = -4,-5 --- Cannot occur with this code. -C -C IDID = -6, Repeated error test failures occurred on the -C last attempted step in DDASSL. A singularity in the -C solution may be present. If you are absolutely -C certain you want to continue, you should restart -C the integration. (Provide initial values of Y and -C YPRIME which are consistent) -C -C IDID = -7, Repeated convergence test failures occurred -C on the last attempted step in DDASSL. An inaccurate -C or ill-conditioned JACOBIAN may be the problem. If -C you are absolutely certain you want to continue, you -C should restart the integration. -C -C IDID = -8, The matrix of partial derivatives is singular. -C Some of your equations may be redundant. -C DDASSL cannot solve the problem as stated. -C It is possible that the redundant equations -C could be removed, and then DDASSL could -C solve the problem. It is also possible -C that a solution to your problem either -C does not exist or is not unique. -C -C IDID = -9, DDASSL had multiple convergence test -C failures, preceeded by multiple error -C test failures, on the last attempted step. -C It is possible that your problem -C is ill-posed, and cannot be solved -C using this code. Or, there may be a -C discontinuity or a singularity in the -C solution. If you are absolutely certain -C you want to continue, you should restart -C the integration. -C -C IDID =-10, DDASSL had multiple convergence test failures -C because IRES was equal to minus one. -C If you are absolutely certain you want -C to continue, you should restart the -C integration. -C -C IDID =-11, IRES=-2 was encountered, and control is being -C returned to the calling program. -C -C IDID =-12, DDASSL failed to compute the initial YPRIME. -C This could happen because the initial -C approximation to YPRIME was not very good, or -C if a YPRIME consistent with the initial Y -C does not exist. The problem could also be caused -C by an inaccurate or singular iteration matrix. -C -C IDID = -13,..,-32 --- Cannot occur with this code. -C -C -C *** Following a terminated task *** -C -C If IDID= -33, you cannot continue the solution of this problem. -C An attempt to do so will result in your -C run being terminated. -C -C -C -------- ERROR MESSAGES --------------------------------------------- -C -C The SLATEC error print routine XERMSG is called in the event of -C unsuccessful completion of a task. Most of these are treated as -C "recoverable errors", which means that (unless the user has directed -C otherwise) control will be returned to the calling program for -C possible action after the message has been printed. -C -C In the event of a negative value of IDID other than -33, an appro- -C priate message is printed and the "error number" printed by XERMSG -C is the value of IDID. There are quite a number of illegal input -C errors that can lead to a returned value IDID=-33. The conditions -C and their printed "error numbers" are as follows: -C -C Error number Condition -C -C 1 Some element of INFO vector is not zero or one. -C 2 NEQ .le. 0 -C 3 MAXORD not in range. -C 4 LRW is less than the required length for RWORK. -C 5 LIW is less than the required length for IWORK. -C 6 Some element of RTOL is .lt. 0 -C 7 Some element of ATOL is .lt. 0 -C 8 All elements of RTOL and ATOL are zero. -C 9 INFO(4)=1 and TSTOP is behind TOUT. -C 10 HMAX .lt. 0.0 -C 11 TOUT is behind T. -C 12 INFO(8)=1 and H0=0.0 -C 13 Some element of WT is .le. 0.0 -C 14 TOUT is too close to T to start integration. -C 15 INFO(4)=1 and TSTOP is behind T. -C 16 --( Not used in this version )-- -C 17 ML illegal. Either .lt. 0 or .gt. NEQ -C 18 MU illegal. Either .lt. 0 or .gt. NEQ -C 19 TOUT = T. -C -C If DDASSL is called again without any action taken to remove the -C cause of an unsuccessful return, XERMSG will be called with a fatal -C error flag, which will cause unconditional termination of the -C program. There are two such fatal errors: -C -C Error number -998: The last step was terminated with a negative -C value of IDID other than -33, and no appropriate action was -C taken. -C -C Error number -999: The previous call was terminated because of -C illegal input (IDID=-33) and there is illegal input in the -C present call, as well. (Suspect infinite loop.) -C -C --------------------------------------------------------------------- -C -C***REFERENCES A DESCRIPTION OF DASSL: A DIFFERENTIAL/ALGEBRAIC -C SYSTEM SOLVER, L. R. PETZOLD, SAND82-8637, -C SANDIA NATIONAL LABORATORIES, SEPTEMBER 1982. -C***ROUTINES CALLED D1MACH, DDAINI, DDANRM, DDASTP, DDATRP, DDAWTS, -C XERMSG -C***REVISION HISTORY (YYMMDD) -C 830315 DATE WRITTEN -C 880387 Code changes made. All common statements have been -C replaced by a DATA statement, which defines pointers into -C RWORK, and PARAMETER statements which define pointers -C into IWORK. As well the documentation has gone through -C grammatical changes. -C 881005 The prologue has been changed to mixed case. -C The subordinate routines had revision dates changed to -C this date, although the documentation for these routines -C is all upper case. No code changes. -C 890511 Code changes made. The DATA statement in the declaration -C section of DDASSL was replaced with a PARAMETER -C statement. Also the statement S = 100.D0 was removed -C from the top of the Newton iteration in DDASTP. -C The subordinate routines had revision dates changed to -C this date. -C 890517 The revision date syntax was replaced with the revision -C history syntax. Also the "DECK" comment was added to -C the top of all subroutines. These changes are consistent -C with new SLATEC guidelines. -C The subordinate routines had revision dates changed to -C this date. No code changes. -C 891013 Code changes made. -C Removed all occurrances of FLOAT or DBLE. All operations -C are now performed with "mixed-mode" arithmetic. -C Also, specific function names were replaced with generic -C function names to be consistent with new SLATEC guidelines. -C In particular: -C Replaced DSQRT with SQRT everywhere. -C Replaced DABS with ABS everywhere. -C Replaced DMIN1 with MIN everywhere. -C Replaced MIN0 with MIN everywhere. -C Replaced DMAX1 with MAX everywhere. -C Replaced MAX0 with MAX everywhere. -C Replaced DSIGN with SIGN everywhere. -C Also replaced REVISION DATE with REVISION HISTORY in all -C subordinate routines. -C 901004 Miscellaneous changes to prologue to complete conversion -C to SLATEC 4.0 format. No code changes. (F.N.Fritsch) -C 901009 Corrected GAMS classification code and converted subsidiary -C routines to 4.0 format. No code changes. (F.N.Fritsch) -C 901010 Converted XERRWV calls to XERMSG calls. (R.Clemens,AFWL) -C 901019 Code changes made. -C Merged SLATEC 4.0 changes with previous changes made -C by C. Ulrich. Below is a history of the changes made by -C C. Ulrich. (Changes in subsidiary routines are implied -C by this history) -C 891228 Bug was found and repaired inside the DDASSL -C and DDAINI routines. DDAINI was incorrectly -C returning the initial T with Y and YPRIME -C computed at T+H. The routine now returns T+H -C rather than the initial T. -C Cosmetic changes made to DDASTP. -C 900904 Three modifications were made to fix a bug (inside -C DDASSL) re interpolation for continuation calls and -C cases where TN is very close to TSTOP: -C -C 1) In testing for whether H is too large, just -C compare H to (TSTOP - TN), rather than -C (TSTOP - TN) * (1-4*UROUND), and set H to -C TSTOP - TN. This will force DDASTP to step -C exactly to TSTOP under certain situations -C (i.e. when H returned from DDASTP would otherwise -C take TN beyond TSTOP). -C -C 2) Inside the DDASTP loop, interpolate exactly to -C TSTOP if TN is very close to TSTOP (rather than -C interpolating to within roundoff of TSTOP). -C -C 3) Modified IDID description for IDID = 2 to say that -C the solution is returned by stepping exactly to -C TSTOP, rather than TOUT. (In some cases the -C solution is actually obtained by extrapolating -C over a distance near unit roundoff to TSTOP, -C but this small distance is deemed acceptable in -C these circumstances.) -C 901026 Added explicit declarations for all variables and minor -C cosmetic changes to prologue, removed unreferenced labels, -C and improved XERMSG calls. (FNF) -C 901030 Added ERROR MESSAGES section and reworked other sections to -C be of more uniform format. (FNF) -C 910624 Fixed minor bug related to HMAX (five lines ending in -C statement 526 in DDASSL). (LRP) -C -C***END PROLOGUE DDASSL -C -C**End -C -C Declare arguments. -C - INTEGER NEQ, INFO(15), IDID, LRW, IWORK(*), LIW, IPAR(*) - DOUBLE PRECISION - * T, Y(*), YPRIME(*), TOUT, RTOL(*), ATOL(*), RWORK(*), - * RPAR(*) - EXTERNAL RES, JAC -C -C Declare externals. -C - EXTERNAL D1MACH, DDAINI, DDANRM, DDASTP, DDATRP, DDAWTS, XERMSG - DOUBLE PRECISION D1MACH, DDANRM -C -C Declare local variables. -C - INTEGER I, ITEMP, LALPHA, LBETA, LCJ, LCJOLD, LCTF, LDELTA, - * LENIW, LENPD, LENRW, LE, LETF, LGAMMA, LH, LHMAX, LHOLD, - * LMXSTP, LIPVT, - * LJCALC, LK, LKOLD, LIWM, LML, LMTYPE, LMU, LMXORD, LNJE, LNPD, - * LNRE, LNS, LNST, LNSTL, LPD, LPHASE, LPHI, LPSI, LROUND, LS, - * LSIGMA, LTN, LTSTOP, LWM, LWT, MBAND, MSAVE, MXORD, NPD, NTEMP, - * NZFLG - DOUBLE PRECISION - * ATOLI, H, HMAX, HMIN, HO, R, RH, RTOLI, TDIST, TN, TNEXT, - * TSTOP, UROUND, YPNORM - LOGICAL DONE -C Auxiliary variables for conversion of values to be included in -C error messages. - CHARACTER*8 XERN1, XERN2 - CHARACTER*16 XERN3, XERN4 -C -C SET POINTERS INTO IWORK - PARAMETER (LML=1, LMU=2, LMXORD=3, LMTYPE=4, LNST=11, - * LNRE=12, LNJE=13, LETF=14, LCTF=15, LNPD=16, LMXSTP=21, - * LIPVT=22, LJCALC=5, LPHASE=6, LK=7, LKOLD=8, - * LNS=9, LNSTL=10, LIWM=1) -C -C SET RELATIVE OFFSET INTO RWORK - PARAMETER (NPD=1) -C -C SET POINTERS INTO RWORK - PARAMETER (LTSTOP=1, LHMAX=2, LH=3, LTN=4, - * LCJ=5, LCJOLD=6, LHOLD=7, LS=8, LROUND=9, - * LALPHA=11, LBETA=17, LGAMMA=23, - * LPSI=29, LSIGMA=35, LDELTA=41) -C -C***FIRST EXECUTABLE STATEMENT DDASSL - IF(INFO(1).NE.0)GO TO 100 -C -C----------------------------------------------------------------------- -C THIS BLOCK IS EXECUTED FOR THE INITIAL CALL ONLY. -C IT CONTAINS CHECKING OF INPUTS AND INITIALIZATIONS. -C----------------------------------------------------------------------- -C -C FIRST CHECK INFO ARRAY TO MAKE SURE ALL ELEMENTS OF INFO -C ARE EITHER ZERO OR ONE. - DO 10 I=2,11 - IF(INFO(I).NE.0.AND.INFO(I).NE.1)GO TO 701 -10 CONTINUE -C - IF(NEQ.LE.0)GO TO 702 -C -C CHECK AND COMPUTE MAXIMUM ORDER - MXORD=5 - IF(INFO(9).EQ.0)GO TO 20 - MXORD=IWORK(LMXORD) - IF(MXORD.LT.1.OR.MXORD.GT.5)GO TO 703 -20 IWORK(LMXORD)=MXORD -C -C COMPUTE MTYPE,LENPD,LENRW.CHECK ML AND MU. - IF(INFO(6).NE.0)GO TO 40 - LENPD=NEQ**2 - LENRW=40+(IWORK(LMXORD)+4)*NEQ+LENPD - IF(INFO(5).NE.0)GO TO 30 - IWORK(LMTYPE)=2 - GO TO 60 -30 IWORK(LMTYPE)=1 - GO TO 60 -40 IF(IWORK(LML).LT.0.OR.IWORK(LML).GE.NEQ)GO TO 717 - IF(IWORK(LMU).LT.0.OR.IWORK(LMU).GE.NEQ)GO TO 718 - LENPD=(2*IWORK(LML)+IWORK(LMU)+1)*NEQ - IF(INFO(5).NE.0)GO TO 50 - IWORK(LMTYPE)=5 - MBAND=IWORK(LML)+IWORK(LMU)+1 - MSAVE=(NEQ/MBAND)+1 - LENRW=40+(IWORK(LMXORD)+4)*NEQ+LENPD+2*MSAVE - GO TO 60 -50 IWORK(LMTYPE)=4 - LENRW=40+(IWORK(LMXORD)+4)*NEQ+LENPD -C -C CHECK LENGTHS OF RWORK AND IWORK -60 LENIW=21+NEQ - IWORK(LNPD)=LENPD - IF(LRW.LT.LENRW)GO TO 704 - IF(LIW.LT.LENIW)GO TO 705 -C -C CHECK TO SEE THAT TOUT IS DIFFERENT FROM T - IF(TOUT .EQ. T)GO TO 719 -C -C CHECK HMAX - IF(INFO(7).EQ.0)GO TO 70 - HMAX=RWORK(LHMAX) - IF(HMAX.LE.0.0D0)GO TO 710 -70 CONTINUE -C -C CHECK AND COMPUTE MAXIMUM STEPS - MXSTP=500 - IF(INFO(12).EQ.0)GO TO 80 - MXSTP=IWORK(LMXSTP) - IF(MXSTP.LT.0)GO TO 716 -80 IWORK(LMXSTP)=MXSTP -C -C INITIALIZE COUNTERS - IWORK(LNST)=0 - IWORK(LNRE)=0 - IWORK(LNJE)=0 -C - IWORK(LNSTL)=0 - IDID=1 - GO TO 200 -C -C----------------------------------------------------------------------- -C THIS BLOCK IS FOR CONTINUATION CALLS -C ONLY. HERE WE CHECK INFO(1),AND IF THE -C LAST STEP WAS INTERRUPTED WE CHECK WHETHER -C APPROPRIATE ACTION WAS TAKEN. -C----------------------------------------------------------------------- -C -100 CONTINUE - IF(INFO(1).EQ.1)GO TO 110 - IF(INFO(1).NE.-1)GO TO 701 -C -C IF WE ARE HERE, THE LAST STEP WAS INTERRUPTED -C BY AN ERROR CONDITION FROM DDASTP,AND -C APPROPRIATE ACTION WAS NOT TAKEN. THIS -C IS A FATAL ERROR. - WRITE (XERN1, '(I8)') IDID - CALL XERMSG ('SLATEC', 'DDASSL', - * 'THE LAST STEP TERMINATED WITH A NEGATIVE VALUE OF IDID = ' // - * XERN1 // ' AND NO APPROPRIATE ACTION WAS TAKEN. ' // - * 'RUN TERMINATED', -998, 2) - RETURN -110 CONTINUE - IWORK(LNSTL)=IWORK(LNST) -C -C----------------------------------------------------------------------- -C THIS BLOCK IS EXECUTED ON ALL CALLS. -C THE ERROR TOLERANCE PARAMETERS ARE -C CHECKED, AND THE WORK ARRAY POINTERS -C ARE SET. -C----------------------------------------------------------------------- -C -200 CONTINUE -C CHECK RTOL,ATOL - NZFLG=0 - RTOLI=RTOL(1) - ATOLI=ATOL(1) - DO 210 I=1,NEQ - IF(INFO(2).EQ.1)RTOLI=RTOL(I) - IF(INFO(2).EQ.1)ATOLI=ATOL(I) - IF(RTOLI.GT.0.0D0.OR.ATOLI.GT.0.0D0)NZFLG=1 - IF(RTOLI.LT.0.0D0)GO TO 706 - IF(ATOLI.LT.0.0D0)GO TO 707 -210 CONTINUE - IF(NZFLG.EQ.0)GO TO 708 -C -C SET UP RWORK STORAGE.IWORK STORAGE IS FIXED -C IN DATA STATEMENT. - LE=LDELTA+NEQ - LWT=LE+NEQ - LPHI=LWT+NEQ - LPD=LPHI+(IWORK(LMXORD)+1)*NEQ - LWM=LPD - NTEMP=NPD+IWORK(LNPD) - IF(INFO(1).EQ.1)GO TO 400 -C -C----------------------------------------------------------------------- -C THIS BLOCK IS EXECUTED ON THE INITIAL CALL -C ONLY. SET THE INITIAL STEP SIZE, AND -C THE ERROR WEIGHT VECTOR, AND PHI. -C COMPUTE INITIAL YPRIME, IF NECESSARY. -C----------------------------------------------------------------------- -C - TN=T - IDID=1 -C -C SET ERROR WEIGHT VECTOR WT - CALL DDAWTS(NEQ,INFO(2),RTOL,ATOL,Y,RWORK(LWT),RPAR,IPAR) - DO 305 I = 1,NEQ - IF(RWORK(LWT+I-1).LE.0.0D0) GO TO 713 -305 CONTINUE -C -C COMPUTE UNIT ROUNDOFF AND HMIN - UROUND = D1MACH(4) - RWORK(LROUND) = UROUND - HMIN = 4.0D0*UROUND*MAX(ABS(T),ABS(TOUT)) -C -C CHECK INITIAL INTERVAL TO SEE THAT IT IS LONG ENOUGH - TDIST = ABS(TOUT - T) - IF(TDIST .LT. HMIN) GO TO 714 -C -C CHECK HO, IF THIS WAS INPUT - IF (INFO(8) .EQ. 0) GO TO 310 - HO = RWORK(LH) - IF ((TOUT - T)*HO .LT. 0.0D0) GO TO 711 - IF (HO .EQ. 0.0D0) GO TO 712 - GO TO 320 -310 CONTINUE -C -C COMPUTE INITIAL STEPSIZE, TO BE USED BY EITHER -C DDASTP OR DDAINI, DEPENDING ON INFO(11) - HO = 0.001D0*TDIST - YPNORM = DDANRM(NEQ,YPRIME,RWORK(LWT),RPAR,IPAR) - IF (YPNORM .GT. 0.5D0/HO) HO = 0.5D0/YPNORM - HO = SIGN(HO,TOUT-T) -C ADJUST HO IF NECESSARY TO MEET HMAX BOUND -320 IF (INFO(7) .EQ. 0) GO TO 330 - RH = ABS(HO)/RWORK(LHMAX) - IF (RH .GT. 1.0D0) HO = HO/RH -C COMPUTE TSTOP, IF APPLICABLE -330 IF (INFO(4) .EQ. 0) GO TO 340 - TSTOP = RWORK(LTSTOP) - IF ((TSTOP - T)*HO .LT. 0.0D0) GO TO 715 - IF ((T + HO - TSTOP)*HO .GT. 0.0D0) HO = TSTOP - T - IF ((TSTOP - TOUT)*HO .LT. 0.0D0) GO TO 709 -C -C COMPUTE INITIAL DERIVATIVE, UPDATING TN AND Y, IF APPLICABLE -340 IF (INFO(11) .EQ. 0) GO TO 350 - CALL DDAINI(TN,Y,YPRIME,NEQ, - * RES,JAC,HO,RWORK(LWT),IDID,RPAR,IPAR, - * RWORK(LPHI),RWORK(LDELTA),RWORK(LE), - * RWORK(LWM),IWORK(LIWM),HMIN,RWORK(LROUND), - * INFO(10),NTEMP) - IF (IDID .LT. 0) GO TO 390 -C -C LOAD H WITH HO. STORE H IN RWORK(LH) -350 H = HO - RWORK(LH) = H -C -C LOAD Y AND H*YPRIME INTO PHI(*,1) AND PHI(*,2) - ITEMP = LPHI + NEQ - DO 370 I = 1,NEQ - RWORK(LPHI + I - 1) = Y(I) -370 RWORK(ITEMP + I - 1) = H*YPRIME(I) -C -390 GO TO 500 -C -C------------------------------------------------------- -C THIS BLOCK IS FOR CONTINUATION CALLS ONLY. ITS -C PURPOSE IS TO CHECK STOP CONDITIONS BEFORE -C TAKING A STEP. -C ADJUST H IF NECESSARY TO MEET HMAX BOUND -C------------------------------------------------------- -C -400 CONTINUE - UROUND=RWORK(LROUND) - DONE = .FALSE. - TN=RWORK(LTN) - H=RWORK(LH) - IF(INFO(7) .EQ. 0) GO TO 410 - RH = ABS(H)/RWORK(LHMAX) - IF(RH .GT. 1.0D0) H = H/RH -410 CONTINUE - IF(T .EQ. TOUT) GO TO 719 - IF((T - TOUT)*H .GT. 0.0D0) GO TO 711 - IF(INFO(4) .EQ. 1) GO TO 430 - IF(INFO(3) .EQ. 1) GO TO 420 - IF((TN-TOUT)*H.LT.0.0D0)GO TO 490 - CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD), - * RWORK(LPHI),RWORK(LPSI)) - T=TOUT - IDID = 3 - DONE = .TRUE. - GO TO 490 -420 IF((TN-T)*H .LE. 0.0D0) GO TO 490 - IF((TN - TOUT)*H .GT. 0.0D0) GO TO 425 - CALL DDATRP(TN,TN,Y,YPRIME,NEQ,IWORK(LKOLD), - * RWORK(LPHI),RWORK(LPSI)) - T = TN - IDID = 1 - DONE = .TRUE. - GO TO 490 -425 CONTINUE - CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD), - * RWORK(LPHI),RWORK(LPSI)) - T = TOUT - IDID = 3 - DONE = .TRUE. - GO TO 490 -430 IF(INFO(3) .EQ. 1) GO TO 440 - TSTOP=RWORK(LTSTOP) - IF((TN-TSTOP)*H.GT.0.0D0) GO TO 715 - IF((TSTOP-TOUT)*H.LT.0.0D0)GO TO 709 - IF((TN-TOUT)*H.LT.0.0D0)GO TO 450 - CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD), - * RWORK(LPHI),RWORK(LPSI)) - T=TOUT - IDID = 3 - DONE = .TRUE. - GO TO 490 -440 TSTOP = RWORK(LTSTOP) - IF((TN-TSTOP)*H .GT. 0.0D0) GO TO 715 - IF((TSTOP-TOUT)*H .LT. 0.0D0) GO TO 709 - IF((TN-T)*H .LE. 0.0D0) GO TO 450 - IF((TN - TOUT)*H .GT. 0.0D0) GO TO 445 - CALL DDATRP(TN,TN,Y,YPRIME,NEQ,IWORK(LKOLD), - * RWORK(LPHI),RWORK(LPSI)) - T = TN - IDID = 1 - DONE = .TRUE. - GO TO 490 -445 CONTINUE - CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD), - * RWORK(LPHI),RWORK(LPSI)) - T = TOUT - IDID = 3 - DONE = .TRUE. - GO TO 490 -450 CONTINUE -C CHECK WHETHER WE ARE WITHIN ROUNDOFF OF TSTOP - IF(ABS(TN-TSTOP).GT.100.0D0*UROUND* - * (ABS(TN)+ABS(H)))GO TO 460 - CALL DDATRP(TN,TSTOP,Y,YPRIME,NEQ,IWORK(LKOLD), - * RWORK(LPHI),RWORK(LPSI)) - IDID=2 - T=TSTOP - DONE = .TRUE. - GO TO 490 -460 TNEXT=TN+H - IF((TNEXT-TSTOP)*H.LE.0.0D0)GO TO 490 - H=TSTOP-TN - RWORK(LH)=H -C -490 IF (DONE) GO TO 580 -C -C------------------------------------------------------- -C THE NEXT BLOCK CONTAINS THE CALL TO THE -C ONE-STEP INTEGRATOR DDASTP. -C THIS IS A LOOPING POINT FOR THE INTEGRATION STEPS. -C CHECK FOR TOO MANY STEPS. -C UPDATE WT. -C CHECK FOR TOO MUCH ACCURACY REQUESTED. -C COMPUTE MINIMUM STEPSIZE. -C------------------------------------------------------- -C -500 CONTINUE -C CHECK FOR FAILURE TO COMPUTE INITIAL YPRIME - IF (IDID .EQ. -12) GO TO 527 -C -C CHECK FOR TOO MANY STEPS - IF((IWORK(LNST)-IWORK(LNSTL)).LT.IWORK(LMXSTP)) - * GO TO 510 - IDID=-1 - GO TO 527 -C -C UPDATE WT -510 CALL DDAWTS(NEQ,INFO(2),RTOL,ATOL,RWORK(LPHI), - * RWORK(LWT),RPAR,IPAR) - DO 520 I=1,NEQ - IF(RWORK(I+LWT-1).GT.0.0D0)GO TO 520 - IDID=-3 - GO TO 527 -520 CONTINUE -C -C TEST FOR TOO MUCH ACCURACY REQUESTED. - R=DDANRM(NEQ,RWORK(LPHI),RWORK(LWT),RPAR,IPAR)* - * 100.0D0*UROUND - IF(R.LE.1.0D0)GO TO 525 -C MULTIPLY RTOL AND ATOL BY R AND RETURN - IF(INFO(2).EQ.1)GO TO 523 - RTOL(1)=R*RTOL(1) - ATOL(1)=R*ATOL(1) - IDID=-2 - GO TO 527 -523 DO 524 I=1,NEQ - RTOL(I)=R*RTOL(I) -524 ATOL(I)=R*ATOL(I) - IDID=-2 - GO TO 527 -525 CONTINUE -C -C COMPUTE MINIMUM STEPSIZE - HMIN=4.0D0*UROUND*MAX(ABS(TN),ABS(TOUT)) -C -C TEST H VS. HMAX - IF (INFO(7) .EQ. 0) GO TO 526 - RH = ABS(H)/RWORK(LHMAX) - IF (RH .GT. 1.0D0) H = H/RH -526 CONTINUE -C - CALL DDASTP(TN,Y,YPRIME,NEQ, - * RES,JAC,H,RWORK(LWT),INFO(1),IDID,RPAR,IPAR, - * RWORK(LPHI),RWORK(LDELTA),RWORK(LE), - * RWORK(LWM),IWORK(LIWM), - * RWORK(LALPHA),RWORK(LBETA),RWORK(LGAMMA), - * RWORK(LPSI),RWORK(LSIGMA), - * RWORK(LCJ),RWORK(LCJOLD),RWORK(LHOLD), - * RWORK(LS),HMIN,RWORK(LROUND), - * IWORK(LPHASE),IWORK(LJCALC),IWORK(LK), - * IWORK(LKOLD),IWORK(LNS),INFO(10),NTEMP) -527 IF(IDID.LT.0)GO TO 600 -C -C-------------------------------------------------------- -C THIS BLOCK HANDLES THE CASE OF A SUCCESSFUL RETURN -C FROM DDASTP (IDID=1). TEST FOR STOP CONDITIONS. -C-------------------------------------------------------- -C - IF(INFO(4).NE.0)GO TO 540 - IF(INFO(3).NE.0)GO TO 530 - IF((TN-TOUT)*H.LT.0.0D0)GO TO 500 - CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ, - * IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) - IDID=3 - T=TOUT - GO TO 580 -530 IF((TN-TOUT)*H.GE.0.0D0)GO TO 535 - T=TN - IDID=1 - GO TO 580 -535 CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ, - * IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) - IDID=3 - T=TOUT - GO TO 580 -540 IF(INFO(3).NE.0)GO TO 550 - IF((TN-TOUT)*H.LT.0.0D0)GO TO 542 - CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ, - * IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) - T=TOUT - IDID=3 - GO TO 580 -542 IF(ABS(TN-TSTOP).LE.100.0D0*UROUND* - * (ABS(TN)+ABS(H)))GO TO 545 - TNEXT=TN+H - IF((TNEXT-TSTOP)*H.LE.0.0D0)GO TO 500 - H=TSTOP-TN - GO TO 500 -545 CALL DDATRP(TN,TSTOP,Y,YPRIME,NEQ, - * IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) - IDID=2 - T=TSTOP - GO TO 580 -550 IF((TN-TOUT)*H.GE.0.0D0)GO TO 555 - IF(ABS(TN-TSTOP).LE.100.0D0*UROUND*(ABS(TN)+ABS(H)))GO TO 552 - T=TN - IDID=1 - GO TO 580 -552 CALL DDATRP(TN,TSTOP,Y,YPRIME,NEQ, - * IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) - IDID=2 - T=TSTOP - GO TO 580 -555 CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ, - * IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) - T=TOUT - IDID=3 - GO TO 580 -C -C-------------------------------------------------------- -C ALL SUCCESSFUL RETURNS FROM DDASSL ARE MADE FROM -C THIS BLOCK. -C-------------------------------------------------------- -C -580 CONTINUE - RWORK(LTN)=TN - RWORK(LH)=H - RETURN -C -C----------------------------------------------------------------------- -C THIS BLOCK HANDLES ALL UNSUCCESSFUL -C RETURNS OTHER THAN FOR ILLEGAL INPUT. -C----------------------------------------------------------------------- -C -600 CONTINUE - ITEMP=-IDID - GO TO (610,620,630,690,690,640,650,660,670,675, - * 680,685), ITEMP -C -C THE MAXIMUM NUMBER OF STEPS WAS TAKEN BEFORE -C REACHING TOUT -610 WRITE (XERN3, '(1P,D15.6)') TN - CALL XERMSG ('SLATEC', 'DDASSL', - * 'AT CURRENT T = ' // XERN3 // ' 500 STEPS TAKEN ON THIS ' // - * 'CALL BEFORE REACHING TOUT', IDID, 1) - GO TO 690 -C -C TOO MUCH ACCURACY FOR MACHINE PRECISION -620 WRITE (XERN3, '(1P,D15.6)') TN - CALL XERMSG ('SLATEC', 'DDASSL', - * 'AT T = ' // XERN3 // ' TOO MUCH ACCURACY REQUESTED FOR ' // - * 'PRECISION OF MACHINE. RTOL AND ATOL WERE INCREASED TO ' // - * 'APPROPRIATE VALUES', IDID, 1) - GO TO 690 -C -C WT(I) .LE. 0.0 FOR SOME I (NOT AT START OF PROBLEM) -630 WRITE (XERN3, '(1P,D15.6)') TN - CALL XERMSG ('SLATEC', 'DDASSL', - * 'AT T = ' // XERN3 // ' SOME ELEMENT OF WT HAS BECOME .LE. ' // - * '0.0', IDID, 1) - GO TO 690 -C -C ERROR TEST FAILED REPEATEDLY OR WITH H=HMIN -640 WRITE (XERN3, '(1P,D15.6)') TN - WRITE (XERN4, '(1P,D15.6)') H - CALL XERMSG ('SLATEC', 'DDASSL', - * 'AT T = ' // XERN3 // ' AND STEPSIZE H = ' // XERN4 // - * ' THE ERROR TEST FAILED REPEATEDLY OR WITH ABS(H)=HMIN', - * IDID, 1) - GO TO 690 -C -C CORRECTOR CONVERGENCE FAILED REPEATEDLY OR WITH H=HMIN -650 WRITE (XERN3, '(1P,D15.6)') TN - WRITE (XERN4, '(1P,D15.6)') H - CALL XERMSG ('SLATEC', 'DDASSL', - * 'AT T = ' // XERN3 // ' AND STEPSIZE H = ' // XERN4 // - * ' THE CORRECTOR FAILED TO CONVERGE REPEATEDLY OR WITH ' // - * 'ABS(H)=HMIN', IDID, 1) - GO TO 690 -C -C THE ITERATION MATRIX IS SINGULAR -660 WRITE (XERN3, '(1P,D15.6)') TN - WRITE (XERN4, '(1P,D15.6)') H - CALL XERMSG ('SLATEC', 'DDASSL', - * 'AT T = ' // XERN3 // ' AND STEPSIZE H = ' // XERN4 // - * ' THE ITERATION MATRIX IS SINGULAR', IDID, 1) - GO TO 690 -C -C CORRECTOR FAILURE PRECEEDED BY ERROR TEST FAILURES. -670 WRITE (XERN3, '(1P,D15.6)') TN - WRITE (XERN4, '(1P,D15.6)') H - CALL XERMSG ('SLATEC', 'DDASSL', - * 'AT T = ' // XERN3 // ' AND STEPSIZE H = ' // XERN4 // - * ' THE CORRECTOR COULD NOT CONVERGE. ALSO, THE ERROR TEST ' // - * 'FAILED REPEATEDLY.', IDID, 1) - GO TO 690 -C -C CORRECTOR FAILURE BECAUSE IRES = -1 -675 WRITE (XERN3, '(1P,D15.6)') TN - WRITE (XERN4, '(1P,D15.6)') H - CALL XERMSG ('SLATEC', 'DDASSL', - * 'AT T = ' // XERN3 // ' AND STEPSIZE H = ' // XERN4 // - * ' THE CORRECTOR COULD NOT CONVERGE BECAUSE IRES WAS EQUAL ' // - * 'TO MINUS ONE', IDID, 1) - GO TO 690 -C -C FAILURE BECAUSE IRES = -2 -680 WRITE (XERN3, '(1P,D15.6)') TN - WRITE (XERN4, '(1P,D15.6)') H - CALL XERMSG ('SLATEC', 'DDASSL', - * 'AT T = ' // XERN3 // ' AND STEPSIZE H = ' // XERN4 // - * ' IRES WAS EQUAL TO MINUS TWO', IDID, 1) - GO TO 690 -C -C FAILED TO COMPUTE INITIAL YPRIME -685 WRITE (XERN3, '(1P,D15.6)') TN - WRITE (XERN4, '(1P,D15.6)') HO - CALL XERMSG ('SLATEC', 'DDASSL', - * 'AT T = ' // XERN3 // ' AND STEPSIZE H = ' // XERN4 // - * ' THE INITIAL YPRIME COULD NOT BE COMPUTED', IDID, 1) - GO TO 690 -C -690 CONTINUE - INFO(1)=-1 - T=TN - RWORK(LTN)=TN - RWORK(LH)=H - RETURN -C -C----------------------------------------------------------------------- -C THIS BLOCK HANDLES ALL ERROR RETURNS DUE -C TO ILLEGAL INPUT, AS DETECTED BEFORE CALLING -C DDASTP. FIRST THE ERROR MESSAGE ROUTINE IS -C CALLED. IF THIS HAPPENS TWICE IN -C SUCCESSION, EXECUTION IS TERMINATED -C -C----------------------------------------------------------------------- -701 CALL XERMSG ('SLATEC', 'DDASSL', - * 'SOME ELEMENT OF INFO VECTOR IS NOT ZERO OR ONE', 1, 1) - GO TO 750 -C -702 WRITE (XERN1, '(I8)') NEQ - CALL XERMSG ('SLATEC', 'DDASSL', - * 'NEQ = ' // XERN1 // ' .LE. 0', 2, 1) - GO TO 750 -C -703 WRITE (XERN1, '(I8)') MXORD - CALL XERMSG ('SLATEC', 'DDASSL', - * 'MAXORD = ' // XERN1 // ' NOT IN RANGE', 3, 1) - GO TO 750 -C -704 WRITE (XERN1, '(I8)') LENRW - WRITE (XERN2, '(I8)') LRW - CALL XERMSG ('SLATEC', 'DDASSL', - * 'RWORK LENGTH NEEDED, LENRW = ' // XERN1 // - * ', EXCEEDS LRW = ' // XERN2, 4, 1) - GO TO 750 -C -705 WRITE (XERN1, '(I8)') LENIW - WRITE (XERN2, '(I8)') LIW - CALL XERMSG ('SLATEC', 'DDASSL', - * 'IWORK LENGTH NEEDED, LENIW = ' // XERN1 // - * ', EXCEEDS LIW = ' // XERN2, 5, 1) - GO TO 750 -C -706 CALL XERMSG ('SLATEC', 'DDASSL', - * 'SOME ELEMENT OF RTOL IS .LT. 0', 6, 1) - GO TO 750 -C -707 CALL XERMSG ('SLATEC', 'DDASSL', - * 'SOME ELEMENT OF ATOL IS .LT. 0', 7, 1) - GO TO 750 -C -708 CALL XERMSG ('SLATEC', 'DDASSL', - * 'ALL ELEMENTS OF RTOL AND ATOL ARE ZERO', 8, 1) - GO TO 750 -C -709 WRITE (XERN3, '(1P,D15.6)') TSTOP - WRITE (XERN4, '(1P,D15.6)') TOUT - CALL XERMSG ('SLATEC', 'DDASSL', - * 'INFO(4) = 1 AND TSTOP = ' // XERN3 // ' BEHIND TOUT = ' // - * XERN4, 9, 1) - GO TO 750 -C -710 WRITE (XERN3, '(1P,D15.6)') HMAX - CALL XERMSG ('SLATEC', 'DDASSL', - * 'HMAX = ' // XERN3 // ' .LT. 0.0', 10, 1) - GO TO 750 -C -711 WRITE (XERN3, '(1P,D15.6)') TOUT - WRITE (XERN4, '(1P,D15.6)') T - CALL XERMSG ('SLATEC', 'DDASSL', - * 'TOUT = ' // XERN3 // ' BEHIND T = ' // XERN4, 11, 1) - GO TO 750 -C -712 CALL XERMSG ('SLATEC', 'DDASSL', - * 'INFO(8)=1 AND H0=0.0', 12, 1) - GO TO 750 -C -713 CALL XERMSG ('SLATEC', 'DDASSL', - * 'SOME ELEMENT OF WT IS .LE. 0.0', 13, 1) - GO TO 750 -C -714 WRITE (XERN3, '(1P,D15.6)') TOUT - WRITE (XERN4, '(1P,D15.6)') T - CALL XERMSG ('SLATEC', 'DDASSL', - * 'TOUT = ' // XERN3 // ' TOO CLOSE TO T = ' // XERN4 // - * ' TO START INTEGRATION', 14, 1) - GO TO 750 -C -715 WRITE (XERN3, '(1P,D15.6)') TSTOP - WRITE (XERN4, '(1P,D15.6)') T - CALL XERMSG ('SLATEC', 'DDASSL', - * 'INFO(4)=1 AND TSTOP = ' // XERN3 // ' BEHIND T = ' // XERN4, - * 15, 1) - GO TO 750 -C -716 WRITE (XERN1, '(I8)') MXSTP - CALL XERMSG ('SLATEC', 'DDASSL', - * 'INFO(12)=1 AND MXSTP = ' // XERN1 // ' ILLEGAL.', 3, 1) - GO TO 750 -C -717 WRITE (XERN1, '(I8)') IWORK(LML) - CALL XERMSG ('SLATEC', 'DDASSL', - * 'ML = ' // XERN1 // ' ILLEGAL. EITHER .LT. 0 OR .GT. NEQ', - * 17, 1) - GO TO 750 -C -718 WRITE (XERN1, '(I8)') IWORK(LMU) - CALL XERMSG ('SLATEC', 'DDASSL', - * 'MU = ' // XERN1 // ' ILLEGAL. EITHER .LT. 0 OR .GT. NEQ', - * 18, 1) - GO TO 750 -C -719 WRITE (XERN3, '(1P,D15.6)') TOUT - CALL XERMSG ('SLATEC', 'DDASSL', - * 'TOUT = T = ' // XERN3, 19, 1) - GO TO 750 -C -750 IDID=-33 - IF(INFO(1).EQ.-1) THEN - CALL XERMSG ('SLATEC', 'DDASSL', - * 'REPEATED OCCURRENCES OF ILLEGAL INPUT$$' // - * 'RUN TERMINATED. APPARENT INFINITE LOOP', -999, 2) - ENDIF -C - INFO(1)=-1 - RETURN -C-----------END OF SUBROUTINE DDASSL------------------------------------ - END
--- a/liboctave/cruft/dassl/ddastp.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,612 +0,0 @@ - SUBROUTINE DDASTP (X, Y, YPRIME, NEQ, RES, JAC, H, WT, JSTART, - + IDID, RPAR, IPAR, PHI, DELTA, E, WM, IWM, ALPHA, BETA, GAMMA, - + PSI, SIGMA, CJ, CJOLD, HOLD, S, HMIN, UROUND, IPHASE, JCALC, - + K, KOLD, NS, NONNEG, NTEMP) -C***BEGIN PROLOGUE DDASTP -C***SUBSIDIARY -C***PURPOSE Perform one step of the DDASSL integration. -C***LIBRARY SLATEC (DASSL) -C***TYPE DOUBLE PRECISION (SDASTP-S, DDASTP-D) -C***AUTHOR PETZOLD, LINDA R., (LLNL) -C***DESCRIPTION -C----------------------------------------------------------------------- -C DDASTP SOLVES A SYSTEM OF DIFFERENTIAL/ -C ALGEBRAIC EQUATIONS OF THE FORM -C G(X,Y,YPRIME) = 0, FOR ONE STEP (NORMALLY -C FROM X TO X+H). -C -C THE METHODS USED ARE MODIFIED DIVIDED -C DIFFERENCE,FIXED LEADING COEFFICIENT -C FORMS OF BACKWARD DIFFERENTIATION -C FORMULAS. THE CODE ADJUSTS THE STEPSIZE -C AND ORDER TO CONTROL THE LOCAL ERROR PER -C STEP. -C -C -C THE PARAMETERS REPRESENT -C X -- INDEPENDENT VARIABLE -C Y -- SOLUTION VECTOR AT X -C YPRIME -- DERIVATIVE OF SOLUTION VECTOR -C AFTER SUCCESSFUL STEP -C NEQ -- NUMBER OF EQUATIONS TO BE INTEGRATED -C RES -- EXTERNAL USER-SUPPLIED SUBROUTINE -C TO EVALUATE THE RESIDUAL. THE CALL IS -C CALL RES(X,Y,YPRIME,DELTA,IRES,RPAR,IPAR) -C X,Y,YPRIME ARE INPUT. DELTA IS OUTPUT. -C ON INPUT, IRES=0. RES SHOULD ALTER IRES ONLY -C IF IT ENCOUNTERS AN ILLEGAL VALUE OF Y OR A -C STOP CONDITION. SET IRES=-1 IF AN INPUT VALUE -C OF Y IS ILLEGAL, AND DDASTP WILL TRY TO SOLVE -C THE PROBLEM WITHOUT GETTING IRES = -1. IF -C IRES=-2, DDASTP RETURNS CONTROL TO THE CALLING -C PROGRAM WITH IDID = -11. -C JAC -- EXTERNAL USER-SUPPLIED ROUTINE TO EVALUATE -C THE ITERATION MATRIX (THIS IS OPTIONAL) -C THE CALL IS OF THE FORM -C CALL JAC(X,Y,YPRIME,PD,CJ,RPAR,IPAR) -C PD IS THE MATRIX OF PARTIAL DERIVATIVES, -C PD=DG/DY+CJ*DG/DYPRIME -C H -- APPROPRIATE STEP SIZE FOR NEXT STEP. -C NORMALLY DETERMINED BY THE CODE -C WT -- VECTOR OF WEIGHTS FOR ERROR CRITERION. -C JSTART -- INTEGER VARIABLE SET 0 FOR -C FIRST STEP, 1 OTHERWISE. -C IDID -- COMPLETION CODE WITH THE FOLLOWING MEANINGS: -C IDID= 1 -- THE STEP WAS COMPLETED SUCCESSFULLY -C IDID=-6 -- THE ERROR TEST FAILED REPEATEDLY -C IDID=-7 -- THE CORRECTOR COULD NOT CONVERGE -C IDID=-8 -- THE ITERATION MATRIX IS SINGULAR -C IDID=-9 -- THE CORRECTOR COULD NOT CONVERGE. -C THERE WERE REPEATED ERROR TEST -C FAILURES ON THIS STEP. -C IDID=-10-- THE CORRECTOR COULD NOT CONVERGE -C BECAUSE IRES WAS EQUAL TO MINUS ONE -C IDID=-11-- IRES EQUAL TO -2 WAS ENCOUNTERED, -C AND CONTROL IS BEING RETURNED TO -C THE CALLING PROGRAM -C RPAR,IPAR -- REAL AND INTEGER PARAMETER ARRAYS THAT -C ARE USED FOR COMMUNICATION BETWEEN THE -C CALLING PROGRAM AND EXTERNAL USER ROUTINES -C THEY ARE NOT ALTERED BY DDASTP -C PHI -- ARRAY OF DIVIDED DIFFERENCES USED BY -C DDASTP. THE LENGTH IS NEQ*(K+1),WHERE -C K IS THE MAXIMUM ORDER -C DELTA,E -- WORK VECTORS FOR DDASTP OF LENGTH NEQ -C WM,IWM -- REAL AND INTEGER ARRAYS STORING -C MATRIX INFORMATION SUCH AS THE MATRIX -C OF PARTIAL DERIVATIVES,PERMUTATION -C VECTOR,AND VARIOUS OTHER INFORMATION. -C -C THE OTHER PARAMETERS ARE INFORMATION -C WHICH IS NEEDED INTERNALLY BY DDASTP TO -C CONTINUE FROM STEP TO STEP. -C -C----------------------------------------------------------------------- -C***ROUTINES CALLED DDAJAC, DDANRM, DDASLV, DDATRP -C***REVISION HISTORY (YYMMDD) -C 830315 DATE WRITTEN -C 901009 Finished conversion to SLATEC 4.0 format (F.N.Fritsch) -C 901019 Merged changes made by C. Ulrich with SLATEC 4.0 format. -C 901026 Added explicit declarations for all variables and minor -C cosmetic changes to prologue. (FNF) -C***END PROLOGUE DDASTP -C - INTEGER NEQ, JSTART, IDID, IPAR(*), IWM(*), IPHASE, JCALC, K, - * KOLD, NS, NONNEG, NTEMP - DOUBLE PRECISION - * X, Y(*), YPRIME(*), H, WT(*), RPAR(*), PHI(NEQ,*), DELTA(*), - * E(*), WM(*), ALPHA(*), BETA(*), GAMMA(*), PSI(*), SIGMA(*), CJ, - * CJOLD, HOLD, S, HMIN, UROUND - EXTERNAL RES, JAC -C - EXTERNAL DDAJAC, DDANRM, DDASLV, DDATRP - DOUBLE PRECISION DDANRM -C - INTEGER I, IER, IRES, J, J1, KDIFF, KM1, KNEW, KP1, KP2, LCTF, - * LETF, LMXORD, LNJE, LNRE, LNST, M, MAXIT, NCF, NEF, NSF, NSP1 - DOUBLE PRECISION - * ALPHA0, ALPHAS, CJLAST, CK, DELNRM, ENORM, ERK, ERKM1, - * ERKM2, ERKP1, ERR, EST, HNEW, OLDNRM, PNORM, R, RATE, TEMP1, - * TEMP2, TERK, TERKM1, TERKM2, TERKP1, XOLD, XRATE - LOGICAL CONVGD -C - PARAMETER (LMXORD=3) - PARAMETER (LNST=11) - PARAMETER (LNRE=12) - PARAMETER (LNJE=13) - PARAMETER (LETF=14) - PARAMETER (LCTF=15) -C - DATA MAXIT/4/ - DATA XRATE/0.25D0/ -C -C -C -C -C -C----------------------------------------------------------------------- -C BLOCK 1. -C INITIALIZE. ON THE FIRST CALL,SET -C THE ORDER TO 1 AND INITIALIZE -C OTHER VARIABLES. -C----------------------------------------------------------------------- -C -C INITIALIZATIONS FOR ALL CALLS -C***FIRST EXECUTABLE STATEMENT DDASTP - IDID=1 - XOLD=X - NCF=0 - NSF=0 - NEF=0 - IF(JSTART .NE. 0) GO TO 120 -C -C IF THIS IS THE FIRST STEP,PERFORM -C OTHER INITIALIZATIONS - IWM(LETF) = 0 - IWM(LCTF) = 0 - K=1 - KOLD=0 - HOLD=0.0D0 - JSTART=1 - PSI(1)=H - CJOLD = 1.0D0/H - CJ = CJOLD - S = 100.D0 - JCALC = -1 - DELNRM=1.0D0 - IPHASE = 0 - NS=0 -120 CONTINUE -C -C -C -C -C -C----------------------------------------------------------------------- -C BLOCK 2 -C COMPUTE COEFFICIENTS OF FORMULAS FOR -C THIS STEP. -C----------------------------------------------------------------------- -200 CONTINUE - KP1=K+1 - KP2=K+2 - KM1=K-1 - XOLD=X - IF(H.NE.HOLD.OR.K .NE. KOLD) NS = 0 - NS=MIN(NS+1,KOLD+2) - NSP1=NS+1 - IF(KP1 .LT. NS)GO TO 230 -C - BETA(1)=1.0D0 - ALPHA(1)=1.0D0 - TEMP1=H - GAMMA(1)=0.0D0 - SIGMA(1)=1.0D0 - DO 210 I=2,KP1 - TEMP2=PSI(I-1) - PSI(I-1)=TEMP1 - BETA(I)=BETA(I-1)*PSI(I-1)/TEMP2 - TEMP1=TEMP2+H - ALPHA(I)=H/TEMP1 - SIGMA(I)=(I-1)*SIGMA(I-1)*ALPHA(I) - GAMMA(I)=GAMMA(I-1)+ALPHA(I-1)/H -210 CONTINUE - PSI(KP1)=TEMP1 -230 CONTINUE -C -C COMPUTE ALPHAS, ALPHA0 - ALPHAS = 0.0D0 - ALPHA0 = 0.0D0 - DO 240 I = 1,K - ALPHAS = ALPHAS - 1.0D0/I - ALPHA0 = ALPHA0 - ALPHA(I) -240 CONTINUE -C -C COMPUTE LEADING COEFFICIENT CJ - CJLAST = CJ - CJ = -ALPHAS/H -C -C COMPUTE VARIABLE STEPSIZE ERROR COEFFICIENT CK - CK = ABS(ALPHA(KP1) + ALPHAS - ALPHA0) - CK = MAX(CK,ALPHA(KP1)) -C -C DECIDE WHETHER NEW JACOBIAN IS NEEDED - TEMP1 = (1.0D0 - XRATE)/(1.0D0 + XRATE) - TEMP2 = 1.0D0/TEMP1 - IF (CJ/CJOLD .LT. TEMP1 .OR. CJ/CJOLD .GT. TEMP2) JCALC = -1 - IF (CJ .NE. CJLAST) S = 100.D0 -C -C CHANGE PHI TO PHI STAR - IF(KP1 .LT. NSP1) GO TO 280 - DO 270 J=NSP1,KP1 - DO 260 I=1,NEQ -260 PHI(I,J)=BETA(J)*PHI(I,J) -270 CONTINUE -280 CONTINUE -C -C UPDATE TIME - X=X+H -C -C -C -C -C -C----------------------------------------------------------------------- -C BLOCK 3 -C PREDICT THE SOLUTION AND DERIVATIVE, -C AND SOLVE THE CORRECTOR EQUATION -C----------------------------------------------------------------------- -C -C FIRST,PREDICT THE SOLUTION AND DERIVATIVE -300 CONTINUE - DO 310 I=1,NEQ - Y(I)=PHI(I,1) -310 YPRIME(I)=0.0D0 - DO 330 J=2,KP1 - DO 320 I=1,NEQ - Y(I)=Y(I)+PHI(I,J) -320 YPRIME(I)=YPRIME(I)+GAMMA(J)*PHI(I,J) -330 CONTINUE - PNORM = DDANRM (NEQ,Y,WT,RPAR,IPAR) -C -C -C -C SOLVE THE CORRECTOR EQUATION USING A -C MODIFIED NEWTON SCHEME. - CONVGD= .TRUE. - M=0 - IWM(LNRE)=IWM(LNRE)+1 - IRES = 0 - CALL RES(X,Y,YPRIME,DELTA,IRES,RPAR,IPAR) - IF (IRES .LT. 0) GO TO 380 -C -C -C IF INDICATED,REEVALUATE THE -C ITERATION MATRIX PD = DG/DY + CJ*DG/DYPRIME -C (WHERE G(X,Y,YPRIME)=0). SET -C JCALC TO 0 AS AN INDICATOR THAT -C THIS HAS BEEN DONE. - IF(JCALC .NE. -1)GO TO 340 - IWM(LNJE)=IWM(LNJE)+1 - JCALC=0 - CALL DDAJAC(NEQ,X,Y,YPRIME,DELTA,CJ,H, - * IER,WT,E,WM,IWM,RES,IRES,UROUND,JAC,RPAR, - * IPAR,NTEMP) - CJOLD=CJ - S = 100.D0 - IF (IRES .LT. 0) GO TO 380 - IF(IER .NE. 0)GO TO 380 - NSF=0 -C -C -C INITIALIZE THE ERROR ACCUMULATION VECTOR E. -340 CONTINUE - DO 345 I=1,NEQ -345 E(I)=0.0D0 -C -C -C CORRECTOR LOOP. -350 CONTINUE -C -C MULTIPLY RESIDUAL BY TEMP1 TO ACCELERATE CONVERGENCE - TEMP1 = 2.0D0/(1.0D0 + CJ/CJOLD) - DO 355 I = 1,NEQ -355 DELTA(I) = DELTA(I) * TEMP1 -C -C COMPUTE A NEW ITERATE (BACK-SUBSTITUTION). -C STORE THE CORRECTION IN DELTA. - CALL DDASLV(NEQ,DELTA,WM,IWM) -C -C UPDATE Y,E,AND YPRIME - DO 360 I=1,NEQ - Y(I)=Y(I)-DELTA(I) - E(I)=E(I)-DELTA(I) -360 YPRIME(I)=YPRIME(I)-CJ*DELTA(I) -C -C TEST FOR CONVERGENCE OF THE ITERATION - DELNRM=DDANRM(NEQ,DELTA,WT,RPAR,IPAR) - IF (DELNRM .LE. 100.D0*UROUND*PNORM) GO TO 375 - IF (M .GT. 0) GO TO 365 - OLDNRM = DELNRM - GO TO 367 -365 RATE = (DELNRM/OLDNRM)**(1.0D0/M) - IF (RATE .GT. 0.90D0) GO TO 370 - S = RATE/(1.0D0 - RATE) -367 IF (S*DELNRM .LE. 0.33D0) GO TO 375 -C -C THE CORRECTOR HAS NOT YET CONVERGED. -C UPDATE M AND TEST WHETHER THE -C MAXIMUM NUMBER OF ITERATIONS HAVE -C BEEN TRIED. - M=M+1 - IF(M.GE.MAXIT)GO TO 370 -C -C EVALUATE THE RESIDUAL -C AND GO BACK TO DO ANOTHER ITERATION - IWM(LNRE)=IWM(LNRE)+1 - IRES = 0 - CALL RES(X,Y,YPRIME,DELTA,IRES, - * RPAR,IPAR) - IF (IRES .LT. 0) GO TO 380 - GO TO 350 -C -C -C THE CORRECTOR FAILED TO CONVERGE IN MAXIT -C ITERATIONS. IF THE ITERATION MATRIX -C IS NOT CURRENT,RE-DO THE STEP WITH -C A NEW ITERATION MATRIX. -370 CONTINUE - IF(JCALC.EQ.0)GO TO 380 - JCALC=-1 - GO TO 300 -C -C -C THE ITERATION HAS CONVERGED. IF NONNEGATIVITY OF SOLUTION IS -C REQUIRED, SET THE SOLUTION NONNEGATIVE, IF THE PERTURBATION -C TO DO IT IS SMALL ENOUGH. IF THE CHANGE IS TOO LARGE, THEN -C CONSIDER THE CORRECTOR ITERATION TO HAVE FAILED. -375 IF(NONNEG .EQ. 0) GO TO 390 - DO 377 I = 1,NEQ -377 DELTA(I) = MIN(Y(I),0.0D0) - DELNRM = DDANRM(NEQ,DELTA,WT,RPAR,IPAR) - IF(DELNRM .GT. 0.33D0) GO TO 380 - DO 378 I = 1,NEQ -378 E(I) = E(I) - DELTA(I) - GO TO 390 -C -C -C EXITS FROM BLOCK 3 -C NO CONVERGENCE WITH CURRENT ITERATION -C MATRIX,OR SINGULAR ITERATION MATRIX -380 CONVGD= .FALSE. -390 JCALC = 1 - IF(.NOT.CONVGD)GO TO 600 -C -C -C -C -C -C----------------------------------------------------------------------- -C BLOCK 4 -C ESTIMATE THE ERRORS AT ORDERS K,K-1,K-2 -C AS IF CONSTANT STEPSIZE WAS USED. ESTIMATE -C THE LOCAL ERROR AT ORDER K AND TEST -C WHETHER THE CURRENT STEP IS SUCCESSFUL. -C----------------------------------------------------------------------- -C -C ESTIMATE ERRORS AT ORDERS K,K-1,K-2 - ENORM = DDANRM(NEQ,E,WT,RPAR,IPAR) - ERK = SIGMA(K+1)*ENORM - TERK = (K+1)*ERK - EST = ERK - KNEW=K - IF(K .EQ. 1)GO TO 430 - DO 405 I = 1,NEQ -405 DELTA(I) = PHI(I,KP1) + E(I) - ERKM1=SIGMA(K)*DDANRM(NEQ,DELTA,WT,RPAR,IPAR) - TERKM1 = K*ERKM1 - IF(K .GT. 2)GO TO 410 - IF(TERKM1 .LE. 0.5D0*TERK)GO TO 420 - GO TO 430 -410 CONTINUE - DO 415 I = 1,NEQ -415 DELTA(I) = PHI(I,K) + DELTA(I) - ERKM2=SIGMA(K-1)*DDANRM(NEQ,DELTA,WT,RPAR,IPAR) - TERKM2 = (K-1)*ERKM2 - IF(MAX(TERKM1,TERKM2).GT.TERK)GO TO 430 -C LOWER THE ORDER -420 CONTINUE - KNEW=K-1 - EST = ERKM1 -C -C -C CALCULATE THE LOCAL ERROR FOR THE CURRENT STEP -C TO SEE IF THE STEP WAS SUCCESSFUL -430 CONTINUE - ERR = CK * ENORM - IF(ERR .GT. 1.0D0)GO TO 600 -C -C -C -C -C -C----------------------------------------------------------------------- -C BLOCK 5 -C THE STEP IS SUCCESSFUL. DETERMINE -C THE BEST ORDER AND STEPSIZE FOR -C THE NEXT STEP. UPDATE THE DIFFERENCES -C FOR THE NEXT STEP. -C----------------------------------------------------------------------- - IDID=1 - IWM(LNST)=IWM(LNST)+1 - KDIFF=K-KOLD - KOLD=K - HOLD=H -C -C -C ESTIMATE THE ERROR AT ORDER K+1 UNLESS: -C ALREADY DECIDED TO LOWER ORDER, OR -C ALREADY USING MAXIMUM ORDER, OR -C STEPSIZE NOT CONSTANT, OR -C ORDER RAISED IN PREVIOUS STEP - IF(KNEW.EQ.KM1.OR.K.EQ.IWM(LMXORD))IPHASE=1 - IF(IPHASE .EQ. 0)GO TO 545 - IF(KNEW.EQ.KM1)GO TO 540 - IF(K.EQ.IWM(LMXORD)) GO TO 550 - IF(KP1.GE.NS.OR.KDIFF.EQ.1)GO TO 550 - DO 510 I=1,NEQ -510 DELTA(I)=E(I)-PHI(I,KP2) - ERKP1 = (1.0D0/(K+2))*DDANRM(NEQ,DELTA,WT,RPAR,IPAR) - TERKP1 = (K+2)*ERKP1 - IF(K.GT.1)GO TO 520 - IF(TERKP1.GE.0.5D0*TERK)GO TO 550 - GO TO 530 -520 IF(TERKM1.LE.MIN(TERK,TERKP1))GO TO 540 - IF(TERKP1.GE.TERK.OR.K.EQ.IWM(LMXORD))GO TO 550 -C -C RAISE ORDER -530 K=KP1 - EST = ERKP1 - GO TO 550 -C -C LOWER ORDER -540 K=KM1 - EST = ERKM1 - GO TO 550 -C -C IF IPHASE = 0, INCREASE ORDER BY ONE AND MULTIPLY STEPSIZE BY -C FACTOR TWO -545 K = KP1 - HNEW = H*2.0D0 - H = HNEW - GO TO 575 -C -C -C DETERMINE THE APPROPRIATE STEPSIZE FOR -C THE NEXT STEP. -550 HNEW=H - TEMP2=K+1 - R=(2.0D0*EST+0.0001D0)**(-1.0D0/TEMP2) - IF(R .LT. 2.0D0) GO TO 555 - HNEW = 2.0D0*H - GO TO 560 -555 IF(R .GT. 1.0D0) GO TO 560 - R = MAX(0.5D0,MIN(0.9D0,R)) - HNEW = H*R -560 H=HNEW -C -C -C UPDATE DIFFERENCES FOR NEXT STEP -575 CONTINUE - IF(KOLD.EQ.IWM(LMXORD))GO TO 585 - DO 580 I=1,NEQ -580 PHI(I,KP2)=E(I) -585 CONTINUE - DO 590 I=1,NEQ -590 PHI(I,KP1)=PHI(I,KP1)+E(I) - DO 595 J1=2,KP1 - J=KP1-J1+1 - DO 595 I=1,NEQ -595 PHI(I,J)=PHI(I,J)+PHI(I,J+1) - RETURN -C -C -C -C -C -C----------------------------------------------------------------------- -C BLOCK 6 -C THE STEP IS UNSUCCESSFUL. RESTORE X,PSI,PHI -C DETERMINE APPROPRIATE STEPSIZE FOR -C CONTINUING THE INTEGRATION, OR EXIT WITH -C AN ERROR FLAG IF THERE HAVE BEEN MANY -C FAILURES. -C----------------------------------------------------------------------- -600 IPHASE = 1 -C -C RESTORE X,PHI,PSI - X=XOLD - IF(KP1.LT.NSP1)GO TO 630 - DO 620 J=NSP1,KP1 - TEMP1=1.0D0/BETA(J) - DO 610 I=1,NEQ -610 PHI(I,J)=TEMP1*PHI(I,J) -620 CONTINUE -630 CONTINUE - DO 640 I=2,KP1 -640 PSI(I-1)=PSI(I)-H -C -C -C TEST WHETHER FAILURE IS DUE TO CORRECTOR ITERATION -C OR ERROR TEST - IF(CONVGD)GO TO 660 - IWM(LCTF)=IWM(LCTF)+1 -C -C -C THE NEWTON ITERATION FAILED TO CONVERGE WITH -C A CURRENT ITERATION MATRIX. DETERMINE THE CAUSE -C OF THE FAILURE AND TAKE APPROPRIATE ACTION. - IF(IER.EQ.0)GO TO 650 -C -C THE ITERATION MATRIX IS SINGULAR. REDUCE -C THE STEPSIZE BY A FACTOR OF 4. IF -C THIS HAPPENS THREE TIMES IN A ROW ON -C THE SAME STEP, RETURN WITH AN ERROR FLAG - NSF=NSF+1 - R = 0.25D0 - H=H*R - IF (NSF .LT. 3 .AND. ABS(H) .GE. HMIN) GO TO 690 - IDID=-8 - GO TO 675 -C -C -C THE NEWTON ITERATION FAILED TO CONVERGE FOR A REASON -C OTHER THAN A SINGULAR ITERATION MATRIX. IF IRES = -2, THEN -C RETURN. OTHERWISE, REDUCE THE STEPSIZE AND TRY AGAIN, UNLESS -C TOO MANY FAILURES HAVE OCCURRED. -650 CONTINUE - IF (IRES .GT. -2) GO TO 655 - IDID = -11 - GO TO 675 -655 NCF = NCF + 1 - R = 0.25D0 - H = H*R - IF (NCF .LT. 10 .AND. ABS(H) .GE. HMIN) GO TO 690 - IDID = -7 - IF (IRES .LT. 0) IDID = -10 - IF (NEF .GE. 3) IDID = -9 - GO TO 675 -C -C -C THE NEWTON SCHEME CONVERGED,AND THE CAUSE -C OF THE FAILURE WAS THE ERROR ESTIMATE -C EXCEEDING THE TOLERANCE. -660 NEF=NEF+1 - IWM(LETF)=IWM(LETF)+1 - IF (NEF .GT. 1) GO TO 665 -C -C ON FIRST ERROR TEST FAILURE, KEEP CURRENT ORDER OR LOWER -C ORDER BY ONE. COMPUTE NEW STEPSIZE BASED ON DIFFERENCES -C OF THE SOLUTION. - K = KNEW - TEMP2 = K + 1 - R = 0.90D0*(2.0D0*EST+0.0001D0)**(-1.0D0/TEMP2) - R = MAX(0.25D0,MIN(0.9D0,R)) - H = H*R - IF (ABS(H) .GE. HMIN) GO TO 690 - IDID = -6 - GO TO 675 -C -C ON SECOND ERROR TEST FAILURE, USE THE CURRENT ORDER OR -C DECREASE ORDER BY ONE. REDUCE THE STEPSIZE BY A FACTOR OF -C FOUR. -665 IF (NEF .GT. 2) GO TO 670 - K = KNEW - H = 0.25D0*H - IF (ABS(H) .GE. HMIN) GO TO 690 - IDID = -6 - GO TO 675 -C -C ON THIRD AND SUBSEQUENT ERROR TEST FAILURES, SET THE ORDER TO -C ONE AND REDUCE THE STEPSIZE BY A FACTOR OF FOUR. -670 K = 1 - H = 0.25D0*H - IF (ABS(H) .GE. HMIN) GO TO 690 - IDID = -6 - GO TO 675 -C -C -C -C -C FOR ALL CRASHES, RESTORE Y TO ITS LAST VALUE, -C INTERPOLATE TO FIND YPRIME AT LAST X, AND RETURN -675 CONTINUE - CALL DDATRP(X,X,Y,YPRIME,NEQ,K,PHI,PSI) - RETURN -C -C -C GO BACK AND TRY THIS STEP AGAIN -690 GO TO 200 -C -C------END OF SUBROUTINE DDASTP------ - END
--- a/liboctave/cruft/dassl/ddatrp.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,64 +0,0 @@ - SUBROUTINE DDATRP (X, XOUT, YOUT, YPOUT, NEQ, KOLD, PHI, PSI) -C***BEGIN PROLOGUE DDATRP -C***SUBSIDIARY -C***PURPOSE Interpolation routine for DDASSL. -C***LIBRARY SLATEC (DASSL) -C***TYPE DOUBLE PRECISION (SDATRP-S, DDATRP-D) -C***AUTHOR PETZOLD, LINDA R., (LLNL) -C***DESCRIPTION -C----------------------------------------------------------------------- -C THE METHODS IN SUBROUTINE DDASTP USE POLYNOMIALS -C TO APPROXIMATE THE SOLUTION. DDATRP APPROXIMATES THE -C SOLUTION AND ITS DERIVATIVE AT TIME XOUT BY EVALUATING -C ONE OF THESE POLYNOMIALS,AND ITS DERIVATIVE,THERE. -C INFORMATION DEFINING THIS POLYNOMIAL IS PASSED FROM -C DDASTP, SO DDATRP CANNOT BE USED ALONE. -C -C THE PARAMETERS ARE: -C X THE CURRENT TIME IN THE INTEGRATION. -C XOUT THE TIME AT WHICH THE SOLUTION IS DESIRED -C YOUT THE INTERPOLATED APPROXIMATION TO Y AT XOUT -C (THIS IS OUTPUT) -C YPOUT THE INTERPOLATED APPROXIMATION TO YPRIME AT XOUT -C (THIS IS OUTPUT) -C NEQ NUMBER OF EQUATIONS -C KOLD ORDER USED ON LAST SUCCESSFUL STEP -C PHI ARRAY OF SCALED DIVIDED DIFFERENCES OF Y -C PSI ARRAY OF PAST STEPSIZE HISTORY -C----------------------------------------------------------------------- -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 830315 DATE WRITTEN -C 901009 Finished conversion to SLATEC 4.0 format (F.N.Fritsch) -C 901019 Merged changes made by C. Ulrich with SLATEC 4.0 format. -C 901026 Added explicit declarations for all variables and minor -C cosmetic changes to prologue. (FNF) -C***END PROLOGUE DDATRP -C - INTEGER NEQ, KOLD - DOUBLE PRECISION X, XOUT, YOUT(*), YPOUT(*), PHI(NEQ,*), PSI(*) -C - INTEGER I, J, KOLDP1 - DOUBLE PRECISION C, D, GAMMA, TEMP1 -C -C***FIRST EXECUTABLE STATEMENT DDATRP - KOLDP1=KOLD+1 - TEMP1=XOUT-X - DO 10 I=1,NEQ - YOUT(I)=PHI(I,1) -10 YPOUT(I)=0.0D0 - C=1.0D0 - D=0.0D0 - GAMMA=TEMP1/PSI(1) - DO 30 J=2,KOLDP1 - D=D*GAMMA+C/PSI(J-1) - C=C*GAMMA - GAMMA=(TEMP1+PSI(J-1))/PSI(J) - DO 20 I=1,NEQ - YOUT(I)=YOUT(I)+C*PHI(I,J) -20 YPOUT(I)=YPOUT(I)+D*PHI(I,J) -30 CONTINUE - RETURN -C -C------END OF SUBROUTINE DDATRP------ - END
--- a/liboctave/cruft/dassl/ddawts.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,42 +0,0 @@ - SUBROUTINE DDAWTS (NEQ, IWT, RTOL, ATOL, Y, WT, RPAR, IPAR) -C***BEGIN PROLOGUE DDAWTS -C***SUBSIDIARY -C***PURPOSE Set error weight vector for DDASSL. -C***LIBRARY SLATEC (DASSL) -C***TYPE DOUBLE PRECISION (SDAWTS-S, DDAWTS-D) -C***AUTHOR PETZOLD, LINDA R., (LLNL) -C***DESCRIPTION -C----------------------------------------------------------------------- -C THIS SUBROUTINE SETS THE ERROR WEIGHT VECTOR -C WT ACCORDING TO WT(I)=RTOL(I)*ABS(Y(I))+ATOL(I), -C I=1,-,N. -C RTOL AND ATOL ARE SCALARS IF IWT = 0, -C AND VECTORS IF IWT = 1. -C----------------------------------------------------------------------- -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 830315 DATE WRITTEN -C 901009 Finished conversion to SLATEC 4.0 format (F.N.Fritsch) -C 901019 Merged changes made by C. Ulrich with SLATEC 4.0 format. -C 901026 Added explicit declarations for all variables and minor -C cosmetic changes to prologue. (FNF) -C***END PROLOGUE DDAWTS -C - INTEGER NEQ, IWT, IPAR(*) - DOUBLE PRECISION RTOL(*), ATOL(*), Y(*), WT(*), RPAR(*) -C - INTEGER I - DOUBLE PRECISION ATOLI, RTOLI -C -C***FIRST EXECUTABLE STATEMENT DDAWTS - RTOLI=RTOL(1) - ATOLI=ATOL(1) - DO 20 I=1,NEQ - IF (IWT .EQ.0) GO TO 10 - RTOLI=RTOL(I) - ATOLI=ATOL(I) -10 WT(I)=RTOLI*ABS(Y(I))+ATOLI -20 CONTINUE - RETURN -C-----------END OF SUBROUTINE DDAWTS------------------------------------ - END
--- a/liboctave/cruft/dassl/module.mk Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,9 +0,0 @@ -CRUFT_SOURCES += \ - liboctave/cruft/dassl/ddaini.f \ - liboctave/cruft/dassl/ddajac.f \ - liboctave/cruft/dassl/ddanrm.f \ - liboctave/cruft/dassl/ddaslv.f \ - liboctave/cruft/dassl/ddassl.f \ - liboctave/cruft/dassl/ddastp.f \ - liboctave/cruft/dassl/ddatrp.f \ - liboctave/cruft/dassl/ddawts.f
--- a/liboctave/cruft/fftpack/cfftb.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,8 +0,0 @@ - subroutine cfftb (n,c,wsave) - dimension c(*) ,wsave(*) - if (n .eq. 1) return - iw1 = n+n+1 - iw2 = iw1+n+n - call cfftb1 (n,c,wsave,wsave(iw1),wsave(iw2)) - return - end
--- a/liboctave/cruft/fftpack/cfftb1.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,61 +0,0 @@ - subroutine cfftb1 (n,c,ch,wa,ifac) - dimension ch(*) ,c(*) ,wa(*) ,ifac(*) - nf = ifac(2) - na = 0 - l1 = 1 - iw = 1 - do 116 k1=1,nf - ip = ifac(k1+2) - l2 = ip*l1 - ido = n/l2 - idot = ido+ido - idl1 = idot*l1 - if (ip .ne. 4) go to 103 - ix2 = iw+idot - ix3 = ix2+idot - if (na .ne. 0) go to 101 - call passb4 (idot,l1,c,ch,wa(iw),wa(ix2),wa(ix3)) - go to 102 - 101 call passb4 (idot,l1,ch,c,wa(iw),wa(ix2),wa(ix3)) - 102 na = 1-na - go to 115 - 103 if (ip .ne. 2) go to 106 - if (na .ne. 0) go to 104 - call passb2 (idot,l1,c,ch,wa(iw)) - go to 105 - 104 call passb2 (idot,l1,ch,c,wa(iw)) - 105 na = 1-na - go to 115 - 106 if (ip .ne. 3) go to 109 - ix2 = iw+idot - if (na .ne. 0) go to 107 - call passb3 (idot,l1,c,ch,wa(iw),wa(ix2)) - go to 108 - 107 call passb3 (idot,l1,ch,c,wa(iw),wa(ix2)) - 108 na = 1-na - go to 115 - 109 if (ip .ne. 5) go to 112 - ix2 = iw+idot - ix3 = ix2+idot - ix4 = ix3+idot - if (na .ne. 0) go to 110 - call passb5 (idot,l1,c,ch,wa(iw),wa(ix2),wa(ix3),wa(ix4)) - go to 111 - 110 call passb5 (idot,l1,ch,c,wa(iw),wa(ix2),wa(ix3),wa(ix4)) - 111 na = 1-na - go to 115 - 112 if (na .ne. 0) go to 113 - call passb (nac,idot,ip,l1,idl1,c,c,c,ch,ch,wa(iw)) - go to 114 - 113 call passb (nac,idot,ip,l1,idl1,ch,ch,ch,c,c,wa(iw)) - 114 if (nac .ne. 0) na = 1-na - 115 l1 = l2 - iw = iw+(ip-1)*idot - 116 continue - if (na .eq. 0) return - n2 = n+n - do 117 i=1,n2 - c(i) = ch(i) - 117 continue - return - end
--- a/liboctave/cruft/fftpack/cfftf.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,8 +0,0 @@ - subroutine cfftf (n,c,wsave) - dimension c(*) ,wsave(*) - if (n .eq. 1) return - iw1 = n+n+1 - iw2 = iw1+n+n - call cfftf1 (n,c,wsave,wsave(iw1),wsave(iw2)) - return - end
--- a/liboctave/cruft/fftpack/cfftf1.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,61 +0,0 @@ - subroutine cfftf1 (n,c,ch,wa,ifac) - dimension ch(*) ,c(*) ,wa(*) ,ifac(*) - nf = ifac(2) - na = 0 - l1 = 1 - iw = 1 - do 116 k1=1,nf - ip = ifac(k1+2) - l2 = ip*l1 - ido = n/l2 - idot = ido+ido - idl1 = idot*l1 - if (ip .ne. 4) go to 103 - ix2 = iw+idot - ix3 = ix2+idot - if (na .ne. 0) go to 101 - call passf4 (idot,l1,c,ch,wa(iw),wa(ix2),wa(ix3)) - go to 102 - 101 call passf4 (idot,l1,ch,c,wa(iw),wa(ix2),wa(ix3)) - 102 na = 1-na - go to 115 - 103 if (ip .ne. 2) go to 106 - if (na .ne. 0) go to 104 - call passf2 (idot,l1,c,ch,wa(iw)) - go to 105 - 104 call passf2 (idot,l1,ch,c,wa(iw)) - 105 na = 1-na - go to 115 - 106 if (ip .ne. 3) go to 109 - ix2 = iw+idot - if (na .ne. 0) go to 107 - call passf3 (idot,l1,c,ch,wa(iw),wa(ix2)) - go to 108 - 107 call passf3 (idot,l1,ch,c,wa(iw),wa(ix2)) - 108 na = 1-na - go to 115 - 109 if (ip .ne. 5) go to 112 - ix2 = iw+idot - ix3 = ix2+idot - ix4 = ix3+idot - if (na .ne. 0) go to 110 - call passf5 (idot,l1,c,ch,wa(iw),wa(ix2),wa(ix3),wa(ix4)) - go to 111 - 110 call passf5 (idot,l1,ch,c,wa(iw),wa(ix2),wa(ix3),wa(ix4)) - 111 na = 1-na - go to 115 - 112 if (na .ne. 0) go to 113 - call passf (nac,idot,ip,l1,idl1,c,c,c,ch,ch,wa(iw)) - go to 114 - 113 call passf (nac,idot,ip,l1,idl1,ch,ch,ch,c,c,wa(iw)) - 114 if (nac .ne. 0) na = 1-na - 115 l1 = l2 - iw = iw+(ip-1)*idot - 116 continue - if (na .eq. 0) return - n2 = n+n - do 117 i=1,n2 - c(i) = ch(i) - 117 continue - return - end
--- a/liboctave/cruft/fftpack/cffti.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,8 +0,0 @@ - subroutine cffti (n,wsave) - dimension wsave(*) - if (n .eq. 1) return - iw1 = n+n+1 - iw2 = iw1+n+n - call cffti1 (n,wsave(iw1),wsave(iw2)) - return - end
--- a/liboctave/cruft/fftpack/cffti1.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,60 +0,0 @@ - subroutine cffti1 (n,wa,ifac) - dimension wa(*) ,ifac(*) ,ntryh(4) - data ntryh(1),ntryh(2),ntryh(3),ntryh(4)/3,4,2,5/ - nl = n - nf = 0 - j = 0 - 101 j = j+1 - if (j-4) 102,102,103 - 102 ntry = ntryh(j) - go to 104 - 103 ntry = ntry+2 - 104 nq = nl/ntry - nr = nl-ntry*nq - if (nr) 101,105,101 - 105 nf = nf+1 - ifac(nf+2) = ntry - nl = nq - if (ntry .ne. 2) go to 107 - if (nf .eq. 1) go to 107 - do 106 i=2,nf - ib = nf-i+2 - ifac(ib+2) = ifac(ib+1) - 106 continue - ifac(3) = 2 - 107 if (nl .ne. 1) go to 104 - ifac(1) = n - ifac(2) = nf - tpi = 6.28318530717959 - argh = tpi/dble(n) - i = 2 - l1 = 1 - do 110 k1=1,nf - ip = ifac(k1+2) - ld = 0 - l2 = l1*ip - ido = n/l2 - idot = ido+ido+2 - ipm = ip-1 - do 109 j=1,ipm - i1 = i - wa(i-1) = 1. - wa(i) = 0. - ld = ld+l1 - fi = 0. - argld = dble(ld)*argh - do 108 ii=4,idot,2 - i = i+2 - fi = fi+1. - arg = fi*argld - wa(i-1) = cos(arg) - wa(i) = sin(arg) - 108 continue - if (ip .le. 5) go to 109 - wa(i1-1) = wa(i-1) - wa(i1) = wa(i) - 109 continue - l1 = l2 - 110 continue - return - end
--- a/liboctave/cruft/fftpack/fftpack.doc Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,865 +0,0 @@ - - FFTPACK - -* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * - - version 4 april 1985 - - a package of fortran subprograms for the fast fourier - transform of periodic and other symmetric sequences - - by - - paul n swarztrauber - - national center for atmospheric research boulder,colorado 80307 - - which is sponsored by the national science foundation - -* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * - - -this package consists of programs which perform fast fourier -transforms for both complex and real periodic sequences and -certain other symmetric sequences that are listed below. - -1. rffti initialize rfftf and rfftb -2. rfftf forward transform of a real periodic sequence -3. rfftb backward transform of a real coefficient array - -4. ezffti initialize ezfftf and ezfftb -5. ezfftf a simplified real periodic forward transform -6. ezfftb a simplified real periodic backward transform - -7. sinti initialize sint -8. sint sine transform of a real odd sequence - -9. costi initialize cost -10. cost cosine transform of a real even sequence - -11. sinqi initialize sinqf and sinqb -12. sinqf forward sine transform with odd wave numbers -13. sinqb unnormalized inverse of sinqf - -14. cosqi initialize cosqf and cosqb -15. cosqf forward cosine transform with odd wave numbers -16. cosqb unnormalized inverse of cosqf - -17. cffti initialize cfftf and cfftb -18. cfftf forward transform of a complex periodic sequence -19. cfftb unnormalized inverse of cfftf - - -****************************************************************** - -subroutine rffti(n,wsave) - - **************************************************************** - -subroutine rffti initializes the array wsave which is used in -both rfftf and rfftb. the prime factorization of n together with -a tabulation of the trigonometric functions are computed and -stored in wsave. - -input parameter - -n the length of the sequence to be transformed. - -output parameter - -wsave a work array which must be dimensioned at least 2*n+15. - the same work array can be used for both rfftf and rfftb - as long as n remains unchanged. different wsave arrays - are required for different values of n. the contents of - wsave must not be changed between calls of rfftf or rfftb. - -****************************************************************** - -subroutine rfftf(n,r,wsave) - -****************************************************************** - -subroutine rfftf computes the fourier coefficients of a real -perodic sequence (fourier analysis). the transform is defined -below at output parameter r. - -input parameters - -n the length of the array r to be transformed. the method - is most efficient when n is a product of small primes. - n may change so long as different work arrays are provided - -r a real array of length n which contains the sequence - to be transformed - -wsave a work array which must be dimensioned at least 2*n+15. - in the program that calls rfftf. the wsave array must be - initialized by calling subroutine rffti(n,wsave) and a - different wsave array must be used for each different - value of n. this initialization does not have to be - repeated so long as n remains unchanged thus subsequent - transforms can be obtained faster than the first. - the same wsave array can be used by rfftf and rfftb. - - -output parameters - -r r(1) = the sum from i=1 to i=n of r(i) - - if n is even set l =n/2 , if n is odd set l = (n+1)/2 - - then for k = 2,...,l - - r(2*k-2) = the sum from i = 1 to i = n of - - r(i)*cos((k-1)*(i-1)*2*pi/n) - - r(2*k-1) = the sum from i = 1 to i = n of - - -r(i)*sin((k-1)*(i-1)*2*pi/n) - - if n is even - - r(n) = the sum from i = 1 to i = n of - - (-1)**(i-1)*r(i) - - ***** note - this transform is unnormalized since a call of rfftf - followed by a call of rfftb will multiply the input - sequence by n. - -wsave contains results which must not be destroyed between - calls of rfftf or rfftb. - - -****************************************************************** - -subroutine rfftb(n,r,wsave) - -****************************************************************** - -subroutine rfftb computes the real perodic sequence from its -fourier coefficients (fourier synthesis). the transform is defined -below at output parameter r. - -input parameters - -n the length of the array r to be transformed. the method - is most efficient when n is a product of small primes. - n may change so long as different work arrays are provided - -r a real array of length n which contains the sequence - to be transformed - -wsave a work array which must be dimensioned at least 2*n+15. - in the program that calls rfftb. the wsave array must be - initialized by calling subroutine rffti(n,wsave) and a - different wsave array must be used for each different - value of n. this initialization does not have to be - repeated so long as n remains unchanged thus subsequent - transforms can be obtained faster than the first. - the same wsave array can be used by rfftf and rfftb. - - -output parameters - -r for n even and for i = 1,...,n - - r(i) = r(1)+(-1)**(i-1)*r(n) - - plus the sum from k=2 to k=n/2 of - - 2.*r(2*k-2)*cos((k-1)*(i-1)*2*pi/n) - - -2.*r(2*k-1)*sin((k-1)*(i-1)*2*pi/n) - - for n odd and for i = 1,...,n - - r(i) = r(1) plus the sum from k=2 to k=(n+1)/2 of - - 2.*r(2*k-2)*cos((k-1)*(i-1)*2*pi/n) - - -2.*r(2*k-1)*sin((k-1)*(i-1)*2*pi/n) - - ***** note - this transform is unnormalized since a call of rfftf - followed by a call of rfftb will multiply the input - sequence by n. - -wsave contains results which must not be destroyed between - calls of rfftb or rfftf. - - -****************************************************************** - -subroutine ezffti(n,wsave) - -****************************************************************** - -subroutine ezffti initializes the array wsave which is used in -both ezfftf and ezfftb. the prime factorization of n together with -a tabulation of the trigonometric functions are computed and -stored in wsave. - -input parameter - -n the length of the sequence to be transformed. - -output parameter - -wsave a work array which must be dimensioned at least 3*n+15. - the same work array can be used for both ezfftf and ezfftb - as long as n remains unchanged. different wsave arrays - are required for different values of n. - - -****************************************************************** - -subroutine ezfftf(n,r,azero,a,b,wsave) - -****************************************************************** - -subroutine ezfftf computes the fourier coefficients of a real -perodic sequence (fourier analysis). the transform is defined -below at output parameters azero,a and b. ezfftf is a simplified -but slower version of rfftf. - -input parameters - -n the length of the array r to be transformed. the method - is must efficient when n is the product of small primes. - -r a real array of length n which contains the sequence - to be transformed. r is not destroyed. - - -wsave a work array which must be dimensioned at least 3*n+15. - in the program that calls ezfftf. the wsave array must be - initialized by calling subroutine ezffti(n,wsave) and a - different wsave array must be used for each different - value of n. this initialization does not have to be - repeated so long as n remains unchanged thus subsequent - transforms can be obtained faster than the first. - the same wsave array can be used by ezfftf and ezfftb. - -output parameters - -azero the sum from i=1 to i=n of r(i)/n - -a,b for n even b(n/2)=0. and a(n/2) is the sum from i=1 to - i=n of (-1)**(i-1)*r(i)/n - - for n even define kmax=n/2-1 - for n odd define kmax=(n-1)/2 - - then for k=1,...,kmax - - a(k) equals the sum from i=1 to i=n of - - 2./n*r(i)*cos(k*(i-1)*2*pi/n) - - b(k) equals the sum from i=1 to i=n of - - 2./n*r(i)*sin(k*(i-1)*2*pi/n) - - -****************************************************************** - -subroutine ezfftb(n,r,azero,a,b,wsave) - -****************************************************************** - -subroutine ezfftb computes a real perodic sequence from its -fourier coefficients (fourier synthesis). the transform is -defined below at output parameter r. ezfftb is a simplified -but slower version of rfftb. - -input parameters - -n the length of the output array r. the method is most - efficient when n is the product of small primes. - -azero the constant fourier coefficient - -a,b arrays which contain the remaining fourier coefficients - these arrays are not destroyed. - - the length of these arrays depends on whether n is even or - odd. - - if n is even n/2 locations are required - if n is odd (n-1)/2 locations are required - -wsave a work array which must be dimensioned at least 3*n+15. - in the program that calls ezfftb. the wsave array must be - initialized by calling subroutine ezffti(n,wsave) and a - different wsave array must be used for each different - value of n. this initialization does not have to be - repeated so long as n remains unchanged thus subsequent - transforms can be obtained faster than the first. - the same wsave array can be used by ezfftf and ezfftb. - - -output parameters - -r if n is even define kmax=n/2 - if n is odd define kmax=(n-1)/2 - - then for i=1,...,n - - r(i)=azero plus the sum from k=1 to k=kmax of - - a(k)*cos(k*(i-1)*2*pi/n)+b(k)*sin(k*(i-1)*2*pi/n) - -********************* complex notation ************************** - - for j=1,...,n - - r(j) equals the sum from k=-kmax to k=kmax of - - c(k)*exp(i*k*(j-1)*2*pi/n) - - where - - c(k) = .5*cmplx(a(k),-b(k)) for k=1,...,kmax - - c(-k) = conjg(c(k)) - - c(0) = azero - - and i=sqrt(-1) - -*************** amplitude - phase notation *********************** - - for i=1,...,n - - r(i) equals azero plus the sum from k=1 to k=kmax of - - alpha(k)*cos(k*(i-1)*2*pi/n+beta(k)) - - where - - alpha(k) = sqrt(a(k)*a(k)+b(k)*b(k)) - - cos(beta(k))=a(k)/alpha(k) - - sin(beta(k))=-b(k)/alpha(k) - -****************************************************************** - -subroutine sinti(n,wsave) - -****************************************************************** - -subroutine sinti initializes the array wsave which is used in -subroutine sint. the prime factorization of n together with -a tabulation of the trigonometric functions are computed and -stored in wsave. - -input parameter - -n the length of the sequence to be transformed. the method - is most efficient when n+1 is a product of small primes. - -output parameter - -wsave a work array with at least int(2.5*n+15) locations. - different wsave arrays are required for different values - of n. the contents of wsave must not be changed between - calls of sint. - -****************************************************************** - -subroutine sint(n,x,wsave) - -****************************************************************** - -subroutine sint computes the discrete fourier sine transform -of an odd sequence x(i). the transform is defined below at -output parameter x. - -sint is the unnormalized inverse of itself since a call of sint -followed by another call of sint will multiply the input sequence -x by 2*(n+1). - -the array wsave which is used by subroutine sint must be -initialized by calling subroutine sinti(n,wsave). - -input parameters - -n the length of the sequence to be transformed. the method - is most efficient when n+1 is the product of small primes. - -x an array which contains the sequence to be transformed - - -wsave a work array with dimension at least int(2.5*n+15) - in the program that calls sint. the wsave array must be - initialized by calling subroutine sinti(n,wsave) and a - different wsave array must be used for each different - value of n. this initialization does not have to be - repeated so long as n remains unchanged thus subsequent - transforms can be obtained faster than the first. - -output parameters - -x for i=1,...,n - - x(i)= the sum from k=1 to k=n - - 2*x(k)*sin(k*i*pi/(n+1)) - - a call of sint followed by another call of - sint will multiply the sequence x by 2*(n+1). - hence sint is the unnormalized inverse - of itself. - -wsave contains initialization calculations which must not be - destroyed between calls of sint. - -****************************************************************** - -subroutine costi(n,wsave) - -****************************************************************** - -subroutine costi initializes the array wsave which is used in -subroutine cost. the prime factorization of n together with -a tabulation of the trigonometric functions are computed and -stored in wsave. - -input parameter - -n the length of the sequence to be transformed. the method - is most efficient when n-1 is a product of small primes. - -output parameter - -wsave a work array which must be dimensioned at least 3*n+15. - different wsave arrays are required for different values - of n. the contents of wsave must not be changed between - calls of cost. - -****************************************************************** - -subroutine cost(n,x,wsave) - -****************************************************************** - -subroutine cost computes the discrete fourier cosine transform -of an even sequence x(i). the transform is defined below at output -parameter x. - -cost is the unnormalized inverse of itself since a call of cost -followed by another call of cost will multiply the input sequence -x by 2*(n-1). the transform is defined below at output parameter x - -the array wsave which is used by subroutine cost must be -initialized by calling subroutine costi(n,wsave). - -input parameters - -n the length of the sequence x. n must be greater than 1. - the method is most efficient when n-1 is a product of - small primes. - -x an array which contains the sequence to be transformed - -wsave a work array which must be dimensioned at least 3*n+15 - in the program that calls cost. the wsave array must be - initialized by calling subroutine costi(n,wsave) and a - different wsave array must be used for each different - value of n. this initialization does not have to be - repeated so long as n remains unchanged thus subsequent - transforms can be obtained faster than the first. - -output parameters - -x for i=1,...,n - - x(i) = x(1)+(-1)**(i-1)*x(n) - - + the sum from k=2 to k=n-1 - - 2*x(k)*cos((k-1)*(i-1)*pi/(n-1)) - - a call of cost followed by another call of - cost will multiply the sequence x by 2*(n-1) - hence cost is the unnormalized inverse - of itself. - -wsave contains initialization calculations which must not be - destroyed between calls of cost. - -****************************************************************** - -subroutine sinqi(n,wsave) - -****************************************************************** - -subroutine sinqi initializes the array wsave which is used in -both sinqf and sinqb. the prime factorization of n together with -a tabulation of the trigonometric functions are computed and -stored in wsave. - -input parameter - -n the length of the sequence to be transformed. the method - is most efficient when n is a product of small primes. - -output parameter - -wsave a work array which must be dimensioned at least 3*n+15. - the same work array can be used for both sinqf and sinqb - as long as n remains unchanged. different wsave arrays - are required for different values of n. the contents of - wsave must not be changed between calls of sinqf or sinqb. - -****************************************************************** - -subroutine sinqf(n,x,wsave) - -****************************************************************** - -subroutine sinqf computes the fast fourier transform of quarter -wave data. that is , sinqf computes the coefficients in a sine -series representation with only odd wave numbers. the transform -is defined below at output parameter x. - -sinqb is the unnormalized inverse of sinqf since a call of sinqf -followed by a call of sinqb will multiply the input sequence x -by 4*n. - -the array wsave which is used by subroutine sinqf must be -initialized by calling subroutine sinqi(n,wsave). - - -input parameters - -n the length of the array x to be transformed. the method - is most efficient when n is a product of small primes. - -x an array which contains the sequence to be transformed - -wsave a work array which must be dimensioned at least 3*n+15. - in the program that calls sinqf. the wsave array must be - initialized by calling subroutine sinqi(n,wsave) and a - different wsave array must be used for each different - value of n. this initialization does not have to be - repeated so long as n remains unchanged thus subsequent - transforms can be obtained faster than the first. - -output parameters - -x for i=1,...,n - - x(i) = (-1)**(i-1)*x(n) - - + the sum from k=1 to k=n-1 of - - 2*x(k)*sin((2*i-1)*k*pi/(2*n)) - - a call of sinqf followed by a call of - sinqb will multiply the sequence x by 4*n. - therefore sinqb is the unnormalized inverse - of sinqf. - -wsave contains initialization calculations which must not - be destroyed between calls of sinqf or sinqb. - -****************************************************************** - -subroutine sinqb(n,x,wsave) - -****************************************************************** - -subroutine sinqb computes the fast fourier transform of quarter -wave data. that is , sinqb computes a sequence from its -representation in terms of a sine series with odd wave numbers. -the transform is defined below at output parameter x. - -sinqf is the unnormalized inverse of sinqb since a call of sinqb -followed by a call of sinqf will multiply the input sequence x -by 4*n. - -the array wsave which is used by subroutine sinqb must be -initialized by calling subroutine sinqi(n,wsave). - - -input parameters - -n the length of the array x to be transformed. the method - is most efficient when n is a product of small primes. - -x an array which contains the sequence to be transformed - -wsave a work array which must be dimensioned at least 3*n+15. - in the program that calls sinqb. the wsave array must be - initialized by calling subroutine sinqi(n,wsave) and a - different wsave array must be used for each different - value of n. this initialization does not have to be - repeated so long as n remains unchanged thus subsequent - transforms can be obtained faster than the first. - -output parameters - -x for i=1,...,n - - x(i)= the sum from k=1 to k=n of - - 4*x(k)*sin((2k-1)*i*pi/(2*n)) - - a call of sinqb followed by a call of - sinqf will multiply the sequence x by 4*n. - therefore sinqf is the unnormalized inverse - of sinqb. - -wsave contains initialization calculations which must not - be destroyed between calls of sinqb or sinqf. - -****************************************************************** - -subroutine cosqi(n,wsave) - -****************************************************************** - -subroutine cosqi initializes the array wsave which is used in -both cosqf and cosqb. the prime factorization of n together with -a tabulation of the trigonometric functions are computed and -stored in wsave. - -input parameter - -n the length of the array to be transformed. the method - is most efficient when n is a product of small primes. - -output parameter - -wsave a work array which must be dimensioned at least 3*n+15. - the same work array can be used for both cosqf and cosqb - as long as n remains unchanged. different wsave arrays - are required for different values of n. the contents of - wsave must not be changed between calls of cosqf or cosqb. - -****************************************************************** - -subroutine cosqf(n,x,wsave) - -****************************************************************** - -subroutine cosqf computes the fast fourier transform of quarter -wave data. that is , cosqf computes the coefficients in a cosine -series representation with only odd wave numbers. the transform -is defined below at output parameter x - -cosqf is the unnormalized inverse of cosqb since a call of cosqf -followed by a call of cosqb will multiply the input sequence x -by 4*n. - -the array wsave which is used by subroutine cosqf must be -initialized by calling subroutine cosqi(n,wsave). - - -input parameters - -n the length of the array x to be transformed. the method - is most efficient when n is a product of small primes. - -x an array which contains the sequence to be transformed - -wsave a work array which must be dimensioned at least 3*n+15 - in the program that calls cosqf. the wsave array must be - initialized by calling subroutine cosqi(n,wsave) and a - different wsave array must be used for each different - value of n. this initialization does not have to be - repeated so long as n remains unchanged thus subsequent - transforms can be obtained faster than the first. - -output parameters - -x for i=1,...,n - - x(i) = x(1) plus the sum from k=2 to k=n of - - 2*x(k)*cos((2*i-1)*(k-1)*pi/(2*n)) - - a call of cosqf followed by a call of - cosqb will multiply the sequence x by 4*n. - therefore cosqb is the unnormalized inverse - of cosqf. - -wsave contains initialization calculations which must not - be destroyed between calls of cosqf or cosqb. - -****************************************************************** - -subroutine cosqb(n,x,wsave) - -****************************************************************** - -subroutine cosqb computes the fast fourier transform of quarter -wave data. that is , cosqb computes a sequence from its -representation in terms of a cosine series with odd wave numbers. -the transform is defined below at output parameter x. - -cosqb is the unnormalized inverse of cosqf since a call of cosqb -followed by a call of cosqf will multiply the input sequence x -by 4*n. - -the array wsave which is used by subroutine cosqb must be -initialized by calling subroutine cosqi(n,wsave). - - -input parameters - -n the length of the array x to be transformed. the method - is most efficient when n is a product of small primes. - -x an array which contains the sequence to be transformed - -wsave a work array that must be dimensioned at least 3*n+15 - in the program that calls cosqb. the wsave array must be - initialized by calling subroutine cosqi(n,wsave) and a - different wsave array must be used for each different - value of n. this initialization does not have to be - repeated so long as n remains unchanged thus subsequent - transforms can be obtained faster than the first. - -output parameters - -x for i=1,...,n - - x(i)= the sum from k=1 to k=n of - - 4*x(k)*cos((2*k-1)*(i-1)*pi/(2*n)) - - a call of cosqb followed by a call of - cosqf will multiply the sequence x by 4*n. - therefore cosqf is the unnormalized inverse - of cosqb. - -wsave contains initialization calculations which must not - be destroyed between calls of cosqb or cosqf. - -****************************************************************** - -subroutine cffti(n,wsave) - -****************************************************************** - -subroutine cffti initializes the array wsave which is used in -both cfftf and cfftb. the prime factorization of n together with -a tabulation of the trigonometric functions are computed and -stored in wsave. - -input parameter - -n the length of the sequence to be transformed - -output parameter - -wsave a work array which must be dimensioned at least 4*n+15 - the same work array can be used for both cfftf and cfftb - as long as n remains unchanged. different wsave arrays - are required for different values of n. the contents of - wsave must not be changed between calls of cfftf or cfftb. - -****************************************************************** - -subroutine cfftf(n,c,wsave) - -****************************************************************** - -subroutine cfftf computes the forward complex discrete fourier -transform (the fourier analysis). equivalently , cfftf computes -the fourier coefficients of a complex periodic sequence. -the transform is defined below at output parameter c. - -the transform is not normalized. to obtain a normalized transform -the output must be divided by n. otherwise a call of cfftf -followed by a call of cfftb will multiply the sequence by n. - -the array wsave which is used by subroutine cfftf must be -initialized by calling subroutine cffti(n,wsave). - -input parameters - - -n the length of the complex sequence c. the method is - more efficient when n is the product of small primes. n - -c a complex array of length n which contains the sequence - -wsave a real work array which must be dimensioned at least 4n+15 - in the program that calls cfftf. the wsave array must be - initialized by calling subroutine cffti(n,wsave) and a - different wsave array must be used for each different - value of n. this initialization does not have to be - repeated so long as n remains unchanged thus subsequent - transforms can be obtained faster than the first. - the same wsave array can be used by cfftf and cfftb. - -output parameters - -c for j=1,...,n - - c(j)=the sum from k=1,...,n of - - c(k)*exp(-i*(j-1)*(k-1)*2*pi/n) - - where i=sqrt(-1) - -wsave contains initialization calculations which must not be - destroyed between calls of subroutine cfftf or cfftb - -****************************************************************** - -subroutine cfftb(n,c,wsave) - -****************************************************************** - -subroutine cfftb computes the backward complex discrete fourier -transform (the fourier synthesis). equivalently , cfftb computes -a complex periodic sequence from its fourier coefficients. -the transform is defined below at output parameter c. - -a call of cfftf followed by a call of cfftb will multiply the -sequence by n. - -the array wsave which is used by subroutine cfftb must be -initialized by calling subroutine cffti(n,wsave). - -input parameters - - -n the length of the complex sequence c. the method is - more efficient when n is the product of small primes. - -c a complex array of length n which contains the sequence - -wsave a real work array which must be dimensioned at least 4n+15 - in the program that calls cfftb. the wsave array must be - initialized by calling subroutine cffti(n,wsave) and a - different wsave array must be used for each different - value of n. this initialization does not have to be - repeated so long as n remains unchanged thus subsequent - transforms can be obtained faster than the first. - the same wsave array can be used by cfftf and cfftb. - -output parameters - -c for j=1,...,n - - c(j)=the sum from k=1,...,n of - - c(k)*exp(i*(j-1)*(k-1)*2*pi/n) - - where i=sqrt(-1) - -wsave contains initialization calculations which must not be - destroyed between calls of subroutine cfftf or cfftb - - - -["send index for vfftpk" describes a vectorized version of fftpack]
--- a/liboctave/cruft/fftpack/module.mk Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,42 +0,0 @@ -FFTPACK_SRC = \ - liboctave/cruft/fftpack/cfftb.f \ - liboctave/cruft/fftpack/cfftb1.f \ - liboctave/cruft/fftpack/cfftf.f \ - liboctave/cruft/fftpack/cfftf1.f \ - liboctave/cruft/fftpack/cffti.f \ - liboctave/cruft/fftpack/cffti1.f \ - liboctave/cruft/fftpack/passb.f \ - liboctave/cruft/fftpack/passb2.f \ - liboctave/cruft/fftpack/passb3.f \ - liboctave/cruft/fftpack/passb4.f \ - liboctave/cruft/fftpack/passb5.f \ - liboctave/cruft/fftpack/passf.f \ - liboctave/cruft/fftpack/passf2.f \ - liboctave/cruft/fftpack/passf3.f \ - liboctave/cruft/fftpack/passf4.f \ - liboctave/cruft/fftpack/passf5.f \ - liboctave/cruft/fftpack/zfftb.f \ - liboctave/cruft/fftpack/zfftb1.f \ - liboctave/cruft/fftpack/zfftf.f \ - liboctave/cruft/fftpack/zfftf1.f \ - liboctave/cruft/fftpack/zffti.f \ - liboctave/cruft/fftpack/zffti1.f \ - liboctave/cruft/fftpack/zpassb.f \ - liboctave/cruft/fftpack/zpassb2.f \ - liboctave/cruft/fftpack/zpassb3.f \ - liboctave/cruft/fftpack/zpassb4.f \ - liboctave/cruft/fftpack/zpassb5.f \ - liboctave/cruft/fftpack/zpassf.f \ - liboctave/cruft/fftpack/zpassf2.f \ - liboctave/cruft/fftpack/zpassf3.f \ - liboctave/cruft/fftpack/zpassf4.f \ - liboctave/cruft/fftpack/zpassf5.f - -if AMCOND_HAVE_FFTW - liboctave_EXTRA_DIST += $(FFTPACK_SRC) -else - CRUFT_SOURCES += $(FFTPACK_SRC) -endif - -liboctave_EXTRA_DIST += \ - liboctave/cruft/fftpack/fftpack.doc
--- a/liboctave/cruft/fftpack/passb.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,116 +0,0 @@ - subroutine passb (nac,ido,ip,l1,idl1,cc,c1,c2,ch,ch2,wa) - dimension ch(ido,l1,ip) ,cc(ido,ip,l1) , - 1 c1(ido,l1,ip) ,wa(1) ,c2(idl1,ip), - 2 ch2(idl1,ip) - idot = ido/2 - nt = ip*idl1 - ipp2 = ip+2 - ipph = (ip+1)/2 - idp = ip*ido -c - if (ido .lt. l1) go to 106 - do 103 j=2,ipph - jc = ipp2-j - do 102 k=1,l1 - do 101 i=1,ido - ch(i,k,j) = cc(i,j,k)+cc(i,jc,k) - ch(i,k,jc) = cc(i,j,k)-cc(i,jc,k) - 101 continue - 102 continue - 103 continue - do 105 k=1,l1 - do 104 i=1,ido - ch(i,k,1) = cc(i,1,k) - 104 continue - 105 continue - go to 112 - 106 do 109 j=2,ipph - jc = ipp2-j - do 108 i=1,ido - do 107 k=1,l1 - ch(i,k,j) = cc(i,j,k)+cc(i,jc,k) - ch(i,k,jc) = cc(i,j,k)-cc(i,jc,k) - 107 continue - 108 continue - 109 continue - do 111 i=1,ido - do 110 k=1,l1 - ch(i,k,1) = cc(i,1,k) - 110 continue - 111 continue - 112 idl = 2-ido - inc = 0 - do 116 l=2,ipph - lc = ipp2-l - idl = idl+ido - do 113 ik=1,idl1 - c2(ik,l) = ch2(ik,1)+wa(idl-1)*ch2(ik,2) - c2(ik,lc) = wa(idl)*ch2(ik,ip) - 113 continue - idlj = idl - inc = inc+ido - do 115 j=3,ipph - jc = ipp2-j - idlj = idlj+inc - if (idlj .gt. idp) idlj = idlj-idp - war = wa(idlj-1) - wai = wa(idlj) - do 114 ik=1,idl1 - c2(ik,l) = c2(ik,l)+war*ch2(ik,j) - c2(ik,lc) = c2(ik,lc)+wai*ch2(ik,jc) - 114 continue - 115 continue - 116 continue - do 118 j=2,ipph - do 117 ik=1,idl1 - ch2(ik,1) = ch2(ik,1)+ch2(ik,j) - 117 continue - 118 continue - do 120 j=2,ipph - jc = ipp2-j - do 119 ik=2,idl1,2 - ch2(ik-1,j) = c2(ik-1,j)-c2(ik,jc) - ch2(ik-1,jc) = c2(ik-1,j)+c2(ik,jc) - ch2(ik,j) = c2(ik,j)+c2(ik-1,jc) - ch2(ik,jc) = c2(ik,j)-c2(ik-1,jc) - 119 continue - 120 continue - nac = 1 - if (ido .eq. 2) return - nac = 0 - do 121 ik=1,idl1 - c2(ik,1) = ch2(ik,1) - 121 continue - do 123 j=2,ip - do 122 k=1,l1 - c1(1,k,j) = ch(1,k,j) - c1(2,k,j) = ch(2,k,j) - 122 continue - 123 continue - if (idot .gt. l1) go to 127 - idij = 0 - do 126 j=2,ip - idij = idij+2 - do 125 i=4,ido,2 - idij = idij+2 - do 124 k=1,l1 - c1(i-1,k,j) = wa(idij-1)*ch(i-1,k,j)-wa(idij)*ch(i,k,j) - c1(i,k,j) = wa(idij-1)*ch(i,k,j)+wa(idij)*ch(i-1,k,j) - 124 continue - 125 continue - 126 continue - return - 127 idj = 2-ido - do 130 j=2,ip - idj = idj+ido - do 129 k=1,l1 - idij = idj - do 128 i=4,ido,2 - idij = idij+2 - c1(i-1,k,j) = wa(idij-1)*ch(i-1,k,j)-wa(idij)*ch(i,k,j) - c1(i,k,j) = wa(idij-1)*ch(i,k,j)+wa(idij)*ch(i-1,k,j) - 128 continue - 129 continue - 130 continue - return - end
--- a/liboctave/cruft/fftpack/passb2.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,23 +0,0 @@ - subroutine passb2 (ido,l1,cc,ch,wa1) - dimension cc(ido,2,l1) ,ch(ido,l1,2) , - 1 wa1(1) - if (ido .gt. 2) go to 102 - do 101 k=1,l1 - ch(1,k,1) = cc(1,1,k)+cc(1,2,k) - ch(1,k,2) = cc(1,1,k)-cc(1,2,k) - ch(2,k,1) = cc(2,1,k)+cc(2,2,k) - ch(2,k,2) = cc(2,1,k)-cc(2,2,k) - 101 continue - return - 102 do 104 k=1,l1 - do 103 i=2,ido,2 - ch(i-1,k,1) = cc(i-1,1,k)+cc(i-1,2,k) - tr2 = cc(i-1,1,k)-cc(i-1,2,k) - ch(i,k,1) = cc(i,1,k)+cc(i,2,k) - ti2 = cc(i,1,k)-cc(i,2,k) - ch(i,k,2) = wa1(i-1)*ti2+wa1(i)*tr2 - ch(i-1,k,2) = wa1(i-1)*tr2-wa1(i)*ti2 - 103 continue - 104 continue - return - end
--- a/liboctave/cruft/fftpack/passb3.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,42 +0,0 @@ - subroutine passb3 (ido,l1,cc,ch,wa1,wa2) - dimension cc(ido,3,l1) ,ch(ido,l1,3) , - 1 wa1(1) ,wa2(1) - data taur,taui /-.5,.866025403784439/ - if (ido .ne. 2) go to 102 - do 101 k=1,l1 - tr2 = cc(1,2,k)+cc(1,3,k) - cr2 = cc(1,1,k)+taur*tr2 - ch(1,k,1) = cc(1,1,k)+tr2 - ti2 = cc(2,2,k)+cc(2,3,k) - ci2 = cc(2,1,k)+taur*ti2 - ch(2,k,1) = cc(2,1,k)+ti2 - cr3 = taui*(cc(1,2,k)-cc(1,3,k)) - ci3 = taui*(cc(2,2,k)-cc(2,3,k)) - ch(1,k,2) = cr2-ci3 - ch(1,k,3) = cr2+ci3 - ch(2,k,2) = ci2+cr3 - ch(2,k,3) = ci2-cr3 - 101 continue - return - 102 do 104 k=1,l1 - do 103 i=2,ido,2 - tr2 = cc(i-1,2,k)+cc(i-1,3,k) - cr2 = cc(i-1,1,k)+taur*tr2 - ch(i-1,k,1) = cc(i-1,1,k)+tr2 - ti2 = cc(i,2,k)+cc(i,3,k) - ci2 = cc(i,1,k)+taur*ti2 - ch(i,k,1) = cc(i,1,k)+ti2 - cr3 = taui*(cc(i-1,2,k)-cc(i-1,3,k)) - ci3 = taui*(cc(i,2,k)-cc(i,3,k)) - dr2 = cr2-ci3 - dr3 = cr2+ci3 - di2 = ci2+cr3 - di3 = ci2-cr3 - ch(i,k,2) = wa1(i-1)*di2+wa1(i)*dr2 - ch(i-1,k,2) = wa1(i-1)*dr2-wa1(i)*di2 - ch(i,k,3) = wa2(i-1)*di3+wa2(i)*dr3 - ch(i-1,k,3) = wa2(i-1)*dr3-wa2(i)*di3 - 103 continue - 104 continue - return - end
--- a/liboctave/cruft/fftpack/passb4.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,51 +0,0 @@ - subroutine passb4 (ido,l1,cc,ch,wa1,wa2,wa3) - dimension cc(ido,4,l1) ,ch(ido,l1,4) , - 1 wa1(1) ,wa2(1) ,wa3(1) - if (ido .ne. 2) go to 102 - do 101 k=1,l1 - ti1 = cc(2,1,k)-cc(2,3,k) - ti2 = cc(2,1,k)+cc(2,3,k) - tr4 = cc(2,4,k)-cc(2,2,k) - ti3 = cc(2,2,k)+cc(2,4,k) - tr1 = cc(1,1,k)-cc(1,3,k) - tr2 = cc(1,1,k)+cc(1,3,k) - ti4 = cc(1,2,k)-cc(1,4,k) - tr3 = cc(1,2,k)+cc(1,4,k) - ch(1,k,1) = tr2+tr3 - ch(1,k,3) = tr2-tr3 - ch(2,k,1) = ti2+ti3 - ch(2,k,3) = ti2-ti3 - ch(1,k,2) = tr1+tr4 - ch(1,k,4) = tr1-tr4 - ch(2,k,2) = ti1+ti4 - ch(2,k,4) = ti1-ti4 - 101 continue - return - 102 do 104 k=1,l1 - do 103 i=2,ido,2 - ti1 = cc(i,1,k)-cc(i,3,k) - ti2 = cc(i,1,k)+cc(i,3,k) - ti3 = cc(i,2,k)+cc(i,4,k) - tr4 = cc(i,4,k)-cc(i,2,k) - tr1 = cc(i-1,1,k)-cc(i-1,3,k) - tr2 = cc(i-1,1,k)+cc(i-1,3,k) - ti4 = cc(i-1,2,k)-cc(i-1,4,k) - tr3 = cc(i-1,2,k)+cc(i-1,4,k) - ch(i-1,k,1) = tr2+tr3 - cr3 = tr2-tr3 - ch(i,k,1) = ti2+ti3 - ci3 = ti2-ti3 - cr2 = tr1+tr4 - cr4 = tr1-tr4 - ci2 = ti1+ti4 - ci4 = ti1-ti4 - ch(i-1,k,2) = wa1(i-1)*cr2-wa1(i)*ci2 - ch(i,k,2) = wa1(i-1)*ci2+wa1(i)*cr2 - ch(i-1,k,3) = wa2(i-1)*cr3-wa2(i)*ci3 - ch(i,k,3) = wa2(i-1)*ci3+wa2(i)*cr3 - ch(i-1,k,4) = wa3(i-1)*cr4-wa3(i)*ci4 - ch(i,k,4) = wa3(i-1)*ci4+wa3(i)*cr4 - 103 continue - 104 continue - return - end
--- a/liboctave/cruft/fftpack/passb5.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,75 +0,0 @@ - subroutine passb5 (ido,l1,cc,ch,wa1,wa2,wa3,wa4) - dimension cc(ido,5,l1) ,ch(ido,l1,5) , - 1 wa1(1) ,wa2(1) ,wa3(1) ,wa4(1) - data tr11,ti11,tr12,ti12 /.309016994374947,.951056516295154, - 1-.809016994374947,.587785252292473/ - if (ido .ne. 2) go to 102 - do 101 k=1,l1 - ti5 = cc(2,2,k)-cc(2,5,k) - ti2 = cc(2,2,k)+cc(2,5,k) - ti4 = cc(2,3,k)-cc(2,4,k) - ti3 = cc(2,3,k)+cc(2,4,k) - tr5 = cc(1,2,k)-cc(1,5,k) - tr2 = cc(1,2,k)+cc(1,5,k) - tr4 = cc(1,3,k)-cc(1,4,k) - tr3 = cc(1,3,k)+cc(1,4,k) - ch(1,k,1) = cc(1,1,k)+tr2+tr3 - ch(2,k,1) = cc(2,1,k)+ti2+ti3 - cr2 = cc(1,1,k)+tr11*tr2+tr12*tr3 - ci2 = cc(2,1,k)+tr11*ti2+tr12*ti3 - cr3 = cc(1,1,k)+tr12*tr2+tr11*tr3 - ci3 = cc(2,1,k)+tr12*ti2+tr11*ti3 - cr5 = ti11*tr5+ti12*tr4 - ci5 = ti11*ti5+ti12*ti4 - cr4 = ti12*tr5-ti11*tr4 - ci4 = ti12*ti5-ti11*ti4 - ch(1,k,2) = cr2-ci5 - ch(1,k,5) = cr2+ci5 - ch(2,k,2) = ci2+cr5 - ch(2,k,3) = ci3+cr4 - ch(1,k,3) = cr3-ci4 - ch(1,k,4) = cr3+ci4 - ch(2,k,4) = ci3-cr4 - ch(2,k,5) = ci2-cr5 - 101 continue - return - 102 do 104 k=1,l1 - do 103 i=2,ido,2 - ti5 = cc(i,2,k)-cc(i,5,k) - ti2 = cc(i,2,k)+cc(i,5,k) - ti4 = cc(i,3,k)-cc(i,4,k) - ti3 = cc(i,3,k)+cc(i,4,k) - tr5 = cc(i-1,2,k)-cc(i-1,5,k) - tr2 = cc(i-1,2,k)+cc(i-1,5,k) - tr4 = cc(i-1,3,k)-cc(i-1,4,k) - tr3 = cc(i-1,3,k)+cc(i-1,4,k) - ch(i-1,k,1) = cc(i-1,1,k)+tr2+tr3 - ch(i,k,1) = cc(i,1,k)+ti2+ti3 - cr2 = cc(i-1,1,k)+tr11*tr2+tr12*tr3 - ci2 = cc(i,1,k)+tr11*ti2+tr12*ti3 - cr3 = cc(i-1,1,k)+tr12*tr2+tr11*tr3 - ci3 = cc(i,1,k)+tr12*ti2+tr11*ti3 - cr5 = ti11*tr5+ti12*tr4 - ci5 = ti11*ti5+ti12*ti4 - cr4 = ti12*tr5-ti11*tr4 - ci4 = ti12*ti5-ti11*ti4 - dr3 = cr3-ci4 - dr4 = cr3+ci4 - di3 = ci3+cr4 - di4 = ci3-cr4 - dr5 = cr2+ci5 - dr2 = cr2-ci5 - di5 = ci2-cr5 - di2 = ci2+cr5 - ch(i-1,k,2) = wa1(i-1)*dr2-wa1(i)*di2 - ch(i,k,2) = wa1(i-1)*di2+wa1(i)*dr2 - ch(i-1,k,3) = wa2(i-1)*dr3-wa2(i)*di3 - ch(i,k,3) = wa2(i-1)*di3+wa2(i)*dr3 - ch(i-1,k,4) = wa3(i-1)*dr4-wa3(i)*di4 - ch(i,k,4) = wa3(i-1)*di4+wa3(i)*dr4 - ch(i-1,k,5) = wa4(i-1)*dr5-wa4(i)*di5 - ch(i,k,5) = wa4(i-1)*di5+wa4(i)*dr5 - 103 continue - 104 continue - return - end
--- a/liboctave/cruft/fftpack/passf.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,116 +0,0 @@ - subroutine passf (nac,ido,ip,l1,idl1,cc,c1,c2,ch,ch2,wa) - dimension ch(ido,l1,ip) ,cc(ido,ip,l1) , - 1 c1(ido,l1,ip) ,wa(1) ,c2(idl1,ip), - 2 ch2(idl1,ip) - idot = ido/2 - nt = ip*idl1 - ipp2 = ip+2 - ipph = (ip+1)/2 - idp = ip*ido -c - if (ido .lt. l1) go to 106 - do 103 j=2,ipph - jc = ipp2-j - do 102 k=1,l1 - do 101 i=1,ido - ch(i,k,j) = cc(i,j,k)+cc(i,jc,k) - ch(i,k,jc) = cc(i,j,k)-cc(i,jc,k) - 101 continue - 102 continue - 103 continue - do 105 k=1,l1 - do 104 i=1,ido - ch(i,k,1) = cc(i,1,k) - 104 continue - 105 continue - go to 112 - 106 do 109 j=2,ipph - jc = ipp2-j - do 108 i=1,ido - do 107 k=1,l1 - ch(i,k,j) = cc(i,j,k)+cc(i,jc,k) - ch(i,k,jc) = cc(i,j,k)-cc(i,jc,k) - 107 continue - 108 continue - 109 continue - do 111 i=1,ido - do 110 k=1,l1 - ch(i,k,1) = cc(i,1,k) - 110 continue - 111 continue - 112 idl = 2-ido - inc = 0 - do 116 l=2,ipph - lc = ipp2-l - idl = idl+ido - do 113 ik=1,idl1 - c2(ik,l) = ch2(ik,1)+wa(idl-1)*ch2(ik,2) - c2(ik,lc) = -wa(idl)*ch2(ik,ip) - 113 continue - idlj = idl - inc = inc+ido - do 115 j=3,ipph - jc = ipp2-j - idlj = idlj+inc - if (idlj .gt. idp) idlj = idlj-idp - war = wa(idlj-1) - wai = wa(idlj) - do 114 ik=1,idl1 - c2(ik,l) = c2(ik,l)+war*ch2(ik,j) - c2(ik,lc) = c2(ik,lc)-wai*ch2(ik,jc) - 114 continue - 115 continue - 116 continue - do 118 j=2,ipph - do 117 ik=1,idl1 - ch2(ik,1) = ch2(ik,1)+ch2(ik,j) - 117 continue - 118 continue - do 120 j=2,ipph - jc = ipp2-j - do 119 ik=2,idl1,2 - ch2(ik-1,j) = c2(ik-1,j)-c2(ik,jc) - ch2(ik-1,jc) = c2(ik-1,j)+c2(ik,jc) - ch2(ik,j) = c2(ik,j)+c2(ik-1,jc) - ch2(ik,jc) = c2(ik,j)-c2(ik-1,jc) - 119 continue - 120 continue - nac = 1 - if (ido .eq. 2) return - nac = 0 - do 121 ik=1,idl1 - c2(ik,1) = ch2(ik,1) - 121 continue - do 123 j=2,ip - do 122 k=1,l1 - c1(1,k,j) = ch(1,k,j) - c1(2,k,j) = ch(2,k,j) - 122 continue - 123 continue - if (idot .gt. l1) go to 127 - idij = 0 - do 126 j=2,ip - idij = idij+2 - do 125 i=4,ido,2 - idij = idij+2 - do 124 k=1,l1 - c1(i-1,k,j) = wa(idij-1)*ch(i-1,k,j)+wa(idij)*ch(i,k,j) - c1(i,k,j) = wa(idij-1)*ch(i,k,j)-wa(idij)*ch(i-1,k,j) - 124 continue - 125 continue - 126 continue - return - 127 idj = 2-ido - do 130 j=2,ip - idj = idj+ido - do 129 k=1,l1 - idij = idj - do 128 i=4,ido,2 - idij = idij+2 - c1(i-1,k,j) = wa(idij-1)*ch(i-1,k,j)+wa(idij)*ch(i,k,j) - c1(i,k,j) = wa(idij-1)*ch(i,k,j)-wa(idij)*ch(i-1,k,j) - 128 continue - 129 continue - 130 continue - return - end
--- a/liboctave/cruft/fftpack/passf2.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,23 +0,0 @@ - subroutine passf2 (ido,l1,cc,ch,wa1) - dimension cc(ido,2,l1) ,ch(ido,l1,2) , - 1 wa1(1) - if (ido .gt. 2) go to 102 - do 101 k=1,l1 - ch(1,k,1) = cc(1,1,k)+cc(1,2,k) - ch(1,k,2) = cc(1,1,k)-cc(1,2,k) - ch(2,k,1) = cc(2,1,k)+cc(2,2,k) - ch(2,k,2) = cc(2,1,k)-cc(2,2,k) - 101 continue - return - 102 do 104 k=1,l1 - do 103 i=2,ido,2 - ch(i-1,k,1) = cc(i-1,1,k)+cc(i-1,2,k) - tr2 = cc(i-1,1,k)-cc(i-1,2,k) - ch(i,k,1) = cc(i,1,k)+cc(i,2,k) - ti2 = cc(i,1,k)-cc(i,2,k) - ch(i,k,2) = wa1(i-1)*ti2-wa1(i)*tr2 - ch(i-1,k,2) = wa1(i-1)*tr2+wa1(i)*ti2 - 103 continue - 104 continue - return - end
--- a/liboctave/cruft/fftpack/passf3.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,42 +0,0 @@ - subroutine passf3 (ido,l1,cc,ch,wa1,wa2) - dimension cc(ido,3,l1) ,ch(ido,l1,3) , - 1 wa1(1) ,wa2(1) - data taur,taui /-.5,-.866025403784439/ - if (ido .ne. 2) go to 102 - do 101 k=1,l1 - tr2 = cc(1,2,k)+cc(1,3,k) - cr2 = cc(1,1,k)+taur*tr2 - ch(1,k,1) = cc(1,1,k)+tr2 - ti2 = cc(2,2,k)+cc(2,3,k) - ci2 = cc(2,1,k)+taur*ti2 - ch(2,k,1) = cc(2,1,k)+ti2 - cr3 = taui*(cc(1,2,k)-cc(1,3,k)) - ci3 = taui*(cc(2,2,k)-cc(2,3,k)) - ch(1,k,2) = cr2-ci3 - ch(1,k,3) = cr2+ci3 - ch(2,k,2) = ci2+cr3 - ch(2,k,3) = ci2-cr3 - 101 continue - return - 102 do 104 k=1,l1 - do 103 i=2,ido,2 - tr2 = cc(i-1,2,k)+cc(i-1,3,k) - cr2 = cc(i-1,1,k)+taur*tr2 - ch(i-1,k,1) = cc(i-1,1,k)+tr2 - ti2 = cc(i,2,k)+cc(i,3,k) - ci2 = cc(i,1,k)+taur*ti2 - ch(i,k,1) = cc(i,1,k)+ti2 - cr3 = taui*(cc(i-1,2,k)-cc(i-1,3,k)) - ci3 = taui*(cc(i,2,k)-cc(i,3,k)) - dr2 = cr2-ci3 - dr3 = cr2+ci3 - di2 = ci2+cr3 - di3 = ci2-cr3 - ch(i,k,2) = wa1(i-1)*di2-wa1(i)*dr2 - ch(i-1,k,2) = wa1(i-1)*dr2+wa1(i)*di2 - ch(i,k,3) = wa2(i-1)*di3-wa2(i)*dr3 - ch(i-1,k,3) = wa2(i-1)*dr3+wa2(i)*di3 - 103 continue - 104 continue - return - end
--- a/liboctave/cruft/fftpack/passf4.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,51 +0,0 @@ - subroutine passf4 (ido,l1,cc,ch,wa1,wa2,wa3) - dimension cc(ido,4,l1) ,ch(ido,l1,4) , - 1 wa1(1) ,wa2(1) ,wa3(1) - if (ido .ne. 2) go to 102 - do 101 k=1,l1 - ti1 = cc(2,1,k)-cc(2,3,k) - ti2 = cc(2,1,k)+cc(2,3,k) - tr4 = cc(2,2,k)-cc(2,4,k) - ti3 = cc(2,2,k)+cc(2,4,k) - tr1 = cc(1,1,k)-cc(1,3,k) - tr2 = cc(1,1,k)+cc(1,3,k) - ti4 = cc(1,4,k)-cc(1,2,k) - tr3 = cc(1,2,k)+cc(1,4,k) - ch(1,k,1) = tr2+tr3 - ch(1,k,3) = tr2-tr3 - ch(2,k,1) = ti2+ti3 - ch(2,k,3) = ti2-ti3 - ch(1,k,2) = tr1+tr4 - ch(1,k,4) = tr1-tr4 - ch(2,k,2) = ti1+ti4 - ch(2,k,4) = ti1-ti4 - 101 continue - return - 102 do 104 k=1,l1 - do 103 i=2,ido,2 - ti1 = cc(i,1,k)-cc(i,3,k) - ti2 = cc(i,1,k)+cc(i,3,k) - ti3 = cc(i,2,k)+cc(i,4,k) - tr4 = cc(i,2,k)-cc(i,4,k) - tr1 = cc(i-1,1,k)-cc(i-1,3,k) - tr2 = cc(i-1,1,k)+cc(i-1,3,k) - ti4 = cc(i-1,4,k)-cc(i-1,2,k) - tr3 = cc(i-1,2,k)+cc(i-1,4,k) - ch(i-1,k,1) = tr2+tr3 - cr3 = tr2-tr3 - ch(i,k,1) = ti2+ti3 - ci3 = ti2-ti3 - cr2 = tr1+tr4 - cr4 = tr1-tr4 - ci2 = ti1+ti4 - ci4 = ti1-ti4 - ch(i-1,k,2) = wa1(i-1)*cr2+wa1(i)*ci2 - ch(i,k,2) = wa1(i-1)*ci2-wa1(i)*cr2 - ch(i-1,k,3) = wa2(i-1)*cr3+wa2(i)*ci3 - ch(i,k,3) = wa2(i-1)*ci3-wa2(i)*cr3 - ch(i-1,k,4) = wa3(i-1)*cr4+wa3(i)*ci4 - ch(i,k,4) = wa3(i-1)*ci4-wa3(i)*cr4 - 103 continue - 104 continue - return - end
--- a/liboctave/cruft/fftpack/passf5.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,75 +0,0 @@ - subroutine passf5 (ido,l1,cc,ch,wa1,wa2,wa3,wa4) - dimension cc(ido,5,l1) ,ch(ido,l1,5) , - 1 wa1(1) ,wa2(1) ,wa3(1) ,wa4(1) - data tr11,ti11,tr12,ti12 /.309016994374947,-.951056516295154, - 1-.809016994374947,-.587785252292473/ - if (ido .ne. 2) go to 102 - do 101 k=1,l1 - ti5 = cc(2,2,k)-cc(2,5,k) - ti2 = cc(2,2,k)+cc(2,5,k) - ti4 = cc(2,3,k)-cc(2,4,k) - ti3 = cc(2,3,k)+cc(2,4,k) - tr5 = cc(1,2,k)-cc(1,5,k) - tr2 = cc(1,2,k)+cc(1,5,k) - tr4 = cc(1,3,k)-cc(1,4,k) - tr3 = cc(1,3,k)+cc(1,4,k) - ch(1,k,1) = cc(1,1,k)+tr2+tr3 - ch(2,k,1) = cc(2,1,k)+ti2+ti3 - cr2 = cc(1,1,k)+tr11*tr2+tr12*tr3 - ci2 = cc(2,1,k)+tr11*ti2+tr12*ti3 - cr3 = cc(1,1,k)+tr12*tr2+tr11*tr3 - ci3 = cc(2,1,k)+tr12*ti2+tr11*ti3 - cr5 = ti11*tr5+ti12*tr4 - ci5 = ti11*ti5+ti12*ti4 - cr4 = ti12*tr5-ti11*tr4 - ci4 = ti12*ti5-ti11*ti4 - ch(1,k,2) = cr2-ci5 - ch(1,k,5) = cr2+ci5 - ch(2,k,2) = ci2+cr5 - ch(2,k,3) = ci3+cr4 - ch(1,k,3) = cr3-ci4 - ch(1,k,4) = cr3+ci4 - ch(2,k,4) = ci3-cr4 - ch(2,k,5) = ci2-cr5 - 101 continue - return - 102 do 104 k=1,l1 - do 103 i=2,ido,2 - ti5 = cc(i,2,k)-cc(i,5,k) - ti2 = cc(i,2,k)+cc(i,5,k) - ti4 = cc(i,3,k)-cc(i,4,k) - ti3 = cc(i,3,k)+cc(i,4,k) - tr5 = cc(i-1,2,k)-cc(i-1,5,k) - tr2 = cc(i-1,2,k)+cc(i-1,5,k) - tr4 = cc(i-1,3,k)-cc(i-1,4,k) - tr3 = cc(i-1,3,k)+cc(i-1,4,k) - ch(i-1,k,1) = cc(i-1,1,k)+tr2+tr3 - ch(i,k,1) = cc(i,1,k)+ti2+ti3 - cr2 = cc(i-1,1,k)+tr11*tr2+tr12*tr3 - ci2 = cc(i,1,k)+tr11*ti2+tr12*ti3 - cr3 = cc(i-1,1,k)+tr12*tr2+tr11*tr3 - ci3 = cc(i,1,k)+tr12*ti2+tr11*ti3 - cr5 = ti11*tr5+ti12*tr4 - ci5 = ti11*ti5+ti12*ti4 - cr4 = ti12*tr5-ti11*tr4 - ci4 = ti12*ti5-ti11*ti4 - dr3 = cr3-ci4 - dr4 = cr3+ci4 - di3 = ci3+cr4 - di4 = ci3-cr4 - dr5 = cr2+ci5 - dr2 = cr2-ci5 - di5 = ci2-cr5 - di2 = ci2+cr5 - ch(i-1,k,2) = wa1(i-1)*dr2+wa1(i)*di2 - ch(i,k,2) = wa1(i-1)*di2-wa1(i)*dr2 - ch(i-1,k,3) = wa2(i-1)*dr3+wa2(i)*di3 - ch(i,k,3) = wa2(i-1)*di3-wa2(i)*dr3 - ch(i-1,k,4) = wa3(i-1)*dr4+wa3(i)*di4 - ch(i,k,4) = wa3(i-1)*di4-wa3(i)*dr4 - ch(i-1,k,5) = wa4(i-1)*dr5+wa4(i)*di5 - ch(i,k,5) = wa4(i-1)*di5-wa4(i)*dr5 - 103 continue - 104 continue - return - end
--- a/liboctave/cruft/fftpack/zfftb.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,9 +0,0 @@ - subroutine zfftb (n,c,wsave) - implicit double precision (a-h,o-z) - dimension c(*) ,wsave(*) - if (n .eq. 1) return - iw1 = n+n+1 - iw2 = iw1+n+n - call zfftb1 (n,c,wsave,wsave(iw1),wsave(iw2)) - return - end
--- a/liboctave/cruft/fftpack/zfftb1.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,62 +0,0 @@ - subroutine zfftb1 (n,c,ch,wa,ifac) - implicit double precision (a-h,o-z) - dimension ch(*) ,c(*) ,wa(*) ,ifac(*) - nf = ifac(2) - na = 0 - l1 = 1 - iw = 1 - do 116 k1=1,nf - ip = ifac(k1+2) - l2 = ip*l1 - ido = n/l2 - idot = ido+ido - idl1 = idot*l1 - if (ip .ne. 4) go to 103 - ix2 = iw+idot - ix3 = ix2+idot - if (na .ne. 0) go to 101 - call zpassb4 (idot,l1,c,ch,wa(iw),wa(ix2),wa(ix3)) - go to 102 - 101 call zpassb4 (idot,l1,ch,c,wa(iw),wa(ix2),wa(ix3)) - 102 na = 1-na - go to 115 - 103 if (ip .ne. 2) go to 106 - if (na .ne. 0) go to 104 - call zpassb2 (idot,l1,c,ch,wa(iw)) - go to 105 - 104 call zpassb2 (idot,l1,ch,c,wa(iw)) - 105 na = 1-na - go to 115 - 106 if (ip .ne. 3) go to 109 - ix2 = iw+idot - if (na .ne. 0) go to 107 - call zpassb3 (idot,l1,c,ch,wa(iw),wa(ix2)) - go to 108 - 107 call zpassb3 (idot,l1,ch,c,wa(iw),wa(ix2)) - 108 na = 1-na - go to 115 - 109 if (ip .ne. 5) go to 112 - ix2 = iw+idot - ix3 = ix2+idot - ix4 = ix3+idot - if (na .ne. 0) go to 110 - call zpassb5 (idot,l1,c,ch,wa(iw),wa(ix2),wa(ix3),wa(ix4)) - go to 111 - 110 call zpassb5 (idot,l1,ch,c,wa(iw),wa(ix2),wa(ix3),wa(ix4)) - 111 na = 1-na - go to 115 - 112 if (na .ne. 0) go to 113 - call zpassb (nac,idot,ip,l1,idl1,c,c,c,ch,ch,wa(iw)) - go to 114 - 113 call zpassb (nac,idot,ip,l1,idl1,ch,ch,ch,c,c,wa(iw)) - 114 if (nac .ne. 0) na = 1-na - 115 l1 = l2 - iw = iw+(ip-1)*idot - 116 continue - if (na .eq. 0) return - n2 = n+n - do 117 i=1,n2 - c(i) = ch(i) - 117 continue - return - end
--- a/liboctave/cruft/fftpack/zfftf.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,9 +0,0 @@ - subroutine zfftf (n,c,wsave) - implicit double precision (a-h,o-z) - dimension c(*) ,wsave(*) - if (n .eq. 1) return - iw1 = n+n+1 - iw2 = iw1+n+n - call zfftf1 (n,c,wsave,wsave(iw1),wsave(iw2)) - return - end
--- a/liboctave/cruft/fftpack/zfftf1.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,62 +0,0 @@ - subroutine zfftf1 (n,c,ch,wa,ifac) - implicit double precision (a-h,o-z) - dimension ch(*) ,c(*) ,wa(*) ,ifac(*) - nf = ifac(2) - na = 0 - l1 = 1 - iw = 1 - do 116 k1=1,nf - ip = ifac(k1+2) - l2 = ip*l1 - ido = n/l2 - idot = ido+ido - idl1 = idot*l1 - if (ip .ne. 4) go to 103 - ix2 = iw+idot - ix3 = ix2+idot - if (na .ne. 0) go to 101 - call zpassf4 (idot,l1,c,ch,wa(iw),wa(ix2),wa(ix3)) - go to 102 - 101 call zpassf4 (idot,l1,ch,c,wa(iw),wa(ix2),wa(ix3)) - 102 na = 1-na - go to 115 - 103 if (ip .ne. 2) go to 106 - if (na .ne. 0) go to 104 - call zpassf2 (idot,l1,c,ch,wa(iw)) - go to 105 - 104 call zpassf2 (idot,l1,ch,c,wa(iw)) - 105 na = 1-na - go to 115 - 106 if (ip .ne. 3) go to 109 - ix2 = iw+idot - if (na .ne. 0) go to 107 - call zpassf3 (idot,l1,c,ch,wa(iw),wa(ix2)) - go to 108 - 107 call zpassf3 (idot,l1,ch,c,wa(iw),wa(ix2)) - 108 na = 1-na - go to 115 - 109 if (ip .ne. 5) go to 112 - ix2 = iw+idot - ix3 = ix2+idot - ix4 = ix3+idot - if (na .ne. 0) go to 110 - call zpassf5 (idot,l1,c,ch,wa(iw),wa(ix2),wa(ix3),wa(ix4)) - go to 111 - 110 call zpassf5 (idot,l1,ch,c,wa(iw),wa(ix2),wa(ix3),wa(ix4)) - 111 na = 1-na - go to 115 - 112 if (na .ne. 0) go to 113 - call zpassf (nac,idot,ip,l1,idl1,c,c,c,ch,ch,wa(iw)) - go to 114 - 113 call zpassf (nac,idot,ip,l1,idl1,ch,ch,ch,c,c,wa(iw)) - 114 if (nac .ne. 0) na = 1-na - 115 l1 = l2 - iw = iw+(ip-1)*idot - 116 continue - if (na .eq. 0) return - n2 = n+n - do 117 i=1,n2 - c(i) = ch(i) - 117 continue - return - end
--- a/liboctave/cruft/fftpack/zffti.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,9 +0,0 @@ - subroutine zffti (n,wsave) - implicit double precision (a-h,o-z) - dimension wsave(*) - if (n .eq. 1) return - iw1 = n+n+1 - iw2 = iw1+n+n - call zffti1 (n,wsave(iw1),wsave(iw2)) - return - end
--- a/liboctave/cruft/fftpack/zffti1.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,61 +0,0 @@ - subroutine zffti1 (n,wa,ifac) - implicit double precision (a-h,o-z) - dimension wa(*) ,ifac(*) ,ntryh(4) - data ntryh(1),ntryh(2),ntryh(3),ntryh(4)/3,4,2,5/ - nl = n - nf = 0 - j = 0 - 101 j = j+1 - if (j-4) 102,102,103 - 102 ntry = ntryh(j) - go to 104 - 103 ntry = ntry+2 - 104 nq = nl/ntry - nr = nl-ntry*nq - if (nr) 101,105,101 - 105 nf = nf+1 - ifac(nf+2) = ntry - nl = nq - if (ntry .ne. 2) go to 107 - if (nf .eq. 1) go to 107 - do 106 i=2,nf - ib = nf-i+2 - ifac(ib+2) = ifac(ib+1) - 106 continue - ifac(3) = 2 - 107 if (nl .ne. 1) go to 104 - ifac(1) = n - ifac(2) = nf - tpi = 6.28318530717959d0 - argh = tpi/dble(n) - i = 2 - l1 = 1 - do 110 k1=1,nf - ip = ifac(k1+2) - ld = 0 - l2 = l1*ip - ido = n/l2 - idot = ido+ido+2 - ipm = ip-1 - do 109 j=1,ipm - i1 = i - wa(i-1) = 1. - wa(i) = 0. - ld = ld+l1 - fi = 0. - argld = dble(ld)*argh - do 108 ii=4,idot,2 - i = i+2 - fi = fi+1. - arg = fi*argld - wa(i-1) = cos(arg) - wa(i) = sin(arg) - 108 continue - if (ip .le. 5) go to 109 - wa(i1-1) = wa(i-1) - wa(i1) = wa(i) - 109 continue - l1 = l2 - 110 continue - return - end
--- a/liboctave/cruft/fftpack/zpassb.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,117 +0,0 @@ - subroutine zpassb (nac,ido,ip,l1,idl1,cc,c1,c2,ch,ch2,wa) - implicit double precision (a-h,o-z) - dimension ch(ido,l1,ip) ,cc(ido,ip,l1) , - 1 c1(ido,l1,ip) ,wa(1) ,c2(idl1,ip), - 2 ch2(idl1,ip) - idot = ido/2 - nt = ip*idl1 - ipp2 = ip+2 - ipph = (ip+1)/2 - idp = ip*ido -c - if (ido .lt. l1) go to 106 - do 103 j=2,ipph - jc = ipp2-j - do 102 k=1,l1 - do 101 i=1,ido - ch(i,k,j) = cc(i,j,k)+cc(i,jc,k) - ch(i,k,jc) = cc(i,j,k)-cc(i,jc,k) - 101 continue - 102 continue - 103 continue - do 105 k=1,l1 - do 104 i=1,ido - ch(i,k,1) = cc(i,1,k) - 104 continue - 105 continue - go to 112 - 106 do 109 j=2,ipph - jc = ipp2-j - do 108 i=1,ido - do 107 k=1,l1 - ch(i,k,j) = cc(i,j,k)+cc(i,jc,k) - ch(i,k,jc) = cc(i,j,k)-cc(i,jc,k) - 107 continue - 108 continue - 109 continue - do 111 i=1,ido - do 110 k=1,l1 - ch(i,k,1) = cc(i,1,k) - 110 continue - 111 continue - 112 idl = 2-ido - inc = 0 - do 116 l=2,ipph - lc = ipp2-l - idl = idl+ido - do 113 ik=1,idl1 - c2(ik,l) = ch2(ik,1)+wa(idl-1)*ch2(ik,2) - c2(ik,lc) = wa(idl)*ch2(ik,ip) - 113 continue - idlj = idl - inc = inc+ido - do 115 j=3,ipph - jc = ipp2-j - idlj = idlj+inc - if (idlj .gt. idp) idlj = idlj-idp - war = wa(idlj-1) - wai = wa(idlj) - do 114 ik=1,idl1 - c2(ik,l) = c2(ik,l)+war*ch2(ik,j) - c2(ik,lc) = c2(ik,lc)+wai*ch2(ik,jc) - 114 continue - 115 continue - 116 continue - do 118 j=2,ipph - do 117 ik=1,idl1 - ch2(ik,1) = ch2(ik,1)+ch2(ik,j) - 117 continue - 118 continue - do 120 j=2,ipph - jc = ipp2-j - do 119 ik=2,idl1,2 - ch2(ik-1,j) = c2(ik-1,j)-c2(ik,jc) - ch2(ik-1,jc) = c2(ik-1,j)+c2(ik,jc) - ch2(ik,j) = c2(ik,j)+c2(ik-1,jc) - ch2(ik,jc) = c2(ik,j)-c2(ik-1,jc) - 119 continue - 120 continue - nac = 1 - if (ido .eq. 2) return - nac = 0 - do 121 ik=1,idl1 - c2(ik,1) = ch2(ik,1) - 121 continue - do 123 j=2,ip - do 122 k=1,l1 - c1(1,k,j) = ch(1,k,j) - c1(2,k,j) = ch(2,k,j) - 122 continue - 123 continue - if (idot .gt. l1) go to 127 - idij = 0 - do 126 j=2,ip - idij = idij+2 - do 125 i=4,ido,2 - idij = idij+2 - do 124 k=1,l1 - c1(i-1,k,j) = wa(idij-1)*ch(i-1,k,j)-wa(idij)*ch(i,k,j) - c1(i,k,j) = wa(idij-1)*ch(i,k,j)+wa(idij)*ch(i-1,k,j) - 124 continue - 125 continue - 126 continue - return - 127 idj = 2-ido - do 130 j=2,ip - idj = idj+ido - do 129 k=1,l1 - idij = idj - do 128 i=4,ido,2 - idij = idij+2 - c1(i-1,k,j) = wa(idij-1)*ch(i-1,k,j)-wa(idij)*ch(i,k,j) - c1(i,k,j) = wa(idij-1)*ch(i,k,j)+wa(idij)*ch(i-1,k,j) - 128 continue - 129 continue - 130 continue - return - end
--- a/liboctave/cruft/fftpack/zpassb2.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,24 +0,0 @@ - subroutine zpassb2 (ido,l1,cc,ch,wa1) - implicit double precision (a-h,o-z) - dimension cc(ido,2,l1) ,ch(ido,l1,2) , - 1 wa1(1) - if (ido .gt. 2) go to 102 - do 101 k=1,l1 - ch(1,k,1) = cc(1,1,k)+cc(1,2,k) - ch(1,k,2) = cc(1,1,k)-cc(1,2,k) - ch(2,k,1) = cc(2,1,k)+cc(2,2,k) - ch(2,k,2) = cc(2,1,k)-cc(2,2,k) - 101 continue - return - 102 do 104 k=1,l1 - do 103 i=2,ido,2 - ch(i-1,k,1) = cc(i-1,1,k)+cc(i-1,2,k) - tr2 = cc(i-1,1,k)-cc(i-1,2,k) - ch(i,k,1) = cc(i,1,k)+cc(i,2,k) - ti2 = cc(i,1,k)-cc(i,2,k) - ch(i,k,2) = wa1(i-1)*ti2+wa1(i)*tr2 - ch(i-1,k,2) = wa1(i-1)*tr2-wa1(i)*ti2 - 103 continue - 104 continue - return - end
--- a/liboctave/cruft/fftpack/zpassb3.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,43 +0,0 @@ - subroutine zpassb3 (ido,l1,cc,ch,wa1,wa2) - implicit double precision (a-h,o-z) - dimension cc(ido,3,l1) ,ch(ido,l1,3) , - 1 wa1(1) ,wa2(1) - data taur,taui /-.5,.866025403784439d0/ - if (ido .ne. 2) go to 102 - do 101 k=1,l1 - tr2 = cc(1,2,k)+cc(1,3,k) - cr2 = cc(1,1,k)+taur*tr2 - ch(1,k,1) = cc(1,1,k)+tr2 - ti2 = cc(2,2,k)+cc(2,3,k) - ci2 = cc(2,1,k)+taur*ti2 - ch(2,k,1) = cc(2,1,k)+ti2 - cr3 = taui*(cc(1,2,k)-cc(1,3,k)) - ci3 = taui*(cc(2,2,k)-cc(2,3,k)) - ch(1,k,2) = cr2-ci3 - ch(1,k,3) = cr2+ci3 - ch(2,k,2) = ci2+cr3 - ch(2,k,3) = ci2-cr3 - 101 continue - return - 102 do 104 k=1,l1 - do 103 i=2,ido,2 - tr2 = cc(i-1,2,k)+cc(i-1,3,k) - cr2 = cc(i-1,1,k)+taur*tr2 - ch(i-1,k,1) = cc(i-1,1,k)+tr2 - ti2 = cc(i,2,k)+cc(i,3,k) - ci2 = cc(i,1,k)+taur*ti2 - ch(i,k,1) = cc(i,1,k)+ti2 - cr3 = taui*(cc(i-1,2,k)-cc(i-1,3,k)) - ci3 = taui*(cc(i,2,k)-cc(i,3,k)) - dr2 = cr2-ci3 - dr3 = cr2+ci3 - di2 = ci2+cr3 - di3 = ci2-cr3 - ch(i,k,2) = wa1(i-1)*di2+wa1(i)*dr2 - ch(i-1,k,2) = wa1(i-1)*dr2-wa1(i)*di2 - ch(i,k,3) = wa2(i-1)*di3+wa2(i)*dr3 - ch(i-1,k,3) = wa2(i-1)*dr3-wa2(i)*di3 - 103 continue - 104 continue - return - end
--- a/liboctave/cruft/fftpack/zpassb4.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,52 +0,0 @@ - subroutine zpassb4 (ido,l1,cc,ch,wa1,wa2,wa3) - implicit double precision (a-h,o-z) - dimension cc(ido,4,l1) ,ch(ido,l1,4) , - 1 wa1(1) ,wa2(1) ,wa3(1) - if (ido .ne. 2) go to 102 - do 101 k=1,l1 - ti1 = cc(2,1,k)-cc(2,3,k) - ti2 = cc(2,1,k)+cc(2,3,k) - tr4 = cc(2,4,k)-cc(2,2,k) - ti3 = cc(2,2,k)+cc(2,4,k) - tr1 = cc(1,1,k)-cc(1,3,k) - tr2 = cc(1,1,k)+cc(1,3,k) - ti4 = cc(1,2,k)-cc(1,4,k) - tr3 = cc(1,2,k)+cc(1,4,k) - ch(1,k,1) = tr2+tr3 - ch(1,k,3) = tr2-tr3 - ch(2,k,1) = ti2+ti3 - ch(2,k,3) = ti2-ti3 - ch(1,k,2) = tr1+tr4 - ch(1,k,4) = tr1-tr4 - ch(2,k,2) = ti1+ti4 - ch(2,k,4) = ti1-ti4 - 101 continue - return - 102 do 104 k=1,l1 - do 103 i=2,ido,2 - ti1 = cc(i,1,k)-cc(i,3,k) - ti2 = cc(i,1,k)+cc(i,3,k) - ti3 = cc(i,2,k)+cc(i,4,k) - tr4 = cc(i,4,k)-cc(i,2,k) - tr1 = cc(i-1,1,k)-cc(i-1,3,k) - tr2 = cc(i-1,1,k)+cc(i-1,3,k) - ti4 = cc(i-1,2,k)-cc(i-1,4,k) - tr3 = cc(i-1,2,k)+cc(i-1,4,k) - ch(i-1,k,1) = tr2+tr3 - cr3 = tr2-tr3 - ch(i,k,1) = ti2+ti3 - ci3 = ti2-ti3 - cr2 = tr1+tr4 - cr4 = tr1-tr4 - ci2 = ti1+ti4 - ci4 = ti1-ti4 - ch(i-1,k,2) = wa1(i-1)*cr2-wa1(i)*ci2 - ch(i,k,2) = wa1(i-1)*ci2+wa1(i)*cr2 - ch(i-1,k,3) = wa2(i-1)*cr3-wa2(i)*ci3 - ch(i,k,3) = wa2(i-1)*ci3+wa2(i)*cr3 - ch(i-1,k,4) = wa3(i-1)*cr4-wa3(i)*ci4 - ch(i,k,4) = wa3(i-1)*ci4+wa3(i)*cr4 - 103 continue - 104 continue - return - end
--- a/liboctave/cruft/fftpack/zpassb5.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,76 +0,0 @@ - subroutine zpassb5 (ido,l1,cc,ch,wa1,wa2,wa3,wa4) - implicit double precision (a-h,o-z) - dimension cc(ido,5,l1) ,ch(ido,l1,5) , - 1 wa1(1) ,wa2(1) ,wa3(1) ,wa4(1) - data tr11,ti11,tr12,ti12 /.309016994374947d0,.951056516295154d0, - 1-.809016994374947d0,.587785252292473d0/ - if (ido .ne. 2) go to 102 - do 101 k=1,l1 - ti5 = cc(2,2,k)-cc(2,5,k) - ti2 = cc(2,2,k)+cc(2,5,k) - ti4 = cc(2,3,k)-cc(2,4,k) - ti3 = cc(2,3,k)+cc(2,4,k) - tr5 = cc(1,2,k)-cc(1,5,k) - tr2 = cc(1,2,k)+cc(1,5,k) - tr4 = cc(1,3,k)-cc(1,4,k) - tr3 = cc(1,3,k)+cc(1,4,k) - ch(1,k,1) = cc(1,1,k)+tr2+tr3 - ch(2,k,1) = cc(2,1,k)+ti2+ti3 - cr2 = cc(1,1,k)+tr11*tr2+tr12*tr3 - ci2 = cc(2,1,k)+tr11*ti2+tr12*ti3 - cr3 = cc(1,1,k)+tr12*tr2+tr11*tr3 - ci3 = cc(2,1,k)+tr12*ti2+tr11*ti3 - cr5 = ti11*tr5+ti12*tr4 - ci5 = ti11*ti5+ti12*ti4 - cr4 = ti12*tr5-ti11*tr4 - ci4 = ti12*ti5-ti11*ti4 - ch(1,k,2) = cr2-ci5 - ch(1,k,5) = cr2+ci5 - ch(2,k,2) = ci2+cr5 - ch(2,k,3) = ci3+cr4 - ch(1,k,3) = cr3-ci4 - ch(1,k,4) = cr3+ci4 - ch(2,k,4) = ci3-cr4 - ch(2,k,5) = ci2-cr5 - 101 continue - return - 102 do 104 k=1,l1 - do 103 i=2,ido,2 - ti5 = cc(i,2,k)-cc(i,5,k) - ti2 = cc(i,2,k)+cc(i,5,k) - ti4 = cc(i,3,k)-cc(i,4,k) - ti3 = cc(i,3,k)+cc(i,4,k) - tr5 = cc(i-1,2,k)-cc(i-1,5,k) - tr2 = cc(i-1,2,k)+cc(i-1,5,k) - tr4 = cc(i-1,3,k)-cc(i-1,4,k) - tr3 = cc(i-1,3,k)+cc(i-1,4,k) - ch(i-1,k,1) = cc(i-1,1,k)+tr2+tr3 - ch(i,k,1) = cc(i,1,k)+ti2+ti3 - cr2 = cc(i-1,1,k)+tr11*tr2+tr12*tr3 - ci2 = cc(i,1,k)+tr11*ti2+tr12*ti3 - cr3 = cc(i-1,1,k)+tr12*tr2+tr11*tr3 - ci3 = cc(i,1,k)+tr12*ti2+tr11*ti3 - cr5 = ti11*tr5+ti12*tr4 - ci5 = ti11*ti5+ti12*ti4 - cr4 = ti12*tr5-ti11*tr4 - ci4 = ti12*ti5-ti11*ti4 - dr3 = cr3-ci4 - dr4 = cr3+ci4 - di3 = ci3+cr4 - di4 = ci3-cr4 - dr5 = cr2+ci5 - dr2 = cr2-ci5 - di5 = ci2-cr5 - di2 = ci2+cr5 - ch(i-1,k,2) = wa1(i-1)*dr2-wa1(i)*di2 - ch(i,k,2) = wa1(i-1)*di2+wa1(i)*dr2 - ch(i-1,k,3) = wa2(i-1)*dr3-wa2(i)*di3 - ch(i,k,3) = wa2(i-1)*di3+wa2(i)*dr3 - ch(i-1,k,4) = wa3(i-1)*dr4-wa3(i)*di4 - ch(i,k,4) = wa3(i-1)*di4+wa3(i)*dr4 - ch(i-1,k,5) = wa4(i-1)*dr5-wa4(i)*di5 - ch(i,k,5) = wa4(i-1)*di5+wa4(i)*dr5 - 103 continue - 104 continue - return - end
--- a/liboctave/cruft/fftpack/zpassf.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,117 +0,0 @@ - subroutine zpassf (nac,ido,ip,l1,idl1,cc,c1,c2,ch,ch2,wa) - implicit double precision (a-h,o-z) - dimension ch(ido,l1,ip) ,cc(ido,ip,l1) , - 1 c1(ido,l1,ip) ,wa(1) ,c2(idl1,ip), - 2 ch2(idl1,ip) - idot = ido/2 - nt = ip*idl1 - ipp2 = ip+2 - ipph = (ip+1)/2 - idp = ip*ido -c - if (ido .lt. l1) go to 106 - do 103 j=2,ipph - jc = ipp2-j - do 102 k=1,l1 - do 101 i=1,ido - ch(i,k,j) = cc(i,j,k)+cc(i,jc,k) - ch(i,k,jc) = cc(i,j,k)-cc(i,jc,k) - 101 continue - 102 continue - 103 continue - do 105 k=1,l1 - do 104 i=1,ido - ch(i,k,1) = cc(i,1,k) - 104 continue - 105 continue - go to 112 - 106 do 109 j=2,ipph - jc = ipp2-j - do 108 i=1,ido - do 107 k=1,l1 - ch(i,k,j) = cc(i,j,k)+cc(i,jc,k) - ch(i,k,jc) = cc(i,j,k)-cc(i,jc,k) - 107 continue - 108 continue - 109 continue - do 111 i=1,ido - do 110 k=1,l1 - ch(i,k,1) = cc(i,1,k) - 110 continue - 111 continue - 112 idl = 2-ido - inc = 0 - do 116 l=2,ipph - lc = ipp2-l - idl = idl+ido - do 113 ik=1,idl1 - c2(ik,l) = ch2(ik,1)+wa(idl-1)*ch2(ik,2) - c2(ik,lc) = -wa(idl)*ch2(ik,ip) - 113 continue - idlj = idl - inc = inc+ido - do 115 j=3,ipph - jc = ipp2-j - idlj = idlj+inc - if (idlj .gt. idp) idlj = idlj-idp - war = wa(idlj-1) - wai = wa(idlj) - do 114 ik=1,idl1 - c2(ik,l) = c2(ik,l)+war*ch2(ik,j) - c2(ik,lc) = c2(ik,lc)-wai*ch2(ik,jc) - 114 continue - 115 continue - 116 continue - do 118 j=2,ipph - do 117 ik=1,idl1 - ch2(ik,1) = ch2(ik,1)+ch2(ik,j) - 117 continue - 118 continue - do 120 j=2,ipph - jc = ipp2-j - do 119 ik=2,idl1,2 - ch2(ik-1,j) = c2(ik-1,j)-c2(ik,jc) - ch2(ik-1,jc) = c2(ik-1,j)+c2(ik,jc) - ch2(ik,j) = c2(ik,j)+c2(ik-1,jc) - ch2(ik,jc) = c2(ik,j)-c2(ik-1,jc) - 119 continue - 120 continue - nac = 1 - if (ido .eq. 2) return - nac = 0 - do 121 ik=1,idl1 - c2(ik,1) = ch2(ik,1) - 121 continue - do 123 j=2,ip - do 122 k=1,l1 - c1(1,k,j) = ch(1,k,j) - c1(2,k,j) = ch(2,k,j) - 122 continue - 123 continue - if (idot .gt. l1) go to 127 - idij = 0 - do 126 j=2,ip - idij = idij+2 - do 125 i=4,ido,2 - idij = idij+2 - do 124 k=1,l1 - c1(i-1,k,j) = wa(idij-1)*ch(i-1,k,j)+wa(idij)*ch(i,k,j) - c1(i,k,j) = wa(idij-1)*ch(i,k,j)-wa(idij)*ch(i-1,k,j) - 124 continue - 125 continue - 126 continue - return - 127 idj = 2-ido - do 130 j=2,ip - idj = idj+ido - do 129 k=1,l1 - idij = idj - do 128 i=4,ido,2 - idij = idij+2 - c1(i-1,k,j) = wa(idij-1)*ch(i-1,k,j)+wa(idij)*ch(i,k,j) - c1(i,k,j) = wa(idij-1)*ch(i,k,j)-wa(idij)*ch(i-1,k,j) - 128 continue - 129 continue - 130 continue - return - end
--- a/liboctave/cruft/fftpack/zpassf2.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,24 +0,0 @@ - subroutine zpassf2 (ido,l1,cc,ch,wa1) - implicit double precision (a-h,o-z) - dimension cc(ido,2,l1) ,ch(ido,l1,2) , - 1 wa1(1) - if (ido .gt. 2) go to 102 - do 101 k=1,l1 - ch(1,k,1) = cc(1,1,k)+cc(1,2,k) - ch(1,k,2) = cc(1,1,k)-cc(1,2,k) - ch(2,k,1) = cc(2,1,k)+cc(2,2,k) - ch(2,k,2) = cc(2,1,k)-cc(2,2,k) - 101 continue - return - 102 do 104 k=1,l1 - do 103 i=2,ido,2 - ch(i-1,k,1) = cc(i-1,1,k)+cc(i-1,2,k) - tr2 = cc(i-1,1,k)-cc(i-1,2,k) - ch(i,k,1) = cc(i,1,k)+cc(i,2,k) - ti2 = cc(i,1,k)-cc(i,2,k) - ch(i,k,2) = wa1(i-1)*ti2-wa1(i)*tr2 - ch(i-1,k,2) = wa1(i-1)*tr2+wa1(i)*ti2 - 103 continue - 104 continue - return - end
--- a/liboctave/cruft/fftpack/zpassf3.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,43 +0,0 @@ - subroutine zpassf3 (ido,l1,cc,ch,wa1,wa2) - implicit double precision (a-h,o-z) - dimension cc(ido,3,l1) ,ch(ido,l1,3) , - 1 wa1(1) ,wa2(1) - data taur,taui /-.5d0,-.866025403784439d0/ - if (ido .ne. 2) go to 102 - do 101 k=1,l1 - tr2 = cc(1,2,k)+cc(1,3,k) - cr2 = cc(1,1,k)+taur*tr2 - ch(1,k,1) = cc(1,1,k)+tr2 - ti2 = cc(2,2,k)+cc(2,3,k) - ci2 = cc(2,1,k)+taur*ti2 - ch(2,k,1) = cc(2,1,k)+ti2 - cr3 = taui*(cc(1,2,k)-cc(1,3,k)) - ci3 = taui*(cc(2,2,k)-cc(2,3,k)) - ch(1,k,2) = cr2-ci3 - ch(1,k,3) = cr2+ci3 - ch(2,k,2) = ci2+cr3 - ch(2,k,3) = ci2-cr3 - 101 continue - return - 102 do 104 k=1,l1 - do 103 i=2,ido,2 - tr2 = cc(i-1,2,k)+cc(i-1,3,k) - cr2 = cc(i-1,1,k)+taur*tr2 - ch(i-1,k,1) = cc(i-1,1,k)+tr2 - ti2 = cc(i,2,k)+cc(i,3,k) - ci2 = cc(i,1,k)+taur*ti2 - ch(i,k,1) = cc(i,1,k)+ti2 - cr3 = taui*(cc(i-1,2,k)-cc(i-1,3,k)) - ci3 = taui*(cc(i,2,k)-cc(i,3,k)) - dr2 = cr2-ci3 - dr3 = cr2+ci3 - di2 = ci2+cr3 - di3 = ci2-cr3 - ch(i,k,2) = wa1(i-1)*di2-wa1(i)*dr2 - ch(i-1,k,2) = wa1(i-1)*dr2+wa1(i)*di2 - ch(i,k,3) = wa2(i-1)*di3-wa2(i)*dr3 - ch(i-1,k,3) = wa2(i-1)*dr3+wa2(i)*di3 - 103 continue - 104 continue - return - end
--- a/liboctave/cruft/fftpack/zpassf4.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,52 +0,0 @@ - subroutine zpassf4 (ido,l1,cc,ch,wa1,wa2,wa3) - implicit double precision (a-h,o-z) - dimension cc(ido,4,l1) ,ch(ido,l1,4) , - 1 wa1(1) ,wa2(1) ,wa3(1) - if (ido .ne. 2) go to 102 - do 101 k=1,l1 - ti1 = cc(2,1,k)-cc(2,3,k) - ti2 = cc(2,1,k)+cc(2,3,k) - tr4 = cc(2,2,k)-cc(2,4,k) - ti3 = cc(2,2,k)+cc(2,4,k) - tr1 = cc(1,1,k)-cc(1,3,k) - tr2 = cc(1,1,k)+cc(1,3,k) - ti4 = cc(1,4,k)-cc(1,2,k) - tr3 = cc(1,2,k)+cc(1,4,k) - ch(1,k,1) = tr2+tr3 - ch(1,k,3) = tr2-tr3 - ch(2,k,1) = ti2+ti3 - ch(2,k,3) = ti2-ti3 - ch(1,k,2) = tr1+tr4 - ch(1,k,4) = tr1-tr4 - ch(2,k,2) = ti1+ti4 - ch(2,k,4) = ti1-ti4 - 101 continue - return - 102 do 104 k=1,l1 - do 103 i=2,ido,2 - ti1 = cc(i,1,k)-cc(i,3,k) - ti2 = cc(i,1,k)+cc(i,3,k) - ti3 = cc(i,2,k)+cc(i,4,k) - tr4 = cc(i,2,k)-cc(i,4,k) - tr1 = cc(i-1,1,k)-cc(i-1,3,k) - tr2 = cc(i-1,1,k)+cc(i-1,3,k) - ti4 = cc(i-1,4,k)-cc(i-1,2,k) - tr3 = cc(i-1,2,k)+cc(i-1,4,k) - ch(i-1,k,1) = tr2+tr3 - cr3 = tr2-tr3 - ch(i,k,1) = ti2+ti3 - ci3 = ti2-ti3 - cr2 = tr1+tr4 - cr4 = tr1-tr4 - ci2 = ti1+ti4 - ci4 = ti1-ti4 - ch(i-1,k,2) = wa1(i-1)*cr2+wa1(i)*ci2 - ch(i,k,2) = wa1(i-1)*ci2-wa1(i)*cr2 - ch(i-1,k,3) = wa2(i-1)*cr3+wa2(i)*ci3 - ch(i,k,3) = wa2(i-1)*ci3-wa2(i)*cr3 - ch(i-1,k,4) = wa3(i-1)*cr4+wa3(i)*ci4 - ch(i,k,4) = wa3(i-1)*ci4-wa3(i)*cr4 - 103 continue - 104 continue - return - end
--- a/liboctave/cruft/fftpack/zpassf5.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,76 +0,0 @@ - subroutine zpassf5 (ido,l1,cc,ch,wa1,wa2,wa3,wa4) - implicit double precision (a-h,o-z) - dimension cc(ido,5,l1) ,ch(ido,l1,5) , - 1 wa1(1) ,wa2(1) ,wa3(1) ,wa4(1) - data tr11,ti11,tr12,ti12 /.309016994374947d0,-.951056516295154d0, - 1-.809016994374947d0,-.587785252292473d0/ - if (ido .ne. 2) go to 102 - do 101 k=1,l1 - ti5 = cc(2,2,k)-cc(2,5,k) - ti2 = cc(2,2,k)+cc(2,5,k) - ti4 = cc(2,3,k)-cc(2,4,k) - ti3 = cc(2,3,k)+cc(2,4,k) - tr5 = cc(1,2,k)-cc(1,5,k) - tr2 = cc(1,2,k)+cc(1,5,k) - tr4 = cc(1,3,k)-cc(1,4,k) - tr3 = cc(1,3,k)+cc(1,4,k) - ch(1,k,1) = cc(1,1,k)+tr2+tr3 - ch(2,k,1) = cc(2,1,k)+ti2+ti3 - cr2 = cc(1,1,k)+tr11*tr2+tr12*tr3 - ci2 = cc(2,1,k)+tr11*ti2+tr12*ti3 - cr3 = cc(1,1,k)+tr12*tr2+tr11*tr3 - ci3 = cc(2,1,k)+tr12*ti2+tr11*ti3 - cr5 = ti11*tr5+ti12*tr4 - ci5 = ti11*ti5+ti12*ti4 - cr4 = ti12*tr5-ti11*tr4 - ci4 = ti12*ti5-ti11*ti4 - ch(1,k,2) = cr2-ci5 - ch(1,k,5) = cr2+ci5 - ch(2,k,2) = ci2+cr5 - ch(2,k,3) = ci3+cr4 - ch(1,k,3) = cr3-ci4 - ch(1,k,4) = cr3+ci4 - ch(2,k,4) = ci3-cr4 - ch(2,k,5) = ci2-cr5 - 101 continue - return - 102 do 104 k=1,l1 - do 103 i=2,ido,2 - ti5 = cc(i,2,k)-cc(i,5,k) - ti2 = cc(i,2,k)+cc(i,5,k) - ti4 = cc(i,3,k)-cc(i,4,k) - ti3 = cc(i,3,k)+cc(i,4,k) - tr5 = cc(i-1,2,k)-cc(i-1,5,k) - tr2 = cc(i-1,2,k)+cc(i-1,5,k) - tr4 = cc(i-1,3,k)-cc(i-1,4,k) - tr3 = cc(i-1,3,k)+cc(i-1,4,k) - ch(i-1,k,1) = cc(i-1,1,k)+tr2+tr3 - ch(i,k,1) = cc(i,1,k)+ti2+ti3 - cr2 = cc(i-1,1,k)+tr11*tr2+tr12*tr3 - ci2 = cc(i,1,k)+tr11*ti2+tr12*ti3 - cr3 = cc(i-1,1,k)+tr12*tr2+tr11*tr3 - ci3 = cc(i,1,k)+tr12*ti2+tr11*ti3 - cr5 = ti11*tr5+ti12*tr4 - ci5 = ti11*ti5+ti12*ti4 - cr4 = ti12*tr5-ti11*tr4 - ci4 = ti12*ti5-ti11*ti4 - dr3 = cr3-ci4 - dr4 = cr3+ci4 - di3 = ci3+cr4 - di4 = ci3-cr4 - dr5 = cr2+ci5 - dr2 = cr2-ci5 - di5 = ci2-cr5 - di2 = ci2+cr5 - ch(i-1,k,2) = wa1(i-1)*dr2+wa1(i)*di2 - ch(i,k,2) = wa1(i-1)*di2-wa1(i)*dr2 - ch(i-1,k,3) = wa2(i-1)*dr3+wa2(i)*di3 - ch(i,k,3) = wa2(i-1)*di3-wa2(i)*dr3 - ch(i-1,k,4) = wa3(i-1)*dr4+wa3(i)*di4 - ch(i,k,4) = wa3(i-1)*di4-wa3(i)*dr4 - ch(i-1,k,5) = wa4(i-1)*dr5+wa4(i)*di5 - ch(i,k,5) = wa4(i-1)*di5-wa4(i)*dr5 - 103 continue - 104 continue - return - end
--- a/liboctave/cruft/lapack-xtra/crsf2csf.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,96 +0,0 @@ -c Copyright (C) 2010-2017 VZLU Prague, a.s., Czech Republic -c -c Author: Jaroslav Hajek <highegg@gmail.com> -c -c This file is part of Octave. -c -c Octave is free software; you can redistribute it and/or modify it -c under the terms of the GNU General Public License as published by -c the Free Software Foundation; either version 3 of the License, or -c (at your option) any later version. -c -c Octave is distributed in the hope that it will be useful, but -c WITHOUT ANY WARRANTY; without even the implied warranty of -c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -c GNU General Public License for more details. -c -c You should have received a copy of the GNU General Public License -c along with Octave; see the file COPYING. If not, see -c <http://www.gnu.org/licenses/>. -c - - subroutine crsf2csf(n,t,u,c,s) - integer n - complex t(n,n),u(n,n) - real c(n-1),s(n-1) - real x,y,z - integer j - do j = 1,n-1 - c(j) = 1 - end do - j = 1 - do while (j < n) -c apply previous rotations to rows - call crcrot1(j,t(1,j),c,s) - - y = t(j+1,j) - if (y /= 0) then -c 2x2 block, form Givens rotation [c, i*s; i*s, c] - z = t(j,j+1) - c(j) = sqrt(z/(z-y)) - s(j) = sqrt(y/(y-z)) -c apply new rotation to t(j:j+1,j) - call crcrot1(2,t(j,j),c(j),s(j)) -c apply all rotations to t(1:j+1,j+1) - call crcrot1(j+1,t(1,j+1),c,s) -c apply new rotation to columns j,j+1 - call crcrot2(j+1,t(1,j),t(1,j+1),c(j),s(j)) -c zero subdiagonal entry, skip next row - t(j+1,j) = 0 - j = j + 2 - else - j = j + 1 - end if - end do - -c apply rotations to last column if needed - if (j == n) then - call crcrot1(j,t(1,j),c,s) - end if - -c apply stored rotations to all columns of u - do j = 1,n-1 - if (c(j) /= 1) then - call crcrot2(n,u(1,j),u(1,j+1),c(j),s(j)) - end if - end do - - end subroutine - - subroutine crcrot1(n,x,c,s) -c apply rotations to a column from the left - integer n - complex x(n), t - real c(n-1),s(n-1) - integer i - do i = 1,n-1 - if (c(i) /= 1) then - t = x(i)*c(i) - x(i+1)*cmplx(0,s(i)) - x(i+1) = x(i+1)*c(i) - x(i)*cmplx(0,s(i)) - x(i) = t - endif - end do - end subroutine - - subroutine crcrot2(n,x,y,c,s) -c apply a single rotation from the right to a pair of columns - integer n - complex x(n),y(n),t - real c, s - integer i - do i = 1,n - t = x(i)*c + y(i)*cmplx(0,s) - y(i) = y(i)*c + x(i)*cmplx(0,s) - x(i) = t - end do - end subroutine
--- a/liboctave/cruft/lapack-xtra/module.mk Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,10 +0,0 @@ -CRUFT_SOURCES += \ - liboctave/cruft/lapack-xtra/xclange.f \ - liboctave/cruft/lapack-xtra/xdlamch.f \ - liboctave/cruft/lapack-xtra/xdlange.f \ - liboctave/cruft/lapack-xtra/xilaenv.f \ - liboctave/cruft/lapack-xtra/xslamch.f \ - liboctave/cruft/lapack-xtra/xslange.f \ - liboctave/cruft/lapack-xtra/xzlange.f \ - liboctave/cruft/lapack-xtra/zrsf2csf.f \ - liboctave/cruft/lapack-xtra/crsf2csf.f
--- a/liboctave/cruft/lapack-xtra/xclange.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,155 +0,0 @@ -*** This subroutine includes all of the CLANGE function instead of -*** simply wrapping it in a subroutine to avoid possible differences in -*** the way complex values are returned by various Fortran compilers. -*** For example, if we simply wrap the function and compile this file -*** with gfortran and the library that provides CLANGE is compiled with -*** a compiler that uses the g77 (f2c-compatible) calling convention for -*** complex-valued functions, all hell will break loose. - - SUBROUTINE XCLANGE ( NORM, M, N, A, LDA, WORK, VALUE ) - -*** DOUBLE PRECISION FUNCTION CLANGE( NORM, M, N, A, LDA, WORK ) -* -* -- LAPACK auxiliary routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 -* -* .. Scalar Arguments .. - CHARACTER NORM - INTEGER LDA, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION WORK( * ) - COMPLEX*16 A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* CLANGE returns the value of the one norm, or the Frobenius norm, or -* the infinity norm, or the element of largest absolute value of a -* complex matrix A. -* -* Description -* =========== -* -* CLANGE returns the value -* -* CLANGE = ( max(abs(A(i,j))), NORM = 'M' or 'm' -* ( -* ( norm1(A), NORM = '1', 'O' or 'o' -* ( -* ( normI(A), NORM = 'I' or 'i' -* ( -* ( normF(A), NORM = 'F', 'f', 'E' or 'e' -* -* where norm1 denotes the one norm of a matrix (maximum column sum), -* normI denotes the infinity norm of a matrix (maximum row sum) and -* normF denotes the Frobenius norm of a matrix (square root of sum of -* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. -* -* Arguments -* ========= -* -* NORM (input) CHARACTER*1 -* Specifies the value to be returned in CLANGE as described -* above. -* -* M (input) INTEGER -* The number of rows of the matrix A. M >= 0. When M = 0, -* CLANGE is set to zero. -* -* N (input) INTEGER -* The number of columns of the matrix A. N >= 0. When N = 0, -* CLANGE is set to zero. -* -* A (input) COMPLEX*16 array, dimension (LDA,N) -* The m by n matrix A. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(M,1). -* -* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)), -* where LWORK >= M when NORM = 'I'; otherwise, WORK is not -* referenced. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, J - DOUBLE PRECISION SCALE, SUM, VALUE -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL CLASSQ -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN, SQRT -* .. -* .. Executable Statements .. -* - IF( MIN( M, N ).EQ.0 ) THEN - VALUE = ZERO - ELSE IF( LSAME( NORM, 'M' ) ) THEN -* -* Find max(abs(A(i,j))). -* - VALUE = ZERO - DO 20 J = 1, N - DO 10 I = 1, M - VALUE = MAX( VALUE, ABS( A( I, J ) ) ) - 10 CONTINUE - 20 CONTINUE - ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN -* -* Find norm1(A). -* - VALUE = ZERO - DO 40 J = 1, N - SUM = ZERO - DO 30 I = 1, M - SUM = SUM + ABS( A( I, J ) ) - 30 CONTINUE - VALUE = MAX( VALUE, SUM ) - 40 CONTINUE - ELSE IF( LSAME( NORM, 'I' ) ) THEN -* -* Find normI(A). -* - DO 50 I = 1, M - WORK( I ) = ZERO - 50 CONTINUE - DO 70 J = 1, N - DO 60 I = 1, M - WORK( I ) = WORK( I ) + ABS( A( I, J ) ) - 60 CONTINUE - 70 CONTINUE - VALUE = ZERO - DO 80 I = 1, M - VALUE = MAX( VALUE, WORK( I ) ) - 80 CONTINUE - ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN -* -* Find normF(A). -* - SCALE = ZERO - SUM = ONE - DO 90 J = 1, N - CALL CLASSQ( M, A( 1, J ), 1, SCALE, SUM ) - 90 CONTINUE - VALUE = SCALE*SQRT( SUM ) - END IF -* -*** CLANGE = VALUE - RETURN -* -* End of CLANGE -* - END
--- a/liboctave/cruft/lapack-xtra/xdlamch.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,6 +0,0 @@ - subroutine xdlamch (cmach, retval) - character cmach - double precision retval, dlamch - retval = dlamch (cmach) - return - end
--- a/liboctave/cruft/lapack-xtra/xdlange.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,7 +0,0 @@ - subroutine xdlange (norm, m, n, a, lda, work, retval) - character norm - integer lda, m, n - double precision a (lda, *), work (*), dlange, retval - retval = dlange (norm, m, n, a, lda, work) - return - end
--- a/liboctave/cruft/lapack-xtra/xilaenv.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,6 +0,0 @@ - subroutine xilaenv (ispec, name, opts, n1, n2, n3, n4, retval) - character*(*) name, opts - integer ilaenv, ispec, n1, n2, n3, n4, retval - retval = ilaenv (ispec, name, opts, n1, n2, n3, n4) - return - end
--- a/liboctave/cruft/lapack-xtra/xslamch.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,6 +0,0 @@ - subroutine xslamch (cmach, retval) - character cmach - real retval, slamch - retval = slamch (cmach) - return - end
--- a/liboctave/cruft/lapack-xtra/xslange.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,7 +0,0 @@ - subroutine xslange (norm, m, n, a, lda, work, retval) - character norm - integer lda, m, n - real a (lda, *), work (*), slange, retval - retval = slange (norm, m, n, a, lda, work) - return - end
--- a/liboctave/cruft/lapack-xtra/xzlange.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,155 +0,0 @@ -*** This subroutine includes all of the ZLANGE function instead of -*** simply wrapping it in a subroutine to avoid possible differences in -*** the way complex values are returned by various Fortran compilers. -*** For example, if we simply wrap the function and compile this file -*** with gfortran and the library that provides ZLANGE is compiled with -*** a compiler that uses the g77 (f2c-compatible) calling convention for -*** complex-valued functions, all hell will break loose. - - SUBROUTINE XZLANGE ( NORM, M, N, A, LDA, WORK, VALUE ) - -*** DOUBLE PRECISION FUNCTION ZLANGE( NORM, M, N, A, LDA, WORK ) -* -* -- LAPACK auxiliary routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 -* -* .. Scalar Arguments .. - CHARACTER NORM - INTEGER LDA, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION WORK( * ) - COMPLEX*16 A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* ZLANGE returns the value of the one norm, or the Frobenius norm, or -* the infinity norm, or the element of largest absolute value of a -* complex matrix A. -* -* Description -* =========== -* -* ZLANGE returns the value -* -* ZLANGE = ( max(abs(A(i,j))), NORM = 'M' or 'm' -* ( -* ( norm1(A), NORM = '1', 'O' or 'o' -* ( -* ( normI(A), NORM = 'I' or 'i' -* ( -* ( normF(A), NORM = 'F', 'f', 'E' or 'e' -* -* where norm1 denotes the one norm of a matrix (maximum column sum), -* normI denotes the infinity norm of a matrix (maximum row sum) and -* normF denotes the Frobenius norm of a matrix (square root of sum of -* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. -* -* Arguments -* ========= -* -* NORM (input) CHARACTER*1 -* Specifies the value to be returned in ZLANGE as described -* above. -* -* M (input) INTEGER -* The number of rows of the matrix A. M >= 0. When M = 0, -* ZLANGE is set to zero. -* -* N (input) INTEGER -* The number of columns of the matrix A. N >= 0. When N = 0, -* ZLANGE is set to zero. -* -* A (input) COMPLEX*16 array, dimension (LDA,N) -* The m by n matrix A. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(M,1). -* -* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)), -* where LWORK >= M when NORM = 'I'; otherwise, WORK is not -* referenced. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, J - DOUBLE PRECISION SCALE, SUM, VALUE -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL ZLASSQ -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN, SQRT -* .. -* .. Executable Statements .. -* - IF( MIN( M, N ).EQ.0 ) THEN - VALUE = ZERO - ELSE IF( LSAME( NORM, 'M' ) ) THEN -* -* Find max(abs(A(i,j))). -* - VALUE = ZERO - DO 20 J = 1, N - DO 10 I = 1, M - VALUE = MAX( VALUE, ABS( A( I, J ) ) ) - 10 CONTINUE - 20 CONTINUE - ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN -* -* Find norm1(A). -* - VALUE = ZERO - DO 40 J = 1, N - SUM = ZERO - DO 30 I = 1, M - SUM = SUM + ABS( A( I, J ) ) - 30 CONTINUE - VALUE = MAX( VALUE, SUM ) - 40 CONTINUE - ELSE IF( LSAME( NORM, 'I' ) ) THEN -* -* Find normI(A). -* - DO 50 I = 1, M - WORK( I ) = ZERO - 50 CONTINUE - DO 70 J = 1, N - DO 60 I = 1, M - WORK( I ) = WORK( I ) + ABS( A( I, J ) ) - 60 CONTINUE - 70 CONTINUE - VALUE = ZERO - DO 80 I = 1, M - VALUE = MAX( VALUE, WORK( I ) ) - 80 CONTINUE - ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN -* -* Find normF(A). -* - SCALE = ZERO - SUM = ONE - DO 90 J = 1, N - CALL ZLASSQ( M, A( 1, J ), 1, SCALE, SUM ) - 90 CONTINUE - VALUE = SCALE*SQRT( SUM ) - END IF -* -*** ZLANGE = VALUE - RETURN -* -* End of ZLANGE -* - END
--- a/liboctave/cruft/lapack-xtra/zrsf2csf.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,96 +0,0 @@ -c Copyright (C) 2010-2017 VZLU Prague, a.s., Czech Republic -c -c Author: Jaroslav Hajek <highegg@gmail.com> -c -c This file is part of Octave. -c -c Octave is free software; you can redistribute it and/or modify it -c under the terms of the GNU General Public License as published by -c the Free Software Foundation; either version 3 of the License, or -c (at your option) any later version. -c -c Octave is distributed in the hope that it will be useful, but -c WITHOUT ANY WARRANTY; without even the implied warranty of -c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -c GNU General Public License for more details. -c -c You should have received a copy of the GNU General Public License -c along with Octave; see the file COPYING. If not, see -c <http://www.gnu.org/licenses/>. -c - - subroutine zrsf2csf(n,t,u,c,s) - integer n - double complex t(n,n),u(n,n) - double precision c(n-1),s(n-1) - double precision x,y,z - integer j - do j = 1,n-1 - c(j) = 1 - end do - j = 1 - do while (j < n) -c apply previous rotations to rows - call zrcrot1(j,t(1,j),c,s) - - y = t(j+1,j) - if (y /= 0) then -c 2x2 block, form Givens rotation [c, i*s; i*s, c] - z = t(j,j+1) - c(j) = sqrt(z/(z-y)) - s(j) = sqrt(y/(y-z)) -c apply new rotation to t(j:j+1,j) - call zrcrot1(2,t(j,j),c(j),s(j)) -c apply all rotations to t(1:j+1,j+1) - call zrcrot1(j+1,t(1,j+1),c,s) -c apply new rotation to columns j,j+1 - call zrcrot2(j+1,t(1,j),t(1,j+1),c(j),s(j)) -c zero subdiagonal entry, skip next row - t(j+1,j) = 0 - j = j + 2 - else - j = j + 1 - end if - end do - -c apply rotations to last column if needed - if (j == n) then - call zrcrot1(j,t(1,j),c,s) - end if - -c apply stored rotations to all columns of u - do j = 1,n-1 - if (c(j) /= 1) then - call zrcrot2(n,u(1,j),u(1,j+1),c(j),s(j)) - end if - end do - - end subroutine - - subroutine zrcrot1(n,x,c,s) -c apply rotations to a column from the left - integer n - double complex x(n), t - double precision c(n-1),s(n-1) - integer i - do i = 1,n-1 - if (c(i) /= 1) then - t = x(i)*c(i) - x(i+1)*dcmplx(0,s(i)) - x(i+1) = x(i+1)*c(i) - x(i)*dcmplx(0,s(i)) - x(i) = t - endif - end do - end subroutine - - subroutine zrcrot2(n,x,y,c,s) -c apply a single rotation from the right to a pair of columns - integer n - double complex x(n),y(n),t - double precision c, s - integer i - do i = 1,n - t = x(i)*c + y(i)*dcmplx(0,s) - y(i) = y(i)*c + x(i)*dcmplx(0,s) - x(i) = t - end do - end subroutine
--- a/liboctave/cruft/module.mk Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,46 +0,0 @@ -nodist_liboctave_cruft_libcruft_la_SOURCES = - -liboctave_cruft_libcruft_la_FFLAGS = $(F77_INTEGER_8_FLAG) - -liboctave_cruft_libcruft_la_DEPENDENCIES = liboctave/cruft/cruft.def - -CRUFT_INC = - -CRUFT_SOURCES = - -include liboctave/cruft/amos/module.mk -include liboctave/cruft/blas-xtra/module.mk -include liboctave/cruft/daspk/module.mk -include liboctave/cruft/dasrt/module.mk -include liboctave/cruft/dassl/module.mk -include liboctave/cruft/Faddeeva/module.mk -include liboctave/cruft/fftpack/module.mk -include liboctave/cruft/lapack-xtra/module.mk -include liboctave/cruft/odepack/module.mk -include liboctave/cruft/ordered-qz/module.mk -include liboctave/cruft/quadpack/module.mk -include liboctave/cruft/ranlib/module.mk -include liboctave/cruft/slatec-err/module.mk -include liboctave/cruft/slatec-fn/module.mk - -liboctave/cruft/cruft.def: $(liboctave_cruft_libcruft_la_SOURCES) build-aux/mk-f77-def.sh - $(AM_V_GEN)rm -f $@-t $@ && \ - $(SHELL) build-aux/mk-f77-def.sh $(srcdir) $(liboctave_cruft_libcruft_la_SOURCES) > $@-t && \ - mv $@-t $@ - -liboctave_CLEANFILES += \ - liboctave/cruft/cruft.def \ - liboctave/cruft/ranlib/ranlib.def \ - $(nodist_liboctave_cruft_libcruft_la_SOURCES) - -noinst_LTLIBRARIES += liboctave/cruft/libcruft.la - -liboctave_cruft_libcruft_la_SOURCES = $(CRUFT_SOURCES) - -liboctave_cruft_libcruft_la_CPPFLAGS = $(liboctave_liboctave_la_CPPFLAGS) - -liboctave_cruft_libcruft_la_CFLAGS = $(liboctave_liboctave_la_CFLAGS) - -liboctave_cruft_libcruft_la_CXXFLAGS = $(liboctave_liboctave_la_CXXFLAGS) - -liboctave_liboctave_la_LIBADD += liboctave/cruft/libcruft.la
--- a/liboctave/cruft/odepack/cfode.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,112 +0,0 @@ - SUBROUTINE CFODE (METH, ELCO, TESCO) -CLLL. OPTIMIZE - INTEGER METH - INTEGER I, IB, NQ, NQM1, NQP1 - DOUBLE PRECISION ELCO, TESCO - DOUBLE PRECISION AGAMQ, FNQ, FNQM1, PC, PINT, RAGQ, - 1 RQFAC, RQ1FAC, TSIGN, XPIN - DIMENSION ELCO(13,12), TESCO(3,12) -C----------------------------------------------------------------------- -C CFODE IS CALLED BY THE INTEGRATOR ROUTINE TO SET COEFFICIENTS -C NEEDED THERE. THE COEFFICIENTS FOR THE CURRENT METHOD, AS -C GIVEN BY THE VALUE OF METH, ARE SET FOR ALL ORDERS AND SAVED. -C THE MAXIMUM ORDER ASSUMED HERE IS 12 IF METH = 1 AND 5 IF METH = 2. -C (A SMALLER VALUE OF THE MAXIMUM ORDER IS ALSO ALLOWED.) -C CFODE IS CALLED ONCE AT THE BEGINNING OF THE PROBLEM, -C AND IS NOT CALLED AGAIN UNLESS AND UNTIL METH IS CHANGED. -C -C THE ELCO ARRAY CONTAINS THE BASIC METHOD COEFFICIENTS. -C THE COEFFICIENTS EL(I), 1 .LE. I .LE. NQ+1, FOR THE METHOD OF -C ORDER NQ ARE STORED IN ELCO(I,NQ). THEY ARE GIVEN BY A GENETRATING -C POLYNOMIAL, I.E., -C L(X) = EL(1) + EL(2)*X + ... + EL(NQ+1)*X**NQ. -C FOR THE IMPLICIT ADAMS METHODS, L(X) IS GIVEN BY -C DL/DX = (X+1)*(X+2)*...*(X+NQ-1)/FACTORIAL(NQ-1), L(-1) = 0. -C FOR THE BDF METHODS, L(X) IS GIVEN BY -C L(X) = (X+1)*(X+2)* ... *(X+NQ)/K, -C WHERE K = FACTORIAL(NQ)*(1 + 1/2 + ... + 1/NQ). -C -C THE TESCO ARRAY CONTAINS TEST CONSTANTS USED FOR THE -C LOCAL ERROR TEST AND THE SELECTION OF STEP SIZE AND/OR ORDER. -C AT ORDER NQ, TESCO(K,NQ) IS USED FOR THE SELECTION OF STEP -C SIZE AT ORDER NQ - 1 IF K = 1, AT ORDER NQ IF K = 2, AND AT ORDER -C NQ + 1 IF K = 3. -C----------------------------------------------------------------------- - DIMENSION PC(12) -C - GO TO (100, 200), METH -C - 100 ELCO(1,1) = 1.0D0 - ELCO(2,1) = 1.0D0 - TESCO(1,1) = 0.0D0 - TESCO(2,1) = 2.0D0 - TESCO(1,2) = 1.0D0 - TESCO(3,12) = 0.0D0 - PC(1) = 1.0D0 - RQFAC = 1.0D0 - DO 140 NQ = 2,12 -C----------------------------------------------------------------------- -C THE PC ARRAY WILL CONTAIN THE COEFFICIENTS OF THE POLYNOMIAL -C P(X) = (X+1)*(X+2)*...*(X+NQ-1). -C INITIALLY, P(X) = 1. -C----------------------------------------------------------------------- - RQ1FAC = RQFAC - RQFAC = RQFAC/DBLE(NQ) - NQM1 = NQ - 1 - FNQM1 = DBLE(NQM1) - NQP1 = NQ + 1 -C FORM COEFFICIENTS OF P(X)*(X+NQ-1). ---------------------------------- - PC(NQ) = 0.0D0 - DO 110 IB = 1,NQM1 - I = NQP1 - IB - 110 PC(I) = PC(I-1) + FNQM1*PC(I) - PC(1) = FNQM1*PC(1) -C COMPUTE INTEGRAL, -1 TO 0, OF P(X) AND X*P(X). ----------------------- - PINT = PC(1) - XPIN = PC(1)/2.0D0 - TSIGN = 1.0D0 - DO 120 I = 2,NQ - TSIGN = -TSIGN - PINT = PINT + TSIGN*PC(I)/DBLE(I) - 120 XPIN = XPIN + TSIGN*PC(I)/DBLE(I+1) -C STORE COEFFICIENTS IN ELCO AND TESCO. -------------------------------- - ELCO(1,NQ) = PINT*RQ1FAC - ELCO(2,NQ) = 1.0D0 - DO 130 I = 2,NQ - 130 ELCO(I+1,NQ) = RQ1FAC*PC(I)/DBLE(I) - AGAMQ = RQFAC*XPIN - RAGQ = 1.0D0/AGAMQ - TESCO(2,NQ) = RAGQ - IF (NQ .LT. 12) TESCO(1,NQP1) = RAGQ*RQFAC/DBLE(NQP1) - TESCO(3,NQM1) = RAGQ - 140 CONTINUE - RETURN -C - 200 PC(1) = 1.0D0 - RQ1FAC = 1.0D0 - DO 230 NQ = 1,5 -C----------------------------------------------------------------------- -C THE PC ARRAY WILL CONTAIN THE COEFFICIENTS OF THE POLYNOMIAL -C P(X) = (X+1)*(X+2)*...*(X+NQ). -C INITIALLY, P(X) = 1. -C----------------------------------------------------------------------- - FNQ = DBLE(NQ) - NQP1 = NQ + 1 -C FORM COEFFICIENTS OF P(X)*(X+NQ). ------------------------------------ - PC(NQP1) = 0.0D0 - DO 210 IB = 1,NQ - I = NQ + 2 - IB - 210 PC(I) = PC(I-1) + FNQ*PC(I) - PC(1) = FNQ*PC(1) -C STORE COEFFICIENTS IN ELCO AND TESCO. -------------------------------- - DO 220 I = 1,NQP1 - 220 ELCO(I,NQ) = PC(I)/PC(2) - ELCO(2,NQ) = 1.0D0 - TESCO(1,NQ) = RQ1FAC - TESCO(2,NQ) = DBLE(NQP1)/ELCO(1,NQ) - TESCO(3,NQ) = DBLE(NQ+2)/ELCO(1,NQ) - RQ1FAC = RQ1FAC/FNQ - 230 CONTINUE - RETURN -C----------------------- END OF SUBROUTINE CFODE ----------------------- - END
--- a/liboctave/cruft/odepack/dlsode.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1525 +0,0 @@ - SUBROUTINE DLSODE (F, NEQ, Y, T, TOUT, ITOL, RTOL, ATOL, ITASK, - 1 ISTATE, IOPT, RWORK, LRW, IWORK, LIW, JAC, MF) - EXTERNAL F, JAC - INTEGER NEQ, ITOL, ITASK, ISTATE, IOPT, LRW, IWORK, LIW, MF - DOUBLE PRECISION Y, T, TOUT, RTOL, ATOL, RWORK - DIMENSION NEQ(*), Y(*), RTOL(*), ATOL(*), RWORK(LRW), IWORK(LIW) -C----------------------------------------------------------------------- -C THIS IS THE MARCH 30, 1987 VERSION OF -C LSODE.. LIVERMORE SOLVER FOR ORDINARY DIFFERENTIAL EQUATIONS. -C THIS VERSION IS IN DOUBLE PRECISION. -C -C LSODE SOLVES THE INITIAL VALUE PROBLEM FOR STIFF OR NONSTIFF -C SYSTEMS OF FIRST ORDER ODE-S, -C DY/DT = F(T,Y) , OR, IN COMPONENT FORM, -C DY(I)/DT = F(I) = F(I,T,Y(1),Y(2),...,Y(NEQ)) (I = 1,...,NEQ). -C LSODE IS A PACKAGE BASED ON THE GEAR AND GEARB PACKAGES, AND ON THE -C OCTOBER 23, 1978 VERSION OF THE TENTATIVE ODEPACK USER INTERFACE -C STANDARD, WITH MINOR MODIFICATIONS. -C----------------------------------------------------------------------- -C REFERENCE.. -C ALAN C. HINDMARSH, ODEPACK, A SYSTEMATIZED COLLECTION OF ODE -C SOLVERS, IN SCIENTIFIC COMPUTING, R. S. STEPLEMAN ET AL. (EDS.), -C NORTH-HOLLAND, AMSTERDAM, 1983, PP. 55-64. -C----------------------------------------------------------------------- -C AUTHOR AND CONTACT.. ALAN C. HINDMARSH, -C COMPUTING AND MATHEMATICS RESEARCH DIV., L-316 -C LAWRENCE LIVERMORE NATIONAL LABORATORY -C LIVERMORE, CA 94550. -C----------------------------------------------------------------------- -C SUMMARY OF USAGE. -C -C COMMUNICATION BETWEEN THE USER AND THE LSODE PACKAGE, FOR NORMAL -C SITUATIONS, IS SUMMARIZED HERE. THIS SUMMARY DESCRIBES ONLY A SUBSET -C OF THE FULL SET OF OPTIONS AVAILABLE. SEE THE FULL DESCRIPTION FOR -C DETAILS, INCLUDING OPTIONAL COMMUNICATION, NONSTANDARD OPTIONS, -C AND INSTRUCTIONS FOR SPECIAL SITUATIONS. SEE ALSO THE EXAMPLE -C PROBLEM (WITH PROGRAM AND OUTPUT) FOLLOWING THIS SUMMARY. -C -C A. FIRST PROVIDE A SUBROUTINE OF THE FORM.. -C SUBROUTINE F (NEQ, T, Y, YDOT, IERR) -C DIMENSION Y(NEQ), YDOT(NEQ) -C WHICH SUPPLIES THE VECTOR FUNCTION F BY LOADING YDOT(I) WITH F(I). -C -C B. NEXT DETERMINE (OR GUESS) WHETHER OR NOT THE PROBLEM IS STIFF. -C STIFFNESS OCCURS WHEN THE JACOBIAN MATRIX DF/DY HAS AN EIGENVALUE -C WHOSE REAL PART IS NEGATIVE AND LARGE IN MAGNITUDE, COMPARED TO THE -C RECIPROCAL OF THE T SPAN OF INTEREST. IF THE PROBLEM IS NONSTIFF, -C USE A METHOD FLAG MF = 10. IF IT IS STIFF, THERE ARE FOUR STANDARD -C CHOICES FOR MF, AND LSODE REQUIRES THE JACOBIAN MATRIX IN SOME FORM. -C THIS MATRIX IS REGARDED EITHER AS FULL (MF = 21 OR 22), -C OR BANDED (MF = 24 OR 25). IN THE BANDED CASE, LSODE REQUIRES TWO -C HALF-BANDWIDTH PARAMETERS ML AND MU. THESE ARE, RESPECTIVELY, THE -C WIDTHS OF THE LOWER AND UPPER PARTS OF THE BAND, EXCLUDING THE MAIN -C DIAGONAL. THUS THE BAND CONSISTS OF THE LOCATIONS (I,J) WITH -C I-ML .LE. J .LE. I+MU, AND THE FULL BANDWIDTH IS ML+MU+1. -C -C C. IF THE PROBLEM IS STIFF, YOU ARE ENCOURAGED TO SUPPLY THE JACOBIAN -C DIRECTLY (MF = 21 OR 24), BUT IF THIS IS NOT FEASIBLE, LSODE WILL -C COMPUTE IT INTERNALLY BY DIFFERENCE QUOTIENTS (MF = 22 OR 25). -C IF YOU ARE SUPPLYING THE JACOBIAN, PROVIDE A SUBROUTINE OF THE FORM.. -C SUBROUTINE JAC (NEQ, T, Y, ML, MU, PD, NROWPD) -C DIMENSION Y(NEQ), PD(NROWPD,NEQ) -C WHICH SUPPLIES DF/DY BY LOADING PD AS FOLLOWS.. -C FOR A FULL JACOBIAN (MF = 21), LOAD PD(I,J) WITH DF(I)/DY(J), -C THE PARTIAL DERIVATIVE OF F(I) WITH RESPECT TO Y(J). (IGNORE THE -C ML AND MU ARGUMENTS IN THIS CASE.) -C FOR A BANDED JACOBIAN (MF = 24), LOAD PD(I-J+MU+1,J) WITH -C DF(I)/DY(J), I.E. LOAD THE DIAGONAL LINES OF DF/DY INTO THE ROWS OF -C PD FROM THE TOP DOWN. -C IN EITHER CASE, ONLY NONZERO ELEMENTS NEED BE LOADED. -C -C D. WRITE A MAIN PROGRAM WHICH CALLS SUBROUTINE LSODE ONCE FOR -C EACH POINT AT WHICH ANSWERS ARE DESIRED. THIS SHOULD ALSO PROVIDE -C FOR POSSIBLE USE OF LOGICAL UNIT 6 FOR OUTPUT OF ERROR MESSAGES -C BY LSODE. ON THE FIRST CALL TO LSODE, SUPPLY ARGUMENTS AS FOLLOWS.. -C F = NAME OF SUBROUTINE FOR RIGHT-HAND SIDE VECTOR F. -C THIS NAME MUST BE DECLARED EXTERNAL IN CALLING PROGRAM. -C NEQ = NUMBER OF FIRST ORDER ODE-S. -C Y = ARRAY OF INITIAL VALUES, OF LENGTH NEQ. -C T = THE INITIAL VALUE OF THE INDEPENDENT VARIABLE. -C TOUT = FIRST POINT WHERE OUTPUT IS DESIRED (.NE. T). -C ITOL = 1 OR 2 ACCORDING AS ATOL (BELOW) IS A SCALAR OR ARRAY. -C RTOL = RELATIVE TOLERANCE PARAMETER (SCALAR). -C ATOL = ABSOLUTE TOLERANCE PARAMETER (SCALAR OR ARRAY). -C THE ESTIMATED LOCAL ERROR IN Y(I) WILL BE CONTROLLED SO AS -C TO BE ROUGHLY LESS (IN MAGNITUDE) THAN -C EWT(I) = RTOL*ABS(Y(I)) + ATOL IF ITOL = 1, OR -C EWT(I) = RTOL*ABS(Y(I)) + ATOL(I) IF ITOL = 2. -C THUS THE LOCAL ERROR TEST PASSES IF, IN EACH COMPONENT, -C EITHER THE ABSOLUTE ERROR IS LESS THAN ATOL (OR ATOL(I)), -C OR THE RELATIVE ERROR IS LESS THAN RTOL. -C USE RTOL = 0.0 FOR PURE ABSOLUTE ERROR CONTROL, AND -C USE ATOL = 0.0 (OR ATOL(I) = 0.0) FOR PURE RELATIVE ERROR -C CONTROL. CAUTION.. ACTUAL (GLOBAL) ERRORS MAY EXCEED THESE -C LOCAL TOLERANCES, SO CHOOSE THEM CONSERVATIVELY. -C ITASK = 1 FOR NORMAL COMPUTATION OF OUTPUT VALUES OF Y AT T = TOUT. -C ISTATE = INTEGER FLAG (INPUT AND OUTPUT). SET ISTATE = 1. -C IOPT = 0 TO INDICATE NO OPTIONAL INPUTS USED. -C RWORK = REAL WORK ARRAY OF LENGTH AT LEAST.. -C 20 + 16*NEQ FOR MF = 10, -C 22 + 9*NEQ + NEQ**2 FOR MF = 21 OR 22, -C 22 + 10*NEQ + (2*ML + MU)*NEQ FOR MF = 24 OR 25. -C LRW = DECLARED LENGTH OF RWORK (IN USER-S DIMENSION). -C IWORK = INTEGER WORK ARRAY OF LENGTH AT LEAST.. -C 20 FOR MF = 10, -C 20 + NEQ FOR MF = 21, 22, 24, OR 25. -C IF MF = 24 OR 25, INPUT IN IWORK(1),IWORK(2) THE LOWER -C AND UPPER HALF-BANDWIDTHS ML,MU. -C LIW = DECLARED LENGTH OF IWORK (IN USER-S DIMENSION). -C JAC = NAME OF SUBROUTINE FOR JACOBIAN MATRIX (MF = 21 OR 24). -C IF USED, THIS NAME MUST BE DECLARED EXTERNAL IN CALLING -C PROGRAM. IF NOT USED, PASS A DUMMY NAME. -C MF = METHOD FLAG. STANDARD VALUES ARE.. -C 10 FOR NONSTIFF (ADAMS) METHOD, NO JACOBIAN USED. -C 21 FOR STIFF (BDF) METHOD, USER-SUPPLIED FULL JACOBIAN. -C 22 FOR STIFF METHOD, INTERNALLY GENERATED FULL JACOBIAN. -C 24 FOR STIFF METHOD, USER-SUPPLIED BANDED JACOBIAN. -C 25 FOR STIFF METHOD, INTERNALLY GENERATED BANDED JACOBIAN. -C NOTE THAT THE MAIN PROGRAM MUST DECLARE ARRAYS Y, RWORK, IWORK, -C AND POSSIBLY ATOL. -C -C E. THE OUTPUT FROM THE FIRST CALL (OR ANY CALL) IS.. -C Y = ARRAY OF COMPUTED VALUES OF Y(T) VECTOR. -C T = CORRESPONDING VALUE OF INDEPENDENT VARIABLE (NORMALLY TOUT). -C ISTATE = 2 IF LSODE WAS SUCCESSFUL, NEGATIVE OTHERWISE. -C -1 MEANS EXCESS WORK DONE ON THIS CALL (PERHAPS WRONG MF). -C -2 MEANS EXCESS ACCURACY REQUESTED (TOLERANCES TOO SMALL). -C -3 MEANS ILLEGAL INPUT DETECTED (SEE PRINTED MESSAGE). -C -4 MEANS REPEATED ERROR TEST FAILURES (CHECK ALL INPUTS). -C -5 MEANS REPEATED CONVERGENCE FAILURES (PERHAPS BAD JACOBIAN -C SUPPLIED OR WRONG CHOICE OF MF OR TOLERANCES). -C -6 MEANS ERROR WEIGHT BECAME ZERO DURING PROBLEM. (SOLUTION -C COMPONENT I VANISHED, AND ATOL OR ATOL(I) = 0.) -C -13 MEANS EXIT REQUESTED IN USER-SUPPLIED FUNCTION. -C -C F. TO CONTINUE THE INTEGRATION AFTER A SUCCESSFUL RETURN, SIMPLY -C RESET TOUT AND CALL LSODE AGAIN. NO OTHER PARAMETERS NEED BE RESET. -C -C----------------------------------------------------------------------- -C EXAMPLE PROBLEM. -C -C THE FOLLOWING IS A SIMPLE EXAMPLE PROBLEM, WITH THE CODING -C NEEDED FOR ITS SOLUTION BY LSODE. THE PROBLEM IS FROM CHEMICAL -C KINETICS, AND CONSISTS OF THE FOLLOWING THREE RATE EQUATIONS.. -C DY1/DT = -.04*Y1 + 1.E4*Y2*Y3 -C DY2/DT = .04*Y1 - 1.E4*Y2*Y3 - 3.E7*Y2**2 -C DY3/DT = 3.E7*Y2**2 -C ON THE INTERVAL FROM T = 0.0 TO T = 4.E10, WITH INITIAL CONDITIONS -C Y1 = 1.0, Y2 = Y3 = 0. THE PROBLEM IS STIFF. -C -C THE FOLLOWING CODING SOLVES THIS PROBLEM WITH LSODE, USING MF = 21 -C AND PRINTING RESULTS AT T = .4, 4., ..., 4.E10. IT USES -C ITOL = 2 AND ATOL MUCH SMALLER FOR Y2 THAN Y1 OR Y3 BECAUSE -C Y2 HAS MUCH SMALLER VALUES. -C AT THE END OF THE RUN, STATISTICAL QUANTITIES OF INTEREST ARE -C PRINTED (SEE OPTIONAL OUTPUTS IN THE FULL DESCRIPTION BELOW). -C -C EXTERNAL FEX, JEX -C DOUBLE PRECISION ATOL, RTOL, RWORK, T, TOUT, Y -C DIMENSION Y(3), ATOL(3), RWORK(58), IWORK(23) -C NEQ = 3 -C Y(1) = 1.D0 -C Y(2) = 0.D0 -C Y(3) = 0.D0 -C T = 0.D0 -C TOUT = .4D0 -C ITOL = 2 -C RTOL = 1.D-4 -C ATOL(1) = 1.D-6 -C ATOL(2) = 1.D-10 -C ATOL(3) = 1.D-6 -C ITASK = 1 -C ISTATE = 1 -C IOPT = 0 -C LRW = 58 -C LIW = 23 -C MF = 21 -C DO 40 IOUT = 1,12 -C CALL LSODE(FEX,NEQ,Y,T,TOUT,ITOL,RTOL,ATOL,ITASK,ISTATE, -C 1 IOPT,RWORK,LRW,IWORK,LIW,JEX,MF) -C WRITE(6,20)T,Y(1),Y(2),Y(3) -C 20 FORMAT(7H AT T =,E12.4,6H Y =,3E14.6) -C IF (ISTATE .LT. 0) GO TO 80 -C 40 TOUT = TOUT*10.D0 -C WRITE(6,60)IWORK(11),IWORK(12),IWORK(13) -C 60 FORMAT(/12H NO. STEPS =,I4,11H NO. F-S =,I4,11H NO. J-S =,I4) -C STOP -C 80 WRITE(6,90)ISTATE -C 90 FORMAT(///22H ERROR HALT.. ISTATE =,I3) -C STOP -C END -C -C SUBROUTINE FEX (NEQ, T, Y, YDOT) -C DOUBLE PRECISION T, Y, YDOT -C DIMENSION Y(3), YDOT(3) -C YDOT(1) = -.04D0*Y(1) + 1.D4*Y(2)*Y(3) -C YDOT(3) = 3.D7*Y(2)*Y(2) -C YDOT(2) = -YDOT(1) - YDOT(3) -C RETURN -C END -C -C SUBROUTINE JEX (NEQ, T, Y, ML, MU, PD, NRPD) -C DOUBLE PRECISION PD, T, Y -C DIMENSION Y(3), PD(NRPD,3) -C PD(1,1) = -.04D0 -C PD(1,2) = 1.D4*Y(3) -C PD(1,3) = 1.D4*Y(2) -C PD(2,1) = .04D0 -C PD(2,3) = -PD(1,3) -C PD(3,2) = 6.D7*Y(2) -C PD(2,2) = -PD(1,2) - PD(3,2) -C RETURN -C END -C -C THE OUTPUT OF THIS PROGRAM (ON A CDC-7600 IN SINGLE PRECISION) -C IS AS FOLLOWS.. -C -C AT T = 4.0000E-01 Y = 9.851726E-01 3.386406E-05 1.479357E-02 -C AT T = 4.0000E+00 Y = 9.055142E-01 2.240418E-05 9.446344E-02 -C AT T = 4.0000E+01 Y = 7.158050E-01 9.184616E-06 2.841858E-01 -C AT T = 4.0000E+02 Y = 4.504846E-01 3.222434E-06 5.495122E-01 -C AT T = 4.0000E+03 Y = 1.831701E-01 8.940379E-07 8.168290E-01 -C AT T = 4.0000E+04 Y = 3.897016E-02 1.621193E-07 9.610297E-01 -C AT T = 4.0000E+05 Y = 4.935213E-03 1.983756E-08 9.950648E-01 -C AT T = 4.0000E+06 Y = 5.159269E-04 2.064759E-09 9.994841E-01 -C AT T = 4.0000E+07 Y = 5.306413E-05 2.122677E-10 9.999469E-01 -C AT T = 4.0000E+08 Y = 5.494529E-06 2.197824E-11 9.999945E-01 -C AT T = 4.0000E+09 Y = 5.129458E-07 2.051784E-12 9.999995E-01 -C AT T = 4.0000E+10 Y = -7.170586E-08 -2.868234E-13 1.000000E+00 -C -C NO. STEPS = 330 NO. F-S = 405 NO. J-S = 69 -C----------------------------------------------------------------------- -C FULL DESCRIPTION OF USER INTERFACE TO LSODE. -C -C THE USER INTERFACE TO LSODE CONSISTS OF THE FOLLOWING PARTS. -C -C I. THE CALL SEQUENCE TO SUBROUTINE LSODE, WHICH IS A DRIVER -C ROUTINE FOR THE SOLVER. THIS INCLUDES DESCRIPTIONS OF BOTH -C THE CALL SEQUENCE ARGUMENTS AND OF USER-SUPPLIED ROUTINES. -C FOLLOWING THESE DESCRIPTIONS IS A DESCRIPTION OF -C OPTIONAL INPUTS AVAILABLE THROUGH THE CALL SEQUENCE, AND THEN -C A DESCRIPTION OF OPTIONAL OUTPUTS (IN THE WORK ARRAYS). -C -C II. DESCRIPTIONS OF OTHER ROUTINES IN THE LSODE PACKAGE THAT MAY BE -C (OPTIONALLY) CALLED BY THE USER. THESE PROVIDE THE ABILITY TO -C ALTER ERROR MESSAGE HANDLING, SAVE AND RESTORE THE INTERNAL -C COMMON, AND OBTAIN SPECIFIED DERIVATIVES OF THE SOLUTION Y(T). -C -C III. DESCRIPTIONS OF COMMON BLOCKS TO BE DECLARED IN OVERLAY -C OR SIMILAR ENVIRONMENTS, OR TO BE SAVED WHEN DOING AN INTERRUPT -C OF THE PROBLEM AND CONTINUED SOLUTION LATER. -C -C IV. DESCRIPTION OF TWO ROUTINES IN THE LSODE PACKAGE, EITHER OF -C WHICH THE USER MAY REPLACE WITH HIS OWN VERSION, IF DESIRED. -C THESE RELATE TO THE MEASUREMENT OF ERRORS. -C -C----------------------------------------------------------------------- -C PART I. CALL SEQUENCE. -C -C THE CALL SEQUENCE PARAMETERS USED FOR INPUT ONLY ARE -C F, NEQ, TOUT, ITOL, RTOL, ATOL, ITASK, IOPT, LRW, LIW, JAC, MF, -C AND THOSE USED FOR BOTH INPUT AND OUTPUT ARE -C Y, T, ISTATE. -C THE WORK ARRAYS RWORK AND IWORK ARE ALSO USED FOR CONDITIONAL AND -C OPTIONAL INPUTS AND OPTIONAL OUTPUTS. (THE TERM OUTPUT HERE REFERS -C TO THE RETURN FROM SUBROUTINE LSODE TO THE USER-S CALLING PROGRAM.) -C -C THE LEGALITY OF INPUT PARAMETERS WILL BE THOROUGHLY CHECKED ON THE -C INITIAL CALL FOR THE PROBLEM, BUT NOT CHECKED THEREAFTER UNLESS A -C CHANGE IN INPUT PARAMETERS IS FLAGGED BY ISTATE = 3 ON INPUT. -C -C THE DESCRIPTIONS OF THE CALL ARGUMENTS ARE AS FOLLOWS. -C -C F = THE NAME OF THE USER-SUPPLIED SUBROUTINE DEFINING THE -C ODE SYSTEM. THE SYSTEM MUST BE PUT IN THE FIRST-ORDER -C FORM DY/DT = F(T,Y), WHERE F IS A VECTOR-VALUED FUNCTION -C OF THE SCALAR T AND THE VECTOR Y. SUBROUTINE F IS TO -C COMPUTE THE FUNCTION F. IT IS TO HAVE THE FORM -C SUBROUTINE F (NEQ, T, Y, YDOT) -C DIMENSION Y(1), YDOT(1) -C WHERE NEQ, T, AND Y ARE INPUT, AND THE ARRAY YDOT = F(T,Y) -C IS OUTPUT. Y AND YDOT ARE ARRAYS OF LENGTH NEQ. -C (IN THE DIMENSION STATEMENT ABOVE, 1 IS A DUMMY -C DIMENSION.. IT CAN BE REPLACED BY ANY VALUE.) -C SUBROUTINE F SHOULD NOT ALTER Y(1),...,Y(NEQ). -C F MUST BE DECLARED EXTERNAL IN THE CALLING PROGRAM. -C -C SUBROUTINE F MAY ACCESS USER-DEFINED QUANTITIES IN -C NEQ(2),... AND/OR IN Y(NEQ(1)+1),... IF NEQ IS AN ARRAY -C (DIMENSIONED IN F) AND/OR Y HAS LENGTH EXCEEDING NEQ(1). -C SEE THE DESCRIPTIONS OF NEQ AND Y BELOW. -C -C IF QUANTITIES COMPUTED IN THE F ROUTINE ARE NEEDED -C EXTERNALLY TO LSODE, AN EXTRA CALL TO F SHOULD BE MADE -C FOR THIS PURPOSE, FOR CONSISTENT AND ACCURATE RESULTS. -C IF ONLY THE DERIVATIVE DY/DT IS NEEDED, USE INTDY INSTEAD. -C -C NEQ = THE SIZE OF THE ODE SYSTEM (NUMBER OF FIRST ORDER -C ORDINARY DIFFERENTIAL EQUATIONS). USED ONLY FOR INPUT. -C NEQ MAY BE DECREASED, BUT NOT INCREASED, DURING THE PROBLEM. -C IF NEQ IS DECREASED (WITH ISTATE = 3 ON INPUT), THE -C REMAINING COMPONENTS OF Y SHOULD BE LEFT UNDISTURBED, IF -C THESE ARE TO BE ACCESSED IN F AND/OR JAC. -C -C NORMALLY, NEQ IS A SCALAR, AND IT IS GENERALLY REFERRED TO -C AS A SCALAR IN THIS USER INTERFACE DESCRIPTION. HOWEVER, -C NEQ MAY BE AN ARRAY, WITH NEQ(1) SET TO THE SYSTEM SIZE. -C (THE LSODE PACKAGE ACCESSES ONLY NEQ(1).) IN EITHER CASE, -C THIS PARAMETER IS PASSED AS THE NEQ ARGUMENT IN ALL CALLS -C TO F AND JAC. HENCE, IF IT IS AN ARRAY, LOCATIONS -C NEQ(2),... MAY BE USED TO STORE OTHER INTEGER DATA AND PASS -C IT TO F AND/OR JAC. SUBROUTINES F AND/OR JAC MUST INCLUDE -C NEQ IN A DIMENSION STATEMENT IN THAT CASE. -C -C Y = A REAL ARRAY FOR THE VECTOR OF DEPENDENT VARIABLES, OF -C LENGTH NEQ OR MORE. USED FOR BOTH INPUT AND OUTPUT ON THE -C FIRST CALL (ISTATE = 1), AND ONLY FOR OUTPUT ON OTHER CALLS. -C ON THE FIRST CALL, Y MUST CONTAIN THE VECTOR OF INITIAL -C VALUES. ON OUTPUT, Y CONTAINS THE COMPUTED SOLUTION VECTOR, -C EVALUATED AT T. IF DESIRED, THE Y ARRAY MAY BE USED -C FOR OTHER PURPOSES BETWEEN CALLS TO THE SOLVER. -C -C THIS ARRAY IS PASSED AS THE Y ARGUMENT IN ALL CALLS TO -C F AND JAC. HENCE ITS LENGTH MAY EXCEED NEQ, AND LOCATIONS -C Y(NEQ+1),... MAY BE USED TO STORE OTHER REAL DATA AND -C PASS IT TO F AND/OR JAC. (THE LSODE PACKAGE ACCESSES ONLY -C Y(1),...,Y(NEQ).) -C -C T = THE INDEPENDENT VARIABLE. ON INPUT, T IS USED ONLY ON THE -C FIRST CALL, AS THE INITIAL POINT OF THE INTEGRATION. -C ON OUTPUT, AFTER EACH CALL, T IS THE VALUE AT WHICH A -C COMPUTED SOLUTION Y IS EVALUATED (USUALLY THE SAME AS TOUT). -C ON AN ERROR RETURN, T IS THE FARTHEST POINT REACHED. -C -C TOUT = THE NEXT VALUE OF T AT WHICH A COMPUTED SOLUTION IS DESIRED. -C USED ONLY FOR INPUT. -C -C WHEN STARTING THE PROBLEM (ISTATE = 1), TOUT MAY BE EQUAL -C TO T FOR ONE CALL, THEN SHOULD .NE. T FOR THE NEXT CALL. -C FOR THE INITIAL T, AN INPUT VALUE OF TOUT .NE. T IS USED -C IN ORDER TO DETERMINE THE DIRECTION OF THE INTEGRATION -C (I.E. THE ALGEBRAIC SIGN OF THE STEP SIZES) AND THE ROUGH -C SCALE OF THE PROBLEM. INTEGRATION IN EITHER DIRECTION -C (FORWARD OR BACKWARD IN T) IS PERMITTED. -C -C IF ITASK = 2 OR 5 (ONE-STEP MODES), TOUT IS IGNORED AFTER -C THE FIRST CALL (I.E. THE FIRST CALL WITH TOUT .NE. T). -C OTHERWISE, TOUT IS REQUIRED ON EVERY CALL. -C -C IF ITASK = 1, 3, OR 4, THE VALUES OF TOUT NEED NOT BE -C MONOTONE, BUT A VALUE OF TOUT WHICH BACKS UP IS LIMITED -C TO THE CURRENT INTERNAL T INTERVAL, WHOSE ENDPOINTS ARE -C TCUR - HU AND TCUR (SEE OPTIONAL OUTPUTS, BELOW, FOR -C TCUR AND HU). -C -C ITOL = AN INDICATOR FOR THE TYPE OF ERROR CONTROL. SEE -C DESCRIPTION BELOW UNDER ATOL. USED ONLY FOR INPUT. -C -C RTOL = A RELATIVE ERROR TOLERANCE PARAMETER, EITHER A SCALAR OR -C AN ARRAY OF LENGTH NEQ. SEE DESCRIPTION BELOW UNDER ATOL. -C INPUT ONLY. -C -C ATOL = AN ABSOLUTE ERROR TOLERANCE PARAMETER, EITHER A SCALAR OR -C AN ARRAY OF LENGTH NEQ. INPUT ONLY. -C -C THE INPUT PARAMETERS ITOL, RTOL, AND ATOL DETERMINE -C THE ERROR CONTROL PERFORMED BY THE SOLVER. THE SOLVER WILL -C CONTROL THE VECTOR E = (E(I)) OF ESTIMATED LOCAL ERRORS -C IN Y, ACCORDING TO AN INEQUALITY OF THE FORM -C RMS-NORM OF ( E(I)/EWT(I) ) .LE. 1, -C WHERE EWT(I) = RTOL(I)*ABS(Y(I)) + ATOL(I), -C AND THE RMS-NORM (ROOT-MEAN-SQUARE NORM) HERE IS -C RMS-NORM(V) = SQRT(SUM V(I)**2 / NEQ). HERE EWT = (EWT(I)) -C IS A VECTOR OF WEIGHTS WHICH MUST ALWAYS BE POSITIVE, AND -C THE VALUES OF RTOL AND ATOL SHOULD ALL BE NON-NEGATIVE. -C THE FOLLOWING TABLE GIVES THE TYPES (SCALAR/ARRAY) OF -C RTOL AND ATOL, AND THE CORRESPONDING FORM OF EWT(I). -C -C ITOL RTOL ATOL EWT(I) -C 1 SCALAR SCALAR RTOL*ABS(Y(I)) + ATOL -C 2 SCALAR ARRAY RTOL*ABS(Y(I)) + ATOL(I) -C 3 ARRAY SCALAR RTOL(I)*ABS(Y(I)) + ATOL -C 4 ARRAY ARRAY RTOL(I)*ABS(Y(I)) + ATOL(I) -C -C WHEN EITHER OF THESE PARAMETERS IS A SCALAR, IT NEED NOT -C BE DIMENSIONED IN THE USER-S CALLING PROGRAM. -C -C IF NONE OF THE ABOVE CHOICES (WITH ITOL, RTOL, AND ATOL -C FIXED THROUGHOUT THE PROBLEM) IS SUITABLE, MORE GENERAL -C ERROR CONTROLS CAN BE OBTAINED BY SUBSTITUTING -C USER-SUPPLIED ROUTINES FOR THE SETTING OF EWT AND/OR FOR -C THE NORM CALCULATION. SEE PART IV BELOW. -C -C IF GLOBAL ERRORS ARE TO BE ESTIMATED BY MAKING A REPEATED -C RUN ON THE SAME PROBLEM WITH SMALLER TOLERANCES, THEN ALL -C COMPONENTS OF RTOL AND ATOL (I.E. OF EWT) SHOULD BE SCALED -C DOWN UNIFORMLY. -C -C ITASK = AN INDEX SPECIFYING THE TASK TO BE PERFORMED. -C INPUT ONLY. ITASK HAS THE FOLLOWING VALUES AND MEANINGS. -C 1 MEANS NORMAL COMPUTATION OF OUTPUT VALUES OF Y(T) AT -C T = TOUT (BY OVERSHOOTING AND INTERPOLATING). -C 2 MEANS TAKE ONE STEP ONLY AND RETURN. -C 3 MEANS STOP AT THE FIRST INTERNAL MESH POINT AT OR -C BEYOND T = TOUT AND RETURN. -C 4 MEANS NORMAL COMPUTATION OF OUTPUT VALUES OF Y(T) AT -C T = TOUT BUT WITHOUT OVERSHOOTING T = TCRIT. -C TCRIT MUST BE INPUT AS RWORK(1). TCRIT MAY BE EQUAL TO -C OR BEYOND TOUT, BUT NOT BEHIND IT IN THE DIRECTION OF -C INTEGRATION. THIS OPTION IS USEFUL IF THE PROBLEM -C HAS A SINGULARITY AT OR BEYOND T = TCRIT. -C 5 MEANS TAKE ONE STEP, WITHOUT PASSING TCRIT, AND RETURN. -C TCRIT MUST BE INPUT AS RWORK(1). -C -C NOTE.. IF ITASK = 4 OR 5 AND THE SOLVER REACHES TCRIT -C (WITHIN ROUNDOFF), IT WILL RETURN T = TCRIT (EXACTLY) TO -C INDICATE THIS (UNLESS ITASK = 4 AND TOUT COMES BEFORE TCRIT, -C IN WHICH CASE ANSWERS AT T = TOUT ARE RETURNED FIRST). -C -C ISTATE = AN INDEX USED FOR INPUT AND OUTPUT TO SPECIFY THE -C THE STATE OF THE CALCULATION. -C -C ON INPUT, THE VALUES OF ISTATE ARE AS FOLLOWS. -C 1 MEANS THIS IS THE FIRST CALL FOR THE PROBLEM -C (INITIALIZATIONS WILL BE DONE). SEE NOTE BELOW. -C 2 MEANS THIS IS NOT THE FIRST CALL, AND THE CALCULATION -C IS TO CONTINUE NORMALLY, WITH NO CHANGE IN ANY INPUT -C PARAMETERS EXCEPT POSSIBLY TOUT AND ITASK. -C (IF ITOL, RTOL, AND/OR ATOL ARE CHANGED BETWEEN CALLS -C WITH ISTATE = 2, THE NEW VALUES WILL BE USED BUT NOT -C TESTED FOR LEGALITY.) -C 3 MEANS THIS IS NOT THE FIRST CALL, AND THE -C CALCULATION IS TO CONTINUE NORMALLY, BUT WITH -C A CHANGE IN INPUT PARAMETERS OTHER THAN -C TOUT AND ITASK. CHANGES ARE ALLOWED IN -C NEQ, ITOL, RTOL, ATOL, IOPT, LRW, LIW, MF, ML, MU, -C AND ANY OF THE OPTIONAL INPUTS EXCEPT H0. -C (SEE IWORK DESCRIPTION FOR ML AND MU.) -C NOTE.. A PRELIMINARY CALL WITH TOUT = T IS NOT COUNTED -C AS A FIRST CALL HERE, AS NO INITIALIZATION OR CHECKING OF -C INPUT IS DONE. (SUCH A CALL IS SOMETIMES USEFUL FOR THE -C PURPOSE OF OUTPUTTING THE INITIAL CONDITIONS.) -C THUS THE FIRST CALL FOR WHICH TOUT .NE. T REQUIRES -C ISTATE = 1 ON INPUT. -C -C ON OUTPUT, ISTATE HAS THE FOLLOWING VALUES AND MEANINGS. -C 1 MEANS NOTHING WAS DONE, AS TOUT WAS EQUAL TO T WITH -C ISTATE = 1 ON INPUT. (HOWEVER, AN INTERNAL COUNTER WAS -C SET TO DETECT AND PREVENT REPEATED CALLS OF THIS TYPE.) -C 2 MEANS THE INTEGRATION WAS PERFORMED SUCCESSFULLY. -C -1 MEANS AN EXCESSIVE AMOUNT OF WORK (MORE THAN MXSTEP -C STEPS) WAS DONE ON THIS CALL, BEFORE COMPLETING THE -C REQUESTED TASK, BUT THE INTEGRATION WAS OTHERWISE -C SUCCESSFUL AS FAR AS T. (MXSTEP IS AN OPTIONAL INPUT -C AND IS NORMALLY 500.) TO CONTINUE, THE USER MAY -C SIMPLY RESET ISTATE TO A VALUE .GT. 1 AND CALL AGAIN -C (THE EXCESS WORK STEP COUNTER WILL BE RESET TO 0). -C IN ADDITION, THE USER MAY INCREASE MXSTEP TO AVOID -C THIS ERROR RETURN (SEE BELOW ON OPTIONAL INPUTS). -C -2 MEANS TOO MUCH ACCURACY WAS REQUESTED FOR THE PRECISION -C OF THE MACHINE BEING USED. THIS WAS DETECTED BEFORE -C COMPLETING THE REQUESTED TASK, BUT THE INTEGRATION -C WAS SUCCESSFUL AS FAR AS T. TO CONTINUE, THE TOLERANCE -C PARAMETERS MUST BE RESET, AND ISTATE MUST BE SET -C TO 3. THE OPTIONAL OUTPUT TOLSF MAY BE USED FOR THIS -C PURPOSE. (NOTE.. IF THIS CONDITION IS DETECTED BEFORE -C TAKING ANY STEPS, THEN AN ILLEGAL INPUT RETURN -C (ISTATE = -3) OCCURS INSTEAD.) -C -3 MEANS ILLEGAL INPUT WAS DETECTED, BEFORE TAKING ANY -C INTEGRATION STEPS. SEE WRITTEN MESSAGE FOR DETAILS. -C NOTE.. IF THE SOLVER DETECTS AN INFINITE LOOP OF CALLS -C TO THE SOLVER WITH ILLEGAL INPUT, IT WILL CAUSE -C THE RUN TO STOP. -C -4 MEANS THERE WERE REPEATED ERROR TEST FAILURES ON -C ONE ATTEMPTED STEP, BEFORE COMPLETING THE REQUESTED -C TASK, BUT THE INTEGRATION WAS SUCCESSFUL AS FAR AS T. -C THE PROBLEM MAY HAVE A SINGULARITY, OR THE INPUT -C MAY BE INAPPROPRIATE. -C -5 MEANS THERE WERE REPEATED CONVERGENCE TEST FAILURES ON -C ONE ATTEMPTED STEP, BEFORE COMPLETING THE REQUESTED -C TASK, BUT THE INTEGRATION WAS SUCCESSFUL AS FAR AS T. -C THIS MAY BE CAUSED BY AN INACCURATE JACOBIAN MATRIX, -C IF ONE IS BEING USED. -C -6 MEANS EWT(I) BECAME ZERO FOR SOME I DURING THE -C INTEGRATION. PURE RELATIVE ERROR CONTROL (ATOL(I)=0.0) -C WAS REQUESTED ON A VARIABLE WHICH HAS NOW VANISHED. -C THE INTEGRATION WAS SUCCESSFUL AS FAR AS T. -C -C NOTE.. SINCE THE NORMAL OUTPUT VALUE OF ISTATE IS 2, -C IT DOES NOT NEED TO BE RESET FOR NORMAL CONTINUATION. -C ALSO, SINCE A NEGATIVE INPUT VALUE OF ISTATE WILL BE -C REGARDED AS ILLEGAL, A NEGATIVE OUTPUT VALUE REQUIRES THE -C USER TO CHANGE IT, AND POSSIBLY OTHER INPUTS, BEFORE -C CALLING THE SOLVER AGAIN. -C -C IOPT = AN INTEGER FLAG TO SPECIFY WHETHER OR NOT ANY OPTIONAL -C INPUTS ARE BEING USED ON THIS CALL. INPUT ONLY. -C THE OPTIONAL INPUTS ARE LISTED SEPARATELY BELOW. -C IOPT = 0 MEANS NO OPTIONAL INPUTS ARE BEING USED. -C DEFAULT VALUES WILL BE USED IN ALL CASES. -C IOPT = 1 MEANS ONE OR MORE OPTIONAL INPUTS ARE BEING USED. -C -C RWORK = A REAL WORKING ARRAY (DOUBLE PRECISION). -C THE LENGTH OF RWORK MUST BE AT LEAST -C 20 + NYH*(MAXORD + 1) + 3*NEQ + LWM WHERE -C NYH = THE INITIAL VALUE OF NEQ, -C MAXORD = 12 (IF METH = 1) OR 5 (IF METH = 2) (UNLESS A -C SMALLER VALUE IS GIVEN AS AN OPTIONAL INPUT), -C LWM = 0 IF MITER = 0, -C LWM = NEQ**2 + 2 IF MITER IS 1 OR 2, -C LWM = NEQ + 2 IF MITER = 3, AND -C LWM = (2*ML+MU+1)*NEQ + 2 IF MITER IS 4 OR 5. -C (SEE THE MF DESCRIPTION FOR METH AND MITER.) -C THUS IF MAXORD HAS ITS DEFAULT VALUE AND NEQ IS CONSTANT, -C THIS LENGTH IS.. -C 20 + 16*NEQ FOR MF = 10, -C 22 + 16*NEQ + NEQ**2 FOR MF = 11 OR 12, -C 22 + 17*NEQ FOR MF = 13, -C 22 + 17*NEQ + (2*ML+MU)*NEQ FOR MF = 14 OR 15, -C 20 + 9*NEQ FOR MF = 20, -C 22 + 9*NEQ + NEQ**2 FOR MF = 21 OR 22, -C 22 + 10*NEQ FOR MF = 23, -C 22 + 10*NEQ + (2*ML+MU)*NEQ FOR MF = 24 OR 25. -C THE FIRST 20 WORDS OF RWORK ARE RESERVED FOR CONDITIONAL -C AND OPTIONAL INPUTS AND OPTIONAL OUTPUTS. -C -C THE FOLLOWING WORD IN RWORK IS A CONDITIONAL INPUT.. -C RWORK(1) = TCRIT = CRITICAL VALUE OF T WHICH THE SOLVER -C IS NOT TO OVERSHOOT. REQUIRED IF ITASK IS -C 4 OR 5, AND IGNORED OTHERWISE. (SEE ITASK.) -C -C LRW = THE LENGTH OF THE ARRAY RWORK, AS DECLARED BY THE USER. -C (THIS WILL BE CHECKED BY THE SOLVER.) -C -C IWORK = AN INTEGER WORK ARRAY. THE LENGTH OF IWORK MUST BE AT LEAST -C 20 IF MITER = 0 OR 3 (MF = 10, 13, 20, 23), OR -C 20 + NEQ OTHERWISE (MF = 11, 12, 14, 15, 21, 22, 24, 25). -C THE FIRST FEW WORDS OF IWORK ARE USED FOR CONDITIONAL AND -C OPTIONAL INPUTS AND OPTIONAL OUTPUTS. -C -C THE FOLLOWING 2 WORDS IN IWORK ARE CONDITIONAL INPUTS.. -C IWORK(1) = ML THESE ARE THE LOWER AND UPPER -C IWORK(2) = MU HALF-BANDWIDTHS, RESPECTIVELY, OF THE -C BANDED JACOBIAN, EXCLUDING THE MAIN DIAGONAL. -C THE BAND IS DEFINED BY THE MATRIX LOCATIONS -C (I,J) WITH I-ML .LE. J .LE. I+MU. ML AND MU -C MUST SATISFY 0 .LE. ML,MU .LE. NEQ-1. -C THESE ARE REQUIRED IF MITER IS 4 OR 5, AND -C IGNORED OTHERWISE. ML AND MU MAY IN FACT BE -C THE BAND PARAMETERS FOR A MATRIX TO WHICH -C DF/DY IS ONLY APPROXIMATELY EQUAL. -C -C LIW = THE LENGTH OF THE ARRAY IWORK, AS DECLARED BY THE USER. -C (THIS WILL BE CHECKED BY THE SOLVER.) -C -C NOTE.. THE WORK ARRAYS MUST NOT BE ALTERED BETWEEN CALLS TO LSODE -C FOR THE SAME PROBLEM, EXCEPT POSSIBLY FOR THE CONDITIONAL AND -C OPTIONAL INPUTS, AND EXCEPT FOR THE LAST 3*NEQ WORDS OF RWORK. -C THE LATTER SPACE IS USED FOR INTERNAL SCRATCH SPACE, AND SO IS -C AVAILABLE FOR USE BY THE USER OUTSIDE LSODE BETWEEN CALLS, IF -C DESIRED (BUT NOT FOR USE BY F OR JAC). -C -C JAC = THE NAME OF THE USER-SUPPLIED ROUTINE (MITER = 1 OR 4) TO -C COMPUTE THE JACOBIAN MATRIX, DF/DY, AS A FUNCTION OF -C THE SCALAR T AND THE VECTOR Y. IT IS TO HAVE THE FORM -C SUBROUTINE JAC (NEQ, T, Y, ML, MU, PD, NROWPD) -C DIMENSION Y(1), PD(NROWPD,1) -C WHERE NEQ, T, Y, ML, MU, AND NROWPD ARE INPUT AND THE ARRAY -C PD IS TO BE LOADED WITH PARTIAL DERIVATIVES (ELEMENTS OF -C THE JACOBIAN MATRIX) ON OUTPUT. PD MUST BE GIVEN A FIRST -C DIMENSION OF NROWPD. T AND Y HAVE THE SAME MEANING AS IN -C SUBROUTINE F. (IN THE DIMENSION STATEMENT ABOVE, 1 IS A -C DUMMY DIMENSION.. IT CAN BE REPLACED BY ANY VALUE.) -C IN THE FULL MATRIX CASE (MITER = 1), ML AND MU ARE -C IGNORED, AND THE JACOBIAN IS TO BE LOADED INTO PD IN -C COLUMNWISE MANNER, WITH DF(I)/DY(J) LOADED INTO PD(I,J). -C IN THE BAND MATRIX CASE (MITER = 4), THE ELEMENTS -C WITHIN THE BAND ARE TO BE LOADED INTO PD IN COLUMNWISE -C MANNER, WITH DIAGONAL LINES OF DF/DY LOADED INTO THE ROWS -C OF PD. THUS DF(I)/DY(J) IS TO BE LOADED INTO PD(I-J+MU+1,J). -C ML AND MU ARE THE HALF-BANDWIDTH PARAMETERS (SEE IWORK). -C THE LOCATIONS IN PD IN THE TWO TRIANGULAR AREAS WHICH -C CORRESPOND TO NONEXISTENT MATRIX ELEMENTS CAN BE IGNORED -C OR LOADED ARBITRARILY, AS THEY ARE OVERWRITTEN BY LSODE. -C JAC NEED NOT PROVIDE DF/DY EXACTLY. A CRUDE -C APPROXIMATION (POSSIBLY WITH A SMALLER BANDWIDTH) WILL DO. -C IN EITHER CASE, PD IS PRESET TO ZERO BY THE SOLVER, -C SO THAT ONLY THE NONZERO ELEMENTS NEED BE LOADED BY JAC. -C EACH CALL TO JAC IS PRECEDED BY A CALL TO F WITH THE SAME -C ARGUMENTS NEQ, T, AND Y. THUS TO GAIN SOME EFFICIENCY, -C INTERMEDIATE QUANTITIES SHARED BY BOTH CALCULATIONS MAY BE -C SAVED IN A USER COMMON BLOCK BY F AND NOT RECOMPUTED BY JAC, -C IF DESIRED. ALSO, JAC MAY ALTER THE Y ARRAY, IF DESIRED. -C JAC MUST BE DECLARED EXTERNAL IN THE CALLING PROGRAM. -C SUBROUTINE JAC MAY ACCESS USER-DEFINED QUANTITIES IN -C NEQ(2),... AND/OR IN Y(NEQ(1)+1),... IF NEQ IS AN ARRAY -C (DIMENSIONED IN JAC) AND/OR Y HAS LENGTH EXCEEDING NEQ(1). -C SEE THE DESCRIPTIONS OF NEQ AND Y ABOVE. -C -C MF = THE METHOD FLAG. USED ONLY FOR INPUT. THE LEGAL VALUES OF -C MF ARE 10, 11, 12, 13, 14, 15, 20, 21, 22, 23, 24, AND 25. -C MF HAS DECIMAL DIGITS METH AND MITER.. MF = 10*METH + MITER. -C METH INDICATES THE BASIC LINEAR MULTISTEP METHOD.. -C METH = 1 MEANS THE IMPLICIT ADAMS METHOD. -C METH = 2 MEANS THE METHOD BASED ON BACKWARD -C DIFFERENTIATION FORMULAS (BDF-S). -C MITER INDICATES THE CORRECTOR ITERATION METHOD.. -C MITER = 0 MEANS FUNCTIONAL ITERATION (NO JACOBIAN MATRIX -C IS INVOLVED). -C MITER = 1 MEANS CHORD ITERATION WITH A USER-SUPPLIED -C FULL (NEQ BY NEQ) JACOBIAN. -C MITER = 2 MEANS CHORD ITERATION WITH AN INTERNALLY -C GENERATED (DIFFERENCE QUOTIENT) FULL JACOBIAN -C (USING NEQ EXTRA CALLS TO F PER DF/DY VALUE). -C MITER = 3 MEANS CHORD ITERATION WITH AN INTERNALLY -C GENERATED DIAGONAL JACOBIAN APPROXIMATION. -C (USING 1 EXTRA CALL TO F PER DF/DY EVALUATION). -C MITER = 4 MEANS CHORD ITERATION WITH A USER-SUPPLIED -C BANDED JACOBIAN. -C MITER = 5 MEANS CHORD ITERATION WITH AN INTERNALLY -C GENERATED BANDED JACOBIAN (USING ML+MU+1 EXTRA -C CALLS TO F PER DF/DY EVALUATION). -C IF MITER = 1 OR 4, THE USER MUST SUPPLY A SUBROUTINE JAC -C (THE NAME IS ARBITRARY) AS DESCRIBED ABOVE UNDER JAC. -C FOR OTHER VALUES OF MITER, A DUMMY ARGUMENT CAN BE USED. -C----------------------------------------------------------------------- -C OPTIONAL INPUTS. -C -C THE FOLLOWING IS A LIST OF THE OPTIONAL INPUTS PROVIDED FOR IN THE -C CALL SEQUENCE. (SEE ALSO PART II.) FOR EACH SUCH INPUT VARIABLE, -C THIS TABLE LISTS ITS NAME AS USED IN THIS DOCUMENTATION, ITS -C LOCATION IN THE CALL SEQUENCE, ITS MEANING, AND THE DEFAULT VALUE. -C THE USE OF ANY OF THESE INPUTS REQUIRES IOPT = 1, AND IN THAT -C CASE ALL OF THESE INPUTS ARE EXAMINED. A VALUE OF ZERO FOR ANY -C OF THESE OPTIONAL INPUTS WILL CAUSE THE DEFAULT VALUE TO BE USED. -C THUS TO USE A SUBSET OF THE OPTIONAL INPUTS, SIMPLY PRELOAD -C LOCATIONS 5 TO 10 IN RWORK AND IWORK TO 0.0 AND 0 RESPECTIVELY, AND -C THEN SET THOSE OF INTEREST TO NONZERO VALUES. -C -C NAME LOCATION MEANING AND DEFAULT VALUE -C -C H0 RWORK(5) THE STEP SIZE TO BE ATTEMPTED ON THE FIRST STEP. -C THE DEFAULT VALUE IS DETERMINED BY THE SOLVER. -C -C HMAX RWORK(6) THE MAXIMUM ABSOLUTE STEP SIZE ALLOWED. -C THE DEFAULT VALUE IS INFINITE. -C -C HMIN RWORK(7) THE MINIMUM ABSOLUTE STEP SIZE ALLOWED. -C THE DEFAULT VALUE IS 0. (THIS LOWER BOUND IS NOT -C ENFORCED ON THE FINAL STEP BEFORE REACHING TCRIT -C WHEN ITASK = 4 OR 5.) -C -C MAXORD IWORK(5) THE MAXIMUM ORDER TO BE ALLOWED. THE DEFAULT -C VALUE IS 12 IF METH = 1, AND 5 IF METH = 2. -C IF MAXORD EXCEEDS THE DEFAULT VALUE, IT WILL -C BE REDUCED TO THE DEFAULT VALUE. -C IF MAXORD IS CHANGED DURING THE PROBLEM, IT MAY -C CAUSE THE CURRENT ORDER TO BE REDUCED. -C -C MXSTEP IWORK(6) MAXIMUM NUMBER OF (INTERNALLY DEFINED) STEPS -C ALLOWED DURING ONE CALL TO THE SOLVER. -C THE DEFAULT VALUE IS 500. -C -C MXHNIL IWORK(7) MAXIMUM NUMBER OF MESSAGES PRINTED (PER PROBLEM) -C WARNING THAT T + H = T ON A STEP (H = STEP SIZE). -C THIS MUST BE POSITIVE TO RESULT IN A NON-DEFAULT -C VALUE. THE DEFAULT VALUE IS 10. -C----------------------------------------------------------------------- -C OPTIONAL OUTPUTS. -C -C AS OPTIONAL ADDITIONAL OUTPUT FROM LSODE, THE VARIABLES LISTED -C BELOW ARE QUANTITIES RELATED TO THE PERFORMANCE OF LSODE -C WHICH ARE AVAILABLE TO THE USER. THESE ARE COMMUNICATED BY WAY OF -C THE WORK ARRAYS, BUT ALSO HAVE INTERNAL MNEMONIC NAMES AS SHOWN. -C EXCEPT WHERE STATED OTHERWISE, ALL OF THESE OUTPUTS ARE DEFINED -C ON ANY SUCCESSFUL RETURN FROM LSODE, AND ON ANY RETURN WITH -C ISTATE = -1, -2, -4, -5, OR -6. ON AN ILLEGAL INPUT RETURN -C (ISTATE = -3), THEY WILL BE UNCHANGED FROM THEIR EXISTING VALUES -C (IF ANY), EXCEPT POSSIBLY FOR TOLSF, LENRW, AND LENIW. -C ON ANY ERROR RETURN, OUTPUTS RELEVANT TO THE ERROR WILL BE DEFINED, -C AS NOTED BELOW. -C -C NAME LOCATION MEANING -C -C HU RWORK(11) THE STEP SIZE IN T LAST USED (SUCCESSFULLY). -C -C HCUR RWORK(12) THE STEP SIZE TO BE ATTEMPTED ON THE NEXT STEP. -C -C TCUR RWORK(13) THE CURRENT VALUE OF THE INDEPENDENT VARIABLE -C WHICH THE SOLVER HAS ACTUALLY REACHED, I.E. THE -C CURRENT INTERNAL MESH POINT IN T. ON OUTPUT, TCUR -C WILL ALWAYS BE AT LEAST AS FAR AS THE ARGUMENT -C T, BUT MAY BE FARTHER (IF INTERPOLATION WAS DONE). -C -C TOLSF RWORK(14) A TOLERANCE SCALE FACTOR, GREATER THAN 1.0, -C COMPUTED WHEN A REQUEST FOR TOO MUCH ACCURACY WAS -C DETECTED (ISTATE = -3 IF DETECTED AT THE START OF -C THE PROBLEM, ISTATE = -2 OTHERWISE). IF ITOL IS -C LEFT UNALTERED BUT RTOL AND ATOL ARE UNIFORMLY -C SCALED UP BY A FACTOR OF TOLSF FOR THE NEXT CALL, -C THEN THE SOLVER IS DEEMED LIKELY TO SUCCEED. -C (THE USER MAY ALSO IGNORE TOLSF AND ALTER THE -C TOLERANCE PARAMETERS IN ANY OTHER WAY APPROPRIATE.) -C -C NST IWORK(11) THE NUMBER OF STEPS TAKEN FOR THE PROBLEM SO FAR. -C -C NFE IWORK(12) THE NUMBER OF F EVALUATIONS FOR THE PROBLEM SO FAR. -C -C NJE IWORK(13) THE NUMBER OF JACOBIAN EVALUATIONS (AND OF MATRIX -C LU DECOMPOSITIONS) FOR THE PROBLEM SO FAR. -C -C NQU IWORK(14) THE METHOD ORDER LAST USED (SUCCESSFULLY). -C -C NQCUR IWORK(15) THE ORDER TO BE ATTEMPTED ON THE NEXT STEP. -C -C IMXER IWORK(16) THE INDEX OF THE COMPONENT OF LARGEST MAGNITUDE IN -C THE WEIGHTED LOCAL ERROR VECTOR ( E(I)/EWT(I) ), -C ON AN ERROR RETURN WITH ISTATE = -4 OR -5. -C -C LENRW IWORK(17) THE LENGTH OF RWORK ACTUALLY REQUIRED. -C THIS IS DEFINED ON NORMAL RETURNS AND ON AN ILLEGAL -C INPUT RETURN FOR INSUFFICIENT STORAGE. -C -C LENIW IWORK(18) THE LENGTH OF IWORK ACTUALLY REQUIRED. -C THIS IS DEFINED ON NORMAL RETURNS AND ON AN ILLEGAL -C INPUT RETURN FOR INSUFFICIENT STORAGE. -C -C THE FOLLOWING TWO ARRAYS ARE SEGMENTS OF THE RWORK ARRAY WHICH -C MAY ALSO BE OF INTEREST TO THE USER AS OPTIONAL OUTPUTS. -C FOR EACH ARRAY, THE TABLE BELOW GIVES ITS INTERNAL NAME, -C ITS BASE ADDRESS IN RWORK, AND ITS DESCRIPTION. -C -C NAME BASE ADDRESS DESCRIPTION -C -C YH 21 THE NORDSIECK HISTORY ARRAY, OF SIZE NYH BY -C (NQCUR + 1), WHERE NYH IS THE INITIAL VALUE -C OF NEQ. FOR J = 0,1,...,NQCUR, COLUMN J+1 -C OF YH CONTAINS HCUR**J/FACTORIAL(J) TIMES -C THE J-TH DERIVATIVE OF THE INTERPOLATING -C POLYNOMIAL CURRENTLY REPRESENTING THE SOLUTION, -C EVALUATED AT T = TCUR. -C -C ACOR LENRW-NEQ+1 ARRAY OF SIZE NEQ USED FOR THE ACCUMULATED -C CORRECTIONS ON EACH STEP, SCALED ON OUTPUT -C TO REPRESENT THE ESTIMATED LOCAL ERROR IN Y -C ON THE LAST STEP. THIS IS THE VECTOR E IN -C THE DESCRIPTION OF THE ERROR CONTROL. IT IS -C DEFINED ONLY ON A SUCCESSFUL RETURN FROM LSODE. -C -C----------------------------------------------------------------------- -C PART II. OTHER ROUTINES CALLABLE. -C -C THE FOLLOWING ARE OPTIONAL CALLS WHICH THE USER MAY MAKE TO -C GAIN ADDITIONAL CAPABILITIES IN CONJUNCTION WITH LSODE. -C (THE ROUTINES XSETUN AND XSETF ARE DESIGNED TO CONFORM TO THE -C SLATEC ERROR HANDLING PACKAGE.) -C -C FORM OF CALL FUNCTION -C CALL XSETUN(LUN) SET THE LOGICAL UNIT NUMBER, LUN, FOR -C OUTPUT OF MESSAGES FROM LSODE, IF -C THE DEFAULT IS NOT DESIRED. -C THE DEFAULT VALUE OF LUN IS 6. -C -C CALL XSETF(MFLAG) SET A FLAG TO CONTROL THE PRINTING OF -C MESSAGES BY LSODE. -C MFLAG = 0 MEANS DO NOT PRINT. (DANGER.. -C THIS RISKS LOSING VALUABLE INFORMATION.) -C MFLAG = 1 MEANS PRINT (THE DEFAULT). -C -C EITHER OF THE ABOVE CALLS MAY BE MADE AT -C ANY TIME AND WILL TAKE EFFECT IMMEDIATELY. -C -C CALL SRCOM(RSAV,ISAV,JOB) SAVES AND RESTORES THE CONTENTS OF -C THE INTERNAL COMMON BLOCKS USED BY -C LSODE (SEE PART III BELOW). -C RSAV MUST BE A REAL ARRAY OF LENGTH 218 -C OR MORE, AND ISAV MUST BE AN INTEGER -C ARRAY OF LENGTH 41 OR MORE. -C JOB=1 MEANS SAVE COMMON INTO RSAV/ISAV. -C JOB=2 MEANS RESTORE COMMON FROM RSAV/ISAV. -C SRCOM IS USEFUL IF ONE IS -C INTERRUPTING A RUN AND RESTARTING -C LATER, OR ALTERNATING BETWEEN TWO OR -C MORE PROBLEMS SOLVED WITH LSODE. -C -C CALL INTDY(,,,,,) PROVIDE DERIVATIVES OF Y, OF VARIOUS -C (SEE BELOW) ORDERS, AT A SPECIFIED POINT T, IF -C DESIRED. IT MAY BE CALLED ONLY AFTER -C A SUCCESSFUL RETURN FROM LSODE. -C -C THE DETAILED INSTRUCTIONS FOR USING INTDY ARE AS FOLLOWS. -C THE FORM OF THE CALL IS.. -C -C CALL INTDY (T, K, RWORK(21), NYH, DKY, IFLAG) -C -C THE INPUT PARAMETERS ARE.. -C -C T = VALUE OF INDEPENDENT VARIABLE WHERE ANSWERS ARE DESIRED -C (NORMALLY THE SAME AS THE T LAST RETURNED BY LSODE). -C FOR VALID RESULTS, T MUST LIE BETWEEN TCUR - HU AND TCUR. -C (SEE OPTIONAL OUTPUTS FOR TCUR AND HU.) -C K = INTEGER ORDER OF THE DERIVATIVE DESIRED. K MUST SATISFY -C 0 .LE. K .LE. NQCUR, WHERE NQCUR IS THE CURRENT ORDER -C (SEE OPTIONAL OUTPUTS). THE CAPABILITY CORRESPONDING -C TO K = 0, I.E. COMPUTING Y(T), IS ALREADY PROVIDED -C BY LSODE DIRECTLY. SINCE NQCUR .GE. 1, THE FIRST -C DERIVATIVE DY/DT IS ALWAYS AVAILABLE WITH INTDY. -C RWORK(21) = THE BASE ADDRESS OF THE HISTORY ARRAY YH. -C NYH = COLUMN LENGTH OF YH, EQUAL TO THE INITIAL VALUE OF NEQ. -C -C THE OUTPUT PARAMETERS ARE.. -C -C DKY = A REAL ARRAY OF LENGTH NEQ CONTAINING THE COMPUTED VALUE -C OF THE K-TH DERIVATIVE OF Y(T). -C IFLAG = INTEGER FLAG, RETURNED AS 0 IF K AND T WERE LEGAL, -C -1 IF K WAS ILLEGAL, AND -2 IF T WAS ILLEGAL. -C ON AN ERROR RETURN, A MESSAGE IS ALSO WRITTEN. -C----------------------------------------------------------------------- -C PART III. COMMON BLOCKS. -C -C IF LSODE IS TO BE USED IN AN OVERLAY SITUATION, THE USER -C MUST DECLARE, IN THE PRIMARY OVERLAY, THE VARIABLES IN.. -C (1) THE CALL SEQUENCE TO LSODE, -C (2) THE INTERNAL COMMON BLOCK -C /LS0001/ OF LENGTH 257 (218 DOUBLE PRECISION WORDS -C FOLLOWED BY 39 INTEGER WORDS), -C -C IF LSODE IS USED ON A SYSTEM IN WHICH THE CONTENTS OF INTERNAL -C COMMON BLOCKS ARE NOT PRESERVED BETWEEN CALLS, THE USER SHOULD -C DECLARE THE ABOVE TWO COMMON BLOCKS IN HIS MAIN PROGRAM TO INSURE -C THAT THEIR CONTENTS ARE PRESERVED. -C -C IF THE SOLUTION OF A GIVEN PROBLEM BY LSODE IS TO BE INTERRUPTED -C AND THEN LATER CONTINUED, SUCH AS WHEN RESTARTING AN INTERRUPTED RUN -C OR ALTERNATING BETWEEN TWO OR MORE PROBLEMS, THE USER SHOULD SAVE, -C FOLLOWING THE RETURN FROM THE LAST LSODE CALL PRIOR TO THE -C INTERRUPTION, THE CONTENTS OF THE CALL SEQUENCE VARIABLES AND THE -C INTERNAL COMMON BLOCKS, AND LATER RESTORE THESE VALUES BEFORE THE -C NEXT LSODE CALL FOR THAT PROBLEM. TO SAVE AND RESTORE THE COMMON -C BLOCKS, USE SUBROUTINE SRCOM (SEE PART II ABOVE). -C -C----------------------------------------------------------------------- -C PART IV. OPTIONALLY REPLACEABLE SOLVER ROUTINES. -C -C BELOW ARE DESCRIPTIONS OF TWO ROUTINES IN THE LSODE PACKAGE WHICH -C RELATE TO THE MEASUREMENT OF ERRORS. EITHER ROUTINE CAN BE -C REPLACED BY A USER-SUPPLIED VERSION, IF DESIRED. HOWEVER, SINCE SUCH -C A REPLACEMENT MAY HAVE A MAJOR IMPACT ON PERFORMANCE, IT SHOULD BE -C DONE ONLY WHEN ABSOLUTELY NECESSARY, AND ONLY WITH GREAT CAUTION. -C (NOTE.. THE MEANS BY WHICH THE PACKAGE VERSION OF A ROUTINE IS -C SUPERSEDED BY THE USER-S VERSION MAY BE SYSTEM-DEPENDENT.) -C -C (A) EWSET. -C THE FOLLOWING SUBROUTINE IS CALLED JUST BEFORE EACH INTERNAL -C INTEGRATION STEP, AND SETS THE ARRAY OF ERROR WEIGHTS, EWT, AS -C DESCRIBED UNDER ITOL/RTOL/ATOL ABOVE.. -C SUBROUTINE EWSET (NEQ, ITOL, RTOL, ATOL, YCUR, EWT) -C WHERE NEQ, ITOL, RTOL, AND ATOL ARE AS IN THE LSODE CALL SEQUENCE, -C YCUR CONTAINS THE CURRENT DEPENDENT VARIABLE VECTOR, AND -C EWT IS THE ARRAY OF WEIGHTS SET BY EWSET. -C -C IF THE USER SUPPLIES THIS SUBROUTINE, IT MUST RETURN IN EWT(I) -C (I = 1,...,NEQ) A POSITIVE QUANTITY SUITABLE FOR COMPARING ERRORS -C IN Y(I) TO. THE EWT ARRAY RETURNED BY EWSET IS PASSED TO THE -C VNORM ROUTINE (SEE BELOW), AND ALSO USED BY LSODE IN THE COMPUTATION -C OF THE OPTIONAL OUTPUT IMXER, THE DIAGONAL JACOBIAN APPROXIMATION, -C AND THE INCREMENTS FOR DIFFERENCE QUOTIENT JACOBIANS. -C -C IN THE USER-SUPPLIED VERSION OF EWSET, IT MAY BE DESIRABLE TO USE -C THE CURRENT VALUES OF DERIVATIVES OF Y. DERIVATIVES UP TO ORDER NQ -C ARE AVAILABLE FROM THE HISTORY ARRAY YH, DESCRIBED ABOVE UNDER -C OPTIONAL OUTPUTS. IN EWSET, YH IS IDENTICAL TO THE YCUR ARRAY, -C EXTENDED TO NQ + 1 COLUMNS WITH A COLUMN LENGTH OF NYH AND SCALE -C FACTORS OF H**J/FACTORIAL(J). ON THE FIRST CALL FOR THE PROBLEM, -C GIVEN BY NST = 0, NQ IS 1 AND H IS TEMPORARILY SET TO 1.0. -C THE QUANTITIES NQ, NYH, H, AND NST CAN BE OBTAINED BY INCLUDING -C IN EWSET THE STATEMENTS.. -C DOUBLE PRECISION H, RLS -C COMMON /LS0001/ RLS(218),ILS(39) -C NQ = ILS(35) -C NYH = ILS(14) -C NST = ILS(36) -C H = RLS(212) -C THUS, FOR EXAMPLE, THE CURRENT VALUE OF DY/DT CAN BE OBTAINED AS -C YCUR(NYH+I)/H (I=1,...,NEQ) (AND THE DIVISION BY H IS -C UNNECESSARY WHEN NST = 0). -C -C (B) VNORM. -C THE FOLLOWING IS A REAL FUNCTION ROUTINE WHICH COMPUTES THE WEIGHTED -C ROOT-MEAN-SQUARE NORM OF A VECTOR V.. -C D = VNORM (N, V, W) -C WHERE.. -C N = THE LENGTH OF THE VECTOR, -C V = REAL ARRAY OF LENGTH N CONTAINING THE VECTOR, -C W = REAL ARRAY OF LENGTH N CONTAINING WEIGHTS, -C D = SQRT( (1/N) * SUM(V(I)*W(I))**2 ). -C VNORM IS CALLED WITH N = NEQ AND WITH W(I) = 1.0/EWT(I), WHERE -C EWT IS AS SET BY SUBROUTINE EWSET. -C -C IF THE USER SUPPLIES THIS FUNCTION, IT SHOULD RETURN A NON-NEGATIVE -C VALUE OF VNORM SUITABLE FOR USE IN THE ERROR CONTROL IN LSODE. -C NONE OF THE ARGUMENTS SHOULD BE ALTERED BY VNORM. -C FOR EXAMPLE, A USER-SUPPLIED VNORM ROUTINE MIGHT.. -C -SUBSTITUTE A MAX-NORM OF (V(I)*W(I)) FOR THE RMS-NORM, OR -C -IGNORE SOME COMPONENTS OF V IN THE NORM, WITH THE EFFECT OF -C SUPPRESSING THE ERROR CONTROL ON THOSE COMPONENTS OF Y. -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- -C OTHER ROUTINES IN THE LSODE PACKAGE. -C -C IN ADDITION TO SUBROUTINE LSODE, THE LSODE PACKAGE INCLUDES THE -C FOLLOWING SUBROUTINES AND FUNCTION ROUTINES.. -C INTDY COMPUTES AN INTERPOLATED VALUE OF THE Y VECTOR AT T = TOUT. -C STODE IS THE CORE INTEGRATOR, WHICH DOES ONE STEP OF THE -C INTEGRATION AND THE ASSOCIATED ERROR CONTROL. -C CFODE SETS ALL METHOD COEFFICIENTS AND TEST CONSTANTS. -C PREPJ COMPUTES AND PREPROCESSES THE JACOBIAN MATRIX J = DF/DY -C AND THE NEWTON ITERATION MATRIX P = I - H*L0*J. -C SOLSY MANAGES SOLUTION OF LINEAR SYSTEM IN CHORD ITERATION. -C EWSET SETS THE ERROR WEIGHT VECTOR EWT BEFORE EACH STEP. -C VNORM COMPUTES THE WEIGHTED R.M.S. NORM OF A VECTOR. -C SRCOM IS A USER-CALLABLE ROUTINE TO SAVE AND RESTORE -C THE CONTENTS OF THE INTERNAL COMMON BLOCKS. -C DGETRF AND DGETRS ARE ROUTINES FROM LAPACK FOR SOLVING FULL -C SYSTEMS OF LINEAR ALGEBRAIC EQUATIONS. -C DGBTRF AND DGBTRS ARE ROUTINES FROM LAPACK FOR SOLVING BANDED -C LINEAR SYSTEMS. -C DAXPY, DSCAL, IDAMAX, AND DDOT ARE BASIC LINEAR ALGEBRA MODULES -C (BLAS) USED BY THE ABOVE LINPACK ROUTINES. -C D1MACH COMPUTES THE UNIT ROUNDOFF IN A MACHINE-INDEPENDENT MANNER. -C XERRWD, XSETUN, AND XSETF HANDLE THE PRINTING OF ALL ERROR -C MESSAGES AND WARNINGS. XERRWD IS MACHINE-DEPENDENT. -C NOTE.. VNORM, IDAMAX, DDOT, AND D1MACH ARE FUNCTION ROUTINES. -C ALL THE OTHERS ARE SUBROUTINES. -C -C THE INTRINSIC AND EXTERNAL ROUTINES USED BY LSODE ARE.. -C DABS, DMAX1, DMIN1, DBLE, MAX0, MIN0, MOD, DSIGN, DSQRT, AND WRITE. -C -C A BLOCK DATA SUBPROGRAM IS ALSO INCLUDED WITH THE PACKAGE, -C FOR LOADING SOME OF THE VARIABLES IN INTERNAL COMMON. -C -C----------------------------------------------------------------------- -C THE FOLLOWING CARD IS FOR OPTIMIZED COMPILATION ON LLNL COMPILERS. -CLLL. OPTIMIZE -C----------------------------------------------------------------------- - EXTERNAL PREPJ, SOLSY - INTEGER ILLIN, INIT, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, - 1 MXSTEP, MXHNIL, NHNIL, NTREP, NSLAST, NYH, - 2 IALTH, IPUP, LMAX, MEO, NQNYH, NSLP - INTEGER ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, METH, MITER, - 1 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU - INTEGER I, I1, I2, IFLAG, IMXER, KGO, LF0, - 1 LENIW, LENRW, LENWM, ML, MORD, MU, MXHNL0, MXSTP0 - DOUBLE PRECISION CONIT, CRATE, EL, ELCO, HOLD, RMAX, TESCO, - 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND - DOUBLE PRECISION ATOLI, AYI, BIG, EWTI, H0, HMAX, HMX, RH, RTOLI, - 1 TCRIT, TDIST, TNEXT, TOL, TOLSF, TP, SIZE, SUM, W0, - 2 D1MACH, VNORM - DIMENSION MORD(2) - LOGICAL IHIT -C----------------------------------------------------------------------- -C THE FOLLOWING INTERNAL COMMON BLOCK CONTAINS -C (A) VARIABLES WHICH ARE LOCAL TO ANY SUBROUTINE BUT WHOSE VALUES MUST -C BE PRESERVED BETWEEN CALLS TO THE ROUTINE (OWN VARIABLES), AND -C (B) VARIABLES WHICH ARE COMMUNICATED BETWEEN SUBROUTINES. -C THE STRUCTURE OF THE BLOCK IS AS FOLLOWS.. ALL REAL VARIABLES ARE -C LISTED FIRST, FOLLOWED BY ALL INTEGERS. WITHIN EACH TYPE, THE -C VARIABLES ARE GROUPED WITH THOSE LOCAL TO SUBROUTINE LSODE FIRST, -C THEN THOSE LOCAL TO SUBROUTINE STODE, AND FINALLY THOSE USED -C FOR COMMUNICATION. THE BLOCK IS DECLARED IN SUBROUTINES -C LSODE, INTDY, STODE, PREPJ, AND SOLSY. GROUPS OF VARIABLES ARE -C REPLACED BY DUMMY ARRAYS IN THE COMMON DECLARATIONS IN ROUTINES -C WHERE THOSE VARIABLES ARE NOT USED. -C----------------------------------------------------------------------- - COMMON /LS0001/ CONIT, CRATE, EL(13), ELCO(13,12), - 1 HOLD, RMAX, TESCO(3,12), - 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, - 2 ILLIN, INIT, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, - 3 MXSTEP, MXHNIL, NHNIL, NTREP, NSLAST, NYH, - 3 IALTH, IPUP, LMAX, MEO, NQNYH, NSLP, - 4 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, METH, MITER, - 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU -C - DATA MORD(1),MORD(2)/12,5/, MXSTP0/500/, MXHNL0/10/ -C----------------------------------------------------------------------- -C BLOCK A. -C THIS CODE BLOCK IS EXECUTED ON EVERY CALL. -C IT TESTS ISTATE AND ITASK FOR LEGALITY AND BRANCHES APPROPRIATELY. -C IF ISTATE .GT. 1 BUT THE FLAG INIT SHOWS THAT INITIALIZATION HAS -C NOT YET BEEN DONE, AN ERROR RETURN OCCURS. -C IF ISTATE = 1 AND TOUT = T, JUMP TO BLOCK G AND RETURN IMMEDIATELY. -C----------------------------------------------------------------------- - IF (ISTATE .LT. 1 .OR. ISTATE .GT. 3) GO TO 601 - IF (ITASK .LT. 1 .OR. ITASK .GT. 5) GO TO 602 - IF (ISTATE .EQ. 1) GO TO 10 - IF (INIT .EQ. 0) GO TO 603 - IF (ISTATE .EQ. 2) GO TO 200 - GO TO 20 - 10 INIT = 0 - IF (TOUT .EQ. T) GO TO 430 - 20 NTREP = 0 -C----------------------------------------------------------------------- -C BLOCK B. -C THE NEXT CODE BLOCK IS EXECUTED FOR THE INITIAL CALL (ISTATE = 1), -C OR FOR A CONTINUATION CALL WITH PARAMETER CHANGES (ISTATE = 3). -C IT CONTAINS CHECKING OF ALL INPUTS AND VARIOUS INITIALIZATIONS. -C -C FIRST CHECK LEGALITY OF THE NON-OPTIONAL INPUTS NEQ, ITOL, IOPT, -C MF, ML, AND MU. -C----------------------------------------------------------------------- - IF (NEQ(1) .LE. 0) GO TO 604 - IF (ISTATE .EQ. 1) GO TO 25 - IF (NEQ(1) .GT. N) GO TO 605 - 25 N = NEQ(1) - IF (ITOL .LT. 1 .OR. ITOL .GT. 4) GO TO 606 - IF (IOPT .LT. 0 .OR. IOPT .GT. 1) GO TO 607 - METH = MF/10 - MITER = MF - 10*METH - IF (METH .LT. 1 .OR. METH .GT. 2) GO TO 608 - IF (MITER .LT. 0 .OR. MITER .GT. 5) GO TO 608 - IF (MITER .LE. 3) GO TO 30 - ML = IWORK(1) - MU = IWORK(2) - IF (ML .LT. 0 .OR. ML .GE. N) GO TO 609 - IF (MU .LT. 0 .OR. MU .GE. N) GO TO 610 - 30 CONTINUE -C NEXT PROCESS AND CHECK THE OPTIONAL INPUTS. -------------------------- - IF (IOPT .EQ. 1) GO TO 40 - MAXORD = MORD(METH) - MXSTEP = MXSTP0 - MXHNIL = MXHNL0 - IF (ISTATE .EQ. 1) H0 = 0.0D0 - HMXI = 0.0D0 - HMIN = 0.0D0 - GO TO 60 - 40 MAXORD = IWORK(5) - IF (MAXORD .LT. 0) GO TO 611 - IF (MAXORD .EQ. 0) MAXORD = 100 - MAXORD = MIN0(MAXORD,MORD(METH)) - MXSTEP = IWORK(6) - IF (MXSTEP .LT. 0) GO TO 612 - IF (MXSTEP .EQ. 0) MXSTEP = MXSTP0 - MXHNIL = IWORK(7) - IF (MXHNIL .LT. 0) GO TO 613 - IF (MXHNIL .EQ. 0) MXHNIL = MXHNL0 - IF (ISTATE .NE. 1) GO TO 50 - H0 = RWORK(5) - IF ((TOUT - T)*H0 .LT. 0.0D0) GO TO 614 - 50 HMAX = RWORK(6) - IF (HMAX .LT. 0.0D0) GO TO 615 - HMXI = 0.0D0 - IF (HMAX .GT. 0.0D0) HMXI = 1.0D0/HMAX - HMIN = RWORK(7) - IF (HMIN .LT. 0.0D0) GO TO 616 -C----------------------------------------------------------------------- -C SET WORK ARRAY POINTERS AND CHECK LENGTHS LRW AND LIW. -C POINTERS TO SEGMENTS OF RWORK AND IWORK ARE NAMED BY PREFIXING L TO -C THE NAME OF THE SEGMENT. E.G., THE SEGMENT YH STARTS AT RWORK(LYH). -C SEGMENTS OF RWORK (IN ORDER) ARE DENOTED YH, WM, EWT, SAVF, ACOR. -C----------------------------------------------------------------------- - 60 LYH = 21 - IF (ISTATE .EQ. 1) NYH = N - LWM = LYH + (MAXORD + 1)*NYH - IF (MITER .EQ. 0) LENWM = 0 - IF (MITER .EQ. 1 .OR. MITER .EQ. 2) LENWM = N*N + 2 - IF (MITER .EQ. 3) LENWM = N + 2 - IF (MITER .GE. 4) LENWM = (2*ML + MU + 1)*N + 2 - LEWT = LWM + LENWM - LSAVF = LEWT + N - LACOR = LSAVF + N - LENRW = LACOR + N - 1 - IWORK(17) = LENRW - LIWM = 1 - LENIW = 20 + N - IF (MITER .EQ. 0 .OR. MITER .EQ. 3) LENIW = 20 - IWORK(18) = LENIW - IF (LENRW .GT. LRW) GO TO 617 - IF (LENIW .GT. LIW) GO TO 618 -C CHECK RTOL AND ATOL FOR LEGALITY. ------------------------------------ - RTOLI = RTOL(1) - ATOLI = ATOL(1) - DO 70 I = 1,N - IF (ITOL .GE. 3) RTOLI = RTOL(I) - IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) ATOLI = ATOL(I) - IF (RTOLI .LT. 0.0D0) GO TO 619 - IF (ATOLI .LT. 0.0D0) GO TO 620 - 70 CONTINUE - IF (ISTATE .EQ. 1) GO TO 100 -C IF ISTATE = 3, SET FLAG TO SIGNAL PARAMETER CHANGES TO STODE. -------- - JSTART = -1 - IF (NQ .LE. MAXORD) GO TO 90 -C MAXORD WAS REDUCED BELOW NQ. COPY YH(*,MAXORD+2) INTO SAVF. --------- - DO 80 I = 1,N - 80 RWORK(I+LSAVF-1) = RWORK(I+LWM-1) -C RELOAD WM(1) = RWORK(LWM), SINCE LWM MAY HAVE CHANGED. --------------- - 90 IF (MITER .GT. 0) RWORK(LWM) = DSQRT(UROUND) - IF (N .EQ. NYH) GO TO 200 -C NEQ WAS REDUCED. ZERO PART OF YH TO AVOID UNDEFINED REFERENCES. ----- - I1 = LYH + L*NYH - I2 = LYH + (MAXORD + 1)*NYH - 1 - IF (I1 .GT. I2) GO TO 200 - DO 95 I = I1,I2 - 95 RWORK(I) = 0.0D0 - GO TO 200 -C----------------------------------------------------------------------- -C BLOCK C. -C THE NEXT BLOCK IS FOR THE INITIAL CALL ONLY (ISTATE = 1). -C IT CONTAINS ALL REMAINING INITIALIZATIONS, THE INITIAL CALL TO F, -C AND THE CALCULATION OF THE INITIAL STEP SIZE. -C THE ERROR WEIGHTS IN EWT ARE INVERTED AFTER BEING LOADED. -C----------------------------------------------------------------------- - 100 UROUND = D1MACH(4) - TN = T - IF (ITASK .NE. 4 .AND. ITASK .NE. 5) GO TO 110 - TCRIT = RWORK(1) - IF ((TCRIT - TOUT)*(TOUT - T) .LT. 0.0D0) GO TO 625 - IF (H0 .NE. 0.0D0 .AND. (T + H0 - TCRIT)*H0 .GT. 0.0D0) - 1 H0 = TCRIT - T - 110 JSTART = 0 - IF (MITER .GT. 0) RWORK(LWM) = DSQRT(UROUND) - NHNIL = 0 - NST = 0 - NJE = 0 - NSLAST = 0 - HU = 0.0D0 - NQU = 0 - CCMAX = 0.3D0 - MAXCOR = 3 - MSBP = 20 - MXNCF = 10 -C INITIAL CALL TO F. (LF0 POINTS TO YH(*,2).) ------------------------- - LF0 = LYH + NYH - IERR = 0 - CALL F (NEQ, T, Y, RWORK(LF0), IERR) - IF (IERR .LT. 0) THEN - ISTATE = -13 - RETURN - ENDIF - NFE = 1 -C LOAD THE INITIAL VALUE VECTOR IN YH. --------------------------------- - DO 115 I = 1,N - 115 RWORK(I+LYH-1) = Y(I) -C LOAD AND INVERT THE EWT ARRAY. (H IS TEMPORARILY SET TO 1.0.) ------- - NQ = 1 - H = 1.0D0 - CALL EWSET (N, ITOL, RTOL, ATOL, RWORK(LYH), RWORK(LEWT)) - DO 120 I = 1,N - IF (RWORK(I+LEWT-1) .LE. 0.0D0) GO TO 621 - 120 RWORK(I+LEWT-1) = 1.0D0/RWORK(I+LEWT-1) -C----------------------------------------------------------------------- -C THE CODING BELOW COMPUTES THE STEP SIZE, H0, TO BE ATTEMPTED ON THE -C FIRST STEP, UNLESS THE USER HAS SUPPLIED A VALUE FOR THIS. -C FIRST CHECK THAT TOUT - T DIFFERS SIGNIFICANTLY FROM ZERO. -C A SCALAR TOLERANCE QUANTITY TOL IS COMPUTED, AS MAX(RTOL(I)) -C IF THIS IS POSITIVE, OR MAX(ATOL(I)/ABS(Y(I))) OTHERWISE, ADJUSTED -C SO AS TO BE BETWEEN 100*UROUND AND 1.0E-3. -C THEN THE COMPUTED VALUE H0 IS GIVEN BY.. -C NEQ -C H0**2 = TOL / ( W0**-2 + (1/NEQ) * SUM ( F(I)/YWT(I) )**2 ) -C 1 -C WHERE W0 = MAX ( ABS(T), ABS(TOUT) ), -C F(I) = I-TH COMPONENT OF INITIAL VALUE OF F, -C YWT(I) = EWT(I)/TOL (A WEIGHT FOR Y(I)). -C THE SIGN OF H0 IS INFERRED FROM THE INITIAL VALUES OF TOUT AND T. -C----------------------------------------------------------------------- - IF (H0 .NE. 0.0D0) GO TO 180 - TDIST = DABS(TOUT - T) - W0 = DMAX1(DABS(T),DABS(TOUT)) - IF (TDIST .LT. 2.0D0*UROUND*W0) GO TO 622 - TOL = RTOL(1) - IF (ITOL .LE. 2) GO TO 140 - DO 130 I = 1,N - 130 TOL = DMAX1(TOL,RTOL(I)) - 140 IF (TOL .GT. 0.0D0) GO TO 160 - ATOLI = ATOL(1) - DO 150 I = 1,N - IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) ATOLI = ATOL(I) - AYI = DABS(Y(I)) - IF (AYI .NE. 0.0D0) TOL = DMAX1(TOL,ATOLI/AYI) - 150 CONTINUE - 160 TOL = DMAX1(TOL,100.0D0*UROUND) - TOL = DMIN1(TOL,0.001D0) - SUM = VNORM (N, RWORK(LF0), RWORK(LEWT)) - SUM = 1.0D0/(TOL*W0*W0) + TOL*SUM**2 - H0 = 1.0D0/DSQRT(SUM) - H0 = DMIN1(H0,TDIST) - H0 = DSIGN(H0,TOUT-T) -C ADJUST H0 IF NECESSARY TO MEET HMAX BOUND. --------------------------- - 180 RH = DABS(H0)*HMXI - IF (RH .GT. 1.0D0) H0 = H0/RH -C LOAD H WITH H0 AND SCALE YH(*,2) BY H0. ------------------------------ - H = H0 - DO 190 I = 1,N - 190 RWORK(I+LF0-1) = H0*RWORK(I+LF0-1) - GO TO 270 -C----------------------------------------------------------------------- -C BLOCK D. -C THE NEXT CODE BLOCK IS FOR CONTINUATION CALLS ONLY (ISTATE = 2 OR 3) -C AND IS TO CHECK STOP CONDITIONS BEFORE TAKING A STEP. -C----------------------------------------------------------------------- - 200 NSLAST = NST - GO TO (210, 250, 220, 230, 240), ITASK - 210 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 250 - CALL INTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) - IF (IFLAG .NE. 0) GO TO 627 - T = TOUT - GO TO 420 - 220 TP = TN - HU*(1.0D0 + 100.0D0*UROUND) - IF ((TP - TOUT)*H .GT. 0.0D0) GO TO 623 - IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 250 - GO TO 400 - 230 TCRIT = RWORK(1) - IF ((TN - TCRIT)*H .GT. 0.0D0) GO TO 624 - IF ((TCRIT - TOUT)*H .LT. 0.0D0) GO TO 625 - IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 245 - CALL INTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) - IF (IFLAG .NE. 0) GO TO 627 - T = TOUT - GO TO 420 - 240 TCRIT = RWORK(1) - IF ((TN - TCRIT)*H .GT. 0.0D0) GO TO 624 - 245 HMX = DABS(TN) + DABS(H) - IHIT = DABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX - IF (IHIT) GO TO 400 - TNEXT = TN + H*(1.0D0 + 4.0D0*UROUND) - IF ((TNEXT - TCRIT)*H .LE. 0.0D0) GO TO 250 - H = (TCRIT - TN)*(1.0D0 - 4.0D0*UROUND) - IF (ISTATE .EQ. 2) JSTART = -2 -C----------------------------------------------------------------------- -C BLOCK E. -C THE NEXT BLOCK IS NORMALLY EXECUTED FOR ALL CALLS AND CONTAINS -C THE CALL TO THE ONE-STEP CORE INTEGRATOR STODE. -C -C THIS IS A LOOPING POINT FOR THE INTEGRATION STEPS. -C -C FIRST CHECK FOR TOO MANY STEPS BEING TAKEN, UPDATE EWT (IF NOT AT -C START OF PROBLEM), CHECK FOR TOO MUCH ACCURACY BEING REQUESTED, AND -C CHECK FOR H BELOW THE ROUNDOFF LEVEL IN T. -C----------------------------------------------------------------------- - 250 CONTINUE - IF ((NST-NSLAST) .GE. MXSTEP) GO TO 500 - CALL EWSET (N, ITOL, RTOL, ATOL, RWORK(LYH), RWORK(LEWT)) - DO 260 I = 1,N - IF (RWORK(I+LEWT-1) .LE. 0.0D0) GO TO 510 - 260 RWORK(I+LEWT-1) = 1.0D0/RWORK(I+LEWT-1) - 270 TOLSF = UROUND*VNORM (N, RWORK(LYH), RWORK(LEWT)) - IF (TOLSF .LE. 1.0D0) GO TO 280 - TOLSF = TOLSF*2.0D0 - IF (NST .EQ. 0) GO TO 626 - GO TO 520 - 280 IF ((TN + H) .NE. TN) GO TO 290 - NHNIL = NHNIL + 1 - IF (NHNIL .GT. MXHNIL) GO TO 290 - CALL XERRWD('LSODE-- WARNING..INTERNAL T (=R1) AND H (=R2) ARE', - 1 50, 101, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) - CALL XERRWD( - 1 ' SUCH THAT IN THE MACHINE, T + H = T ON THE NEXT STEP ', - 1 60, 101, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) - CALL XERRWD(' (H = STEP SIZE). SOLVER WILL CONTINUE ANYWAY', - 1 50, 101, 0, 0, 0, 0, 2, TN, H) - IF (NHNIL .LT. MXHNIL) GO TO 290 - CALL XERRWD('LSODE-- ABOVE WARNING HAS BEEN ISSUED I1 TIMES. ', - 1 50, 102, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) - CALL XERRWD(' IT WILL NOT BE ISSUED AGAIN FOR THIS PROBLEM', - 1 50, 102, 0, 1, MXHNIL, 0, 0, 0.0D0, 0.0D0) - 290 CONTINUE -C----------------------------------------------------------------------- -C CALL STODE(NEQ,Y,YH,NYH,YH,EWT,SAVF,ACOR,WM,IWM,F,JAC,PREPJ,SOLSY) -C----------------------------------------------------------------------- - IERR = 0 - CALL STODE (NEQ, Y, RWORK(LYH), NYH, RWORK(LYH), RWORK(LEWT), - 1 RWORK(LSAVF), RWORK(LACOR), RWORK(LWM), IWORK(LIWM), - 2 F, JAC, PREPJ, SOLSY, IERR) - IF (IERR .LT. 0) THEN - ISTATE = -13 - RETURN - ENDIF - KGO = 1 - KFLAG - GO TO (300, 530, 540), KGO -C----------------------------------------------------------------------- -C BLOCK F. -C THE FOLLOWING BLOCK HANDLES THE CASE OF A SUCCESSFUL RETURN FROM THE -C CORE INTEGRATOR (KFLAG = 0). TEST FOR STOP CONDITIONS. -C----------------------------------------------------------------------- - 300 INIT = 1 - GO TO (310, 400, 330, 340, 350), ITASK -C ITASK = 1. IF TOUT HAS BEEN REACHED, INTERPOLATE. ------------------- - 310 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 250 - CALL INTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) - T = TOUT - GO TO 420 -C ITASK = 3. JUMP TO EXIT IF TOUT WAS REACHED. ------------------------ - 330 IF ((TN - TOUT)*H .GE. 0.0D0) GO TO 400 - GO TO 250 -C ITASK = 4. SEE IF TOUT OR TCRIT WAS REACHED. ADJUST H IF NECESSARY. - 340 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 345 - CALL INTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) - T = TOUT - GO TO 420 - 345 HMX = DABS(TN) + DABS(H) - IHIT = DABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX - IF (IHIT) GO TO 400 - TNEXT = TN + H*(1.0D0 + 4.0D0*UROUND) - IF ((TNEXT - TCRIT)*H .LE. 0.0D0) GO TO 250 - H = (TCRIT - TN)*(1.0D0 - 4.0D0*UROUND) - JSTART = -2 - GO TO 250 -C ITASK = 5. SEE IF TCRIT WAS REACHED AND JUMP TO EXIT. --------------- - 350 HMX = DABS(TN) + DABS(H) - IHIT = DABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX -C----------------------------------------------------------------------- -C BLOCK G. -C THE FOLLOWING BLOCK HANDLES ALL SUCCESSFUL RETURNS FROM LSODE. -C IF ITASK .NE. 1, Y IS LOADED FROM YH AND T IS SET ACCORDINGLY. -C ISTATE IS SET TO 2, THE ILLEGAL INPUT COUNTER IS ZEROED, AND THE -C OPTIONAL OUTPUTS ARE LOADED INTO THE WORK ARRAYS BEFORE RETURNING. -C IF ISTATE = 1 AND TOUT = T, THERE IS A RETURN WITH NO ACTION TAKEN, -C EXCEPT THAT IF THIS HAS HAPPENED REPEATEDLY, THE RUN IS TERMINATED. -C----------------------------------------------------------------------- - 400 DO 410 I = 1,N - 410 Y(I) = RWORK(I+LYH-1) - T = TN - IF (ITASK .NE. 4 .AND. ITASK .NE. 5) GO TO 420 - IF (IHIT) T = TCRIT - 420 ISTATE = 2 - ILLIN = 0 - RWORK(11) = HU - RWORK(12) = H - RWORK(13) = TN - IWORK(11) = NST - IWORK(12) = NFE - IWORK(13) = NJE - IWORK(14) = NQU - IWORK(15) = NQ - RETURN -C - 430 NTREP = NTREP + 1 - IF (NTREP .LT. 5) RETURN - CALL XERRWD( - 1 'LSODE-- REPEATED CALLS WITH ISTATE = 1 AND TOUT = T (=R1) ', - 1 60, 301, 0, 0, 0, 0, 1, T, 0.0D0) - GO TO 800 -C----------------------------------------------------------------------- -C BLOCK H. -C THE FOLLOWING BLOCK HANDLES ALL UNSUCCESSFUL RETURNS OTHER THAN -C THOSE FOR ILLEGAL INPUT. FIRST THE ERROR MESSAGE ROUTINE IS CALLED. -C IF THERE WAS AN ERROR TEST OR CONVERGENCE TEST FAILURE, IMXER IS SET. -C THEN Y IS LOADED FROM YH, T IS SET TO TN, AND THE ILLEGAL INPUT -C COUNTER ILLIN IS SET TO 0. THE OPTIONAL OUTPUTS ARE LOADED INTO -C THE WORK ARRAYS BEFORE RETURNING. -C----------------------------------------------------------------------- -C THE MAXIMUM NUMBER OF STEPS WAS TAKEN BEFORE REACHING TOUT. ---------- - 500 CALL XERRWD('LSODE-- AT CURRENT T (=R1), MXSTEP (=I1) STEPS ', - 1 50, 201, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) - CALL XERRWD(' TAKEN ON THIS CALL BEFORE REACHING TOUT ', - 1 50, 201, 0, 1, MXSTEP, 0, 1, TN, 0.0D0) - ISTATE = -1 - GO TO 580 -C EWT(I) .LE. 0.0 FOR SOME I (NOT AT START OF PROBLEM). ---------------- - 510 EWTI = RWORK(LEWT+I-1) - CALL XERRWD('LSODE-- AT T (=R1), EWT(I1) HAS BECOME R2 .LE. 0.', - 1 50, 202, 0, 1, I, 0, 2, TN, EWTI) - ISTATE = -6 - GO TO 580 -C TOO MUCH ACCURACY REQUESTED FOR MACHINE PRECISION. ------------------- - 520 CALL XERRWD('LSODE-- AT T (=R1), TOO MUCH ACCURACY REQUESTED ', - 1 50, 203, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) - CALL XERRWD(' FOR PRECISION OF MACHINE.. SEE TOLSF (=R2) ', - 1 50, 203, 0, 0, 0, 0, 2, TN, TOLSF) - RWORK(14) = TOLSF - ISTATE = -2 - GO TO 580 -C KFLAG = -1. ERROR TEST FAILED REPEATEDLY OR WITH ABS(H) = HMIN. ----- - 530 CALL XERRWD('LSODE-- AT T(=R1) AND STEP SIZE H(=R2), THE ERROR', - 1 50, 204, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) - CALL XERRWD(' TEST FAILED REPEATEDLY OR WITH ABS(H) = HMIN', - 1 50, 204, 0, 0, 0, 0, 2, TN, H) - ISTATE = -4 - GO TO 560 -C KFLAG = -2. CONVERGENCE FAILED REPEATEDLY OR WITH ABS(H) = HMIN. ---- - 540 CALL XERRWD('LSODE-- AT T (=R1) AND STEP SIZE H (=R2), THE ', - 1 50, 205, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) - CALL XERRWD(' CORRECTOR CONVERGENCE FAILED REPEATEDLY ', - 1 50, 205, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) - CALL XERRWD(' OR WITH ABS(H) = HMIN ', - 1 30, 205, 0, 0, 0, 0, 2, TN, H) - ISTATE = -5 -C COMPUTE IMXER IF RELEVANT. ------------------------------------------- - 560 BIG = 0.0D0 - IMXER = 1 - DO 570 I = 1,N - SIZE = DABS(RWORK(I+LACOR-1)*RWORK(I+LEWT-1)) - IF (BIG .GE. SIZE) GO TO 570 - BIG = SIZE - IMXER = I - 570 CONTINUE - IWORK(16) = IMXER -C SET Y VECTOR, T, ILLIN, AND OPTIONAL OUTPUTS. ------------------------ - 580 DO 590 I = 1,N - 590 Y(I) = RWORK(I+LYH-1) - T = TN - ILLIN = 0 - RWORK(11) = HU - RWORK(12) = H - RWORK(13) = TN - IWORK(11) = NST - IWORK(12) = NFE - IWORK(13) = NJE - IWORK(14) = NQU - IWORK(15) = NQ - RETURN -C----------------------------------------------------------------------- -C BLOCK I. -C THE FOLLOWING BLOCK HANDLES ALL ERROR RETURNS DUE TO ILLEGAL INPUT -C (ISTATE = -3), AS DETECTED BEFORE CALLING THE CORE INTEGRATOR. -C FIRST THE ERROR MESSAGE ROUTINE IS CALLED. THEN IF THERE HAVE BEEN -C 5 CONSECUTIVE SUCH RETURNS JUST BEFORE THIS CALL TO THE SOLVER, -C THE RUN IS HALTED. -C----------------------------------------------------------------------- - 601 CALL XERRWD('LSODE-- ISTATE (=I1) ILLEGAL ', - 1 30, 1, 0, 1, ISTATE, 0, 0, 0.0D0, 0.0D0) - GO TO 700 - 602 CALL XERRWD('LSODE-- ITASK (=I1) ILLEGAL ', - 1 30, 2, 0, 1, ITASK, 0, 0, 0.0D0, 0.0D0) - GO TO 700 - 603 CALL XERRWD('LSODE-- ISTATE .GT. 1 BUT LSODE NOT INITIALIZED ', - 1 50, 3, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) - GO TO 700 - 604 CALL XERRWD('LSODE-- NEQ (=I1) .LT. 1 ', - 1 30, 4, 0, 1, NEQ(1), 0, 0, 0.0D0, 0.0D0) - GO TO 700 - 605 CALL XERRWD('LSODE-- ISTATE = 3 AND NEQ INCREASED (I1 TO I2) ', - 1 50, 5, 0, 2, N, NEQ(1), 0, 0.0D0, 0.0D0) - GO TO 700 - 606 CALL XERRWD('LSODE-- ITOL (=I1) ILLEGAL ', - 1 30, 6, 0, 1, ITOL, 0, 0, 0.0D0, 0.0D0) - GO TO 700 - 607 CALL XERRWD('LSODE-- IOPT (=I1) ILLEGAL ', - 1 30, 7, 0, 1, IOPT, 0, 0, 0.0D0, 0.0D0) - GO TO 700 - 608 CALL XERRWD('LSODE-- MF (=I1) ILLEGAL ', - 1 30, 8, 0, 1, MF, 0, 0, 0.0D0, 0.0D0) - GO TO 700 - 609 CALL XERRWD('LSODE-- ML (=I1) ILLEGAL.. .LT.0 OR .GE.NEQ (=I2)', - 1 50, 9, 0, 2, ML, NEQ(1), 0, 0.0D0, 0.0D0) - GO TO 700 - 610 CALL XERRWD('LSODE-- MU (=I1) ILLEGAL.. .LT.0 OR .GE.NEQ (=I2)', - 1 50, 10, 0, 2, MU, NEQ(1), 0, 0.0D0, 0.0D0) - GO TO 700 - 611 CALL XERRWD('LSODE-- MAXORD (=I1) .LT. 0 ', - 1 30, 11, 0, 1, MAXORD, 0, 0, 0.0D0, 0.0D0) - GO TO 700 - 612 CALL XERRWD('LSODE-- MXSTEP (=I1) .LT. 0 ', - 1 30, 12, 0, 1, MXSTEP, 0, 0, 0.0D0, 0.0D0) - GO TO 700 - 613 CALL XERRWD('LSODE-- MXHNIL (=I1) .LT. 0 ', - 1 30, 13, 0, 1, MXHNIL, 0, 0, 0.0D0, 0.0D0) - GO TO 700 - 614 CALL XERRWD('LSODE-- TOUT (=R1) BEHIND T (=R2) ', - 1 40, 14, 0, 0, 0, 0, 2, TOUT, T) - CALL XERRWD(' INTEGRATION DIRECTION IS GIVEN BY H0 (=R1) ', - 1 50, 14, 0, 0, 0, 0, 1, H0, 0.0D0) - GO TO 700 - 615 CALL XERRWD('LSODE-- HMAX (=R1) .LT. 0.0 ', - 1 30, 15, 0, 0, 0, 0, 1, HMAX, 0.0D0) - GO TO 700 - 616 CALL XERRWD('LSODE-- HMIN (=R1) .LT. 0.0 ', - 1 30, 16, 0, 0, 0, 0, 1, HMIN, 0.0D0) - GO TO 700 - 617 CALL XERRWD( - 1 'LSODE-- RWORK LENGTH NEEDED, LENRW (=I1), EXCEEDS LRW (=I2)', - 1 60, 17, 0, 2, LENRW, LRW, 0, 0.0D0, 0.0D0) - GO TO 700 - 618 CALL XERRWD( - 1 'LSODE-- IWORK LENGTH NEEDED, LENIW (=I1), EXCEEDS LIW (=I2)', - 1 60, 18, 0, 2, LENIW, LIW, 0, 0.0D0, 0.0D0) - GO TO 700 - 619 CALL XERRWD('LSODE-- RTOL(I1) IS R1 .LT. 0.0 ', - 1 40, 19, 0, 1, I, 0, 1, RTOLI, 0.0D0) - GO TO 700 - 620 CALL XERRWD('LSODE-- ATOL(I1) IS R1 .LT. 0.0 ', - 1 40, 20, 0, 1, I, 0, 1, ATOLI, 0.0D0) - GO TO 700 - 621 EWTI = RWORK(LEWT+I-1) - CALL XERRWD('LSODE-- EWT(I1) IS R1 .LE. 0.0 ', - 1 40, 21, 0, 1, I, 0, 1, EWTI, 0.0D0) - GO TO 700 - 622 CALL XERRWD( - 1 'LSODE-- TOUT (=R1) TOO CLOSE TO T(=R2) TO START INTEGRATION', - 1 60, 22, 0, 0, 0, 0, 2, TOUT, T) - GO TO 700 - 623 CALL XERRWD( - 1 'LSODE-- ITASK = I1 AND TOUT (=R1) BEHIND TCUR - HU (= R2) ', - 1 60, 23, 0, 1, ITASK, 0, 2, TOUT, TP) - GO TO 700 - 624 CALL XERRWD( - 1 'LSODE-- ITASK = 4 OR 5 AND TCRIT (=R1) BEHIND TCUR (=R2) ', - 1 60, 24, 0, 0, 0, 0, 2, TCRIT, TN) - GO TO 700 - 625 CALL XERRWD( - 1 'LSODE-- ITASK = 4 OR 5 AND TCRIT (=R1) BEHIND TOUT (=R2) ', - 1 60, 25, 0, 0, 0, 0, 2, TCRIT, TOUT) - GO TO 700 - 626 CALL XERRWD('LSODE-- AT START OF PROBLEM, TOO MUCH ACCURACY ', - 1 50, 26, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) - CALL XERRWD( - 1 ' REQUESTED FOR PRECISION OF MACHINE.. SEE TOLSF (=R1) ', - 1 60, 26, 0, 0, 0, 0, 1, TOLSF, 0.0D0) - RWORK(14) = TOLSF - GO TO 700 - 627 CALL XERRWD('LSODE-- TROUBLE FROM INTDY. ITASK = I1, TOUT = R1', - 1 50, 27, 0, 1, ITASK, 0, 1, TOUT, 0.0D0) -C - 700 IF (ILLIN .EQ. 5) GO TO 710 - ILLIN = ILLIN + 1 - ISTATE = -3 - RETURN - 710 CALL XERRWD('LSODE-- REPEATED OCCURRENCES OF ILLEGAL INPUT ', - 1 50, 302, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) -C - 800 CALL XERRWD('LSODE-- RUN ABORTED.. APPARENT INFINITE LOOP ', - 1 50, 303, 2, 0, 0, 0, 0, 0.0D0, 0.0D0) - RETURN -C----------------------- END OF SUBROUTINE LSODE ----------------------- - END
--- a/liboctave/cruft/odepack/ewset.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,32 +0,0 @@ - SUBROUTINE EWSET (N, ITOL, RTOL, ATOL, YCUR, EWT) -CLLL. OPTIMIZE -C----------------------------------------------------------------------- -C THIS SUBROUTINE SETS THE ERROR WEIGHT VECTOR EWT ACCORDING TO -C EWT(I) = RTOL(I)*ABS(YCUR(I)) + ATOL(I), I = 1,...,N, -C WITH THE SUBSCRIPT ON RTOL AND/OR ATOL POSSIBLY REPLACED BY 1 ABOVE, -C DEPENDING ON THE VALUE OF ITOL. -C----------------------------------------------------------------------- - INTEGER N, ITOL - INTEGER I - DOUBLE PRECISION RTOL, ATOL, YCUR, EWT - DIMENSION RTOL(*), ATOL(*), YCUR(N), EWT(N) -C - GO TO (10, 20, 30, 40), ITOL - 10 CONTINUE - DO 15 I = 1,N - 15 EWT(I) = RTOL(1)*DABS(YCUR(I)) + ATOL(1) - RETURN - 20 CONTINUE - DO 25 I = 1,N - 25 EWT(I) = RTOL(1)*DABS(YCUR(I)) + ATOL(I) - RETURN - 30 CONTINUE - DO 35 I = 1,N - 35 EWT(I) = RTOL(I)*DABS(YCUR(I)) + ATOL(1) - RETURN - 40 CONTINUE - DO 45 I = 1,N - 45 EWT(I) = RTOL(I)*DABS(YCUR(I)) + ATOL(I) - RETURN -C----------------------- END OF SUBROUTINE EWSET ----------------------- - END
--- a/liboctave/cruft/odepack/intdy.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,89 +0,0 @@ - SUBROUTINE INTDY (T, K, YH, NYH, DKY, IFLAG) -CLLL. OPTIMIZE - INTEGER K, NYH, IFLAG - INTEGER ILLIN, INIT, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, - 1 MXSTEP, MXHNIL, NHNIL, NTREP, NSLAST, CNYH, - 2 IALTH, IPUP, LMAX, MEO, NQNYH, NSLP - INTEGER ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, METH, MITER, - 2 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU - INTEGER I, IC, J, JB, JB2, JJ, JJ1, JP1 - DOUBLE PRECISION T, YH, DKY - DOUBLE PRECISION CONIT, CRATE, EL, ELCO, HOLD, RMAX, TESCO, - 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND - DOUBLE PRECISION C, R, S, TP - DIMENSION YH(NYH,*), DKY(*) - COMMON /LS0001/ CONIT, CRATE, EL(13), ELCO(13,12), - 1 HOLD, RMAX, TESCO(3,12), - 2 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, - 2 ILLIN, INIT, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, - 3 MXSTEP, MXHNIL, NHNIL, NTREP, NSLAST, CNYH, - 3 IALTH, IPUP, LMAX, MEO, NQNYH, NSLP, - 4 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, METH, MITER, - 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU -C----------------------------------------------------------------------- -C INTDY COMPUTES INTERPOLATED VALUES OF THE K-TH DERIVATIVE OF THE -C DEPENDENT VARIABLE VECTOR Y, AND STORES IT IN DKY. THIS ROUTINE -C IS CALLED WITHIN THE PACKAGE WITH K = 0 AND T = TOUT, BUT MAY -C ALSO BE CALLED BY THE USER FOR ANY K UP TO THE CURRENT ORDER. -C (SEE DETAILED INSTRUCTIONS IN THE USAGE DOCUMENTATION.) -C----------------------------------------------------------------------- -C THE COMPUTED VALUES IN DKY ARE GOTTEN BY INTERPOLATION USING THE -C NORDSIECK HISTORY ARRAY YH. THIS ARRAY CORRESPONDS UNIQUELY TO A -C VECTOR-VALUED POLYNOMIAL OF DEGREE NQCUR OR LESS, AND DKY IS SET -C TO THE K-TH DERIVATIVE OF THIS POLYNOMIAL AT T. -C THE FORMULA FOR DKY IS.. -C Q -C DKY(I) = SUM C(J,K) * (T - TN)**(J-K) * H**(-J) * YH(I,J+1) -C J=K -C WHERE C(J,K) = J*(J-1)*...*(J-K+1), Q = NQCUR, TN = TCUR, H = HCUR. -C THE QUANTITIES NQ = NQCUR, L = NQ+1, N = NEQ, TN, AND H ARE -C COMMUNICATED BY COMMON. THE ABOVE SUM IS DONE IN REVERSE ORDER. -C IFLAG IS RETURNED NEGATIVE IF EITHER K OR T IS OUT OF BOUNDS. -C----------------------------------------------------------------------- - IFLAG = 0 - IF (K .LT. 0 .OR. K .GT. NQ) GO TO 80 - TP = TN - HU - 100.0D0*UROUND*(TN + HU) - IF ((T-TP)*(T-TN) .GT. 0.0D0) GO TO 90 -C - S = (T - TN)/H - IC = 1 - IF (K .EQ. 0) GO TO 15 - JJ1 = L - K - DO 10 JJ = JJ1,NQ - 10 IC = IC*JJ - 15 C = DBLE(IC) - DO 20 I = 1,N - 20 DKY(I) = C*YH(I,L) - IF (K .EQ. NQ) GO TO 55 - JB2 = NQ - K - DO 50 JB = 1,JB2 - J = NQ - JB - JP1 = J + 1 - IC = 1 - IF (K .EQ. 0) GO TO 35 - JJ1 = JP1 - K - DO 30 JJ = JJ1,J - 30 IC = IC*JJ - 35 C = DBLE(IC) - DO 40 I = 1,N - 40 DKY(I) = C*YH(I,JP1) + S*DKY(I) - 50 CONTINUE - IF (K .EQ. 0) RETURN - 55 R = H**(-K) - DO 60 I = 1,N - 60 DKY(I) = R*DKY(I) - RETURN -C - 80 CALL XERRWD('INTDY-- K (=I1) ILLEGAL ', - 1 30, 51, 0, 1, K, 0, 0, 0.0D0, 0.0D0) - IFLAG = -1 - RETURN - 90 CALL XERRWD('INTDY-- T (=R1) ILLEGAL ', - 1 30, 52, 0, 0, 0, 0, 1, T, 0.0D0) - CALL XERRWD( - 1 ' T NOT IN INTERVAL TCUR - HU (= R1) TO TCUR (=R2) ', - 1 60, 52, 0, 0, 0, 0, 2, TP, TN) - IFLAG = -2 - RETURN -C----------------------- END OF SUBROUTINE INTDY ----------------------- - END
--- a/liboctave/cruft/odepack/module.mk Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,17 +0,0 @@ -CRUFT_SOURCES += \ - liboctave/cruft/odepack/cfode.f \ - liboctave/cruft/odepack/dlsode.f \ - liboctave/cruft/odepack/ewset.f \ - liboctave/cruft/odepack/intdy.f \ - liboctave/cruft/odepack/prepj.f \ - liboctave/cruft/odepack/solsy.f \ - liboctave/cruft/odepack/stode.f \ - liboctave/cruft/odepack/vnorm.f \ - liboctave/cruft/odepack/scfode.f \ - liboctave/cruft/odepack/sewset.f \ - liboctave/cruft/odepack/sintdy.f \ - liboctave/cruft/odepack/slsode.f \ - liboctave/cruft/odepack/sprepj.f \ - liboctave/cruft/odepack/ssolsy.f \ - liboctave/cruft/odepack/sstode.f \ - liboctave/cruft/odepack/svnorm.f
--- a/liboctave/cruft/odepack/prepj.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,182 +0,0 @@ - SUBROUTINE PREPJ (NEQ, Y, YH, NYH, EWT, FTEM, SAVF, WM, IWM, - 1 F, JAC, IERR) -CLLL. OPTIMIZE - EXTERNAL F, JAC - INTEGER NEQ, NYH, IWM - INTEGER ILLIN, INIT, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, - 1 MXSTEP, MXHNIL, NHNIL, NTREP, NSLAST, CNYH, - 2 IALTH, IPUP, LMAX, MEO, NQNYH, NSLP - INTEGER ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, METH, MITER, - 2 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU - INTEGER I, I1, I2, IER, II, J, J1, JJ, LENP, - 1 MBA, MBAND, MEB1, MEBAND, ML, ML3, MU, NP1 - DOUBLE PRECISION Y, YH, EWT, FTEM, SAVF, WM - DOUBLE PRECISION CONIT, CRATE, EL, ELCO, HOLD, RMAX, TESCO, - 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND - DOUBLE PRECISION CON, DI, FAC, HL0, R, R0, SRUR, YI, YJ, YJJ, - 1 VNORM - DIMENSION NEQ(*), Y(*), YH(NYH,*), EWT(*), FTEM(*), SAVF(*), - 1 WM(*), IWM(*) - COMMON /LS0001/ CONIT, CRATE, EL(13), ELCO(13,12), - 1 HOLD, RMAX, TESCO(3,12), - 2 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, - 2 ILLIN, INIT, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, - 3 MXSTEP, MXHNIL, NHNIL, NTREP, NSLAST, CNYH, - 3 IALTH, IPUP, LMAX, MEO, NQNYH, NSLP, - 4 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, METH, MITER, - 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU -C----------------------------------------------------------------------- -C PREPJ IS CALLED BY STODE TO COMPUTE AND PROCESS THE MATRIX -C P = I - H*EL(1)*J , WHERE J IS AN APPROXIMATION TO THE JACOBIAN. -C HERE J IS COMPUTED BY THE USER-SUPPLIED ROUTINE JAC IF -C MITER = 1 OR 4, OR BY FINITE DIFFERENCING IF MITER = 2, 3, OR 5. -C IF MITER = 3, A DIAGONAL APPROXIMATION TO J IS USED. -C J IS STORED IN WM AND REPLACED BY P. IF MITER .NE. 3, P IS THEN -C SUBJECTED TO LU DECOMPOSITION IN PREPARATION FOR LATER SOLUTION -C OF LINEAR SYSTEMS WITH P AS COEFFICIENT MATRIX. THIS IS DONE -C BY DGETRF IF MITER = 1 OR 2, AND BY DGBTRF IF MITER = 4 OR 5. -C -C IN ADDITION TO VARIABLES DESCRIBED PREVIOUSLY, COMMUNICATION -C WITH PREPJ USES THE FOLLOWING.. -C Y = ARRAY CONTAINING PREDICTED VALUES ON ENTRY. -C FTEM = WORK ARRAY OF LENGTH N (ACOR IN STODE). -C SAVF = ARRAY CONTAINING F EVALUATED AT PREDICTED Y. -C WM = REAL WORK SPACE FOR MATRICES. ON OUTPUT IT CONTAINS THE -C INVERSE DIAGONAL MATRIX IF MITER = 3 AND THE LU DECOMPOSITION -C OF P IF MITER IS 1, 2 , 4, OR 5. -C STORAGE OF MATRIX ELEMENTS STARTS AT WM(3). -C WM ALSO CONTAINS THE FOLLOWING MATRIX-RELATED DATA.. -C WM(1) = SQRT(UROUND), USED IN NUMERICAL JACOBIAN INCREMENTS. -C WM(2) = H*EL0, SAVED FOR LATER USE IF MITER = 3. -C IWM = INTEGER WORK SPACE CONTAINING PIVOT INFORMATION, STARTING AT -C IWM(21), IF MITER IS 1, 2, 4, OR 5. IWM ALSO CONTAINS BAND -C PARAMETERS ML = IWM(1) AND MU = IWM(2) IF MITER IS 4 OR 5. -C EL0 = EL(1) (INPUT). -C IERPJ = OUTPUT ERROR FLAG, = 0 IF NO TROUBLE, .GT. 0 IF -C P MATRIX FOUND TO BE SINGULAR. -C JCUR = OUTPUT FLAG = 1 TO INDICATE THAT THE JACOBIAN MATRIX -C (OR APPROXIMATION) IS NOW CURRENT. -C THIS ROUTINE ALSO USES THE COMMON VARIABLES EL0, H, TN, UROUND, -C MITER, N, NFE, AND NJE. -C----------------------------------------------------------------------- - NJE = NJE + 1 - IERPJ = 0 - JCUR = 1 - HL0 = H*EL0 - GO TO (100, 200, 300, 400, 500), MITER -C IF MITER = 1, CALL JAC AND MULTIPLY BY SCALAR. ----------------------- - 100 LENP = N*N - DO 110 I = 1,LENP - 110 WM(I+2) = 0.0D0 - CALL JAC (NEQ, TN, Y, 0, 0, WM(3), N) - CON = -HL0 - DO 120 I = 1,LENP - 120 WM(I+2) = WM(I+2)*CON - GO TO 240 -C IF MITER = 2, MAKE N CALLS TO F TO APPROXIMATE J. -------------------- - 200 FAC = VNORM (N, SAVF, EWT) - R0 = 1000.0D0*DABS(H)*UROUND*DBLE(N)*FAC - IF (R0 .EQ. 0.0D0) R0 = 1.0D0 - SRUR = WM(1) - J1 = 2 - DO 230 J = 1,N - YJ = Y(J) - R = DMAX1(SRUR*DABS(YJ),R0/EWT(J)) - Y(J) = Y(J) + R - FAC = -HL0/R - IERR = 0 - CALL F (NEQ, TN, Y, FTEM, IERR) - IF (IERR .LT. 0) RETURN - DO 220 I = 1,N - 220 WM(I+J1) = (FTEM(I) - SAVF(I))*FAC - Y(J) = YJ - J1 = J1 + N - 230 CONTINUE - NFE = NFE + N -C ADD IDENTITY MATRIX. ------------------------------------------------- - 240 J = 3 - NP1 = N + 1 - DO 250 I = 1,N - WM(J) = WM(J) + 1.0D0 - 250 J = J + NP1 -C DO LU DECOMPOSITION ON P. -------------------------------------------- - CALL DGETRF ( N, N, WM(3), N, IWM(21), IER) - IF (IER .NE. 0) IERPJ = 1 - RETURN -C IF MITER = 3, CONSTRUCT A DIAGONAL APPROXIMATION TO J AND P. --------- - 300 WM(2) = HL0 - R = EL0*0.1D0 - DO 310 I = 1,N - 310 Y(I) = Y(I) + R*(H*SAVF(I) - YH(I,2)) - IERR = 0 - CALL F (NEQ, TN, Y, WM(3), IERR) - IF (IERR .LT. 0) RETURN - NFE = NFE + 1 - DO 320 I = 1,N - R0 = H*SAVF(I) - YH(I,2) - DI = 0.1D0*R0 - H*(WM(I+2) - SAVF(I)) - WM(I+2) = 1.0D0 - IF (DABS(R0) .LT. UROUND/EWT(I)) GO TO 320 - IF (DABS(DI) .EQ. 0.0D0) GO TO 330 - WM(I+2) = 0.1D0*R0/DI - 320 CONTINUE - RETURN - 330 IERPJ = 1 - RETURN -C IF MITER = 4, CALL JAC AND MULTIPLY BY SCALAR. ----------------------- - 400 ML = IWM(1) - MU = IWM(2) - ML3 = ML + 3 - MBAND = ML + MU + 1 - MEBAND = MBAND + ML - LENP = MEBAND*N - DO 410 I = 1,LENP - 410 WM(I+2) = 0.0D0 - CALL JAC (NEQ, TN, Y, ML, MU, WM(ML3), MEBAND) - CON = -HL0 - DO 420 I = 1,LENP - 420 WM(I+2) = WM(I+2)*CON - GO TO 570 -C IF MITER = 5, MAKE MBAND CALLS TO F TO APPROXIMATE J. ---------------- - 500 ML = IWM(1) - MU = IWM(2) - MBAND = ML + MU + 1 - MBA = MIN0(MBAND,N) - MEBAND = MBAND + ML - MEB1 = MEBAND - 1 - SRUR = WM(1) - FAC = VNORM (N, SAVF, EWT) - R0 = 1000.0D0*DABS(H)*UROUND*DBLE(N)*FAC - IF (R0 .EQ. 0.0D0) R0 = 1.0D0 - DO 560 J = 1,MBA - DO 530 I = J,N,MBAND - YI = Y(I) - R = DMAX1(SRUR*DABS(YI),R0/EWT(I)) - 530 Y(I) = Y(I) + R - IERR = 0 - CALL F (NEQ, TN, Y, FTEM, IERR) - IF (IERR .LT. 0) RETURN - DO 550 JJ = J,N,MBAND - Y(JJ) = YH(JJ,1) - YJJ = Y(JJ) - R = DMAX1(SRUR*DABS(YJJ),R0/EWT(JJ)) - FAC = -HL0/R - I1 = MAX0(JJ-MU,1) - I2 = MIN0(JJ+ML,N) - II = JJ*MEB1 - ML + 2 - DO 540 I = I1,I2 - 540 WM(II+I) = (FTEM(I) - SAVF(I))*FAC - 550 CONTINUE - 560 CONTINUE - NFE = NFE + MBA -C ADD IDENTITY MATRIX. ------------------------------------------------- - 570 II = MBAND + 2 - DO 580 I = 1,N - WM(II) = WM(II) + 1.0D0 - 580 II = II + MEBAND -C DO LU DECOMPOSITION OF P. -------------------------------------------- - CALL DGBTRF ( N, N, ML, MU, WM(3), MEBAND, IWM(21), IER) - IF (IER .NE. 0) IERPJ = 1 - RETURN -C----------------------- END OF SUBROUTINE PREPJ ----------------------- - END
--- a/liboctave/cruft/odepack/scfode.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,127 +0,0 @@ - SUBROUTINE SCFODE (METH, ELCO, TESCO) -C***BEGIN PROLOGUE SCFODE -C***SUBSIDIARY -C***PURPOSE Set ODE integrator coefficients. -C***TYPE SINGLE PRECISION (SCFODE-S, DCFODE-D) -C***AUTHOR Hindmarsh, Alan C., (LLNL) -C***DESCRIPTION -C -C SCFODE is called by the integrator routine to set coefficients -C needed there. The coefficients for the current method, as -C given by the value of METH, are set for all orders and saved. -C The maximum order assumed here is 12 if METH = 1 and 5 if METH = 2. -C (A smaller value of the maximum order is also allowed.) -C SCFODE is called once at the beginning of the problem, -C and is not called again unless and until METH is changed. -C -C The ELCO array contains the basic method coefficients. -C The coefficients el(i), 1 .le. i .le. nq+1, for the method of -C order nq are stored in ELCO(i,nq). They are given by a genetrating -C polynomial, i.e., -C l(x) = el(1) + el(2)*x + ... + el(nq+1)*x**nq. -C For the implicit Adams methods, l(x) is given by -C dl/dx = (x+1)*(x+2)*...*(x+nq-1)/factorial(nq-1), l(-1) = 0. -C For the BDF methods, l(x) is given by -C l(x) = (x+1)*(x+2)* ... *(x+nq)/K, -C where K = factorial(nq)*(1 + 1/2 + ... + 1/nq). -C -C The TESCO array contains test constants used for the -C local error test and the selection of step size and/or order. -C At order nq, TESCO(k,nq) is used for the selection of step -C size at order nq - 1 if k = 1, at order nq if k = 2, and at order -C nq + 1 if k = 3. -C -C***SEE ALSO SLSODE -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 791129 DATE WRITTEN -C 890501 Modified prologue to SLATEC/LDOC format. (FNF) -C 890503 Minor cosmetic changes. (FNF) -C 930809 Renamed to allow single/double precision versions. (ACH) -C***END PROLOGUE SCFODE -C**End - INTEGER METH - INTEGER I, IB, NQ, NQM1, NQP1 - REAL ELCO, TESCO - REAL AGAMQ, FNQ, FNQM1, PC, PINT, RAGQ, - 1 RQFAC, RQ1FAC, TSIGN, XPIN - DIMENSION ELCO(13,12), TESCO(3,12) - DIMENSION PC(12) -C -C***FIRST EXECUTABLE STATEMENT SCFODE - GO TO (100, 200), METH -C - 100 ELCO(1,1) = 1.0E0 - ELCO(2,1) = 1.0E0 - TESCO(1,1) = 0.0E0 - TESCO(2,1) = 2.0E0 - TESCO(1,2) = 1.0E0 - TESCO(3,12) = 0.0E0 - PC(1) = 1.0E0 - RQFAC = 1.0E0 - DO 140 NQ = 2,12 -C----------------------------------------------------------------------- -C The PC array will contain the coefficients of the polynomial -C p(x) = (x+1)*(x+2)*...*(x+nq-1). -C Initially, p(x) = 1. -C----------------------------------------------------------------------- - RQ1FAC = RQFAC - RQFAC = RQFAC/NQ - NQM1 = NQ - 1 - FNQM1 = NQM1 - NQP1 = NQ + 1 -C Form coefficients of p(x)*(x+nq-1). ---------------------------------- - PC(NQ) = 0.0E0 - DO 110 IB = 1,NQM1 - I = NQP1 - IB - 110 PC(I) = PC(I-1) + FNQM1*PC(I) - PC(1) = FNQM1*PC(1) -C Compute integral, -1 to 0, of p(x) and x*p(x). ----------------------- - PINT = PC(1) - XPIN = PC(1)/2.0E0 - TSIGN = 1.0E0 - DO 120 I = 2,NQ - TSIGN = -TSIGN - PINT = PINT + TSIGN*PC(I)/I - 120 XPIN = XPIN + TSIGN*PC(I)/(I+1) -C Store coefficients in ELCO and TESCO. -------------------------------- - ELCO(1,NQ) = PINT*RQ1FAC - ELCO(2,NQ) = 1.0E0 - DO 130 I = 2,NQ - 130 ELCO(I+1,NQ) = RQ1FAC*PC(I)/I - AGAMQ = RQFAC*XPIN - RAGQ = 1.0E0/AGAMQ - TESCO(2,NQ) = RAGQ - IF (NQ .LT. 12) TESCO(1,NQP1) = RAGQ*RQFAC/NQP1 - TESCO(3,NQM1) = RAGQ - 140 CONTINUE - RETURN -C - 200 PC(1) = 1.0E0 - RQ1FAC = 1.0E0 - DO 230 NQ = 1,5 -C----------------------------------------------------------------------- -C The PC array will contain the coefficients of the polynomial -C p(x) = (x+1)*(x+2)*...*(x+nq). -C Initially, p(x) = 1. -C----------------------------------------------------------------------- - FNQ = NQ - NQP1 = NQ + 1 -C Form coefficients of p(x)*(x+nq). ------------------------------------ - PC(NQP1) = 0.0E0 - DO 210 IB = 1,NQ - I = NQ + 2 - IB - 210 PC(I) = PC(I-1) + FNQ*PC(I) - PC(1) = FNQ*PC(1) -C Store coefficients in ELCO and TESCO. -------------------------------- - DO 220 I = 1,NQP1 - 220 ELCO(I,NQ) = PC(I)/PC(2) - ELCO(2,NQ) = 1.0E0 - TESCO(1,NQ) = RQ1FAC - TESCO(2,NQ) = NQP1/ELCO(1,NQ) - TESCO(3,NQ) = (NQ+2)/ELCO(1,NQ) - RQ1FAC = RQ1FAC/FNQ - 230 CONTINUE - RETURN -C----------------------- END OF SUBROUTINE SCFODE ---------------------- - END
--- a/liboctave/cruft/odepack/sewset.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,47 +0,0 @@ - SUBROUTINE SEWSET (N, ITOL, RTOL, ATOL, YCUR, EWT) -C***BEGIN PROLOGUE SEWSET -C***SUBSIDIARY -C***PURPOSE Set error weight vector. -C***TYPE SINGLE PRECISION (SEWSET-S, DEWSET-D) -C***AUTHOR Hindmarsh, Alan C., (LLNL) -C***DESCRIPTION -C -C This subroutine sets the error weight vector EWT according to -C EWT(i) = RTOL(i)*ABS(YCUR(i)) + ATOL(i), i = 1,...,N, -C with the subscript on RTOL and/or ATOL possibly replaced by 1 above, -C depending on the value of ITOL. -C -C***SEE ALSO SLSODE -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 791129 DATE WRITTEN -C 890501 Modified prologue to SLATEC/LDOC format. (FNF) -C 890503 Minor cosmetic changes. (FNF) -C 930809 Renamed to allow single/double precision versions. (ACH) -C***END PROLOGUE SEWSET -C**End - INTEGER N, ITOL - INTEGER I - REAL RTOL, ATOL, YCUR, EWT - DIMENSION RTOL(*), ATOL(*), YCUR(N), EWT(N) -C -C***FIRST EXECUTABLE STATEMENT SEWSET - GO TO (10, 20, 30, 40), ITOL - 10 CONTINUE - DO 15 I = 1,N - 15 EWT(I) = RTOL(1)*ABS(YCUR(I)) + ATOL(1) - RETURN - 20 CONTINUE - DO 25 I = 1,N - 25 EWT(I) = RTOL(1)*ABS(YCUR(I)) + ATOL(I) - RETURN - 30 CONTINUE - DO 35 I = 1,N - 35 EWT(I) = RTOL(I)*ABS(YCUR(I)) + ATOL(1) - RETURN - 40 CONTINUE - DO 45 I = 1,N - 45 EWT(I) = RTOL(I)*ABS(YCUR(I)) + ATOL(I) - RETURN -C----------------------- END OF SUBROUTINE SEWSET ---------------------- - END
--- a/liboctave/cruft/odepack/sintdy.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,111 +0,0 @@ - SUBROUTINE SINTDY (T, K, YH, NYH, DKY, IFLAG) -C***BEGIN PROLOGUE SINTDY -C***SUBSIDIARY -C***PURPOSE Interpolate solution derivatives. -C***TYPE SINGLE PRECISION (SINTDY-S, DINTDY-D) -C***AUTHOR Hindmarsh, Alan C., (LLNL) -C***DESCRIPTION -C -C SINTDY computes interpolated values of the K-th derivative of the -C dependent variable vector y, and stores it in DKY. This routine -C is called within the package with K = 0 and T = TOUT, but may -C also be called by the user for any K up to the current order. -C (See detailed instructions in the usage documentation.) -C -C The computed values in DKY are gotten by interpolation using the -C Nordsieck history array YH. This array corresponds uniquely to a -C vector-valued polynomial of degree NQCUR or less, and DKY is set -C to the K-th derivative of this polynomial at T. -C The formula for DKY is: -C q -C DKY(i) = sum c(j,K) * (T - tn)**(j-K) * h**(-j) * YH(i,j+1) -C j=K -C where c(j,K) = j*(j-1)*...*(j-K+1), q = NQCUR, tn = TCUR, h = HCUR. -C The quantities nq = NQCUR, l = nq+1, N = NEQ, tn, and h are -C communicated by COMMON. The above sum is done in reverse order. -C IFLAG is returned negative if either K or T is out of bounds. -C -C***SEE ALSO SLSODE -C***ROUTINES CALLED XERRWV -C***COMMON BLOCKS SLS001 -C***REVISION HISTORY (YYMMDD) -C 791129 DATE WRITTEN -C 890501 Modified prologue to SLATEC/LDOC format. (FNF) -C 890503 Minor cosmetic changes. (FNF) -C 930809 Renamed to allow single/double precision versions. (ACH) -C 010412 Reduced size of Common block /SLS001/. (ACH) -C 031105 Restored 'own' variables to Common block /SLS001/, to -C enable interrupt/restart feature. (ACH) -C 050427 Corrected roundoff decrement in TP. (ACH) -C***END PROLOGUE SINTDY -C**End - INTEGER K, NYH, IFLAG - REAL T, YH, DKY - DIMENSION YH(NYH,*), DKY(*) - INTEGER INIT, MXSTEP, MXHNIL, NHNIL, NSLAST, CNYH, - 1 IALTH, IPUP, LMAX, MEO, NQNYH, NSLP, - 1 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, - 2 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, - 3 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU - REAL CONIT, CRATE, EL, ELCO, HOLD, RMAX, TESCO, - 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND - COMMON /SLS001/ CONIT, CRATE, EL(13), ELCO(13,12), - 1 HOLD, RMAX, TESCO(3,12), - 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, - 2 INIT, MXSTEP, MXHNIL, NHNIL, NSLAST, CNYH, - 3 IALTH, IPUP, LMAX, MEO, NQNYH, NSLP, - 3 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, - 4 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, - 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU - INTEGER I, IC, J, JB, JB2, JJ, JJ1, JP1 - REAL C, R, S, TP - CHARACTER*80 MSG -C -C***FIRST EXECUTABLE STATEMENT SINTDY - IFLAG = 0 - IF (K .LT. 0 .OR. K .GT. NQ) GO TO 80 - TP = TN - HU - 100.0E0*UROUND*SIGN(ABS(TN) + ABS(HU), HU) - IF ((T-TP)*(T-TN) .GT. 0.0E0) GO TO 90 -C - S = (T - TN)/H - IC = 1 - IF (K .EQ. 0) GO TO 15 - JJ1 = L - K - DO 10 JJ = JJ1,NQ - 10 IC = IC*JJ - 15 C = IC - DO 20 I = 1,N - 20 DKY(I) = C*YH(I,L) - IF (K .EQ. NQ) GO TO 55 - JB2 = NQ - K - DO 50 JB = 1,JB2 - J = NQ - JB - JP1 = J + 1 - IC = 1 - IF (K .EQ. 0) GO TO 35 - JJ1 = JP1 - K - DO 30 JJ = JJ1,J - 30 IC = IC*JJ - 35 C = IC - DO 40 I = 1,N - 40 DKY(I) = C*YH(I,JP1) + S*DKY(I) - 50 CONTINUE - IF (K .EQ. 0) RETURN - 55 R = H**(-K) - DO 60 I = 1,N - 60 DKY(I) = R*DKY(I) - RETURN -C - 80 CALL XERRWD('SINTDY- K (=I1) illegal ', - 1 30, 51, 0, 1, K, 0, 0, 0.0E0, 0.0E0) - IFLAG = -1 - RETURN - 90 CALL XERRWD('SINTDY- T (=R1) illegal ', - 1 30, 52, 0, 0, 0, 0, 1, T, 0.0E0) - CALL XERRWD( - 1 ' T not in interval TCUR - HU (= R1) to TCUR (=R2) ', - 1 60, 52, 0, 0, 0, 0, 2, TP, TN) - IFLAG = -2 - RETURN -C----------------------- END OF SUBROUTINE SINTDY ---------------------- - END
--- a/liboctave/cruft/odepack/slsode.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1760 +0,0 @@ -*DECK SLSODE - SUBROUTINE SLSODE (F, NEQ, Y, T, TOUT, ITOL, RTOL, ATOL, ITASK, - 1 ISTATE, IOPT, RWORK, LRW, IWORK, LIW, JAC, MF) - EXTERNAL F, JAC - INTEGER NEQ, ITOL, ITASK, ISTATE, IOPT, LRW, IWORK, LIW, MF - REAL Y, T, TOUT, RTOL, ATOL, RWORK - DIMENSION NEQ(*), Y(*), RTOL(*), ATOL(*), RWORK(LRW), IWORK(LIW) -C***BEGIN PROLOGUE SLSODE -C***PURPOSE Livermore Solver for Ordinary Differential Equations. -C SLSODE solves the initial-value problem for stiff or -C nonstiff systems of first-order ODE's, -C dy/dt = f(t,y), or, in component form, -C dy(i)/dt = f(i) = f(i,t,y(1),y(2),...,y(N)), i=1,...,N. -C***CATEGORY I1A -C***TYPE SINGLE PRECISION (SLSODE-S, DLSODE-D) -C***KEYWORDS ORDINARY DIFFERENTIAL EQUATIONS, INITIAL VALUE PROBLEM, -C STIFF, NONSTIFF -C***AUTHOR Hindmarsh, Alan C., (LLNL) -C Center for Applied Scientific Computing, L-561 -C Lawrence Livermore National Laboratory -C Livermore, CA 94551. -C***DESCRIPTION -C -C NOTE: The "Usage" and "Arguments" sections treat only a subset of -C available options, in condensed fashion. The options -C covered and the information supplied will support most -C standard uses of SLSODE. -C -C For more sophisticated uses, full details on all options are -C given in the concluding section, headed "Long Description." -C A synopsis of the SLSODE Long Description is provided at the -C beginning of that section; general topics covered are: -C - Elements of the call sequence; optional input and output -C - Optional supplemental routines in the SLSODE package -C - internal COMMON block -C -C *Usage: -C Communication between the user and the SLSODE package, for normal -C situations, is summarized here. This summary describes a subset -C of the available options. See "Long Description" for complete -C details, including optional communication, nonstandard options, -C and instructions for special situations. -C -C A sample program is given in the "Examples" section. -C -C Refer to the argument descriptions for the definitions of the -C quantities that appear in the following sample declarations. -C -C For MF = 10, -C PARAMETER (LRW = 20 + 16*NEQ, LIW = 20) -C For MF = 21 or 22, -C PARAMETER (LRW = 22 + 9*NEQ + NEQ**2, LIW = 20 + NEQ) -C For MF = 24 or 25, -C PARAMETER (LRW = 22 + 10*NEQ + (2*ML+MU)*NEQ, -C * LIW = 20 + NEQ) -C -C EXTERNAL F, JAC -C INTEGER NEQ, ITOL, ITASK, ISTATE, IOPT, LRW, IWORK(LIW), -C * LIW, MF -C REAL Y(NEQ), T, TOUT, RTOL, ATOL(ntol), RWORK(LRW) -C -C CALL SLSODE (F, NEQ, Y, T, TOUT, ITOL, RTOL, ATOL, ITASK, -C * ISTATE, IOPT, RWORK, LRW, IWORK, LIW, JAC, MF) -C -C *Arguments: -C F :EXT Name of subroutine for right-hand-side vector f. -C This name must be declared EXTERNAL in calling -C program. The form of F must be: -C -C SUBROUTINE F (NEQ, T, Y, YDOT) -C INTEGER NEQ -C REAL T, Y(*), YDOT(*) -C -C The inputs are NEQ, T, Y. F is to set -C -C YDOT(i) = f(i,T,Y(1),Y(2),...,Y(NEQ)), -C i = 1, ..., NEQ . -C -C NEQ :IN Number of first-order ODE's. -C -C Y :INOUT Array of values of the y(t) vector, of length NEQ. -C Input: For the first call, Y should contain the -C values of y(t) at t = T. (Y is an input -C variable only if ISTATE = 1.) -C Output: On return, Y will contain the values at the -C new t-value. -C -C T :INOUT Value of the independent variable. On return it -C will be the current value of t (normally TOUT). -C -C TOUT :IN Next point where output is desired (.NE. T). -C -C ITOL :IN 1 or 2 according as ATOL (below) is a scalar or -C an array. -C -C RTOL :IN Relative tolerance parameter (scalar). -C -C ATOL :IN Absolute tolerance parameter (scalar or array). -C If ITOL = 1, ATOL need not be dimensioned. -C If ITOL = 2, ATOL must be dimensioned at least NEQ. -C -C The estimated local error in Y(i) will be controlled -C so as to be roughly less (in magnitude) than -C -C EWT(i) = RTOL*ABS(Y(i)) + ATOL if ITOL = 1, or -C EWT(i) = RTOL*ABS(Y(i)) + ATOL(i) if ITOL = 2. -C -C Thus the local error test passes if, in each -C component, either the absolute error is less than -C ATOL (or ATOL(i)), or the relative error is less -C than RTOL. -C -C Use RTOL = 0.0 for pure absolute error control, and -C use ATOL = 0.0 (or ATOL(i) = 0.0) for pure relative -C error control. Caution: Actual (global) errors may -C exceed these local tolerances, so choose them -C conservatively. -C -C ITASK :IN Flag indicating the task SLSODE is to perform. -C Use ITASK = 1 for normal computation of output -C values of y at t = TOUT. -C -C ISTATE:INOUT Index used for input and output to specify the state -C of the calculation. -C Input: -C 1 This is the first call for a problem. -C 2 This is a subsequent call. -C Output: -C 1 Nothing was done, as TOUT was equal to T. -C 2 SLSODE was successful (otherwise, negative). -C Note that ISTATE need not be modified after a -C successful return. -C -1 Excess work done on this call (perhaps wrong -C MF). -C -2 Excess accuracy requested (tolerances too -C small). -C -3 Illegal input detected (see printed message). -C -4 Repeated error test failures (check all -C inputs). -C -5 Repeated convergence failures (perhaps bad -C Jacobian supplied or wrong choice of MF or -C tolerances). -C -6 Error weight became zero during problem -C (solution component i vanished, and ATOL or -C ATOL(i) = 0.). -C -C IOPT :IN Flag indicating whether optional inputs are used: -C 0 No. -C 1 Yes. (See "Optional inputs" under "Long -C Description," Part 1.) -C -C RWORK :WORK Real work array of length at least: -C 20 + 16*NEQ for MF = 10, -C 22 + 9*NEQ + NEQ**2 for MF = 21 or 22, -C 22 + 10*NEQ + (2*ML + MU)*NEQ for MF = 24 or 25. -C -C LRW :IN Declared length of RWORK (in user's DIMENSION -C statement). -C -C IWORK :WORK Integer work array of length at least: -C 20 for MF = 10, -C 20 + NEQ for MF = 21, 22, 24, or 25. -C -C If MF = 24 or 25, input in IWORK(1),IWORK(2) the -C lower and upper Jacobian half-bandwidths ML,MU. -C -C On return, IWORK contains information that may be -C of interest to the user: -C -C Name Location Meaning -C ----- --------- ----------------------------------------- -C NST IWORK(11) Number of steps taken for the problem so -C far. -C NFE IWORK(12) Number of f evaluations for the problem -C so far. -C NJE IWORK(13) Number of Jacobian evaluations (and of -C matrix LU decompositions) for the problem -C so far. -C NQU IWORK(14) Method order last used (successfully). -C LENRW IWORK(17) Length of RWORK actually required. This -C is defined on normal returns and on an -C illegal input return for insufficient -C storage. -C LENIW IWORK(18) Length of IWORK actually required. This -C is defined on normal returns and on an -C illegal input return for insufficient -C storage. -C -C LIW :IN Declared length of IWORK (in user's DIMENSION -C statement). -C -C JAC :EXT Name of subroutine for Jacobian matrix (MF = -C 21 or 24). If used, this name must be declared -C EXTERNAL in calling program. If not used, pass a -C dummy name. The form of JAC must be: -C -C SUBROUTINE JAC (NEQ, T, Y, ML, MU, PD, NROWPD) -C INTEGER NEQ, ML, MU, NROWPD -C REAL T, Y(*), PD(NROWPD,*) -C -C See item c, under "Description" below for more -C information about JAC. -C -C MF :IN Method flag. Standard values are: -C 10 Nonstiff (Adams) method, no Jacobian used. -C 21 Stiff (BDF) method, user-supplied full Jacobian. -C 22 Stiff method, internally generated full -C Jacobian. -C 24 Stiff method, user-supplied banded Jacobian. -C 25 Stiff method, internally generated banded -C Jacobian. -C -C *Description: -C SLSODE solves the initial value problem for stiff or nonstiff -C systems of first-order ODE's, -C -C dy/dt = f(t,y) , -C -C or, in component form, -C -C dy(i)/dt = f(i) = f(i,t,y(1),y(2),...,y(NEQ)) -C (i = 1, ..., NEQ) . -C -C SLSODE is a package based on the GEAR and GEARB packages, and on -C the October 23, 1978, version of the tentative ODEPACK user -C interface standard, with minor modifications. -C -C The steps in solving such a problem are as follows. -C -C a. First write a subroutine of the form -C -C SUBROUTINE F (NEQ, T, Y, YDOT) -C INTEGER NEQ -C REAL T, Y(*), YDOT(*) -C -C which supplies the vector function f by loading YDOT(i) with -C f(i). -C -C b. Next determine (or guess) whether or not the problem is stiff. -C Stiffness occurs when the Jacobian matrix df/dy has an -C eigenvalue whose real part is negative and large in magnitude -C compared to the reciprocal of the t span of interest. If the -C problem is nonstiff, use method flag MF = 10. If it is stiff, -C there are four standard choices for MF, and SLSODE requires the -C Jacobian matrix in some form. This matrix is regarded either -C as full (MF = 21 or 22), or banded (MF = 24 or 25). In the -C banded case, SLSODE requires two half-bandwidth parameters ML -C and MU. These are, respectively, the widths of the lower and -C upper parts of the band, excluding the main diagonal. Thus the -C band consists of the locations (i,j) with -C -C i - ML <= j <= i + MU , -C -C and the full bandwidth is ML + MU + 1 . -C -C c. If the problem is stiff, you are encouraged to supply the -C Jacobian directly (MF = 21 or 24), but if this is not feasible, -C SLSODE will compute it internally by difference quotients (MF = -C 22 or 25). If you are supplying the Jacobian, write a -C subroutine of the form -C -C SUBROUTINE JAC (NEQ, T, Y, ML, MU, PD, NROWPD) -C INTEGER NEQ, ML, MU, NRWOPD -C REAL T, Y(*), PD(NROWPD,*) -C -C which provides df/dy by loading PD as follows: -C - For a full Jacobian (MF = 21), load PD(i,j) with df(i)/dy(j), -C the partial derivative of f(i) with respect to y(j). (Ignore -C the ML and MU arguments in this case.) -C - For a banded Jacobian (MF = 24), load PD(i-j+MU+1,j) with -C df(i)/dy(j); i.e., load the diagonal lines of df/dy into the -C rows of PD from the top down. -C - In either case, only nonzero elements need be loaded. -C -C d. Write a main program that calls subroutine SLSODE once for each -C point at which answers are desired. This should also provide -C for possible use of logical unit 6 for output of error messages -C by SLSODE. -C -C Before the first call to SLSODE, set ISTATE = 1, set Y and T to -C the initial values, and set TOUT to the first output point. To -C continue the integration after a successful return, simply -C reset TOUT and call SLSODE again. No other parameters need be -C reset. -C -C *Examples: -C The following is a simple example problem, with the coding needed -C for its solution by SLSODE. The problem is from chemical kinetics, -C and consists of the following three rate equations: -C -C dy1/dt = -.04*y1 + 1.E4*y2*y3 -C dy2/dt = .04*y1 - 1.E4*y2*y3 - 3.E7*y2**2 -C dy3/dt = 3.E7*y2**2 -C -C on the interval from t = 0.0 to t = 4.E10, with initial conditions -C y1 = 1.0, y2 = y3 = 0. The problem is stiff. -C -C The following coding solves this problem with SLSODE, using -C MF = 21 and printing results at t = .4, 4., ..., 4.E10. It uses -C ITOL = 2 and ATOL much smaller for y2 than for y1 or y3 because y2 -C has much smaller values. At the end of the run, statistical -C quantities of interest are printed. -C -C EXTERNAL FEX, JEX -C INTEGER IOPT, IOUT, ISTATE, ITASK, ITOL, IWORK(23), LIW, LRW, -C * MF, NEQ -C REAL ATOL(3), RTOL, RWORK(58), T, TOUT, Y(3) -C NEQ = 3 -C Y(1) = 1. -C Y(2) = 0. -C Y(3) = 0. -C T = 0. -C TOUT = .4 -C ITOL = 2 -C RTOL = 1.E-4 -C ATOL(1) = 1.E-6 -C ATOL(2) = 1.E-10 -C ATOL(3) = 1.E-6 -C ITASK = 1 -C ISTATE = 1 -C IOPT = 0 -C LRW = 58 -C LIW = 23 -C MF = 21 -C DO 40 IOUT = 1,12 -C CALL SLSODE (FEX, NEQ, Y, T, TOUT, ITOL, RTOL, ATOL, ITASK, -C * ISTATE, IOPT, RWORK, LRW, IWORK, LIW, JEX, MF) -C WRITE(6,20) T, Y(1), Y(2), Y(3) -C 20 FORMAT(' At t =',E12.4,' y =',3E14.6) -C IF (ISTATE .LT. 0) GO TO 80 -C 40 TOUT = TOUT*10. -C WRITE(6,60) IWORK(11), IWORK(12), IWORK(13) -C 60 FORMAT(/' No. steps =',i4,', No. f-s =',i4,', No. J-s =',i4) -C STOP -C 80 WRITE(6,90) ISTATE -C 90 FORMAT(///' Error halt.. ISTATE =',I3) -C STOP -C END -C -C SUBROUTINE FEX (NEQ, T, Y, YDOT) -C INTEGER NEQ -C REAL T, Y(3), YDOT(3) -C YDOT(1) = -.04*Y(1) + 1.E4*Y(2)*Y(3) -C YDOT(3) = 3.E7*Y(2)*Y(2) -C YDOT(2) = -YDOT(1) - YDOT(3) -C RETURN -C END -C -C SUBROUTINE JEX (NEQ, T, Y, ML, MU, PD, NRPD) -C INTEGER NEQ, ML, MU, NRPD -C REAL T, Y(3), PD(NRPD,3) -C PD(1,1) = -.04 -C PD(1,2) = 1.E4*Y(3) -C PD(1,3) = 1.E4*Y(2) -C PD(2,1) = .04 -C PD(2,3) = -PD(1,3) -C PD(3,2) = 6.E7*Y(2) -C PD(2,2) = -PD(1,2) - PD(3,2) -C RETURN -C END -C -C The output from this program (on a Cray-1 in single precision) -C is as follows. -C -C At t = 4.0000e-01 y = 9.851726e-01 3.386406e-05 1.479357e-02 -C At t = 4.0000e+00 y = 9.055142e-01 2.240418e-05 9.446344e-02 -C At t = 4.0000e+01 y = 7.158050e-01 9.184616e-06 2.841858e-01 -C At t = 4.0000e+02 y = 4.504846e-01 3.222434e-06 5.495122e-01 -C At t = 4.0000e+03 y = 1.831701e-01 8.940379e-07 8.168290e-01 -C At t = 4.0000e+04 y = 3.897016e-02 1.621193e-07 9.610297e-01 -C At t = 4.0000e+05 y = 4.935213e-03 1.983756e-08 9.950648e-01 -C At t = 4.0000e+06 y = 5.159269e-04 2.064759e-09 9.994841e-01 -C At t = 4.0000e+07 y = 5.306413e-05 2.122677e-10 9.999469e-01 -C At t = 4.0000e+08 y = 5.494530e-06 2.197825e-11 9.999945e-01 -C At t = 4.0000e+09 y = 5.129458e-07 2.051784e-12 9.999995e-01 -C At t = 4.0000e+10 y = -7.170603e-08 -2.868241e-13 1.000000e+00 -C -C No. steps = 330, No. f-s = 405, No. J-s = 69 -C -C *Accuracy: -C The accuracy of the solution depends on the choice of tolerances -C RTOL and ATOL. Actual (global) errors may exceed these local -C tolerances, so choose them conservatively. -C -C *Cautions: -C The work arrays should not be altered between calls to SLSODE for -C the same problem, except possibly for the conditional and optional -C inputs. -C -C *Portability: -C Since NEQ is dimensioned inside SLSODE, some compilers may object -C to a call to SLSODE with NEQ a scalar variable. In this event, -C use DIMENSION NEQ(1). Similar remarks apply to RTOL and ATOL. -C -C Note to Cray users: -C For maximum efficiency, use the CFT77 compiler. Appropriate -C compiler optimization directives have been inserted for CFT77. -C -C *Reference: -C Alan C. Hindmarsh, "ODEPACK, A Systematized Collection of ODE -C Solvers," in Scientific Computing, R. S. Stepleman, et al., Eds. -C (North-Holland, Amsterdam, 1983), pp. 55-64. -C -C *Long Description: -C The following complete description of the user interface to -C SLSODE consists of four parts: -C -C 1. The call sequence to subroutine SLSODE, which is a driver -C routine for the solver. This includes descriptions of both -C the call sequence arguments and user-supplied routines. -C Following these descriptions is a description of optional -C inputs available through the call sequence, and then a -C description of optional outputs in the work arrays. -C -C 2. Descriptions of other routines in the SLSODE package that may -C be (optionally) called by the user. These provide the ability -C to alter error message handling, save and restore the internal -C COMMON, and obtain specified derivatives of the solution y(t). -C -C 3. Descriptions of COMMON block to be declared in overlay or -C similar environments, or to be saved when doing an interrupt -C of the problem and continued solution later. -C -C 4. Description of two routines in the SLSODE package, either of -C which the user may replace with his own version, if desired. -C These relate to the measurement of errors. -C -C -C Part 1. Call Sequence -C ---------------------- -C -C Arguments -C --------- -C The call sequence parameters used for input only are -C -C F, NEQ, TOUT, ITOL, RTOL, ATOL, ITASK, IOPT, LRW, LIW, JAC, MF, -C -C and those used for both input and output are -C -C Y, T, ISTATE. -C -C The work arrays RWORK and IWORK are also used for conditional and -C optional inputs and optional outputs. (The term output here -C refers to the return from subroutine SLSODE to the user's calling -C program.) -C -C The legality of input parameters will be thoroughly checked on the -C initial call for the problem, but not checked thereafter unless a -C change in input parameters is flagged by ISTATE = 3 on input. -C -C The descriptions of the call arguments are as follows. -C -C F The name of the user-supplied subroutine defining the ODE -C system. The system must be put in the first-order form -C dy/dt = f(t,y), where f is a vector-valued function of -C the scalar t and the vector y. Subroutine F is to compute -C the function f. It is to have the form -C -C SUBROUTINE F (NEQ, T, Y, YDOT) -C REAL T, Y(*), YDOT(*) -C -C where NEQ, T, and Y are input, and the array YDOT = -C f(T,Y) is output. Y and YDOT are arrays of length NEQ. -C Subroutine F should not alter Y(1),...,Y(NEQ). F must be -C declared EXTERNAL in the calling program. -C -C Subroutine F may access user-defined quantities in -C NEQ(2),... and/or in Y(NEQ(1)+1),..., if NEQ is an array -C (dimensioned in F) and/or Y has length exceeding NEQ(1). -C See the descriptions of NEQ and Y below. -C -C If quantities computed in the F routine are needed -C externally to SLSODE, an extra call to F should be made -C for this purpose, for consistent and accurate results. -C If only the derivative dy/dt is needed, use SINTDY -C instead. -C -C NEQ The size of the ODE system (number of first-order -C ordinary differential equations). Used only for input. -C NEQ may be decreased, but not increased, during the -C problem. If NEQ is decreased (with ISTATE = 3 on input), -C the remaining components of Y should be left undisturbed, -C if these are to be accessed in F and/or JAC. -C -C Normally, NEQ is a scalar, and it is generally referred -C to as a scalar in this user interface description. -C However, NEQ may be an array, with NEQ(1) set to the -C system size. (The SLSODE package accesses only NEQ(1).) -C In either case, this parameter is passed as the NEQ -C argument in all calls to F and JAC. Hence, if it is an -C array, locations NEQ(2),... may be used to store other -C integer data and pass it to F and/or JAC. Subroutines -C F and/or JAC must include NEQ in a DIMENSION statement -C in that case. -C -C Y A real array for the vector of dependent variables, of -C length NEQ or more. Used for both input and output on -C the first call (ISTATE = 1), and only for output on -C other calls. On the first call, Y must contain the -C vector of initial values. On output, Y contains the -C computed solution vector, evaluated at T. If desired, -C the Y array may be used for other purposes between -C calls to the solver. -C -C This array is passed as the Y argument in all calls to F -C and JAC. Hence its length may exceed NEQ, and locations -C Y(NEQ+1),... may be used to store other real data and -C pass it to F and/or JAC. (The SLSODE package accesses -C only Y(1),...,Y(NEQ).) -C -C T The independent variable. On input, T is used only on -C the first call, as the initial point of the integration. -C On output, after each call, T is the value at which a -C computed solution Y is evaluated (usually the same as -C TOUT). On an error return, T is the farthest point -C reached. -C -C TOUT The next value of T at which a computed solution is -C desired. Used only for input. -C -C When starting the problem (ISTATE = 1), TOUT may be equal -C to T for one call, then should not equal T for the next -C call. For the initial T, an input value of TOUT .NE. T -C is used in order to determine the direction of the -C integration (i.e., the algebraic sign of the step sizes) -C and the rough scale of the problem. Integration in -C either direction (forward or backward in T) is permitted. -C -C If ITASK = 2 or 5 (one-step modes), TOUT is ignored -C after the first call (i.e., the first call with -C TOUT .NE. T). Otherwise, TOUT is required on every call. -C -C If ITASK = 1, 3, or 4, the values of TOUT need not be -C monotone, but a value of TOUT which backs up is limited -C to the current internal T interval, whose endpoints are -C TCUR - HU and TCUR. (See "Optional Outputs" below for -C TCUR and HU.) -C -C -C ITOL An indicator for the type of error control. See -C description below under ATOL. Used only for input. -C -C RTOL A relative error tolerance parameter, either a scalar or -C an array of length NEQ. See description below under -C ATOL. Input only. -C -C ATOL An absolute error tolerance parameter, either a scalar or -C an array of length NEQ. Input only. -C -C The input parameters ITOL, RTOL, and ATOL determine the -C error control performed by the solver. The solver will -C control the vector e = (e(i)) of estimated local errors -C in Y, according to an inequality of the form -C -C rms-norm of ( e(i)/EWT(i) ) <= 1, -C -C where -C -C EWT(i) = RTOL(i)*ABS(Y(i)) + ATOL(i), -C -C and the rms-norm (root-mean-square norm) here is -C -C rms-norm(v) = SQRT(sum v(i)**2 / NEQ). -C -C Here EWT = (EWT(i)) is a vector of weights which must -C always be positive, and the values of RTOL and ATOL -C should all be nonnegative. The following table gives the -C types (scalar/array) of RTOL and ATOL, and the -C corresponding form of EWT(i). -C -C ITOL RTOL ATOL EWT(i) -C ---- ------ ------ ----------------------------- -C 1 scalar scalar RTOL*ABS(Y(i)) + ATOL -C 2 scalar array RTOL*ABS(Y(i)) + ATOL(i) -C 3 array scalar RTOL(i)*ABS(Y(i)) + ATOL -C 4 array array RTOL(i)*ABS(Y(i)) + ATOL(i) -C -C When either of these parameters is a scalar, it need not -C be dimensioned in the user's calling program. -C -C If none of the above choices (with ITOL, RTOL, and ATOL -C fixed throughout the problem) is suitable, more general -C error controls can be obtained by substituting -C user-supplied routines for the setting of EWT and/or for -C the norm calculation. See Part 4 below. -C -C If global errors are to be estimated by making a repeated -C run on the same problem with smaller tolerances, then all -C components of RTOL and ATOL (i.e., of EWT) should be -C scaled down uniformly. -C -C ITASK An index specifying the task to be performed. Input -C only. ITASK has the following values and meanings: -C 1 Normal computation of output values of y(t) at -C t = TOUT (by overshooting and interpolating). -C 2 Take one step only and return. -C 3 Stop at the first internal mesh point at or beyond -C t = TOUT and return. -C 4 Normal computation of output values of y(t) at -C t = TOUT but without overshooting t = TCRIT. TCRIT -C must be input as RWORK(1). TCRIT may be equal to or -C beyond TOUT, but not behind it in the direction of -C integration. This option is useful if the problem -C has a singularity at or beyond t = TCRIT. -C 5 Take one step, without passing TCRIT, and return. -C TCRIT must be input as RWORK(1). -C -C Note: If ITASK = 4 or 5 and the solver reaches TCRIT -C (within roundoff), it will return T = TCRIT (exactly) to -C indicate this (unless ITASK = 4 and TOUT comes before -C TCRIT, in which case answers at T = TOUT are returned -C first). -C -C ISTATE An index used for input and output to specify the state -C of the calculation. -C -C On input, the values of ISTATE are as follows: -C 1 This is the first call for the problem -C (initializations will be done). See "Note" below. -C 2 This is not the first call, and the calculation is to -C continue normally, with no change in any input -C parameters except possibly TOUT and ITASK. (If ITOL, -C RTOL, and/or ATOL are changed between calls with -C ISTATE = 2, the new values will be used but not -C tested for legality.) -C 3 This is not the first call, and the calculation is to -C continue normally, but with a change in input -C parameters other than TOUT and ITASK. Changes are -C allowed in NEQ, ITOL, RTOL, ATOL, IOPT, LRW, LIW, MF, -C ML, MU, and any of the optional inputs except H0. -C (See IWORK description for ML and MU.) -C -C Note: A preliminary call with TOUT = T is not counted as -C a first call here, as no initialization or checking of -C input is done. (Such a call is sometimes useful for the -C purpose of outputting the initial conditions.) Thus the -C first call for which TOUT .NE. T requires ISTATE = 1 on -C input. -C -C On output, ISTATE has the following values and meanings: -C 1 Nothing was done, as TOUT was equal to T with -C ISTATE = 1 on input. -C 2 The integration was performed successfully. -C -1 An excessive amount of work (more than MXSTEP steps) -C was done on this call, before completing the -C requested task, but the integration was otherwise -C successful as far as T. (MXSTEP is an optional input -C and is normally 500.) To continue, the user may -C simply reset ISTATE to a value >1 and call again (the -C excess work step counter will be reset to 0). In -C addition, the user may increase MXSTEP to avoid this -C error return; see "Optional Inputs" below. -C -2 Too much accuracy was requested for the precision of -C the machine being used. This was detected before -C completing the requested task, but the integration -C was successful as far as T. To continue, the -C tolerance parameters must be reset, and ISTATE must -C be set to 3. The optional output TOLSF may be used -C for this purpose. (Note: If this condition is -C detected before taking any steps, then an illegal -C input return (ISTATE = -3) occurs instead.) -C -3 Illegal input was detected, before taking any -C integration steps. See written message for details. -C (Note: If the solver detects an infinite loop of -C calls to the solver with illegal input, it will cause -C the run to stop.) -C -4 There were repeated error-test failures on one -C attempted step, before completing the requested task, -C but the integration was successful as far as T. The -C problem may have a singularity, or the input may be -C inappropriate. -C -5 There were repeated convergence-test failures on one -C attempted step, before completing the requested task, -C but the integration was successful as far as T. This -C may be caused by an inaccurate Jacobian matrix, if -C one is being used. -C -6 EWT(i) became zero for some i during the integration. -C Pure relative error control (ATOL(i)=0.0) was -C requested on a variable which has now vanished. The -C integration was successful as far as T. -C -C Note: Since the normal output value of ISTATE is 2, it -C does not need to be reset for normal continuation. Also, -C since a negative input value of ISTATE will be regarded -C as illegal, a negative output value requires the user to -C change it, and possibly other inputs, before calling the -C solver again. -C -C IOPT An integer flag to specify whether any optional inputs -C are being used on this call. Input only. The optional -C inputs are listed under a separate heading below. -C 0 No optional inputs are being used. Default values -C will be used in all cases. -C 1 One or more optional inputs are being used. -C -C RWORK A real working array (single precision). The length of -C RWORK must be at least -C -C 20 + NYH*(MAXORD + 1) + 3*NEQ + LWM -C -C where -C NYH = the initial value of NEQ, -C MAXORD = 12 (if METH = 1) or 5 (if METH = 2) (unless a -C smaller value is given as an optional input), -C LWM = 0 if MITER = 0, -C LWM = NEQ**2 + 2 if MITER = 1 or 2, -C LWM = NEQ + 2 if MITER = 3, and -C LWM = (2*ML + MU + 1)*NEQ + 2 -C if MITER = 4 or 5. -C (See the MF description below for METH and MITER.) -C -C Thus if MAXORD has its default value and NEQ is constant, -C this length is: -C 20 + 16*NEQ for MF = 10, -C 22 + 16*NEQ + NEQ**2 for MF = 11 or 12, -C 22 + 17*NEQ for MF = 13, -C 22 + 17*NEQ + (2*ML + MU)*NEQ for MF = 14 or 15, -C 20 + 9*NEQ for MF = 20, -C 22 + 9*NEQ + NEQ**2 for MF = 21 or 22, -C 22 + 10*NEQ for MF = 23, -C 22 + 10*NEQ + (2*ML + MU)*NEQ for MF = 24 or 25. -C -C The first 20 words of RWORK are reserved for conditional -C and optional inputs and optional outputs. -C -C The following word in RWORK is a conditional input: -C RWORK(1) = TCRIT, the critical value of t which the -C solver is not to overshoot. Required if ITASK -C is 4 or 5, and ignored otherwise. See ITASK. -C -C LRW The length of the array RWORK, as declared by the user. -C (This will be checked by the solver.) -C -C IWORK An integer work array. Its length must be at least -C 20 if MITER = 0 or 3 (MF = 10, 13, 20, 23), or -C 20 + NEQ otherwise (MF = 11, 12, 14, 15, 21, 22, 24, 25). -C (See the MF description below for MITER.) The first few -C words of IWORK are used for conditional and optional -C inputs and optional outputs. -C -C The following two words in IWORK are conditional inputs: -C IWORK(1) = ML These are the lower and upper half- -C IWORK(2) = MU bandwidths, respectively, of the banded -C Jacobian, excluding the main diagonal. -C The band is defined by the matrix locations -C (i,j) with i - ML <= j <= i + MU. ML and MU -C must satisfy 0 <= ML,MU <= NEQ - 1. These are -C required if MITER is 4 or 5, and ignored -C otherwise. ML and MU may in fact be the band -C parameters for a matrix to which df/dy is only -C approximately equal. -C -C LIW The length of the array IWORK, as declared by the user. -C (This will be checked by the solver.) -C -C Note: The work arrays must not be altered between calls to SLSODE -C for the same problem, except possibly for the conditional and -C optional inputs, and except for the last 3*NEQ words of RWORK. -C The latter space is used for internal scratch space, and so is -C available for use by the user outside SLSODE between calls, if -C desired (but not for use by F or JAC). -C -C JAC The name of the user-supplied routine (MITER = 1 or 4) to -C compute the Jacobian matrix, df/dy, as a function of the -C scalar t and the vector y. (See the MF description below -C for MITER.) It is to have the form -C -C SUBROUTINE JAC (NEQ, T, Y, ML, MU, PD, NROWPD) -C REAL T, Y(*), PD(NROWPD,*) -C -C where NEQ, T, Y, ML, MU, and NROWPD are input and the -C array PD is to be loaded with partial derivatives -C (elements of the Jacobian matrix) on output. PD must be -C given a first dimension of NROWPD. T and Y have the same -C meaning as in subroutine F. -C -C In the full matrix case (MITER = 1), ML and MU are -C ignored, and the Jacobian is to be loaded into PD in -C columnwise manner, with df(i)/dy(j) loaded into PD(i,j). -C -C In the band matrix case (MITER = 4), the elements within -C the band are to be loaded into PD in columnwise manner, -C with diagonal lines of df/dy loaded into the rows of PD. -C Thus df(i)/dy(j) is to be loaded into PD(i-j+MU+1,j). ML -C and MU are the half-bandwidth parameters (see IWORK). -C The locations in PD in the two triangular areas which -C correspond to nonexistent matrix elements can be ignored -C or loaded arbitrarily, as they are overwritten by SLSODE. -C -C JAC need not provide df/dy exactly. A crude approximation -C (possibly with a smaller bandwidth) will do. -C -C In either case, PD is preset to zero by the solver, so -C that only the nonzero elements need be loaded by JAC. -C Each call to JAC is preceded by a call to F with the same -C arguments NEQ, T, and Y. Thus to gain some efficiency, -C intermediate quantities shared by both calculations may -C be saved in a user COMMON block by F and not recomputed -C by JAC, if desired. Also, JAC may alter the Y array, if -C desired. JAC must be declared EXTERNAL in the calling -C program. -C -C Subroutine JAC may access user-defined quantities in -C NEQ(2),... and/or in Y(NEQ(1)+1),... if NEQ is an array -C (dimensioned in JAC) and/or Y has length exceeding -C NEQ(1). See the descriptions of NEQ and Y above. -C -C MF The method flag. Used only for input. The legal values -C of MF are 10, 11, 12, 13, 14, 15, 20, 21, 22, 23, 24, -C and 25. MF has decimal digits METH and MITER: -C MF = 10*METH + MITER . -C -C METH indicates the basic linear multistep method: -C 1 Implicit Adams method. -C 2 Method based on backward differentiation formulas -C (BDF's). -C -C MITER indicates the corrector iteration method: -C 0 Functional iteration (no Jacobian matrix is -C involved). -C 1 Chord iteration with a user-supplied full (NEQ by -C NEQ) Jacobian. -C 2 Chord iteration with an internally generated -C (difference quotient) full Jacobian (using NEQ -C extra calls to F per df/dy value). -C 3 Chord iteration with an internally generated -C diagonal Jacobian approximation (using one extra call -C to F per df/dy evaluation). -C 4 Chord iteration with a user-supplied banded Jacobian. -C 5 Chord iteration with an internally generated banded -C Jacobian (using ML + MU + 1 extra calls to F per -C df/dy evaluation). -C -C If MITER = 1 or 4, the user must supply a subroutine JAC -C (the name is arbitrary) as described above under JAC. -C For other values of MITER, a dummy argument can be used. -C -C Optional Inputs -C --------------- -C The following is a list of the optional inputs provided for in the -C call sequence. (See also Part 2.) For each such input variable, -C this table lists its name as used in this documentation, its -C location in the call sequence, its meaning, and the default value. -C The use of any of these inputs requires IOPT = 1, and in that case -C all of these inputs are examined. A value of zero for any of -C these optional inputs will cause the default value to be used. -C Thus to use a subset of the optional inputs, simply preload -C locations 5 to 10 in RWORK and IWORK to 0.0 and 0 respectively, -C and then set those of interest to nonzero values. -C -C Name Location Meaning and default value -C ------ --------- ----------------------------------------------- -C H0 RWORK(5) Step size to be attempted on the first step. -C The default value is determined by the solver. -C HMAX RWORK(6) Maximum absolute step size allowed. The -C default value is infinite. -C HMIN RWORK(7) Minimum absolute step size allowed. The -C default value is 0. (This lower bound is not -C enforced on the final step before reaching -C TCRIT when ITASK = 4 or 5.) -C MAXORD IWORK(5) Maximum order to be allowed. The default value -C is 12 if METH = 1, and 5 if METH = 2. (See the -C MF description above for METH.) If MAXORD -C exceeds the default value, it will be reduced -C to the default value. If MAXORD is changed -C during the problem, it may cause the current -C order to be reduced. -C MXSTEP IWORK(6) Maximum number of (internally defined) steps -C allowed during one call to the solver. The -C default value is 500. -C MXHNIL IWORK(7) Maximum number of messages printed (per -C problem) warning that T + H = T on a step -C (H = step size). This must be positive to -C result in a nondefault value. The default -C value is 10. -C -C Optional Outputs -C ---------------- -C As optional additional output from SLSODE, the variables listed -C below are quantities related to the performance of SLSODE which -C are available to the user. These are communicated by way of the -C work arrays, but also have internal mnemonic names as shown. -C Except where stated otherwise, all of these outputs are defined on -C any successful return from SLSODE, and on any return with ISTATE = -C -1, -2, -4, -5, or -6. On an illegal input return (ISTATE = -3), -C they will be unchanged from their existing values (if any), except -C possibly for TOLSF, LENRW, and LENIW. On any error return, -C outputs relevant to the error will be defined, as noted below. -C -C Name Location Meaning -C ----- --------- ------------------------------------------------ -C HU RWORK(11) Step size in t last used (successfully). -C HCUR RWORK(12) Step size to be attempted on the next step. -C TCUR RWORK(13) Current value of the independent variable which -C the solver has actually reached, i.e., the -C current internal mesh point in t. On output, -C TCUR will always be at least as far as the -C argument T, but may be farther (if interpolation -C was done). -C TOLSF RWORK(14) Tolerance scale factor, greater than 1.0, -C computed when a request for too much accuracy -C was detected (ISTATE = -3 if detected at the -C start of the problem, ISTATE = -2 otherwise). -C If ITOL is left unaltered but RTOL and ATOL are -C uniformly scaled up by a factor of TOLSF for the -C next call, then the solver is deemed likely to -C succeed. (The user may also ignore TOLSF and -C alter the tolerance parameters in any other way -C appropriate.) -C NST IWORK(11) Number of steps taken for the problem so far. -C NFE IWORK(12) Number of F evaluations for the problem so far. -C NJE IWORK(13) Number of Jacobian evaluations (and of matrix LU -C decompositions) for the problem so far. -C NQU IWORK(14) Method order last used (successfully). -C NQCUR IWORK(15) Order to be attempted on the next step. -C IMXER IWORK(16) Index of the component of largest magnitude in -C the weighted local error vector ( e(i)/EWT(i) ), -C on an error return with ISTATE = -4 or -5. -C LENRW IWORK(17) Length of RWORK actually required. This is -C defined on normal returns and on an illegal -C input return for insufficient storage. -C LENIW IWORK(18) Length of IWORK actually required. This is -C defined on normal returns and on an illegal -C input return for insufficient storage. -C -C The following two arrays are segments of the RWORK array which may -C also be of interest to the user as optional outputs. For each -C array, the table below gives its internal name, its base address -C in RWORK, and its description. -C -C Name Base address Description -C ---- ------------ ---------------------------------------------- -C YH 21 The Nordsieck history array, of size NYH by -C (NQCUR + 1), where NYH is the initial value of -C NEQ. For j = 0,1,...,NQCUR, column j + 1 of -C YH contains HCUR**j/factorial(j) times the jth -C derivative of the interpolating polynomial -C currently representing the solution, evaluated -C at t = TCUR. -C ACOR LENRW-NEQ+1 Array of size NEQ used for the accumulated -C corrections on each step, scaled on output to -C represent the estimated local error in Y on -C the last step. This is the vector e in the -C description of the error control. It is -C defined only on successful return from SLSODE. -C -C -C Part 2. Other Callable Routines -C -------------------------------- -C -C The following are optional calls which the user may make to gain -C additional capabilities in conjunction with SLSODE. -C -C Form of call Function -C ------------------------ ---------------------------------------- -C CALL XSETUN(LUN) Set the logical unit number, LUN, for -C output of messages from SLSODE, if the -C default is not desired. The default -C value of LUN is 6. This call may be made -C at any time and will take effect -C immediately. -C CALL XSETF(MFLAG) Set a flag to control the printing of -C messages by SLSODE. MFLAG = 0 means do -C not print. (Danger: this risks losing -C valuable information.) MFLAG = 1 means -C print (the default). This call may be -C made at any time and will take effect -C immediately. -C CALL SSRCOM(RSAV,ISAV,JOB) Saves and restores the contents of the -C internal COMMON blocks used by SLSODE -C (see Part 3 below). RSAV must be a -C real array of length 218 or more, and -C ISAV must be an integer array of length -C 37 or more. JOB = 1 means save COMMON -C into RSAV/ISAV. JOB = 2 means restore -C COMMON from same. SSRCOM is useful if -C one is interrupting a run and restarting -C later, or alternating between two or -C more problems solved with SLSODE. -C CALL SINTDY(,,,,,) Provide derivatives of y, of various -C (see below) orders, at a specified point t, if -C desired. It may be called only after a -C successful return from SLSODE. Detailed -C instructions follow. -C -C Detailed instructions for using SINTDY -C -------------------------------------- -C The form of the CALL is: -C -C CALL SINTDY (T, K, RWORK(21), NYH, DKY, IFLAG) -C -C The input parameters are: -C -C T Value of independent variable where answers are -C desired (normally the same as the T last returned by -C SLSODE). For valid results, T must lie between -C TCUR - HU and TCUR. (See "Optional Outputs" above -C for TCUR and HU.) -C K Integer order of the derivative desired. K must -C satisfy 0 <= K <= NQCUR, where NQCUR is the current -C order (see "Optional Outputs"). The capability -C corresponding to K = 0, i.e., computing y(t), is -C already provided by SLSODE directly. Since -C NQCUR >= 1, the first derivative dy/dt is always -C available with SINTDY. -C RWORK(21) The base address of the history array YH. -C NYH Column length of YH, equal to the initial value of NEQ. -C -C The output parameters are: -C -C DKY Real array of length NEQ containing the computed value -C of the Kth derivative of y(t). -C IFLAG Integer flag, returned as 0 if K and T were legal, -C -1 if K was illegal, and -2 if T was illegal. -C On an error return, a message is also written. -C -C -C Part 3. Common Blocks -C ---------------------- -C -C If SLSODE is to be used in an overlay situation, the user must -C declare, in the primary overlay, the variables in: -C (1) the call sequence to SLSODE, -C (2) the internal COMMON block /SLS001/, of length 255 -C (218 single precision words followed by 37 integer words). -C -C If SLSODE is used on a system in which the contents of internal -C COMMON blocks are not preserved between calls, the user should -C declare the above COMMON block in his main program to insure that -C its contents are preserved. -C -C If the solution of a given problem by SLSODE is to be interrupted -C and then later continued, as when restarting an interrupted run or -C alternating between two or more problems, the user should save, -C following the return from the last SLSODE call prior to the -C interruption, the contents of the call sequence variables and the -C internal COMMON block, and later restore these values before the -C next SLSODE call for that problem. In addition, if XSETUN and/or -C XSETF was called for non-default handling of error messages, then -C these calls must be repeated. To save and restore the COMMON -C block, use subroutine SSRCOM (see Part 2 above). -C -C -C Part 4. Optionally Replaceable Solver Routines -C ----------------------------------------------- -C -C Below are descriptions of two routines in the SLSODE package which -C relate to the measurement of errors. Either routine can be -C replaced by a user-supplied version, if desired. However, since -C such a replacement may have a major impact on performance, it -C should be done only when absolutely necessary, and only with great -C caution. (Note: The means by which the package version of a -C routine is superseded by the user's version may be system- -C dependent.) -C -C SEWSET -C ------ -C The following subroutine is called just before each internal -C integration step, and sets the array of error weights, EWT, as -C described under ITOL/RTOL/ATOL above: -C -C SUBROUTINE SEWSET (NEQ, ITOL, RTOL, ATOL, YCUR, EWT) -C -C where NEQ, ITOL, RTOL, and ATOL are as in the SLSODE call -C sequence, YCUR contains the current dependent variable vector, -C and EWT is the array of weights set by SEWSET. -C -C If the user supplies this subroutine, it must return in EWT(i) -C (i = 1,...,NEQ) a positive quantity suitable for comparing errors -C in Y(i) to. The EWT array returned by SEWSET is passed to the -C SVNORM routine (see below), and also used by SLSODE in the -C computation of the optional output IMXER, the diagonal Jacobian -C approximation, and the increments for difference quotient -C Jacobians. -C -C In the user-supplied version of SEWSET, it may be desirable to use -C the current values of derivatives of y. Derivatives up to order NQ -C are available from the history array YH, described above under -C optional outputs. In SEWSET, YH is identical to the YCUR array, -C extended to NQ + 1 columns with a column length of NYH and scale -C factors of H**j/factorial(j). On the first call for the problem, -C given by NST = 0, NQ is 1 and H is temporarily set to 1.0. -C NYH is the initial value of NEQ. The quantities NQ, H, and NST -C can be obtained by including in SEWSET the statements: -C REAL RLS -C COMMON /SLS001/ RLS(218),ILS(37) -C NQ = ILS(33) -C NST = ILS(34) -C H = RLS(212) -C Thus, for example, the current value of dy/dt can be obtained as -C YCUR(NYH+i)/H (i=1,...,NEQ) (and the division by H is unnecessary -C when NST = 0). -C -C SVNORM -C ------ -C SVNORM is a real function routine which computes the weighted -C root-mean-square norm of a vector v: -C -C d = SVNORM (n, v, w) -C -C where: -C n = the length of the vector, -C v = real array of length n containing the vector, -C w = real array of length n containing weights, -C d = SQRT( (1/n) * sum(v(i)*w(i))**2 ). -C -C SVNORM is called with n = NEQ and with w(i) = 1.0/EWT(i), where -C EWT is as set by subroutine SEWSET. -C -C If the user supplies this function, it should return a nonnegative -C value of SVNORM suitable for use in the error control in SLSODE. -C None of the arguments should be altered by SVNORM. For example, a -C user-supplied SVNORM routine might: -C - Substitute a max-norm of (v(i)*w(i)) for the rms-norm, or -C - Ignore some components of v in the norm, with the effect of -C suppressing the error control on those components of Y. -C --------------------------------------------------------------------- -C***ROUTINES CALLED SEWSET, SINTDY, R1MACH, SSTODE, SVNORM, XERRWD -C***COMMON BLOCKS SLS001 -C***REVISION HISTORY (YYYYMMDD) -C 19791129 DATE WRITTEN -C 19791213 Minor changes to declarations; DELP init. in STODE. -C 19800118 Treat NEQ as array; integer declarations added throughout; -C minor changes to prologue. -C 19800306 Corrected TESCO(1,NQP1) setting in CFODE. -C 19800519 Corrected access of YH on forced order reduction; -C numerous corrections to prologues and other comments. -C 19800617 In main driver, added loading of SQRT(UROUND) in RWORK; -C minor corrections to main prologue. -C 19800923 Added zero initialization of HU and NQU. -C 19801218 Revised XERRWV routine; minor corrections to main prologue. -C 19810401 Minor changes to comments and an error message. -C 19810814 Numerous revisions: replaced EWT by 1/EWT; used flags -C JCUR, ICF, IERPJ, IERSL between STODE and subordinates; -C added tuning parameters CCMAX, MAXCOR, MSBP, MXNCF; -C reorganized returns from STODE; reorganized type decls.; -C fixed message length in XERRWV; changed default LUNIT to 6; -C changed Common lengths; changed comments throughout. -C 19870330 Major update by ACH: corrected comments throughout; -C removed TRET from Common; rewrote EWSET with 4 loops; -C fixed t test in INTDY; added Cray directives in STODE; -C in STODE, fixed DELP init. and logic around PJAC call; -C combined routines to save/restore Common; -C passed LEVEL = 0 in error message calls (except run abort). -C 19890426 Modified prologue to SLATEC/LDOC format. (FNF) -C 19890501 Many improvements to prologue. (FNF) -C 19890503 A few final corrections to prologue. (FNF) -C 19890504 Minor cosmetic changes. (FNF) -C 19890510 Corrected description of Y in Arguments section. (FNF) -C 19890517 Minor corrections to prologue. (FNF) -C 19920514 Updated with prologue edited 891025 by G. Shaw for manual. -C 19920515 Converted source lines to upper case. (FNF) -C 19920603 Revised XERRWV calls using mixed upper-lower case. (ACH) -C 19920616 Revised prologue comment regarding CFT. (ACH) -C 19921116 Revised prologue comments regarding Common. (ACH). -C 19930326 Added comment about non-reentrancy. (FNF) -C 19930723 Changed R1MACH to RUMACH. (FNF) -C 19930801 Removed ILLIN and NTREP from Common (affects driver logic); -C minor changes to prologue and internal comments; -C changed Hollerith strings to quoted strings; -C changed internal comments to mixed case; -C replaced XERRWV with new version using character type; -C changed dummy dimensions from 1 to *. (ACH) -C 19930809 Changed to generic intrinsic names; changed names of -C subprograms and Common blocks to SLSODE etc. (ACH) -C 19930929 Eliminated use of REAL intrinsic; other minor changes. (ACH) -C 20010412 Removed all 'own' variables from Common block /SLS001/ -C (affects declarations in 6 routines). (ACH) -C 20010509 Minor corrections to prologue. (ACH) -C 20031105 Restored 'own' variables to Common block /SLS001/, to -C enable interrupt/restart feature. (ACH) -C 20031112 Added SAVE statements for data-loaded constants. -C -C*** END PROLOGUE SLSODE -C -C*Internal Notes: -C -C Other Routines in the SLSODE Package. -C -C In addition to Subroutine SLSODE, the SLSODE package includes the -C following subroutines and function routines: -C SINTDY computes an interpolated value of the y vector at t = TOUT. -C SSTODE is the core integrator, which does one step of the -C integration and the associated error control. -C SCFODE sets all method coefficients and test constants. -C SPREPJ computes and preprocesses the Jacobian matrix J = df/dy -C and the Newton iteration matrix P = I - h*l0*J. -C SSOLSY manages solution of linear system in chord iteration. -C SEWSET sets the error weight vector EWT before each step. -C SVNORM computes the weighted R.M.S. norm of a vector. -C SSRCOM is a user-callable routine to save and restore -C the contents of the internal Common block. -C DGETRF AND DGETRS ARE ROUTINES FROM LAPACK FOR SOLVING FULL -C SYSTEMS OF LINEAR ALGEBRAIC EQUATIONS. -C DGBTRF AND DGBTRS ARE ROUTINES FROM LAPACK FOR SOLVING BANDED -C LINEAR SYSTEMS. -C R1MACH computes the unit roundoff in a machine-independent manner. -C XERRWD, XSETUN, XSETF, IXSAV, IUMACH handle the printing of all -C error messages and warnings. XERRWD is machine-dependent. -C Note: SVNORM, R1MACH, IXSAV, and IUMACH are function routines. -C All the others are subroutines. -C -C**End -C -C Declare externals. - EXTERNAL SPREPJ, SSOLSY - REAL R1MACH, SVNORM -C -C Declare all other variables. - INTEGER INIT, MXSTEP, MXHNIL, NHNIL, NSLAST, NYH, - 1 IALTH, IPUP, LMAX, MEO, NQNYH, NSLP, - 1 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, - 2 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, - 3 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU - INTEGER I, I1, I2, IFLAG, IMXER, KGO, LF0, - 1 LENIW, LENRW, LENWM, ML, MORD, MU, MXHNL0, MXSTP0 - REAL CONIT, CRATE, EL, ELCO, HOLD, RMAX, TESCO, - 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND - REAL ATOLI, AYI, BIG, EWTI, H0, HMAX, HMX, RH, RTOLI, - 1 TCRIT, TDIST, TNEXT, TOL, TOLSF, TP, SIZE, SUM, W0 - DIMENSION MORD(2) - LOGICAL IHIT - CHARACTER*80 MSG - SAVE MORD, MXSTP0, MXHNL0 -C----------------------------------------------------------------------- -C The following internal Common block contains -C (a) variables which are local to any subroutine but whose values must -C be preserved between calls to the routine ("own" variables), and -C (b) variables which are communicated between subroutines. -C The block SLS001 is declared in subroutines SLSODE, SINTDY, SSTODE, -C SPREPJ, and SSOLSY. -C Groups of variables are replaced by dummy arrays in the Common -C declarations in routines where those variables are not used. -C----------------------------------------------------------------------- - COMMON /SLS001/ CONIT, CRATE, EL(13), ELCO(13,12), - 1 HOLD, RMAX, TESCO(3,12), - 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, - 2 INIT, MXSTEP, MXHNIL, NHNIL, NSLAST, NYH, - 3 IALTH, IPUP, LMAX, MEO, NQNYH, NSLP, - 3 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, - 4 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, - 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU -C - DATA MORD(1),MORD(2)/12,5/, MXSTP0/500/, MXHNL0/10/ -C----------------------------------------------------------------------- -C Block A. -C This code block is executed on every call. -C It tests ISTATE and ITASK for legality and branches appropriately. -C If ISTATE .GT. 1 but the flag INIT shows that initialization has -C not yet been done, an error return occurs. -C If ISTATE = 1 and TOUT = T, return immediately. -C----------------------------------------------------------------------- -C -C***FIRST EXECUTABLE STATEMENT SLSODE - IF (ISTATE .LT. 1 .OR. ISTATE .GT. 3) GO TO 601 - IF (ITASK .LT. 1 .OR. ITASK .GT. 5) GO TO 602 - IF (ISTATE .EQ. 1) GO TO 10 - IF (INIT .EQ. 0) GO TO 603 - IF (ISTATE .EQ. 2) GO TO 200 - GO TO 20 - 10 INIT = 0 - IF (TOUT .EQ. T) RETURN -C----------------------------------------------------------------------- -C Block B. -C The next code block is executed for the initial call (ISTATE = 1), -C or for a continuation call with parameter changes (ISTATE = 3). -C It contains checking of all inputs and various initializations. -C -C First check legality of the non-optional inputs NEQ, ITOL, IOPT, -C MF, ML, and MU. -C----------------------------------------------------------------------- - 20 IF (NEQ(1) .LE. 0) GO TO 604 - IF (ISTATE .EQ. 1) GO TO 25 - IF (NEQ(1) .GT. N) GO TO 605 - 25 N = NEQ(1) - IF (ITOL .LT. 1 .OR. ITOL .GT. 4) GO TO 606 - IF (IOPT .LT. 0 .OR. IOPT .GT. 1) GO TO 607 - METH = MF/10 - MITER = MF - 10*METH - IF (METH .LT. 1 .OR. METH .GT. 2) GO TO 608 - IF (MITER .LT. 0 .OR. MITER .GT. 5) GO TO 608 - IF (MITER .LE. 3) GO TO 30 - ML = IWORK(1) - MU = IWORK(2) - IF (ML .LT. 0 .OR. ML .GE. N) GO TO 609 - IF (MU .LT. 0 .OR. MU .GE. N) GO TO 610 - 30 CONTINUE -C Next process and check the optional inputs. -------------------------- - IF (IOPT .EQ. 1) GO TO 40 - MAXORD = MORD(METH) - MXSTEP = MXSTP0 - MXHNIL = MXHNL0 - IF (ISTATE .EQ. 1) H0 = 0.0E0 - HMXI = 0.0E0 - HMIN = 0.0E0 - GO TO 60 - 40 MAXORD = IWORK(5) - IF (MAXORD .LT. 0) GO TO 611 - IF (MAXORD .EQ. 0) MAXORD = 100 - MAXORD = MIN(MAXORD,MORD(METH)) - MXSTEP = IWORK(6) - IF (MXSTEP .LT. 0) GO TO 612 - IF (MXSTEP .EQ. 0) MXSTEP = MXSTP0 - MXHNIL = IWORK(7) - IF (MXHNIL .LT. 0) GO TO 613 - IF (MXHNIL .EQ. 0) MXHNIL = MXHNL0 - IF (ISTATE .NE. 1) GO TO 50 - H0 = RWORK(5) - IF ((TOUT - T)*H0 .LT. 0.0E0) GO TO 614 - 50 HMAX = RWORK(6) - IF (HMAX .LT. 0.0E0) GO TO 615 - HMXI = 0.0E0 - IF (HMAX .GT. 0.0E0) HMXI = 1.0E0/HMAX - HMIN = RWORK(7) - IF (HMIN .LT. 0.0E0) GO TO 616 -C----------------------------------------------------------------------- -C Set work array pointers and check lengths LRW and LIW. -C Pointers to segments of RWORK and IWORK are named by prefixing L to -C the name of the segment. E.g., the segment YH starts at RWORK(LYH). -C Segments of RWORK (in order) are denoted YH, WM, EWT, SAVF, ACOR. -C----------------------------------------------------------------------- - 60 LYH = 21 - IF (ISTATE .EQ. 1) NYH = N - LWM = LYH + (MAXORD + 1)*NYH - IF (MITER .EQ. 0) LENWM = 0 - IF (MITER .EQ. 1 .OR. MITER .EQ. 2) LENWM = N*N + 2 - IF (MITER .EQ. 3) LENWM = N + 2 - IF (MITER .GE. 4) LENWM = (2*ML + MU + 1)*N + 2 - LEWT = LWM + LENWM - LSAVF = LEWT + N - LACOR = LSAVF + N - LENRW = LACOR + N - 1 - IWORK(17) = LENRW - LIWM = 1 - LENIW = 20 + N - IF (MITER .EQ. 0 .OR. MITER .EQ. 3) LENIW = 20 - IWORK(18) = LENIW - IF (LENRW .GT. LRW) GO TO 617 - IF (LENIW .GT. LIW) GO TO 618 -C Check RTOL and ATOL for legality. ------------------------------------ - RTOLI = RTOL(1) - ATOLI = ATOL(1) - DO 70 I = 1,N - IF (ITOL .GE. 3) RTOLI = RTOL(I) - IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) ATOLI = ATOL(I) - IF (RTOLI .LT. 0.0E0) GO TO 619 - IF (ATOLI .LT. 0.0E0) GO TO 620 - 70 CONTINUE - IF (ISTATE .EQ. 1) GO TO 100 -C If ISTATE = 3, set flag to signal parameter changes to SSTODE. ------- - JSTART = -1 - IF (NQ .LE. MAXORD) GO TO 90 -C MAXORD was reduced below NQ. Copy YH(*,MAXORD+2) into SAVF. --------- - DO 80 I = 1,N - 80 RWORK(I+LSAVF-1) = RWORK(I+LWM-1) -C Reload WM(1) = RWORK(LWM), since LWM may have changed. --------------- - 90 IF (MITER .GT. 0) RWORK(LWM) = SQRT(UROUND) - IF (N .EQ. NYH) GO TO 200 -C NEQ was reduced. Zero part of YH to avoid undefined references. ----- - I1 = LYH + L*NYH - I2 = LYH + (MAXORD + 1)*NYH - 1 - IF (I1 .GT. I2) GO TO 200 - DO 95 I = I1,I2 - 95 RWORK(I) = 0.0E0 - GO TO 200 -C----------------------------------------------------------------------- -C Block C. -C The next block is for the initial call only (ISTATE = 1). -C It contains all remaining initializations, the initial call to F, -C and the calculation of the initial step size. -C The error weights in EWT are inverted after being loaded. -C----------------------------------------------------------------------- - 100 UROUND = R1MACH(4) - TN = T - IF (ITASK .NE. 4 .AND. ITASK .NE. 5) GO TO 110 - TCRIT = RWORK(1) - IF ((TCRIT - TOUT)*(TOUT - T) .LT. 0.0E0) GO TO 625 - IF (H0 .NE. 0.0E0 .AND. (T + H0 - TCRIT)*H0 .GT. 0.0E0) - 1 H0 = TCRIT - T - 110 JSTART = 0 - IF (MITER .GT. 0) RWORK(LWM) = SQRT(UROUND) - NHNIL = 0 - NST = 0 - NJE = 0 - NSLAST = 0 - HU = 0.0E0 - NQU = 0 - CCMAX = 0.3E0 - MAXCOR = 3 - MSBP = 20 - MXNCF = 10 -C Initial call to F. (LF0 points to YH(*,2).) ------------------------- - LF0 = LYH + NYH - CALL F (NEQ, T, Y, RWORK(LF0)) - NFE = 1 -C Load the initial value vector in YH. --------------------------------- - DO 115 I = 1,N - 115 RWORK(I+LYH-1) = Y(I) -C Load and invert the EWT array. (H is temporarily set to 1.0.) ------- - NQ = 1 - H = 1.0E0 - CALL SEWSET (N, ITOL, RTOL, ATOL, RWORK(LYH), RWORK(LEWT)) - DO 120 I = 1,N - IF (RWORK(I+LEWT-1) .LE. 0.0E0) GO TO 621 - 120 RWORK(I+LEWT-1) = 1.0E0/RWORK(I+LEWT-1) -C----------------------------------------------------------------------- -C The coding below computes the step size, H0, to be attempted on the -C first step, unless the user has supplied a value for this. -C First check that TOUT - T differs significantly from zero. -C A scalar tolerance quantity TOL is computed, as MAX(RTOL(I)) -C if this is positive, or MAX(ATOL(I)/ABS(Y(I))) otherwise, adjusted -C so as to be between 100*UROUND and 1.0E-3. -C Then the computed value H0 is given by.. -C NEQ -C H0**2 = TOL / ( w0**-2 + (1/NEQ) * SUM ( f(i)/ywt(i) )**2 ) -C 1 -C where w0 = MAX ( ABS(T), ABS(TOUT) ), -C f(i) = i-th component of initial value of f, -C ywt(i) = EWT(i)/TOL (a weight for y(i)). -C The sign of H0 is inferred from the initial values of TOUT and T. -C----------------------------------------------------------------------- - IF (H0 .NE. 0.0E0) GO TO 180 - TDIST = ABS(TOUT - T) - W0 = MAX(ABS(T),ABS(TOUT)) - IF (TDIST .LT. 2.0E0*UROUND*W0) GO TO 622 - TOL = RTOL(1) - IF (ITOL .LE. 2) GO TO 140 - DO 130 I = 1,N - 130 TOL = MAX(TOL,RTOL(I)) - 140 IF (TOL .GT. 0.0E0) GO TO 160 - ATOLI = ATOL(1) - DO 150 I = 1,N - IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) ATOLI = ATOL(I) - AYI = ABS(Y(I)) - IF (AYI .NE. 0.0E0) TOL = MAX(TOL,ATOLI/AYI) - 150 CONTINUE - 160 TOL = MAX(TOL,100.0E0*UROUND) - TOL = MIN(TOL,0.001E0) - SUM = SVNORM (N, RWORK(LF0), RWORK(LEWT)) - SUM = 1.0E0/(TOL*W0*W0) + TOL*SUM**2 - H0 = 1.0E0/SQRT(SUM) - H0 = MIN(H0,TDIST) - H0 = SIGN(H0,TOUT-T) -C Adjust H0 if necessary to meet HMAX bound. --------------------------- - 180 RH = ABS(H0)*HMXI - IF (RH .GT. 1.0E0) H0 = H0/RH -C Load H with H0 and scale YH(*,2) by H0. ------------------------------ - H = H0 - DO 190 I = 1,N - 190 RWORK(I+LF0-1) = H0*RWORK(I+LF0-1) - GO TO 270 -C----------------------------------------------------------------------- -C Block D. -C The next code block is for continuation calls only (ISTATE = 2 or 3) -C and is to check stop conditions before taking a step. -C----------------------------------------------------------------------- - 200 NSLAST = NST - GO TO (210, 250, 220, 230, 240), ITASK - 210 IF ((TN - TOUT)*H .LT. 0.0E0) GO TO 250 - CALL SINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) - IF (IFLAG .NE. 0) GO TO 627 - T = TOUT - GO TO 420 - 220 TP = TN - HU*(1.0E0 + 100.0E0*UROUND) - IF ((TP - TOUT)*H .GT. 0.0E0) GO TO 623 - IF ((TN - TOUT)*H .LT. 0.0E0) GO TO 250 - GO TO 400 - 230 TCRIT = RWORK(1) - IF ((TN - TCRIT)*H .GT. 0.0E0) GO TO 624 - IF ((TCRIT - TOUT)*H .LT. 0.0E0) GO TO 625 - IF ((TN - TOUT)*H .LT. 0.0E0) GO TO 245 - CALL SINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) - IF (IFLAG .NE. 0) GO TO 627 - T = TOUT - GO TO 420 - 240 TCRIT = RWORK(1) - IF ((TN - TCRIT)*H .GT. 0.0E0) GO TO 624 - 245 HMX = ABS(TN) + ABS(H) - IHIT = ABS(TN - TCRIT) .LE. 100.0E0*UROUND*HMX - IF (IHIT) GO TO 400 - TNEXT = TN + H*(1.0E0 + 4.0E0*UROUND) - IF ((TNEXT - TCRIT)*H .LE. 0.0E0) GO TO 250 - H = (TCRIT - TN)*(1.0E0 - 4.0E0*UROUND) - IF (ISTATE .EQ. 2) JSTART = -2 -C----------------------------------------------------------------------- -C Block E. -C The next block is normally executed for all calls and contains -C the call to the one-step core integrator SSTODE. -C -C This is a looping point for the integration steps. -C -C First check for too many steps being taken, update EWT (if not at -C start of problem), check for too much accuracy being requested, and -C check for H below the roundoff level in T. -C----------------------------------------------------------------------- - 250 CONTINUE - IF ((NST-NSLAST) .GE. MXSTEP) GO TO 500 - CALL SEWSET (N, ITOL, RTOL, ATOL, RWORK(LYH), RWORK(LEWT)) - DO 260 I = 1,N - IF (RWORK(I+LEWT-1) .LE. 0.0E0) GO TO 510 - 260 RWORK(I+LEWT-1) = 1.0E0/RWORK(I+LEWT-1) - 270 TOLSF = UROUND*SVNORM (N, RWORK(LYH), RWORK(LEWT)) - IF (TOLSF .LE. 1.0E0) GO TO 280 - TOLSF = TOLSF*2.0E0 - IF (NST .EQ. 0) GO TO 626 - GO TO 520 - 280 IF ((TN + H) .NE. TN) GO TO 290 - NHNIL = NHNIL + 1 - IF (NHNIL .GT. MXHNIL) GO TO 290 - CALL XERRWD('SLSODE- Warning..internal T (=R1) and H (=R2) are', - 1 50, 101, 0, 0, 0, 0, 0, 0.0E0, 0.0E0) - CALL XERRWD( - 1 ' such that in the machine, T + H = T on the next step ', - 1 60, 101, 0, 0, 0, 0, 0, 0.0E0, 0.0E0) - CALL XERRWD(' (H = step size). Solver will continue anyway', - 1 50, 101, 0, 0, 0, 0, 2, TN, H) - IF (NHNIL .LT. MXHNIL) GO TO 290 - CALL XERRWD('SLSODE- Above warning has been issued I1 times. ', - 1 50, 102, 0, 0, 0, 0, 0, 0.0E0, 0.0E0) - CALL XERRWD(' It will not be issued again for this problem', - 1 50, 102, 0, 1, MXHNIL, 0, 0, 0.0E0, 0.0E0) - 290 CONTINUE -C----------------------------------------------------------------------- -C CALL SSTODE(NEQ,Y,YH,NYH,YH,EWT,SAVF,ACOR,WM,IWM,F,JAC,SPREPJ,SSOLSY) -C----------------------------------------------------------------------- - CALL SSTODE (NEQ, Y, RWORK(LYH), NYH, RWORK(LYH), RWORK(LEWT), - 1 RWORK(LSAVF), RWORK(LACOR), RWORK(LWM), IWORK(LIWM), - 2 F, JAC, SPREPJ, SSOLSY) - KGO = 1 - KFLAG - GO TO (300, 530, 540), KGO -C----------------------------------------------------------------------- -C Block F. -C The following block handles the case of a successful return from the -C core integrator (KFLAG = 0). Test for stop conditions. -C----------------------------------------------------------------------- - 300 INIT = 1 - GO TO (310, 400, 330, 340, 350), ITASK -C ITASK = 1. If TOUT has been reached, interpolate. ------------------- - 310 IF ((TN - TOUT)*H .LT. 0.0E0) GO TO 250 - CALL SINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) - T = TOUT - GO TO 420 -C ITASK = 3. Jump to exit if TOUT was reached. ------------------------ - 330 IF ((TN - TOUT)*H .GE. 0.0E0) GO TO 400 - GO TO 250 -C ITASK = 4. See if TOUT or TCRIT was reached. Adjust H if necessary. - 340 IF ((TN - TOUT)*H .LT. 0.0E0) GO TO 345 - CALL SINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) - T = TOUT - GO TO 420 - 345 HMX = ABS(TN) + ABS(H) - IHIT = ABS(TN - TCRIT) .LE. 100.0E0*UROUND*HMX - IF (IHIT) GO TO 400 - TNEXT = TN + H*(1.0E0 + 4.0E0*UROUND) - IF ((TNEXT - TCRIT)*H .LE. 0.0E0) GO TO 250 - H = (TCRIT - TN)*(1.0E0 - 4.0E0*UROUND) - JSTART = -2 - GO TO 250 -C ITASK = 5. See if TCRIT was reached and jump to exit. --------------- - 350 HMX = ABS(TN) + ABS(H) - IHIT = ABS(TN - TCRIT) .LE. 100.0E0*UROUND*HMX -C----------------------------------------------------------------------- -C Block G. -C The following block handles all successful returns from SLSODE. -C If ITASK .NE. 1, Y is loaded from YH and T is set accordingly. -C ISTATE is set to 2, and the optional outputs are loaded into the -C work arrays before returning. -C----------------------------------------------------------------------- - 400 DO 410 I = 1,N - 410 Y(I) = RWORK(I+LYH-1) - T = TN - IF (ITASK .NE. 4 .AND. ITASK .NE. 5) GO TO 420 - IF (IHIT) T = TCRIT - 420 ISTATE = 2 - RWORK(11) = HU - RWORK(12) = H - RWORK(13) = TN - IWORK(11) = NST - IWORK(12) = NFE - IWORK(13) = NJE - IWORK(14) = NQU - IWORK(15) = NQ - RETURN -C----------------------------------------------------------------------- -C Block H. -C The following block handles all unsuccessful returns other than -C those for illegal input. First the error message routine is called. -C If there was an error test or convergence test failure, IMXER is set. -C Then Y is loaded from YH and T is set to TN. The optional outputs -C are loaded into the work arrays before returning. -C----------------------------------------------------------------------- -C The maximum number of steps was taken before reaching TOUT. ---------- - 500 CALL XERRWD('SLSODE- At current T (=R1), MXSTEP (=I1) steps ', - 1 50, 201, 0, 0, 0, 0, 0, 0.0E0, 0.0E0) - CALL XERRWD(' taken on this call before reaching TOUT ', - 1 50, 201, 0, 1, MXSTEP, 0, 1, TN, 0.0E0) - ISTATE = -1 - GO TO 580 -C EWT(I) .LE. 0.0 for some I (not at start of problem). ---------------- - 510 EWTI = RWORK(LEWT+I-1) - CALL XERRWD('SLSODE- At T (=R1), EWT(I1) has become R2 .LE. 0.', - 1 50, 202, 0, 1, I, 0, 2, TN, EWTI) - ISTATE = -6 - GO TO 580 -C Too much accuracy requested for machine precision. ------------------- - 520 CALL XERRWD('SLSODE- At T (=R1), too much accuracy requested ', - 1 50, 203, 0, 0, 0, 0, 0, 0.0E0, 0.0E0) - CALL XERRWD(' for precision of machine.. see TOLSF (=R2) ', - 1 50, 203, 0, 0, 0, 0, 2, TN, TOLSF) - RWORK(14) = TOLSF - ISTATE = -2 - GO TO 580 -C KFLAG = -1. Error test failed repeatedly or with ABS(H) = HMIN. ----- - 530 CALL XERRWD('SLSODE- At T(=R1) and step size H(=R2), the error', - 1 50, 204, 0, 0, 0, 0, 0, 0.0E0, 0.0E0) - CALL XERRWD(' test failed repeatedly or with ABS(H) = HMIN', - 1 50, 204, 0, 0, 0, 0, 2, TN, H) - ISTATE = -4 - GO TO 560 -C KFLAG = -2. Convergence failed repeatedly or with ABS(H) = HMIN. ---- - 540 CALL XERRWD('SLSODE- At T (=R1) and step size H (=R2), the ', - 1 50, 205, 0, 0, 0, 0, 0, 0.0E0, 0.0E0) - CALL XERRWD(' corrector convergence failed repeatedly ', - 1 50, 205, 0, 0, 0, 0, 0, 0.0E0, 0.0E0) - CALL XERRWD(' or with ABS(H) = HMIN ', - 1 30, 205, 0, 0, 0, 0, 2, TN, H) - ISTATE = -5 -C Compute IMXER if relevant. ------------------------------------------- - 560 BIG = 0.0E0 - IMXER = 1 - DO 570 I = 1,N - SIZE = ABS(RWORK(I+LACOR-1)*RWORK(I+LEWT-1)) - IF (BIG .GE. SIZE) GO TO 570 - BIG = SIZE - IMXER = I - 570 CONTINUE - IWORK(16) = IMXER -C Set Y vector, T, and optional outputs. ------------------------------- - 580 DO 590 I = 1,N - 590 Y(I) = RWORK(I+LYH-1) - T = TN - RWORK(11) = HU - RWORK(12) = H - RWORK(13) = TN - IWORK(11) = NST - IWORK(12) = NFE - IWORK(13) = NJE - IWORK(14) = NQU - IWORK(15) = NQ - RETURN -C----------------------------------------------------------------------- -C Block I. -C The following block handles all error returns due to illegal input -C (ISTATE = -3), as detected before calling the core integrator. -C First the error message routine is called. If the illegal input -C is a negative ISTATE, the run is aborted (apparent infinite loop). -C----------------------------------------------------------------------- - 601 CALL XERRWD('SLSODE- ISTATE (=I1) illegal ', - 1 30, 1, 0, 1, ISTATE, 0, 0, 0.0E0, 0.0E0) - IF (ISTATE .LT. 0) GO TO 800 - GO TO 700 - 602 CALL XERRWD('SLSODE- ITASK (=I1) illegal ', - 1 30, 2, 0, 1, ITASK, 0, 0, 0.0E0, 0.0E0) - GO TO 700 - 603 CALL XERRWD('SLSODE- ISTATE .GT. 1 but SLSODE not initialized ', - 1 50, 3, 0, 0, 0, 0, 0, 0.0E0, 0.0E0) - GO TO 700 - 604 CALL XERRWD('SLSODE- NEQ (=I1) .LT. 1 ', - 1 30, 4, 0, 1, NEQ(1), 0, 0, 0.0E0, 0.0E0) - GO TO 700 - 605 CALL XERRWD('SLSODE- ISTATE = 3 and NEQ increased (I1 to I2) ', - 1 50, 5, 0, 2, N, NEQ(1), 0, 0.0E0, 0.0E0) - GO TO 700 - 606 CALL XERRWD('SLSODE- ITOL (=I1) illegal ', - 1 30, 6, 0, 1, ITOL, 0, 0, 0.0E0, 0.0E0) - GO TO 700 - 607 CALL XERRWD('SLSODE- IOPT (=I1) illegal ', - 1 30, 7, 0, 1, IOPT, 0, 0, 0.0E0, 0.0E0) - GO TO 700 - 608 CALL XERRWD('SLSODE- MF (=I1) illegal ', - 1 30, 8, 0, 1, MF, 0, 0, 0.0E0, 0.0E0) - GO TO 700 - 609 CALL XERRWD('SLSODE- ML (=I1) illegal.. .LT.0 or .GE.NEQ (=I2)', - 1 50, 9, 0, 2, ML, NEQ(1), 0, 0.0E0, 0.0E0) - GO TO 700 - 610 CALL XERRWD('SLSODE- MU (=I1) illegal.. .LT.0 or .GE.NEQ (=I2)', - 1 50, 10, 0, 2, MU, NEQ(1), 0, 0.0E0, 0.0E0) - GO TO 700 - 611 CALL XERRWD('SLSODE- MAXORD (=I1) .LT. 0 ', - 1 30, 11, 0, 1, MAXORD, 0, 0, 0.0E0, 0.0E0) - GO TO 700 - 612 CALL XERRWD('SLSODE- MXSTEP (=I1) .LT. 0 ', - 1 30, 12, 0, 1, MXSTEP, 0, 0, 0.0E0, 0.0E0) - GO TO 700 - 613 CALL XERRWD('SLSODE- MXHNIL (=I1) .LT. 0 ', - 1 30, 13, 0, 1, MXHNIL, 0, 0, 0.0E0, 0.0E0) - GO TO 700 - 614 CALL XERRWD('SLSODE- TOUT (=R1) behind T (=R2) ', - 1 40, 14, 0, 0, 0, 0, 2, TOUT, T) - CALL XERRWD(' Integration direction is given by H0 (=R1) ', - 1 50, 14, 0, 0, 0, 0, 1, H0, 0.0E0) - GO TO 700 - 615 CALL XERRWD('SLSODE- HMAX (=R1) .LT. 0.0 ', - 1 30, 15, 0, 0, 0, 0, 1, HMAX, 0.0E0) - GO TO 700 - 616 CALL XERRWD('SLSODE- HMIN (=R1) .LT. 0.0 ', - 1 30, 16, 0, 0, 0, 0, 1, HMIN, 0.0E0) - GO TO 700 - 617 CALL XERRWD( - 1 'SLSODE- RWORK length needed, LENRW (=I1), exceeds LRW (=I2)', - 1 60, 17, 0, 2, LENRW, LRW, 0, 0.0E0, 0.0E0) - GO TO 700 - 618 CALL XERRWD( - 1 'SLSODE- IWORK length needed, LENIW (=I1), exceeds LIW (=I2)', - 1 60, 18, 0, 2, LENIW, LIW, 0, 0.0E0, 0.0E0) - GO TO 700 - 619 CALL XERRWD('SLSODE- RTOL(I1) is R1 .LT. 0.0 ', - 1 40, 19, 0, 1, I, 0, 1, RTOLI, 0.0E0) - GO TO 700 - 620 CALL XERRWD('SLSODE- ATOL(I1) is R1 .LT. 0.0 ', - 1 40, 20, 0, 1, I, 0, 1, ATOLI, 0.0E0) - GO TO 700 - 621 EWTI = RWORK(LEWT+I-1) - CALL XERRWD('SLSODE- EWT(I1) is R1 .LE. 0.0 ', - 1 40, 21, 0, 1, I, 0, 1, EWTI, 0.0E0) - GO TO 700 - 622 CALL XERRWD( - 1 'SLSODE- TOUT (=R1) too close to T(=R2) to start integration', - 1 60, 22, 0, 0, 0, 0, 2, TOUT, T) - GO TO 700 - 623 CALL XERRWD( - 1 'SLSODE- ITASK = I1 and TOUT (=R1) behind TCUR - HU (= R2) ', - 1 60, 23, 0, 1, ITASK, 0, 2, TOUT, TP) - GO TO 700 - 624 CALL XERRWD( - 1 'SLSODE- ITASK = 4 OR 5 and TCRIT (=R1) behind TCUR (=R2) ', - 1 60, 24, 0, 0, 0, 0, 2, TCRIT, TN) - GO TO 700 - 625 CALL XERRWD( - 1 'SLSODE- ITASK = 4 or 5 and TCRIT (=R1) behind TOUT (=R2) ', - 1 60, 25, 0, 0, 0, 0, 2, TCRIT, TOUT) - GO TO 700 - 626 CALL XERRWD('SLSODE- At start of problem, too much accuracy ', - 1 50, 26, 0, 0, 0, 0, 0, 0.0E0, 0.0E0) - CALL XERRWD( - 1 ' requested for precision of machine.. See TOLSF (=R1) ', - 1 60, 26, 0, 0, 0, 0, 1, TOLSF, 0.0E0) - RWORK(14) = TOLSF - GO TO 700 - 627 CALL XERRWD('SLSODE- Trouble in SINTDY. ITASK = I1, TOUT = R1', - 1 50, 27, 0, 1, ITASK, 0, 1, TOUT, 0.0E0) -C - 700 ISTATE = -3 - RETURN -C - 800 CALL XERRWD('SLSODE- Run aborted.. apparent infinite loop ', - 1 50, 303, 2, 0, 0, 0, 0, 0.0E0, 0.0E0) - RETURN -C----------------------- END OF SUBROUTINE SLSODE ---------------------- - END
--- a/liboctave/cruft/odepack/solsy.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,74 +0,0 @@ - SUBROUTINE SOLSY (WM, IWM, X, TEM) -CLLL. OPTIMIZE - INTEGER IWM - INTEGER ILLIN, INIT, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, - 1 MXSTEP, MXHNIL, NHNIL, NTREP, NSLAST, NYH, - 2 IALTH, IPUP, LMAX, MEO, NQNYH, NSLP - INTEGER ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, METH, MITER, - 2 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU - INTEGER I, MEBAND, ML, MU - DOUBLE PRECISION WM, X, TEM - DOUBLE PRECISION CONIT, CRATE, EL, ELCO, HOLD, RMAX, TESCO, - 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND - DOUBLE PRECISION DI, HL0, PHL0, R - DIMENSION WM(*), IWM(*), X(*), TEM(*) - COMMON /LS0001/ CONIT, CRATE, EL(13), ELCO(13,12), - 1 HOLD, RMAX, TESCO(3,12), - 2 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, - 2 ILLIN, INIT, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, - 3 MXSTEP, MXHNIL, NHNIL, NTREP, NSLAST, NYH, - 3 IALTH, IPUP, LMAX, MEO, NQNYH, NSLP, - 4 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, METH, MITER, - 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU -C----------------------------------------------------------------------- -C THIS ROUTINE MANAGES THE SOLUTION OF THE LINEAR SYSTEM ARISING FROM -C A CHORD ITERATION. IT IS CALLED IF MITER .NE. 0. -C IF MITER IS 1 OR 2, IT CALLS DGETRS TO ACCOMPLISH THIS. -C IF MITER = 3 IT UPDATES THE COEFFICIENT H*EL0 IN THE DIAGONAL -C MATRIX, AND THEN COMPUTES THE SOLUTION. -C IF MITER IS 4 OR 5, IT CALLS DGBTRS. -C COMMUNICATION WITH SOLSY USES THE FOLLOWING VARIABLES.. -C WM = REAL WORK SPACE CONTAINING THE INVERSE DIAGONAL MATRIX IF -C MITER = 3 AND THE LU DECOMPOSITION OF THE MATRIX OTHERWISE. -C STORAGE OF MATRIX ELEMENTS STARTS AT WM(3). -C WM ALSO CONTAINS THE FOLLOWING MATRIX-RELATED DATA.. -C WM(1) = SQRT(UROUND) (NOT USED HERE), -C WM(2) = HL0, THE PREVIOUS VALUE OF H*EL0, USED IF MITER = 3. -C IWM = INTEGER WORK SPACE CONTAINING PIVOT INFORMATION, STARTING AT -C IWM(21), IF MITER IS 1, 2, 4, OR 5. IWM ALSO CONTAINS BAND -C PARAMETERS ML = IWM(1) AND MU = IWM(2) IF MITER IS 4 OR 5. -C X = THE RIGHT-HAND SIDE VECTOR ON INPUT, AND THE SOLUTION VECTOR -C ON OUTPUT, OF LENGTH N. -C TEM = VECTOR OF WORK SPACE OF LENGTH N, NOT USED IN THIS VERSION. -C IERSL = OUTPUT FLAG (IN COMMON). IERSL = 0 IF NO TROUBLE OCCURRED. -C IERSL = 1 IF A SINGULAR MATRIX AROSE WITH MITER = 3. -C THIS ROUTINE ALSO USES THE COMMON VARIABLES EL0, H, MITER, AND N. -C----------------------------------------------------------------------- - IERSL = 0 - GO TO (100, 100, 300, 400, 400), MITER - 100 CALL DGETRS ( 'N', N, 1, WM(3), N, IWM(21), X, N, INLPCK) - RETURN -C - 300 PHL0 = WM(2) - HL0 = H*EL0 - WM(2) = HL0 - IF (HL0 .EQ. PHL0) GO TO 330 - R = HL0/PHL0 - DO 320 I = 1,N - DI = 1.0D0 - R*(1.0D0 - 1.0D0/WM(I+2)) - IF (DABS(DI) .EQ. 0.0D0) GO TO 390 - 320 WM(I+2) = 1.0D0/DI - 330 DO 340 I = 1,N - 340 X(I) = WM(I+2)*X(I) - RETURN - 390 IERSL = 1 - RETURN -C - 400 ML = IWM(1) - MU = IWM(2) - MEBAND = 2*ML + MU + 1 - CALL DGBTRS ( 'N', N, ML, MU, 1, WM(3), MEBAND, IWM(21), X, N, - * INLPCK) - RETURN -C----------------------- END OF SUBROUTINE SOLSY ----------------------- - END
--- a/liboctave/cruft/odepack/sprepj.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,196 +0,0 @@ - SUBROUTINE SPREPJ (NEQ, Y, YH, NYH, EWT, FTEM, SAVF, WM, IWM, - 1 F, JAC) -C***BEGIN PROLOGUE SPREPJ -C***SUBSIDIARY -C***PURPOSE Compute and process Newton iteration matrix. -C***TYPE SINGLE PRECISION (SPREPJ-S, DPREPJ-D) -C***AUTHOR Hindmarsh, Alan C., (LLNL) -C***DESCRIPTION -C -C SPREPJ is called by SSTODE to compute and process the matrix -C P = I - h*el(1)*J , where J is an approximation to the Jacobian. -C Here J is computed by the user-supplied routine JAC if -C MITER = 1 or 4, or by finite differencing if MITER = 2, 3, or 5. -C If MITER = 3, a diagonal approximation to J is used. -C J is stored in WM and replaced by P. If MITER .ne. 3, P is then -C subjected to LU decomposition in preparation for later solution -C of linear systems with P as coefficient matrix. This is done -C by SGETRF if MITER = 1 or 2, and by SGBTRF if MITER = 4 or 5. -C -C In addition to variables described in SSTODE and SLSODE prologues, -C communication with SPREPJ uses the following: -C Y = array containing predicted values on entry. -C FTEM = work array of length N (ACOR in SSTODE). -C SAVF = array containing f evaluated at predicted y. -C WM = real work space for matrices. On output it contains the -C inverse diagonal matrix if MITER = 3 and the LU decomposition -C of P if MITER is 1, 2 , 4, or 5. -C Storage of matrix elements starts at WM(3). -C WM also contains the following matrix-related data: -C WM(1) = SQRT(UROUND), used in numerical Jacobian increments. -C WM(2) = H*EL0, saved for later use if MITER = 3. -C IWM = integer work space containing pivot information, starting at -C IWM(21), if MITER is 1, 2, 4, or 5. IWM also contains band -C parameters ML = IWM(1) and MU = IWM(2) if MITER is 4 or 5. -C EL0 = EL(1) (input). -C IERPJ = output error flag, = 0 if no trouble, .gt. 0 if -C P matrix found to be singular. -C JCUR = output flag = 1 to indicate that the Jacobian matrix -C (or approximation) is now current. -C This routine also uses the COMMON variables EL0, H, TN, UROUND, -C MITER, N, NFE, and NJE. -C -C***SEE ALSO SLSODE -C***ROUTINES CALLED SGBTRF, SGETRF, SVNORM -C***COMMON BLOCKS SLS001 -C***REVISION HISTORY (YYMMDD) -C 791129 DATE WRITTEN -C 890501 Modified prologue to SLATEC/LDOC format. (FNF) -C 890504 Minor cosmetic changes. (FNF) -C 930809 Renamed to allow single/double precision versions. (ACH) -C 010412 Reduced size of Common block /SLS001/. (ACH) -C 031105 Restored 'own' variables to Common block /SLS001/, to -C enable interrupt/restart feature. (ACH) -C***END PROLOGUE SPREPJ -C**End - EXTERNAL F, JAC - INTEGER NEQ, NYH, IWM - REAL Y, YH, EWT, FTEM, SAVF, WM - DIMENSION NEQ(*), Y(*), YH(NYH,*), EWT(*), FTEM(*), SAVF(*), - 1 WM(*), IWM(*) - INTEGER INIT, MXSTEP, MXHNIL, NHNIL, NSLAST, CNYH, - 1 IALTH, IPUP, LMAX, MEO, NQNYH, NSLP, - 1 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, - 2 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, - 3 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU - REAL CONIT, CRATE, EL, ELCO, HOLD, RMAX, TESCO, - 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND - COMMON /SLS001/ CONIT, CRATE, EL(13), ELCO(13,12), - 1 HOLD, RMAX, TESCO(3,12), - 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, - 2 INIT, MXSTEP, MXHNIL, NHNIL, NSLAST, CNYH, - 3 IALTH, IPUP, LMAX, MEO, NQNYH, NSLP, - 3 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, - 4 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, - 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU - INTEGER I, I1, I2, IER, II, J, J1, JJ, LENP, - 1 MBA, MBAND, MEB1, MEBAND, ML, ML3, MU, NP1 - REAL CON, DI, FAC, HL0, R, R0, SRUR, YI, YJ, YJJ, - 1 SVNORM -C -C***FIRST EXECUTABLE STATEMENT SPREPJ - NJE = NJE + 1 - IERPJ = 0 - JCUR = 1 - HL0 = H*EL0 - GO TO (100, 200, 300, 400, 500), MITER -C If MITER = 1, call JAC and multiply by scalar. ----------------------- - 100 LENP = N*N - DO 110 I = 1,LENP - 110 WM(I+2) = 0.0E0 - CALL JAC (NEQ, TN, Y, 0, 0, WM(3), N) - CON = -HL0 - DO 120 I = 1,LENP - 120 WM(I+2) = WM(I+2)*CON - GO TO 240 -C If MITER = 2, make N calls to F to approximate J. -------------------- - 200 FAC = SVNORM (N, SAVF, EWT) - R0 = 1000.0E0*ABS(H)*UROUND*N*FAC - IF (R0 .EQ. 0.0E0) R0 = 1.0E0 - SRUR = WM(1) - J1 = 2 - DO 230 J = 1,N - YJ = Y(J) - R = MAX(SRUR*ABS(YJ),R0/EWT(J)) - Y(J) = Y(J) + R - FAC = -HL0/R - CALL F (NEQ, TN, Y, FTEM) - DO 220 I = 1,N - 220 WM(I+J1) = (FTEM(I) - SAVF(I))*FAC - Y(J) = YJ - J1 = J1 + N - 230 CONTINUE - NFE = NFE + N -C Add identity matrix. ------------------------------------------------- - 240 J = 3 - NP1 = N + 1 - DO 250 I = 1,N - WM(J) = WM(J) + 1.0E0 - 250 J = J + NP1 -C Do LU decomposition on P. -------------------------------------------- - CALL SGETRF (N, N, WM(3), N, IWM(21), IER) - IF (IER .NE. 0) IERPJ = 1 - RETURN -C If MITER = 3, construct a diagonal approximation to J and P. --------- - 300 WM(2) = HL0 - R = EL0*0.1E0 - DO 310 I = 1,N - 310 Y(I) = Y(I) + R*(H*SAVF(I) - YH(I,2)) - CALL F (NEQ, TN, Y, WM(3)) - NFE = NFE + 1 - DO 320 I = 1,N - R0 = H*SAVF(I) - YH(I,2) - DI = 0.1E0*R0 - H*(WM(I+2) - SAVF(I)) - WM(I+2) = 1.0E0 - IF (ABS(R0) .LT. UROUND/EWT(I)) GO TO 320 - IF (ABS(DI) .EQ. 0.0E0) GO TO 330 - WM(I+2) = 0.1E0*R0/DI - 320 CONTINUE - RETURN - 330 IERPJ = 1 - RETURN -C If MITER = 4, call JAC and multiply by scalar. ----------------------- - 400 ML = IWM(1) - MU = IWM(2) - ML3 = ML + 3 - MBAND = ML + MU + 1 - MEBAND = MBAND + ML - LENP = MEBAND*N - DO 410 I = 1,LENP - 410 WM(I+2) = 0.0E0 - CALL JAC (NEQ, TN, Y, ML, MU, WM(ML3), MEBAND) - CON = -HL0 - DO 420 I = 1,LENP - 420 WM(I+2) = WM(I+2)*CON - GO TO 570 -C If MITER = 5, make MBAND calls to F to approximate J. ---------------- - 500 ML = IWM(1) - MU = IWM(2) - MBAND = ML + MU + 1 - MBA = MIN(MBAND,N) - MEBAND = MBAND + ML - MEB1 = MEBAND - 1 - SRUR = WM(1) - FAC = SVNORM (N, SAVF, EWT) - R0 = 1000.0E0*ABS(H)*UROUND*N*FAC - IF (R0 .EQ. 0.0E0) R0 = 1.0E0 - DO 560 J = 1,MBA - DO 530 I = J,N,MBAND - YI = Y(I) - R = MAX(SRUR*ABS(YI),R0/EWT(I)) - 530 Y(I) = Y(I) + R - CALL F (NEQ, TN, Y, FTEM) - DO 550 JJ = J,N,MBAND - Y(JJ) = YH(JJ,1) - YJJ = Y(JJ) - R = MAX(SRUR*ABS(YJJ),R0/EWT(JJ)) - FAC = -HL0/R - I1 = MAX(JJ-MU,1) - I2 = MIN(JJ+ML,N) - II = JJ*MEB1 - ML + 2 - DO 540 I = I1,I2 - 540 WM(II+I) = (FTEM(I) - SAVF(I))*FAC - 550 CONTINUE - 560 CONTINUE - NFE = NFE + MBA -C Add identity matrix. ------------------------------------------------- - 570 II = MBAND + 2 - DO 580 I = 1,N - WM(II) = WM(II) + 1.0E0 - 580 II = II + MEBAND -C Do LU decomposition of P. -------------------------------------------- - CALL SGBTRF ( N, N, ML, MU, WM(3), MEBAND, IWM(21), IER) - IF (IER .NE. 0) IERPJ = 1 - RETURN -C----------------------- END OF SUBROUTINE SPREPJ ---------------------- - END
--- a/liboctave/cruft/odepack/ssolsy.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,94 +0,0 @@ - SUBROUTINE SSOLSY (WM, IWM, X, TEM) -C***BEGIN PROLOGUE SSOLSY -C***SUBSIDIARY -C***PURPOSE ODEPACK linear system solver. -C***TYPE SINGLE PRECISION (SSOLSY-S, DSOLSY-D) -C***AUTHOR Hindmarsh, Alan C., (LLNL) -C***DESCRIPTION -C -C This routine manages the solution of the linear system arising from -C a chord iteration. It is called if MITER .ne. 0. -C If MITER is 1 or 2, it calls SGETRF to accomplish this. -C If MITER = 3 it updates the coefficient h*EL0 in the diagonal -C matrix, and then computes the solution. -C If MITER is 4 or 5, it calls SGBTRS. -C Communication with SSOLSY uses the following variables: -C WM = real work space containing the inverse diagonal matrix if -C MITER = 3 and the LU decomposition of the matrix otherwise. -C Storage of matrix elements starts at WM(3). -C WM also contains the following matrix-related data: -C WM(1) = SQRT(UROUND) (not used here), -C WM(2) = HL0, the previous value of h*EL0, used if MITER = 3. -C IWM = integer work space containing pivot information, starting at -C IWM(21), if MITER is 1, 2, 4, or 5. IWM also contains band -C parameters ML = IWM(1) and MU = IWM(2) if MITER is 4 or 5. -C X = the right-hand side vector on input, and the solution vector -C on output, of length N. -C TEM = vector of work space of length N, not used in this version. -C IERSL = output flag (in COMMON). IERSL = 0 if no trouble occurred. -C IERSL = 1 if a singular matrix arose with MITER = 3. -C This routine also uses the COMMON variables EL0, H, MITER, and N. -C -C***SEE ALSO SLSODE -C***ROUTINES CALLED SGBTRS, SGETRS -C***COMMON BLOCKS SLS001 -C***REVISION HISTORY (YYMMDD) -C 791129 DATE WRITTEN -C 890501 Modified prologue to SLATEC/LDOC format. (FNF) -C 890503 Minor cosmetic changes. (FNF) -C 930809 Renamed to allow single/double precision versions. (ACH) -C 010412 Reduced size of Common block /SLS001/. (ACH) -C 031105 Restored 'own' variables to Common block /SLS001/, to -C enable interrupt/restart feature. (ACH) -C***END PROLOGUE SSOLSY -C**End - INTEGER IWM - REAL WM, X, TEM - DIMENSION WM(*), IWM(*), X(*), TEM(*) - INTEGER INIT, MXSTEP, MXHNIL, NHNIL, NSLAST, NYH, - 1 IALTH, IPUP, LMAX, MEO, NQNYH, NSLP, - 1 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, - 2 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, - 3 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU - REAL CONIT, CRATE, EL, ELCO, HOLD, RMAX, TESCO, - 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND - COMMON /SLS001/ CONIT, CRATE, EL(13), ELCO(13,12), - 1 HOLD, RMAX, TESCO(3,12), - 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, - 2 INIT, MXSTEP, MXHNIL, NHNIL, NSLAST, NYH, - 3 IALTH, IPUP, LMAX, MEO, NQNYH, NSLP, - 3 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, - 4 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, - 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU - INTEGER I, MEBAND, ML, MU - REAL DI, HL0, PHL0, R -C -C***FIRST EXECUTABLE STATEMENT SSOLSY - IERSL = 0 - GO TO (100, 100, 300, 400, 400), MITER - 100 CALL SGETRS ( 'N', N, 1, WM(3), N, IWM(21), X, N, INLPCK) - RETURN -C - 300 PHL0 = WM(2) - HL0 = H*EL0 - WM(2) = HL0 - IF (HL0 .EQ. PHL0) GO TO 330 - R = HL0/PHL0 - DO 320 I = 1,N - DI = 1.0E0 - R*(1.0E0 - 1.0E0/WM(I+2)) - IF (ABS(DI) .EQ. 0.0E0) GO TO 390 - 320 WM(I+2) = 1.0E0/DI - 330 DO 340 I = 1,N - 340 X(I) = WM(I+2)*X(I) - RETURN - 390 IERSL = 1 - RETURN -C - 400 ML = IWM(1) - MU = IWM(2) - MEBAND = 2*ML + MU + 1 - CALL SGBTRS ( 'N', N, ML, MU, 1, WM(3), MEBAND, IWM(21), X, N, - * INLPCK) - RETURN -C----------------------- END OF SUBROUTINE SSOLSY ---------------------- - END
--- a/liboctave/cruft/odepack/sstode.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,499 +0,0 @@ - SUBROUTINE SSTODE (NEQ, Y, YH, NYH, YH1, EWT, SAVF, ACOR, - 1 WM, IWM, F, JAC, PJAC, SLVS) -C***BEGIN PROLOGUE SSTODE -C***SUBSIDIARY -C***PURPOSE Performs one step of an ODEPACK integration. -C***TYPE SINGLE PRECISION (SSTODE-S, DSTODE-D) -C***AUTHOR Hindmarsh, Alan C., (LLNL) -C***DESCRIPTION -C -C SSTODE performs one step of the integration of an initial value -C problem for a system of ordinary differential equations. -C Note: SSTODE is independent of the value of the iteration method -C indicator MITER, when this is .ne. 0, and hence is independent -C of the type of chord method used, or the Jacobian structure. -C Communication with SSTODE is done with the following variables: -C -C NEQ = integer array containing problem size in NEQ(1), and -C passed as the NEQ argument in all calls to F and JAC. -C Y = an array of length .ge. N used as the Y argument in -C all calls to F and JAC. -C YH = an NYH by LMAX array containing the dependent variables -C and their approximate scaled derivatives, where -C LMAX = MAXORD + 1. YH(i,j+1) contains the approximate -C j-th derivative of y(i), scaled by h**j/factorial(j) -C (j = 0,1,...,NQ). on entry for the first step, the first -C two columns of YH must be set from the initial values. -C NYH = a constant integer .ge. N, the first dimension of YH. -C YH1 = a one-dimensional array occupying the same space as YH. -C EWT = an array of length N containing multiplicative weights -C for local error measurements. Local errors in Y(i) are -C compared to 1.0/EWT(i) in various error tests. -C SAVF = an array of working storage, of length N. -C Also used for input of YH(*,MAXORD+2) when JSTART = -1 -C and MAXORD .lt. the current order NQ. -C ACOR = a work array of length N, used for the accumulated -C corrections. On a successful return, ACOR(i) contains -C the estimated one-step local error in Y(i). -C WM,IWM = real and integer work arrays associated with matrix -C operations in chord iteration (MITER .ne. 0). -C PJAC = name of routine to evaluate and preprocess Jacobian matrix -C and P = I - h*el0*JAC, if a chord method is being used. -C SLVS = name of routine to solve linear system in chord iteration. -C CCMAX = maximum relative change in h*el0 before PJAC is called. -C H = the step size to be attempted on the next step. -C H is altered by the error control algorithm during the -C problem. H can be either positive or negative, but its -C sign must remain constant throughout the problem. -C HMIN = the minimum absolute value of the step size h to be used. -C HMXI = inverse of the maximum absolute value of h to be used. -C HMXI = 0.0 is allowed and corresponds to an infinite hmax. -C HMIN and HMXI may be changed at any time, but will not -C take effect until the next change of h is considered. -C TN = the independent variable. TN is updated on each step taken. -C JSTART = an integer used for input only, with the following -C values and meanings: -C 0 perform the first step. -C .gt.0 take a new step continuing from the last. -C -1 take the next step with a new value of H, MAXORD, -C N, METH, MITER, and/or matrix parameters. -C -2 take the next step with a new value of H, -C but with other inputs unchanged. -C On return, JSTART is set to 1 to facilitate continuation. -C KFLAG = a completion code with the following meanings: -C 0 the step was succesful. -C -1 the requested error could not be achieved. -C -2 corrector convergence could not be achieved. -C -3 fatal error in PJAC or SLVS. -C A return with KFLAG = -1 or -2 means either -C abs(H) = HMIN or 10 consecutive failures occurred. -C On a return with KFLAG negative, the values of TN and -C the YH array are as of the beginning of the last -C step, and H is the last step size attempted. -C MAXORD = the maximum order of integration method to be allowed. -C MAXCOR = the maximum number of corrector iterations allowed. -C MSBP = maximum number of steps between PJAC calls (MITER .gt. 0). -C MXNCF = maximum number of convergence failures allowed. -C METH/MITER = the method flags. See description in driver. -C N = the number of first-order differential equations. -C The values of CCMAX, H, HMIN, HMXI, TN, JSTART, KFLAG, MAXORD, -C MAXCOR, MSBP, MXNCF, METH, MITER, and N are communicated via COMMON. -C -C***SEE ALSO SLSODE -C***ROUTINES CALLED SCFODE, SVNORM -C***COMMON BLOCKS SLS001 -C***REVISION HISTORY (YYMMDD) -C 791129 DATE WRITTEN -C 890501 Modified prologue to SLATEC/LDOC format. (FNF) -C 890503 Minor cosmetic changes. (FNF) -C 930809 Renamed to allow single/double precision versions. (ACH) -C 010413 Reduced size of Common block /SLS001/. (ACH) -C 031105 Restored 'own' variables to Common block /SLS001/, to -C enable interrupt/restart feature. (ACH) -C***END PROLOGUE SSTODE -C**End - EXTERNAL F, JAC, PJAC, SLVS - INTEGER NEQ, NYH, IWM - REAL Y, YH, YH1, EWT, SAVF, ACOR, WM - DIMENSION NEQ(*), Y(*), YH(NYH,*), YH1(*), EWT(*), SAVF(*), - 1 ACOR(*), WM(*), IWM(*) - INTEGER INIT, MXSTEP, MXHNIL, NHNIL, NSLAST, CNYH, - 1 IALTH, IPUP, LMAX, MEO, NQNYH, NSLP, - 1 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, - 2 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, - 3 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU - INTEGER I, I1, IREDO, IRET, J, JB, M, NCF, NEWQ - REAL CONIT, CRATE, EL, ELCO, HOLD, RMAX, TESCO, - 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND - REAL DCON, DDN, DEL, DELP, DSM, DUP, EXDN, EXSM, EXUP, - 1 R, RH, RHDN, RHSM, RHUP, TOLD, SVNORM - COMMON /SLS001/ CONIT, CRATE, EL(13), ELCO(13,12), - 1 HOLD, RMAX, TESCO(3,12), - 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, - 2 INIT, MXSTEP, MXHNIL, NHNIL, NSLAST, CNYH, - 3 IALTH, IPUP, LMAX, MEO, NQNYH, NSLP, - 3 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, - 4 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, - 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU -C -C***FIRST EXECUTABLE STATEMENT SSTODE - KFLAG = 0 - TOLD = TN - NCF = 0 - IERPJ = 0 - IERSL = 0 - JCUR = 0 - ICF = 0 - DELP = 0.0E0 - IF (JSTART .GT. 0) GO TO 200 - IF (JSTART .EQ. -1) GO TO 100 - IF (JSTART .EQ. -2) GO TO 160 -C----------------------------------------------------------------------- -C On the first call, the order is set to 1, and other variables are -C initialized. RMAX is the maximum ratio by which H can be increased -C in a single step. It is initially 1.E4 to compensate for the small -C initial H, but then is normally equal to 10. If a failure -C occurs (in corrector convergence or error test), RMAX is set to 2 -C for the next increase. -C----------------------------------------------------------------------- - LMAX = MAXORD + 1 - NQ = 1 - L = 2 - IALTH = 2 - RMAX = 10000.0E0 - RC = 0.0E0 - EL0 = 1.0E0 - CRATE = 0.7E0 - HOLD = H - MEO = METH - NSLP = 0 - IPUP = MITER - IRET = 3 - GO TO 140 -C----------------------------------------------------------------------- -C The following block handles preliminaries needed when JSTART = -1. -C IPUP is set to MITER to force a matrix update. -C If an order increase is about to be considered (IALTH = 1), -C IALTH is reset to 2 to postpone consideration one more step. -C If the caller has changed METH, SCFODE is called to reset -C the coefficients of the method. -C If the caller has changed MAXORD to a value less than the current -C order NQ, NQ is reduced to MAXORD, and a new H chosen accordingly. -C If H is to be changed, YH must be rescaled. -C If H or METH is being changed, IALTH is reset to L = NQ + 1 -C to prevent further changes in H for that many steps. -C----------------------------------------------------------------------- - 100 IPUP = MITER - LMAX = MAXORD + 1 - IF (IALTH .EQ. 1) IALTH = 2 - IF (METH .EQ. MEO) GO TO 110 - CALL SCFODE (METH, ELCO, TESCO) - MEO = METH - IF (NQ .GT. MAXORD) GO TO 120 - IALTH = L - IRET = 1 - GO TO 150 - 110 IF (NQ .LE. MAXORD) GO TO 160 - 120 NQ = MAXORD - L = LMAX - DO 125 I = 1,L - 125 EL(I) = ELCO(I,NQ) - NQNYH = NQ*NYH - RC = RC*EL(1)/EL0 - EL0 = EL(1) - CONIT = 0.5E0/(NQ+2) - DDN = SVNORM (N, SAVF, EWT)/TESCO(1,L) - EXDN = 1.0E0/L - RHDN = 1.0E0/(1.3E0*DDN**EXDN + 0.0000013E0) - RH = MIN(RHDN,1.0E0) - IREDO = 3 - IF (H .EQ. HOLD) GO TO 170 - RH = MIN(RH,ABS(H/HOLD)) - H = HOLD - GO TO 175 -C----------------------------------------------------------------------- -C SCFODE is called to get all the integration coefficients for the -C current METH. Then the EL vector and related constants are reset -C whenever the order NQ is changed, or at the start of the problem. -C----------------------------------------------------------------------- - 140 CALL SCFODE (METH, ELCO, TESCO) - 150 DO 155 I = 1,L - 155 EL(I) = ELCO(I,NQ) - NQNYH = NQ*NYH - RC = RC*EL(1)/EL0 - EL0 = EL(1) - CONIT = 0.5E0/(NQ+2) - GO TO (160, 170, 200), IRET -C----------------------------------------------------------------------- -C If H is being changed, the H ratio RH is checked against -C RMAX, HMIN, and HMXI, and the YH array rescaled. IALTH is set to -C L = NQ + 1 to prevent a change of H for that many steps, unless -C forced by a convergence or error test failure. -C----------------------------------------------------------------------- - 160 IF (H .EQ. HOLD) GO TO 200 - RH = H/HOLD - H = HOLD - IREDO = 3 - GO TO 175 - 170 RH = MAX(RH,HMIN/ABS(H)) - 175 RH = MIN(RH,RMAX) - RH = RH/MAX(1.0E0,ABS(H)*HMXI*RH) - R = 1.0E0 - DO 180 J = 2,L - R = R*RH - DO 180 I = 1,N - 180 YH(I,J) = YH(I,J)*R - H = H*RH - RC = RC*RH - IALTH = L - IF (IREDO .EQ. 0) GO TO 690 -C----------------------------------------------------------------------- -C This section computes the predicted values by effectively -C multiplying the YH array by the Pascal Triangle matrix. -C RC is the ratio of new to old values of the coefficient H*EL(1). -C When RC differs from 1 by more than CCMAX, IPUP is set to MITER -C to force PJAC to be called, if a Jacobian is involved. -C In any case, PJAC is called at least every MSBP steps. -C----------------------------------------------------------------------- - 200 IF (ABS(RC-1.0E0) .GT. CCMAX) IPUP = MITER - IF (NST .GE. NSLP+MSBP) IPUP = MITER - TN = TN + H - I1 = NQNYH + 1 - DO 215 JB = 1,NQ - I1 = I1 - NYH -Cdir$ ivdep - DO 210 I = I1,NQNYH - 210 YH1(I) = YH1(I) + YH1(I+NYH) - 215 CONTINUE -C----------------------------------------------------------------------- -C Up to MAXCOR corrector iterations are taken. A convergence test is -C made on the R.M.S. norm of each correction, weighted by the error -C weight vector EWT. The sum of the corrections is accumulated in the -C vector ACOR(i). The YH array is not altered in the corrector loop. -C----------------------------------------------------------------------- - 220 M = 0 - DO 230 I = 1,N - 230 Y(I) = YH(I,1) - CALL F (NEQ, TN, Y, SAVF) - NFE = NFE + 1 - IF (IPUP .LE. 0) GO TO 250 -C----------------------------------------------------------------------- -C If indicated, the matrix P = I - h*el(1)*J is reevaluated and -C preprocessed before starting the corrector iteration. IPUP is set -C to 0 as an indicator that this has been done. -C----------------------------------------------------------------------- - CALL PJAC (NEQ, Y, YH, NYH, EWT, ACOR, SAVF, WM, IWM, F, JAC) - IPUP = 0 - RC = 1.0E0 - NSLP = NST - CRATE = 0.7E0 - IF (IERPJ .NE. 0) GO TO 430 - 250 DO 260 I = 1,N - 260 ACOR(I) = 0.0E0 - 270 IF (MITER .NE. 0) GO TO 350 -C----------------------------------------------------------------------- -C In the case of functional iteration, update Y directly from -C the result of the last function evaluation. -C----------------------------------------------------------------------- - DO 290 I = 1,N - SAVF(I) = H*SAVF(I) - YH(I,2) - 290 Y(I) = SAVF(I) - ACOR(I) - DEL = SVNORM (N, Y, EWT) - DO 300 I = 1,N - Y(I) = YH(I,1) + EL(1)*SAVF(I) - 300 ACOR(I) = SAVF(I) - GO TO 400 -C----------------------------------------------------------------------- -C In the case of the chord method, compute the corrector error, -C and solve the linear system with that as right-hand side and -C P as coefficient matrix. -C----------------------------------------------------------------------- - 350 DO 360 I = 1,N - 360 Y(I) = H*SAVF(I) - (YH(I,2) + ACOR(I)) - CALL SLVS (WM, IWM, Y, SAVF) - IF (IERSL .LT. 0) GO TO 430 - IF (IERSL .GT. 0) GO TO 410 - DEL = SVNORM (N, Y, EWT) - DO 380 I = 1,N - ACOR(I) = ACOR(I) + Y(I) - 380 Y(I) = YH(I,1) + EL(1)*ACOR(I) -C----------------------------------------------------------------------- -C Test for convergence. If M.gt.0, an estimate of the convergence -C rate constant is stored in CRATE, and this is used in the test. -C----------------------------------------------------------------------- - 400 IF (M .NE. 0) CRATE = MAX(0.2E0*CRATE,DEL/DELP) - DCON = DEL*MIN(1.0E0,1.5E0*CRATE)/(TESCO(2,NQ)*CONIT) - IF (DCON .LE. 1.0E0) GO TO 450 - M = M + 1 - IF (M .EQ. MAXCOR) GO TO 410 - IF (M .GE. 2 .AND. DEL .GT. 2.0E0*DELP) GO TO 410 - DELP = DEL - CALL F (NEQ, TN, Y, SAVF) - NFE = NFE + 1 - GO TO 270 -C----------------------------------------------------------------------- -C The corrector iteration failed to converge. -C If MITER .ne. 0 and the Jacobian is out of date, PJAC is called for -C the next try. Otherwise the YH array is retracted to its values -C before prediction, and H is reduced, if possible. If H cannot be -C reduced or MXNCF failures have occurred, exit with KFLAG = -2. -C----------------------------------------------------------------------- - 410 IF (MITER .EQ. 0 .OR. JCUR .EQ. 1) GO TO 430 - ICF = 1 - IPUP = MITER - GO TO 220 - 430 ICF = 2 - NCF = NCF + 1 - RMAX = 2.0E0 - TN = TOLD - I1 = NQNYH + 1 - DO 445 JB = 1,NQ - I1 = I1 - NYH -Cdir$ ivdep - DO 440 I = I1,NQNYH - 440 YH1(I) = YH1(I) - YH1(I+NYH) - 445 CONTINUE - IF (IERPJ .LT. 0 .OR. IERSL .LT. 0) GO TO 680 - IF (ABS(H) .LE. HMIN*1.00001E0) GO TO 670 - IF (NCF .EQ. MXNCF) GO TO 670 - RH = 0.25E0 - IPUP = MITER - IREDO = 1 - GO TO 170 -C----------------------------------------------------------------------- -C The corrector has converged. JCUR is set to 0 -C to signal that the Jacobian involved may need updating later. -C The local error test is made and control passes to statement 500 -C if it fails. -C----------------------------------------------------------------------- - 450 JCUR = 0 - IF (M .EQ. 0) DSM = DEL/TESCO(2,NQ) - IF (M .GT. 0) DSM = SVNORM (N, ACOR, EWT)/TESCO(2,NQ) - IF (DSM .GT. 1.0E0) GO TO 500 -C----------------------------------------------------------------------- -C After a successful step, update the YH array. -C Consider changing H if IALTH = 1. Otherwise decrease IALTH by 1. -C If IALTH is then 1 and NQ .lt. MAXORD, then ACOR is saved for -C use in a possible order increase on the next step. -C If a change in H is considered, an increase or decrease in order -C by one is considered also. A change in H is made only if it is by a -C factor of at least 1.1. If not, IALTH is set to 3 to prevent -C testing for that many steps. -C----------------------------------------------------------------------- - KFLAG = 0 - IREDO = 0 - NST = NST + 1 - HU = H - NQU = NQ - DO 470 J = 1,L - DO 470 I = 1,N - 470 YH(I,J) = YH(I,J) + EL(J)*ACOR(I) - IALTH = IALTH - 1 - IF (IALTH .EQ. 0) GO TO 520 - IF (IALTH .GT. 1) GO TO 700 - IF (L .EQ. LMAX) GO TO 700 - DO 490 I = 1,N - 490 YH(I,LMAX) = ACOR(I) - GO TO 700 -C----------------------------------------------------------------------- -C The error test failed. KFLAG keeps track of multiple failures. -C Restore TN and the YH array to their previous values, and prepare -C to try the step again. Compute the optimum step size for this or -C one lower order. After 2 or more failures, H is forced to decrease -C by a factor of 0.2 or less. -C----------------------------------------------------------------------- - 500 KFLAG = KFLAG - 1 - TN = TOLD - I1 = NQNYH + 1 - DO 515 JB = 1,NQ - I1 = I1 - NYH -Cdir$ ivdep - DO 510 I = I1,NQNYH - 510 YH1(I) = YH1(I) - YH1(I+NYH) - 515 CONTINUE - RMAX = 2.0E0 - IF (ABS(H) .LE. HMIN*1.00001E0) GO TO 660 - IF (KFLAG .LE. -3) GO TO 640 - IREDO = 2 - RHUP = 0.0E0 - GO TO 540 -C----------------------------------------------------------------------- -C Regardless of the success or failure of the step, factors -C RHDN, RHSM, and RHUP are computed, by which H could be multiplied -C at order NQ - 1, order NQ, or order NQ + 1, respectively. -C In the case of failure, RHUP = 0.0 to avoid an order increase. -C The largest of these is determined and the new order chosen -C accordingly. If the order is to be increased, we compute one -C additional scaled derivative. -C----------------------------------------------------------------------- - 520 RHUP = 0.0E0 - IF (L .EQ. LMAX) GO TO 540 - DO 530 I = 1,N - 530 SAVF(I) = ACOR(I) - YH(I,LMAX) - DUP = SVNORM (N, SAVF, EWT)/TESCO(3,NQ) - EXUP = 1.0E0/(L+1) - RHUP = 1.0E0/(1.4E0*DUP**EXUP + 0.0000014E0) - 540 EXSM = 1.0E0/L - RHSM = 1.0E0/(1.2E0*DSM**EXSM + 0.0000012E0) - RHDN = 0.0E0 - IF (NQ .EQ. 1) GO TO 560 - DDN = SVNORM (N, YH(1,L), EWT)/TESCO(1,NQ) - EXDN = 1.0E0/NQ - RHDN = 1.0E0/(1.3E0*DDN**EXDN + 0.0000013E0) - 560 IF (RHSM .GE. RHUP) GO TO 570 - IF (RHUP .GT. RHDN) GO TO 590 - GO TO 580 - 570 IF (RHSM .LT. RHDN) GO TO 580 - NEWQ = NQ - RH = RHSM - GO TO 620 - 580 NEWQ = NQ - 1 - RH = RHDN - IF (KFLAG .LT. 0 .AND. RH .GT. 1.0E0) RH = 1.0E0 - GO TO 620 - 590 NEWQ = L - RH = RHUP - IF (RH .LT. 1.1E0) GO TO 610 - R = EL(L)/L - DO 600 I = 1,N - 600 YH(I,NEWQ+1) = ACOR(I)*R - GO TO 630 - 610 IALTH = 3 - GO TO 700 - 620 IF ((KFLAG .EQ. 0) .AND. (RH .LT. 1.1E0)) GO TO 610 - IF (KFLAG .LE. -2) RH = MIN(RH,0.2E0) -C----------------------------------------------------------------------- -C If there is a change of order, reset NQ, l, and the coefficients. -C In any case H is reset according to RH and the YH array is rescaled. -C Then exit from 690 if the step was OK, or redo the step otherwise. -C----------------------------------------------------------------------- - IF (NEWQ .EQ. NQ) GO TO 170 - 630 NQ = NEWQ - L = NQ + 1 - IRET = 2 - GO TO 150 -C----------------------------------------------------------------------- -C Control reaches this section if 3 or more failures have occurred. -C If 10 failures have occurred, exit with KFLAG = -1. -C It is assumed that the derivatives that have accumulated in the -C YH array have errors of the wrong order. Hence the first -C derivative is recomputed, and the order is set to 1. Then -C H is reduced by a factor of 10, and the step is retried, -C until it succeeds or H reaches HMIN. -C----------------------------------------------------------------------- - 640 IF (KFLAG .EQ. -10) GO TO 660 - RH = 0.1E0 - RH = MAX(HMIN/ABS(H),RH) - H = H*RH - DO 645 I = 1,N - 645 Y(I) = YH(I,1) - CALL F (NEQ, TN, Y, SAVF) - NFE = NFE + 1 - DO 650 I = 1,N - 650 YH(I,2) = H*SAVF(I) - IPUP = MITER - IALTH = 5 - IF (NQ .EQ. 1) GO TO 200 - NQ = 1 - L = 2 - IRET = 3 - GO TO 150 -C----------------------------------------------------------------------- -C All returns are made through this section. H is saved in HOLD -C to allow the caller to change H on the next step. -C----------------------------------------------------------------------- - 660 KFLAG = -1 - GO TO 720 - 670 KFLAG = -2 - GO TO 720 - 680 KFLAG = -3 - GO TO 720 - 690 RMAX = 10.0E0 - 700 R = 1.0E0/TESCO(2,NQU) - DO 710 I = 1,N - 710 ACOR(I) = ACOR(I)*R - 720 HOLD = H - JSTART = 1 - RETURN -C----------------------- END OF SUBROUTINE SSTODE ---------------------- - END
--- a/liboctave/cruft/odepack/stode.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,487 +0,0 @@ - SUBROUTINE STODE (NEQ, Y, YH, NYH, YH1, EWT, SAVF, ACOR, - 1 WM, IWM, F, JAC, PJAC, SLVS, IERR) -CLLL. OPTIMIZE - EXTERNAL F, JAC, PJAC, SLVS - INTEGER NEQ, NYH, IWM - INTEGER ILLIN, INIT, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, - 1 MXSTEP, MXHNIL, NHNIL, NTREP, NSLAST, CNYH, - 2 IALTH, IPUP, LMAX, MEO, NQNYH, NSLP - INTEGER ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, METH, MITER, - 1 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU - INTEGER I, I1, IREDO, IRET, J, JB, M, NCF, NEWQ - DOUBLE PRECISION Y, YH, YH1, EWT, SAVF, ACOR, WM - DOUBLE PRECISION CONIT, CRATE, EL, ELCO, HOLD, RMAX, TESCO, - 2 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND - DOUBLE PRECISION DCON, DDN, DEL, DELP, DSM, DUP, EXDN, EXSM, EXUP, - 1 R, RH, RHDN, RHSM, RHUP, TOLD, VNORM - DIMENSION NEQ(*), Y(*), YH(NYH,*), YH1(*), EWT(*), SAVF(*), - 1 ACOR(*), WM(*), IWM(*) - COMMON /LS0001/ CONIT, CRATE, EL(13), ELCO(13,12), - 1 HOLD, RMAX, TESCO(3,12), - 2 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, - 2 ILLIN, INIT, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, - 3 MXSTEP, MXHNIL, NHNIL, NTREP, NSLAST, CNYH, - 3 IALTH, IPUP, LMAX, MEO, NQNYH, NSLP, - 4 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, METH, MITER, - 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU -C----------------------------------------------------------------------- -C STODE PERFORMS ONE STEP OF THE INTEGRATION OF AN INITIAL VALUE -C PROBLEM FOR A SYSTEM OF ORDINARY DIFFERENTIAL EQUATIONS. -C NOTE.. STODE IS INDEPENDENT OF THE VALUE OF THE ITERATION METHOD -C INDICATOR MITER, WHEN THIS IS .NE. 0, AND HENCE IS INDEPENDENT -C OF THE TYPE OF CHORD METHOD USED, OR THE JACOBIAN STRUCTURE. -C COMMUNICATION WITH STODE IS DONE WITH THE FOLLOWING VARIABLES.. -C -C NEQ = INTEGER ARRAY CONTAINING PROBLEM SIZE IN NEQ(1), AND -C PASSED AS THE NEQ ARGUMENT IN ALL CALLS TO F AND JAC. -C Y = AN ARRAY OF LENGTH .GE. N USED AS THE Y ARGUMENT IN -C ALL CALLS TO F AND JAC. -C YH = AN NYH BY LMAX ARRAY CONTAINING THE DEPENDENT VARIABLES -C AND THEIR APPROXIMATE SCALED DERIVATIVES, WHERE -C LMAX = MAXORD + 1. YH(I,J+1) CONTAINS THE APPROXIMATE -C J-TH DERIVATIVE OF Y(I), SCALED BY H**J/FACTORIAL(J) -C (J = 0,1,...,NQ). ON ENTRY FOR THE FIRST STEP, THE FIRST -C TWO COLUMNS OF YH MUST BE SET FROM THE INITIAL VALUES. -C NYH = A CONSTANT INTEGER .GE. N, THE FIRST DIMENSION OF YH. -C YH1 = A ONE-DIMENSIONAL ARRAY OCCUPYING THE SAME SPACE AS YH. -C EWT = AN ARRAY OF LENGTH N CONTAINING MULTIPLICATIVE WEIGHTS -C FOR LOCAL ERROR MEASUREMENTS. LOCAL ERRORS IN Y(I) ARE -C COMPARED TO 1.0/EWT(I) IN VARIOUS ERROR TESTS. -C SAVF = AN ARRAY OF WORKING STORAGE, OF LENGTH N. -C ALSO USED FOR INPUT OF YH(*,MAXORD+2) WHEN JSTART = -1 -C AND MAXORD .LT. THE CURRENT ORDER NQ. -C ACOR = A WORK ARRAY OF LENGTH N, USED FOR THE ACCUMULATED -C CORRECTIONS. ON A SUCCESSFUL RETURN, ACOR(I) CONTAINS -C THE ESTIMATED ONE-STEP LOCAL ERROR IN Y(I). -C WM,IWM = REAL AND INTEGER WORK ARRAYS ASSOCIATED WITH MATRIX -C OPERATIONS IN CHORD ITERATION (MITER .NE. 0). -C PJAC = NAME OF ROUTINE TO EVALUATE AND PREPROCESS JACOBIAN MATRIX -C AND P = I - H*EL0*JAC, IF A CHORD METHOD IS BEING USED. -C SLVS = NAME OF ROUTINE TO SOLVE LINEAR SYSTEM IN CHORD ITERATION. -C CCMAX = MAXIMUM RELATIVE CHANGE IN H*EL0 BEFORE PJAC IS CALLED. -C H = THE STEP SIZE TO BE ATTEMPTED ON THE NEXT STEP. -C H IS ALTERED BY THE ERROR CONTROL ALGORITHM DURING THE -C PROBLEM. H CAN BE EITHER POSITIVE OR NEGATIVE, BUT ITS -C SIGN MUST REMAIN CONSTANT THROUGHOUT THE PROBLEM. -C HMIN = THE MINIMUM ABSOLUTE VALUE OF THE STEP SIZE H TO BE USED. -C HMXI = INVERSE OF THE MAXIMUM ABSOLUTE VALUE OF H TO BE USED. -C HMXI = 0.0 IS ALLOWED AND CORRESPONDS TO AN INFINITE HMAX. -C HMIN AND HMXI MAY BE CHANGED AT ANY TIME, BUT WILL NOT -C TAKE EFFECT UNTIL THE NEXT CHANGE OF H IS CONSIDERED. -C TN = THE INDEPENDENT VARIABLE. TN IS UPDATED ON EACH STEP TAKEN. -C JSTART = AN INTEGER USED FOR INPUT ONLY, WITH THE FOLLOWING -C VALUES AND MEANINGS.. -C 0 PERFORM THE FIRST STEP. -C .GT.0 TAKE A NEW STEP CONTINUING FROM THE LAST. -C -1 TAKE THE NEXT STEP WITH A NEW VALUE OF H, MAXORD, -C N, METH, MITER, AND/OR MATRIX PARAMETERS. -C -2 TAKE THE NEXT STEP WITH A NEW VALUE OF H, -C BUT WITH OTHER INPUTS UNCHANGED. -C ON RETURN, JSTART IS SET TO 1 TO FACILITATE CONTINUATION. -C KFLAG = A COMPLETION CODE WITH THE FOLLOWING MEANINGS.. -C 0 THE STEP WAS SUCCESFUL. -C -1 THE REQUESTED ERROR COULD NOT BE ACHIEVED. -C -2 CORRECTOR CONVERGENCE COULD NOT BE ACHIEVED. -C -3 FATAL ERROR IN PJAC OR SLVS. -C A RETURN WITH KFLAG = -1 OR -2 MEANS EITHER -C ABS(H) = HMIN OR 10 CONSECUTIVE FAILURES OCCURRED. -C ON A RETURN WITH KFLAG NEGATIVE, THE VALUES OF TN AND -C THE YH ARRAY ARE AS OF THE BEGINNING OF THE LAST -C STEP, AND H IS THE LAST STEP SIZE ATTEMPTED. -C MAXORD = THE MAXIMUM ORDER OF INTEGRATION METHOD TO BE ALLOWED. -C MAXCOR = THE MAXIMUM NUMBER OF CORRECTOR ITERATIONS ALLOWED. -C MSBP = MAXIMUM NUMBER OF STEPS BETWEEN PJAC CALLS (MITER .GT. 0). -C MXNCF = MAXIMUM NUMBER OF CONVERGENCE FAILURES ALLOWED. -C METH/MITER = THE METHOD FLAGS. SEE DESCRIPTION IN DRIVER. -C N = THE NUMBER OF FIRST-ORDER DIFFERENTIAL EQUATIONS. -C IERR = ERROR FLAG FROM USER-SUPPLIED FUNCTION -C----------------------------------------------------------------------- - KFLAG = 0 - TOLD = TN - NCF = 0 - IERPJ = 0 - IERSL = 0 - JCUR = 0 - ICF = 0 - DELP = 0.0D0 - IF (JSTART .GT. 0) GO TO 200 - IF (JSTART .EQ. -1) GO TO 100 - IF (JSTART .EQ. -2) GO TO 160 -C----------------------------------------------------------------------- -C ON THE FIRST CALL, THE ORDER IS SET TO 1, AND OTHER VARIABLES ARE -C INITIALIZED. RMAX IS THE MAXIMUM RATIO BY WHICH H CAN BE INCREASED -C IN A SINGLE STEP. IT IS INITIALLY 1.E4 TO COMPENSATE FOR THE SMALL -C INITIAL H, BUT THEN IS NORMALLY EQUAL TO 10. IF A FAILURE -C OCCURS (IN CORRECTOR CONVERGENCE OR ERROR TEST), RMAX IS SET AT 2 -C FOR THE NEXT INCREASE. -C----------------------------------------------------------------------- - LMAX = MAXORD + 1 - NQ = 1 - L = 2 - IALTH = 2 - RMAX = 10000.0D0 - RC = 0.0D0 - EL0 = 1.0D0 - CRATE = 0.7D0 - HOLD = H - MEO = METH - NSLP = 0 - IPUP = MITER - IRET = 3 - GO TO 140 -C----------------------------------------------------------------------- -C THE FOLLOWING BLOCK HANDLES PRELIMINARIES NEEDED WHEN JSTART = -1. -C IPUP IS SET TO MITER TO FORCE A MATRIX UPDATE. -C IF AN ORDER INCREASE IS ABOUT TO BE CONSIDERED (IALTH = 1), -C IALTH IS RESET TO 2 TO POSTPONE CONSIDERATION ONE MORE STEP. -C IF THE CALLER HAS CHANGED METH, CFODE IS CALLED TO RESET -C THE COEFFICIENTS OF THE METHOD. -C IF THE CALLER HAS CHANGED MAXORD TO A VALUE LESS THAN THE CURRENT -C ORDER NQ, NQ IS REDUCED TO MAXORD, AND A NEW H CHOSEN ACCORDINGLY. -C IF H IS TO BE CHANGED, YH MUST BE RESCALED. -C IF H OR METH IS BEING CHANGED, IALTH IS RESET TO L = NQ + 1 -C TO PREVENT FURTHER CHANGES IN H FOR THAT MANY STEPS. -C----------------------------------------------------------------------- - 100 IPUP = MITER - LMAX = MAXORD + 1 - IF (IALTH .EQ. 1) IALTH = 2 - IF (METH .EQ. MEO) GO TO 110 - CALL CFODE (METH, ELCO, TESCO) - MEO = METH - IF (NQ .GT. MAXORD) GO TO 120 - IALTH = L - IRET = 1 - GO TO 150 - 110 IF (NQ .LE. MAXORD) GO TO 160 - 120 NQ = MAXORD - L = LMAX - DO 125 I = 1,L - 125 EL(I) = ELCO(I,NQ) - NQNYH = NQ*NYH - RC = RC*EL(1)/EL0 - EL0 = EL(1) - CONIT = 0.5D0/DBLE(NQ+2) - DDN = VNORM (N, SAVF, EWT)/TESCO(1,L) - EXDN = 1.0D0/DBLE(L) - RHDN = 1.0D0/(1.3D0*DDN**EXDN + 0.0000013D0) - RH = DMIN1(RHDN,1.0D0) - IREDO = 3 - IF (H .EQ. HOLD) GO TO 170 - RH = DMIN1(RH,DABS(H/HOLD)) - H = HOLD - GO TO 175 -C----------------------------------------------------------------------- -C CFODE IS CALLED TO GET ALL THE INTEGRATION COEFFICIENTS FOR THE -C CURRENT METH. THEN THE EL VECTOR AND RELATED CONSTANTS ARE RESET -C WHENEVER THE ORDER NQ IS CHANGED, OR AT THE START OF THE PROBLEM. -C----------------------------------------------------------------------- - 140 CALL CFODE (METH, ELCO, TESCO) - 150 DO 155 I = 1,L - 155 EL(I) = ELCO(I,NQ) - NQNYH = NQ*NYH - RC = RC*EL(1)/EL0 - EL0 = EL(1) - CONIT = 0.5D0/DBLE(NQ+2) - GO TO (160, 170, 200), IRET -C----------------------------------------------------------------------- -C IF H IS BEING CHANGED, THE H RATIO RH IS CHECKED AGAINST -C RMAX, HMIN, AND HMXI, AND THE YH ARRAY RESCALED. IALTH IS SET TO -C L = NQ + 1 TO PREVENT A CHANGE OF H FOR THAT MANY STEPS, UNLESS -C FORCED BY A CONVERGENCE OR ERROR TEST FAILURE. -C----------------------------------------------------------------------- - 160 IF (H .EQ. HOLD) GO TO 200 - RH = H/HOLD - H = HOLD - IREDO = 3 - GO TO 175 - 170 RH = DMAX1(RH,HMIN/DABS(H)) - 175 RH = DMIN1(RH,RMAX) - RH = RH/DMAX1(1.0D0,DABS(H)*HMXI*RH) - R = 1.0D0 - DO 180 J = 2,L - R = R*RH - DO 180 I = 1,N - 180 YH(I,J) = YH(I,J)*R - H = H*RH - RC = RC*RH - IALTH = L - IF (IREDO .EQ. 0) GO TO 690 -C----------------------------------------------------------------------- -C THIS SECTION COMPUTES THE PREDICTED VALUES BY EFFECTIVELY -C MULTIPLYING THE YH ARRAY BY THE PASCAL TRIANGLE MATRIX. -C RC IS THE RATIO OF NEW TO OLD VALUES OF THE COEFFICIENT H*EL(1). -C WHEN RC DIFFERS FROM 1 BY MORE THAN CCMAX, IPUP IS SET TO MITER -C TO FORCE PJAC TO BE CALLED, IF A JACOBIAN IS INVOLVED. -C IN ANY CASE, PJAC IS CALLED AT LEAST EVERY MSBP STEPS. -C----------------------------------------------------------------------- - 200 IF (DABS(RC-1.0D0) .GT. CCMAX) IPUP = MITER - IF (NST .GE. NSLP+MSBP) IPUP = MITER - TN = TN + H - I1 = NQNYH + 1 - DO 215 JB = 1,NQ - I1 = I1 - NYH -CDIR$ IVDEP - DO 210 I = I1,NQNYH - 210 YH1(I) = YH1(I) + YH1(I+NYH) - 215 CONTINUE -C----------------------------------------------------------------------- -C UP TO MAXCOR CORRECTOR ITERATIONS ARE TAKEN. A CONVERGENCE TEST IS -C MADE ON THE R.M.S. NORM OF EACH CORRECTION, WEIGHTED BY THE ERROR -C WEIGHT VECTOR EWT. THE SUM OF THE CORRECTIONS IS ACCUMULATED IN THE -C VECTOR ACOR(I). THE YH ARRAY IS NOT ALTERED IN THE CORRECTOR LOOP. -C----------------------------------------------------------------------- - 220 M = 0 - DO 230 I = 1,N - 230 Y(I) = YH(I,1) - IERR = 0 - CALL F (NEQ, TN, Y, SAVF, IERR) - IF (IERR .LT. 0) RETURN - NFE = NFE + 1 - IF (IPUP .LE. 0) GO TO 250 -C----------------------------------------------------------------------- -C IF INDICATED, THE MATRIX P = I - H*EL(1)*J IS REEVALUATED AND -C PREPROCESSED BEFORE STARTING THE CORRECTOR ITERATION. IPUP IS SET -C TO 0 AS AN INDICATOR THAT THIS HAS BEEN DONE. -C----------------------------------------------------------------------- - IERR = 0 - CALL PJAC (NEQ, Y, YH, NYH, EWT, ACOR, SAVF, WM, IWM, F, JAC, - 1 IERR) - IF (IERR .LT. 0) RETURN - IPUP = 0 - RC = 1.0D0 - NSLP = NST - CRATE = 0.7D0 - IF (IERPJ .NE. 0) GO TO 430 - 250 DO 260 I = 1,N - 260 ACOR(I) = 0.0D0 - 270 IF (MITER .NE. 0) GO TO 350 -C----------------------------------------------------------------------- -C IN THE CASE OF FUNCTIONAL ITERATION, UPDATE Y DIRECTLY FROM -C THE RESULT OF THE LAST FUNCTION EVALUATION. -C----------------------------------------------------------------------- - DO 290 I = 1,N - SAVF(I) = H*SAVF(I) - YH(I,2) - 290 Y(I) = SAVF(I) - ACOR(I) - DEL = VNORM (N, Y, EWT) - DO 300 I = 1,N - Y(I) = YH(I,1) + EL(1)*SAVF(I) - 300 ACOR(I) = SAVF(I) - GO TO 400 -C----------------------------------------------------------------------- -C IN THE CASE OF THE CHORD METHOD, COMPUTE THE CORRECTOR ERROR, -C AND SOLVE THE LINEAR SYSTEM WITH THAT AS RIGHT-HAND SIDE AND -C P AS COEFFICIENT MATRIX. -C----------------------------------------------------------------------- - 350 DO 360 I = 1,N - 360 Y(I) = H*SAVF(I) - (YH(I,2) + ACOR(I)) - CALL SLVS (WM, IWM, Y, SAVF) - IF (IERSL .LT. 0) GO TO 430 - IF (IERSL .GT. 0) GO TO 410 - DEL = VNORM (N, Y, EWT) - DO 380 I = 1,N - ACOR(I) = ACOR(I) + Y(I) - 380 Y(I) = YH(I,1) + EL(1)*ACOR(I) -C----------------------------------------------------------------------- -C TEST FOR CONVERGENCE. IF M.GT.0, AN ESTIMATE OF THE CONVERGENCE -C RATE CONSTANT IS STORED IN CRATE, AND THIS IS USED IN THE TEST. -C----------------------------------------------------------------------- - 400 IF (M .NE. 0) CRATE = DMAX1(0.2D0*CRATE,DEL/DELP) - DCON = DEL*DMIN1(1.0D0,1.5D0*CRATE)/(TESCO(2,NQ)*CONIT) - IF (DCON .LE. 1.0D0) GO TO 450 - M = M + 1 - IF (M .EQ. MAXCOR) GO TO 410 - IF (M .GE. 2 .AND. DEL .GT. 2.0D0*DELP) GO TO 410 - DELP = DEL - IERR = 0 - CALL F (NEQ, TN, Y, SAVF, IERR) - IF (IERR .LT. 0) RETURN - NFE = NFE + 1 - GO TO 270 -C----------------------------------------------------------------------- -C THE CORRECTOR ITERATION FAILED TO CONVERGE. -C IF MITER .NE. 0 AND THE JACOBIAN IS OUT OF DATE, PJAC IS CALLED FOR -C THE NEXT TRY. OTHERWISE THE YH ARRAY IS RETRACTED TO ITS VALUES -C BEFORE PREDICTION, AND H IS REDUCED, IF POSSIBLE. IF H CANNOT BE -C REDUCED OR MXNCF FAILURES HAVE OCCURRED, EXIT WITH KFLAG = -2. -C----------------------------------------------------------------------- - 410 IF (MITER .EQ. 0 .OR. JCUR .EQ. 1) GO TO 430 - ICF = 1 - IPUP = MITER - GO TO 220 - 430 ICF = 2 - NCF = NCF + 1 - RMAX = 2.0D0 - TN = TOLD - I1 = NQNYH + 1 - DO 445 JB = 1,NQ - I1 = I1 - NYH -CDIR$ IVDEP - DO 440 I = I1,NQNYH - 440 YH1(I) = YH1(I) - YH1(I+NYH) - 445 CONTINUE - IF (IERPJ .LT. 0 .OR. IERSL .LT. 0) GO TO 680 - IF (DABS(H) .LE. HMIN*1.00001D0) GO TO 670 - IF (NCF .EQ. MXNCF) GO TO 670 - RH = 0.25D0 - IPUP = MITER - IREDO = 1 - GO TO 170 -C----------------------------------------------------------------------- -C THE CORRECTOR HAS CONVERGED. JCUR IS SET TO 0 -C TO SIGNAL THAT THE JACOBIAN INVOLVED MAY NEED UPDATING LATER. -C THE LOCAL ERROR TEST IS MADE AND CONTROL PASSES TO STATEMENT 500 -C IF IT FAILS. -C----------------------------------------------------------------------- - 450 JCUR = 0 - IF (M .EQ. 0) DSM = DEL/TESCO(2,NQ) - IF (M .GT. 0) DSM = VNORM (N, ACOR, EWT)/TESCO(2,NQ) - IF (DSM .GT. 1.0D0) GO TO 500 -C----------------------------------------------------------------------- -C AFTER A SUCCESSFUL STEP, UPDATE THE YH ARRAY. -C CONSIDER CHANGING H IF IALTH = 1. OTHERWISE DECREASE IALTH BY 1. -C IF IALTH IS THEN 1 AND NQ .LT. MAXORD, THEN ACOR IS SAVED FOR -C USE IN A POSSIBLE ORDER INCREASE ON THE NEXT STEP. -C IF A CHANGE IN H IS CONSIDERED, AN INCREASE OR DECREASE IN ORDER -C BY ONE IS CONSIDERED ALSO. A CHANGE IN H IS MADE ONLY IF IT IS BY A -C FACTOR OF AT LEAST 1.1. IF NOT, IALTH IS SET TO 3 TO PREVENT -C TESTING FOR THAT MANY STEPS. -C----------------------------------------------------------------------- - KFLAG = 0 - IREDO = 0 - NST = NST + 1 - HU = H - NQU = NQ - DO 470 J = 1,L - DO 470 I = 1,N - 470 YH(I,J) = YH(I,J) + EL(J)*ACOR(I) - IALTH = IALTH - 1 - IF (IALTH .EQ. 0) GO TO 520 - IF (IALTH .GT. 1) GO TO 700 - IF (L .EQ. LMAX) GO TO 700 - DO 490 I = 1,N - 490 YH(I,LMAX) = ACOR(I) - GO TO 700 -C----------------------------------------------------------------------- -C THE ERROR TEST FAILED. KFLAG KEEPS TRACK OF MULTIPLE FAILURES. -C RESTORE TN AND THE YH ARRAY TO THEIR PREVIOUS VALUES, AND PREPARE -C TO TRY THE STEP AGAIN. COMPUTE THE OPTIMUM STEP SIZE FOR THIS OR -C ONE LOWER ORDER. AFTER 2 OR MORE FAILURES, H IS FORCED TO DECREASE -C BY A FACTOR OF 0.2 OR LESS. -C----------------------------------------------------------------------- - 500 KFLAG = KFLAG - 1 - TN = TOLD - I1 = NQNYH + 1 - DO 515 JB = 1,NQ - I1 = I1 - NYH -CDIR$ IVDEP - DO 510 I = I1,NQNYH - 510 YH1(I) = YH1(I) - YH1(I+NYH) - 515 CONTINUE - RMAX = 2.0D0 - IF (DABS(H) .LE. HMIN*1.00001D0) GO TO 660 - IF (KFLAG .LE. -3) GO TO 640 - IREDO = 2 - RHUP = 0.0D0 - GO TO 540 -C----------------------------------------------------------------------- -C REGARDLESS OF THE SUCCESS OR FAILURE OF THE STEP, FACTORS -C RHDN, RHSM, AND RHUP ARE COMPUTED, BY WHICH H COULD BE MULTIPLIED -C AT ORDER NQ - 1, ORDER NQ, OR ORDER NQ + 1, RESPECTIVELY. -C IN THE CASE OF FAILURE, RHUP = 0.0 TO AVOID AN ORDER INCREASE. -C THE LARGEST OF THESE IS DETERMINED AND THE NEW ORDER CHOSEN -C ACCORDINGLY. IF THE ORDER IS TO BE INCREASED, WE COMPUTE ONE -C ADDITIONAL SCALED DERIVATIVE. -C----------------------------------------------------------------------- - 520 RHUP = 0.0D0 - IF (L .EQ. LMAX) GO TO 540 - DO 530 I = 1,N - 530 SAVF(I) = ACOR(I) - YH(I,LMAX) - DUP = VNORM (N, SAVF, EWT)/TESCO(3,NQ) - EXUP = 1.0D0/DBLE(L+1) - RHUP = 1.0D0/(1.4D0*DUP**EXUP + 0.0000014D0) - 540 EXSM = 1.0D0/DBLE(L) - RHSM = 1.0D0/(1.2D0*DSM**EXSM + 0.0000012D0) - RHDN = 0.0D0 - IF (NQ .EQ. 1) GO TO 560 - DDN = VNORM (N, YH(1,L), EWT)/TESCO(1,NQ) - EXDN = 1.0D0/DBLE(NQ) - RHDN = 1.0D0/(1.3D0*DDN**EXDN + 0.0000013D0) - 560 IF (RHSM .GE. RHUP) GO TO 570 - IF (RHUP .GT. RHDN) GO TO 590 - GO TO 580 - 570 IF (RHSM .LT. RHDN) GO TO 580 - NEWQ = NQ - RH = RHSM - GO TO 620 - 580 NEWQ = NQ - 1 - RH = RHDN - IF (KFLAG .LT. 0 .AND. RH .GT. 1.0D0) RH = 1.0D0 - GO TO 620 - 590 NEWQ = L - RH = RHUP - IF (RH .LT. 1.1D0) GO TO 610 - R = EL(L)/DBLE(L) - DO 600 I = 1,N - 600 YH(I,NEWQ+1) = ACOR(I)*R - GO TO 630 - 610 IALTH = 3 - GO TO 700 - 620 IF ((KFLAG .EQ. 0) .AND. (RH .LT. 1.1D0)) GO TO 610 - IF (KFLAG .LE. -2) RH = DMIN1(RH,0.2D0) -C----------------------------------------------------------------------- -C IF THERE IS A CHANGE OF ORDER, RESET NQ, L, AND THE COEFFICIENTS. -C IN ANY CASE H IS RESET ACCORDING TO RH AND THE YH ARRAY IS RESCALED. -C THEN EXIT FROM 690 IF THE STEP WAS OK, OR REDO THE STEP OTHERWISE. -C----------------------------------------------------------------------- - IF (NEWQ .EQ. NQ) GO TO 170 - 630 NQ = NEWQ - L = NQ + 1 - IRET = 2 - GO TO 150 -C----------------------------------------------------------------------- -C CONTROL REACHES THIS SECTION IF 3 OR MORE FAILURES HAVE OCCURRED. -C IF 10 FAILURES HAVE OCCURRED, EXIT WITH KFLAG = -1. -C IT IS ASSUMED THAT THE DERIVATIVES THAT HAVE ACCUMULATED IN THE -C YH ARRAY HAVE ERRORS OF THE WRONG ORDER. HENCE THE FIRST -C DERIVATIVE IS RECOMPUTED, AND THE ORDER IS SET TO 1. THEN -C H IS REDUCED BY A FACTOR OF 10, AND THE STEP IS RETRIED, -C UNTIL IT SUCCEEDS OR H REACHES HMIN. -C----------------------------------------------------------------------- - 640 IF (KFLAG .EQ. -10) GO TO 660 - RH = 0.1D0 - RH = DMAX1(HMIN/DABS(H),RH) - H = H*RH - DO 645 I = 1,N - 645 Y(I) = YH(I,1) - IERR = 0 - CALL F (NEQ, TN, Y, SAVF, IERR) - IF (IERR .LT. 0) RETURN - NFE = NFE + 1 - DO 650 I = 1,N - 650 YH(I,2) = H*SAVF(I) - IPUP = MITER - IALTH = 5 - IF (NQ .EQ. 1) GO TO 200 - NQ = 1 - L = 2 - IRET = 3 - GO TO 150 -C----------------------------------------------------------------------- -C ALL RETURNS ARE MADE THROUGH THIS SECTION. H IS SAVED IN HOLD -C TO ALLOW THE CALLER TO CHANGE H ON THE NEXT STEP. -C----------------------------------------------------------------------- - 660 KFLAG = -1 - GO TO 720 - 670 KFLAG = -2 - GO TO 720 - 680 KFLAG = -3 - GO TO 720 - 690 RMAX = 10.0D0 - 700 R = 1.0D0/TESCO(2,NQU) - DO 710 I = 1,N - 710 ACOR(I) = ACOR(I)*R - 720 HOLD = H - JSTART = 1 - RETURN -C----------------------- END OF SUBROUTINE STODE ----------------------- - END
--- a/liboctave/cruft/odepack/svnorm.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,34 +0,0 @@ - REAL FUNCTION SVNORM (N, V, W) -C***BEGIN PROLOGUE SVNORM -C***SUBSIDIARY -C***PURPOSE Weighted root-mean-square vector norm. -C***TYPE SINGLE PRECISION (SVNORM-S, DVNORM-D) -C***AUTHOR Hindmarsh, Alan C., (LLNL) -C***DESCRIPTION -C -C This function routine computes the weighted root-mean-square norm -C of the vector of length N contained in the array V, with weights -C contained in the array W of length N: -C SVNORM = SQRT( (1/N) * SUM( V(i)*W(i) )**2 ) -C -C***SEE ALSO SLSODE -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 791129 DATE WRITTEN -C 890501 Modified prologue to SLATEC/LDOC format. (FNF) -C 890503 Minor cosmetic changes. (FNF) -C 930809 Renamed to allow single/double precision versions. (ACH) -C***END PROLOGUE SVNORM -C**End - INTEGER N, I - REAL V, W, SUM - DIMENSION V(N), W(N) -C -C***FIRST EXECUTABLE STATEMENT SVNORM - SUM = 0.0E0 - DO 10 I = 1,N - 10 SUM = SUM + (V(I)*W(I))**2 - SVNORM = SQRT(SUM/N) - RETURN -C----------------------- END OF FUNCTION SVNORM ------------------------ - END
--- a/liboctave/cruft/odepack/vnorm.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,18 +0,0 @@ - DOUBLE PRECISION FUNCTION VNORM (N, V, W) -CLLL. OPTIMIZE -C----------------------------------------------------------------------- -C THIS FUNCTION ROUTINE COMPUTES THE WEIGHTED ROOT-MEAN-SQUARE NORM -C OF THE VECTOR OF LENGTH N CONTAINED IN THE ARRAY V, WITH WEIGHTS -C CONTAINED IN THE ARRAY W OF LENGTH N.. -C VNORM = SQRT( (1/N) * SUM( V(I)*W(I) )**2 ) -C----------------------------------------------------------------------- - INTEGER N, I - DOUBLE PRECISION V, W, SUM - DIMENSION V(N), W(N) - SUM = 0.0D0 - DO 10 I = 1,N - 10 SUM = SUM + (V(I)*W(I))**2 - VNORM = DSQRT(SUM/DBLE(N)) - RETURN -C----------------------- END OF FUNCTION VNORM ------------------------- - END
--- a/liboctave/cruft/ordered-qz/README Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,2 +0,0 @@ -Code in this directory is adapted from Paul Van Dooren's toms/590 -code. Modifications are listed in the comment header sections.
--- a/liboctave/cruft/ordered-qz/dsubsp.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,104 +0,0 @@ - SUBROUTINE DSUBSP(NMAX, N, A, B, Z, FTEST, EPS, NDIM, FAIL, IND) - INTEGER NMAX, N, FTEST, NDIM, IND(N) - LOGICAL FAIL - DOUBLE PRECISION A(NMAX,N), B(NMAX,N), Z(NMAX,N), EPS -C* -C* GIVEN THE UPPER TRIANGULAR MATRIX B AND UPPER HESSENBERG MATRIX A -C* WITH 1X1 OR 2X2 DIAGONAL BLOCKS, THIS ROUTINE REORDERS THE DIAGONAL -C* BLOCKS ALONG WITH THEIR GENERALIZED EIGENVALUES BY CONSTRUCTING EQUI- -C* VALENCE TRANSFORMATIONS QT AND ZT. THE ROW TRANSFORMATION ZT IS ALSO -C* PERFORMED ON THE GIVEN (INITIAL) TRANSFORMATION Z (RESULTING FROM A -C* POSSIBLE PREVIOUS STEP OR INITIALIZED WITH THE IDENTITY MATRIX). -C* AFTER REORDERING, THE EIGENVALUES INSIDE THE REGION SPECIFIED BY THE -C* FUNCTION FTEST APPEAR AT THE TOP. IF NDIM IS THEIR NUMBER THEN THE -C* NDIM FIRST COLUMNS OF Z SPAN THE REQUESTED SUBSPACE. DSUBSP REQUIRES -C* THE SUBROUTINE EXCHQZ AND THE INTEGER FUNCTION FTEST WHICH HAS TO BE -C* PROVIDED BY THE USER. THE PARAMETERS IN THE CALLING SEQUENCE ARE : -C* (STARRED PARAMETERS ARE ALTERED BY THE SUBROUTINE) -C* -C* NMAX THE FIRST DIMENSION OF A, B AND Z -C* N THE ORDER OF A, B AND Z -C* *A,*B THE MATRIX PAIR WHOSE BLOCKS ARE TO BE REORDERED. -C* *Z UPON RETURN THIS ARRAY IS MULTIPLIED BY THE COLUMN -C* TRANSFORMATION ZT. -C* FTEST(LS,ALPHA,BETA,S,P) AN INTEGER FUNCTION DESCRIBING THE -C* SPECTRUM OF THE DEFLATING SUBSPACE TO BE COMPUTED: -C* WHEN LS=1 FTEST CHECKS IF ALPHA/BETA IS IN THAT SPECTRUM -C* WHEN LS=2 FTEST CHECKS IF THE TWO COMPLEX CONJUGATE -C* ROOTS WITH SUM S AND PRODUCT P ARE IN THAT SPECTRUM -C* IF THE ANSWER IS POSITIVE, FTEST=1, OTHERWISE FTEST=-1 -C* EPS THE REQUIRED ABSOLUTE ACCURACY OF THE RESULT -C* *NDIM AN INTEGER GIVING THE DIMENSION OF THE COMPUTED -C* DEFLATING SUBSPACE -C* *FAIL A LOGICAL VARIABLE WHICH IS FALSE ON A NORMAL RETURN, -C* TRUE OTHERWISE (WHEN EXCHQZ FAILS) -C* *IND AN INTEGER WORKING ARRAY OF DIMENSION AT LEAST N -C* - INTEGER L, LS, LS1, LS2, L1, LL, NUM, IS, L2I, L2K, I, K, II, - * ISTEP, IFIRST - DOUBLE PRECISION S, P, D, ALPHA, BETA - FAIL = .TRUE. - NDIM = 0 - NUM = 0 - L = 0 - LS = 1 -C*** CONSTRUCT ARRAY IND(I) WHERE : -C*** IABS(IND(I)) IS THE SIZE OF THE BLOCK I -C*** SIGN(IND(I)) INDICATES THE LOCATION OF ITS EIGENVALUES -C*** (AS DETERMINED BY FTEST). -C*** NUM IS THE NUMBER OF ELEMENTS IN THIS ARRAY - DO 30 LL=1,N - L = L + LS - IF (L.GT.N) GO TO 40 - L1 = L + 1 - IF (L1.GT.N) GO TO 10 - IF (A(L1,L).EQ.0.) GO TO 10 -C* HERE A 2X2 BLOCK IS CHECKED * - LS = 2 - D = B(L,L)*B(L1,L1) - S = (A(L,L)*B(L1,L1)+A(L1,L1)*B(L,L)-A(L1,L)*B(L,L1))/D - P = (A(L,L)*A(L1,L1)-A(L,L1)*A(L1,L))/D - IS = FTEST(LS,ALPHA,BETA,S,P) - GO TO 20 -C* HERE A 1X1 BLOCK IS CHECKED * - 10 LS = 1 - IS = FTEST(LS,A(L,L),B(L,L),S,P) - 20 NUM = NUM + 1 - IF (IS.EQ.1) NDIM = NDIM + LS - IND(NUM) = LS*IS - 30 CONTINUE -C*** REORDER BLOCKS SUCH THAT THOSE WITH POSITIVE VALUE -C*** OF IND(.) APPEAR FIRST. - 40 L2I = 1 - DO 100 I=1,NUM - IF (IND(I).GT.0) GO TO 90 -C* IF A NEGATIVE IND(I) IS ENCOUNTERED, THEN SEARCH FOR THE FIRST -C* POSITIVE IND(K) FOLLOWING ON IT - L2K = L2I - DO 60 K=I,NUM - IF (IND(K).LT.0) GO TO 50 - GO TO 70 - 50 L2K = L2K - IND(K) - 60 CONTINUE -C* IF THERE ARE NO POSITIVE INDICES FOLLOWING ON A NEGATIVE ONE -C* THEN STOP - GO TO 110 -C* IF A POSITIVE IND(K) FOLLOWS ON A NEGATIVE IND(I) THEN -C* INTERCHANGE BLOCK K BEFORE BLOCK I BY PERFORMING K-I SWAPS - 70 ISTEP = K - I - LS2 = IND(K) - L = L2K - DO 80 II=1,ISTEP - IFIRST = K - II - LS1 = -IND(IFIRST) - L = L - LS1 - CALL EXCHQZ(NMAX, N, A, B, Z, L, LS1, LS2, EPS, FAIL) - IF (FAIL) RETURN - IND(IFIRST+1) = IND(IFIRST) - 80 CONTINUE - IND(I) = LS2 - 90 L2I = L2I + IND(I) - 100 CONTINUE - 110 FAIL = .FALSE. - RETURN - END
--- a/liboctave/cruft/ordered-qz/exchqz.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,263 +0,0 @@ - SUBROUTINE EXCHQZ(NMAX, N, A, B, Z, L, LS1, LS2, EPS, FAIL) - INTEGER NMAX, N, L, LS1, LS2 - DOUBLE PRECISION A(NMAX,N), B(NMAX,N), Z(NMAX,N), EPS - LOGICAL FAIL -c modified july 9, 1998 a.s.hodel@eng.auburn.edu: -c REAL changed to DOUBLE PRECISION -c calls to AMAX1 changed to call MAX instead. -c calls to SROT changed to DROT (both in BLAS) -c calls to giv changed to dlartg (LAPACK); required new variable tempr -C* -C* GIVEN THE UPPER TRIANGULAR MATRIX B AND UPPER HESSENBERG MATRIX A -C* WITH CONSECUTIVE LS1XLS1 AND LS2XLS2 DIAGONAL BLOCKS (LS1,LS2.LE.2) -C* STARTING AT ROW/COLUMN L, EXCHQZ PRODUCES EQUIVALENCE TRANSFORMA- -C* TIONS QT AND ZT THAT EXCHANGE THE BLOCKS ALONG WITH THEIR GENERALIZED -C* EIGENVALUES. EXCHQZ REQUIRES THE SUBROUTINES DROT (BLAS) AND GIV. -C* THE PARAMETERS IN THE CALLING SEQUENCE ARE (STARRED PARAMETERS ARE -C* ALTERED BY THE SUBROUTINE): -C* -C* NMAX THE FIRST DIMENSION OF A, B AND Z -C* N THE ORDER OF A, B AND Z -C* *A,*B THE MATRIX PAIR WHOSE BLOCKS ARE TO BE INTERCHANGED -C* *Z UPON RETURN THIS ARRAY IS MULTIPLIED BY THE COLUMN -C* TRANSFORMATION ZT. -C* L THE POSITION OF THE BLOCKS -C* LS1 THE SIZE OF THE FIRST BLOCK -C* LS2 THE SIZE OF THE SECOND BLOCK -C* EPS THE REQUIRED ABSOLUTE ACCURACY OF THE RESULT -C* *FAIL A LOGICAL VARIABLE WHICH IS FALSE ON A NORMAL RETURN, -C* TRUE OTHERWISE. -C* - INTEGER I, J, L1, L2, L3, LI, LJ, LL, IT1, IT2 - DOUBLE PRECISION U(3,3), D, E, F, G, SA, SB, A11B11, A21B11, - * A12B22, B12B22, - * A22B22, AMMBMM, ANMBMM, AMNBNN, BMNBNN, ANNBNN, TEMPR - LOGICAL ALTB - FAIL = .FALSE. - L1 = L + 1 - LL = LS1 + LS2 - IF (LL.GT.2) GO TO 10 -C*** INTERCHANGE 1X1 AND 1X1 BLOCKS VIA AN EQUIVALENCE -C*** TRANSFORMATION A:=Q*A*Z , B:=Q*B*Z -C*** WHERE Q AND Z ARE GIVENS ROTATIONS - F = MAX(ABS(A(L1,L1)),ABS(B(L1,L1))) - ALTB = .TRUE. - IF (ABS(A(L1,L1)).GE.F) ALTB = .FALSE. - SA = A(L1,L1)/F - SB = B(L1,L1)/F - F = SA*B(L,L) - SB*A(L,L) -C* CONSTRUCT THE COLUMN TRANSFORMATION Z - G = SA*B(L,L1) - SB*A(L,L1) - CALL DLARTG(F, G, D, E,TEMPR) - CALL DROT(L1, A(1,L), 1, A(1,L1), 1, E, -D) - CALL DROT(L1, B(1,L), 1, B(1,L1), 1, E, -D) - CALL DROT(N, Z(1,L), 1, Z(1,L1), 1, E, -D) -C* CONSTRUCT THE ROW TRANSFORMATION Q - IF (ALTB) CALL DLARTG(B(L,L), B(L1,L), D, E,TEMPR) - IF (.NOT.ALTB) CALL DLARTG(A(L,L), A(L1,L), D, E,TEMPR) - CALL DROT(N-L+1, A(L,L), NMAX, A(L1,L), NMAX, D, E) - CALL DROT(N-L+1, B(L,L), NMAX, B(L1,L), NMAX, D, E) - A(L1,L) = 0. - B(L1,L) = 0. - RETURN -C*** INTERCHANGE 1X1 AND 2X2 BLOCKS VIA AN EQUIVALENCE -C*** TRANSFORMATION A:=Q2*Q1*A*Z1*Z2 , B:=Q2*Q1*B*Z1*Z2 -C*** WHERE EACH QI AND ZI IS A GIVENS ROTATION - 10 L2 = L + 2 - IF (LS1.EQ.2) GO TO 60 - G = MAX(ABS(A(L,L)),ABS(B(L,L))) - ALTB = .TRUE. - IF (ABS(A(L,L)).LT.G) GO TO 20 - ALTB = .FALSE. - CALL DLARTG(A(L1,L1), A(L2,L1), D, E,TEMPR) - CALL DROT(N-L, A(L1,L1), NMAX, A(L2,L1), NMAX, D, E) - CALL DROT(N-L, B(L1,L1), NMAX, B(L2,L1), NMAX, D, E) -C** EVALUATE THE PENCIL AT THE EIGENVALUE CORRESPONDING -C** TO THE 1X1 BLOCK - 20 SA = A(L,L)/G - SB = B(L,L)/G - DO 40 J=1,2 - LJ = L + J - DO 30 I=1,3 - LI = L + I - 1 - U(I,J) = SA*B(LI,LJ) - SB*A(LI,LJ) - 30 CONTINUE - 40 CONTINUE - CALL DLARTG(U(3,1), U(3,2), D, E,TEMPR) - CALL DROT(3, U(1,1), 1, U(1,2), 1, E, -D) -C* PERFORM THE ROW TRANSFORMATION Q1 - CALL DLARTG(U(1,1), U(2,1), D, E,TEMPR) - U(2,2) = -U(1,2)*E + U(2,2)*D - CALL DROT(N-L+1, A(L,L), NMAX, A(L1,L), NMAX, D, E) - CALL DROT(N-L+1, B(L,L), NMAX, B(L1,L), NMAX, D, E) -C* PERFORM THE COLUMN TRANSFORMATION Z1 - IF (ALTB) CALL DLARTG(B(L1,L), B(L1,L1), D, E,TEMPR) - IF (.NOT.ALTB) CALL DLARTG(A(L1,L), A(L1,L1), D, E,TEMPR) - CALL DROT(L2, A(1,L), 1, A(1,L1), 1, E, -D) - CALL DROT(L2, B(1,L), 1, B(1,L1), 1, E, -D) - CALL DROT(N, Z(1,L), 1, Z(1,L1), 1, E, -D) -C* PERFORM THE ROW TRANSFORMATION Q2 - CALL DLARTG(U(2,2), U(3,2), D, E,TEMPR) - CALL DROT(N-L+1, A(L1,L), NMAX, A(L2,L), NMAX, D, E) - CALL DROT(N-L+1, B(L1,L), NMAX, B(L2,L), NMAX, D, E) -C* PERFORM THE COLUMN TRANSFORMATION Z2 - IF (ALTB) CALL DLARTG(B(L2,L1), B(L2,L2), D, E,TEMPR) - IF (.NOT.ALTB) CALL DLARTG(A(L2,L1), A(L2,L2), D, E,TEMPR) - CALL DROT(L2, A(1,L1), 1, A(1,L2), 1, E, -D) - CALL DROT(L2, B(1,L1), 1, B(1,L2), 1, E, -D) - CALL DROT(N, Z(1,L1), 1, Z(1,L2), 1, E, -D) - IF (ALTB) GO TO 50 - CALL DLARTG(B(L,L), B(L1,L), D, E,TEMPR) - CALL DROT(N-L+1, A(L,L), NMAX, A(L1,L), NMAX, D, E) - CALL DROT(N-L+1, B(L,L), NMAX, B(L1,L), NMAX, D, E) -C* PUT THE NEGLECTABLE ELEMENTS EQUAL TO ZERO - 50 A(L2,L) = 0. - A(L2,L1) = 0. - B(L1,L) = 0. - B(L2,L) = 0. - B(L2,L1) = 0. - RETURN -C*** INTERCHANGE 2X2 AND 1X1 BLOCKS VIA AN EQUIVALENCE -C*** TRANSFORMATION A:=Q2*Q1*A*Z1*Z2 , B:=Q2*Q1*B*Z1*Z2 -C*** WHERE EACH QI AND ZI IS A GIVENS ROTATION - 60 IF (LS2.EQ.2) GO TO 110 - G = MAX(ABS(A(L2,L2)),ABS(B(L2,L2))) - ALTB = .TRUE. - IF (ABS(A(L2,L2)).LT.G) GO TO 70 - ALTB = .FALSE. - CALL DLARTG(A(L,L), A(L1,L), D, E,TEMPR) - CALL DROT(N-L+1, A(L,L), NMAX, A(L1,L), NMAX, D, E) - CALL DROT(N-L+1, B(L,L), NMAX, B(L1,L), NMAX, D, E) -C** EVALUATE THE PENCIL AT THE EIGENVALUE CORRESPONDING -C** TO THE 1X1 BLOCK - 70 SA = A(L2,L2)/G - SB = B(L2,L2)/G - DO 90 I=1,2 - LI = L + I - 1 - DO 80 J=1,3 - LJ = L + J - 1 - U(I,J) = SA*B(LI,LJ) - SB*A(LI,LJ) - 80 CONTINUE - 90 CONTINUE - CALL DLARTG(U(1,1), U(2,1), D, E,TEMPR) - CALL DROT(3, U(1,1), 3, U(2,1), 3, D, E) -C* PERFORM THE COLUMN TRANSFORMATION Z1 - CALL DLARTG(U(2,2), U(2,3), D, E,TEMPR) - U(1,2) = U(1,2)*E - U(1,3)*D - CALL DROT(L2, A(1,L1), 1, A(1,L2), 1, E, -D) - CALL DROT(L2, B(1,L1), 1, B(1,L2), 1, E, -D) - CALL DROT(N, Z(1,L1), 1, Z(1,L2), 1, E, -D) -C* PERFORM THE ROW TRANSFORMATION Q1 - IF (ALTB) CALL DLARTG(B(L1,L1), B(L2,L1), D, E,TEMPR) - IF (.NOT.ALTB) CALL DLARTG(A(L1,L1), A(L2,L1), D, E,TEMPR) - CALL DROT(N-L+1, A(L1,L), NMAX, A(L2,L), NMAX, D, E) - CALL DROT(N-L+1, B(L1,L), NMAX, B(L2,L), NMAX, D, E) -C* PERFORM THE COLUMN TRANSFORMATION Z2 - CALL DLARTG(U(1,1), U(1,2), D, E,TEMPR) - CALL DROT(L2, A(1,L), 1, A(1,L1), 1, E, -D) - CALL DROT(L2, B(1,L), 1, B(1,L1), 1, E, -D) - CALL DROT(N, Z(1,L), 1, Z(1,L1), 1, E, -D) -C* PERFORM THE ROW TRANSFORMATION Q2 - IF (ALTB) CALL DLARTG(B(L,L), B(L1,L), D, E,TEMPR) - IF (.NOT.ALTB) CALL DLARTG(A(L,L), A(L1,L), D, E,TEMPR) - CALL DROT(N-L+1, A(L,L), NMAX, A(L1,L), NMAX, D, E) - CALL DROT(N-L+1, B(L,L), NMAX, B(L1,L), NMAX, D, E) - IF (ALTB) GO TO 100 - CALL DLARTG(B(L1,L1), B(L2,L1), D, E,TEMPR) - CALL DROT(N-L, A(L1,L1), NMAX, A(L2,L1), NMAX, D, E) - CALL DROT(N-L, B(L1,L1), NMAX, B(L2,L1), NMAX, D, E) -C* PUT THE NEGLECTABLE ELEMENTS EQUAL TO ZERO - 100 A(L1,L) = 0. - A(L2,L) = 0. - B(L1,L) = 0. - B(L2,1) = 0. - B(L2,L1) = 0. - RETURN -C*** INTERCHANGE 2X2 AND 2X2 BLOCKS VIA A SEQUENCE OF -C*** QZ-STEPS REALIZED BY THE EQUIVALENCE TRANSFORMATIONS -C*** A:=Q5*Q4*Q3*Q2*Q1*A*Z1*Z2*Z3*Z4*Z5 -C*** B:=Q5*Q4*Q3*Q2*Q1*B*Z1*Z2*Z3*Z4*Z5 -C*** WHERE EACH QI AND ZI IS A GIVENS ROTATION - 110 L3 = L + 3 -C* COMPUTE IMPLICIT SHIFT - AMMBMM = A(L,L)/B(L,L) - ANMBMM = A(L1,L)/B(L,L) - AMNBNN = A(L,L1)/B(L1,L1) - ANNBNN = A(L1,L1)/B(L1,L1) - BMNBNN = B(L,L1)/B(L1,L1) - DO 130 IT1=1,3 - U(1,1) = 1. - U(2,1) = 1. - U(3,1) = 1. - DO 120 IT2=1,10 -C* PERFORM ROW TRANSFORMATIONS Q1 AND Q2 - CALL DLARTG(U(2,1), U(3,1), D, E,TEMPR) - CALL DROT(N-L+1, A(L1,L), NMAX, A(L2,L), NMAX, D, E) - CALL DROT(N-L, B(L1,L1), NMAX, B(L2,L1), NMAX, D, E) - U(2,1) = D*U(2,1) + E*U(3,1) - CALL DLARTG(U(1,1), U(2,1), D, E,TEMPR) - CALL DROT(N-L+1, A(L,L), NMAX, A(L1,L), NMAX, D, E) - CALL DROT(N-L+1, B(L,L), NMAX, B(L1,L), NMAX, D, E) -C* PERFORM COLUMN TRANSFORMATIONS Z1 AND Z2 - CALL DLARTG(B(L2,L1), B(L2,L2), D, E,TEMPR) - CALL DROT(L3, A(1,L1), 1, A(1,L2), 1, E, -D) - CALL DROT(L2, B(1,L1), 1, B(1,L2), 1, E, -D) - CALL DROT(N, Z(1,L1), 1, Z(1,L2), 1, E, -D) - CALL DLARTG(B(L1,L), B(L1,L1), D, E,TEMPR) - CALL DROT(L3, A(1,L), 1, A(1,L1), 1, E, -D) - CALL DROT(L1, B(1,L), 1, B(1,L1), 1, E, -D) - CALL DROT(N, Z(1,L), 1, Z(1,L1), 1, E, -D) -C* PERFORM TRANSFORMATIONS Q3,Z3,Q4,Z4,Q5 AND Z5 IN -C* ORDER TO REDUCE THE PENCIL TO HESSENBERG FORM - CALL DLARTG(A(L2,L), A(L3,L), D, E,TEMPR) - CALL DROT(N-L+1, A(L2,L), NMAX, A(L3,L), NMAX, D, E) - CALL DROT(N-L1, B(L2,L2), NMAX, B(L3,L2), NMAX, D, E) - CALL DLARTG(B(L3,L2), B(L3,L3), D, E,TEMPR) - CALL DROT(L3, A(1,L2), 1, A(1,L3), 1, E, -D) - CALL DROT(L3, B(1,L2), 1, B(1,L3), 1, E, -D) - CALL DROT(N, Z(1,L2), 1, Z(1,L3), 1, E, -D) - CALL DLARTG(A(L1,L), A(L2,L), D, E,TEMPR) - CALL DROT(N-L+1, A(L1,L), NMAX, A(L2,L), NMAX, D, E) - CALL DROT(N-L, B(L1,L1), NMAX, B(L2,L1), NMAX, D, E) - CALL DLARTG(B(L2,L1), B(L2,L2), D, E,TEMPR) - CALL DROT(L3, A(1,L1), 1, A(1,L2), 1, E, -D) - CALL DROT(L2, B(1,L1), 1, B(1,L2), 1, E, -D) - CALL DROT(N, Z(1,L1), 1, Z(1,L2), 1, E, -D) - CALL DLARTG(A(L2,L1), A(L3,L1), D, E,TEMPR) - CALL DROT(N-L, A(L2,L1), NMAX, A(L3,L1), NMAX, D, E) - CALL DROT(N-L1, B(L2,L2), NMAX, B(L3,L2), NMAX, D, E) - CALL DLARTG(B(L3,L2), B(L3,L3), D, E,TEMPR) - CALL DROT(L3, A(1,L2), 1, A(1,L3), 1, E, -D) - CALL DROT(L3, B(1,L2), 1, B(1,L3), 1, E, -D) - CALL DROT(N, Z(1,L2), 1, Z(1,L3), 1, E, -D) -C* TEST OF CONVERGENCE ON THE ELEMENT SEPARATING THE BLOCKS - IF (ABS(A(L2,L1)).LE.EPS) GO TO 140 -C* COMPUTE A NEW SHIFT IN CASE OF NO CONVERGENCE - A11B11 = A(L,L)/B(L,L) - A12B22 = A(L,L1)/B(L1,L1) - A21B11 = A(L1,L)/B(L,L) - A22B22 = A(L1,L1)/B(L1,L1) - B12B22 = B(L,L1)/B(L1,L1) - U(1,1) = ((AMMBMM-A11B11)*(ANNBNN-A11B11)-AMNBNN* - * ANMBMM+ANMBMM*BMNBNN*A11B11)/A21B11 + A12B22 - A11B11*B12B22 - U(2,1) = (A22B22-A11B11) - A21B11*B12B22 - (AMMBMM-A11B11) - - * (ANNBNN-A11B11) + ANMBMM*BMNBNN - U(3,1) = A(L2,L1)/B(L1,L1) - 120 CONTINUE - 130 CONTINUE - FAIL = .TRUE. - RETURN -C* PUT THE NEGLECTABLE ELEMENTS EQUAL TO ZERO IN -C* CASE OF CONVERGENCE - 140 A(L2,L) = 0. - A(L2,L1) = 0. - A(L3,L) = 0. - A(L3,L1) = 0. - B(L1,L) = 0. - B(L2,L) = 0. - B(L2,L1) = 0. - B(L3,L) = 0. - B(L3,L1) = 0. - B(L3,L2) = 0. - RETURN - END
--- a/liboctave/cruft/ordered-qz/module.mk Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,8 +0,0 @@ -CRUFT_SOURCES += \ - liboctave/cruft/ordered-qz/dsubsp.f \ - liboctave/cruft/ordered-qz/exchqz.f \ - liboctave/cruft/ordered-qz/ssubsp.f \ - liboctave/cruft/ordered-qz/sexchqz.f - -liboctave_EXTRA_DIST += \ - liboctave/cruft/ordered-qz/README
--- a/liboctave/cruft/ordered-qz/sexchqz.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,261 +0,0 @@ - SUBROUTINE SEXCHQZ(NMAX, N, A, B, Z, L, LS1, LS2, EPS, FAIL) - INTEGER NMAX, N, L, LS1, LS2 - REAL A(NMAX,N), B(NMAX,N), Z(NMAX,N), EPS - LOGICAL FAIL -c modified july 9, 1998 a.s.hodel@eng.auburn.edu: -c calls to AMAX1 changed to call MAX instead. -c calls to giv changed to slartg (LAPACK); required new variable tempr -C* -C* GIVEN THE UPPER TRIANGULAR MATRIX B AND UPPER HESSENBERG MATRIX A -C* WITH CONSECUTIVE LS1XLS1 AND LS2XLS2 DIAGONAL BLOCKS (LS1,LS2.LE.2) -C* STARTING AT ROW/COLUMN L, EXCHQZ PRODUCES EQUIVALENCE TRANSFORMA- -C* TIONS QT AND ZT THAT EXCHANGE THE BLOCKS ALONG WITH THEIR GENERALIZED -C* EIGENVALUES. EXCHQZ REQUIRES THE SUBROUTINES SROT (BLAS) AND GIV. -C* THE PARAMETERS IN THE CALLING SEQUENCE ARE (STARRED PARAMETERS ARE -C* ALTERED BY THE SUBROUTINE): -C* -C* NMAX THE FIRST DIMENSION OF A, B AND Z -C* N THE ORDER OF A, B AND Z -C* *A,*B THE MATRIX PAIR WHOSE BLOCKS ARE TO BE INTERCHANGED -C* *Z UPON RETURN THIS ARRAY IS MULTIPLIED BY THE COLUMN -C* TRANSFORMATION ZT. -C* L THE POSITION OF THE BLOCKS -C* LS1 THE SIZE OF THE FIRST BLOCK -C* LS2 THE SIZE OF THE SECOND BLOCK -C* EPS THE REQUIRED ABSOLUTE ACCURACY OF THE RESULT -C* *FAIL A LOGICAL VARIABLE WHICH IS FALSE ON A NORMAL RETURN, -C* TRUE OTHERWISE. -C* - INTEGER I, J, L1, L2, L3, LI, LJ, LL, IT1, IT2 - REAL U(3,3), D, E, F, G, SA, SB, A11B11, A21B11, - * A12B22, B12B22, - * A22B22, AMMBMM, ANMBMM, AMNBNN, BMNBNN, ANNBNN, TEMPR - LOGICAL ALTB - FAIL = .FALSE. - L1 = L + 1 - LL = LS1 + LS2 - IF (LL.GT.2) GO TO 10 -C*** INTERCHANGE 1X1 AND 1X1 BLOCKS VIA AN EQUIVALENCE -C*** TRANSFORMATION A:=Q*A*Z , B:=Q*B*Z -C*** WHERE Q AND Z ARE GIVENS ROTATIONS - F = MAX(ABS(A(L1,L1)),ABS(B(L1,L1))) - ALTB = .TRUE. - IF (ABS(A(L1,L1)).GE.F) ALTB = .FALSE. - SA = A(L1,L1)/F - SB = B(L1,L1)/F - F = SA*B(L,L) - SB*A(L,L) -C* CONSTRUCT THE COLUMN TRANSFORMATION Z - G = SA*B(L,L1) - SB*A(L,L1) - CALL SLARTG(F, G, D, E,TEMPR) - CALL SROT(L1, A(1,L), 1, A(1,L1), 1, E, -D) - CALL SROT(L1, B(1,L), 1, B(1,L1), 1, E, -D) - CALL SROT(N, Z(1,L), 1, Z(1,L1), 1, E, -D) -C* CONSTRUCT THE ROW TRANSFORMATION Q - IF (ALTB) CALL SLARTG(B(L,L), B(L1,L), D, E,TEMPR) - IF (.NOT.ALTB) CALL SLARTG(A(L,L), A(L1,L), D, E,TEMPR) - CALL SROT(N-L+1, A(L,L), NMAX, A(L1,L), NMAX, D, E) - CALL SROT(N-L+1, B(L,L), NMAX, B(L1,L), NMAX, D, E) - A(L1,L) = 0. - B(L1,L) = 0. - RETURN -C*** INTERCHANGE 1X1 AND 2X2 BLOCKS VIA AN EQUIVALENCE -C*** TRANSFORMATION A:=Q2*Q1*A*Z1*Z2 , B:=Q2*Q1*B*Z1*Z2 -C*** WHERE EACH QI AND ZI IS A GIVENS ROTATION - 10 L2 = L + 2 - IF (LS1.EQ.2) GO TO 60 - G = MAX(ABS(A(L,L)),ABS(B(L,L))) - ALTB = .TRUE. - IF (ABS(A(L,L)).LT.G) GO TO 20 - ALTB = .FALSE. - CALL SLARTG(A(L1,L1), A(L2,L1), D, E,TEMPR) - CALL SROT(N-L, A(L1,L1), NMAX, A(L2,L1), NMAX, D, E) - CALL SROT(N-L, B(L1,L1), NMAX, B(L2,L1), NMAX, D, E) -C** EVALUATE THE PENCIL AT THE EIGENVALUE CORRESPONDING -C** TO THE 1X1 BLOCK - 20 SA = A(L,L)/G - SB = B(L,L)/G - DO 40 J=1,2 - LJ = L + J - DO 30 I=1,3 - LI = L + I - 1 - U(I,J) = SA*B(LI,LJ) - SB*A(LI,LJ) - 30 CONTINUE - 40 CONTINUE - CALL SLARTG(U(3,1), U(3,2), D, E,TEMPR) - CALL SROT(3, U(1,1), 1, U(1,2), 1, E, -D) -C* PERFORM THE ROW TRANSFORMATION Q1 - CALL SLARTG(U(1,1), U(2,1), D, E,TEMPR) - U(2,2) = -U(1,2)*E + U(2,2)*D - CALL SROT(N-L+1, A(L,L), NMAX, A(L1,L), NMAX, D, E) - CALL SROT(N-L+1, B(L,L), NMAX, B(L1,L), NMAX, D, E) -C* PERFORM THE COLUMN TRANSFORMATION Z1 - IF (ALTB) CALL SLARTG(B(L1,L), B(L1,L1), D, E,TEMPR) - IF (.NOT.ALTB) CALL SLARTG(A(L1,L), A(L1,L1), D, E,TEMPR) - CALL SROT(L2, A(1,L), 1, A(1,L1), 1, E, -D) - CALL SROT(L2, B(1,L), 1, B(1,L1), 1, E, -D) - CALL SROT(N, Z(1,L), 1, Z(1,L1), 1, E, -D) -C* PERFORM THE ROW TRANSFORMATION Q2 - CALL SLARTG(U(2,2), U(3,2), D, E,TEMPR) - CALL SROT(N-L+1, A(L1,L), NMAX, A(L2,L), NMAX, D, E) - CALL SROT(N-L+1, B(L1,L), NMAX, B(L2,L), NMAX, D, E) -C* PERFORM THE COLUMN TRANSFORMATION Z2 - IF (ALTB) CALL SLARTG(B(L2,L1), B(L2,L2), D, E,TEMPR) - IF (.NOT.ALTB) CALL SLARTG(A(L2,L1), A(L2,L2), D, E,TEMPR) - CALL SROT(L2, A(1,L1), 1, A(1,L2), 1, E, -D) - CALL SROT(L2, B(1,L1), 1, B(1,L2), 1, E, -D) - CALL SROT(N, Z(1,L1), 1, Z(1,L2), 1, E, -D) - IF (ALTB) GO TO 50 - CALL SLARTG(B(L,L), B(L1,L), D, E,TEMPR) - CALL SROT(N-L+1, A(L,L), NMAX, A(L1,L), NMAX, D, E) - CALL SROT(N-L+1, B(L,L), NMAX, B(L1,L), NMAX, D, E) -C* PUT THE NEGLECTABLE ELEMENTS EQUAL TO ZERO - 50 A(L2,L) = 0. - A(L2,L1) = 0. - B(L1,L) = 0. - B(L2,L) = 0. - B(L2,L1) = 0. - RETURN -C*** INTERCHANGE 2X2 AND 1X1 BLOCKS VIA AN EQUIVALENCE -C*** TRANSFORMATION A:=Q2*Q1*A*Z1*Z2 , B:=Q2*Q1*B*Z1*Z2 -C*** WHERE EACH QI AND ZI IS A GIVENS ROTATION - 60 IF (LS2.EQ.2) GO TO 110 - G = MAX(ABS(A(L2,L2)),ABS(B(L2,L2))) - ALTB = .TRUE. - IF (ABS(A(L2,L2)).LT.G) GO TO 70 - ALTB = .FALSE. - CALL SLARTG(A(L,L), A(L1,L), D, E,TEMPR) - CALL SROT(N-L+1, A(L,L), NMAX, A(L1,L), NMAX, D, E) - CALL SROT(N-L+1, B(L,L), NMAX, B(L1,L), NMAX, D, E) -C** EVALUATE THE PENCIL AT THE EIGENVALUE CORRESPONDING -C** TO THE 1X1 BLOCK - 70 SA = A(L2,L2)/G - SB = B(L2,L2)/G - DO 90 I=1,2 - LI = L + I - 1 - DO 80 J=1,3 - LJ = L + J - 1 - U(I,J) = SA*B(LI,LJ) - SB*A(LI,LJ) - 80 CONTINUE - 90 CONTINUE - CALL SLARTG(U(1,1), U(2,1), D, E,TEMPR) - CALL SROT(3, U(1,1), 3, U(2,1), 3, D, E) -C* PERFORM THE COLUMN TRANSFORMATION Z1 - CALL SLARTG(U(2,2), U(2,3), D, E,TEMPR) - U(1,2) = U(1,2)*E - U(1,3)*D - CALL SROT(L2, A(1,L1), 1, A(1,L2), 1, E, -D) - CALL SROT(L2, B(1,L1), 1, B(1,L2), 1, E, -D) - CALL SROT(N, Z(1,L1), 1, Z(1,L2), 1, E, -D) -C* PERFORM THE ROW TRANSFORMATION Q1 - IF (ALTB) CALL SLARTG(B(L1,L1), B(L2,L1), D, E,TEMPR) - IF (.NOT.ALTB) CALL SLARTG(A(L1,L1), A(L2,L1), D, E,TEMPR) - CALL SROT(N-L+1, A(L1,L), NMAX, A(L2,L), NMAX, D, E) - CALL SROT(N-L+1, B(L1,L), NMAX, B(L2,L), NMAX, D, E) -C* PERFORM THE COLUMN TRANSFORMATION Z2 - CALL SLARTG(U(1,1), U(1,2), D, E,TEMPR) - CALL SROT(L2, A(1,L), 1, A(1,L1), 1, E, -D) - CALL SROT(L2, B(1,L), 1, B(1,L1), 1, E, -D) - CALL SROT(N, Z(1,L), 1, Z(1,L1), 1, E, -D) -C* PERFORM THE ROW TRANSFORMATION Q2 - IF (ALTB) CALL SLARTG(B(L,L), B(L1,L), D, E,TEMPR) - IF (.NOT.ALTB) CALL SLARTG(A(L,L), A(L1,L), D, E,TEMPR) - CALL SROT(N-L+1, A(L,L), NMAX, A(L1,L), NMAX, D, E) - CALL SROT(N-L+1, B(L,L), NMAX, B(L1,L), NMAX, D, E) - IF (ALTB) GO TO 100 - CALL SLARTG(B(L1,L1), B(L2,L1), D, E,TEMPR) - CALL SROT(N-L, A(L1,L1), NMAX, A(L2,L1), NMAX, D, E) - CALL SROT(N-L, B(L1,L1), NMAX, B(L2,L1), NMAX, D, E) -C* PUT THE NEGLECTABLE ELEMENTS EQUAL TO ZERO - 100 A(L1,L) = 0. - A(L2,L) = 0. - B(L1,L) = 0. - B(L2,1) = 0. - B(L2,L1) = 0. - RETURN -C*** INTERCHANGE 2X2 AND 2X2 BLOCKS VIA A SEQUENCE OF -C*** QZ-STEPS REALIZED BY THE EQUIVALENCE TRANSFORMATIONS -C*** A:=Q5*Q4*Q3*Q2*Q1*A*Z1*Z2*Z3*Z4*Z5 -C*** B:=Q5*Q4*Q3*Q2*Q1*B*Z1*Z2*Z3*Z4*Z5 -C*** WHERE EACH QI AND ZI IS A GIVENS ROTATION - 110 L3 = L + 3 -C* COMPUTE IMPLICIT SHIFT - AMMBMM = A(L,L)/B(L,L) - ANMBMM = A(L1,L)/B(L,L) - AMNBNN = A(L,L1)/B(L1,L1) - ANNBNN = A(L1,L1)/B(L1,L1) - BMNBNN = B(L,L1)/B(L1,L1) - DO 130 IT1=1,3 - U(1,1) = 1. - U(2,1) = 1. - U(3,1) = 1. - DO 120 IT2=1,10 -C* PERFORM ROW TRANSFORMATIONS Q1 AND Q2 - CALL SLARTG(U(2,1), U(3,1), D, E,TEMPR) - CALL SROT(N-L+1, A(L1,L), NMAX, A(L2,L), NMAX, D, E) - CALL SROT(N-L, B(L1,L1), NMAX, B(L2,L1), NMAX, D, E) - U(2,1) = D*U(2,1) + E*U(3,1) - CALL SLARTG(U(1,1), U(2,1), D, E,TEMPR) - CALL SROT(N-L+1, A(L,L), NMAX, A(L1,L), NMAX, D, E) - CALL SROT(N-L+1, B(L,L), NMAX, B(L1,L), NMAX, D, E) -C* PERFORM COLUMN TRANSFORMATIONS Z1 AND Z2 - CALL SLARTG(B(L2,L1), B(L2,L2), D, E,TEMPR) - CALL SROT(L3, A(1,L1), 1, A(1,L2), 1, E, -D) - CALL SROT(L2, B(1,L1), 1, B(1,L2), 1, E, -D) - CALL SROT(N, Z(1,L1), 1, Z(1,L2), 1, E, -D) - CALL SLARTG(B(L1,L), B(L1,L1), D, E,TEMPR) - CALL SROT(L3, A(1,L), 1, A(1,L1), 1, E, -D) - CALL SROT(L1, B(1,L), 1, B(1,L1), 1, E, -D) - CALL SROT(N, Z(1,L), 1, Z(1,L1), 1, E, -D) -C* PERFORM TRANSFORMATIONS Q3,Z3,Q4,Z4,Q5 AND Z5 IN -C* ORDER TO REDUCE THE PENCIL TO HESSENBERG FORM - CALL SLARTG(A(L2,L), A(L3,L), D, E,TEMPR) - CALL SROT(N-L+1, A(L2,L), NMAX, A(L3,L), NMAX, D, E) - CALL SROT(N-L1, B(L2,L2), NMAX, B(L3,L2), NMAX, D, E) - CALL SLARTG(B(L3,L2), B(L3,L3), D, E,TEMPR) - CALL SROT(L3, A(1,L2), 1, A(1,L3), 1, E, -D) - CALL SROT(L3, B(1,L2), 1, B(1,L3), 1, E, -D) - CALL SROT(N, Z(1,L2), 1, Z(1,L3), 1, E, -D) - CALL SLARTG(A(L1,L), A(L2,L), D, E,TEMPR) - CALL SROT(N-L+1, A(L1,L), NMAX, A(L2,L), NMAX, D, E) - CALL SROT(N-L, B(L1,L1), NMAX, B(L2,L1), NMAX, D, E) - CALL SLARTG(B(L2,L1), B(L2,L2), D, E,TEMPR) - CALL SROT(L3, A(1,L1), 1, A(1,L2), 1, E, -D) - CALL SROT(L2, B(1,L1), 1, B(1,L2), 1, E, -D) - CALL SROT(N, Z(1,L1), 1, Z(1,L2), 1, E, -D) - CALL SLARTG(A(L2,L1), A(L3,L1), D, E,TEMPR) - CALL SROT(N-L, A(L2,L1), NMAX, A(L3,L1), NMAX, D, E) - CALL SROT(N-L1, B(L2,L2), NMAX, B(L3,L2), NMAX, D, E) - CALL SLARTG(B(L3,L2), B(L3,L3), D, E,TEMPR) - CALL SROT(L3, A(1,L2), 1, A(1,L3), 1, E, -D) - CALL SROT(L3, B(1,L2), 1, B(1,L3), 1, E, -D) - CALL SROT(N, Z(1,L2), 1, Z(1,L3), 1, E, -D) -C* TEST OF CONVERGENCE ON THE ELEMENT SEPARATING THE BLOCKS - IF (ABS(A(L2,L1)).LE.EPS) GO TO 140 -C* COMPUTE A NEW SHIFT IN CASE OF NO CONVERGENCE - A11B11 = A(L,L)/B(L,L) - A12B22 = A(L,L1)/B(L1,L1) - A21B11 = A(L1,L)/B(L,L) - A22B22 = A(L1,L1)/B(L1,L1) - B12B22 = B(L,L1)/B(L1,L1) - U(1,1) = ((AMMBMM-A11B11)*(ANNBNN-A11B11)-AMNBNN* - * ANMBMM+ANMBMM*BMNBNN*A11B11)/A21B11 + A12B22 - A11B11*B12B22 - U(2,1) = (A22B22-A11B11) - A21B11*B12B22 - (AMMBMM-A11B11) - - * (ANNBNN-A11B11) + ANMBMM*BMNBNN - U(3,1) = A(L2,L1)/B(L1,L1) - 120 CONTINUE - 130 CONTINUE - FAIL = .TRUE. - RETURN -C* PUT THE NEGLECTABLE ELEMENTS EQUAL TO ZERO IN -C* CASE OF CONVERGENCE - 140 A(L2,L) = 0. - A(L2,L1) = 0. - A(L3,L) = 0. - A(L3,L1) = 0. - B(L1,L) = 0. - B(L2,L) = 0. - B(L2,L1) = 0. - B(L3,L) = 0. - B(L3,L1) = 0. - B(L3,L2) = 0. - RETURN - END
--- a/liboctave/cruft/ordered-qz/ssubsp.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,104 +0,0 @@ - SUBROUTINE SSUBSP(NMAX, N, A, B, Z, FTEST, EPS, NDIM, FAIL, IND) - INTEGER NMAX, N, FTEST, NDIM, IND(N) - LOGICAL FAIL - REAL A(NMAX,N), B(NMAX,N), Z(NMAX,N), EPS -C* -C* GIVEN THE UPPER TRIANGULAR MATRIX B AND UPPER HESSENBERG MATRIX A -C* WITH 1X1 OR 2X2 DIAGONAL BLOCKS, THIS ROUTINE REORDERS THE DIAGONAL -C* BLOCKS ALONG WITH THEIR GENERALIZED EIGENVALUES BY CONSTRUCTING EQUI- -C* VALENCE TRANSFORMATIONS QT AND ZT. THE ROW TRANSFORMATION ZT IS ALSO -C* PERFORMED ON THE GIVEN (INITIAL) TRANSFORMATION Z (RESULTING FROM A -C* POSSIBLE PREVIOUS STEP OR INITIALIZED WITH THE IDENTITY MATRIX). -C* AFTER REORDERING, THE EIGENVALUES INSIDE THE REGION SPECIFIED BY THE -C* FUNCTION FTEST APPEAR AT THE TOP. IF NDIM IS THEIR NUMBER THEN THE -C* NDIM FIRST COLUMNS OF Z SPAN THE REQUESTED SUBSPACE. DSUBSP REQUIRES -C* THE SUBROUTINE EXCHQZ AND THE INTEGER FUNCTION FTEST WHICH HAS TO BE -C* PROVIDED BY THE USER. THE PARAMETERS IN THE CALLING SEQUENCE ARE : -C* (STARRED PARAMETERS ARE ALTERED BY THE SUBROUTINE) -C* -C* NMAX THE FIRST DIMENSION OF A, B AND Z -C* N THE ORDER OF A, B AND Z -C* *A,*B THE MATRIX PAIR WHOSE BLOCKS ARE TO BE REORDERED. -C* *Z UPON RETURN THIS ARRAY IS MULTIPLIED BY THE COLUMN -C* TRANSFORMATION ZT. -C* FTEST(LS,ALPHA,BETA,S,P) AN INTEGER FUNCTION DESCRIBING THE -C* SPECTRUM OF THE DEFLATING SUBSPACE TO BE COMPUTED: -C* WHEN LS=1 FTEST CHECKS IF ALPHA/BETA IS IN THAT SPECTRUM -C* WHEN LS=2 FTEST CHECKS IF THE TWO COMPLEX CONJUGATE -C* ROOTS WITH SUM S AND PRODUCT P ARE IN THAT SPECTRUM -C* IF THE ANSWER IS POSITIVE, FTEST=1, OTHERWISE FTEST=-1 -C* EPS THE REQUIRED ABSOLUTE ACCURACY OF THE RESULT -C* *NDIM AN INTEGER GIVING THE DIMENSION OF THE COMPUTED -C* DEFLATING SUBSPACE -C* *FAIL A LOGICAL VARIABLE WHICH IS FALSE ON A NORMAL RETURN, -C* TRUE OTHERWISE (WHEN SEXCHQZ FAILS) -C* *IND AN INTEGER WORKING ARRAY OF DIMENSION AT LEAST N -C* - INTEGER L, LS, LS1, LS2, L1, LL, NUM, IS, L2I, L2K, I, K, II, - * ISTEP, IFIRST - REAL S, P, D, ALPHA, BETA - FAIL = .TRUE. - NDIM = 0 - NUM = 0 - L = 0 - LS = 1 -C*** CONSTRUCT ARRAY IND(I) WHERE : -C*** IABS(IND(I)) IS THE SIZE OF THE BLOCK I -C*** SIGN(IND(I)) INDICATES THE LOCATION OF ITS EIGENVALUES -C*** (AS DETERMINED BY FTEST). -C*** NUM IS THE NUMBER OF ELEMENTS IN THIS ARRAY - DO 30 LL=1,N - L = L + LS - IF (L.GT.N) GO TO 40 - L1 = L + 1 - IF (L1.GT.N) GO TO 10 - IF (A(L1,L).EQ.0.) GO TO 10 -C* HERE A 2X2 BLOCK IS CHECKED * - LS = 2 - D = B(L,L)*B(L1,L1) - S = (A(L,L)*B(L1,L1)+A(L1,L1)*B(L,L)-A(L1,L)*B(L,L1))/D - P = (A(L,L)*A(L1,L1)-A(L,L1)*A(L1,L))/D - IS = FTEST(LS,ALPHA,BETA,S,P) - GO TO 20 -C* HERE A 1X1 BLOCK IS CHECKED * - 10 LS = 1 - IS = FTEST(LS,A(L,L),B(L,L),S,P) - 20 NUM = NUM + 1 - IF (IS.EQ.1) NDIM = NDIM + LS - IND(NUM) = LS*IS - 30 CONTINUE -C*** REORDER BLOCKS SUCH THAT THOSE WITH POSITIVE VALUE -C*** OF IND(.) APPEAR FIRST. - 40 L2I = 1 - DO 100 I=1,NUM - IF (IND(I).GT.0) GO TO 90 -C* IF A NEGATIVE IND(I) IS ENCOUNTERED, THEN SEARCH FOR THE FIRST -C* POSITIVE IND(K) FOLLOWING ON IT - L2K = L2I - DO 60 K=I,NUM - IF (IND(K).LT.0) GO TO 50 - GO TO 70 - 50 L2K = L2K - IND(K) - 60 CONTINUE -C* IF THERE ARE NO POSITIVE INDICES FOLLOWING ON A NEGATIVE ONE -C* THEN STOP - GO TO 110 -C* IF A POSITIVE IND(K) FOLLOWS ON A NEGATIVE IND(I) THEN -C* INTERCHANGE BLOCK K BEFORE BLOCK I BY PERFORMING K-I SWAPS - 70 ISTEP = K - I - LS2 = IND(K) - L = L2K - DO 80 II=1,ISTEP - IFIRST = K - II - LS1 = -IND(IFIRST) - L = L - LS1 - CALL SEXCHQZ(NMAX, N, A, B, Z, L, LS1, LS2, EPS, FAIL) - IF (FAIL) RETURN - IND(IFIRST+1) = IND(IFIRST) - 80 CONTINUE - IND(I) = LS2 - 90 L2I = L2I + IND(I) - 100 CONTINUE - 110 FAIL = .FALSE. - RETURN - END
--- a/liboctave/cruft/quadpack/dqagi.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,190 +0,0 @@ - SUBROUTINE DQAGI(F,BOUND,INF,EPSABS,EPSREL,RESULT,ABSERR,NEVAL, - * IER,LIMIT,LENW,LAST,IWORK,WORK) -C***BEGIN PROLOGUE DQAGI -C***DATE WRITTEN 800101 (YYMMDD) -C***REVISION DATE 830518 (YYMMDD) -C***CATEGORY NO. H2A3A1,H2A4A1 -C***KEYWORDS AUTOMATIC INTEGRATOR, INFINITE INTERVALS, -C GENERAL-PURPOSE, TRANSFORMATION, EXTRAPOLATION, -C GLOBALLY ADAPTIVE -C***AUTHOR PIESSENS,ROBERT,APPL. MATH. & PROGR. DIV. - K.U.LEUVEN -C DE DONCKER,ELISE,APPL. MATH. & PROGR. DIV. -K.U.LEUVEN -C***PURPOSE THE ROUTINE CALCULATES AN APPROXIMATION RESULT TO A GIVEN -C INTEGRAL I = INTEGRAL OF F OVER (BOUND,+INFINITY) -C OR I = INTEGRAL OF F OVER (-INFINITY,BOUND) -C OR I = INTEGRAL OF F OVER (-INFINITY,+INFINITY) -C HOPEFULLY SATISFYING FOLLOWING CLAIM FOR ACCURACY -C ABS(I-RESULT).LE.MAX(EPSABS,EPSREL*ABS(I)). -C***DESCRIPTION -C -C INTEGRATION OVER INFINITE INTERVALS -C STANDARD FORTRAN SUBROUTINE -C -C PARAMETERS -C ON ENTRY -C F - SUBROUTINE F(X,RESULT) DEFINING THE INTEGRAND -C FUNCTION F(X). THE ACTUAL NAME FOR F NEEDS TO BE -C DECLARED E X T E R N A L IN THE DRIVER PROGRAM. -C -C BOUND - DOUBLE PRECISION -C FINITE BOUND OF INTEGRATION RANGE -C (HAS NO MEANING IF INTERVAL IS DOUBLY-INFINITE) -C -C INF - INTEGER -C INDICATING THE KIND OF INTEGRATION RANGE INVOLVED -C INF = 1 CORRESPONDS TO (BOUND,+INFINITY), -C INF = -1 TO (-INFINITY,BOUND), -C INF = 2 TO (-INFINITY,+INFINITY). -C -C EPSABS - DOUBLE PRECISION -C ABSOLUTE ACCURACY REQUESTED -C EPSREL - DOUBLE PRECISION -C RELATIVE ACCURACY REQUESTED -C IF EPSABS.LE.0 -C AND EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28), -C THE ROUTINE WILL END WITH IER = 6. -C -C -C ON RETURN -C RESULT - DOUBLE PRECISION -C APPROXIMATION TO THE INTEGRAL -C -C ABSERR - DOUBLE PRECISION -C ESTIMATE OF THE MODULUS OF THE ABSOLUTE ERROR, -C WHICH SHOULD EQUAL OR EXCEED ABS(I-RESULT) -C -C NEVAL - INTEGER -C NUMBER OF INTEGRAND EVALUATIONS -C -C IER - INTEGER -C IER = 0 NORMAL AND RELIABLE TERMINATION OF THE -C ROUTINE. IT IS ASSUMED THAT THE REQUESTED -C ACCURACY HAS BEEN ACHIEVED. -C - IER.GT.0 ABNORMAL TERMINATION OF THE ROUTINE. THE -C ESTIMATES FOR RESULT AND ERROR ARE LESS -C RELIABLE. IT IS ASSUMED THAT THE REQUESTED -C ACCURACY HAS NOT BEEN ACHIEVED. -C ERROR MESSAGES -C IER = 1 MAXIMUM NUMBER OF SUBDIVISIONS ALLOWED -C HAS BEEN ACHIEVED. ONE CAN ALLOW MORE -C SUBDIVISIONS BY INCREASING THE VALUE OF -C LIMIT (AND TAKING THE ACCORDING DIMENSION -C ADJUSTMENTS INTO ACCOUNT). HOWEVER, IF -C THIS YIELDS NO IMPROVEMENT IT IS ADVISED -C TO ANALYZE THE INTEGRAND IN ORDER TO -C DETERMINE THE INTEGRATION DIFFICULTIES. IF -C THE POSITION OF A LOCAL DIFFICULTY CAN BE -C DETERMINED (E.G. SINGULARITY, -C DISCONTINUITY WITHIN THE INTERVAL) ONE -C WILL PROBABLY GAIN FROM SPLITTING UP THE -C INTERVAL AT THIS POINT AND CALLING THE -C INTEGRATOR ON THE SUBRANGES. IF POSSIBLE, -C AN APPROPRIATE SPECIAL-PURPOSE INTEGRATOR -C SHOULD BE USED, WHICH IS DESIGNED FOR -C HANDLING THE TYPE OF DIFFICULTY INVOLVED. -C = 2 THE OCCURRENCE OF ROUNDOFF ERROR IS -C DETECTED, WHICH PREVENTS THE REQUESTED -C TOLERANCE FROM BEING ACHIEVED. -C THE ERROR MAY BE UNDER-ESTIMATED. -C = 3 EXTREMELY BAD INTEGRAND BEHAVIOUR OCCURS -C AT SOME POINTS OF THE INTEGRATION -C INTERVAL. -C = 4 THE ALGORITHM DOES NOT CONVERGE. -C ROUNDOFF ERROR IS DETECTED IN THE -C EXTRAPOLATION TABLE. -C IT IS ASSUMED THAT THE REQUESTED TOLERANCE -C CANNOT BE ACHIEVED, AND THAT THE RETURNED -C RESULT IS THE BEST WHICH CAN BE OBTAINED. -C = 5 THE INTEGRAL IS PROBABLY DIVERGENT, OR -C SLOWLY CONVERGENT. IT MUST BE NOTED THAT -C DIVERGENCE CAN OCCUR WITH ANY OTHER VALUE -C OF IER. -C = 6 THE INPUT IS INVALID, BECAUSE -C (EPSABS.LE.0 AND -C EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28)) -C OR LIMIT.LT.1 OR LENIW.LT.LIMIT*4. -C RESULT, ABSERR, NEVAL, LAST ARE SET TO -C ZERO. EXEPT WHEN LIMIT OR LENIW IS -C INVALID, IWORK(1), WORK(LIMIT*2+1) AND -C WORK(LIMIT*3+1) ARE SET TO ZERO, WORK(1) -C IS SET TO A AND WORK(LIMIT+1) TO B. -C -C DIMENSIONING PARAMETERS -C LIMIT - INTEGER -C DIMENSIONING PARAMETER FOR IWORK -C LIMIT DETERMINES THE MAXIMUM NUMBER OF SUBINTERVALS -C IN THE PARTITION OF THE GIVEN INTEGRATION INTERVAL -C (A,B), LIMIT.GE.1. -C IF LIMIT.LT.1, THE ROUTINE WILL END WITH IER = 6. -C -C LENW - INTEGER -C DIMENSIONING PARAMETER FOR WORK -C LENW MUST BE AT LEAST LIMIT*4. -C IF LENW.LT.LIMIT*4, THE ROUTINE WILL END -C WITH IER = 6. -C -C LAST - INTEGER -C ON RETURN, LAST EQUALS THE NUMBER OF SUBINTERVALS -C PRODUCED IN THE SUBDIVISION PROCESS, WHICH -C DETERMINES THE NUMBER OF SIGNIFICANT ELEMENTS -C ACTUALLY IN THE WORK ARRAYS. -C -C WORK ARRAYS -C IWORK - INTEGER -C VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST -C K ELEMENTS OF WHICH CONTAIN POINTERS -C TO THE ERROR ESTIMATES OVER THE SUBINTERVALS, -C SUCH THAT WORK(LIMIT*3+IWORK(1)),... , -C WORK(LIMIT*3+IWORK(K)) FORM A DECREASING -C SEQUENCE, WITH K = LAST IF LAST.LE.(LIMIT/2+2), AND -C K = LIMIT+1-LAST OTHERWISE -C -C WORK - DOUBLE PRECISION -C VECTOR OF DIMENSION AT LEAST LENW -C ON RETURN -C WORK(1), ..., WORK(LAST) CONTAIN THE LEFT -C END POINTS OF THE SUBINTERVALS IN THE -C PARTITION OF (A,B), -C WORK(LIMIT+1), ..., WORK(LIMIT+LAST) CONTAIN -C THE RIGHT END POINTS, -C WORK(LIMIT*2+1), ...,WORK(LIMIT*2+LAST) CONTAIN THE -C INTEGRAL APPROXIMATIONS OVER THE SUBINTERVALS, -C WORK(LIMIT*3+1), ..., WORK(LIMIT*3) -C CONTAIN THE ERROR ESTIMATES. -C***REFERENCES (NONE) -C***ROUTINES CALLED DQAGIE,XERROR -C***END PROLOGUE DQAGI -C - DOUBLE PRECISION ABSERR,BOUND,EPSABS,EPSREL,RESULT,WORK - INTEGER IER,INF,IWORK,LAST,LENW,LIMIT,LVL,L1,L2,L3,NEVAL -C - DIMENSION IWORK(LIMIT),WORK(LENW) -C - EXTERNAL F -C -C CHECK VALIDITY OF LIMIT AND LENW. -C -C***FIRST EXECUTABLE STATEMENT DQAGI - IER = 6 - NEVAL = 0 - LAST = 0 - RESULT = 0.0D+00 - ABSERR = 0.0D+00 - IF(LIMIT.LT.1.OR.LENW.LT.LIMIT*4) GO TO 10 -C -C PREPARE CALL FOR DQAGIE. -C - L1 = LIMIT+1 - L2 = LIMIT+L1 - L3 = LIMIT+L2 -C - CALL DQAGIE(F,BOUND,INF,EPSABS,EPSREL,LIMIT,RESULT,ABSERR, - * NEVAL,IER,WORK(1),WORK(L1),WORK(L2),WORK(L3),IWORK,LAST) -C -C CALL ERROR HANDLER IF NECESSARY. -C - LVL = 0 -10 IF(IER.EQ.6) LVL = 1 - IF(IER.GT.0) CALL XERROR('ABNORMAL RETURN FROM DQAGI',26,IER,LVL) - RETURN - END
--- a/liboctave/cruft/quadpack/dqagie.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,457 +0,0 @@ - SUBROUTINE DQAGIE(F,BOUND,INF,EPSABS,EPSREL,LIMIT,RESULT,ABSERR, - * NEVAL,IER,ALIST,BLIST,RLIST,ELIST,IORD,LAST) -C***BEGIN PROLOGUE DQAGIE -C***DATE WRITTEN 800101 (YYMMDD) -C***REVISION DATE 830518 (YYMMDD) -C***CATEGORY NO. H2A3A1,H2A4A1 -C***KEYWORDS AUTOMATIC INTEGRATOR, INFINITE INTERVALS, -C GENERAL-PURPOSE, TRANSFORMATION, EXTRAPOLATION, -C GLOBALLY ADAPTIVE -C***AUTHOR PIESSENS,ROBERT,APPL. MATH & PROGR. DIV - K.U.LEUVEN -C DE DONCKER,ELISE,APPL. MATH & PROGR. DIV - K.U.LEUVEN -C***PURPOSE THE ROUTINE CALCULATES AN APPROXIMATION RESULT TO A GIVEN -C INTEGRAL I = INTEGRAL OF F OVER (BOUND,+INFINITY) -C OR I = INTEGRAL OF F OVER (-INFINITY,BOUND) -C OR I = INTEGRAL OF F OVER (-INFINITY,+INFINITY), -C HOPEFULLY SATISFYING FOLLOWING CLAIM FOR ACCURACY -C ABS(I-RESULT).LE.MAX(EPSABS,EPSREL*ABS(I)) -C***DESCRIPTION -C -C INTEGRATION OVER INFINITE INTERVALS -C STANDARD FORTRAN SUBROUTINE -C -C F - SUBROUTINE F(X,IERR,RESULT) DEFINING THE INTEGRAND -C FUNCTION F(X). THE ACTUAL NAME FOR F NEEDS TO BE -C DECLARED E X T E R N A L IN THE DRIVER PROGRAM. -C -C BOUND - DOUBLE PRECISION -C FINITE BOUND OF INTEGRATION RANGE -C (HAS NO MEANING IF INTERVAL IS DOUBLY-INFINITE) -C -C INF - DOUBLE PRECISION -C INDICATING THE KIND OF INTEGRATION RANGE INVOLVED -C INF = 1 CORRESPONDS TO (BOUND,+INFINITY), -C INF = -1 TO (-INFINITY,BOUND), -C INF = 2 TO (-INFINITY,+INFINITY). -C -C EPSABS - DOUBLE PRECISION -C ABSOLUTE ACCURACY REQUESTED -C EPSREL - DOUBLE PRECISION -C RELATIVE ACCURACY REQUESTED -C IF EPSABS.LE.0 -C AND EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28), -C THE ROUTINE WILL END WITH IER = 6. -C -C LIMIT - INTEGER -C GIVES AN UPPER BOUND ON THE NUMBER OF SUBINTERVALS -C IN THE PARTITION OF (A,B), LIMIT.GE.1 -C -C ON RETURN -C RESULT - DOUBLE PRECISION -C APPROXIMATION TO THE INTEGRAL -C -C ABSERR - DOUBLE PRECISION -C ESTIMATE OF THE MODULUS OF THE ABSOLUTE ERROR, -C WHICH SHOULD EQUAL OR EXCEED ABS(I-RESULT) -C -C NEVAL - INTEGER -C NUMBER OF INTEGRAND EVALUATIONS -C -C IER - INTEGER -C IER = 0 NORMAL AND RELIABLE TERMINATION OF THE -C ROUTINE. IT IS ASSUMED THAT THE REQUESTED -C ACCURACY HAS BEEN ACHIEVED. -C IER.GT.0 ABNORMAL TERMINATION OF THE ROUTINE. THE -C ESTIMATES FOR RESULT AND ERROR ARE LESS -C RELIABLE. IT IS ASSUMED THAT THE REQUESTED -C ACCURACY HAS NOT BEEN ACHIEVED. -C IER.LT.0 EXIT REQUESTED FROM USER-SUPPLIED -C FUNCTION. -C -C ERROR MESSAGES -C IER = 1 MAXIMUM NUMBER OF SUBDIVISIONS ALLOWED -C HAS BEEN ACHIEVED. ONE CAN ALLOW MORE -C SUBDIVISIONS BY INCREASING THE VALUE OF -C LIMIT (AND TAKING THE ACCORDING DIMENSION -C ADJUSTMENTS INTO ACCOUNT). HOWEVER,IF -C THIS YIELDS NO IMPROVEMENT IT IS ADVISED -C TO ANALYZE THE INTEGRAND IN ORDER TO -C DETERMINE THE INTEGRATION DIFFICULTIES. -C IF THE POSITION OF A LOCAL DIFFICULTY CAN -C BE DETERMINED (E.G. SINGULARITY, -C DISCONTINUITY WITHIN THE INTERVAL) ONE -C WILL PROBABLY GAIN FROM SPLITTING UP THE -C INTERVAL AT THIS POINT AND CALLING THE -C INTEGRATOR ON THE SUBRANGES. IF POSSIBLE, -C AN APPROPRIATE SPECIAL-PURPOSE INTEGRATOR -C SHOULD BE USED, WHICH IS DESIGNED FOR -C HANDLING THE TYPE OF DIFFICULTY INVOLVED. -C = 2 THE OCCURRENCE OF ROUNDOFF ERROR IS -C DETECTED, WHICH PREVENTS THE REQUESTED -C TOLERANCE FROM BEING ACHIEVED. -C THE ERROR MAY BE UNDER-ESTIMATED. -C = 3 EXTREMELY BAD INTEGRAND BEHAVIOUR OCCURS -C AT SOME POINTS OF THE INTEGRATION -C INTERVAL. -C = 4 THE ALGORITHM DOES NOT CONVERGE. -C ROUNDOFF ERROR IS DETECTED IN THE -C EXTRAPOLATION TABLE. -C IT IS ASSUMED THAT THE REQUESTED TOLERANCE -C CANNOT BE ACHIEVED, AND THAT THE RETURNED -C RESULT IS THE BEST WHICH CAN BE OBTAINED. -C = 5 THE INTEGRAL IS PROBABLY DIVERGENT, OR -C SLOWLY CONVERGENT. IT MUST BE NOTED THAT -C DIVERGENCE CAN OCCUR WITH ANY OTHER VALUE -C OF IER. -C = 6 THE INPUT IS INVALID, BECAUSE -C (EPSABS.LE.0 AND -C EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28), -C RESULT, ABSERR, NEVAL, LAST, RLIST(1), -C ELIST(1) AND IORD(1) ARE SET TO ZERO. -C ALIST(1) AND BLIST(1) ARE SET TO 0 -C AND 1 RESPECTIVELY. -C -C ALIST - DOUBLE PRECISION -C VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST -C LAST ELEMENTS OF WHICH ARE THE LEFT -C END POINTS OF THE SUBINTERVALS IN THE PARTITION -C OF THE TRANSFORMED INTEGRATION RANGE (0,1). -C -C BLIST - DOUBLE PRECISION -C VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST -C LAST ELEMENTS OF WHICH ARE THE RIGHT -C END POINTS OF THE SUBINTERVALS IN THE PARTITION -C OF THE TRANSFORMED INTEGRATION RANGE (0,1). -C -C RLIST - DOUBLE PRECISION -C VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST -C LAST ELEMENTS OF WHICH ARE THE INTEGRAL -C APPROXIMATIONS ON THE SUBINTERVALS -C -C ELIST - DOUBLE PRECISION -C VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST -C LAST ELEMENTS OF WHICH ARE THE MODULI OF THE -C ABSOLUTE ERROR ESTIMATES ON THE SUBINTERVALS -C -C IORD - INTEGER -C VECTOR OF DIMENSION LIMIT, THE FIRST K -C ELEMENTS OF WHICH ARE POINTERS TO THE -C ERROR ESTIMATES OVER THE SUBINTERVALS, -C SUCH THAT ELIST(IORD(1)), ..., ELIST(IORD(K)) -C FORM A DECREASING SEQUENCE, WITH K = LAST -C IF LAST.LE.(LIMIT/2+2), AND K = LIMIT+1-LAST -C OTHERWISE -C -C LAST - INTEGER -C NUMBER OF SUBINTERVALS ACTUALLY PRODUCED -C IN THE SUBDIVISION PROCESS -C -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH,DQELG,DQK15I,DQPSRT -C***END PROLOGUE DQAGIE - DOUBLE PRECISION ABSEPS,ABSERR,ALIST,AREA,AREA1,AREA12,AREA2,A1, - * A2,BLIST,BOUN,BOUND,B1,B2,CORREC,DABS,DEFABS,DEFAB1,DEFAB2, - * DMAX1,DRES,D1MACH,ELIST,EPMACH,EPSABS,EPSREL,ERLARG,ERLAST, - * ERRBND,ERRMAX,ERROR1,ERROR2,ERRO12,ERRSUM,ERTEST,OFLOW,RESABS, - * RESEPS,RESULT,RES3LA,RLIST,RLIST2,SMALL,UFLOW - INTEGER ID,IER,IERRO,INF,IORD,IROFF1,IROFF2,IROFF3,JUPBND,K,KSGN, - * KTMIN,LAST,LIMIT,MAXERR,NEVAL,NRES,NRMAX,NUMRL2 - LOGICAL EXTRAP,NOEXT -C - DIMENSION ALIST(LIMIT),BLIST(LIMIT),ELIST(LIMIT),IORD(LIMIT), - * RES3LA(3),RLIST(LIMIT),RLIST2(52) -C - EXTERNAL F -C -C THE DIMENSION OF RLIST2 IS DETERMINED BY THE VALUE OF -C LIMEXP IN SUBROUTINE DQELG. -C -C -C LIST OF MAJOR VARIABLES -C ----------------------- -C -C ALIST - LIST OF LEFT END POINTS OF ALL SUBINTERVALS -C CONSIDERED UP TO NOW -C BLIST - LIST OF RIGHT END POINTS OF ALL SUBINTERVALS -C CONSIDERED UP TO NOW -C RLIST(I) - APPROXIMATION TO THE INTEGRAL OVER -C (ALIST(I),BLIST(I)) -C RLIST2 - ARRAY OF DIMENSION AT LEAST (LIMEXP+2), -C CONTAINING THE PART OF THE EPSILON TABLE -C WICH IS STILL NEEDED FOR FURTHER COMPUTATIONS -C ELIST(I) - ERROR ESTIMATE APPLYING TO RLIST(I) -C MAXERR - POINTER TO THE INTERVAL WITH LARGEST ERROR -C ESTIMATE -C ERRMAX - ELIST(MAXERR) -C ERLAST - ERROR ON THE INTERVAL CURRENTLY SUBDIVIDED -C (BEFORE THAT SUBDIVISION HAS TAKEN PLACE) -C AREA - SUM OF THE INTEGRALS OVER THE SUBINTERVALS -C ERRSUM - SUM OF THE ERRORS OVER THE SUBINTERVALS -C ERRBND - REQUESTED ACCURACY MAX(EPSABS,EPSREL* -C ABS(RESULT)) -C *****1 - VARIABLE FOR THE LEFT SUBINTERVAL -C *****2 - VARIABLE FOR THE RIGHT SUBINTERVAL -C LAST - INDEX FOR SUBDIVISION -C NRES - NUMBER OF CALLS TO THE EXTRAPOLATION ROUTINE -C NUMRL2 - NUMBER OF ELEMENTS CURRENTLY IN RLIST2. IF AN -C APPROPRIATE APPROXIMATION TO THE COMPOUNDED -C INTEGRAL HAS BEEN OBTAINED, IT IS PUT IN -C RLIST2(NUMRL2) AFTER NUMRL2 HAS BEEN INCREASED -C BY ONE. -C SMALL - LENGTH OF THE SMALLEST INTERVAL CONSIDERED UP -C TO NOW, MULTIPLIED BY 1.5 -C ERLARG - SUM OF THE ERRORS OVER THE INTERVALS LARGER -C THAN THE SMALLEST INTERVAL CONSIDERED UP TO NOW -C EXTRAP - LOGICAL VARIABLE DENOTING THAT THE ROUTINE -C IS ATTEMPTING TO PERFORM EXTRAPOLATION. I.E. -C BEFORE SUBDIVIDING THE SMALLEST INTERVAL WE -C TRY TO DECREASE THE VALUE OF ERLARG. -C NOEXT - LOGICAL VARIABLE DENOTING THAT EXTRAPOLATION -C IS NO LONGER ALLOWED (TRUE-VALUE) -C -C MACHINE DEPENDENT CONSTANTS -C --------------------------- -C -C EPMACH IS THE LARGEST RELATIVE SPACING. -C UFLOW IS THE SMALLEST POSITIVE MAGNITUDE. -C OFLOW IS THE LARGEST POSITIVE MAGNITUDE. -C -C***FIRST EXECUTABLE STATEMENT DQAGIE - EPMACH = D1MACH(4) -C -C TEST ON VALIDITY OF PARAMETERS -C ----------------------------- -C - IER = 0 - NEVAL = 0 - LAST = 0 - RESULT = 0.0D+00 - ABSERR = 0.0D+00 - ALIST(1) = 0.0D+00 - BLIST(1) = 0.1D+01 - RLIST(1) = 0.0D+00 - ELIST(1) = 0.0D+00 - IORD(1) = 0 - IF(EPSABS.LE.0.0D+00.AND.EPSREL.LT.DMAX1(0.5D+02*EPMACH,0.5D-28)) - * IER = 6 - IF(IER.EQ.6) GO TO 999 -C -C -C FIRST APPROXIMATION TO THE INTEGRAL -C ----------------------------------- -C -C DETERMINE THE INTERVAL TO BE MAPPED ONTO (0,1). -C IF INF = 2 THE INTEGRAL IS COMPUTED AS I = I1+I2, WHERE -C I1 = INTEGRAL OF F OVER (-INFINITY,0), -C I2 = INTEGRAL OF F OVER (0,+INFINITY). -C - BOUN = BOUND - IF(INF.EQ.2) BOUN = 0.0D+00 - CALL DQK15I(F,BOUN,INF,0.0D+00,0.1D+01,RESULT,ABSERR, - * DEFABS,RESABS,IER) - IF (IER .LT. 0) RETURN -C -C TEST ON ACCURACY -C - LAST = 1 - RLIST(1) = RESULT - ELIST(1) = ABSERR - IORD(1) = 1 - DRES = DABS(RESULT) - ERRBND = DMAX1(EPSABS,EPSREL*DRES) - IF(ABSERR.LE.1.0D+02*EPMACH*DEFABS.AND.ABSERR.GT.ERRBND) IER = 2 - IF(LIMIT.EQ.1) IER = 1 - IF(IER.NE.0.OR.(ABSERR.LE.ERRBND.AND.ABSERR.NE.RESABS).OR. - * ABSERR.EQ.0.0D+00) GO TO 130 -C -C INITIALIZATION -C -------------- -C - UFLOW = D1MACH(1) - OFLOW = D1MACH(2) - RLIST2(1) = RESULT - ERRMAX = ABSERR - MAXERR = 1 - AREA = RESULT - ERRSUM = ABSERR - ABSERR = OFLOW - NRMAX = 1 - NRES = 0 - KTMIN = 0 - NUMRL2 = 2 - EXTRAP = .FALSE. - NOEXT = .FALSE. - IERRO = 0 - IROFF1 = 0 - IROFF2 = 0 - IROFF3 = 0 - KSGN = -1 - IF(DRES.GE.(0.1D+01-0.5D+02*EPMACH)*DEFABS) KSGN = 1 -C -C MAIN DO-LOOP -C ------------ -C - DO 90 LAST = 2,LIMIT -C -C BISECT THE SUBINTERVAL WITH NRMAX-TH LARGEST ERROR ESTIMATE. -C - A1 = ALIST(MAXERR) - B1 = 0.5D+00*(ALIST(MAXERR)+BLIST(MAXERR)) - A2 = B1 - B2 = BLIST(MAXERR) - ERLAST = ERRMAX - CALL DQK15I(F,BOUN,INF,A1,B1,AREA1,ERROR1,RESABS,DEFAB1,IER) - IF (IER .LT. 0) RETURN - CALL DQK15I(F,BOUN,INF,A2,B2,AREA2,ERROR2,RESABS,DEFAB2,IER) - IF (IER .LT. 0) RETURN -C -C IMPROVE PREVIOUS APPROXIMATIONS TO INTEGRAL -C AND ERROR AND TEST FOR ACCURACY. -C - AREA12 = AREA1+AREA2 - ERRO12 = ERROR1+ERROR2 - ERRSUM = ERRSUM+ERRO12-ERRMAX - AREA = AREA+AREA12-RLIST(MAXERR) - IF(DEFAB1.EQ.ERROR1.OR.DEFAB2.EQ.ERROR2)GO TO 15 - IF(DABS(RLIST(MAXERR)-AREA12).GT.0.1D-04*DABS(AREA12) - * .OR.ERRO12.LT.0.99D+00*ERRMAX) GO TO 10 - IF(EXTRAP) IROFF2 = IROFF2+1 - IF(.NOT.EXTRAP) IROFF1 = IROFF1+1 - 10 IF(LAST.GT.10.AND.ERRO12.GT.ERRMAX) IROFF3 = IROFF3+1 - 15 RLIST(MAXERR) = AREA1 - RLIST(LAST) = AREA2 - ERRBND = DMAX1(EPSABS,EPSREL*DABS(AREA)) -C -C TEST FOR ROUNDOFF ERROR AND EVENTUALLY SET ERROR FLAG. -C - IF(IROFF1+IROFF2.GE.10.OR.IROFF3.GE.20) IER = 2 - IF(IROFF2.GE.5) IERRO = 3 -C -C SET ERROR FLAG IN THE CASE THAT THE NUMBER OF -C SUBINTERVALS EQUALS LIMIT. -C - IF(LAST.EQ.LIMIT) IER = 1 -C -C SET ERROR FLAG IN THE CASE OF BAD INTEGRAND BEHAVIOUR -C AT SOME POINTS OF THE INTEGRATION RANGE. -C - IF(DMAX1(DABS(A1),DABS(B2)).LE.(0.1D+01+0.1D+03*EPMACH)* - * (DABS(A2)+0.1D+04*UFLOW)) IER = 4 -C -C APPEND THE NEWLY-CREATED INTERVALS TO THE LIST. -C - IF(ERROR2.GT.ERROR1) GO TO 20 - ALIST(LAST) = A2 - BLIST(MAXERR) = B1 - BLIST(LAST) = B2 - ELIST(MAXERR) = ERROR1 - ELIST(LAST) = ERROR2 - GO TO 30 - 20 ALIST(MAXERR) = A2 - ALIST(LAST) = A1 - BLIST(LAST) = B1 - RLIST(MAXERR) = AREA2 - RLIST(LAST) = AREA1 - ELIST(MAXERR) = ERROR2 - ELIST(LAST) = ERROR1 -C -C CALL SUBROUTINE DQPSRT TO MAINTAIN THE DESCENDING ORDERING -C IN THE LIST OF ERROR ESTIMATES AND SELECT THE SUBINTERVAL -C WITH NRMAX-TH LARGEST ERROR ESTIMATE (TO BE BISECTED NEXT). -C - 30 CALL DQPSRT(LIMIT,LAST,MAXERR,ERRMAX,ELIST,IORD,NRMAX) - IF(ERRSUM.LE.ERRBND) GO TO 115 - IF(IER.NE.0) GO TO 100 - IF(LAST.EQ.2) GO TO 80 - IF(NOEXT) GO TO 90 - ERLARG = ERLARG-ERLAST - IF(DABS(B1-A1).GT.SMALL) ERLARG = ERLARG+ERRO12 - IF(EXTRAP) GO TO 40 -C -C TEST WHETHER THE INTERVAL TO BE BISECTED NEXT IS THE -C SMALLEST INTERVAL. -C - IF(DABS(BLIST(MAXERR)-ALIST(MAXERR)).GT.SMALL) GO TO 90 - EXTRAP = .TRUE. - NRMAX = 2 - 40 IF(IERRO.EQ.3.OR.ERLARG.LE.ERTEST) GO TO 60 -C -C THE SMALLEST INTERVAL HAS THE LARGEST ERROR. -C BEFORE BISECTING DECREASE THE SUM OF THE ERRORS OVER THE -C LARGER INTERVALS (ERLARG) AND PERFORM EXTRAPOLATION. -C - ID = NRMAX - JUPBND = LAST - IF(LAST.GT.(2+LIMIT/2)) JUPBND = LIMIT+3-LAST - DO 50 K = ID,JUPBND - MAXERR = IORD(NRMAX) - ERRMAX = ELIST(MAXERR) - IF(DABS(BLIST(MAXERR)-ALIST(MAXERR)).GT.SMALL) GO TO 90 - NRMAX = NRMAX+1 - 50 CONTINUE -C -C PERFORM EXTRAPOLATION. -C - 60 NUMRL2 = NUMRL2+1 - RLIST2(NUMRL2) = AREA - CALL DQELG(NUMRL2,RLIST2,RESEPS,ABSEPS,RES3LA,NRES) - KTMIN = KTMIN+1 - IF(KTMIN.GT.5.AND.ABSERR.LT.0.1D-02*ERRSUM) IER = 5 - IF(ABSEPS.GE.ABSERR) GO TO 70 - KTMIN = 0 - ABSERR = ABSEPS - RESULT = RESEPS - CORREC = ERLARG - ERTEST = DMAX1(EPSABS,EPSREL*DABS(RESEPS)) - IF(ABSERR.LE.ERTEST) GO TO 100 -C -C PREPARE BISECTION OF THE SMALLEST INTERVAL. -C - 70 IF(NUMRL2.EQ.1) NOEXT = .TRUE. - IF(IER.EQ.5) GO TO 100 - MAXERR = IORD(1) - ERRMAX = ELIST(MAXERR) - NRMAX = 1 - EXTRAP = .FALSE. - SMALL = SMALL*0.5D+00 - ERLARG = ERRSUM - GO TO 90 - 80 SMALL = 0.375D+00 - ERLARG = ERRSUM - ERTEST = ERRBND - RLIST2(2) = AREA - 90 CONTINUE -C -C SET FINAL RESULT AND ERROR ESTIMATE. -C ------------------------------------ -C - 100 IF(ABSERR.EQ.OFLOW) GO TO 115 - IF((IER+IERRO).EQ.0) GO TO 110 - IF(IERRO.EQ.3) ABSERR = ABSERR+CORREC - IF(IER.EQ.0) IER = 3 - IF(RESULT.NE.0.0D+00.AND.AREA.NE.0.0D+00)GO TO 105 - IF(ABSERR.GT.ERRSUM)GO TO 115 - IF(AREA.EQ.0.0D+00) GO TO 130 - GO TO 110 - 105 IF(ABSERR/DABS(RESULT).GT.ERRSUM/DABS(AREA))GO TO 115 -C -C TEST ON DIVERGENCE -C - 110 IF(KSGN.EQ.(-1).AND.DMAX1(DABS(RESULT),DABS(AREA)).LE. - * DEFABS*0.1D-01) GO TO 130 - IF(0.1D-01.GT.(RESULT/AREA).OR.(RESULT/AREA).GT.0.1D+03. - *OR.ERRSUM.GT.DABS(AREA)) IER = 6 - GO TO 130 -C -C COMPUTE GLOBAL INTEGRAL SUM. -C - 115 RESULT = 0.0D+00 - DO 120 K = 1,LAST - RESULT = RESULT+RLIST(K) - 120 CONTINUE - ABSERR = ERRSUM - 130 NEVAL = 30*LAST-15 - IF(INF.EQ.2) NEVAL = 2*NEVAL - IF(IER.GT.2) IER=IER-1 - 999 RETURN - END
--- a/liboctave/cruft/quadpack/dqagp.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,224 +0,0 @@ - SUBROUTINE DQAGP(F,A,B,NPTS2,POINTS,EPSABS,EPSREL,RESULT,ABSERR, - * NEVAL,IER,LENIW,LENW,LAST,IWORK,WORK) -C***BEGIN PROLOGUE DQAGP -C***DATE WRITTEN 800101 (YYMMDD) -C***REVISION DATE 830518 (YYMMDD) -C***CATEGORY NO. H2A2A1 -C***KEYWORDS AUTOMATIC INTEGRATOR, GENERAL-PURPOSE, -C SINGULARITIES AT USER SPECIFIED POINTS, -C EXTRAPOLATION, GLOBALLY ADAPTIVE -C***AUTHOR PIESSENS,ROBERT,APPL. MATH. & PROGR. DIV - K.U.LEUVEN -C DE DONCKER,ELISE,APPL. MATH. & PROGR. DIV. - K.U.LEUVEN -C***PURPOSE THE ROUTINE CALCULATES AN APPROXIMATION RESULT TO A GIVEN -C DEFINITE INTEGRAL I = INTEGRAL OF F OVER (A,B), -C HOPEFULLY SATISFYING FOLLOWING CLAIM FOR ACCURACY -C BREAK POINTS OF THE INTEGRATION INTERVAL, WHERE LOCAL -C DIFFICULTIES OF THE INTEGRAND MAY OCCUR (E.G. -C SINGULARITIES, DISCONTINUITIES), ARE PROVIDED BY THE USER. -C***DESCRIPTION -C -C COMPUTATION OF A DEFINITE INTEGRAL -C STANDARD FORTRAN SUBROUTINE -C DOUBLE PRECISION VERSION -C -C PARAMETERS -C ON ENTRY -C F - SUBROUTINE F(X,IERR,RESULT) DEFINING THE INTEGRAND -C FUNCTION F(X). THE ACTUAL NAME FOR F NEEDS TO BE -C DECLARED E X T E R N A L IN THE DRIVER PROGRAM. -C -C A - DOUBLE PRECISION -C LOWER LIMIT OF INTEGRATION -C -C B - DOUBLE PRECISION -C UPPER LIMIT OF INTEGRATION -C -C NPTS2 - INTEGER -C NUMBER EQUAL TO TWO MORE THAN THE NUMBER OF -C USER-SUPPLIED BREAK POINTS WITHIN THE INTEGRATION -C RANGE, NPTS.GE.2. -C IF NPTS2.LT.2, THE ROUTINE WILL END WITH IER = 6. -C -C POINTS - DOUBLE PRECISION -C VECTOR OF DIMENSION NPTS2, THE FIRST (NPTS2-2) -C ELEMENTS OF WHICH ARE THE USER PROVIDED BREAK -C POINTS. IF THESE POINTS DO NOT CONSTITUTE AN -C ASCENDING SEQUENCE THERE WILL BE AN AUTOMATIC -C SORTING. -C -C EPSABS - DOUBLE PRECISION -C ABSOLUTE ACCURACY REQUESTED -C EPSREL - DOUBLE PRECISION -C RELATIVE ACCURACY REQUESTED -C IF EPSABS.LE.0 -C AND EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28), -C THE ROUTINE WILL END WITH IER = 6. -C -C ON RETURN -C RESULT - DOUBLE PRECISION -C APPROXIMATION TO THE INTEGRAL -C -C ABSERR - DOUBLE PRECISION -C ESTIMATE OF THE MODULUS OF THE ABSOLUTE ERROR, -C WHICH SHOULD EQUAL OR EXCEED ABS(I-RESULT) -C -C NEVAL - INTEGER -C NUMBER OF INTEGRAND EVALUATIONS -C -C IER - INTEGER -C IER = 0 NORMAL AND RELIABLE TERMINATION OF THE -C ROUTINE. IT IS ASSUMED THAT THE REQUESTED -C ACCURACY HAS BEEN ACHIEVED. -C IER.GT.0 ABNORMAL TERMINATION OF THE ROUTINE. -C THE ESTIMATES FOR INTEGRAL AND ERROR ARE -C LESS RELIABLE. IT IS ASSUMED THAT THE -C REQUESTED ACCURACY HAS NOT BEEN ACHIEVED. -C ERROR MESSAGES -C IER = 1 MAXIMUM NUMBER OF SUBDIVISIONS ALLOWED -C HAS BEEN ACHIEVED. ONE CAN ALLOW MORE -C SUBDIVISIONS BY INCREASING THE VALUE OF -C LIMIT (AND TAKING THE ACCORDING DIMENSION -C ADJUSTMENTS INTO ACCOUNT). HOWEVER, IF -C THIS YIELDS NO IMPROVEMENT IT IS ADVISED -C TO ANALYZE THE INTEGRAND IN ORDER TO -C DETERMINE THE INTEGRATION DIFFICULTIES. IF -C THE POSITION OF A LOCAL DIFFICULTY CAN BE -C DETERMINED (I.E. SINGULARITY, -C DISCONTINUITY WITHIN THE INTERVAL), IT -C SHOULD BE SUPPLIED TO THE ROUTINE AS AN -C ELEMENT OF THE VECTOR POINTS. IF NECESSARY -C AN APPROPRIATE SPECIAL-PURPOSE INTEGRATOR -C MUST BE USED, WHICH IS DESIGNED FOR -C HANDLING THE TYPE OF DIFFICULTY INVOLVED. -C = 2 THE OCCURRENCE OF ROUNDOFF ERROR IS -C DETECTED, WHICH PREVENTS THE REQUESTED -C TOLERANCE FROM BEING ACHIEVED. -C THE ERROR MAY BE UNDER-ESTIMATED. -C = 3 EXTREMELY BAD INTEGRAND BEHAVIOUR OCCURS -C AT SOME POINTS OF THE INTEGRATION -C INTERVAL. -C = 4 THE ALGORITHM DOES NOT CONVERGE. -C ROUNDOFF ERROR IS DETECTED IN THE -C EXTRAPOLATION TABLE. -C IT IS PRESUMED THAT THE REQUESTED -C TOLERANCE CANNOT BE ACHIEVED, AND THAT -C THE RETURNED RESULT IS THE BEST WHICH -C CAN BE OBTAINED. -C = 5 THE INTEGRAL IS PROBABLY DIVERGENT, OR -C SLOWLY CONVERGENT. IT MUST BE NOTED THAT -C DIVERGENCE CAN OCCUR WITH ANY OTHER VALUE -C OF IER.GT.0. -C = 6 THE INPUT IS INVALID BECAUSE -C NPTS2.LT.2 OR -C BREAK POINTS ARE SPECIFIED OUTSIDE -C THE INTEGRATION RANGE OR -C (EPSABS.LE.0 AND -C EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28)) -C RESULT, ABSERR, NEVAL, LAST ARE SET TO -C ZERO. EXEPT WHEN LENIW OR LENW OR NPTS2 IS -C INVALID, IWORK(1), IWORK(LIMIT+1), -C WORK(LIMIT*2+1) AND WORK(LIMIT*3+1) -C ARE SET TO ZERO. -C WORK(1) IS SET TO A AND WORK(LIMIT+1) -C TO B (WHERE LIMIT = (LENIW-NPTS2)/2). -C -C DIMENSIONING PARAMETERS -C LENIW - INTEGER -C DIMENSIONING PARAMETER FOR IWORK -C LENIW DETERMINES LIMIT = (LENIW-NPTS2)/2, -C WHICH IS THE MAXIMUM NUMBER OF SUBINTERVALS IN THE -C PARTITION OF THE GIVEN INTEGRATION INTERVAL (A,B), -C LENIW.GE.(3*NPTS2-2). -C IF LENIW.LT.(3*NPTS2-2), THE ROUTINE WILL END WITH -C IER = 6. -C -C LENW - INTEGER -C DIMENSIONING PARAMETER FOR WORK -C LENW MUST BE AT LEAST LENIW*2-NPTS2. -C IF LENW.LT.LENIW*2-NPTS2, THE ROUTINE WILL END -C WITH IER = 6. -C -C LAST - INTEGER -C ON RETURN, LAST EQUALS THE NUMBER OF SUBINTERVALS -C PRODUCED IN THE SUBDIVISION PROCESS, WHICH -C DETERMINES THE NUMBER OF SIGNIFICANT ELEMENTS -C ACTUALLY IN THE WORK ARRAYS. -C -C WORK ARRAYS -C IWORK - INTEGER -C VECTOR OF DIMENSION AT LEAST LENIW. ON RETURN, -C THE FIRST K ELEMENTS OF WHICH CONTAIN -C POINTERS TO THE ERROR ESTIMATES OVER THE -C SUBINTERVALS, SUCH THAT WORK(LIMIT*3+IWORK(1)),..., -C WORK(LIMIT*3+IWORK(K)) FORM A DECREASING -C SEQUENCE, WITH K = LAST IF LAST.LE.(LIMIT/2+2), AND -C K = LIMIT+1-LAST OTHERWISE -C IWORK(LIMIT+1), ...,IWORK(LIMIT+LAST) CONTAIN THE -C SUBDIVISION LEVELS OF THE SUBINTERVALS, I.E. -C IF (AA,BB) IS A SUBINTERVAL OF (P1,P2) -C WHERE P1 AS WELL AS P2 IS A USER-PROVIDED -C BREAK POINT OR INTEGRATION LIMIT, THEN (AA,BB) HAS -C LEVEL L IF ABS(BB-AA) = ABS(P2-P1)*2**(-L), -C IWORK(LIMIT*2+1), ..., IWORK(LIMIT*2+NPTS2) HAVE -C NO SIGNIFICANCE FOR THE USER, -C NOTE THAT LIMIT = (LENIW-NPTS2)/2. -C -C WORK - DOUBLE PRECISION -C VECTOR OF DIMENSION AT LEAST LENW -C ON RETURN -C WORK(1), ..., WORK(LAST) CONTAIN THE LEFT -C END POINTS OF THE SUBINTERVALS IN THE -C PARTITION OF (A,B), -C WORK(LIMIT+1), ..., WORK(LIMIT+LAST) CONTAIN -C THE RIGHT END POINTS, -C WORK(LIMIT*2+1), ..., WORK(LIMIT*2+LAST) CONTAIN -C THE INTEGRAL APPROXIMATIONS OVER THE SUBINTERVALS, -C WORK(LIMIT*3+1), ..., WORK(LIMIT*3+LAST) -C CONTAIN THE CORRESPONDING ERROR ESTIMATES, -C WORK(LIMIT*4+1), ..., WORK(LIMIT*4+NPTS2) -C CONTAIN THE INTEGRATION LIMITS AND THE -C BREAK POINTS SORTED IN AN ASCENDING SEQUENCE. -C NOTE THAT LIMIT = (LENIW-NPTS2)/2. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED DQAGPE,XERROR -C***END PROLOGUE DQAGP -C - DOUBLE PRECISION A,ABSERR,B,EPSABS,EPSREL,POINTS,RESULT,WORK - INTEGER IER,IWORK,LAST,LENIW,LENW,LIMIT,LVL,L1,L2,L3,L4,NEVAL, - * NPTS2 -C - DIMENSION IWORK(LENIW),POINTS(NPTS2),WORK(LENW) -C - EXTERNAL F -C -C CHECK VALIDITY OF LIMIT AND LENW. -C -C***FIRST EXECUTABLE STATEMENT DQAGP - IER = 6 - NEVAL = 0 - LAST = 0 - RESULT = 0.0D+00 - ABSERR = 0.0D+00 - IF(LENIW.LT.(3*NPTS2-2).OR.LENW.LT.(LENIW*2-NPTS2).OR.NPTS2.LT.2) - * GO TO 10 -C -C PREPARE CALL FOR DQAGPE. -C - LIMIT = (LENIW-NPTS2)/2 - L1 = LIMIT+1 - L2 = LIMIT+L1 - L3 = LIMIT+L2 - L4 = LIMIT+L3 -C - CALL DQAGPE(F,A,B,NPTS2,POINTS,EPSABS,EPSREL,LIMIT,RESULT,ABSERR, - * NEVAL,IER,WORK(1),WORK(L1),WORK(L2),WORK(L3),WORK(L4), - * IWORK(1),IWORK(L1),IWORK(L2),LAST) -C -C CALL ERROR HANDLER IF NECESSARY. -C - LVL = 0 -10 IF(IER.EQ.6) LVL = 1 - IF(IER.GT.0) CALL XERROR('ABNORMAL RETURN FROM DQAGP',26,IER,LVL) - RETURN - END
--- a/liboctave/cruft/quadpack/dqagpe.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,555 +0,0 @@ - SUBROUTINE DQAGPE(F,A,B,NPTS2,POINTS,EPSABS,EPSREL,LIMIT,RESULT, - * ABSERR,NEVAL,IER,ALIST,BLIST,RLIST,ELIST,PTS,IORD,LEVEL,NDIN, - * LAST) -C***BEGIN PROLOGUE DQAGPE -C***DATE WRITTEN 800101 (YYMMDD) -C***REVISION DATE 830518 (YYMMDD) -C***CATEGORY NO. H2A2A1 -C***KEYWORDS AUTOMATIC INTEGRATOR, GENERAL-PURPOSE, -C SINGULARITIES AT USER SPECIFIED POINTS, -C EXTRAPOLATION, GLOBALLY ADAPTIVE. -C***AUTHOR PIESSENS,ROBERT ,APPL. MATH. & PROGR. DIV. - K.U.LEUVEN -C DE DONCKER,ELISE,APPL. MATH. & PROGR. DIV. - K.U.LEUVEN -C***PURPOSE THE ROUTINE CALCULATES AN APPROXIMATION RESULT TO A GIVEN -C DEFINITE INTEGRAL I = INTEGRAL OF F OVER (A,B), HOPEFULLY -C SATISFYING FOLLOWING CLAIM FOR ACCURACY ABS(I-RESULT).LE. -C MAX(EPSABS,EPSREL*ABS(I)). BREAK POINTS OF THE INTEGRATION -C INTERVAL, WHERE LOCAL DIFFICULTIES OF THE INTEGRAND MAY -C OCCUR(E.G. SINGULARITIES,DISCONTINUITIES),PROVIDED BY USER. -C***DESCRIPTION -C -C COMPUTATION OF A DEFINITE INTEGRAL -C STANDARD FORTRAN SUBROUTINE -C DOUBLE PRECISION VERSION -C -C PARAMETERS -C ON ENTRY -C F - SUBROUTINE F(X,IERR,RESULT) DEFINING THE INTEGRAND -C FUNCTION F(X). THE ACTUAL NAME FOR F NEEDS TO BE -C DECLARED E X T E R N A L IN THE DRIVER PROGRAM. -C -C A - DOUBLE PRECISION -C LOWER LIMIT OF INTEGRATION -C -C B - DOUBLE PRECISION -C UPPER LIMIT OF INTEGRATION -C -C NPTS2 - INTEGER -C NUMBER EQUAL TO TWO MORE THAN THE NUMBER OF -C USER-SUPPLIED BREAK POINTS WITHIN THE INTEGRATION -C RANGE, NPTS2.GE.2. -C IF NPTS2.LT.2, THE ROUTINE WILL END WITH IER = 6. -C -C POINTS - DOUBLE PRECISION -C VECTOR OF DIMENSION NPTS2, THE FIRST (NPTS2-2) -C ELEMENTS OF WHICH ARE THE USER PROVIDED BREAK -C POINTS. IF THESE POINTS DO NOT CONSTITUTE AN -C ASCENDING SEQUENCE THERE WILL BE AN AUTOMATIC -C SORTING. -C -C EPSABS - DOUBLE PRECISION -C ABSOLUTE ACCURACY REQUESTED -C EPSREL - DOUBLE PRECISION -C RELATIVE ACCURACY REQUESTED -C IF EPSABS.LE.0 -C AND EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28), -C THE ROUTINE WILL END WITH IER = 6. -C -C LIMIT - INTEGER -C GIVES AN UPPER BOUND ON THE NUMBER OF SUBINTERVALS -C IN THE PARTITION OF (A,B), LIMIT.GE.NPTS2 -C IF LIMIT.LT.NPTS2, THE ROUTINE WILL END WITH -C IER = 6. -C -C ON RETURN -C RESULT - DOUBLE PRECISION -C APPROXIMATION TO THE INTEGRAL -C -C ABSERR - DOUBLE PRECISION -C ESTIMATE OF THE MODULUS OF THE ABSOLUTE ERROR, -C WHICH SHOULD EQUAL OR EXCEED ABS(I-RESULT) -C -C NEVAL - INTEGER -C NUMBER OF INTEGRAND EVALUATIONS -C -C IER - INTEGER -C IER = 0 NORMAL AND RELIABLE TERMINATION OF THE -C ROUTINE. IT IS ASSUMED THAT THE REQUESTED -C ACCURACY HAS BEEN ACHIEVED. -C IER.GT.0 ABNORMAL TERMINATION OF THE ROUTINE. -C THE ESTIMATES FOR INTEGRAL AND ERROR ARE -C LESS RELIABLE. IT IS ASSUMED THAT THE -C REQUESTED ACCURACY HAS NOT BEEN ACHIEVED. -C IER.LT.0 EXIT REQUESTED FROM USER-SUPPLIED -C FUNCTION. -C -C ERROR MESSAGES -C IER = 1 MAXIMUM NUMBER OF SUBDIVISIONS ALLOWED -C HAS BEEN ACHIEVED. ONE CAN ALLOW MORE -C SUBDIVISIONS BY INCREASING THE VALUE OF -C LIMIT (AND TAKING THE ACCORDING DIMENSION -C ADJUSTMENTS INTO ACCOUNT). HOWEVER, IF -C THIS YIELDS NO IMPROVEMENT IT IS ADVISED -C TO ANALYZE THE INTEGRAND IN ORDER TO -C DETERMINE THE INTEGRATION DIFFICULTIES. IF -C THE POSITION OF A LOCAL DIFFICULTY CAN BE -C DETERMINED (I.E. SINGULARITY, -C DISCONTINUITY WITHIN THE INTERVAL), IT -C SHOULD BE SUPPLIED TO THE ROUTINE AS AN -C ELEMENT OF THE VECTOR POINTS. IF NECESSARY -C AN APPROPRIATE SPECIAL-PURPOSE INTEGRATOR -C MUST BE USED, WHICH IS DESIGNED FOR -C HANDLING THE TYPE OF DIFFICULTY INVOLVED. -C = 2 THE OCCURRENCE OF ROUNDOFF ERROR IS -C DETECTED, WHICH PREVENTS THE REQUESTED -C TOLERANCE FROM BEING ACHIEVED. -C THE ERROR MAY BE UNDER-ESTIMATED. -C = 3 EXTREMELY BAD INTEGRAND BEHAVIOUR OCCURS -C AT SOME POINTS OF THE INTEGRATION -C INTERVAL. -C = 4 THE ALGORITHM DOES NOT CONVERGE. -C ROUNDOFF ERROR IS DETECTED IN THE -C EXTRAPOLATION TABLE. IT IS PRESUMED THAT -C THE REQUESTED TOLERANCE CANNOT BE -C ACHIEVED, AND THAT THE RETURNED RESULT IS -C THE BEST WHICH CAN BE OBTAINED. -C = 5 THE INTEGRAL IS PROBABLY DIVERGENT, OR -C SLOWLY CONVERGENT. IT MUST BE NOTED THAT -C DIVERGENCE CAN OCCUR WITH ANY OTHER VALUE -C OF IER.GT.0. -C = 6 THE INPUT IS INVALID BECAUSE -C NPTS2.LT.2 OR -C BREAK POINTS ARE SPECIFIED OUTSIDE -C THE INTEGRATION RANGE OR -C (EPSABS.LE.0 AND -C EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28)) -C OR LIMIT.LT.NPTS2. -C RESULT, ABSERR, NEVAL, LAST, RLIST(1), -C AND ELIST(1) ARE SET TO ZERO. ALIST(1) AND -C BLIST(1) ARE SET TO A AND B RESPECTIVELY. -C -C ALIST - DOUBLE PRECISION -C VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST -C LAST ELEMENTS OF WHICH ARE THE LEFT END POINTS -C OF THE SUBINTERVALS IN THE PARTITION OF THE GIVEN -C INTEGRATION RANGE (A,B) -C -C BLIST - DOUBLE PRECISION -C VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST -C LAST ELEMENTS OF WHICH ARE THE RIGHT END POINTS -C OF THE SUBINTERVALS IN THE PARTITION OF THE GIVEN -C INTEGRATION RANGE (A,B) -C -C RLIST - DOUBLE PRECISION -C VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST -C LAST ELEMENTS OF WHICH ARE THE INTEGRAL -C APPROXIMATIONS ON THE SUBINTERVALS -C -C ELIST - DOUBLE PRECISION -C VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST -C LAST ELEMENTS OF WHICH ARE THE MODULI OF THE -C ABSOLUTE ERROR ESTIMATES ON THE SUBINTERVALS -C -C PTS - DOUBLE PRECISION -C VECTOR OF DIMENSION AT LEAST NPTS2, CONTAINING THE -C INTEGRATION LIMITS AND THE BREAK POINTS OF THE -C INTERVAL IN ASCENDING SEQUENCE. -C -C LEVEL - INTEGER -C VECTOR OF DIMENSION AT LEAST LIMIT, CONTAINING THE -C SUBDIVISION LEVELS OF THE SUBINTERVAL, I.E. IF -C (AA,BB) IS A SUBINTERVAL OF (P1,P2) WHERE P1 AS -C WELL AS P2 IS A USER-PROVIDED BREAK POINT OR -C INTEGRATION LIMIT, THEN (AA,BB) HAS LEVEL L IF -C ABS(BB-AA) = ABS(P2-P1)*2**(-L). -C -C NDIN - INTEGER -C VECTOR OF DIMENSION AT LEAST NPTS2, AFTER FIRST -C INTEGRATION OVER THE INTERVALS (PTS(I)),PTS(I+1), -C I = 0,1, ..., NPTS2-2, THE ERROR ESTIMATES OVER -C SOME OF THE INTERVALS MAY HAVE BEEN INCREASED -C ARTIFICIALLY, IN ORDER TO PUT THEIR SUBDIVISION -C FORWARD. IF THIS HAPPENS FOR THE SUBINTERVAL -C NUMBERED K, NDIN(K) IS PUT TO 1, OTHERWISE -C NDIN(K) = 0. -C -C IORD - INTEGER -C VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST K -C ELEMENTS OF WHICH ARE POINTERS TO THE -C ERROR ESTIMATES OVER THE SUBINTERVALS, -C SUCH THAT ELIST(IORD(1)), ..., ELIST(IORD(K)) -C FORM A DECREASING SEQUENCE, WITH K = LAST -C IF LAST.LE.(LIMIT/2+2), AND K = LIMIT+1-LAST -C OTHERWISE -C -C LAST - INTEGER -C NUMBER OF SUBINTERVALS ACTUALLY PRODUCED IN THE -C SUBDIVISIONS PROCESS -C -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH,DQELG,DQK21,DQPSRT -C***END PROLOGUE DQAGPE - DOUBLE PRECISION A,ABSEPS,ABSERR,ALIST,AREA,AREA1,AREA12,AREA2,A1, - * A2,B,BLIST,B1,B2,CORREC,DABS,DEFABS,DEFAB1,DEFAB2,DMAX1,DMIN1, - * DRES,D1MACH,ELIST,EPMACH,EPSABS,EPSREL,ERLARG,ERLAST,ERRBND, - * ERRMAX,ERROR1,ERRO12,ERROR2,ERRSUM,ERTEST,OFLOW,POINTS,PTS, - * RESA,RESABS,RESEPS,RESULT,RES3LA,RLIST,RLIST2,SIGN,TEMP,UFLOW - INTEGER I,ID,IER,IERRO,IND1,IND2,IORD,IP1,IROFF1,IROFF2,IROFF3,J, - * JLOW,JUPBND,K,KSGN,KTMIN,LAST,LEVCUR,LEVEL,LEVMAX,LIMIT,MAXERR, - * NDIN,NEVAL,NINT,NINTP1,NPTS,NPTS2,NRES,NRMAX,NUMRL2 - LOGICAL EXTRAP,NOEXT -C -C - DIMENSION ALIST(LIMIT),BLIST(LIMIT),ELIST(LIMIT),IORD(LIMIT), - * LEVEL(LIMIT),NDIN(NPTS2),POINTS(NPTS2),PTS(NPTS2),RES3LA(3), - * RLIST(LIMIT),RLIST2(52) -C - EXTERNAL F -C -C THE DIMENSION OF RLIST2 IS DETERMINED BY THE VALUE OF -C LIMEXP IN SUBROUTINE EPSALG (RLIST2 SHOULD BE OF DIMENSION -C (LIMEXP+2) AT LEAST). -C -C -C LIST OF MAJOR VARIABLES -C ----------------------- -C -C ALIST - LIST OF LEFT END POINTS OF ALL SUBINTERVALS -C CONSIDERED UP TO NOW -C BLIST - LIST OF RIGHT END POINTS OF ALL SUBINTERVALS -C CONSIDERED UP TO NOW -C RLIST(I) - APPROXIMATION TO THE INTEGRAL OVER -C (ALIST(I),BLIST(I)) -C RLIST2 - ARRAY OF DIMENSION AT LEAST LIMEXP+2 -C CONTAINING THE PART OF THE EPSILON TABLE WHICH -C IS STILL NEEDED FOR FURTHER COMPUTATIONS -C ELIST(I) - ERROR ESTIMATE APPLYING TO RLIST(I) -C MAXERR - POINTER TO THE INTERVAL WITH LARGEST ERROR -C ESTIMATE -C ERRMAX - ELIST(MAXERR) -C ERLAST - ERROR ON THE INTERVAL CURRENTLY SUBDIVIDED -C (BEFORE THAT SUBDIVISION HAS TAKEN PLACE) -C AREA - SUM OF THE INTEGRALS OVER THE SUBINTERVALS -C ERRSUM - SUM OF THE ERRORS OVER THE SUBINTERVALS -C ERRBND - REQUESTED ACCURACY MAX(EPSABS,EPSREL* -C ABS(RESULT)) -C *****1 - VARIABLE FOR THE LEFT SUBINTERVAL -C *****2 - VARIABLE FOR THE RIGHT SUBINTERVAL -C LAST - INDEX FOR SUBDIVISION -C NRES - NUMBER OF CALLS TO THE EXTRAPOLATION ROUTINE -C NUMRL2 - NUMBER OF ELEMENTS IN RLIST2. IF AN APPROPRIATE -C APPROXIMATION TO THE COMPOUNDED INTEGRAL HAS -C BEEN OBTAINED, IT IS PUT IN RLIST2(NUMRL2) AFTER -C NUMRL2 HAS BEEN INCREASED BY ONE. -C ERLARG - SUM OF THE ERRORS OVER THE INTERVALS LARGER -C THAN THE SMALLEST INTERVAL CONSIDERED UP TO NOW -C EXTRAP - LOGICAL VARIABLE DENOTING THAT THE ROUTINE -C IS ATTEMPTING TO PERFORM EXTRAPOLATION. I.E. -C BEFORE SUBDIVIDING THE SMALLEST INTERVAL WE -C TRY TO DECREASE THE VALUE OF ERLARG. -C NOEXT - LOGICAL VARIABLE DENOTING THAT EXTRAPOLATION IS -C NO LONGER ALLOWED (TRUE-VALUE) -C -C MACHINE DEPENDENT CONSTANTS -C --------------------------- -C -C EPMACH IS THE LARGEST RELATIVE SPACING. -C UFLOW IS THE SMALLEST POSITIVE MAGNITUDE. -C OFLOW IS THE LARGEST POSITIVE MAGNITUDE. -C -C***FIRST EXECUTABLE STATEMENT DQAGPE - EPMACH = D1MACH(4) -C -C TEST ON VALIDITY OF PARAMETERS -C ----------------------------- -C - IER = 0 - NEVAL = 0 - LAST = 0 - RESULT = 0.0D+00 - ABSERR = 0.0D+00 - ALIST(1) = A - BLIST(1) = B - RLIST(1) = 0.0D+00 - ELIST(1) = 0.0D+00 - IORD(1) = 0 - LEVEL(1) = 0 - NPTS = NPTS2-2 - IF(NPTS2.LT.2.OR.LIMIT.LE.NPTS.OR.(EPSABS.LE.0.0D+00.AND. - * EPSREL.LT.DMAX1(0.5D+02*EPMACH,0.5D-28))) IER = 6 - IF(IER.EQ.6) GO TO 999 -C -C IF ANY BREAK POINTS ARE PROVIDED, SORT THEM INTO AN -C ASCENDING SEQUENCE. -C - SIGN = 1.0D+00 - IF(A.GT.B) SIGN = -1.0D+00 - PTS(1) = DMIN1(A,B) - IF(NPTS.EQ.0) GO TO 15 - DO 10 I = 1,NPTS - PTS(I+1) = POINTS(I) - 10 CONTINUE - 15 PTS(NPTS+2) = DMAX1(A,B) - NINT = NPTS+1 - A1 = PTS(1) - IF(NPTS.EQ.0) GO TO 40 - NINTP1 = NINT+1 - DO 20 I = 1,NINT - IP1 = I+1 - DO 20 J = IP1,NINTP1 - IF(PTS(I).LE.PTS(J)) GO TO 20 - TEMP = PTS(I) - PTS(I) = PTS(J) - PTS(J) = TEMP - 20 CONTINUE - IF(PTS(1).NE.DMIN1(A,B).OR.PTS(NINTP1).NE.DMAX1(A,B)) IER = 6 - IF(IER.EQ.6) GO TO 999 -C -C COMPUTE FIRST INTEGRAL AND ERROR APPROXIMATIONS. -C ------------------------------------------------ -C - 40 RESABS = 0.0D+00 - DO 50 I = 1,NINT - B1 = PTS(I+1) - CALL DQK21(F,A1,B1,AREA1,ERROR1,DEFABS,RESA,IER) - IF (IER .LT. 0) RETURN - ABSERR = ABSERR+ERROR1 - RESULT = RESULT+AREA1 - NDIN(I) = 0 - IF(ERROR1.EQ.RESA.AND.ERROR1.NE.0.0D+00) NDIN(I) = 1 - RESABS = RESABS+DEFABS - LEVEL(I) = 0 - ELIST(I) = ERROR1 - ALIST(I) = A1 - BLIST(I) = B1 - RLIST(I) = AREA1 - IORD(I) = I - A1 = B1 - 50 CONTINUE - ERRSUM = 0.0D+00 - DO 55 I = 1,NINT - IF(NDIN(I).EQ.1) ELIST(I) = ABSERR - ERRSUM = ERRSUM+ELIST(I) - 55 CONTINUE -C -C TEST ON ACCURACY. -C - LAST = NINT - NEVAL = 21*NINT - DRES = DABS(RESULT) - ERRBND = DMAX1(EPSABS,EPSREL*DRES) - IF(ABSERR.LE.0.1D+03*EPMACH*RESABS.AND.ABSERR.GT.ERRBND) IER = 2 - IF(NINT.EQ.1) GO TO 80 - DO 70 I = 1,NPTS - JLOW = I+1 - IND1 = IORD(I) - DO 60 J = JLOW,NINT - IND2 = IORD(J) - IF(ELIST(IND1).GT.ELIST(IND2)) GO TO 60 - IND1 = IND2 - K = J - 60 CONTINUE - IF(IND1.EQ.IORD(I)) GO TO 70 - IORD(K) = IORD(I) - IORD(I) = IND1 - 70 CONTINUE - IF(LIMIT.LT.NPTS2) IER = 1 - 80 IF(IER.NE.0.OR.ABSERR.LE.ERRBND) GO TO 210 -C -C INITIALIZATION -C -------------- -C - RLIST2(1) = RESULT - MAXERR = IORD(1) - ERRMAX = ELIST(MAXERR) - AREA = RESULT - NRMAX = 1 - NRES = 0 - NUMRL2 = 1 - KTMIN = 0 - EXTRAP = .FALSE. - NOEXT = .FALSE. - ERLARG = ERRSUM - ERTEST = ERRBND - LEVMAX = 1 - IROFF1 = 0 - IROFF2 = 0 - IROFF3 = 0 - IERRO = 0 - UFLOW = D1MACH(1) - OFLOW = D1MACH(2) - ABSERR = OFLOW - KSGN = -1 - IF(DRES.GE.(0.1D+01-0.5D+02*EPMACH)*RESABS) KSGN = 1 -C -C MAIN DO-LOOP -C ------------ -C - DO 160 LAST = NPTS2,LIMIT -C -C BISECT THE SUBINTERVAL WITH THE NRMAX-TH LARGEST ERROR -C ESTIMATE. -C - LEVCUR = LEVEL(MAXERR)+1 - A1 = ALIST(MAXERR) - B1 = 0.5D+00*(ALIST(MAXERR)+BLIST(MAXERR)) - A2 = B1 - B2 = BLIST(MAXERR) - ERLAST = ERRMAX - CALL DQK21(F,A1,B1,AREA1,ERROR1,RESA,DEFAB1,IER) - IF (IER .LT. 0) RETURN - CALL DQK21(F,A2,B2,AREA2,ERROR2,RESA,DEFAB2,IER) - IF (IER .LT. 0) RETURN -C -C IMPROVE PREVIOUS APPROXIMATIONS TO INTEGRAL -C AND ERROR AND TEST FOR ACCURACY. -C - NEVAL = NEVAL+42 - AREA12 = AREA1+AREA2 - ERRO12 = ERROR1+ERROR2 - ERRSUM = ERRSUM+ERRO12-ERRMAX - AREA = AREA+AREA12-RLIST(MAXERR) - IF(DEFAB1.EQ.ERROR1.OR.DEFAB2.EQ.ERROR2) GO TO 95 - IF(DABS(RLIST(MAXERR)-AREA12).GT.0.1D-04*DABS(AREA12) - * .OR.ERRO12.LT.0.99D+00*ERRMAX) GO TO 90 - IF(EXTRAP) IROFF2 = IROFF2+1 - IF(.NOT.EXTRAP) IROFF1 = IROFF1+1 - 90 IF(LAST.GT.10.AND.ERRO12.GT.ERRMAX) IROFF3 = IROFF3+1 - 95 LEVEL(MAXERR) = LEVCUR - LEVEL(LAST) = LEVCUR - RLIST(MAXERR) = AREA1 - RLIST(LAST) = AREA2 - ERRBND = DMAX1(EPSABS,EPSREL*DABS(AREA)) -C -C TEST FOR ROUNDOFF ERROR AND EVENTUALLY SET ERROR FLAG. -C - IF(IROFF1+IROFF2.GE.10.OR.IROFF3.GE.20) IER = 2 - IF(IROFF2.GE.5) IERRO = 3 -C -C SET ERROR FLAG IN THE CASE THAT THE NUMBER OF -C SUBINTERVALS EQUALS LIMIT. -C - IF(LAST.EQ.LIMIT) IER = 1 -C -C SET ERROR FLAG IN THE CASE OF BAD INTEGRAND BEHAVIOUR -C AT A POINT OF THE INTEGRATION RANGE -C - IF(DMAX1(DABS(A1),DABS(B2)).LE.(0.1D+01+0.1D+03*EPMACH)* - * (DABS(A2)+0.1D+04*UFLOW)) IER = 4 -C -C APPEND THE NEWLY-CREATED INTERVALS TO THE LIST. -C - IF(ERROR2.GT.ERROR1) GO TO 100 - ALIST(LAST) = A2 - BLIST(MAXERR) = B1 - BLIST(LAST) = B2 - ELIST(MAXERR) = ERROR1 - ELIST(LAST) = ERROR2 - GO TO 110 - 100 ALIST(MAXERR) = A2 - ALIST(LAST) = A1 - BLIST(LAST) = B1 - RLIST(MAXERR) = AREA2 - RLIST(LAST) = AREA1 - ELIST(MAXERR) = ERROR2 - ELIST(LAST) = ERROR1 -C -C CALL SUBROUTINE DQPSRT TO MAINTAIN THE DESCENDING ORDERING -C IN THE LIST OF ERROR ESTIMATES AND SELECT THE SUBINTERVAL -C WITH NRMAX-TH LARGEST ERROR ESTIMATE (TO BE BISECTED NEXT). -C - 110 CALL DQPSRT(LIMIT,LAST,MAXERR,ERRMAX,ELIST,IORD,NRMAX) -C ***JUMP OUT OF DO-LOOP - IF(ERRSUM.LE.ERRBND) GO TO 190 -C ***JUMP OUT OF DO-LOOP - IF(IER.NE.0) GO TO 170 - IF(NOEXT) GO TO 160 - ERLARG = ERLARG-ERLAST - IF(LEVCUR+1.LE.LEVMAX) ERLARG = ERLARG+ERRO12 - IF(EXTRAP) GO TO 120 -C -C TEST WHETHER THE INTERVAL TO BE BISECTED NEXT IS THE -C SMALLEST INTERVAL. -C - IF(LEVEL(MAXERR)+1.LE.LEVMAX) GO TO 160 - EXTRAP = .TRUE. - NRMAX = 2 - 120 IF(IERRO.EQ.3.OR.ERLARG.LE.ERTEST) GO TO 140 -C -C THE SMALLEST INTERVAL HAS THE LARGEST ERROR. -C BEFORE BISECTING DECREASE THE SUM OF THE ERRORS OVER -C THE LARGER INTERVALS (ERLARG) AND PERFORM EXTRAPOLATION. -C - ID = NRMAX - JUPBND = LAST - IF(LAST.GT.(2+LIMIT/2)) JUPBND = LIMIT+3-LAST - DO 130 K = ID,JUPBND - MAXERR = IORD(NRMAX) - ERRMAX = ELIST(MAXERR) -C ***JUMP OUT OF DO-LOOP - IF(LEVEL(MAXERR)+1.LE.LEVMAX) GO TO 160 - NRMAX = NRMAX+1 - 130 CONTINUE -C -C PERFORM EXTRAPOLATION. -C - 140 NUMRL2 = NUMRL2+1 - RLIST2(NUMRL2) = AREA - IF(NUMRL2.LE.2) GO TO 155 - CALL DQELG(NUMRL2,RLIST2,RESEPS,ABSEPS,RES3LA,NRES) - KTMIN = KTMIN+1 - IF(KTMIN.GT.5.AND.ABSERR.LT.0.1D-02*ERRSUM) IER = 5 - IF(ABSEPS.GE.ABSERR) GO TO 150 - KTMIN = 0 - ABSERR = ABSEPS - RESULT = RESEPS - CORREC = ERLARG - ERTEST = DMAX1(EPSABS,EPSREL*DABS(RESEPS)) -C ***JUMP OUT OF DO-LOOP - IF(ABSERR.LT.ERTEST) GO TO 170 -C -C PREPARE BISECTION OF THE SMALLEST INTERVAL. -C - 150 IF(NUMRL2.EQ.1) NOEXT = .TRUE. - IF(IER.GE.5) GO TO 170 - 155 MAXERR = IORD(1) - ERRMAX = ELIST(MAXERR) - NRMAX = 1 - EXTRAP = .FALSE. - LEVMAX = LEVMAX+1 - ERLARG = ERRSUM - 160 CONTINUE -C -C SET THE FINAL RESULT. -C --------------------- -C -C - 170 IF(ABSERR.EQ.OFLOW) GO TO 190 - IF((IER+IERRO).EQ.0) GO TO 180 - IF(IERRO.EQ.3) ABSERR = ABSERR+CORREC - IF(IER.EQ.0) IER = 3 - IF(RESULT.NE.0.0D+00.AND.AREA.NE.0.0D+00)GO TO 175 - IF(ABSERR.GT.ERRSUM)GO TO 190 - IF(AREA.EQ.0.0D+00) GO TO 210 - GO TO 180 - 175 IF(ABSERR/DABS(RESULT).GT.ERRSUM/DABS(AREA))GO TO 190 -C -C TEST ON DIVERGENCE. -C - 180 IF(KSGN.EQ.(-1).AND.DMAX1(DABS(RESULT),DABS(AREA)).LE. - * RESABS*0.1D-01) GO TO 210 - IF(0.1D-01.GT.(RESULT/AREA).OR.(RESULT/AREA).GT.0.1D+03.OR. - * ERRSUM.GT.DABS(AREA)) IER = 6 - GO TO 210 -C -C COMPUTE GLOBAL INTEGRAL SUM. -C - 190 RESULT = 0.0D+00 - DO 200 K = 1,LAST - RESULT = RESULT+RLIST(K) - 200 CONTINUE - ABSERR = ERRSUM - 210 IF(IER.GT.2) IER = IER-1 - RESULT = RESULT*SIGN - 999 RETURN - END
--- a/liboctave/cruft/quadpack/dqelg.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,184 +0,0 @@ - SUBROUTINE DQELG(N,EPSTAB,RESULT,ABSERR,RES3LA,NRES) -C***BEGIN PROLOGUE DQELG -C***REFER TO DQAGIE,DQAGOE,DQAGPE,DQAGSE -C***ROUTINES CALLED D1MACH -C***REVISION DATE 830518 (YYMMDD) -C***KEYWORDS EPSILON ALGORITHM, CONVERGENCE ACCELERATION, -C EXTRAPOLATION -C***AUTHOR PIESSENS,ROBERT,APPL. MATH. & PROGR. DIV. - K.U.LEUVEN -C DE DONCKER,ELISE,APPL. MATH & PROGR. DIV. - K.U.LEUVEN -C***PURPOSE THE ROUTINE DETERMINES THE LIMIT OF A GIVEN SEQUENCE OF -C APPROXIMATIONS, BY MEANS OF THE EPSILON ALGORITHM OF -C P.WYNN. AN ESTIMATE OF THE ABSOLUTE ERROR IS ALSO GIVEN. -C THE CONDENSED EPSILON TABLE IS COMPUTED. ONLY THOSE -C ELEMENTS NEEDED FOR THE COMPUTATION OF THE NEXT DIAGONAL -C ARE PRESERVED. -C***DESCRIPTION -C -C EPSILON ALGORITHM -C STANDARD FORTRAN SUBROUTINE -C DOUBLE PRECISION VERSION -C -C PARAMETERS -C N - INTEGER -C EPSTAB(N) CONTAINS THE NEW ELEMENT IN THE -C FIRST COLUMN OF THE EPSILON TABLE. -C -C EPSTAB - DOUBLE PRECISION -C VECTOR OF DIMENSION 52 CONTAINING THE ELEMENTS -C OF THE TWO LOWER DIAGONALS OF THE TRIANGULAR -C EPSILON TABLE. THE ELEMENTS ARE NUMBERED -C STARTING AT THE RIGHT-HAND CORNER OF THE -C TRIANGLE. -C -C RESULT - DOUBLE PRECISION -C RESULTING APPROXIMATION TO THE INTEGRAL -C -C ABSERR - DOUBLE PRECISION -C ESTIMATE OF THE ABSOLUTE ERROR COMPUTED FROM -C RESULT AND THE 3 PREVIOUS RESULTS -C -C RES3LA - DOUBLE PRECISION -C VECTOR OF DIMENSION 3 CONTAINING THE LAST 3 -C RESULTS -C -C NRES - INTEGER -C NUMBER OF CALLS TO THE ROUTINE -C (SHOULD BE ZERO AT FIRST CALL) -C -C***END PROLOGUE DQELG -C - DOUBLE PRECISION ABSERR,DABS,DELTA1,DELTA2,DELTA3,DMAX1,D1MACH, - * EPMACH,EPSINF,EPSTAB,ERROR,ERR1,ERR2,ERR3,E0,E1,E1ABS,E2,E3, - * OFLOW,RES,RESULT,RES3LA,SS,TOL1,TOL2,TOL3 - INTEGER I,IB,IB2,IE,INDX,K1,K2,K3,LIMEXP,N,NEWELM,NRES,NUM - DIMENSION EPSTAB(52),RES3LA(3) -C -C LIST OF MAJOR VARIABLES -C ----------------------- -C -C E0 - THE 4 ELEMENTS ON WHICH THE COMPUTATION OF A NEW -C E1 ELEMENT IN THE EPSILON TABLE IS BASED -C E2 -C E3 E0 -C E3 E1 NEW -C E2 -C NEWELM - NUMBER OF ELEMENTS TO BE COMPUTED IN THE NEW -C DIAGONAL -C ERROR - ERROR = ABS(E1-E0)+ABS(E2-E1)+ABS(NEW-E2) -C RESULT - THE ELEMENT IN THE NEW DIAGONAL WITH LEAST VALUE -C OF ERROR -C -C MACHINE DEPENDENT CONSTANTS -C --------------------------- -C -C EPMACH IS THE LARGEST RELATIVE SPACING. -C OFLOW IS THE LARGEST POSITIVE MAGNITUDE. -C LIMEXP IS THE MAXIMUM NUMBER OF ELEMENTS THE EPSILON -C TABLE CAN CONTAIN. IF THIS NUMBER IS REACHED, THE UPPER -C DIAGONAL OF THE EPSILON TABLE IS DELETED. -C -C***FIRST EXECUTABLE STATEMENT DQELG - EPMACH = D1MACH(4) - OFLOW = D1MACH(2) - NRES = NRES+1 - ABSERR = OFLOW - RESULT = EPSTAB(N) - IF(N.LT.3) GO TO 100 - LIMEXP = 50 - EPSTAB(N+2) = EPSTAB(N) - NEWELM = (N-1)/2 - EPSTAB(N) = OFLOW - NUM = N - K1 = N - DO 40 I = 1,NEWELM - K2 = K1-1 - K3 = K1-2 - RES = EPSTAB(K1+2) - E0 = EPSTAB(K3) - E1 = EPSTAB(K2) - E2 = RES - E1ABS = DABS(E1) - DELTA2 = E2-E1 - ERR2 = DABS(DELTA2) - TOL2 = DMAX1(DABS(E2),E1ABS)*EPMACH - DELTA3 = E1-E0 - ERR3 = DABS(DELTA3) - TOL3 = DMAX1(E1ABS,DABS(E0))*EPMACH - IF(ERR2.GT.TOL2.OR.ERR3.GT.TOL3) GO TO 10 -C -C IF E0, E1 AND E2 ARE EQUAL TO WITHIN MACHINE -C ACCURACY, CONVERGENCE IS ASSUMED. -C RESULT = E2 -C ABSERR = ABS(E1-E0)+ABS(E2-E1) -C - RESULT = RES - ABSERR = ERR2+ERR3 -C ***JUMP OUT OF DO-LOOP - GO TO 100 - 10 E3 = EPSTAB(K1) - EPSTAB(K1) = E1 - DELTA1 = E1-E3 - ERR1 = DABS(DELTA1) - TOL1 = DMAX1(E1ABS,DABS(E3))*EPMACH -C -C IF TWO ELEMENTS ARE VERY CLOSE TO EACH OTHER, OMIT -C A PART OF THE TABLE BY ADJUSTING THE VALUE OF N -C - IF(ERR1.LE.TOL1.OR.ERR2.LE.TOL2.OR.ERR3.LE.TOL3) GO TO 20 - SS = 0.1D+01/DELTA1+0.1D+01/DELTA2-0.1D+01/DELTA3 - EPSINF = DABS(SS*E1) -C -C TEST TO DETECT IRREGULAR BEHAVIOUR IN THE TABLE, AND -C EVENTUALLY OMIT A PART OF THE TABLE ADJUSTING THE VALUE -C OF N. -C - IF(EPSINF.GT.0.1D-03) GO TO 30 - 20 N = I+I-1 -C ***JUMP OUT OF DO-LOOP - GO TO 50 -C -C COMPUTE A NEW ELEMENT AND EVENTUALLY ADJUST -C THE VALUE OF RESULT. -C - 30 RES = E1+0.1D+01/SS - EPSTAB(K1) = RES - K1 = K1-2 - ERROR = ERR2+DABS(RES-E2)+ERR3 - IF(ERROR.GT.ABSERR) GO TO 40 - ABSERR = ERROR - RESULT = RES - 40 CONTINUE -C -C SHIFT THE TABLE. -C - 50 IF(N.EQ.LIMEXP) N = 2*(LIMEXP/2)-1 - IB = 1 - IF((NUM/2)*2.EQ.NUM) IB = 2 - IE = NEWELM+1 - DO 60 I=1,IE - IB2 = IB+2 - EPSTAB(IB) = EPSTAB(IB2) - IB = IB2 - 60 CONTINUE - IF(NUM.EQ.N) GO TO 80 - INDX = NUM-N+1 - DO 70 I = 1,N - EPSTAB(I)= EPSTAB(INDX) - INDX = INDX+1 - 70 CONTINUE - 80 IF(NRES.GE.4) GO TO 90 - RES3LA(NRES) = RESULT - ABSERR = OFLOW - GO TO 100 -C -C COMPUTE ERROR ESTIMATE -C - 90 ABSERR = DABS(RESULT-RES3LA(3))+DABS(RESULT-RES3LA(2)) - * +DABS(RESULT-RES3LA(1)) - RES3LA(1) = RES3LA(2) - RES3LA(2) = RES3LA(3) - RES3LA(3) = RESULT - 100 ABSERR = DMAX1(ABSERR,0.5D+01*EPMACH*DABS(RESULT)) - RETURN - END
--- a/liboctave/cruft/quadpack/dqk15i.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,211 +0,0 @@ - SUBROUTINE DQK15I(F,BOUN,INF,A,B,RESULT,ABSERR,RESABS,RESASC, - 1 IERR) -C***BEGIN PROLOGUE DQK15I -C***DATE WRITTEN 800101 (YYMMDD) -C***REVISION DATE 830518 (YYMMDD) -C***CATEGORY NO. H2A3A2,H2A4A2 -C***KEYWORDS 15-POINT TRANSFORMED GAUSS-KRONROD RULES -C***AUTHOR PIESSENS,ROBERT,APPL. MATH. & PROGR. DIV. - K.U.LEUVEN -C DE DONCKER,ELISE,APPL. MATH. & PROGR. DIV. - K.U.LEUVEN -C***PURPOSE THE ORIGINAL (INFINITE INTEGRATION RANGE IS MAPPED -C ONTO THE INTERVAL (0,1) AND (A,B) IS A PART OF (0,1). -C IT IS THE PURPOSE TO COMPUTE -C I = INTEGRAL OF TRANSFORMED INTEGRAND OVER (A,B), -C J = INTEGRAL OF ABS(TRANSFORMED INTEGRAND) OVER (A,B). -C***DESCRIPTION -C -C INTEGRATION RULE -C STANDARD FORTRAN SUBROUTINE -C DOUBLE PRECISION VERSION -C -C PARAMETERS -C ON ENTRY -C F - SUBROUTINE F(X,IERR,RESULT) DEFINING THE INTEGRAND -C FUNCTION F(X). THE ACTUAL NAME FOR F NEEDS TO BE -C DECLARED E X T E R N A L IN THE CALLING PROGRAM. -C -C BOUN - DOUBLE PRECISION -C FINITE BOUND OF ORIGINAL INTEGRATION -C RANGE (SET TO ZERO IF INF = +2) -C -C INF - INTEGER -C IF INF = -1, THE ORIGINAL INTERVAL IS -C (-INFINITY,BOUND), -C IF INF = +1, THE ORIGINAL INTERVAL IS -C (BOUND,+INFINITY), -C IF INF = +2, THE ORIGINAL INTERVAL IS -C (-INFINITY,+INFINITY) AND -C THE INTEGRAL IS COMPUTED AS THE SUM OF TWO -C INTEGRALS, ONE OVER (-INFINITY,0) AND ONE OVER -C (0,+INFINITY). -C -C A - DOUBLE PRECISION -C LOWER LIMIT FOR INTEGRATION OVER SUBRANGE -C OF (0,1) -C -C B - DOUBLE PRECISION -C UPPER LIMIT FOR INTEGRATION OVER SUBRANGE -C OF (0,1) -C -C ON RETURN -C RESULT - DOUBLE PRECISION -C APPROXIMATION TO THE INTEGRAL I -C RESULT IS COMPUTED BY APPLYING THE 15-POINT -C KRONROD RULE(RESK) OBTAINED BY OPTIMAL ADDITION -C OF ABSCISSAE TO THE 7-POINT GAUSS RULE(RESG). -C -C ABSERR - DOUBLE PRECISION -C ESTIMATE OF THE MODULUS OF THE ABSOLUTE ERROR, -C WHICH SHOULD EQUAL OR EXCEED ABS(I-RESULT) -C -C RESABS - DOUBLE PRECISION -C APPROXIMATION TO THE INTEGRAL J -C -C RESASC - DOUBLE PRECISION -C APPROXIMATION TO THE INTEGRAL OF -C ABS((TRANSFORMED INTEGRAND)-I/(B-A)) OVER (A,B) -C -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH -C***END PROLOGUE DQK15I -C - DOUBLE PRECISION A,ABSC,ABSC1,ABSC2,ABSERR,B,BOUN,CENTR,DABS,DINF, - * DMAX1,DMIN1,D1MACH,EPMACH,FC,FSUM,FVAL1,FVAL2,FV1,FV2,HLGTH, - * RESABS,RESASC,RESG,RESK,RESKH,RESULT,TABSC1,TABSC2,UFLOW,WG,WGK, - * XGK,FVALT - INTEGER INF,J - EXTERNAL F -C - DIMENSION FV1(7),FV2(7),XGK(8),WGK(8),WG(8) -C -C THE ABSCISSAE AND WEIGHTS ARE SUPPLIED FOR THE INTERVAL -C (-1,1). BECAUSE OF SYMMETRY ONLY THE POSITIVE ABSCISSAE AND -C THEIR CORRESPONDING WEIGHTS ARE GIVEN. -C -C XGK - ABSCISSAE OF THE 15-POINT KRONROD RULE -C XGK(2), XGK(4), ... ABSCISSAE OF THE 7-POINT -C GAUSS RULE -C XGK(1), XGK(3), ... ABSCISSAE WHICH ARE OPTIMALLY -C ADDED TO THE 7-POINT GAUSS RULE -C -C WGK - WEIGHTS OF THE 15-POINT KRONROD RULE -C -C WG - WEIGHTS OF THE 7-POINT GAUSS RULE, CORRESPONDING -C TO THE ABSCISSAE XGK(2), XGK(4), ... -C WG(1), WG(3), ... ARE SET TO ZERO. -C - DATA WG(1) / 0.0D0 / - DATA WG(2) / 0.1294849661 6886969327 0611432679 082D0 / - DATA WG(3) / 0.0D0 / - DATA WG(4) / 0.2797053914 8927666790 1467771423 780D0 / - DATA WG(5) / 0.0D0 / - DATA WG(6) / 0.3818300505 0511894495 0369775488 975D0 / - DATA WG(7) / 0.0D0 / - DATA WG(8) / 0.4179591836 7346938775 5102040816 327D0 / -C - DATA XGK(1) / 0.9914553711 2081263920 6854697526 329D0 / - DATA XGK(2) / 0.9491079123 4275852452 6189684047 851D0 / - DATA XGK(3) / 0.8648644233 5976907278 9712788640 926D0 / - DATA XGK(4) / 0.7415311855 9939443986 3864773280 788D0 / - DATA XGK(5) / 0.5860872354 6769113029 4144838258 730D0 / - DATA XGK(6) / 0.4058451513 7739716690 6606412076 961D0 / - DATA XGK(7) / 0.2077849550 0789846760 0689403773 245D0 / - DATA XGK(8) / 0.0000000000 0000000000 0000000000 000D0 / -C - DATA WGK(1) / 0.0229353220 1052922496 3732008058 970D0 / - DATA WGK(2) / 0.0630920926 2997855329 0700663189 204D0 / - DATA WGK(3) / 0.1047900103 2225018383 9876322541 518D0 / - DATA WGK(4) / 0.1406532597 1552591874 5189590510 238D0 / - DATA WGK(5) / 0.1690047266 3926790282 6583426598 550D0 / - DATA WGK(6) / 0.1903505780 6478540991 3256402421 014D0 / - DATA WGK(7) / 0.2044329400 7529889241 4161999234 649D0 / - DATA WGK(8) / 0.2094821410 8472782801 2999174891 714D0 / -C -C -C LIST OF MAJOR VARIABLES -C ----------------------- -C -C CENTR - MID POINT OF THE INTERVAL -C HLGTH - HALF-LENGTH OF THE INTERVAL -C ABSC* - ABSCISSA -C TABSC* - TRANSFORMED ABSCISSA -C FVAL* - FUNCTION VALUE -C RESG - RESULT OF THE 7-POINT GAUSS FORMULA -C RESK - RESULT OF THE 15-POINT KRONROD FORMULA -C RESKH - APPROXIMATION TO THE MEAN VALUE OF THE TRANSFORMED -C INTEGRAND OVER (A,B), I.E. TO I/(B-A) -C -C MACHINE DEPENDENT CONSTANTS -C --------------------------- -C -C EPMACH IS THE LARGEST RELATIVE SPACING. -C UFLOW IS THE SMALLEST POSITIVE MAGNITUDE. -C -C***FIRST EXECUTABLE STATEMENT DQK15I - EPMACH = D1MACH(4) - UFLOW = D1MACH(1) - DINF = MIN0(1,INF) -C - CENTR = 0.5D+00*(A+B) - HLGTH = 0.5D+00*(B-A) - TABSC1 = BOUN+DINF*(0.1D+01-CENTR)/CENTR - IERR = 0 - CALL F(TABSC1,IERR,FVAL1) - IF (IERR .LT. 0) RETURN - IF(INF.EQ.2) THEN - CALL F(-TABSC1,IERR,FVALT) - IF (IERR .LT. 0) RETURN - FVAL1 = FVAL1+FVALT - ENDIF - FC = (FVAL1/CENTR)/CENTR -C -C COMPUTE THE 15-POINT KRONROD APPROXIMATION TO -C THE INTEGRAL, AND ESTIMATE THE ERROR. -C - RESG = WG(8)*FC - RESK = WGK(8)*FC - RESABS = DABS(RESK) - DO 10 J=1,7 - ABSC = HLGTH*XGK(J) - ABSC1 = CENTR-ABSC - ABSC2 = CENTR+ABSC - TABSC1 = BOUN+DINF*(0.1D+01-ABSC1)/ABSC1 - TABSC2 = BOUN+DINF*(0.1D+01-ABSC2)/ABSC2 - CALL F(TABSC1,IERR,FVAL1) - IF (IERR .LT. 0) RETURN - CALL F(TABSC2,IERR,FVAL2) - IF (IERR .LT. 0) RETURN - IF(INF.EQ.2) THEN - CALL F(-TABSC1,IERR,FVALT) - IF (IERR .LT. 0) RETURN - FVAL1 = FVAL1+FVALT - ENDIF - IF(INF.EQ.2) THEN - CALL F(-TABSC2,IERR,FVALT) - IF (IERR .LT. 0) RETURN - FVAL2 = FVAL2+FVALT - ENDIF - FVAL1 = (FVAL1/ABSC1)/ABSC1 - FVAL2 = (FVAL2/ABSC2)/ABSC2 - FV1(J) = FVAL1 - FV2(J) = FVAL2 - FSUM = FVAL1+FVAL2 - RESG = RESG+WG(J)*FSUM - RESK = RESK+WGK(J)*FSUM - RESABS = RESABS+WGK(J)*(DABS(FVAL1)+DABS(FVAL2)) - 10 CONTINUE - RESKH = RESK*0.5D+00 - RESASC = WGK(8)*DABS(FC-RESKH) - DO 20 J=1,7 - RESASC = RESASC+WGK(J)*(DABS(FV1(J)-RESKH)+DABS(FV2(J)-RESKH)) - 20 CONTINUE - RESULT = RESK*HLGTH - RESASC = RESASC*HLGTH - RESABS = RESABS*HLGTH - ABSERR = DABS((RESK-RESG)*HLGTH) - IF(RESASC.NE.0.0D+00.AND.ABSERR.NE.0.D0) ABSERR = RESASC* - * DMIN1(0.1D+01,(0.2D+03*ABSERR/RESASC)**1.5D+00) - IF(RESABS.GT.UFLOW/(0.5D+02*EPMACH)) ABSERR = DMAX1 - * ((EPMACH*0.5D+02)*RESABS,ABSERR) - RETURN - END
--- a/liboctave/cruft/quadpack/dqk21.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,187 +0,0 @@ - SUBROUTINE DQK21(F,A,B,RESULT,ABSERR,RESABS,RESASC,IERR) -C***BEGIN PROLOGUE DQK21 -C***DATE WRITTEN 800101 (YYMMDD) -C***REVISION DATE 830518 (YYMMDD) -C***CATEGORY NO. H2A1A2 -C***KEYWORDS 21-POINT GAUSS-KRONROD RULES -C***AUTHOR PIESSENS,ROBERT,APPL. MATH. & PROGR. DIV. - K.U.LEUVEN -C DE DONCKER,ELISE,APPL. MATH. & PROGR. DIV. - K.U.LEUVEN -C***PURPOSE TO COMPUTE I = INTEGRAL OF F OVER (A,B), WITH ERROR -C ESTIMATE -C J = INTEGRAL OF ABS(F) OVER (A,B) -C***DESCRIPTION -C -C INTEGRATION RULES -C STANDARD FORTRAN SUBROUTINE -C DOUBLE PRECISION VERSION -C -C PARAMETERS -C ON ENTRY -C F - SUBROUTINE F(X,IERR,RESULT) DEFINING THE INTEGRAND -C FUNCTION F(X). THE ACTUAL NAME FOR F NEEDS TO BE -C DECLARED E X T E R N A L IN THE DRIVER PROGRAM. -C -C A - DOUBLE PRECISION -C LOWER LIMIT OF INTEGRATION -C -C B - DOUBLE PRECISION -C UPPER LIMIT OF INTEGRATION -C -C ON RETURN -C RESULT - DOUBLE PRECISION -C APPROXIMATION TO THE INTEGRAL I -C RESULT IS COMPUTED BY APPLYING THE 21-POINT -C KRONROD RULE (RESK) OBTAINED BY OPTIMAL ADDITION -C OF ABSCISSAE TO THE 10-POINT GAUSS RULE (RESG). -C -C ABSERR - DOUBLE PRECISION -C ESTIMATE OF THE MODULUS OF THE ABSOLUTE ERROR, -C WHICH SHOULD NOT EXCEED ABS(I-RESULT) -C -C RESABS - DOUBLE PRECISION -C APPROXIMATION TO THE INTEGRAL J -C -C RESASC - DOUBLE PRECISION -C APPROXIMATION TO THE INTEGRAL OF ABS(F-I/(B-A)) -C OVER (A,B) -C -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH -C***END PROLOGUE DQK21 -C - DOUBLE PRECISION A,ABSC,ABSERR,B,CENTR,DABS,DHLGTH,DMAX1,DMIN1, - * D1MACH,EPMACH,FC,FSUM,FVAL1,FVAL2,FV1,FV2,HLGTH,RESABS,RESASC, - * RESG,RESK,RESKH,RESULT,UFLOW,WG,WGK,XGK - INTEGER J,JTW,JTWM1 - EXTERNAL F -C - DIMENSION FV1(10),FV2(10),WG(5),WGK(11),XGK(11) -C -C THE ABSCISSAE AND WEIGHTS ARE GIVEN FOR THE INTERVAL (-1,1). -C BECAUSE OF SYMMETRY ONLY THE POSITIVE ABSCISSAE AND THEIR -C CORRESPONDING WEIGHTS ARE GIVEN. -C -C XGK - ABSCISSAE OF THE 21-POINT KRONROD RULE -C XGK(2), XGK(4), ... ABSCISSAE OF THE 10-POINT -C GAUSS RULE -C XGK(1), XGK(3), ... ABSCISSAE WHICH ARE OPTIMALLY -C ADDED TO THE 10-POINT GAUSS RULE -C -C WGK - WEIGHTS OF THE 21-POINT KRONROD RULE -C -C WG - WEIGHTS OF THE 10-POINT GAUSS RULE -C -C -C GAUSS QUADRATURE WEIGHTS AND KRONRON QUADRATURE ABSCISSAE AND WEIGHTS -C AS EVALUATED WITH 80 DECIMAL DIGIT ARITHMETIC BY L. W. FULLERTON, -C BELL LABS, NOV. 1981. -C - DATA WG ( 1) / 0.0666713443 0868813759 3568809893 332 D0 / - DATA WG ( 2) / 0.1494513491 5058059314 5776339657 697 D0 / - DATA WG ( 3) / 0.2190863625 1598204399 5534934228 163 D0 / - DATA WG ( 4) / 0.2692667193 0999635509 1226921569 469 D0 / - DATA WG ( 5) / 0.2955242247 1475287017 3892994651 338 D0 / -C - DATA XGK ( 1) / 0.9956571630 2580808073 5527280689 003 D0 / - DATA XGK ( 2) / 0.9739065285 1717172007 7964012084 452 D0 / - DATA XGK ( 3) / 0.9301574913 5570822600 1207180059 508 D0 / - DATA XGK ( 4) / 0.8650633666 8898451073 2096688423 493 D0 / - DATA XGK ( 5) / 0.7808177265 8641689706 3717578345 042 D0 / - DATA XGK ( 6) / 0.6794095682 9902440623 4327365114 874 D0 / - DATA XGK ( 7) / 0.5627571346 6860468333 9000099272 694 D0 / - DATA XGK ( 8) / 0.4333953941 2924719079 9265943165 784 D0 / - DATA XGK ( 9) / 0.2943928627 0146019813 1126603103 866 D0 / - DATA XGK ( 10) / 0.1488743389 8163121088 4826001129 720 D0 / - DATA XGK ( 11) / 0.0000000000 0000000000 0000000000 000 D0 / -C - DATA WGK ( 1) / 0.0116946388 6737187427 8064396062 192 D0 / - DATA WGK ( 2) / 0.0325581623 0796472747 8818972459 390 D0 / - DATA WGK ( 3) / 0.0547558965 7435199603 1381300244 580 D0 / - DATA WGK ( 4) / 0.0750396748 1091995276 7043140916 190 D0 / - DATA WGK ( 5) / 0.0931254545 8369760553 5065465083 366 D0 / - DATA WGK ( 6) / 0.1093871588 0229764189 9210590325 805 D0 / - DATA WGK ( 7) / 0.1234919762 6206585107 7958109831 074 D0 / - DATA WGK ( 8) / 0.1347092173 1147332592 8054001771 707 D0 / - DATA WGK ( 9) / 0.1427759385 7706008079 7094273138 717 D0 / - DATA WGK ( 10) / 0.1477391049 0133849137 4841515972 068 D0 / - DATA WGK ( 11) / 0.1494455540 0291690566 4936468389 821 D0 / -C -C -C LIST OF MAJOR VARIABLES -C ----------------------- -C -C CENTR - MID POINT OF THE INTERVAL -C HLGTH - HALF-LENGTH OF THE INTERVAL -C ABSC - ABSCISSA -C FVAL* - FUNCTION VALUE -C RESG - RESULT OF THE 10-POINT GAUSS FORMULA -C RESK - RESULT OF THE 21-POINT KRONROD FORMULA -C RESKH - APPROXIMATION TO THE MEAN VALUE OF F OVER (A,B), -C I.E. TO I/(B-A) -C -C -C MACHINE DEPENDENT CONSTANTS -C --------------------------- -C -C EPMACH IS THE LARGEST RELATIVE SPACING. -C UFLOW IS THE SMALLEST POSITIVE MAGNITUDE. -C -C***FIRST EXECUTABLE STATEMENT DQK21 - EPMACH = D1MACH(4) - UFLOW = D1MACH(1) -C - CENTR = 0.5D+00*(A+B) - HLGTH = 0.5D+00*(B-A) - DHLGTH = DABS(HLGTH) -C -C COMPUTE THE 21-POINT KRONROD APPROXIMATION TO -C THE INTEGRAL, AND ESTIMATE THE ABSOLUTE ERROR. -C - RESG = 0.0D+00 - IERR = 0 - CALL F(CENTR,IERR,FC) - IF (IERR .LT. 0) RETURN - RESK = WGK(11)*FC - RESABS = DABS(RESK) - DO 10 J=1,5 - JTW = 2*J - ABSC = HLGTH*XGK(JTW) - CALL F(CENTR-ABSC,IERR,FVAL1) - IF (IERR .LT. 0) RETURN - CALL F(CENTR+ABSC,IERR,FVAL2) - IF (IERR .LT. 0) RETURN - FV1(JTW) = FVAL1 - FV2(JTW) = FVAL2 - FSUM = FVAL1+FVAL2 - RESG = RESG+WG(J)*FSUM - RESK = RESK+WGK(JTW)*FSUM - RESABS = RESABS+WGK(JTW)*(DABS(FVAL1)+DABS(FVAL2)) - 10 CONTINUE - DO 15 J = 1,5 - JTWM1 = 2*J-1 - ABSC = HLGTH*XGK(JTWM1) - CALL F(CENTR-ABSC,IERR,FVAL1) - IF (IERR .LT. 0) RETURN - CALL F(CENTR+ABSC,IERR,FVAL2) - IF (IERR .LT. 0) RETURN - FV1(JTWM1) = FVAL1 - FV2(JTWM1) = FVAL2 - FSUM = FVAL1+FVAL2 - RESK = RESK+WGK(JTWM1)*FSUM - RESABS = RESABS+WGK(JTWM1)*(DABS(FVAL1)+DABS(FVAL2)) - 15 CONTINUE - RESKH = RESK*0.5D+00 - RESASC = WGK(11)*DABS(FC-RESKH) - DO 20 J=1,10 - RESASC = RESASC+WGK(J)*(DABS(FV1(J)-RESKH)+DABS(FV2(J)-RESKH)) - 20 CONTINUE - RESULT = RESK*HLGTH - RESABS = RESABS*DHLGTH - RESASC = RESASC*DHLGTH - ABSERR = DABS((RESK-RESG)*HLGTH) - IF(RESASC.NE.0.0D+00.AND.ABSERR.NE.0.0D+00) - * ABSERR = RESASC*DMIN1(0.1D+01,(0.2D+03*ABSERR/RESASC)**1.5D+00) - IF(RESABS.GT.UFLOW/(0.5D+02*EPMACH)) ABSERR = DMAX1 - * ((EPMACH*0.5D+02)*RESABS,ABSERR) - RETURN - END
--- a/liboctave/cruft/quadpack/dqpsrt.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,129 +0,0 @@ - SUBROUTINE DQPSRT(LIMIT,LAST,MAXERR,ERMAX,ELIST,IORD,NRMAX) -C***BEGIN PROLOGUE DQPSRT -C***REFER TO DQAGE,DQAGIE,DQAGPE,DQAWSE -C***ROUTINES CALLED (NONE) -C***REVISION DATE 810101 (YYMMDD) -C***KEYWORDS SEQUENTIAL SORTING -C***AUTHOR PIESSENS,ROBERT,APPL. MATH. & PROGR. DIV. - K.U.LEUVEN -C DE DONCKER,ELISE,APPL. MATH. & PROGR. DIV. - K.U.LEUVEN -C***PURPOSE THIS ROUTINE MAINTAINS THE DESCENDING ORDERING IN THE -C LIST OF THE LOCAL ERROR ESTIMATED RESULTING FROM THE -C INTERVAL SUBDIVISION PROCESS. AT EACH CALL TWO ERROR -C ESTIMATES ARE INSERTED USING THE SEQUENTIAL SEARCH -C METHOD, TOP-DOWN FOR THE LARGEST ERROR ESTIMATE AND -C BOTTOM-UP FOR THE SMALLEST ERROR ESTIMATE. -C***DESCRIPTION -C -C ORDERING ROUTINE -C STANDARD FORTRAN SUBROUTINE -C DOUBLE PRECISION VERSION -C -C PARAMETERS (MEANING AT OUTPUT) -C LIMIT - INTEGER -C MAXIMUM NUMBER OF ERROR ESTIMATES THE LIST -C CAN CONTAIN -C -C LAST - INTEGER -C NUMBER OF ERROR ESTIMATES CURRENTLY IN THE LIST -C -C MAXERR - INTEGER -C MAXERR POINTS TO THE NRMAX-TH LARGEST ERROR -C ESTIMATE CURRENTLY IN THE LIST -C -C ERMAX - DOUBLE PRECISION -C NRMAX-TH LARGEST ERROR ESTIMATE -C ERMAX = ELIST(MAXERR) -C -C ELIST - DOUBLE PRECISION -C VECTOR OF DIMENSION LAST CONTAINING -C THE ERROR ESTIMATES -C -C IORD - INTEGER -C VECTOR OF DIMENSION LAST, THE FIRST K ELEMENTS -C OF WHICH CONTAIN POINTERS TO THE ERROR -C ESTIMATES, SUCH THAT -C ELIST(IORD(1)),..., ELIST(IORD(K)) -C FORM A DECREASING SEQUENCE, WITH -C K = LAST IF LAST.LE.(LIMIT/2+2), AND -C K = LIMIT+1-LAST OTHERWISE -C -C NRMAX - INTEGER -C MAXERR = IORD(NRMAX) -C -C***END PROLOGUE DQPSRT -C - DOUBLE PRECISION ELIST,ERMAX,ERRMAX,ERRMIN - INTEGER I,IBEG,IDO,IORD,ISUCC,J,JBND,JUPBN,K,LAST,LIMIT,MAXERR, - * NRMAX - DIMENSION ELIST(LAST),IORD(LAST) -C -C CHECK WHETHER THE LIST CONTAINS MORE THAN -C TWO ERROR ESTIMATES. -C -C***FIRST EXECUTABLE STATEMENT DQPSRT - IF(LAST.GT.2) GO TO 10 - IORD(1) = 1 - IORD(2) = 2 - GO TO 90 -C -C THIS PART OF THE ROUTINE IS ONLY EXECUTED IF, DUE TO A -C DIFFICULT INTEGRAND, SUBDIVISION INCREASED THE ERROR -C ESTIMATE. IN THE NORMAL CASE THE INSERT PROCEDURE SHOULD -C START AFTER THE NRMAX-TH LARGEST ERROR ESTIMATE. -C - 10 ERRMAX = ELIST(MAXERR) - IF(NRMAX.EQ.1) GO TO 30 - IDO = NRMAX-1 - DO 20 I = 1,IDO - ISUCC = IORD(NRMAX-1) -C ***JUMP OUT OF DO-LOOP - IF(ERRMAX.LE.ELIST(ISUCC)) GO TO 30 - IORD(NRMAX) = ISUCC - NRMAX = NRMAX-1 - 20 CONTINUE -C -C COMPUTE THE NUMBER OF ELEMENTS IN THE LIST TO BE MAINTAINED -C IN DESCENDING ORDER. THIS NUMBER DEPENDS ON THE NUMBER OF -C SUBDIVISIONS STILL ALLOWED. -C - 30 JUPBN = LAST - IF(LAST.GT.(LIMIT/2+2)) JUPBN = LIMIT+3-LAST - ERRMIN = ELIST(LAST) -C -C INSERT ERRMAX BY TRAVERSING THE LIST TOP-DOWN, -C STARTING COMPARISON FROM THE ELEMENT ELIST(IORD(NRMAX+1)). -C - JBND = JUPBN-1 - IBEG = NRMAX+1 - IF(IBEG.GT.JBND) GO TO 50 - DO 40 I=IBEG,JBND - ISUCC = IORD(I) -C ***JUMP OUT OF DO-LOOP - IF(ERRMAX.GE.ELIST(ISUCC)) GO TO 60 - IORD(I-1) = ISUCC - 40 CONTINUE - 50 IORD(JBND) = MAXERR - IORD(JUPBN) = LAST - GO TO 90 -C -C INSERT ERRMIN BY TRAVERSING THE LIST BOTTOM-UP. -C - 60 IORD(I-1) = MAXERR - K = JBND - DO 70 J=I,JBND - ISUCC = IORD(K) -C ***JUMP OUT OF DO-LOOP - IF(ERRMIN.LT.ELIST(ISUCC)) GO TO 80 - IORD(K+1) = ISUCC - K = K-1 - 70 CONTINUE - IORD(I) = LAST - GO TO 90 - 80 IORD(K+1) = LAST -C -C SET MAXERR AND ERMAX. -C - 90 MAXERR = IORD(NRMAX) - ERMAX = ELIST(MAXERR) - RETURN - END
--- a/liboctave/cruft/quadpack/module.mk Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,18 +0,0 @@ -CRUFT_SOURCES += \ - liboctave/cruft/quadpack/dqagi.f \ - liboctave/cruft/quadpack/dqagie.f \ - liboctave/cruft/quadpack/dqagp.f \ - liboctave/cruft/quadpack/dqagpe.f \ - liboctave/cruft/quadpack/dqelg.f \ - liboctave/cruft/quadpack/dqk15i.f \ - liboctave/cruft/quadpack/dqk21.f \ - liboctave/cruft/quadpack/dqpsrt.f \ - liboctave/cruft/quadpack/qagie.f \ - liboctave/cruft/quadpack/qagi.f \ - liboctave/cruft/quadpack/qagpe.f \ - liboctave/cruft/quadpack/qagp.f \ - liboctave/cruft/quadpack/qelg.f \ - liboctave/cruft/quadpack/qk15i.f \ - liboctave/cruft/quadpack/qk21.f \ - liboctave/cruft/quadpack/qpsrt.f \ - liboctave/cruft/quadpack/xerror.f
--- a/liboctave/cruft/quadpack/qagi.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,190 +0,0 @@ - subroutine qagi(f,bound,inf,epsabs,epsrel,result,abserr,neval, - * ier,limit,lenw,last,iwork,work) -c***begin prologue qagi -c***date written 800101 (yymmdd) -c***revision date 830518 (yymmdd) -c***category no. h2a3a1,h2a4a1 -c***keywords automatic integrator, infinite intervals, -c general-purpose, transformation, extrapolation, -c globally adaptive -c***author piessens,robert,appl. math. & progr. div. - k.u.leuven -c de doncker,elise,appl. math. & progr. div. -k.u.leuven -c***purpose the routine calculates an approximation result to a given -c integral i = integral of f over (bound,+infinity) -c or i = integral of f over (-infinity,bound) -c or i = integral of f over (-infinity,+infinity) -c hopefully satisfying following claim for accuracy -c abs(i-result).le.max(epsabs,epsrel*abs(i)). -c***description -c -c integration over infinite intervals -c standard fortran subroutine -c -c parameters -c on entry -c f - subroutine f(x,result) defining the integrand -c function f(x). the actual name for f needs to be -c declared e x t e r n a l in the driver program. -c -c bound - real -c finite bound of integration range -c (has no meaning if interval is doubly-infinite) -c -c inf - integer -c indicating the kind of integration range involved -c inf = 1 corresponds to (bound,+infinity), -c inf = -1 to (-infinity,bound), -c inf = 2 to (-infinity,+infinity). -c -c epsabs - real -c absolute accuracy requested -c epsrel - real -c relative accuracy requested -c if epsabs.le.0 -c and epsrel.lt.max(50*rel.mach.acc.,0.5d-28), -c the routine will end with ier = 6. -c -c -c on return -c result - real -c approximation to the integral -c -c abserr - real -c estimate of the modulus of the absolute error, -c which should equal or exceed abs(i-result) -c -c neval - integer -c number of integrand evaluations -c -c ier - integer -c ier = 0 normal and reliable termination of the -c routine. it is assumed that the requested -c accuracy has been achieved. -c - ier.gt.0 abnormal termination of the routine. the -c estimates for result and error are less -c reliable. it is assumed that the requested -c accuracy has not been achieved. -c error messages -c ier = 1 maximum number of subdivisions allowed -c has been achieved. one can allow more -c subdivisions by increasing the value of -c limit (and taking the according dimension -c adjustments into account). however, if -c this yields no improvement it is advised -c to analyze the integrand in order to -c determine the integration difficulties. if -c the position of a local difficulty can be -c determined (e.g. singularity, -c discontinuity within the interval) one -c will probably gain from splitting up the -c interval at this point and calling the -c integrator on the subranges. if possible, -c an appropriate special-purpose integrator -c should be used, which is designed for -c handling the type of difficulty involved. -c = 2 the occurrence of roundoff error is -c detected, which prevents the requested -c tolerance from being achieved. -c the error may be under-estimated. -c = 3 extremely bad integrand behaviour occurs -c at some points of the integration -c interval. -c = 4 the algorithm does not converge. -c roundoff error is detected in the -c extrapolation table. -c it is assumed that the requested tolerance -c cannot be achieved, and that the returned -c result is the best which can be obtained. -c = 5 the integral is probably divergent, or -c slowly convergent. it must be noted that -c divergence can occur with any other value -c of ier. -c = 6 the input is invalid, because -c (epsabs.le.0 and -c epsrel.lt.max(50*rel.mach.acc.,0.5d-28)) -c or limit.lt.1 or leniw.lt.limit*4. -c result, abserr, neval, last are set to -c zero. exept when limit or leniw is -c invalid, iwork(1), work(limit*2+1) and -c work(limit*3+1) are set to zero, work(1) -c is set to a and work(limit+1) to b. -c -c dimensioning parameters -c limit - integer -c dimensioning parameter for iwork -c limit determines the maximum number of subintervals -c in the partition of the given integration interval -c (a,b), limit.ge.1. -c if limit.lt.1, the routine will end with ier = 6. -c -c lenw - integer -c dimensioning parameter for work -c lenw must be at least limit*4. -c if lenw.lt.limit*4, the routine will end -c with ier = 6. -c -c last - integer -c on return, last equals the number of subintervals -c produced in the subdivision process, which -c determines the number of significant elements -c actually in the work arrays. -c -c work arrays -c iwork - integer -c vector of dimension at least limit, the first -c k elements of which contain pointers -c to the error estimates over the subintervals, -c such that work(limit*3+iwork(1)),... , -c work(limit*3+iwork(k)) form a decreasing -c sequence, with k = last if last.le.(limit/2+2), and -c k = limit+1-last otherwise -c -c work - real -c vector of dimension at least lenw -c on return -c work(1), ..., work(last) contain the left -c end points of the subintervals in the -c partition of (a,b), -c work(limit+1), ..., work(limit+last) contain -c the right end points, -c work(limit*2+1), ...,work(limit*2+last) contain the -c integral approximations over the subintervals, -c work(limit*3+1), ..., work(limit*3) -c contain the error estimates. -c***references (none) -c***routines called qagie,xerror -c***end prologue qagi -c - real abserr, epsabs,epsrel,result,work - integer ier,iwork, lenw,limit,lvl,l1,l2,l3,neval -c - dimension iwork(limit),work(lenw) -c - external f -c -c check validity of limit and lenw. -c -c***first executable statement qagi - ier = 6 - neval = 0 - last = 0 - result = 0.0e+00 - abserr = 0.0e+00 - if(limit.lt.1.or.lenw.lt.limit*4) go to 10 -c -c prepare call for qagie. -c - l1 = limit+1 - l2 = limit+l1 - l3 = limit+l2 -c - call qagie(f,bound,inf,epsabs,epsrel,limit,result,abserr, - * neval,ier,work(1),work(l1),work(l2),work(l3),iwork,last) -c -c call error handler if necessary. -c - lvl = 0 -10 if(ier.eq.6) lvl = 1 - if(ier.ne.0) call xerror('abnormal return from qagi',26,ier,lvl) - return - end
--- a/liboctave/cruft/quadpack/qagie.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,460 +0,0 @@ - subroutine qagie(f,bound,inf,epsabs,epsrel,limit,result,abserr, - * neval,ier,alist,blist,rlist,elist,iord,last) -c***begin prologue qagie -c***date written 800101 (yymmdd) -c***revision date 830518 (yymmdd) -c***category no. h2a3a1,h2a4a1 -c***keywords automatic integrator, infinite intervals, -c general-purpose, transformation, extrapolation, -c globally adaptive -c***author piessens,robert,appl. math & progr. div - k.u.leuven -c de doncker,elise,appl. math & progr. div - k.u.leuven -c***purpose the routine calculates an approximation result to a given -c integral i = integral of f over (bound,+infinity) -c or i = integral of f over (-infinity,bound) -c or i = integral of f over (-infinity,+infinity), -c hopefully satisfying following claim for accuracy -c abs(i-result).le.max(epsabs,epsrel*abs(i)) -c***description -c -c integration over infinite intervals -c standard fortran subroutine -c -c f - subroutine f(x,ierr,result) defining the integrand -c function f(x). the actual name for f needs to be -c declared e x t e r n a l in the driver program. -c -c bound - real -c finite bound of integration range -c (has no meaning if interval is doubly-infinite) -c -c inf - real -c indicating the kind of integration range involved -c inf = 1 corresponds to (bound,+infinity), -c inf = -1 to (-infinity,bound), -c inf = 2 to (-infinity,+infinity). -c -c epsabs - real -c absolute accuracy requested -c epsrel - real -c relative accuracy requested -c if epsabs.le.0 -c and epsrel.lt.max(50*rel.mach.acc.,0.5d-28), -c the routine will end with ier = 6. -c -c limit - integer -c gives an upper bound on the number of subintervals -c in the partition of (a,b), limit.ge.1 -c -c on return -c result - real -c approximation to the integral -c -c abserr - real -c estimate of the modulus of the absolute error, -c which should equal or exceed abs(i-result) -c -c neval - integer -c number of integrand evaluations -c -c ier - integer -c ier = 0 normal and reliable termination of the -c routine. it is assumed that the requested -c accuracy has been achieved. -c - ier.gt.0 abnormal termination of the routine. the -c estimates for result and error are less -c reliable. it is assumed that the requested -c accuracy has not been achieved. -c error messages -c ier = 1 maximum number of subdivisions allowed -c has been achieved. one can allow more -c subdivisions by increasing the value of -c limit (and taking the according dimension -c adjustments into account). however,if -c this yields no improvement it is advised -c to analyze the integrand in order to -c determine the integration difficulties. -c if the position of a local difficulty can -c be determined (e.g. singularity, -c discontinuity within the interval) one -c will probably gain from splitting up the -c interval at this point and calling the -c integrator on the subranges. if possible, -c an appropriate special-purpose integrator -c should be used, which is designed for -c handling the type of difficulty involved. -c = 2 the occurrence of roundoff error is -c detected, which prevents the requested -c tolerance from being achieved. -c the error may be under-estimated. -c = 3 extremely bad integrand behaviour occurs -c at some points of the integration -c interval. -c = 4 the algorithm does not converge. -c roundoff error is detected in the -c extrapolation table. -c it is assumed that the requested tolerance -c cannot be achieved, and that the returned -c result is the best which can be obtained. -c = 5 the integral is probably divergent, or -c slowly convergent. it must be noted that -c divergence can occur with any other value -c of ier. -c = 6 the input is invalid, because -c (epsabs.le.0 and -c epsrel.lt.max(50*rel.mach.acc.,0.5d-28), -c result, abserr, neval, last, rlist(1), -c elist(1) and iord(1) are set to zero. -c alist(1) and blist(1) are set to 0 -c and 1 respectively. -c -c alist - real -c vector of dimension at least limit, the first -c last elements of which are the left -c end points of the subintervals in the partition -c of the transformed integration range (0,1). -c -c blist - real -c vector of dimension at least limit, the first -c last elements of which are the right -c end points of the subintervals in the partition -c of the transformed integration range (0,1). -c -c rlist - real -c vector of dimension at least limit, the first -c last elements of which are the integral -c approximations on the subintervals -c -c elist - real -c vector of dimension at least limit, the first -c last elements of which are the moduli of the -c absolute error estimates on the subintervals -c -c iord - integer -c vector of dimension limit, the first k -c elements of which are pointers to the -c error estimates over the subintervals, -c such that elist(iord(1)), ..., elist(iord(k)) -c form a decreasing sequence, with k = last -c if last.le.(limit/2+2), and k = limit+1-last -c otherwise -c -c last - integer -c number of subintervals actually produced -c in the subdivision process -c -c***references (none) -c***routines called qelg,qk15i,qpsrt,r1mach -c***end prologue qagie -c - real abseps,abserr,alist,area,area1,area12,area2,a1, - * a2,blist,boun,bound,b1,b2,correc,defabs,defab1,defab2, - * dres,r1mach,elist,epmach,epsabs,epsrel,erlarg,erlast, - * errbnd,errmax,error1,error2,erro12,errsum,ertest,oflow,resabs, - * reseps,result,res3la,rlist,rlist2,small,uflow - integer id,ier,ierro,inf,iord,iroff1,iroff2,iroff3,jupbnd,k,ksgn, - * ktmin,last,limit,maxerr,neval,nres,nrmax,numrl2 - logical extrap,noext -c - dimension alist(limit),blist(limit),elist(limit),iord(limit), - * res3la(3),rlist(limit),rlist2(52) -c - external f -c -c the dimension of rlist2 is determined by the value of -c limexp in subroutine qelg. -c -c -c list of major variables -c ----------------------- -c -c alist - list of left end points of all subintervals -c considered up to now -c blist - list of right end points of all subintervals -c considered up to now -c rlist(i) - approximation to the integral over -c (alist(i),blist(i)) -c rlist2 - array of dimension at least (limexp+2), -c containing the part of the epsilon table -c wich is still needed for further computations -c elist(i) - error estimate applying to rlist(i) -c maxerr - pointer to the interval with largest error -c estimate -c errmax - elist(maxerr) -c erlast - error on the interval currently subdivided -c (before that subdivision has taken place) -c area - sum of the integrals over the subintervals -c errsum - sum of the errors over the subintervals -c errbnd - requested accuracy max(epsabs,epsrel* -c abs(result)) -c *****1 - variable for the left subinterval -c *****2 - variable for the right subinterval -c last - index for subdivision -c nres - number of calls to the extrapolation routine -c numrl2 - number of elements currently in rlist2. if an -c appropriate approximation to the compounded -c integral has been obtained, it is put in -c rlist2(numrl2) after numrl2 has been increased -c by one. -c small - length of the smallest interval considered up -c to now, multiplied by 1.5 -c erlarg - sum of the errors over the intervals larger -c than the smallest interval considered up to now -c extrap - logical variable denoting that the routine -c is attempting to perform extrapolation. i.e. -c before subdividing the smallest interval we -c try to decrease the value of erlarg. -c noext - logical variable denoting that extrapolation -c is no longer allowed (true-value) -c -c machine dependent constants -c --------------------------- -c -c epmach is the largest relative spacing. -c uflow is the smallest positive magnitude. -c oflow is the largest positive magnitude. -c - epmach = r1mach(4) -c -c test on validity of parameters -c ----------------------------- -c -c***first executable statement qagie - ier = 0 - neval = 0 - last = 0 - result = 0.0e+00 - abserr = 0.0e+00 - alist(1) = 0.0e+00 - blist(1) = 0.1e+01 - rlist(1) = 0.0e+00 - elist(1) = 0.0e+00 - iord(1) = 0 - if(epsabs.le.0.0e+00.and.epsrel.lt.amax1(0.5e+02*epmach,0.5e-14)) - * ier = 6 - if(ier.eq.6) go to 999 -c -c -c first approximation to the integral -c ----------------------------------- -c -c determine the interval to be mapped onto (0,1). -c if inf = 2 the integral is computed as i = i1+i2, where -c i1 = integral of f over (-infinity,0), -c i2 = integral of f over (0,+infinity). -c - boun = bound - if(inf.eq.2) boun = 0.0e+00 - call qk15i(f,boun,inf,0.0e+00,0.1e+01,result,abserr, - * defabs,resabs,ier) - if (ier.lt.0) return -c -c test on accuracy -c - last = 1 - rlist(1) = result - elist(1) = abserr - iord(1) = 1 - dres = abs(result) - errbnd = amax1(epsabs,epsrel*dres) - if(abserr.le.1.0e+02*epmach*defabs.and.abserr.gt. - * errbnd) ier = 2 - if(limit.eq.1) ier = 1 - if(ier.ne.0.or.(abserr.le.errbnd.and.abserr.ne.resabs).or. - * abserr.eq.0.0e+00) go to 130 -c -c initialization -c -------------- -c - uflow = r1mach(1) - oflow = r1mach(2) - rlist2(1) = result - errmax = abserr - maxerr = 1 - area = result - errsum = abserr - abserr = oflow - nrmax = 1 - nres = 0 - ktmin = 0 - numrl2 = 2 - extrap = .false. - noext = .false. - ierro = 0 - iroff1 = 0 - iroff2 = 0 - iroff3 = 0 - ksgn = -1 - if(dres.ge.(0.1e+01-0.5e+02*epmach)*defabs) ksgn = 1 -c -c main do-loop -c ------------ -c - do 90 last = 2,limit -c -c bisect the subinterval with nrmax-th largest -c error estimate. -c - a1 = alist(maxerr) - b1 = 0.5e+00*(alist(maxerr)+blist(maxerr)) - a2 = b1 - b2 = blist(maxerr) - erlast = errmax - call qk15i(f,boun,inf,a1,b1,area1,error1,resabs,defab1,ier) - if (ier.lt.0) return - call qk15i(f,boun,inf,a2,b2,area2,error2,resabs,defab2,ier) - if (ier.lt.0) return -c -c improve previous approximations to integral -c and error and test for accuracy. -c - area12 = area1+area2 - erro12 = error1+error2 - errsum = errsum+erro12-errmax - area = area+area12-rlist(maxerr) - if(defab1.eq.error1.or.defab2.eq.error2)go to 15 - if(abs(rlist(maxerr)-area12).gt.0.1e-04*abs(area12) - * .or.erro12.lt.0.99e+00*errmax) go to 10 - if(extrap) iroff2 = iroff2+1 - if(.not.extrap) iroff1 = iroff1+1 - 10 if(last.gt.10.and.erro12.gt.errmax) iroff3 = iroff3+1 - 15 rlist(maxerr) = area1 - rlist(last) = area2 - errbnd = amax1(epsabs,epsrel*abs(area)) -c -c test for roundoff error and eventually -c set error flag. -c - if(iroff1+iroff2.ge.10.or.iroff3.ge.20) ier = 2 - if(iroff2.ge.5) ierro = 3 -c -c set error flag in the case that the number of -c subintervals equals limit. -c - if(last.eq.limit) ier = 1 -c -c set error flag in the case of bad integrand behaviour -c at some points of the integration range. -c - if(amax1(abs(a1),abs(b2)).le.(0.1e+01+0.1e+03*epmach)* - * (abs(a2)+0.1e+04*uflow)) ier = 4 -c -c append the newly-created intervals to the list. -c - if(error2.gt.error1) go to 20 - alist(last) = a2 - blist(maxerr) = b1 - blist(last) = b2 - elist(maxerr) = error1 - elist(last) = error2 - go to 30 - 20 alist(maxerr) = a2 - alist(last) = a1 - blist(last) = b1 - rlist(maxerr) = area2 - rlist(last) = area1 - elist(maxerr) = error2 - elist(last) = error1 -c -c call subroutine qpsrt to maintain the descending ordering -c in the list of error estimates and select the -c subinterval with nrmax-th largest error estimate (to be -c bisected next). -c - 30 call qpsrt(limit,last,maxerr,errmax,elist,iord,nrmax) - if(errsum.le.errbnd) go to 115 - if(ier.ne.0) go to 100 - if(last.eq.2) go to 80 - if(noext) go to 90 - erlarg = erlarg-erlast - if(abs(b1-a1).gt.small) erlarg = erlarg+erro12 - if(extrap) go to 40 -c -c test whether the interval to be bisected next is the -c smallest interval. -c - if(abs(blist(maxerr)-alist(maxerr)).gt.small) go to 90 - extrap = .true. - nrmax = 2 - 40 if(ierro.eq.3.or.erlarg.le.ertest) go to 60 -c -c the smallest interval has the largest error. -c before bisecting decrease the sum of the errors -c over the larger intervals (erlarg) and perform -c extrapolation. -c - id = nrmax - jupbnd = last - if(last.gt.(2+limit/2)) jupbnd = limit+3-last - do 50 k = id,jupbnd - maxerr = iord(nrmax) - errmax = elist(maxerr) - if(abs(blist(maxerr)-alist(maxerr)).gt.small) go to 90 - nrmax = nrmax+1 - 50 continue -c -c perform extrapolation. -c - 60 numrl2 = numrl2+1 - rlist2(numrl2) = area - call qelg(numrl2,rlist2,reseps,abseps,res3la,nres) - ktmin = ktmin+1 - if(ktmin.gt.5.and.abserr.lt.0.1e-02*errsum) ier = 5 - if(abseps.ge.abserr) go to 70 - ktmin = 0 - abserr = abseps - result = reseps - correc = erlarg - ertest = amax1(epsabs,epsrel*abs(reseps)) - if(abserr.le.ertest) go to 100 -c -c prepare bisection of the smallest interval. -c - 70 if(numrl2.eq.1) noext = .true. - if(ier.eq.5) go to 100 - maxerr = iord(1) - errmax = elist(maxerr) - nrmax = 1 - extrap = .false. - small = small*0.5e+00 - erlarg = errsum - go to 90 - 80 small = 0.375e+00 - erlarg = errsum - ertest = errbnd - rlist2(2) = area - 90 continue -c -c set final result and error estimate. -c ------------------------------------ -c - 100 if(abserr.eq.oflow) go to 115 - if((ier+ierro).eq.0) go to 110 - if(ierro.eq.3) abserr = abserr+correc - if(ier.eq.0) ier = 3 - if(result.ne.0.0e+00.and.area.ne.0.0e+00)go to 105 - if(abserr.gt.errsum)go to 115 - if(area.eq.0.0e+00) go to 130 - go to 110 - 105 if(abserr/abs(result).gt.errsum/abs(area))go to 115 -c -c test on divergence -c - 110 if(ksgn.eq.(-1).and.amax1(abs(result),abs(area)).le. - * defabs*0.1e-01) go to 130 - if(0.1e-01.gt.(result/area).or.(result/area).gt.0.1e+03. - *or.errsum.gt.abs(area)) ier = 6 - go to 130 -c -c compute global integral sum. -c - 115 result = 0.0e+00 - do 120 k = 1,last - result = result+rlist(k) - 120 continue - abserr = errsum - 130 neval = 30*last-15 - if(inf.eq.2) neval = 2*neval - if(ier.gt.2) ier=ier-1 - 999 return - end
--- a/liboctave/cruft/quadpack/qagp.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,223 +0,0 @@ - subroutine qagp(f,a,b,npts2,points,epsabs,epsrel,result,abserr, - * neval,ier,leniw,lenw,last,iwork,work) -c***begin prologue qagp -c***date written 800101 (yymmdd) -c***revision date 830518 (yymmdd) -c***category no. h2a2a1 -c***keywords automatic integrator, general-purpose, -c singularities at user specified points, -c extrapolation, globally adaptive -c***author piessens,robert,appl. math. & progr. div - k.u.leuven -c de doncker,elise,appl. math. & progr. div. - k.u.leuven -c***purpose the routine calculates an approximation result to a given -c definite integral i = integral of f over (a,b), -c hopefully satisfying following claim for accuracy -c break points of the integration interval, where local -c difficulties of the integrand may occur(e.g. singularities, -c discontinuities), are provided by the user. -c***description -c -c computation of a definite integral -c standard fortran subroutine -c real version -c -c parameters -c on entry -c f - subroutine f(x,ierr,result) defining the integrand -c function f(x). the actual name for f needs to be -c declared e x t e r n a l in the driver program. -c -c a - real -c lower limit of integration -c -c b - real -c upper limit of integration -c -c npts2 - integer -c number equal to two more than the number of -c user-supplied break points within the integration -c range, npts.ge.2. -c if npts2.lt.2, the routine will end with ier = 6. -c -c points - real -c vector of dimension npts2, the first (npts2-2) -c elements of which are the user provided break -c points. if these points do not constitute an -c ascending sequence there will be an automatic -c sorting. -c -c epsabs - real -c absolute accuracy requested -c epsrel - real -c relative accuracy requested -c if epsabs.le.0 -c and epsrel.lt.max(50*rel.mach.acc.,0.5d-28), -c the routine will end with ier = 6. -c -c on return -c result - real -c approximation to the integral -c -c abserr - real -c estimate of the modulus of the absolute error, -c which should equal or exceed abs(i-result) -c -c neval - integer -c number of integrand evaluations -c -c ier - integer -c ier = 0 normal and reliable termination of the -c routine. it is assumed that the requested -c accuracy has been achieved. -c ier.gt.0 abnormal termination of the routine. -c the estimates for integral and error are -c less reliable. it is assumed that the -c requested accuracy has not been achieved. -c error messages -c ier = 1 maximum number of subdivisions allowed -c has been achieved. one can allow more -c subdivisions by increasing the value of -c limit (and taking the according dimension -c adjustments into account). however, if -c this yields no improvement it is advised -c to analyze the integrand in order to -c determine the integration difficulties. if -c the position of a local difficulty can be -c determined (i.e. singularity, -c discontinuity within the interval), it -c should be supplied to the routine as an -c element of the vector points. if necessary -c an appropriate special-purpose integrator -c must be used, which is designed for -c handling the type of difficulty involved. -c = 2 the occurrence of roundoff error is -c detected, which prevents the requested -c tolerance from being achieved. -c the error may be under-estimated. -c = 3 extremely bad integrand behaviour occurs -c at some points of the integration -c interval. -c = 4 the algorithm does not converge. -c roundoff error is detected in the -c extrapolation table. -c it is presumed that the requested -c tolerance cannot be achieved, and that -c the returned result is the best which -c can be obtained. -c = 5 the integral is probably divergent, or -c slowly convergent. it must be noted that -c divergence can occur with any other value -c of ier.gt.0. -c = 6 the input is invalid because -c npts2.lt.2 or -c break points are specified outside -c the integration range or -c (epsabs.le.0 and -c epsrel.lt.max(50*rel.mach.acc.,0.5d-28)) -c result, abserr, neval, last are set to -c zero. exept when leniw or lenw or npts2 is -c invalid, iwork(1), iwork(limit+1), -c work(limit*2+1) and work(limit*3+1) -c are set to zero. -c work(1) is set to a and work(limit+1) -c to b (where limit = (leniw-npts2)/2). -c -c dimensioning parameters -c leniw - integer -c dimensioning parameter for iwork -c leniw determines limit = (leniw-npts2)/2, -c which is the maximum number of subintervals in the -c partition of the given integration interval (a,b), -c leniw.ge.(3*npts2-2). -c if leniw.lt.(3*npts2-2), the routine will end with -c ier = 6. -c -c lenw - integer -c dimensioning parameter for work -c lenw must be at least leniw*2-npts2. -c if lenw.lt.leniw*2-npts2, the routine will end -c with ier = 6. -c -c last - integer -c on return, last equals the number of subintervals -c produced in the subdivision process, which -c determines the number of significant elements -c actually in the work arrays. -c -c work arrays -c iwork - integer -c vector of dimension at least leniw. on return, -c the first k elements of which contain -c pointers to the error estimates over the -c subintervals, such that work(limit*3+iwork(1)),..., -c work(limit*3+iwork(k)) form a decreasing -c sequence, with k = last if last.le.(limit/2+2), and -c k = limit+1-last otherwise -c iwork(limit+1), ...,iwork(limit+last) contain the -c subdivision levels of the subintervals, i.e. -c if (aa,bb) is a subinterval of (p1,p2) -c where p1 as well as p2 is a user-provided -c break point or integration limit, then (aa,bb) has -c level l if abs(bb-aa) = abs(p2-p1)*2**(-l), -c iwork(limit*2+1), ..., iwork(limit*2+npts2) have -c no significance for the user, -c note that limit = (leniw-npts2)/2. -c -c work - real -c vector of dimension at least lenw -c on return -c work(1), ..., work(last) contain the left -c end points of the subintervals in the -c partition of (a,b), -c work(limit+1), ..., work(limit+last) contain -c the right end points, -c work(limit*2+1), ..., work(limit*2+last) contain -c the integral approximations over the subintervals, -c work(limit*3+1), ..., work(limit*3+last) -c contain the corresponding error estimates, -c work(limit*4+1), ..., work(limit*4+npts2) -c contain the integration limits and the -c break points sorted in an ascending sequence. -c note that limit = (leniw-npts2)/2. -c -c***references (none) -c***routines called qagpe,xerror -c***end prologue qagp -c - real a,abserr,b,epsabs,epsrel,points,result,work - integer ier,iwork,leniw,lenw,limit,lvl,l1,l2,l3,neval,npts2 -c - dimension iwork(leniw),points(npts2),work(lenw) -c - external f -c -c check validity of limit and lenw. -c -c***first executable statement qagp - ier = 6 - neval = 0 - last = 0 - result = 0.0e+00 - abserr = 0.0e+00 - if(leniw.lt.(3*npts2-2).or.lenw.lt.(leniw*2-npts2).or.npts2.lt.2) - * go to 10 -c -c prepare call for qagpe. -c - limit = (leniw-npts2)/2 - l1 = limit+1 - l2 = limit+l1 - l3 = limit+l2 - l4 = limit+l3 -c - call qagpe(f,a,b,npts2,points,epsabs,epsrel,limit,result,abserr, - * neval,ier,work(1),work(l1),work(l2),work(l3),work(l4), - * iwork(1),iwork(l1),iwork(l2),last) -c -c call error handler if necessary. -c - lvl = 0 -10 if(ier.eq.6) lvl = 1 - if(ier.ne.0) call xerror('abnormal return from qagp',26,ier,lvl) - return - end
--- a/liboctave/cruft/quadpack/qagpe.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,560 +0,0 @@ - subroutine qagpe(f,a,b,npts2,points,epsabs,epsrel,limit,result, - * abserr,neval,ier,alist,blist,rlist,elist,pts,iord,level,ndin, - * last) -c***begin prologue qagpe -c***date written 800101 (yymmdd) -c***revision date 830518 (yymmdd) -c***category no. h2a2a1 -c***keywords automatic integrator, general-purpose, -c singularities at user specified points, -c extrapolation, globally adaptive. -c***author piessens,robert ,appl. math. & progr. div. - k.u.leuven -c de doncker,elise,appl. math. & progr. div. - k.u.leuven -c***purpose the routine calculates an approximation result to a given -c definite integral i = integral of f over (a,b),hopefully -c satisfying following claim for accuracy abs(i-result).le. -c max(epsabs,epsrel*abs(i)). break points of the integration -c interval, where local difficulties of the integrand may -c occur(e.g. singularities,discontinuities),provided by user. -c***description -c -c computation of a definite integral -c standard fortran subroutine -c real version -c -c parameters -c on entry -c f - subroutine f(x,ierr,result) defining the integrand -c function f(x). the actual name for f needs to be -c declared e x t e r n a l in the driver program. -c -c a - real -c lower limit of integration -c -c b - real -c upper limit of integration -c -c npts2 - integer -c number equal to two more than the number of -c user-supplied break points within the integration -c range, npts2.ge.2. -c if npts2.lt.2, the routine will end with ier = 6. -c -c points - real -c vector of dimension npts2, the first (npts2-2) -c elements of which are the user provided break -c points. if these points do not constitute an -c ascending sequence there will be an automatic -c sorting. -c -c epsabs - real -c absolute accuracy requested -c epsrel - real -c relative accuracy requested -c if epsabs.le.0 -c and epsrel.lt.max(50*rel.mach.acc.,0.5d-28), -c the routine will end with ier = 6. -c -c limit - integer -c gives an upper bound on the number of subintervals -c in the partition of (a,b), limit.ge.npts2 -c if limit.lt.npts2, the routine will end with -c ier = 6. -c -c on return -c result - real -c approximation to the integral -c -c abserr - real -c estimate of the modulus of the absolute error, -c which should equal or exceed abs(i-result) -c -c neval - integer -c number of integrand evaluations -c -c ier - integer -c ier = 0 normal and reliable termination of the -c routine. it is assumed that the requested -c accuracy has been achieved. -c ier.gt.0 abnormal termination of the routine. -c the estimates for integral and error are -c less reliable. it is assumed that the -c requested accuracy has not been achieved. -c error messages -c ier = 1 maximum number of subdivisions allowed -c has been achieved. one can allow more -c subdivisions by increasing the value of -c limit (and taking the according dimension -c adjustments into account). however, if -c this yields no improvement it is advised -c to analyze the integrand in order to -c determine the integration difficulties. if -c the position of a local difficulty can be -c determined (i.e. singularity, -c discontinuity within the interval), it -c should be supplied to the routine as an -c element of the vector points. if necessary -c an appropriate special-purpose integrator -c must be used, which is designed for -c handling the type of difficulty involved. -c = 2 the occurrence of roundoff error is -c detected, which prevents the requested -c tolerance from being achieved. -c the error may be under-estimated. -c = 3 extremely bad integrand behaviour occurs -c at some points of the integration -c interval. -c = 4 the algorithm does not converge. -c roundoff error is detected in the -c extrapolation table. it is presumed that -c the requested tolerance cannot be -c achieved, and that the returned result is -c the best which can be obtained. -c = 5 the integral is probably divergent, or -c slowly convergent. it must be noted that -c divergence can occur with any other value -c of ier.gt.0. -c = 6 the input is invalid because -c npts2.lt.2 or -c break points are specified outside -c the integration range or -c (epsabs.le.0 and -c epsrel.lt.max(50*rel.mach.acc.,0.5d-28)) -c or limit.lt.npts2. -c result, abserr, neval, last, rlist(1), -c and elist(1) are set to zero. alist(1) and -c blist(1) are set to a and b respectively. -c -c alist - real -c vector of dimension at least limit, the first -c last elements of which are the left end points -c of the subintervals in the partition of the given -c integration range (a,b) -c -c blist - real -c vector of dimension at least limit, the first -c last elements of which are the right end points -c of the subintervals in the partition of the given -c integration range (a,b) -c -c rlist - real -c vector of dimension at least limit, the first -c last elements of which are the integral -c approximations on the subintervals -c -c elist - real -c vector of dimension at least limit, the first -c last elements of which are the moduli of the -c absolute error estimates on the subintervals -c -c pts - real -c vector of dimension at least npts2, containing the -c integration limits and the break points of the -c interval in ascending sequence. -c -c level - integer -c vector of dimension at least limit, containing the -c subdivision levels of the subinterval, i.e. if -c (aa,bb) is a subinterval of (p1,p2) where p1 as -c well as p2 is a user-provided break point or -c integration limit, then (aa,bb) has level l if -c abs(bb-aa) = abs(p2-p1)*2**(-l). -c -c ndin - integer -c vector of dimension at least npts2, after first -c integration over the intervals (pts(i)),pts(i+1), -c i = 0,1, ..., npts2-2, the error estimates over -c some of the intervals may have been increased -c artificially, in order to put their subdivision -c forward. if this happens for the subinterval -c numbered k, ndin(k) is put to 1, otherwise -c ndin(k) = 0. -c -c iord - integer -c vector of dimension at least limit, the first k -c elements of which are pointers to the -c error estimates over the subintervals, -c such that elist(iord(1)), ..., elist(iord(k)) -c form a decreasing sequence, with k = last -c if last.le.(limit/2+2), and k = limit+1-last -c otherwise -c -c last - integer -c number of subintervals actually produced in the -c subdivisions process -c -c***references (none) -c***routines called qelg,qk21,qpsrt,r1mach -c***end prologue qagpe - real a,abseps,abserr,alist,area,area1,area12,area2,a1, - * a2,b,blist,b1,b2,correc,defabs,defab1,defab2, - * dres,r1mach,elist,epmach,epsabs,epsrel,erlarg,erlast,errbnd, - * errmax,error1,erro12,error2,errsum,ertest,oflow,points,pts, - * resa,resabs,reseps,result,res3la,rlist,rlist2,sign,temp, - * uflow - integer i,id,ier,ierro,ind1,ind2,iord,ip1,iroff1,iroff2, - * iroff3,j,jlow,jupbnd,k,ksgn,ktmin,last,levcur,level,levmax, - * limit,maxerr,ndin,neval,nint,nintp1,npts,npts2,nres, - * nrmax,numrl2 - logical extrap,noext -c -c - dimension alist(limit),blist(limit),elist(limit),iord(limit), - * level(limit),ndin(npts2),points(npts2),pts(npts2),res3la(3), - * rlist(limit),rlist2(52) -c - external f -c -c the dimension of rlist2 is determined by the value of -c limexp in subroutine epsalg (rlist2 should be of dimension -c (limexp+2) at least). -c -c -c list of major variables -c ----------------------- -c -c alist - list of left end points of all subintervals -c considered up to now -c blist - list of right end points of all subintervals -c considered up to now -c rlist(i) - approximation to the integral over -c (alist(i),blist(i)) -c rlist2 - array of dimension at least limexp+2 -c containing the part of the epsilon table which -c is still needed for further computations -c elist(i) - error estimate applying to rlist(i) -c maxerr - pointer to the interval with largest error -c estimate -c errmax - elist(maxerr) -c erlast - error on the interval currently subdivided -c (before that subdivision has taken place) -c area - sum of the integrals over the subintervals -c errsum - sum of the errors over the subintervals -c errbnd - requested accuracy max(epsabs,epsrel* -c abs(result)) -c *****1 - variable for the left subinterval -c *****2 - variable for the right subinterval -c last - index for subdivision -c nres - number of calls to the extrapolation routine -c numrl2 - number of elements in rlist2. if an -c appropriate approximation to the compounded -c integral has been obtained, it is put in -c rlist2(numrl2) after numrl2 has been increased -c by one. -c erlarg - sum of the errors over the intervals larger -c than the smallest interval considered up to now -c extrap - logical variable denoting that the routine -c is attempting to perform extrapolation. i.e. -c before subdividing the smallest interval we -c try to decrease the value of erlarg. -c noext - logical variable denoting that extrapolation is -c no longer allowed (true-value) -c -c machine dependent constants -c --------------------------- -c -c epmach is the largest relative spacing. -c uflow is the smallest positive magnitude. -c oflow is the largest positive magnitude. -c -c***first executable statement qagpe - epmach = r1mach(4) -c -c test on validity of parameters -c ----------------------------- -c - ier = 0 - neval = 0 - last = 0 - result = 0.0e+00 - abserr = 0.0e+00 - alist(1) = a - blist(1) = b - rlist(1) = 0.0e+00 - elist(1) = 0.0e+00 - iord(1) = 0 - level(1) = 0 - npts = npts2-2 - if(npts2.lt.2.or.limit.le.npts.or.(epsabs.le.0.0e+00.and. - * epsrel.lt.amax1(0.5e+02*epmach,0.5e-14))) ier = 6 - if(ier.eq.6) go to 210 -c -c if any break points are provided, sort them into an -c ascending sequence. -c - sign = 1.0e+00 - if(a.gt.b) sign = -1.0e+00 - pts(1) = amin1(a,b) - if(npts.eq.0) go to 15 - do 10 i = 1,npts - pts(i+1) = points(i) - 10 continue - 15 pts(npts+2) = amax1(a,b) - nint = npts+1 - a1 = pts(1) - if(npts.eq.0) go to 40 - nintp1 = nint+1 - do 20 i = 1,nint - ip1 = i+1 - do 20 j = ip1,nintp1 - if(pts(i).le.pts(j)) go to 20 - temp = pts(i) - pts(i) = pts(j) - pts(j) = temp - 20 continue - if(pts(1).ne.amin1(a,b).or.pts(nintp1).ne. - * amax1(a,b)) ier = 6 - if(ier.eq.6) go to 999 -c -c compute first integral and error approximations. -c ------------------------------------------------ -c - 40 resabs = 0.0e+00 - do 50 i = 1,nint - b1 = pts(i+1) - call qk21(f,a1,b1,area1,error1,defabs,resa,ier) - if (ier.lt.0) return - abserr = abserr+error1 - result = result+area1 - ndin(i) = 0 - if(error1.eq.resa.and.error1.ne.0.0e+00) ndin(i) = 1 - resabs = resabs+defabs - level(i) = 0 - elist(i) = error1 - alist(i) = a1 - blist(i) = b1 - rlist(i) = area1 - iord(i) = i - a1 = b1 - 50 continue - errsum = 0.0e+00 - do 55 i = 1,nint - if(ndin(i).eq.1) elist(i) = abserr - errsum = errsum+elist(i) - 55 continue -c -c test on accuracy. -c - last = nint - neval = 21*nint - dres = abs(result) - errbnd = amax1(epsabs,epsrel*dres) - if(abserr.le.0.1e+03*epmach*resabs.and.abserr.gt. - * errbnd) ier = 2 - if(nint.eq.1) go to 80 - do 70 i = 1,npts - jlow = i+1 - ind1 = iord(i) - do 60 j = jlow,nint - ind2 = iord(j) - if(elist(ind1).gt.elist(ind2)) go to 60 - ind1 = ind2 - k = j - 60 continue - if(ind1.eq.iord(i)) go to 70 - iord(k) = iord(i) - iord(i) = ind1 - 70 continue - if(limit.lt.npts2) ier = 1 - 80 if(ier.ne.0.or.abserr.le.errbnd) go to 999 -c -c initialization -c -------------- -c - rlist2(1) = result - maxerr = iord(1) - errmax = elist(maxerr) - area = result - nrmax = 1 - nres = 0 - numrl2 = 1 - ktmin = 0 - extrap = .false. - noext = .false. - erlarg = errsum - ertest = errbnd - levmax = 1 - iroff1 = 0 - iroff2 = 0 - iroff3 = 0 - ierro = 0 - uflow = r1mach(1) - oflow = r1mach(2) - abserr = oflow - ksgn = -1 - if(dres.ge.(0.1e+01-0.5e+02*epmach)*resabs) ksgn = 1 -c -c main do-loop -c ------------ -c - do 160 last = npts2,limit -c -c bisect the subinterval with the nrmax-th largest -c error estimate. -c - levcur = level(maxerr)+1 - a1 = alist(maxerr) - b1 = 0.5e+00*(alist(maxerr)+blist(maxerr)) - a2 = b1 - b2 = blist(maxerr) - erlast = errmax - call qk21(f,a1,b1,area1,error1,resa,defab1,ier) - if (ier.lt.0) return - call qk21(f,a2,b2,area2,error2,resa,defab2,ier) - if (ier.lt.0) return -c -c improve previous approximations to integral -c and error and test for accuracy. -c - neval = neval+42 - area12 = area1+area2 - erro12 = error1+error2 - errsum = errsum+erro12-errmax - area = area+area12-rlist(maxerr) - if(defab1.eq.error1.or.defab2.eq.error2) go to 95 - if(abs(rlist(maxerr)-area12).gt.0.1e-04*abs(area12) - * .or.erro12.lt.0.99e+00*errmax) go to 90 - if(extrap) iroff2 = iroff2+1 - if(.not.extrap) iroff1 = iroff1+1 - 90 if(last.gt.10.and.erro12.gt.errmax) iroff3 = iroff3+1 - 95 level(maxerr) = levcur - level(last) = levcur - rlist(maxerr) = area1 - rlist(last) = area2 - errbnd = amax1(epsabs,epsrel*abs(area)) -c -c test for roundoff error and eventually -c set error flag. -c - if(iroff1+iroff2.ge.10.or.iroff3.ge.20) ier = 2 - if(iroff2.ge.5) ierro = 3 -c -c set error flag in the case that the number of -c subintervals equals limit. -c - if(last.eq.limit) ier = 1 -c -c set error flag in the case of bad integrand behaviour -c at a point of the integration range -c - if(amax1(abs(a1),abs(b2)).le.(0.1e+01+0.1e+03*epmach)* - * (abs(a2)+0.1e+04*uflow)) ier = 4 -c -c append the newly-created intervals to the list. -c - if(error2.gt.error1) go to 100 - alist(last) = a2 - blist(maxerr) = b1 - blist(last) = b2 - elist(maxerr) = error1 - elist(last) = error2 - go to 110 - 100 alist(maxerr) = a2 - alist(last) = a1 - blist(last) = b1 - rlist(maxerr) = area2 - rlist(last) = area1 - elist(maxerr) = error2 - elist(last) = error1 -c -c call subroutine qpsrt to maintain the descending ordering -c in the list of error estimates and select the -c subinterval with nrmax-th largest error estimate (to be -c bisected next). -c - 110 call qpsrt(limit,last,maxerr,errmax,elist,iord,nrmax) -c ***jump out of do-loop - if(errsum.le.errbnd) go to 190 -c ***jump out of do-loop - if(ier.ne.0) go to 170 - if(noext) go to 160 - erlarg = erlarg-erlast - if(levcur+1.le.levmax) erlarg = erlarg+erro12 - if(extrap) go to 120 -c -c test whether the interval to be bisected next is the -c smallest interval. -c - if(level(maxerr)+1.le.levmax) go to 160 - extrap = .true. - nrmax = 2 - 120 if(ierro.eq.3.or.erlarg.le.ertest) go to 140 -c -c the smallest interval has the largest error. -c before bisecting decrease the sum of the errors -c over the larger intervals (erlarg) and perform -c extrapolation. -c - id = nrmax - jupbnd = last - if(last.gt.(2+limit/2)) jupbnd = limit+3-last - do 130 k = id,jupbnd - maxerr = iord(nrmax) - errmax = elist(maxerr) -c ***jump out of do-loop - if(level(maxerr)+1.le.levmax) go to 160 - nrmax = nrmax+1 - 130 continue -c -c perform extrapolation. -c - 140 numrl2 = numrl2+1 - rlist2(numrl2) = area - if(numrl2.le.2) go to 155 - call qelg(numrl2,rlist2,reseps,abseps,res3la,nres) - ktmin = ktmin+1 - if(ktmin.gt.5.and.abserr.lt.0.1e-02*errsum) ier = 5 - if(abseps.ge.abserr) go to 150 - ktmin = 0 - abserr = abseps - result = reseps - correc = erlarg - ertest = amax1(epsabs,epsrel*abs(reseps)) -c ***jump out of do-loop - if(abserr.lt.ertest) go to 170 -c -c prepare bisection of the smallest interval. -c - 150 if(numrl2.eq.1) noext = .true. - if(ier.ge.5) go to 170 - 155 maxerr = iord(1) - errmax = elist(maxerr) - nrmax = 1 - extrap = .false. - levmax = levmax+1 - erlarg = errsum - 160 continue -c -c set the final result. -c --------------------- -c -c - 170 if(abserr.eq.oflow) go to 190 - if((ier+ierro).eq.0) go to 180 - if(ierro.eq.3) abserr = abserr+correc - if(ier.eq.0) ier = 3 - if(result.ne.0.0e+00.and.area.ne.0.0e+00)go to 175 - if(abserr.gt.errsum)go to 190 - if(area.eq.0.0e+00) go to 210 - go to 180 - 175 if(abserr/abs(result).gt.errsum/abs(area))go to 190 -c -c test on divergence. -c - 180 if(ksgn.eq.(-1).and.amax1(abs(result),abs(area)).le. - * resabs*0.1e-01) go to 210 - if(0.1e-01.gt.(result/area).or.(result/area).gt.0.1e+03.or. - * errsum.gt.abs(area)) ier = 6 - go to 210 -c -c compute global integral sum. -c - 190 result = 0.0e+00 - do 200 k = 1,last - result = result+rlist(k) - 200 continue - abserr = errsum - 210 if(ier.gt.2) ier = ier - 1 - result = result*sign - 999 return - end
--- a/liboctave/cruft/quadpack/qelg.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,184 +0,0 @@ - subroutine qelg(n,epstab,result,abserr,res3la,nres) -c***begin prologue qelg -c***refer to qagie,qagoe,qagpe,qagse -c***routines called r1mach -c***revision date 830518 (yymmdd) -c***keywords epsilon algorithm, convergence acceleration, -c extrapolation -c***author piessens,robert,appl. math. & progr. div. - k.u.leuven -c de doncker,elise,appl. math & progr. div. - k.u.leuven -c***purpose the routine determines the limit of a given sequence of -c approximations, by means of the epsilon algorithm of -c p. wynn. an estimate of the absolute error is also given. -c the condensed epsilon table is computed. only those -c elements needed for the computation of the next diagonal -c are preserved. -c***description -c -c epsilon algorithm -c standard fortran subroutine -c real version -c -c parameters -c n - integer -c epstab(n) contains the new element in the -c first column of the epsilon table. -c -c epstab - real -c vector of dimension 52 containing the elements -c of the two lower diagonals of the triangular -c epsilon table. the elements are numbered -c starting at the right-hand corner of the -c triangle. -c -c result - real -c resulting approximation to the integral -c -c abserr - real -c estimate of the absolute error computed from -c result and the 3 previous results -c -c res3la - real -c vector of dimension 3 containing the last 3 -c results -c -c nres - integer -c number of calls to the routine -c (should be zero at first call) -c -c***end prologue qelg -c - real abserr,delta1,delta2,delta3,r1mach, - * epmach,epsinf,epstab,error,err1,err2,err3,e0,e1,e1abs,e2,e3, - * oflow,res,result,res3la,ss,tol1,tol2,tol3 - integer i,ib,ib2,ie,indx,k1,k2,k3,limexp,n,newelm,nres,num - dimension epstab(52),res3la(3) -c -c list of major variables -c ----------------------- -c -c e0 - the 4 elements on which the -c e1 computation of a new element in -c e2 the epsilon table is based -c e3 e0 -c e3 e1 new -c e2 -c newelm - number of elements to be computed in the new -c diagonal -c error - error = abs(e1-e0)+abs(e2-e1)+abs(new-e2) -c result - the element in the new diagonal with least value -c of error -c -c machine dependent constants -c --------------------------- -c -c epmach is the largest relative spacing. -c oflow is the largest positive magnitude. -c limexp is the maximum number of elements the epsilon -c table can contain. if this number is reached, the upper -c diagonal of the epsilon table is deleted. -c -c***first executable statement qelg - epmach = r1mach(4) - oflow = r1mach(2) - nres = nres+1 - abserr = oflow - result = epstab(n) - if(n.lt.3) go to 100 - limexp = 50 - epstab(n+2) = epstab(n) - newelm = (n-1)/2 - epstab(n) = oflow - num = n - k1 = n - do 40 i = 1,newelm - k2 = k1-1 - k3 = k1-2 - res = epstab(k1+2) - e0 = epstab(k3) - e1 = epstab(k2) - e2 = res - e1abs = abs(e1) - delta2 = e2-e1 - err2 = abs(delta2) - tol2 = amax1(abs(e2),e1abs)*epmach - delta3 = e1-e0 - err3 = abs(delta3) - tol3 = amax1(e1abs,abs(e0))*epmach - if(err2.gt.tol2.or.err3.gt.tol3) go to 10 -c -c if e0, e1 and e2 are equal to within machine -c accuracy, convergence is assumed. -c result = e2 -c abserr = abs(e1-e0)+abs(e2-e1) -c - result = res - abserr = err2+err3 -c ***jump out of do-loop - go to 100 - 10 e3 = epstab(k1) - epstab(k1) = e1 - delta1 = e1-e3 - err1 = abs(delta1) - tol1 = amax1(e1abs,abs(e3))*epmach -c -c if two elements are very close to each other, omit -c a part of the table by adjusting the value of n -c - if(err1.le.tol1.or.err2.le.tol2.or.err3.le.tol3) go to 20 - ss = 0.1e+01/delta1+0.1e+01/delta2-0.1e+01/delta3 - epsinf = abs(ss*e1) -c -c test to detect irregular behaviour in the table, and -c eventually omit a part of the table adjusting the value -c of n. -c - if(epsinf.gt.0.1e-03) go to 30 - 20 n = i+i-1 -c ***jump out of do-loop - go to 50 -c -c compute a new element and eventually adjust -c the value of result. -c - 30 res = e1+0.1e+01/ss - epstab(k1) = res - k1 = k1-2 - error = err2+abs(res-e2)+err3 - if(error.gt.abserr) go to 40 - abserr = error - result = res - 40 continue -c -c shift the table. -c - 50 if(n.eq.limexp) n = 2*(limexp/2)-1 - ib = 1 - if((num/2)*2.eq.num) ib = 2 - ie = newelm+1 - do 60 i=1,ie - ib2 = ib+2 - epstab(ib) = epstab(ib2) - ib = ib2 - 60 continue - if(num.eq.n) go to 80 - indx = num-n+1 - do 70 i = 1,n - epstab(i)= epstab(indx) - indx = indx+1 - 70 continue - 80 if(nres.ge.4) go to 90 - res3la(nres) = result - abserr = oflow - go to 100 -c -c compute error estimate -c - 90 abserr = abs(result-res3la(3))+abs(result-res3la(2)) - * +abs(result-res3la(1)) - res3la(1) = res3la(2) - res3la(2) = res3la(3) - res3la(3) = result - 100 abserr = amax1(abserr,0.5e+01*epmach*abs(result)) - return - end
--- a/liboctave/cruft/quadpack/qk15i.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,202 +0,0 @@ - subroutine qk15i(f,boun,inf,a,b,result,abserr,resabs,resasc,ierr) -c***begin prologue qk15i -c***date written 800101 (yymmdd) -c***revision date 830518 (yymmdd) -c***category no. h2a3a2,h2a4a2 -c***keywords 15-point transformed gauss-kronrod rules -c***author piessens,robert,appl. math. & progr. div. - k.u.leuven -c de doncker,elise,appl. math. & progr. div. - k.u.leuven -c***purpose the original (infinite integration range is mapped -c onto the interval (0,1) and (a,b) is a part of (0,1). -c it is the purpose to compute -c i = integral of transformed integrand over (a,b), -c j = integral of abs(transformed integrand) over (a,b). -c***description -c -c integration rule -c standard fortran subroutine -c real version -c -c parameters -c on entry -c f - subroutine f(x,ierr,result) defining the integrand -c function f(x). the actual name for f needs to be -c declared e x t e r n a l in the calling program. -c -c boun - real -c finite bound of original integration -c range (set to zero if inf = +2) -c -c inf - integer -c if inf = -1, the original interval is -c (-infinity,bound), -c if inf = +1, the original interval is -c (bound,+infinity), -c if inf = +2, the original interval is -c (-infinity,+infinity) and -c the integral is computed as the sum of two -c integrals, one over (-infinity,0) and one over -c (0,+infinity). -c -c a - real -c lower limit for integration over subrange -c of (0,1) -c -c b - real -c upper limit for integration over subrange -c of (0,1) -c -c on return -c result - real -c approximation to the integral i -c result is computed by applying the 15-point -c kronrod rule(resk) obtained by optimal addition -c of abscissae to the 7-point gauss rule(resg). -c -c abserr - real -c estimate of the modulus of the absolute error, -c which should equal or exceed abs(i-result) -c -c resabs - real -c approximation to the integral j -c -c resasc - real -c approximation to the integral of -c abs((transformed integrand)-i/(b-a)) over (a,b) -c -c***references (none) -c***routines called r1mach -c***end prologue qk15i -c - real a,absc,absc1,absc2,abserr,b,boun,centr, - * dinf,r1mach,epmach,fc,fsum,fval1,fval2,fvalt,fv1, - * fv2,hlgth,resabs,resasc,resg,resk,reskh,result,tabsc1,tabsc2, - * uflow,wg,wgk,xgk - integer inf,j,min0 - external f -c - dimension fv1(7),fv2(7),xgk(8),wgk(8),wg(8) -c -c the abscissae and weights are supplied for the interval -c (-1,1). because of symmetry only the positive abscissae and -c their corresponding weights are given. -c -c xgk - abscissae of the 15-point kronrod rule -c xgk(2), xgk(4), ... abscissae of the 7-point -c gauss rule -c xgk(1), xgk(3), ... abscissae which are optimally -c added to the 7-point gauss rule -c -c wgk - weights of the 15-point kronrod rule -c -c wg - weights of the 7-point gauss rule, corresponding -c to the abscissae xgk(2), xgk(4), ... -c wg(1), wg(3), ... are set to zero. -c - data xgk(1),xgk(2),xgk(3),xgk(4),xgk(5),xgk(6),xgk(7), - * xgk(8)/ - * 0.9914553711208126e+00, 0.9491079123427585e+00, - * 0.8648644233597691e+00, 0.7415311855993944e+00, - * 0.5860872354676911e+00, 0.4058451513773972e+00, - * 0.2077849550078985e+00, 0.0000000000000000e+00/ -c - data wgk(1),wgk(2),wgk(3),wgk(4),wgk(5),wgk(6),wgk(7), - * wgk(8)/ - * 0.2293532201052922e-01, 0.6309209262997855e-01, - * 0.1047900103222502e+00, 0.1406532597155259e+00, - * 0.1690047266392679e+00, 0.1903505780647854e+00, - * 0.2044329400752989e+00, 0.2094821410847278e+00/ -c - data wg(1),wg(2),wg(3),wg(4),wg(5),wg(6),wg(7),wg(8)/ - * 0.0000000000000000e+00, 0.1294849661688697e+00, - * 0.0000000000000000e+00, 0.2797053914892767e+00, - * 0.0000000000000000e+00, 0.3818300505051189e+00, - * 0.0000000000000000e+00, 0.4179591836734694e+00/ -c -c -c list of major variables -c ----------------------- -c -c centr - mid point of the interval -c hlgth - half-length of the interval -c absc* - abscissa -c tabsc* - transformed abscissa -c fval* - function value -c resg - result of the 7-point gauss formula -c resk - result of the 15-point kronrod formula -c reskh - approximation to the mean value of the transformed -c integrand over (a,b), i.e. to i/(b-a) -c -c machine dependent constants -c --------------------------- -c -c epmach is the largest relative spacing. -c uflow is the smallest positive magnitude. -c -c***first executable statement qk15i - epmach = r1mach(4) - uflow = r1mach(1) - dinf = min0(1,inf) -c - centr = 0.5e+00*(a+b) - hlgth = 0.5e+00*(b-a) - tabsc1 = boun+dinf*(0.1e+01-centr)/centr - call f(tabsc1, ierr, fval1) - if (ierr.lt.0) return - if(inf.eq.2) then - call f(-tabsc1, ierr, fval1) - if (ierr.lt.0) return - fval1 = fval1 + fvalt - endif - fc = (fval1/centr)/centr -c -c compute the 15-point kronrod approximation to -c the integral, and estimate the error. -c - resg = wg(8)*fc - resk = wgk(8)*fc - resabs = abs(resk) - do 10 j=1,7 - absc = hlgth*xgk(j) - absc1 = centr-absc - absc2 = centr+absc - tabsc1 = boun+dinf*(0.1e+01-absc1)/absc1 - tabsc2 = boun+dinf*(0.1e+01-absc2)/absc2 - call f(tabsc1, ierr, fval1) - if (ierr.lt.0) return - call f(tabsc2, ierr, fval2) - if (ierr.lt.0) return - if(inf.eq.2) then - call f(-tabsc1,ierr,fvalt) - if (ierr.lt.0) return - fval1 = fval1 + fvalt - endif - if(inf.eq.2) then - call f(-tabsc2,ierr,fvalt) - if (ierr.lt.0) return - fval2 = fval2 + fvalt - endif - fval1 = (fval1/absc1)/absc1 - fval2 = (fval2/absc2)/absc2 - fv1(j) = fval1 - fv2(j) = fval2 - fsum = fval1+fval2 - resg = resg+wg(j)*fsum - resk = resk+wgk(j)*fsum - resabs = resabs+wgk(j)*(abs(fval1)+abs(fval2)) - 10 continue - reskh = resk*0.5e+00 - resasc = wgk(8)*abs(fc-reskh) - do 20 j=1,7 - resasc = resasc+wgk(j)*(abs(fv1(j)-reskh)+abs(fv2(j)-reskh)) - 20 continue - result = resk*hlgth - resasc = resasc*hlgth - resabs = resabs*hlgth - abserr = abs((resk-resg)*hlgth) - if(resasc.ne.0.0e+00.and.abserr.ne.0.e0) abserr = resasc* - * amin1(0.1e+01,(0.2e+03*abserr/resasc)**1.5e+00) - if(resabs.gt.uflow/(0.5e+02*epmach)) abserr = amax1 - * ((epmach*0.5e+02)*resabs,abserr) - return - end
--- a/liboctave/cruft/quadpack/qk21.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,175 +0,0 @@ - subroutine qk21(f,a,b,result,abserr,resabs,resasc,ierr) -c***begin prologue qk21 -c***date written 800101 (yymmdd) -c***revision date 830518 (yymmdd) -c***category no. h2a1a2 -c***keywords 21-point gauss-kronrod rules -c***author piessens,robert,appl. math. & progr. div. - k.u.leuven -c de doncker,elise,appl. math. & progr. div. - k.u.leuven -c***purpose to compute i = integral of f over (a,b), with error -c estimate -c j = integral of abs(f) over (a,b) -c***description -c -c integration rules -c standard fortran subroutine -c real version -c -c parameters -c on entry -c f - subroutine f(x,ierr,result) defining the integrand -c function f(x). the actual name for f needs to be -c declared e x t e r n a l in the driver program. -c -c a - real -c lower limit of integration -c -c b - real -c upper limit of integration -c -c on return -c result - real -c approximation to the integral i -c result is computed by applying the 21-point -c kronrod rule (resk) obtained by optimal addition -c of abscissae to the 10-point gauss rule (resg). -c -c abserr - real -c estimate of the modulus of the absolute error, -c which should not exceed abs(i-result) -c -c resabs - real -c approximation to the integral j -c -c resasc - real -c approximation to the integral of abs(f-i/(b-a)) -c over (a,b) -c -c***references (none) -c***routines called r1mach -c***end prologue qk21 -c - real a,absc,abserr,b,centr,dhlgth,epmach,fc,fsum,fval1,fval2, - * fv1,fv2,hlgth,resabs,resg,resk,reskh,result,r1mach,uflow,wg,wgk, - * xgk - integer j,jtw,jtwm1 - external f -c - dimension fv1(10),fv2(10),wg(5),wgk(11),xgk(11) -c -c the abscissae and weights are given for the interval (-1,1). -c because of symmetry only the positive abscissae and their -c corresponding weights are given. -c -c xgk - abscissae of the 21-point kronrod rule -c xgk(2), xgk(4), ... abscissae of the 10-point -c gauss rule -c xgk(1), xgk(3), ... abscissae which are optimally -c added to the 10-point gauss rule -c -c wgk - weights of the 21-point kronrod rule -c -c wg - weights of the 10-point gauss rule -c - data xgk(1),xgk(2),xgk(3),xgk(4),xgk(5),xgk(6),xgk(7), - * xgk(8),xgk(9),xgk(10),xgk(11)/ - * 0.9956571630258081e+00, 0.9739065285171717e+00, - * 0.9301574913557082e+00, 0.8650633666889845e+00, - * 0.7808177265864169e+00, 0.6794095682990244e+00, - * 0.5627571346686047e+00, 0.4333953941292472e+00, - * 0.2943928627014602e+00, 0.1488743389816312e+00, - * 0.0000000000000000e+00/ -c - data wgk(1),wgk(2),wgk(3),wgk(4),wgk(5),wgk(6),wgk(7), - * wgk(8),wgk(9),wgk(10),wgk(11)/ - * 0.1169463886737187e-01, 0.3255816230796473e-01, - * 0.5475589657435200e-01, 0.7503967481091995e-01, - * 0.9312545458369761e-01, 0.1093871588022976e+00, - * 0.1234919762620659e+00, 0.1347092173114733e+00, - * 0.1427759385770601e+00, 0.1477391049013385e+00, - * 0.1494455540029169e+00/ -c - data wg(1),wg(2),wg(3),wg(4),wg(5)/ - * 0.6667134430868814e-01, 0.1494513491505806e+00, - * 0.2190863625159820e+00, 0.2692667193099964e+00, - * 0.2955242247147529e+00/ -c -c -c list of major variables -c ----------------------- -c -c centr - mid point of the interval -c hlgth - half-length of the interval -c absc - abscissa -c fval* - function value -c resg - result of the 10-point gauss formula -c resk - result of the 21-point kronrod formula -c reskh - approximation to the mean value of f over (a,b), -c i.e. to i/(b-a) -c -c -c machine dependent constants -c --------------------------- -c -c epmach is the largest relative spacing. -c uflow is the smallest positive magnitude. -c -c***first executable statement qk21 - epmach = r1mach(4) - uflow = r1mach(1) -c - centr = 0.5e+00*(a+b) - hlgth = 0.5e+00*(b-a) - dhlgth = abs(hlgth) -c -c compute the 21-point kronrod approximation to -c the integral, and estimate the absolute error. -c - resg = 0.0e+00 - call f(centr, ierr, fc) - if (ierr .lt. 0) return - resk = wgk(11)*fc - resabs = abs(resk) - do 10 j=1,5 - jtw = 2*j - absc = hlgth*xgk(jtw) - call f(centr-absc,ierr,fval1) - if (ierr .lt. 0) return - call f(centr+absc,ierr,fval2) - if (ierr .lt. 0) return - fv1(jtw) = fval1 - fv2(jtw) = fval2 - fsum = fval1+fval2 - resg = resg+wg(j)*fsum - resk = resk+wgk(jtw)*fsum - resabs = resabs+wgk(jtw)*(abs(fval1)+abs(fval2)) - 10 continue - do 15 j = 1,5 - jtwm1 = 2*j-1 - absc = hlgth*xgk(jtwm1) - call f(centr-absc,ierr,fval1) - if (ierr .lt. 0) return - call f(centr+absc,ierr,fval2) - if (ierr .lt. 0) return - fv1(jtwm1) = fval1 - fv2(jtwm1) = fval2 - fsum = fval1+fval2 - resk = resk+wgk(jtwm1)*fsum - resabs = resabs+wgk(jtwm1)*(abs(fval1)+abs(fval2)) - 15 continue - reskh = resk*0.5e+00 - resasc = wgk(11)*abs(fc-reskh) - do 20 j=1,10 - resasc = resasc+wgk(j)*(abs(fv1(j)-reskh)+abs(fv2(j)-reskh)) - 20 continue - result = resk*hlgth - resabs = resabs*dhlgth - resasc = resasc*dhlgth - abserr = abs((resk-resg)*hlgth) - if(resasc.ne.0.0e+00.and.abserr.ne.0.0e+00) - * abserr = resasc*amin1(0.1e+01, - * (0.2e+03*abserr/resasc)**1.5e+00) - if(resabs.gt.uflow/(0.5e+02*epmach)) abserr = amax1 - * ((epmach*0.5e+02)*resabs,abserr) - return - end
--- a/liboctave/cruft/quadpack/qpsrt.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,136 +0,0 @@ - subroutine qpsrt(limit,last,maxerr,ermax,elist,iord,nrmax) -c***begin prologue qpsrt -c***refer to qage,qagie,qagpe,qagse,qawce,qawse,qawoe -c***routines called (none) -c***keywords sequential sorting -c***description -c -c 1. qpsrt -c ordering routine -c standard fortran subroutine -c real version -c -c 2. purpose -c this routine maintains the descending ordering -c in the list of the local error estimates resulting from -c the interval subdivision process. at each call two error -c estimates are inserted using the sequential search -c method, top-down for the largest error estimate -c and bottom-up for the smallest error estimate. -c -c 3. calling sequence -c call qpsrt(limit,last,maxerr,ermax,elist,iord,nrmax) -c -c parameters (meaning at output) -c limit - integer -c maximum number of error estimates the list -c can contain -c -c last - integer -c number of error estimates currently -c in the list -c -c maxerr - integer -c maxerr points to the nrmax-th largest error -c estimate currently in the list -c -c ermax - real -c nrmax-th largest error estimate -c ermax = elist(maxerr) -c -c elist - real -c vector of dimension last containing -c the error estimates -c -c iord - integer -c vector of dimension last, the first k -c elements of which contain pointers -c to the error estimates, such that -c elist(iord(1)),... , elist(iord(k)) -c form a decreasing sequence, with -c k = last if last.le.(limit/2+2), and -c k = limit+1-last otherwise -c -c nrmax - integer -c maxerr = iord(nrmax) -c -c 4. no subroutines or functions needed -c***end prologue qpsrt -c - real elist,ermax,errmax,errmin - integer i,ibeg,ido,iord,isucc,j,jbnd,jupbn,k,last,limit,maxerr, - * nrmax - dimension elist(last),iord(last) -c -c check whether the list contains more than -c two error estimates. -c -c***first executable statement qpsrt - if(last.gt.2) go to 10 - iord(1) = 1 - iord(2) = 2 - go to 90 -c -c this part of the routine is only executed -c if, due to a difficult integrand, subdivision -c increased the error estimate. in the normal case -c the insert procedure should start after the -c nrmax-th largest error estimate. -c - 10 errmax = elist(maxerr) - if(nrmax.eq.1) go to 30 - ido = nrmax-1 - do 20 i = 1,ido - isucc = iord(nrmax-1) -c ***jump out of do-loop - if(errmax.le.elist(isucc)) go to 30 - iord(nrmax) = isucc - nrmax = nrmax-1 - 20 continue -c -c compute the number of elements in the list to -c be maintained in descending order. this number -c depends on the number of subdivisions still -c allowed. -c - 30 jupbn = last - if(last.gt.(limit/2+2)) jupbn = limit+3-last - errmin = elist(last) -c -c insert errmax by traversing the list top-down, -c starting comparison from the element elist(iord(nrmax+1)). -c - jbnd = jupbn-1 - ibeg = nrmax+1 - if(ibeg.gt.jbnd) go to 50 - do 40 i=ibeg,jbnd - isucc = iord(i) -c ***jump out of do-loop - if(errmax.ge.elist(isucc)) go to 60 - iord(i-1) = isucc - 40 continue - 50 iord(jbnd) = maxerr - iord(jupbn) = last - go to 90 -c -c insert errmin by traversing the list bottom-up. -c - 60 iord(i-1) = maxerr - k = jbnd - do 70 j=i,jbnd - isucc = iord(k) -c ***jump out of do-loop - if(errmin.lt.elist(isucc)) go to 80 - iord(k+1) = isucc - k = k-1 - 70 continue - iord(i) = last - go to 90 - 80 iord(k+1) = last -c -c set maxerr and ermax. -c - 90 maxerr = iord(nrmax) - ermax = elist(maxerr) - return - end
--- a/liboctave/cruft/quadpack/xerror.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,39 +0,0 @@ - SUBROUTINE XERROR(MESSG,NMESSG,NERR,LEVEL) -C -C ABSTRACT -C XERROR PROCESSES A DIAGNOSTIC MESSAGE, IN A MANNER -C DETERMINED BY THE VALUE OF LEVEL AND THE CURRENT VALUE -C OF THE LIBRARY ERROR CONTROL FLAG, KONTRL. -C (SEE SUBROUTINE XSETF FOR DETAILS.) -C -C DESCRIPTION OF PARAMETERS -C --INPUT-- -C MESSG - THE HOLLERITH MESSAGE TO BE PROCESSED, CONTAINING -C NO MORE THAN 72 CHARACTERS. -C NMESSG- THE ACTUAL NUMBER OF CHARACTERS IN MESSG. -C NERR - THE ERROR NUMBER ASSOCIATED WITH THIS MESSAGE. -C NERR MUST NOT BE ZERO. -C LEVEL - ERROR CATEGORY. -C =2 MEANS THIS IS AN UNCONDITIONALLY FATAL ERROR. -C =1 MEANS THIS IS A RECOVERABLE ERROR. (I.E., IT IS -C NON-FATAL IF XSETF HAS BEEN APPROPRIATELY CALLED.) -C =0 MEANS THIS IS A WARNING MESSAGE ONLY. -C =-1 MEANS THIS IS A WARNING MESSAGE WHICH IS TO BE -C PRINTED AT MOST ONCE, REGARDLESS OF HOW MANY -C TIMES THIS CALL IS EXECUTED. -C -C EXAMPLES -C CALL XERROR(23HSMOOTH -- NUM WAS ZERO.,23,1,2) -C CALL XERROR(43HINTEG -- LESS THAN FULL ACCURACY ACHIEVED., -C 43,2,1) -C CALL XERROR(65HROOTER -- ACTUAL ZERO OF F FOUND BEFORE INTERVAL -C 1 FULLY COLLAPSED.,65,3,0) -C CALL XERROR(39HEXP -- UNDERFLOWS BEING SET TO ZERO.,39,1,-1) -C -C WRITTEN BY RON JONES, WITH SLATEC COMMON MATH LIBRARY SUBCOMMITTEE -C LATEST REVISION --- 7 FEB 1979 -C - DIMENSION MESSG(NMESSG) - CALL XERRWD(MESSG,NMESSG,NERR,LEVEL,0,0,0,0,0.,0.) - RETURN - END
--- a/liboctave/cruft/ranlib/Basegen.doc Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,382 +0,0 @@ - - - - - - - - - - - - RANDLIB - - Library of Fortran Routines for Random Number Generation - - - - - - - - - Base Generator Documentation - - - - - - - - - Compiled and Written by: - - Barry W. Brown - James Lovato - - - - - - - - - - - Department of Biomathematics, Box 237 - The University of Texas, M.D. Anderson Cancer Center - 1515 Holcombe Boulevard - Houston, TX 77030 - - - This work was supported by grant CA-16672 from the National Cancer Institute. - - - - - Base Random Number Generator - - - -I. OVERVIEW AND DEFAULT BEHAVIOR - -This set of programs contains 32 virtual random number generators. -Each generator can provide 1,048,576 blocks of numbers, and each block -is of length 1,073,741,824. Any generator can be set to the beginning -or end of the current block or to its starting value. The methods are -from the paper cited immediately below, and most of the code is a -transliteration from the Pascal of the paper into Fortran. - -P. L'Ecuyer and S. Cote. Implementing a Random Number Package with -Splitting Facilities. ACM Transactions on Mathematical Software 17:1, -pp 98-111. - -Most users won't need the sophisticated capabilities of this package, -and will desire a single generator. This single generator (which will -have a non-repeating length of 2.3 X 10^18 numbers) is the default. -In order to accommodate this use, the concept of the current generator -is added to those of the cited paper; references to a generator are -always to the current generator. The current generator is initially -generator number 1; it can be changed by SETCGN, and the ordinal -number of the current generator can be obtained from GETCGN. - -The user of the default can set the initial values of the two integer -seeds with SETALL. If the user does not set the seeds, the random -number generation will use the default values, 1234567890 and -123456789. The values of the current seeds can be achieved by a call -to GETSD. Random number may be obtained as integers ranging from 1 to -a large integer by reference to function IGNLGI or as a floating point -number between 0 and 1 by a reference to function RANF. These are the -only routines needed by a user desiring a single stream of random -numbers. - -II. CONCEPTS - -A stream of pseudo-random numbers is a sequence, each member of which -can be obtained either as an integer in the range 1..2,147,483,563 or -as a floating point number in the range [0..1]. The user is in charge -of which representation is desired. - -The method contains an algorithm for generating a stream with a very -long period, 2.3 X 10^18. This stream in partitioned into G (=32) -virtual generators. Each virtual generator contains 2^20 (=1,048,576) -blocks of non-overlapping random numbers. Each block is 2^30 -(=1,073,741,824) in length. - - - -Base Random Number Generator Page 2 - - -The state of a generator is determined by two integers called seeds. -The seeds can be initialized by the user; the initial values of the -first must lie between 1 and 2,147,483,562, that of the second between -1 and 2,147,483,398. Each time a number is generated, the values of -the seeds change. Three values of seeds are remembered by the -generators at all times: the value with which the generator was -initialized, the value at the beginning of the current block, and the -value at the beginning of the next block. The seeds of any generator -can be set to any of these three values at any time. - - Of the 32 virtual generators, exactly one will be the current -generator, i.e., that one will be used to generate values for IGNLGI -and RANDF. Initially, the current generator is set to number one. -The current generator may be changed by calling SETCGN, and the number -of the current generator can be obtained using GETCGN. - -III. AN EXAMPLE - -An example of the need for these capabilities is as follows. Two -statistical techniques are being compared on data of different sizes. -The first technique uses bootstrapping and is thought to be as -accurate using less data than the second method which employs only -brute force. - -For the first method, a data set of size uniformly distributed between -25 and 50 will be generated. Then the data set of the specified size -will be generated and alalyzed. The second method will choose a data -set size between 100 and 200, generate the data and alalyze it. This -process will be repeated 1000 times. - -For variance reduction, we want the random numbers used in the two -methods to be the same for each of the 1000 comparisons. But method -two will use more random numbers than method one and without this -package, synchronization might be difficult. - -With the package, it is a snap. Use generator 1 to obtain the sample -size for method one and generator 2 to obtain the data. Then reset -the state to the beginning of the current block and do the same for -the second method. This assures that the initial data for method two -is that used by method one. When both have concluded, advance the -block for both generators. - -IV. THE INTERFACE - -A random number is obtained either as a random integer between 1 and -2,147,483,562 by invoking integer function IGNLGI (I GeNerate LarGe -Integer) or as a random floating point number between 0 and 1 by -invoking real function RANF. Neither function has arguments. - -The seed of the first generator can be set by invoking subroutine -SETALL; the values of the seeds of the other 31 generators are -calculated from this value. - - - -Base Random Number Generator Page 3 - - -The number of the current generator can be set by calling subroutine -SETCGN, which takes a single argument, the integer generator number in -the range 1..32. The number of the current generator can be obtained -by invoking subroutine GETCGN which returns the number in its single -integer argument. - - -V. CALLING SEQUENCES - - A. SETTING THE SEED OF ALL GENERATORS - -C********************************************************************** -C -C SUBROUTINE SETALL(ISEED1,ISEED2) -C SET ALL random number generators -C -C Sets the initial seed of generator 1 to ISEED1 and ISEED2. The -C initial seeds of the other generators are set accordingly, and -C all generators states are set to these seeds. -C -C Arguments -C -C -C ISEED1 -> First of two integer seeds -C INTEGER ISEED1 -C -C ISEED2 -> Second of two integer seeds -C INTEGER ISEED1 -C -C********************************************************************** - - - B. OBTAINING RANDOM NUMBERS - -C********************************************************************** -C -C INTEGER FUNCTION IGNLGI() -C GeNerate LarGe Integer -C -C Returns a random integer following a uniform distribution over -C (1, 2147483562) using the current generator. -C -C********************************************************************** - -C********************************************************************** -C -C REAL FUNCTION RANF() -C RANDom number generator as a Function -C -C Returns a random floating point number from a uniform distribution -C over 0 - 1 (endpoints of this interval are not returned) using the -C current generator -C -C********************************************************************** - - - -Base Random Number Generator Page 4 - - - C. SETTING AND OBTAINING THE NUMBER OF THE CURRENT GENERATOR - -C********************************************************************** -C -C SUBROUTINE SETCGN( G ) -C Set GeNerator -C -C Sets the current generator to G. All references to a generator -C are to the current generator. -C -C Arguments -C -C G --> Number of the current random number generator (1..32) -C INTEGER G -C -C********************************************************************** - -C********************************************************************** -C -C SUBROUTINE GETCGN(G) -C Get GeNerator -C -C Returns in G the number of the current random number generator -C -C Arguments -C -C G <-- Number of the current random number generator (1..32) -C INTEGER G -C -C********************************************************************** - - D. OBTAINING OR CHANGING SEEDS IN CURRENT GENERATOR - -C********************************************************************** -C -C SUBROUTINE ADVNST(K) -C ADV-a-N-ce ST-ate -C -C Advances the state of the current generator by 2^K values and -C resets the initial seed to that value. -C -C Arguments -C -C -C K -> The generator is advanced by 2^K values -C INTEGER K -C -C********************************************************************** - - - -Base Random Number Generator Page 5 - - -C********************************************************************** -C -C SUBROUTINE GETSD(ISEED1,ISEED2) -C GET SeeD -C -C Returns the value of two integer seeds of the current generator -C -C Arguments -C -C -C -C ISEED1 <- First integer seed of generator G -C INTEGER ISEED1 -C -C ISEED2 <- Second integer seed of generator G -C INTEGER ISEED1 -C -C********************************************************************** - -C********************************************************************** -C -C SUBROUTINE INITGN(ISDTYP) -C INIT-ialize current G-e-N-erator -C -C Reinitializes the state of the current generator -C -C Arguments -C -C -C ISDTYP -> The state to which the generator is to be set -C ISDTYP = -1 => sets the seeds to their initial value -C ISDTYP = 0 => sets the seeds to the first value of -C the current block -C ISDTYP = 1 => sets the seeds to the first value of -C the next block -C -C INTEGER ISDTYP -C -C********************************************************************** - -C********************************************************************** -C -C SUBROUTINE SETSD(ISEED1,ISEED2) -C SET S-ee-D of current generator -C -C Resets the initial seed of the current generator to ISEED1 and -C ISEED2. The seeds of the other generators remain unchanged. -C -C Arguments -C -C -C ISEED1 -> First integer seed -C INTEGER ISEED1 -C -C ISEED2 -> Second integer seed -C INTEGER ISEED1 -C -C********************************************************************** - - - -Base Random Number Generator Page 6 - - - E. MISCELLANY - -C********************************************************************** -C -C INTEGER FUNCTION MLTMOD(A,S,M) -C -C Returns (A*S) MOD M -C -C Arguments -C -C -C A, S, M --> -C INTEGER A,S,M -C -C********************************************************************** - -C********************************************************************** -C -C SUBROUTINE SETANT(QVALUE) -C SET ANTithetic -C -C Sets whether the current generator produces antithetic values. If -C X is the value normally returned from a uniform [0,1] random -C number generator then 1 - X is the antithetic value. If X is the -C value normally returned from a uniform [0,N] random number -C generator then N - 1 - X is the antithetic value. -C -C All generators are initialized to NOT generate antithetic values. -C -C Arguments -C -C QVALUE -> .TRUE. if generator G is to generating antithetic -C values, otherwise .FALSE. -C LOGICAL QVALUE -C -C**********************************************************************
--- a/liboctave/cruft/ranlib/HOWTOGET Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,31 +0,0 @@ - - WHERE TO GET IT - - Software written by members of the section is freely available to - anyone. Reposting on other archives is encouraged. The code is - furnished in source form and as DOS and Macintosh executables. Readers - with Internet access and a browser might note the following web site - addresses: - - University of Texas M. D. Anderson Cancer Center Home Page: - http://utmdacc.mdacc.tmc.edu/ - - Department of Biomathematics Home Page: - http://odin.mdacc.tmc.edu/ - - - Available Software: - http://odin.mdacc.tmc.edu/anonftp/ - - - Our code can also be obtained by anonymous ftp to odin.mdacc.tmc.edu. - The index is on file ./pub/index. - - Our statistical code is also posted to statlib after some delay. - Statlib can be accessed at: - http://lib.stat.cmu.edu/ - See in particular: - http://lib.stat.cmu.edu/general/Utexas/ - - The code is also archived at many other sites (at their option). Use - your favorite search engine to find one close to you.
--- a/liboctave/cruft/ranlib/README Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,346 +0,0 @@ - - - - - - - - - - - - RANDLIB - - Library of Fortran Routines for Random Number Generation - - - Version 1.3 -- August, 1997 - - - - - README - - - - - - - - - Compiled and Written by: - - Barry W. Brown - James Lovato - Kathy Russell - John Venier - - - - - - - - - - Department of Biomathematics, Box 237 - The University of Texas, M.D. Anderson Cancer Center - 1515 Holcombe Boulevard - Houston, TX 77030 - - - This work was supported by grant CA-16672 from the National Cancer Institute. - - - - THANKS TO OUR SUPPORTERS - -This work was supported in part by grant CA-16672 from the National -Cancer Institute. We are grateful to Larry and Pat McNeil of Corpus -Cristi for their generous support. Some equipment used in this effort -was provided by IBM as part of a cooperative study agreement; we thank -them. - - - SUMMARY OF RANDLIB - -The bottom level routines provide 32 virtual random number generators. -Each generator can provide 1,048,576 blocks of numbers, and each block -is of length 1,073,741,824. Any generator can be set to the beginning -or end of the current block or to its starting value. Packaging is -provided so that if these capabilities are not needed, a single -generator with period 2.3 X 10^18 is seen. - -Using this base, routines are provided that return: - (1) Beta random deviates - (2) Chi-square random deviates - (3) Exponential random deviates - (4) F random deviates - (5) Gamma random deviates - (6) Multivariate normal random deviates (mean and covariance - matrix specified) - (7) Noncentral chi-square random deviates - (8) Noncentral F random deviates - (9) Univariate normal random deviates - (10) Random permutations of an integer array - (11) Real uniform random deviates between specified limits - (12) Binomial random deviates - (13) Negative Binomial random deviates - (14) Multinomial random deviates - (15) Poisson random deviates - (16) Integer uniform deviates between specified limits - (17) Seeds for the random number generator calculated from a - character string - - INSTALLATION - -Directory src contains the Fortran source. The Fortran code from this -directory should be compiled and placed in a library. Directory test -contains three test programs for this code. - - - - - - - DOCUMENTATION - -Documentation is on directory doc on the distribution. All of the -documentation is in the form of character (ASCII) files. An -explanation of the concepts involved in the base generator and details -of its implementation are contained in Basegen.doc. A summary of all -of the available routines is contained in randlib.chs (chs is an -abbreviation of 'cheat sheet'). The 'chs' file will probably be the -reference to randlib that is primarily used. The file, randlib.fdoc, -contains all comments heading each routine. There is somewhat more -information in 'fdoc' than 'chs', but the additional information -consists primarily of references to the literature. - - - - SOURCES - -The following routines, which were written by others and lightly -modified for consistency in packaging, are included in RANDLIB. - - Bottom Level Routines - -These routines are a transliteration of the Pascal in the reference to -Fortran. - -L'Ecuyer, P. and Cote, S. "Implementing a Random Number Package with -Splitting Facilities." ACM Transactions on Mathematical Software, -17:98-111 (1991) - - Exponential - -This code was obtained from Netlib. - -Ahrens, J.H. and Dieter, U. Computer Methods for Sampling From the -Exponential and Normal Distributions. Comm. ACM, 15,10 (Oct. 1972), -873 - 882. - - Gamma - -(Case R >= 1.0) - -Ahrens, J.H. and Dieter, U. Generating Gamma Variates by a Modified -Rejection Technique. Comm. ACM, 25,1 (Jan. 1982), 47 - 54. -Algorithm GD - -(Case 0.0 <= R <= 1.0) - -Ahrens, J.H. and Dieter, U. Computer Methods for Sampling from Gamma, -Beta, Poisson and Binomial Distributions. Computing, 12 (1974), -223-246. Adaptation of algorithm GS. - - - - - - - Normal - -This code was obtained from netlib. - -Ahrens, J.H. and Dieter, U. Extensions of Forsythe's Method for -Random Sampling from the Normal Distribution. Math. Comput., 27,124 -(Oct. 1973), 927 - 937. - - Binomial - -This code was kindly sent me by Dr. Kachitvichyanukul. - -Kachitvichyanukul, V. and Schmeiser, B. W. Binomial Random Variate -Generation. Communications of the ACM, 31, 2 (February, 1988) 216. - - - Poisson - -This code was obtained from netlib. - -Ahrens, J.H. and Dieter, U. Computer Generation of Poisson Deviates -From Modified Normal Distributions. ACM Trans. Math. Software, 8, 2 -(June 1982),163-179 - - Beta - -This code was written by us following the recipe in the following. - -R. C. H. Cheng Generating Beta Variables with Nonintegral Shape -Parameters. Communications of the ACM, 21:317-322 (1978) (Algorithms -BB and BC) - - Linpack - -Routines SPOFA and SDOT are used to perform the Cholesky decomposition -of the covariance matrix in SETGMN (used for the generation of -multivariate normal deviates). - -Dongarra, J. J., Moler, C. B., Bunch, J. R. and Stewart, G. W. -Linpack User's Guide. SIAM Press, Philadelphia. (1979) - - - - - LEGALITIES - -Code that appeared in an ACM publication is subject to their -algorithms policy: - - Submittal of an algorithm for publication in one of the ACM - Transactions implies that unrestricted use of the algorithm within a - computer is permissible. General permission to copy and distribute - the algorithm without fee is granted provided that the copies are not - made or distributed for direct commercial advantage. The ACM - copyright notice and the title of the publication and its date appear, - and notice is given that copying is by permission of the Association - for Computing Machinery. To copy otherwise, or to republish, requires - a fee and/or specific permission. - - Krogh, F. Algorithms Policy. ACM Tran. Math. Softw. 13(1987), - 183-186. - -We place the Randlib code that we have written in the public domain. - - NO WARRANTY - - WE PROVIDE ABSOLUTELY NO WARRANTY OF ANY KIND EITHER EXPRESSED OR - IMPLIED, INCLUDING BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF - MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK - AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD - THIS PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY - SERVICING, REPAIR OR CORRECTION. - - IN NO EVENT SHALL THE UNIVERSITY OF TEXAS OR ANY OF ITS COMPONENT - INSTITUTIONS INCLUDING M. D. ANDERSON HOSPITAL BE LIABLE TO YOU FOR - DAMAGES, INCLUDING ANY LOST PROFITS, LOST MONIES, OR OTHER SPECIAL, - INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR - INABILITY TO USE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA OR - ITS ANALYSIS BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY THIRD - PARTIES) THE PROGRAM. - - (Above NO WARRANTY modified from the GNU NO WARRANTY statement.) - - - - WHAT'S NEW IN VERSION 1.1? - - -Random number generation for the Negative Binomial and Multinomial -distributions has been included. - -Two errors in the code which generates random numbers from the Gamma -distribution were fixed. - - - WHAT'S NEW IN VERSION 1.2? - -We changed the name of the package from 'ranlib' to 'randlib'. This -was done so that we can determine who archives it. 'ranlib' is the -name of a Unix utility which produces many spurious hits on a web -search engine. - - -The linpack routines are now housed in the /src directory. - -In several routines, some variables were given an explicit SAVE -attribute and some dummy initial values were changed to prevent -potential errors. -'genbet.f' 'ignbin.f' 'ignpoi.f' 'phrtsd.f' 'sexpo.f' 'sgamma.f' -'snorm.f' - -In several routines, argument checking was implemented; the code now -breaks if inappropriate values are passed to it. -'genbet.f' A and B must be >= 1.0E-37 instead of 0.0 -'genexp.f' AV must be >= 0.0 -'gengam.f' A and R both must be > 0.0 -'gennor.f' SD must be >= 0.0 -'ignbin.f' N must be >= 0, and 0.0 <= PP <= 1.0. -'ignnbn.f' N must be > 0, 0.0 < P < 1.0 (previously allowed N = 0) -'ignpoi.f' MU must be >= 0.0 - -For the Non-Central Chi-Squared and Non-Central F distributions, the -case DF = 1.0 (DFN = 1.0 for the F) is now allowed. -'gennch.f' 'gennf.f' - -Wherever possible, the user-accessible code now calls the base -generators directly. This means improved performance and fewer -dependencies, but the routines should work exactly as before from the -user's point of view. -'genchi.f' 'genf.f' 'gennch.f' 'gennf.f' 'ignnbn.f' - -Many minor modifications have been made which should make the code -more robust, without changing how the code is used. -'genbet.f' 'gengam.f' 'ignpoi.f' 'ignuin.f' 'sgamma.f' 'tstmid.f' - -Finally, five distributions have been added to the mid-level tester, -which test the Exponential, Gamma, Multinomial, Negative Binomial, and -Normal distributions. -'tstmid.f' - - - - - WHAT'S NOT NEW IN VERSION 1.2 ? - -No calling sequences have changed. - - WHAT'S NEW IN VERSION 1.3? - -The calling sequence of SETGMN has been changed! We added an argument -(INTEGER LDCOVM) representing the leading actual dimension of COVM, to -allow the user to use this routine in the case that COVM is contained -in a larger array. This change also makes the routine more compatible -with LINPACK routines. See the following files for details: -'setgmn.f' in the /src directory, and 'randlib.fdoc' and 'randlib.chs' -in the /doc directory. - -Briefly, the declaration of SETGMN has been changed -from: - SUBROUTINE setgmn(meanv,covm,p,parm) -to: - SUBROUTINE setgmn(meanv,covm,ldcovm,p,parm) - -The program 'tstgmn.f' (in the /test directory) was changed to reflect -the change in the calling sequence of SETGMN. - -'randlib.fdoc' and 'randlib.chs' in the /doc directory were changed to -relect the change in the calling sequence of SETGMN. - -Minor changes were made in two routines ('sgamma.f' and 'sexpo.f') to -fix unusual bugs. - -The protection from overflow in deviate generation in two routines -('genf.f' and 'gennf.f') was changed to prevent a constant from -underflowing at compile time. - - WHAT'S NOT NEW IN VERSION 1.3 ? - -No calling sequences (other than SETGMN) have changed. - - MANY THANKS - -The authors would like to thank the many users who have reported bugs -and suggested improvements; Randlib would not be the same today -without them. We heartily encourage others to join them.
--- a/liboctave/cruft/ranlib/advnst.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,80 +0,0 @@ - SUBROUTINE advnst(k) -C********************************************************************** -C -C SUBROUTINE ADVNST(K) -C ADV-a-N-ce ST-ate -C -C Advances the state of the current generator by 2^K values and -C resets the initial seed to that value. -C -C This is a transcription from Pascal to Fortran of routine -C Advance_State from the paper -C -C L'Ecuyer, P. and Cote, S. "Implementing a Random Number Package -C with Splitting Facilities." ACM Transactions on Mathematical -C Software, 17:98-111 (1991) -C -C -C Arguments -C -C -C K -> The generator is advanced by2^K values -C INTEGER K -C -C********************************************************************** -C .. Parameters .. - INTEGER numg - PARAMETER (numg=32) -C .. -C .. Scalar Arguments .. - INTEGER k -C .. -C .. Scalars in Common .. - INTEGER a1,a1vw,a1w,a2,a2vw,a2w,m1,m2 -C .. -C .. Arrays in Common .. - INTEGER cg1(numg),cg2(numg),ig1(numg),ig2(numg),lg1(numg), - + lg2(numg) - LOGICAL qanti(numg) -C .. -C .. Local Scalars .. - INTEGER g,i,ib1,ib2 -C .. -C .. External Functions .. - INTEGER mltmod - LOGICAL qrgnin - EXTERNAL mltmod,qrgnin -C .. -C .. External Subroutines .. - EXTERNAL getcgn,setsd -C .. -C .. Common blocks .. - COMMON /globe/m1,m2,a1,a2,a1w,a2w,a1vw,a2vw,ig1,ig2,lg1,lg2,cg1, - + cg2,qanti -C .. -C .. Save statement .. - SAVE /globe/ -C .. -C .. Executable Statements .. -C Abort unless random number generator initialized - IF (qrgnin()) GO TO 10 - WRITE (*,*) ' ADVNST called before random number generator ', - + ' initialized -- abort!' - CALL XSTOPX - + (' ADVNST called before random number generator initialized') - - 10 CALL getcgn(g) -C - ib1 = a1 - ib2 = a2 - DO 20,i = 1,k - ib1 = mltmod(ib1,ib1,m1) - ib2 = mltmod(ib2,ib2,m2) - 20 CONTINUE - CALL setsd(mltmod(ib1,cg1(g),m1),mltmod(ib2,cg2(g),m2)) -C -C NOW, IB1 = A1**K AND IB2 = A2**K -C - RETURN - - END
--- a/liboctave/cruft/ranlib/genbet.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,249 +0,0 @@ - REAL FUNCTION genbet(aa,bb) -C********************************************************************** -C -C REAL FUNCTION GENBET( A, B ) -C GeNerate BETa random deviate -C -C -C Function -C -C -C Returns a single random deviate from the beta distribution with -C parameters A and B. The density of the beta is -C x^(a-1) * (1-x)^(b-1) / B(a,b) for 0 < x < 1 -C -C -C Arguments -C -C -C A --> First parameter of the beta distribution -C REAL A -C JJV (A > 1.0E-37) -C -C B --> Second parameter of the beta distribution -C REAL B -C JJV (B > 1.0E-37) -C -C -C Method -C -C -C R. C. H. Cheng -C Generating Beta Variates with Nonintegral Shape Parameters -C Communications of the ACM, 21:317-322 (1978) -C (Algorithms BB and BC) -C -C********************************************************************** -C .. Parameters .. -C Close to the largest number that can be exponentiated - REAL expmax -C JJV changed this - 89 was too high, and LOG(1.0E38) = 87.49823 - PARAMETER (expmax=87.49823) -C Close to the largest representable single precision number - REAL infnty - PARAMETER (infnty=1.0E38) -C JJV added the parameter minlog -C Close to the smallest number of which a LOG can be taken. - REAL minlog - PARAMETER (minlog=1.0E-37) -C .. -C .. Scalar Arguments .. - REAL aa,bb -C .. -C .. Local Scalars .. - REAL a,alpha,b,beta,delta,gamma,k1,k2,olda,oldb,r,s,t,u1,u2,v,w,y, - + z - LOGICAL qsame -C .. -C .. External Functions .. - REAL ranf - EXTERNAL ranf -C .. -C .. Intrinsic Functions .. - INTRINSIC exp,log,max,min,sqrt -C .. -C .. Save statement .. -C JJV added a,b - SAVE olda,oldb,alpha,beta,gamma,k1,k2,a,b -C .. -C .. Data statements .. -C JJV changed these to ridiculous values - DATA olda,oldb/-1.0E37,-1.0E37/ -C .. -C .. Executable Statements .. - qsame = (olda.EQ.aa) .AND. (oldb.EQ.bb) - IF (qsame) GO TO 20 -C JJV added small minimum for small log problem in calc of W - IF (.NOT. (aa.LT.minlog.OR.bb.LT.minlog)) GO TO 10 - WRITE (*,*) ' AA or BB < ',minlog,' in GENBET - Abort!' - WRITE (*,*) ' AA: ',aa,' BB ',bb - CALL XSTOPX (' AA or BB too small in GENBET - Abort!') - - 10 olda = aa - oldb = bb - 20 IF (.NOT. (min(aa,bb).GT.1.0)) GO TO 100 - - -C Alborithm BB - -C -C Initialize -C - IF (qsame) GO TO 30 - a = min(aa,bb) - b = max(aa,bb) - alpha = a + b - beta = sqrt((alpha-2.0)/ (2.0*a*b-alpha)) - gamma = a + 1.0/beta - 30 CONTINUE - 40 u1 = ranf() -C -C Step 1 -C - u2 = ranf() - v = beta*log(u1/ (1.0-u1)) -C JJV altered this - IF (v.GT.expmax) GO TO 55 -C JJV added checker to see if a*exp(v) will overflow -C JJV 50 _was_ w = a*exp(v); also note here a > 1.0 - 50 w = exp(v) - IF (w.GT.infnty/a) GO TO 55 - w = a*w - GO TO 60 - 55 w = infnty - - 60 z = u1**2*u2 - r = gamma*v - 1.3862944 - s = a + r - w -C -C Step 2 -C - IF ((s+2.609438).GE. (5.0*z)) GO TO 70 -C -C Step 3 -C - t = log(z) - IF (s.GT.t) GO TO 70 -C -C Step 4 -C -C JJV added checker to see if log(alpha/(b+w)) will -C JJV overflow. If so, we count the log as -INF, and -C JJV consequently evaluate conditional as true, i.e. -C JJV the algorithm rejects the trial and starts over -C JJV May not need this here since ALPHA > 2.0 - IF (alpha/(b+w).LT.minlog) GO TO 40 - - IF ((r+alpha*log(alpha/ (b+w))).LT.t) GO TO 40 -C -C Step 5 -C - 70 IF (.NOT. (aa.EQ.a)) GO TO 80 - genbet = w/ (b+w) - GO TO 90 - - 80 genbet = b/ (b+w) - 90 GO TO 230 - - -C Algorithm BC - -C -C Initialize -C - 100 IF (qsame) GO TO 110 - a = max(aa,bb) - b = min(aa,bb) - alpha = a + b - beta = 1.0/b - delta = 1.0 + a - b - k1 = delta* (0.0138889+0.0416667*b)/ (a*beta-0.777778) - k2 = 0.25 + (0.5+0.25/delta)*b - 110 CONTINUE - 120 u1 = ranf() -C -C Step 1 -C - u2 = ranf() - IF (u1.GE.0.5) GO TO 130 -C -C Step 2 -C - y = u1*u2 - z = u1*y - IF ((0.25*u2+z-y).GE.k1) GO TO 120 - GO TO 170 -C -C Step 3 -C - 130 z = u1**2*u2 - IF (.NOT. (z.LE.0.25)) GO TO 160 - v = beta*log(u1/ (1.0-u1)) - -C JJV instead of checking v > expmax at top, I will check -C JJV if a < 1, then check the appropriate values - - IF (a.GT.1.0) GO TO 135 -C JJV A < 1 so it can help out if EXP(V) would overflow - IF (v.GT.expmax) GO TO 132 - w = a*exp(v) - GO TO 200 - 132 w = v + log(a) - IF (w.GT.expmax) GO TO 140 - w = exp(w) - GO TO 200 - -C JJV in this case A > 1 - 135 IF (v.GT.expmax) GO TO 140 - w = exp(v) - IF (w.GT.infnty/a) GO TO 140 - w = a*w - GO TO 200 - 140 w = infnty - GO TO 200 - - 160 IF (z.GE.k2) GO TO 120 -C -C Step 4 -C -C -C Step 5 -C - 170 v = beta*log(u1/ (1.0-u1)) - -C JJV same kind of checking as above - IF (a.GT.1.0) GO TO 175 -C JJV A < 1 so it can help out if EXP(V) would overflow - IF (v.GT.expmax) GO TO 172 - w = a*exp(v) - GO TO 190 - 172 w = v + log(a) - IF (w.GT.expmax) GO TO 180 - w = exp(w) - GO TO 190 - -C JJV in this case A > 1 - 175 IF (v.GT.expmax) GO TO 180 - w = exp(v) - IF (w.GT.infnty/a) GO TO 180 - w = a*w - GO TO 190 - - 180 w = infnty - -C JJV here we also check to see if log overlows; if so, we treat it -C JJV as -INF, which means condition is true, i.e. restart - 190 IF (alpha/(b+w).LT.minlog) GO TO 120 - IF ((alpha* (log(alpha/ (b+w))+v)-1.3862944).LT.log(z)) GO TO 120 -C -C Step 6 -C - 200 IF (.NOT. (a.EQ.aa)) GO TO 210 - genbet = w/ (b+w) - GO TO 220 - - 210 genbet = b/ (b+w) - 220 CONTINUE - 230 RETURN - - END
--- a/liboctave/cruft/ranlib/genchi.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,49 +0,0 @@ - REAL FUNCTION genchi(df) -C********************************************************************** -C -C REAL FUNCTION GENCHI( DF ) -C Generate random value of CHIsquare variable -C -C -C Function -C -C -C Generates random deviate from the distribution of a chisquare -C with DF degrees of freedom random variable. -C -C -C Arguments -C -C -C DF --> Degrees of freedom of the chisquare -C (Must be positive) -C REAL DF -C -C -C Method -C -C -C Uses relation between chisquare and gamma. -C -C********************************************************************** -C .. Scalar Arguments .. - REAL df -C .. -C .. External Functions .. -C REAL gengam -C EXTERNAL gengam - REAL sgamma - EXTERNAL sgamma -C .. -C .. Executable Statements .. - IF (.NOT. (df.LE.0.0)) GO TO 10 - WRITE (*,*) 'DF <= 0 in GENCHI - ABORT' - WRITE (*,*) 'Value of DF: ',df - CALL XSTOPX ('DF <= 0 in GENCHI - ABORT') - -C JJV changed this to call sgamma directly -C 10 genchi = 2.0*gengam(1.0,df/2.0) - 10 genchi = 2.0*sgamma(df/2.0) - RETURN - - END
--- a/liboctave/cruft/ranlib/genexp.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,60 +0,0 @@ - REAL FUNCTION genexp(av) - -C********************************************************************** -C -C REAL FUNCTION GENEXP( AV ) -C -C GENerate EXPonential random deviate -C -C -C Function -C -C -C Generates a single random deviate from an exponential -C distribution with mean AV. -C -C -C Arguments -C -C -C AV --> The mean of the exponential distribution from which -C a random deviate is to be generated. -C REAL AV -C JJV (AV >= 0) -C -C GENEXP <-- The random deviate. -C REAL GENEXP -C -C -C Method -C -C -C Renames SEXPO from TOMS as slightly modified by BWB to use RANF -C instead of SUNIF. -C -C For details see: -C -C Ahrens, J.H. and Dieter, U. -C Computer Methods for Sampling From the -C Exponential and Normal Distributions. -C Comm. ACM, 15,10 (Oct. 1972), 873 - 882. -C -C********************************************************************** -C .. Scalar Arguments .. - REAL av -C .. -C .. External Functions .. - REAL sexpo - EXTERNAL sexpo -C .. -C .. Executable Statements .. -C JJV added check to ensure AV >= 0.0 - IF (av.GE.0.0) GO TO 10 - WRITE (*,*) 'AV < 0.0 in GENEXP - ABORT' - WRITE (*,*) 'Value of AV: ',av - CALL XSTOPX ('AV < 0.0 in GENEXP - ABORT') - - 10 genexp = sexpo()*av - RETURN - - END
--- a/liboctave/cruft/ranlib/genf.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,72 +0,0 @@ - REAL FUNCTION genf(dfn,dfd) -C********************************************************************** -C -C REAL FUNCTION GENF( DFN, DFD ) -C GENerate random deviate from the F distribution -C -C -C Function -C -C -C Generates a random deviate from the F (variance ratio) -C distribution with DFN degrees of freedom in the numerator -C and DFD degrees of freedom in the denominator. -C -C -C Arguments -C -C -C DFN --> Numerator degrees of freedom -C (Must be positive) -C REAL DFN -C DFD --> Denominator degrees of freedom -C (Must be positive) -C REAL DFD -C -C -C Method -C -C -C Directly generates ratio of chisquare variates -C -C********************************************************************** -C .. Scalar Arguments .. - REAL dfd,dfn -C .. -C .. Local Scalars .. - REAL xden,xnum -C .. -C JJV changed this code to call sgamma directly -C .. External Functions .. -C REAL genchi -C EXTERNAL genchi - REAL sgamma - EXTERNAL sgamma -C .. -C .. Executable Statements .. - IF (.NOT. (dfn.LE.0.0.OR.dfd.LE.0.0)) GO TO 10 - WRITE (*,*) 'Degrees of freedom nonpositive in GENF - abort!' - WRITE (*,*) 'DFN value: ',dfn,'DFD value: ',dfd - CALL XSTOPX ('Degrees of freedom nonpositive in GENF - abort!') - - 10 xnum = 2.0*sgamma(dfn/2.0)/dfn - -C GENF = ( GENCHI( DFN ) / DFN ) / ( GENCHI( DFD ) / DFD ) - xden = 2.0*sgamma(dfd/2.0)/dfd -C JJV changed constant so that it will not underflow at compile time -C JJV while not slowing generator by using double precision or logs. -C IF (.NOT. (xden.LE. (1.0E-38*xnum))) GO TO 20 - IF (.NOT. (xden.LE. (1.0E-37*xnum))) GO TO 20 - WRITE (*,*) ' GENF - generated numbers would cause overflow' - WRITE (*,*) ' Numerator ',xnum,' Denominator ',xden -C JJV next 2 lines changed to maintain truncation of large deviates. -C WRITE (*,*) ' GENF returning 1.0E38' -C genf = 1.0E38 - WRITE (*,*) ' GENF returning 1.0E37' - genf = 1.0E37 - GO TO 30 - - 20 genf = xnum/xden - 30 RETURN - - END
--- a/liboctave/cruft/ranlib/gengam.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,72 +0,0 @@ - REAL FUNCTION gengam(a,r) -C********************************************************************** -C -C REAL FUNCTION GENGAM( A, R ) -C GENerates random deviates from GAMma distribution -C -C -C Function -C -C -C Generates random deviates from the gamma distribution whose -C density is -C (A**R)/Gamma(R) * X**(R-1) * Exp(-A*X) -C -C -C Arguments -C -C -C JJV added the argument ranges supported -C A --> Location parameter of Gamma distribution -C REAL A ( A > 0 ) -C -C R --> Shape parameter of Gamma distribution -C REAL R ( R > 0 ) -C -C -C Method -C -C -C Renames SGAMMA from TOMS as slightly modified by BWB to use RANF -C instead of SUNIF. -C -C For details see: -C (Case R >= 1.0) -C Ahrens, J.H. and Dieter, U. -C Generating Gamma Variates by a -C Modified Rejection Technique. -C Comm. ACM, 25,1 (Jan. 1982), 47 - 54. -C Algorithm GD -C -C JJV altered the following to reflect sgamma argument ranges -C (Case 0.0 < R < 1.0) -C Ahrens, J.H. and Dieter, U. -C Computer Methods for Sampling from Gamma, -C Beta, Poisson and Binomial Distributions. -C Computing, 12 (1974), 223-246/ -C Adapted algorithm GS. -C -C********************************************************************** -C .. Scalar Arguments .. - REAL a,r -C .. -C .. External Functions .. - REAL sgamma - EXTERNAL sgamma -C .. -C .. Executable Statements .. - -C JJV added argument value checker - IF ( a.GT.0.0 .AND. r.GT.0.0 ) GO TO 10 - WRITE (*,*) 'In GENGAM - Either (1) Location param A <= 0.0 or' - WRITE (*,*) '(2) Shape param R <= 0.0 - ABORT!' - WRITE (*,*) 'A value: ',a,'R value: ',r - CALL XSTOPX - + ('Location or shape param out of range in GENGAM - ABORT!') -C JJV end addition - - 10 gengam = sgamma(r)/a -C gengam = gengam/a - RETURN - - END
--- a/liboctave/cruft/ranlib/genmn.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,82 +0,0 @@ - SUBROUTINE genmn(parm,x,work) -C********************************************************************** -C -C SUBROUTINE GENMN(PARM,X,WORK) -C GENerate Multivariate Normal random deviate -C -C -C Arguments -C -C -C PARM --> Parameters needed to generate multivariate normal -C deviates (MEANV and Cholesky decomposition of -C COVM). Set by a previous call to SETGMN. -C 1 : 1 - size of deviate, P -C 2 : P + 1 - mean vector -C P+2 : P*(P+3)/2 + 1 - upper half of cholesky -C decomposition of cov matrix -C REAL PARM(*) -C -C X <-- Vector deviate generated. -C REAL X(P) -C -C WORK <--> Scratch array -C REAL WORK(P) -C -C -C Method -C -C -C 1) Generate P independent standard normal deviates - Ei ~ N(0,1) -C -C 2) Using Cholesky decomposition find A s.t. trans(A)*A = COVM -C -C 3) trans(A)E + MEANV ~ N(MEANV,COVM) -C -C********************************************************************** -C .. Array Arguments .. - REAL parm(*),work(*),x(*) -C .. -C .. Local Scalars .. - REAL ae - INTEGER i,icount,j,p -C .. -C .. External Functions .. - REAL snorm - EXTERNAL snorm -C .. -C .. Intrinsic Functions .. - INTRINSIC int -C .. -C .. Executable Statements .. - p = int(parm(1)) -C -C Generate P independent normal deviates - WORK ~ N(0,1) -C - DO 10,i = 1,p - work(i) = snorm() - 10 CONTINUE - DO 30,i = 1,p -C -C PARM (P+2 : P*(P+3)/2 + 1) contains A, the Cholesky -C decomposition of the desired covariance matrix. -C trans(A)(1,1) = PARM(P+2) -C trans(A)(2,1) = PARM(P+3) -C trans(A)(2,2) = PARM(P+2+P) -C trans(A)(3,1) = PARM(P+4) -C trans(A)(3,2) = PARM(P+3+P) -C trans(A)(3,3) = PARM(P+2-1+2P) ... -C -C trans(A)*WORK + MEANV ~ N(MEANV,COVM) -C - icount = 0 - ae = 0.0 - DO 20,j = 1,i - icount = icount + j - 1 - ae = ae + parm(i+ (j-1)*p-icount+p+1)*work(j) - 20 CONTINUE - x(i) = ae + parm(i+1) - 30 CONTINUE - RETURN -C - END
--- a/liboctave/cruft/ranlib/genmul.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,92 +0,0 @@ - SUBROUTINE genmul(n,p,ncat,ix) -C********************************************************************** -C -C SUBROUTINE GENMUL( N, P, NCAT, IX ) -C GENerate an observation from the MULtinomial distribution -C -C -C Arguments -C -C -C N --> Number of events that will be classified into one of -C the categories 1..NCAT -C INTEGER N -C -C P --> Vector of probabilities. P(i) is the probability that -C an event will be classified into category i. Thus, P(i) -C must be [0,1]. Only the first NCAT-1 P(i) must be defined -C since P(NCAT) is 1.0 minus the sum of the first -C NCAT-1 P(i). -C REAL P(NCAT-1) -C -C NCAT --> Number of categories. Length of P and IX. -C INTEGER NCAT -C -C IX <-- Observation from multinomial distribution. All IX(i) -C will be nonnegative and their sum will be N. -C INTEGER IX(NCAT) -C -C -C Method -C -C -C Algorithm from page 559 of -C -C Devroye, Luc -C -C Non-Uniform Random Variate Generation. Springer-Verlag, -C New York, 1986. -C -C********************************************************************** -C .. Scalar Arguments .. - INTEGER n,ncat -C .. -C .. Array Arguments .. - REAL p(*) - INTEGER ix(*) -C .. -C .. Local Scalars .. - REAL prob,ptot,sum - INTEGER i,icat,ntot -C .. -C .. External Functions .. - INTEGER ignbin - EXTERNAL ignbin -C .. -C .. Intrinsic Functions .. - INTRINSIC abs -C .. -C .. Executable Statements .. - -C Check Arguments - IF (n.LT.0) CALL XSTOPX ('N < 0 in GENMUL') - IF (ncat.LE.1) CALL XSTOPX ('NCAT <= 1 in GENMUL') - ptot = 0.0 - DO 10,i = 1,ncat - 1 - IF (p(i).LT.0.0) CALL XSTOPX ('Some P(i) < 0 in GENMUL') - IF (p(i).GT.1.0) CALL XSTOPX ('Some P(i) > 1 in GENMUL') - ptot = ptot + p(i) - 10 CONTINUE - IF (ptot.GT.0.99999) CALL XSTOPX ('Sum of P(i) > 1 in GENMUL') - -C Initialize variables - ntot = n - sum = 1.0 - DO 20,i = 1,ncat - ix(i) = 0 - 20 CONTINUE - -C Generate the observation - DO 30,icat = 1,ncat - 1 - prob = p(icat)/sum - ix(icat) = ignbin(ntot,prob) - ntot = ntot - ix(icat) - IF (ntot.LE.0) RETURN - sum = sum - p(icat) - 30 CONTINUE - ix(ncat) = ntot - -C Finished - RETURN - - END
--- a/liboctave/cruft/ranlib/gennch.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,69 +0,0 @@ - REAL FUNCTION gennch(df,xnonc) -C********************************************************************** -C -C REAL FUNCTION GENNCH( DF, XNONC ) -C Generate random value of Noncentral CHIsquare variable -C -C -C Function -C -C - -C Generates random deviate from the distribution of a noncentral -C chisquare with DF degrees of freedom and noncentrality parameter -C XNONC. -C -C -C Arguments -C -C -C DF --> Degrees of freedom of the chisquare -C (Must be >= 1.0) -C REAL DF -C -C XNONC --> Noncentrality parameter of the chisquare -C (Must be >= 0.0) -C REAL XNONC -C -C -C Method -C -C -C Uses fact that noncentral chisquare is the sum of a chisquare -C deviate with DF-1 degrees of freedom plus the square of a normal -C deviate with mean sqrt(XNONC) and standard deviation 1. -C -C********************************************************************** -C .. Scalar Arguments .. - REAL df,xnonc -C .. -C .. External Functions .. -C JJV changed these to call SGAMMA and SNORM directly -C REAL genchi,gennor -C EXTERNAL genchi,gennor - REAL sgamma,snorm - EXTERNAL sgamma,snorm -C .. -C .. Intrinsic Functions .. - INTRINSIC sqrt -C .. -C JJV changed abort to df < 1, and added case: df = 1 -C .. Executable Statements .. - IF (.NOT. (df.LT.1.0.OR.xnonc.LT.0.0)) GO TO 10 - WRITE (*,*) 'DF < 1 or XNONC < 0 in GENNCH - ABORT' - WRITE (*,*) 'Value of DF: ',df,' Value of XNONC',xnonc - CALL XSTOPX ('DF < 1 or XNONC < 0 in GENNCH - ABORT') - -C JJV changed this to call SGAMMA and SNORM directly -C gennch = genchi(df-1.0) + gennor(sqrt(xnonc),1.0)**2 - - 10 IF (df.GE.1.000001) GO TO 20 -C JJV case DF = 1.0 - gennch = (snorm() + sqrt(xnonc))**2 - GO TO 30 - -C JJV case DF > 1.0 - 20 gennch = 2.0*sgamma((df-1.0)/2.0) + (snorm() + sqrt(xnonc))**2 - 30 RETURN - - END
--- a/liboctave/cruft/ranlib/gennf.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,98 +0,0 @@ - REAL FUNCTION gennf(dfn,dfd,xnonc) - -C********************************************************************** -C -C REAL FUNCTION GENNF( DFN, DFD, XNONC ) -C GENerate random deviate from the Noncentral F distribution -C -C -C Function -C -C -C Generates a random deviate from the noncentral F (variance ratio) -C distribution with DFN degrees of freedom in the numerator, and DFD -C degrees of freedom in the denominator, and noncentrality parameter -C XNONC. -C -C -C Arguments -C -C -C DFN --> Numerator degrees of freedom -C (Must be >= 1.0) -C REAL DFN -C DFD --> Denominator degrees of freedom -C (Must be positive) -C REAL DFD -C -C XNONC --> Noncentrality parameter -C (Must be nonnegative) -C REAL XNONC -C -C -C Method -C -C -C Directly generates ratio of noncentral numerator chisquare variate -C to central denominator chisquare variate. -C -C********************************************************************** -C .. Scalar Arguments .. - REAL dfd,dfn,xnonc -C .. -C .. Local Scalars .. - REAL xden,xnum - LOGICAL qcond -C .. -C .. External Functions .. -C JJV changed the code to call SGAMMA and SNORM directly -C REAL genchi,gennch -C EXTERNAL genchi,gennch - REAL sgamma,snorm - EXTERNAL sgamma,snorm -C .. -C .. Executable Statements .. -C JJV changed the argument checker to allow DFN = 1.0 -C JJV in the same way as GENNCH was changed. - qcond = dfn .LT. 1.0 .OR. dfd .LE. 0.0 .OR. xnonc .LT. 0.0 - IF (.NOT. (qcond)) GO TO 10 - WRITE (*,*) 'In GENNF - Either (1) Numerator DF < 1.0 or' - WRITE (*,*) '(2) Denominator DF <= 0.0 or ' - WRITE (*,*) '(3) Noncentrality parameter < 0.0' - WRITE (*,*) 'DFN value: ',dfn,'DFD value: ',dfd,'XNONC value: ', - + xnonc - - CALL XSTOPX - + ('Degrees of freedom or noncent param out of range in GENNF') - -C GENNF = ( GENNCH( DFN, XNONC ) / DFN ) / ( GENCHI( DFD ) / DFD ) -C JJV changed this to call SGAMMA and SNORM directly -C xnum = gennch(dfn,xnonc)/dfn - 10 IF (dfn.GE.1.000001) GO TO 20 -C JJV case dfn = 1.0 - here I am treating dfn as exactly 1.0 - xnum = (snorm() + sqrt(xnonc))**2 - GO TO 30 - -C JJV case dfn > 1.0 - 20 xnum = (2.0*sgamma((dfn-1.0)/2.0) + (snorm()+sqrt(xnonc))**2)/dfn - -C xden = genchi(dfd)/dfd - 30 xden = 2.0*sgamma(dfd/2.0)/dfd - -C JJV changed constant so that it will not underflow at compile time -C JJV while not slowing generator by using double precision or logs. -C IF (.NOT. (xden.LE. (1.0E-38*xnum))) GO TO 40 - IF (.NOT. (xden.LE. (1.0E-37*xnum))) GO TO 40 - WRITE (*,*) ' GENNF - generated numbers would cause overflow' - WRITE (*,*) ' Numerator ',xnum,' Denominator ',xden -C JJV next 2 lines changed to maintain truncation of large deviates. -C WRITE (*,*) ' GENNF returning 1.0E38' -C gennf = 1.0E38 - WRITE (*,*) ' GENNF returning 1.0E37' - gennf = 1.0E37 - GO TO 50 - - 40 gennf = xnum/xden - 50 RETURN - - END
--- a/liboctave/cruft/ranlib/gennor.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,61 +0,0 @@ - REAL FUNCTION gennor(av,sd) -C********************************************************************** -C -C REAL FUNCTION GENNOR( AV, SD ) -C -C GENerate random deviate from a NORmal distribution -C -C -C Function -C -C -C Generates a single random deviate from a normal distribution -C with mean, AV, and standard deviation, SD. -C -C -C Arguments -C -C -C AV --> Mean of the normal distribution. -C REAL AV -C -C SD --> Standard deviation of the normal distribution. -C REAL SD -C JJV (SD >= 0) -C -C GENNOR <-- Generated normal deviate. -C REAL GENNOR -C -C -C Method -C -C -C Renames SNORM from TOMS as slightly modified by BWB to use RANF -C instead of SUNIF. -C -C For details see: -C Ahrens, J.H. and Dieter, U. -C Extensions of Forsythe's Method for Random -C Sampling from the Normal Distribution. -C Math. Comput., 27,124 (Oct. 1973), 927 - 937. -C -C -C********************************************************************** -C .. Scalar Arguments .. - REAL av,sd -C .. -C .. External Functions .. - REAL snorm - EXTERNAL snorm -C .. -C .. Executable Statements .. -C JJV added check to ensure SD >= 0.0 - IF (sd.GE.0.0) GO TO 10 - WRITE (*,*) 'SD < 0.0 in GENNOR - ABORT' - WRITE (*,*) 'Value of SD: ',sd - CALL XSTOPX ('SD < 0.0 in GENNOR - ABORT') - - 10 gennor = sd*snorm() + av - RETURN - - END
--- a/liboctave/cruft/ranlib/genprm.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,41 +0,0 @@ - SUBROUTINE genprm(iarray,larray) -C********************************************************************** -C -C SUBROUTINE GENPRM( IARRAY, LARRAY ) -C GENerate random PeRMutation of iarray -C -C -C Arguments -C -C -C IARRAY <--> On output IARRAY is a random permutation of its -C value on input -C INTEGER IARRAY( LARRAY ) -C -C LARRAY <--> Length of IARRAY -C INTEGER LARRAY -C -C********************************************************************** -C .. Scalar Arguments .. - INTEGER larray -C .. -C .. Array Arguments .. - INTEGER iarray(larray) -C .. -C .. Local Scalars .. - INTEGER i,itmp,iwhich -C .. -C .. External Functions .. - INTEGER ignuin - EXTERNAL ignuin -C .. -C .. Executable Statements .. - DO 10,i = 1,larray - iwhich = ignuin(i,larray) - itmp = iarray(iwhich) - iarray(iwhich) = iarray(i) - iarray(i) = itmp - 10 CONTINUE - RETURN - - END
--- a/liboctave/cruft/ranlib/genunf.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,42 +0,0 @@ - REAL FUNCTION genunf(low,high) -C********************************************************************** -C -C REAL FUNCTION GENUNF( LOW, HIGH ) -C -C GeNerate Uniform Real between LOW and HIGH -C -C -C Function -C -C -C Generates a real uniformly distributed between LOW and HIGH. -C -C -C Arguments -C -C -C LOW --> Low bound (exclusive) on real value to be generated -C REAL LOW -C -C HIGH --> High bound (exclusive) on real value to be generated -C REAL HIGH -C -C********************************************************************** -C .. Scalar Arguments .. - REAL high,low -C .. -C .. External Functions .. - REAL ranf - EXTERNAL ranf -C .. -C .. Executable Statements .. - IF (.NOT. (low.GT.high)) GO TO 10 - WRITE (*,*) 'LOW > HIGH in GENUNF: LOW ',low,' HIGH: ',high - WRITE (*,*) 'Abort' - CALL XSTOPX ('LOW > High in GENUNF - Abort') - - 10 genunf = low + (high-low)*ranf() - - RETURN - - END
--- a/liboctave/cruft/ranlib/getcgn.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,55 +0,0 @@ - SUBROUTINE getcgn(g) - INTEGER g -C********************************************************************** -C -C SUBROUTINE GETCGN(G) -C Get GeNerator -C -C Returns in G the number of the current random number generator -C -C -C Arguments -C -C -C G <-- Number of the current random number generator (1..32) -C INTEGER G -C -C********************************************************************** -C - INTEGER curntg,numg - SAVE curntg - PARAMETER (numg=32) - DATA curntg/1/ -C - g = curntg - RETURN - - ENTRY setcgn(g) -C********************************************************************** -C -C SUBROUTINE SETCGN( G ) -C Set GeNerator -C -C Sets the current generator to G. All references to a generat -C are to the current generator. -C -C -C Arguments -C -C -C G --> Number of the current random number generator (1..32) -C INTEGER G -C -C********************************************************************** -C -C Abort if generator number out of range -C - IF (.NOT. (g.LT.0.OR.g.GT.numg)) GO TO 10 - WRITE (*,*) ' Generator number out of range in SETCGN:', - + ' Legal range is 1 to ',numg,' -- ABORT!' - CALL XSTOPX (' Generator number out of range in SETCGN') - - 10 curntg = g - RETURN - - END
--- a/liboctave/cruft/ranlib/getsd.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,73 +0,0 @@ - SUBROUTINE getsd(iseed1,iseed2) -C********************************************************************** -C -C SUBROUTINE GETSD(G,ISEED1,ISEED2) -C GET SeeD -C -C Returns the value of two integer seeds of the current generator -C -C This is a transcription from Pascal to Fortran of routine -C Get_State from the paper -C -C L'Ecuyer, P. and Cote, S. "Implementing a Random Number Package -C with Splitting Facilities." ACM Transactions on Mathematical -C Software, 17:98-111 (1991) -C -C -C Arguments -C -C -C -C ISEED1 <- First integer seed of generator G -C INTEGER ISEED1 -C -C ISEED2 <- Second integer seed of generator G -C INTEGER ISEED1 -C -C********************************************************************** -C .. Parameters .. - INTEGER numg - PARAMETER (numg=32) -C .. -C .. Scalar Arguments .. - INTEGER iseed1,iseed2 -C .. -C .. Scalars in Common .. - INTEGER a1,a1vw,a1w,a2,a2vw,a2w,m1,m2 -C .. -C .. Arrays in Common .. - INTEGER cg1(numg),cg2(numg),ig1(numg),ig2(numg),lg1(numg), - + lg2(numg) - LOGICAL qanti(numg) -C .. -C .. Local Scalars .. - INTEGER g -C .. -C .. External Functions .. - LOGICAL qrgnin - EXTERNAL qrgnin -C .. -C .. External Subroutines .. - EXTERNAL getcgn -C .. -C .. Common blocks .. - COMMON /globe/m1,m2,a1,a2,a1w,a2w,a1vw,a2vw,ig1,ig2,lg1,lg2,cg1, - + cg2,qanti -C .. -C .. Save statement .. - SAVE /globe/ -C .. -C .. Executable Statements .. -C Abort unless random number generator initialized - IF (qrgnin()) GO TO 10 - WRITE (*,*) ' GETSD called before random number generator ', - + ' initialized -- abort!' - CALL XSTOPX - + (' GETSD called before random number generator initialized') - - 10 CALL getcgn(g) - iseed1 = cg1(g) - iseed2 = cg2(g) - RETURN - - END
--- a/liboctave/cruft/ranlib/ignbin.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,325 +0,0 @@ - INTEGER FUNCTION ignbin(n,pp) -C********************************************************************** -C -C INTEGER FUNCTION IGNBIN( N, PP ) -C -C GENerate BINomial random deviate -C -C -C Function -C -C -C Generates a single random deviate from a binomial -C distribution whose number of trials is N and whose -C probability of an event in each trial is P. -C -C -C Arguments -C -C -C N --> The number of trials in the binomial distribution -C from which a random deviate is to be generated. -C INTEGER N -C JJV (N >= 0) -C -C PP --> The probability of an event in each trial of the -C binomial distribution from which a random deviate -C is to be generated. -C REAL PP -C JJV (0.0 <= pp <= 1.0) -C -C IGNBIN <-- A random deviate yielding the number of events -C from N independent trials, each of which has -C a probability of event P. -C INTEGER IGNBIN -C -C -C Note -C -C -C Uses RANF so the value of the seeds, ISEED1 and ISEED2 must be set -C by a call similar to the following -C DUM = RANSET( ISEED1, ISEED2 ) -C -C -C Method -C -C -C This is algorithm BTPE from: -C -C Kachitvichyanukul, V. and Schmeiser, B. W. -C -C Binomial Random Variate Generation. -C Communications of the ACM, 31, 2 -C (February, 1988) 216. -C -C********************************************************************** -C SUBROUTINE BTPEC(N,PP,ISEED,JX) -C -C BINOMIAL RANDOM VARIATE GENERATOR -C MEAN .LT. 30 -- INVERSE CDF -C MEAN .GE. 30 -- ALGORITHM BTPE: ACCEPTANCE-REJECTION VIA -C FOUR REGION COMPOSITION. THE FOUR REGIONS ARE A TRIANGLE -C (SYMMETRIC IN THE CENTER), A PAIR OF PARALLELOGRAMS (ABOVE -C THE TRIANGLE), AND EXPONENTIAL LEFT AND RIGHT TAILS. -C -C BTPE REFERS TO BINOMIAL-TRIANGLE-PARALLELOGRAM-EXPONENTIAL. -C BTPEC REFERS TO BTPE AND "COMBINED." THUS BTPE IS THE -C RESEARCH AND BTPEC IS THE IMPLEMENTATION OF A COMPLETE -C USABLE ALGORITHM. -C REFERENCE: VORATAS KACHITVICHYANUKUL AND BRUCE SCHMEISER, -C "BINOMIAL RANDOM VARIATE GENERATION," -C COMMUNICATIONS OF THE ACM, FORTHCOMING -C WRITTEN: SEPTEMBER 1980. -C LAST REVISED: MAY 1985, JULY 1987 -C REQUIRED SUBPROGRAM: RAND() -- A UNIFORM (0,1) RANDOM NUMBER -C GENERATOR -C ARGUMENTS -C -C N : NUMBER OF BERNOULLI TRIALS (INPUT) -C PP : PROBABILITY OF SUCCESS IN EACH TRIAL (INPUT) -C ISEED: RANDOM NUMBER SEED (INPUT AND OUTPUT) -C JX: RANDOMLY GENERATED OBSERVATION (OUTPUT) -C -C VARIABLES -C PSAVE: VALUE OF PP FROM THE LAST CALL TO BTPEC -C NSAVE: VALUE OF N FROM THE LAST CALL TO BTPEC -C XNP: VALUE OF THE MEAN FROM THE LAST CALL TO BTPEC -C -C P: PROBABILITY USED IN THE GENERATION PHASE OF BTPEC -C FFM: TEMPORARY VARIABLE EQUAL TO XNP + P -C M: INTEGER VALUE OF THE CURRENT MODE -C FM: FLOATING POINT VALUE OF THE CURRENT MODE -C XNPQ: TEMPORARY VARIABLE USED IN SETUP AND SQUEEZING STEPS -C P1: AREA OF THE TRIANGLE -C C: HEIGHT OF THE PARALLELOGRAMS -C XM: CENTER OF THE TRIANGLE -C XL: LEFT END OF THE TRIANGLE -C XR: RIGHT END OF THE TRIANGLE -C AL: TEMPORARY VARIABLE -C XLL: RATE FOR THE LEFT EXPONENTIAL TAIL -C XLR: RATE FOR THE RIGHT EXPONENTIAL TAIL -C P2: AREA OF THE PARALLELOGRAMS -C P3: AREA OF THE LEFT EXPONENTIAL TAIL -C P4: AREA OF THE RIGHT EXPONENTIAL TAIL -C U: A U(0,P4) RANDOM VARIATE USED FIRST TO SELECT ONE OF THE -C FOUR REGIONS AND THEN CONDITIONALLY TO GENERATE A VALUE -C FROM THE REGION -C V: A U(0,1) RANDOM NUMBER USED TO GENERATE THE RANDOM VALUE -C (REGION 1) OR TRANSFORMED INTO THE VARIATE TO ACCEPT OR -C REJECT THE CANDIDATE VALUE -C IX: INTEGER CANDIDATE VALUE -C X: PRELIMINARY CONTINUOUS CANDIDATE VALUE IN REGION 2 LOGIC -C AND A FLOATING POINT IX IN THE ACCEPT/REJECT LOGIC -C K: ABSOLUTE VALUE OF (IX-M) -C F: THE HEIGHT OF THE SCALED DENSITY FUNCTION USED IN THE -C ACCEPT/REJECT DECISION WHEN BOTH M AND IX ARE SMALL -C ALSO USED IN THE INVERSE TRANSFORMATION -C R: THE RATIO P/Q -C G: CONSTANT USED IN CALCULATION OF PROBABILITY -C MP: MODE PLUS ONE, THE LOWER INDEX FOR EXPLICIT CALCULATION -C OF F WHEN IX IS GREATER THAN M -C IX1: CANDIDATE VALUE PLUS ONE, THE LOWER INDEX FOR EXPLICIT -C CALCULATION OF F WHEN IX IS LESS THAN M -C I: INDEX FOR EXPLICIT CALCULATION OF F FOR BTPE -C AMAXP: MAXIMUM ERROR OF THE LOGARITHM OF NORMAL BOUND -C YNORM: LOGARITHM OF NORMAL BOUND -C ALV: NATURAL LOGARITHM OF THE ACCEPT/REJECT VARIATE V -C -C X1,F1,Z,W,Z2,X2,F2, AND W2 ARE TEMPORARY VARIABLES TO BE -C USED IN THE FINAL ACCEPT/REJECT TEST -C -C QN: PROBABILITY OF NO SUCCESS IN N TRIALS -C -C REMARK -C IX AND JX COULD LOGICALLY BE THE SAME VARIABLE, WHICH WOULD -C SAVE A MEMORY POSITION AND A LINE OF CODE. HOWEVER, SOME -C COMPILERS (E.G.,CDC MNF) OPTIMIZE BETTER WHEN THE ARGUMENTS -C ARE NOT INVOLVED. -C -C ISEED NEEDS TO BE DOUBLE PRECISION IF THE IMSL ROUTINE -C GGUBFS IS USED TO GENERATE UNIFORM RANDOM NUMBER, OTHERWISE -C TYPE OF ISEED SHOULD BE DICTATED BY THE UNIFORM GENERATOR -C -C********************************************************************** - -C -C -C -C*****DETERMINE APPROPRIATE ALGORITHM AND WHETHER SETUP IS NECESSARY -C -C .. -C .. Scalar Arguments .. - REAL pp - INTEGER n -C .. -C .. Local Scalars .. - REAL al,alv,amaxp,c,f,f1,f2,ffm,fm,g,p,p1,p2,p3,p4,psave,q,qn,r,u, - + v,w,w2,x,x1,x2,xl,xll,xlr,xm,xnp,xnpq,xr,ynorm,z,z2 - INTEGER i,ix,ix1,k,m,mp,nsave -C .. -C .. External Functions .. - REAL ranf - EXTERNAL ranf -C .. -C .. Intrinsic Functions .. - INTRINSIC abs,alog,amin1,iabs,int,sqrt -C JJV .. -C JJV .. Save statement .. - SAVE p,q,m,fm,xnp,xnpq,p1,xm,xl,xr,c,xll,xlr,p2,p3,p4,qn,r,g, - + psave,nsave -C JJV I am including the variables in data statements -C .. -C .. Data statements .. -C JJV made these ridiculous starting values - the hope is that -C JJV no one will call this the first time with them as args - DATA psave,nsave/-1.0E37,-214748365/ -C .. -C .. Executable Statements .. - IF (pp.NE.psave) GO TO 10 - IF (n.NE.nsave) GO TO 20 - IF (xnp-30.0.LT.0.0) GO TO 150 - GO TO 30 -C -C*****SETUP, PERFORM ONLY WHEN PARAMETERS CHANGE -C - -C JJV added the argument checker - involved only renaming 10 -C JJV and 20 to the checkers and adding checkers -C JJV Only remaining problem - if called initially with the -C JJV initial values of psave and nsave, it will hang - 10 IF (pp.LT.0.0) CALL XSTOPX ('PP < 0.0 in IGNBIN - ABORT!') - IF (pp.GT.1.0) CALL XSTOPX ('PP > 1.0 in IGNBIN - ABORT!') - psave = pp - p = amin1(psave,1.-psave) - q = 1. - p - 20 IF (n.LT.0) CALL XSTOPX ('N < 0 in IGNBIN - ABORT!') - xnp = n*p - nsave = n - IF (xnp.LT.30.) GO TO 140 - ffm = xnp + p - m = ffm - fm = m - xnpq = xnp*q - p1 = int(2.195*sqrt(xnpq)-4.6*q) + 0.5 - xm = fm + 0.5 - xl = xm - p1 - xr = xm + p1 - c = 0.134 + 20.5/ (15.3+fm) - al = (ffm-xl)/ (ffm-xl*p) - xll = al* (1.+.5*al) - al = (xr-ffm)/ (xr*q) - xlr = al* (1.+.5*al) - p2 = p1* (1.+c+c) - p3 = p2 + c/xll - p4 = p3 + c/xlr -C WRITE(6,100) N,P,P1,P2,P3,P4,XL,XR,XM,FM -C 100 FORMAT(I15,4F18.7/5F18.7) -C -C*****GENERATE VARIATE -C - 30 u = ranf()*p4 - v = ranf() -C -C TRIANGULAR REGION -C - IF (u.GT.p1) GO TO 40 - ix = xm - p1*v + u - GO TO 170 -C -C PARALLELOGRAM REGION -C - 40 IF (u.GT.p2) GO TO 50 - x = xl + (u-p1)/c - v = v*c + 1. - abs(xm-x)/p1 - IF (v.GT.1. .OR. v.LE.0.) GO TO 30 - ix = x - GO TO 70 -C -C LEFT TAIL -C - 50 IF (u.GT.p3) GO TO 60 - ix = xl + alog(v)/xll - IF (ix.LT.0) GO TO 30 - v = v* (u-p2)*xll - GO TO 70 -C -C RIGHT TAIL -C - 60 ix = xr - alog(v)/xlr - IF (ix.GT.n) GO TO 30 - v = v* (u-p3)*xlr -C -C*****DETERMINE APPROPRIATE WAY TO PERFORM ACCEPT/REJECT TEST -C - 70 k = iabs(ix-m) - IF (k.GT.20 .AND. k.LT.xnpq/2-1) GO TO 130 -C -C EXPLICIT EVALUATION -C - f = 1.0 - r = p/q - g = (n+1)*r - IF (m-ix.LT.0) GO TO 80 - IF (m-ix.EQ.0) GO TO 120 - GO TO 100 - 80 mp = m + 1 - DO 90 i = mp,ix - f = f* (g/i-r) - 90 CONTINUE - GO TO 120 - - 100 ix1 = ix + 1 - DO 110 i = ix1,m - f = f/ (g/i-r) - 110 CONTINUE - 120 IF (v-f.LE.0) GO TO 170 - GO TO 30 -C -C SQUEEZING USING UPPER AND LOWER BOUNDS ON ALOG(F(X)) -C - 130 amaxp = (k/xnpq)* ((k* (k/3.+.625)+.1666666666666)/xnpq+.5) - ynorm = -k*k/ (2.*xnpq) - alv = alog(v) - IF (alv.LT.ynorm-amaxp) GO TO 170 - IF (alv.GT.ynorm+amaxp) GO TO 30 -C -C STIRLING'S FORMULA TO MACHINE ACCURACY FOR -C THE FINAL ACCEPTANCE/REJECTION TEST -C - x1 = ix + 1 - f1 = fm + 1. - z = n + 1 - fm - w = n - ix + 1. - z2 = z*z - x2 = x1*x1 - f2 = f1*f1 - w2 = w*w - IF (alv- (xm*alog(f1/x1)+ (n-m+.5)*alog(z/w)+ (ix- - + m)*alog(w*p/ (x1*q))+ (13860.- (462.- (132.- (99.- - + 140./f2)/f2)/f2)/f2)/f1/166320.+ (13860.- (462.- (132.- (99.- - + 140./z2)/z2)/z2)/z2)/z/166320.+ (13860.- (462.- (132.- (99.- - + 140./x2)/x2)/x2)/x2)/x1/166320.+ (13860.- (462.- (132.- (99.- - + 140./w2)/w2)/w2)/w2)/w/166320.) .LE. 0.) GO TO 170 - GO TO 30 -C -C INVERSE CDF LOGIC FOR MEAN LESS THAN 30 -C - 140 qn = q**n - r = p/q - g = r* (n+1) - 150 ix = 0 - f = qn - u = ranf() - 160 IF (u.LT.f) GO TO 170 - IF (ix.GT.110) GO TO 150 - u = u - f - ix = ix + 1 - f = f* (g/ix-r) - GO TO 160 - - 170 IF (psave.GT.0.5) ix = n - ix - ignbin = ix - RETURN - - END
--- a/liboctave/cruft/ranlib/ignlgi.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,77 +0,0 @@ - INTEGER FUNCTION ignlgi() -C********************************************************************** -C -C INTEGER FUNCTION IGNLGI() -C GeNerate LarGe Integer -C -C Returns a random integer following a uniform distribution over -C (1, 2147483562) using the current generator. -C -C This is a transcription from Pascal to Fortran of routine -C Random from the paper -C -C L'Ecuyer, P. and Cote, S. "Implementing a Random Number Package -C with Splitting Facilities." ACM Transactions on Mathematical -C Software, 17:98-111 (1991) -C -C********************************************************************** -C .. Parameters .. - INTEGER numg - PARAMETER (numg=32) -C .. -C .. Scalars in Common .. - INTEGER a1,a1vw,a1w,a2,a2vw,a2w,m1,m2 -C .. -C .. Arrays in Common .. - INTEGER cg1(numg),cg2(numg),ig1(numg),ig2(numg),lg1(numg), - + lg2(numg) - LOGICAL qanti(numg) -C .. -C .. Local Scalars .. - INTEGER curntg,k,s1,s2,z - LOGICAL qqssd -C .. -C .. External Functions .. - LOGICAL qrgnin - EXTERNAL qrgnin -C .. -C .. External Subroutines .. - EXTERNAL getcgn,inrgcm,rgnqsd,setall -C .. -C .. Common blocks .. - COMMON /globe/m1,m2,a1,a2,a1w,a2w,a1vw,a2vw,ig1,ig2,lg1,lg2,cg1, - + cg2,qanti -C .. -C .. Save statement .. - SAVE /globe/ -C .. -C .. Executable Statements .. -C -C IF THE RANDOM NUMBER PACKAGE HAS NOT BEEN INITIALIZED YET, DO SO. -C IT CAN BE INITIALIZED IN ONE OF TWO WAYS : 1) THE FIRST CALL TO -C THIS ROUTINE 2) A CALL TO SETALL. -C - IF (.NOT. (qrgnin())) CALL inrgcm() - CALL rgnqsd(qqssd) - IF (.NOT. (qqssd)) CALL setall(1234567890,123456789) -C -C Get Current Generator -C - CALL getcgn(curntg) - s1 = cg1(curntg) - s2 = cg2(curntg) - k = s1/53668 - s1 = a1* (s1-k*53668) - k*12211 - IF (s1.LT.0) s1 = s1 + m1 - k = s2/52774 - s2 = a2* (s2-k*52774) - k*3791 - IF (s2.LT.0) s2 = s2 + m2 - cg1(curntg) = s1 - cg2(curntg) = s2 - z = s1 - s2 - IF (z.LT.1) z = z + m1 - 1 - IF (qanti(curntg)) z = m1 - z - ignlgi = z - RETURN - - END
--- a/liboctave/cruft/ranlib/ignnbn.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,78 +0,0 @@ - INTEGER FUNCTION ignnbn(n,p) -C********************************************************************** -C -C INTEGER FUNCTION IGNNBN( N, P ) -C -C GENerate Negative BiNomial random deviate -C -C -C Function -C -C -C Generates a single random deviate from a negative binomial -C distribution. -C -C -C Arguments -C -C -C N --> Required number of events. -C INTEGER N -C JJV (N > 0) -C -C P --> The probability of an event during a Bernoulli trial. -C REAL P -C JJV (0.0 < P < 1.0) -C -C -C -C Method -C -C -C Algorithm from page 480 of -C -C Devroye, Luc -C -C Non-Uniform Random Variate Generation. Springer-Verlag, -C New York, 1986. -C -C********************************************************************** -C .. -C .. Scalar Arguments .. - REAL p - INTEGER n -C .. -C .. Local Scalars .. - REAL y,a,r -C .. -C .. External Functions .. -C JJV changed to call SGAMMA directly -C REAL gengam - REAL sgamma - INTEGER ignpoi -C EXTERNAL gengam,ignpoi - EXTERNAL sgamma,ignpoi -C .. -C .. Intrinsic Functions .. - INTRINSIC real -C .. -C .. Executable Statements .. -C Check Arguments -C JJV changed argumnet checker to abort if N <= 0 - IF (n.LE.0) CALL XSTOPX ('N <= 0 in IGNNBN') - IF (p.LE.0.0) CALL XSTOPX ('P <= 0.0 in IGNNBN') - IF (p.GE.1.0) CALL XSTOPX ('P >= 1.0 in IGNNBN') - -C Generate Y, a random gamma (n,(1-p)/p) variable -C JJV Note: the above parametrization is consistent with Devroye, -C JJV but gamma (p/(1-p),n) is the equivalent in our code - 10 r = real(n) - a = p/ (1.0-p) -C y = gengam(a,r) - y = sgamma(r)/a - -C Generate a random Poisson(y) variable - ignnbn = ignpoi(y) - RETURN - - END
--- a/liboctave/cruft/ranlib/ignpoi.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,285 +0,0 @@ - INTEGER FUNCTION ignpoi(mu) -C********************************************************************** -C -C INTEGER FUNCTION IGNPOI( MU ) -C -C GENerate POIsson random deviate -C -C -C Function -C -C -C Generates a single random deviate from a Poisson -C distribution with mean MU. -C -C -C Arguments -C -C -C MU --> The mean of the Poisson distribution from which -C a random deviate is to be generated. -C REAL MU -C JJV (MU >= 0.0) -C -C IGNPOI <-- The random deviate. -C INTEGER IGNPOI (non-negative) -C -C -C Method -C -C -C Renames KPOIS from TOMS as slightly modified by BWB to use RANF -C instead of SUNIF. -C -C For details see: -C -C Ahrens, J.H. and Dieter, U. -C Computer Generation of Poisson Deviates -C From Modified Normal Distributions. -C ACM Trans. Math. Software, 8, 2 -C (June 1982),163-179 -C -C********************************************************************** -C**********************************************************************C -C**********************************************************************C -C C -C C -C P O I S S O N DISTRIBUTION C -C C -C C -C**********************************************************************C -C**********************************************************************C -C C -C FOR DETAILS SEE: C -C C -C AHRENS, J.H. AND DIETER, U. C -C COMPUTER GENERATION OF POISSON DEVIATES C -C FROM MODIFIED NORMAL DISTRIBUTIONS. C -C ACM TRANS. MATH. SOFTWARE, 8,2 (JUNE 1982), 163 - 179. C -C C -C (SLIGHTLY MODIFIED VERSION OF THE PROGRAM IN THE ABOVE ARTICLE) C -C C -C**********************************************************************C -C -C INTEGER FUNCTION IGNPOI(IR,MU) -C -C INPUT: IR=CURRENT STATE OF BASIC RANDOM NUMBER GENERATOR -C MU=MEAN MU OF THE POISSON DISTRIBUTION -C OUTPUT: IGNPOI=SAMPLE FROM THE POISSON-(MU)-DISTRIBUTION -C -C -C -C MUPREV=PREVIOUS MU, MUOLD=MU AT LAST EXECUTION OF STEP P OR CASE B -C TABLES: COEFFICIENTS A0-A7 FOR STEP F. FACTORIALS FACT -C COEFFICIENTS A(K) - FOR PX = FK*V*V*SUM(A(K)*V**K)-DEL -C -C -C -C SEPARATION OF CASES A AND B -C -C .. Scalar Arguments .. - REAL mu -C .. -C .. Local Scalars .. - REAL a0,a1,a2,a3,a4,a5,a6,a7,b1,b2,c,c0,c1,c2,c3,d,del,difmuk,e, - + fk,fx,fy,g,muold,muprev,omega,p,p0,px,py,q,s,t,u,v,x,xx -C JJV I added a variable 'll' here - it is the 'l' for CASE A - INTEGER j,k,kflag,l,ll,m -C .. -C .. Local Arrays .. - REAL fact(10),pp(35) -C .. -C .. External Functions .. - REAL ranf,sexpo,snorm - EXTERNAL ranf,sexpo,snorm -C .. -C .. Intrinsic Functions .. - INTRINSIC abs,alog,exp,float,ifix,max0,min0,sign,sqrt -C .. -C JJV added this for case: mu unchanged -C .. Save statement .. - SAVE s, d, l, ll, omega, c3, c2, c1, c0, c, m, p, q, p0, - + a0, a1, a2, a3, a4, a5, a6, a7, fact, pp, muprev, muold -C .. -C JJV end addition - I am including vars in Data statements -C .. Data statements .. -C JJV changed initial values of MUPREV and MUOLD to -1.0E37 -C JJV if no one calls IGNPOI with MU = -1.0E37 the first time, -C JJV the code shouldn't break - DATA muprev,muold/-1.0E37,-1.0E37/ - DATA a0,a1,a2,a3,a4,a5,a6,a7/-.5,.3333333,-.2500068,.2000118, - + -.1661269,.1421878,-.1384794,.1250060/ - DATA fact/1.,1.,2.,6.,24.,120.,720.,5040.,40320.,362880./ - DATA pp/35*0.0/ -C .. -C .. Executable Statements .. - - IF (mu.EQ.muprev) GO TO 10 - IF (mu.LT.10.0) GO TO 120 -C -C C A S E A. (RECALCULATION OF S,D,LL IF MU HAS CHANGED) -C -C JJV This is the case where I changed 'l' to 'll' -C JJV Here 'll' is set once and used in a comparison once - - muprev = mu - s = sqrt(mu) - d = 6.0*mu*mu -C -C THE POISSON PROBABILITIES PK EXCEED THE DISCRETE NORMAL -C PROBABILITIES FK WHENEVER K >= M(MU). LL=IFIX(MU-1.1484) -C IS AN UPPER BOUND TO M(MU) FOR ALL MU >= 10 . -C - ll = ifix(mu-1.1484) -C -C STEP N. NORMAL SAMPLE - SNORM(IR) FOR STANDARD NORMAL DEVIATE -C - 10 g = mu + s*snorm() - IF (g.LT.0.0) GO TO 20 - ignpoi = ifix(g) -C -C STEP I. IMMEDIATE ACCEPTANCE IF IGNPOI IS LARGE ENOUGH -C - IF (ignpoi.GE.ll) RETURN -C -C STEP S. SQUEEZE ACCEPTANCE - SUNIF(IR) FOR (0,1)-SAMPLE U -C - fk = float(ignpoi) - difmuk = mu - fk - u = ranf() - IF (d*u.GE.difmuk*difmuk*difmuk) RETURN -C -C STEP P. PREPARATIONS FOR STEPS Q AND H. -C (RECALCULATIONS OF PARAMETERS IF NECESSARY) -C .3989423=(2*PI)**(-.5) .416667E-1=1./24. .1428571=1./7. -C THE QUANTITIES B1, B2, C3, C2, C1, C0 ARE FOR THE HERMITE -C APPROXIMATIONS TO THE DISCRETE NORMAL PROBABILITIES FK. -C C=.1069/MU GUARANTEES MAJORIZATION BY THE 'HAT'-FUNCTION. -C - 20 IF (mu.EQ.muold) GO TO 30 - muold = mu - omega = .3989423/s - b1 = .4166667E-1/mu - b2 = .3*b1*b1 - c3 = .1428571*b1*b2 - c2 = b2 - 15.*c3 - c1 = b1 - 6.*b2 + 45.*c3 - c0 = 1. - b1 + 3.*b2 - 15.*c3 - c = .1069/mu - 30 IF (g.LT.0.0) GO TO 50 -C -C 'SUBROUTINE' F IS CALLED (KFLAG=0 FOR CORRECT RETURN) -C - kflag = 0 - GO TO 70 -C -C STEP Q. QUOTIENT ACCEPTANCE (RARE CASE) -C - 40 IF (fy-u*fy.LE.py*exp(px-fx)) RETURN -C -C STEP E. EXPONENTIAL SAMPLE - SEXPO(IR) FOR STANDARD EXPONENTIAL -C DEVIATE E AND SAMPLE T FROM THE LAPLACE 'HAT' -C (IF T <= -.6744 THEN PK < FK FOR ALL MU >= 10.) -C - 50 e = sexpo() - u = ranf() - u = u + u - 1.0 - t = 1.8 + sign(e,u) - IF (t.LE. (-.6744)) GO TO 50 - ignpoi = ifix(mu+s*t) - fk = float(ignpoi) - difmuk = mu - fk -C -C 'SUBROUTINE' F IS CALLED (KFLAG=1 FOR CORRECT RETURN) -C - kflag = 1 - GO TO 70 -C -C STEP H. HAT ACCEPTANCE (E IS REPEATED ON REJECTION) -C - 60 IF (c*abs(u).GT.py*exp(px+e)-fy*exp(fx+e)) GO TO 50 - RETURN -C -C STEP F. 'SUBROUTINE' F. CALCULATION OF PX,PY,FX,FY. -C CASE IGNPOI .LT. 10 USES FACTORIALS FROM TABLE FACT -C - 70 IF (ignpoi.GE.10) GO TO 80 - px = -mu - py = mu**ignpoi/fact(ignpoi+1) - GO TO 110 -C -C CASE IGNPOI .GE. 10 USES POLYNOMIAL APPROXIMATION -C A0-A7 FOR ACCURACY WHEN ADVISABLE -C .8333333E-1=1./12. .3989423=(2*PI)**(-.5) -C - 80 del = .8333333E-1/fk - del = del - 4.8*del*del*del - v = difmuk/fk - IF (abs(v).LE.0.25) GO TO 90 - px = fk*alog(1.0+v) - difmuk - del - GO TO 100 - - 90 px = fk*v*v* (((((((a7*v+a6)*v+a5)*v+a4)*v+a3)*v+a2)*v+a1)*v+a0) - - + del - 100 py = .3989423/sqrt(fk) - 110 x = (0.5-difmuk)/s - xx = x*x - fx = -0.5*xx - fy = omega* (((c3*xx+c2)*xx+c1)*xx+c0) - IF (kflag.LE.0) GO TO 40 - GO TO 60 -C -C C A S E B. (START NEW TABLE AND CALCULATE P0 IF NECESSARY) -C -C JJV changed MUPREV assignment from 0.0 to initial value - 120 muprev = -1.0E37 - IF (mu.EQ.muold) GO TO 130 -C JJV added argument checker here - IF (mu.GE.0.0) GO TO 125 - WRITE (*,*) 'MU < 0 in IGNPOI - ABORT' - WRITE (*,*) 'Value of MU: ',mu - CALL XSTOPX ('MU < 0 in IGNPOI - ABORT') -C JJV added line label here - 125 muold = mu - m = max0(1,ifix(mu)) - l = 0 - p = exp(-mu) - q = p - p0 = p -C -C STEP U. UNIFORM SAMPLE FOR INVERSION METHOD -C - 130 u = ranf() - ignpoi = 0 - IF (u.LE.p0) RETURN -C -C STEP T. TABLE COMPARISON UNTIL THE END PP(L) OF THE -C PP-TABLE OF CUMULATIVE POISSON PROBABILITIES -C (0.458=PP(9) FOR MU=10) -C - IF (l.EQ.0) GO TO 150 - j = 1 - IF (u.GT.0.458) j = min0(l,m) - DO 140 k = j,l - IF (u.LE.pp(k)) GO TO 180 - 140 CONTINUE - IF (l.EQ.35) GO TO 130 -C -C STEP C. CREATION OF NEW POISSON PROBABILITIES P -C AND THEIR CUMULATIVES Q=PP(K) -C - 150 l = l + 1 - DO 160 k = l,35 - p = p*mu/float(k) - q = q + p - pp(k) = q - IF (u.LE.q) GO TO 170 - 160 CONTINUE - l = 35 - GO TO 130 - - 170 l = k - 180 ignpoi = k - RETURN - - END
--- a/liboctave/cruft/ranlib/ignuin.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,95 +0,0 @@ - INTEGER FUNCTION ignuin(low,high) -C********************************************************************** -C -C INTEGER FUNCTION IGNUIN( LOW, HIGH ) -C -C GeNerate Uniform INteger -C -C -C Function -C -C -C Generates an integer uniformly distributed between LOW and HIGH. -C -C -C Arguments -C -C -C LOW --> Low bound (inclusive) on integer value to be generated -C INTEGER LOW -C -C HIGH --> High bound (inclusive) on integer value to be generated -C INTEGER HIGH -C -C -C Note -C -C -C If (HIGH-LOW) > 2,147,483,561 prints error message on * unit and -C stops the program. -C -C********************************************************************** - -C IGNLGI generates integers between 1 and 2147483562 -C MAXNUM is 1 less than maximum generable value -C .. Parameters .. - INTEGER maxnum - PARAMETER (maxnum=2147483561) - CHARACTER*(*) err1,err2 - PARAMETER (err1='LOW > HIGH in IGNUIN', - + err2=' ( HIGH - LOW ) > 2,147,483,561 in IGNUIN') -C .. -C .. Scalar Arguments .. - INTEGER high,low -C .. -C .. Local Scalars .. - INTEGER err,ign,maxnow,range,ranp1 -C .. -C .. External Functions .. - INTEGER ignlgi - EXTERNAL ignlgi -C .. -C .. Intrinsic Functions .. - INTRINSIC mod -C .. -C .. Executable Statements .. - IF (.NOT. (low.GT.high)) GO TO 10 - err = 1 -C ABORT-PROGRAM - GO TO 80 - - 10 range = high - low - IF (.NOT. (range.GT.maxnum)) GO TO 20 - err = 2 -C ABORT-PROGRAM - GO TO 80 - - 20 IF (.NOT. (low.EQ.high)) GO TO 30 - ignuin = low - RETURN - -C Number to be generated should be in range 0..RANGE -C Set MAXNOW so that the number of integers in 0..MAXNOW is an -C integral multiple of the number in 0..RANGE - - 30 ranp1 = range + 1 - maxnow = (maxnum/ranp1)*ranp1 - 40 ign = ignlgi() - 1 - IF (.NOT. (ign.LE.maxnow)) GO TO 40 - ignuin = low + mod(ign,ranp1) - RETURN - - 80 IF (.NOT. (err.EQ.1)) GO TO 90 - WRITE (*,*) err1 - GO TO 100 - -C TO ABORT-PROGRAM - 90 WRITE (*,*) err2 - 100 WRITE (*,*) ' LOW: ',low,' HIGH: ',high - WRITE (*,*) ' Abort on Fatal ERROR' - IF (.NOT. (err.EQ.1)) GO TO 110 - CALL XSTOPX ('LOW > HIGH in IGNUIN') - - 110 CALL XSTOPX (' ( HIGH - LOW ) > 2,147,483,561 in IGNUIN') - - 120 END
--- a/liboctave/cruft/ranlib/initgn.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,93 +0,0 @@ - SUBROUTINE initgn(isdtyp) -C********************************************************************** -C -C SUBROUTINE INITGN(ISDTYP) -C INIT-ialize current G-e-N-erator -C -C Reinitializes the state of the current generator -C -C This is a transcription from Pascal to Fortran of routine -C Init_Generator from the paper -C -C L'Ecuyer, P. and Cote, S. "Implementing a Random Number Package -C with Splitting Facilities." ACM Transactions on Mathematical -C Software, 17:98-111 (1991) -C -C -C Arguments -C -C -C ISDTYP -> The state to which the generator is to be set -C -C ISDTYP = -1 => sets the seeds to their initial value -C ISDTYP = 0 => sets the seeds to the first value of -C the current block -C ISDTYP = 1 => sets the seeds to the first value of -C the next block -C -C INTEGER ISDTYP -C -C********************************************************************** -C .. Parameters .. - INTEGER numg - PARAMETER (numg=32) -C .. -C .. Scalar Arguments .. - INTEGER isdtyp -C .. -C .. Scalars in Common .. - INTEGER a1,a1vw,a1w,a2,a2vw,a2w,m1,m2 -C .. -C .. Arrays in Common .. - INTEGER cg1(numg),cg2(numg),ig1(numg),ig2(numg),lg1(numg), - + lg2(numg) - LOGICAL qanti(numg) -C .. -C .. Local Scalars .. - INTEGER g -C .. -C .. External Functions .. - LOGICAL qrgnin - INTEGER mltmod - EXTERNAL qrgnin,mltmod -C .. -C .. External Subroutines .. - EXTERNAL getcgn -C .. -C .. Common blocks .. - COMMON /globe/m1,m2,a1,a2,a1w,a2w,a1vw,a2vw,ig1,ig2,lg1,lg2,cg1, - + cg2,qanti -C .. -C .. Save statement .. - SAVE /globe/ -C .. -C .. Executable Statements .. -C Abort unless random number generator initialized - IF (qrgnin()) GO TO 10 - WRITE (*,*) ' INITGN called before random number generator ', - + ' initialized -- abort!' - CALL XSTOPX - + (' INITGN called before random number generator initialized') - - 10 CALL getcgn(g) - IF ((-1).NE. (isdtyp)) GO TO 20 - lg1(g) = ig1(g) - lg2(g) = ig2(g) - GO TO 50 - - 20 IF ((0).NE. (isdtyp)) GO TO 30 - CONTINUE - GO TO 50 -C do nothing - 30 IF ((1).NE. (isdtyp)) GO TO 40 - lg1(g) = mltmod(a1w,lg1(g),m1) - lg2(g) = mltmod(a2w,lg2(g),m2) - GO TO 50 - - 40 CALL XSTOPX ('ISDTYP NOT IN RANGE') - - 50 cg1(g) = lg1(g) - cg2(g) = lg2(g) - RETURN - - END
--- a/liboctave/cruft/ranlib/inrgcm.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,70 +0,0 @@ - SUBROUTINE inrgcm() -C********************************************************************** -C -C SUBROUTINE INRGCM() -C INitialize Random number Generator CoMmon -C -C -C Function -C -C -C Initializes common area for random number generator. This saves -C the nuisance of a BLOCK DATA routine and the difficulty of -C assuring that the routine is loaded with the other routines. -C -C********************************************************************** -C .. Parameters .. - INTEGER numg - PARAMETER (numg=32) -C .. -C .. Scalars in Common .. - INTEGER a1,a1vw,a1w,a2,a2vw,a2w,m1,m2 -C .. -C .. Arrays in Common .. - INTEGER cg1(numg),cg2(numg),ig1(numg),ig2(numg),lg1(numg), - + lg2(numg) - LOGICAL qanti(numg) -C .. -C .. Local Scalars .. - INTEGER i - LOGICAL qdum -C .. -C .. External Functions .. - LOGICAL qrgnsn - EXTERNAL qrgnsn -C .. -C .. Common blocks .. - COMMON /globe/m1,m2,a1,a2,a1w,a2w,a1vw,a2vw,ig1,ig2,lg1,lg2,cg1, - + cg2,qanti -C .. -C .. Save statement .. - SAVE /globe/ -C .. -C .. Executable Statements .. -C V=20; W=30; -C -C A1W = MOD(A1**(2**W),M1) A2W = MOD(A2**(2**W),M2) -C A1VW = MOD(A1**(2**(V+W)),M1) A2VW = MOD(A2**(2**(V+W)),M2) -C -C If V or W is changed A1W, A2W, A1VW, and A2VW need to be recomputed. -C An efficient way to precompute a**(2*j) MOD m is to start with -C a and square it j times modulo m using the function MLTMOD. -C - m1 = 2147483563 - m2 = 2147483399 - a1 = 40014 - a2 = 40692 - a1w = 1033780774 - a2w = 1494757890 - a1vw = 2082007225 - a2vw = 784306273 - DO 10,i = 1,numg - qanti(i) = .FALSE. - 10 CONTINUE -C -C Tell the world that common has been initialized -C - qdum = qrgnsn(.TRUE.) - RETURN - - END
--- a/liboctave/cruft/ranlib/lennob.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,36 +0,0 @@ - INTEGER FUNCTION lennob(string) - IMPLICIT INTEGER (a-p,r-z),LOGICAL (q) -C********************************************************************** -C -C INTEGER FUNCTION LENNOB( STRING ) -C LENgth NOt counting trailing Blanks -C -C -C Function -C -C -C Returns the length of STRING up to and including the last -C non-blank character. -C -C -C Arguments -C -C -C STRING --> String whose length not counting trailing blanks -C is returned. -C -C********************************************************************** - CHARACTER*(*) string - - end = len(string) - DO 20,i = end,1,-1 - IF (.NOT. (string(i:i).NE.' ')) GO TO 10 - lennob = i - RETURN - - 10 CONTINUE - 20 CONTINUE - lennob = 0 - RETURN - - END
--- a/liboctave/cruft/ranlib/mltmod.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,106 +0,0 @@ - INTEGER FUNCTION mltmod(a,s,m) -C********************************************************************** -C -C INTEGER FUNCTION MLTMOD(A,S,M) -C -C Returns (A*S) MOD M -C -C This is a transcription from Pascal to Fortran of routine -C MULtMod_Decompos from the paper -C -C L'Ecuyer, P. and Cote, S. "Implementing a Random Number Package -C with Splitting Facilities." ACM Transactions on Mathematical -C Software, 17:98-111 (1991) -C -C -C Arguments -C -C -C A, S, M --> -C INTEGER A,S,M -C -C********************************************************************** -C .. Parameters .. - INTEGER h - PARAMETER (h=32768) -C .. -C .. Scalar Arguments .. - INTEGER a,m,s -C .. -C .. Local Scalars .. - INTEGER a0,a1,k,p,q,qh,rh -C .. -C .. Executable Statements .. -C -C H = 2**((b-2)/2) where b = 32 because we are using a 32 bit -C machine. On a different machine recompute H -C - IF (.NOT. (a.LE.0.OR.a.GE.m.OR.s.LE.0.OR.s.GE.m)) GO TO 10 - WRITE (*,*) ' A, M, S out of order in MLTMOD - ABORT!' - WRITE (*,*) ' A = ',a,' S = ',s,' M = ',m - WRITE (*,*) ' MLTMOD requires: 0 < A < M; 0 < S < M' - CALL XSTOPX (' A, M, S out of order in MLTMOD - ABORT!') - - 10 IF (.NOT. (a.LT.h)) GO TO 20 - a0 = a - p = 0 - GO TO 120 - - 20 a1 = a/h - a0 = a - h*a1 - qh = m/h - rh = m - h*qh - IF (.NOT. (a1.GE.h)) GO TO 50 - a1 = a1 - h - k = s/qh - p = h* (s-k*qh) - k*rh - 30 IF (.NOT. (p.LT.0)) GO TO 40 - p = p + m - GO TO 30 - - 40 GO TO 60 - - 50 p = 0 -C -C P = (A2*S*H)MOD M -C - 60 IF (.NOT. (a1.NE.0)) GO TO 90 - q = m/a1 - k = s/q - p = p - k* (m-a1*q) - IF (p.GT.0) p = p - m - p = p + a1* (s-k*q) - 70 IF (.NOT. (p.LT.0)) GO TO 80 - p = p + m - GO TO 70 - - 80 CONTINUE - 90 k = p/qh -C -C P = ((A2*H + A1)*S)MOD M -C - p = h* (p-k*qh) - k*rh - 100 IF (.NOT. (p.LT.0)) GO TO 110 - p = p + m - GO TO 100 - - 110 CONTINUE - 120 IF (.NOT. (a0.NE.0)) GO TO 150 -C -C P = ((A2*H + A1)*H*S)MOD M -C - q = m/a0 - k = s/q - p = p - k* (m-a0*q) - IF (p.GT.0) p = p - m - p = p + a0* (s-k*q) - 130 IF (.NOT. (p.LT.0)) GO TO 140 - p = p + m - GO TO 130 - - 140 CONTINUE - 150 mltmod = p -C - RETURN - - END
--- a/liboctave/cruft/ranlib/module.mk Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,63 +0,0 @@ -RANLIB_SRC = \ - liboctave/cruft/ranlib/advnst.f \ - liboctave/cruft/ranlib/genbet.f \ - liboctave/cruft/ranlib/genchi.f \ - liboctave/cruft/ranlib/genexp.f \ - liboctave/cruft/ranlib/genf.f \ - liboctave/cruft/ranlib/gengam.f \ - liboctave/cruft/ranlib/genmn.f \ - liboctave/cruft/ranlib/genmul.f \ - liboctave/cruft/ranlib/gennch.f \ - liboctave/cruft/ranlib/gennf.f \ - liboctave/cruft/ranlib/gennor.f \ - liboctave/cruft/ranlib/genprm.f \ - liboctave/cruft/ranlib/genunf.f \ - liboctave/cruft/ranlib/getcgn.f \ - liboctave/cruft/ranlib/getsd.f \ - liboctave/cruft/ranlib/ignbin.f \ - liboctave/cruft/ranlib/ignlgi.f \ - liboctave/cruft/ranlib/ignnbn.f \ - liboctave/cruft/ranlib/ignpoi.f \ - liboctave/cruft/ranlib/ignuin.f \ - liboctave/cruft/ranlib/initgn.f \ - liboctave/cruft/ranlib/inrgcm.f \ - liboctave/cruft/ranlib/lennob.f \ - liboctave/cruft/ranlib/mltmod.f \ - liboctave/cruft/ranlib/phrtsd.f \ - liboctave/cruft/ranlib/qrgnin.f \ - liboctave/cruft/ranlib/ranf.f \ - liboctave/cruft/ranlib/setall.f \ - liboctave/cruft/ranlib/setant.f \ - liboctave/cruft/ranlib/setgmn.f \ - liboctave/cruft/ranlib/setsd.f \ - liboctave/cruft/ranlib/sexpo.f \ - liboctave/cruft/ranlib/sgamma.f \ - liboctave/cruft/ranlib/snorm.f \ - liboctave/cruft/ranlib/wrap.f - -noinst_LTLIBRARIES += liboctave/cruft/ranlib/libranlib.la - -liboctave_cruft_ranlib_libranlib_la_SOURCES = $(RANLIB_SRC) - -liboctave_cruft_ranlib_libranlib_la_DEPENDENCIES = liboctave/cruft/ranlib/ranlib.def - -## Special rules for files which must be built before compilation -## ranlib directory may not exist in VPATH build; create it if necessary. -liboctave/cruft/ranlib/ranlib.def: $(RANLIB_SRC) build-aux/mk-f77-def.sh | liboctave/cruft/ranlib/$(octave_dirstamp) - $(AM_V_GEN)rm -f $@-t $@ && \ - $(SHELL) build-aux/mk-f77-def.sh $(srcdir) $(RANLIB_SRC) > $@-t && \ - mv $@-t $@ - -liboctave_liboctave_la_LIBADD += liboctave/cruft/ranlib/libranlib.la - -liboctave_EXTRA_DIST += \ - liboctave/cruft/ranlib/Basegen.doc \ - liboctave/cruft/ranlib/HOWTOGET \ - liboctave/cruft/ranlib/README \ - liboctave/cruft/ranlib/randlib.chs \ - liboctave/cruft/ranlib/randlib.fdoc \ - liboctave/cruft/ranlib/tstbot.for \ - liboctave/cruft/ranlib/tstgmn.for \ - liboctave/cruft/ranlib/tstmid.for - -DIRSTAMP_FILES += liboctave/cruft/ranlib/$(octave_dirstamp)
--- a/liboctave/cruft/ranlib/phrtsd.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,92 +0,0 @@ - SUBROUTINE phrtsd(phrase,seed1,seed2) -C********************************************************************** -C -C SUBROUTINE PHRTSD( PHRASE, SEED1, SEED2 ) -C PHRase To SeeDs -C -C -C Function -C -C -C Uses a phrase (character string) to generate two seeds for the RGN -C random number generator. -C -C -C Arguments -C -C -C PHRASE --> Phrase to be used for random number generation -C CHARACTER*(*) PHRASE -C -C SEED1 <-- First seed for RGN generator -C INTEGER SEED1 -C -C SEED2 <-- Second seed for RGN generator -C INTEGER SEED2 -C -C -C Note -C -C -C Trailing blanks are eliminated before the seeds are generated. -C -C Generated seed values will fall in the range 1..2^30 -C (1..1,073,741,824) -C -C********************************************************************** -C .. Parameters .. - CHARACTER*(*) table - PARAMETER (table='abcdefghijklmnopqrstuvwxyz'// - + 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'//'0123456789'// - + '!@#$%^&*()_+[];:''"<>?,./') - INTEGER twop30 - PARAMETER (twop30=1073741824) - INTEGER sixty4 - PARAMETER (sixty4=64) -C .. -C .. Scalar Arguments .. - INTEGER seed1,seed2 - CHARACTER phrase* (*) -C .. -C .. Local Scalars .. - INTEGER i,ichr,j,lphr,idxval -C .. -C .. Local Arrays .. - INTEGER shift(0:4),values(5) -C .. -C .. External Functions .. - INTEGER lennob - EXTERNAL lennob -C .. -C .. Intrinsic Functions .. - INTRINSIC index,mod -C .. -C JJV added Save statement for variable in Data statement -C .. Save statements .. - SAVE shift -C JJV end addition -C .. -C .. Data statements .. - DATA shift/1,64,4096,262144,16777216/ -C .. -C .. Executable Statements .. - seed1 = 1234567890 - seed2 = 123456789 - lphr = lennob(phrase) - IF (lphr.LT.1) RETURN - DO 30,i = 1,lphr - idxval = index(table,phrase(i:i)) - ichr = mod(idxval,sixty4) - IF (ichr.EQ.0) ichr = 63 - DO 10,j = 1,5 - values(j) = ichr - j - IF (values(j).LT.1) values(j) = values(j) + 63 - 10 CONTINUE - DO 20,j = 1,5 - seed1 = mod(seed1+shift(j-1)*values(j),twop30) - seed2 = mod(seed2+shift(j-1)*values(6-j),twop30) - 20 CONTINUE - 30 CONTINUE - RETURN - - END
--- a/liboctave/cruft/ranlib/qrgnin.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,48 +0,0 @@ - LOGICAL FUNCTION qrgnin() -C********************************************************************** -C -C LOGICAL FUNCTION QRGNIN() -C Q Random GeNerators INitialized? -C -C A trivial routine to determine whether or not the random -C number generator has been initialized. Returns .TRUE. if -C it has, else .FALSE. -C -C********************************************************************** -C .. Scalar Arguments .. - LOGICAL qvalue -C .. -C .. Local Scalars .. - LOGICAL qinit -C .. -C .. Entry Points .. - LOGICAL qrgnsn -C .. -C .. Save statement .. - SAVE qinit -C .. -C .. Data statements .. - DATA qinit/.FALSE./ -C .. -C .. Executable Statements .. - qrgnin = qinit - RETURN - - ENTRY qrgnsn(qvalue) -C********************************************************************** -C -C LOGICAL FUNCTION QRGNSN( QVALUE ) -C Q Random GeNerators Set whether iNitialized -C -C Sets state of whether random number generator is initialized -C to QVALUE. -C -C This routine is actually an entry in QRGNIN, hence it is a -C logical function. It returns the (meaningless) value .TRUE. -C -C********************************************************************** - qinit = qvalue - qrgnsn = .TRUE. - RETURN - - END
--- a/liboctave/cruft/ranlib/randlib.chs Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,362 +0,0 @@ - SUMMARY OF ROUTINES IN RANDLIB - -0. Base Level Routines to Set and Obtain Values of Seeds - -(These should be the only base level routines used by those who don't -need multiple generators with blocks of numbers.) - -C********************************************************************** -C -C SUBROUTINE SETALL(ISEED1,ISEED2) -C SET ALL random number generators -C INTEGER ISEED1, ISEED2 -C -C********************************************************************** -C********************************************************************** -C -C SUBROUTINE GETSD(ISEED1,ISEED2) -C GET SeeD -C INTEGER ISEED1, ISEED2 -C -C Returns the value of two integer seeds of the current generator -C in ISEED1, ISEED2 -C -C********************************************************************** - -I. Higher Level Routines - -C********************************************************************** -C -C REAL FUNCTION GENBET( A, B ) -C GeNerate BETa random deviate -C REAL A,B -C -C Returns a single random deviate from the beta distribution with -C parameters A and B. The density of the beta is -C x^(a-1) * (1-x)^(b-1) / B(a,b) for 0 < x < 1 -C -C********************************************************************** -C********************************************************************** -C -C REAL FUNCTION GENCHI( DF ) -C Generate random value of CHIsquare variable -C REAL DF -C -C Generates random deviate from the distribution of a chisquare -C with DF degrees of freedom random variable. -C -C********************************************************************** -C********************************************************************** -C -C REAL FUNCTION GENEXP( AV ) -C GENerate EXPonential random deviate -C REAL AV -C -C Generates a single random deviate from an exponential -C distribution with mean AV. -C -C********************************************************************** -C********************************************************************** -C -C REAL FUNCTION GENF( DFN, DFD ) -C GENerate random deviate from the F distribution -C REAL DFN, DFD -C -C Generates a random deviate from the F (variance ratio) -C distribution with DFN degrees of freedom in the numerator -C and DFD degrees of freedom in the denominator. -C -C********************************************************************** -C********************************************************************** -C -C REAL FUNCTION GENGAM( A, R ) -C GENerates random deviates from GAMma distribution -C REAL A, R -C -C Generates random deviates from the gamma distribution whose -C density is -C (A**R)/Gamma(R) * X**(R-1) * Exp(-A*X) -C -C********************************************************************** -C********************************************************************** -C -C SUBROUTINE GENMN(PARM,X,WORK) -C GENerate Multivariate Normal random deviate -C REAL PARM(*), X(*), WORK(*) -C -C PARM is set by SETGMN which must be called prior to GENMN. The -C generated deviates are placed in X. WORK is a work array of the -C same size as X. -C -C********************************************************************** -C********************************************************************** -C -C SUBROUTINE GENMUL( N, P, NCAT, IX ) -C GENerate MULtinomial random deviate -C REAL P(*) -C INTEGER N, NCAT, IX(*) -C -C Generates deviates from a Multinomial distribution with NCAT -C categories. P specifies the probability of an event in each -C category. The generated deviates are placed in IX. -C -C********************************************************************** -C********************************************************************** -C -C REAL FUNCTION GENNCH( DF, XNONC ) -C Generate random value of Noncentral CHIsquare variable -C REAL DF, XNONC -C -C Generates random deviate from the distribution of a noncentral -C chisquare with DF degrees of freedom and noncentrality parameter -C XNONC. -C -C********************************************************************** -C********************************************************************** -C -C REAL FUNCTION GENNF( DFN, DFD, XNONC ) -C GENerate random deviate from the Noncentral F distribution -C REAL DFN, DFD, XNONC -C -C Generates a random deviate from the noncentral F (variance ratio) -C distribution with DFN degrees of freedom in the numerator, and DFD -C degrees of freedom in the denominator, and noncentrality parameter -C XNONC. -C -C********************************************************************** -C********************************************************************** -C -C REAL FUNCTION GENNOR( AV, SD ) -C GENerate random deviate from a NORmal distribution -C REAL AV, SD -C -C Generates a single random deviate from a normal distribution -C with mean, AV, and standard deviation, SD. -C -C********************************************************************** -C********************************************************************** -C -C SUBROUTINE GENPRM( IARRAY, LARRAY ) -C GENerate random PeRMutation of iarray -C INTEGER IARRAY(LARRAY), LARRAY -C -C********************************************************************** -C********************************************************************** -C -C REAL FUNCTION GENUNF( LOW, HIGH ) -C GeNerate Uniform Real between LOW and HIGH -C REAL LOW, HIGH -C -C********************************************************************** -C********************************************************************** -C -C INTEGER FUNCTION IGNBIN( N, P ) -C GENerate BINomial random deviate -C INTEGER N -C REAL P -C -C Returns a single random deviate from a binomial -C distribution whose number of trials is N and whose -C probability of an event in each trial is P. -C -C********************************************************************** -C********************************************************************** -C -C INTEGER FUNCTION IGNNBN( N, P ) -C GENerate Negative BiNomial random deviate -C INTEGER N -C REAL P -C -C Returns a single random deviate from a negative binomial -C distribution with number of events N and whose -C probability of an event in each trial is P. -C -C********************************************************************** -C********************************************************************** -C -C INTEGER FUNCTION IGNPOI( AV ) -C GENerate POIsson random deviate -C REAL AV -C -C Generates a single random deviate from a Poisson -C distribution with mean AV. -C -C********************************************************************** -C********************************************************************** -C -C INTEGER FUNCTION IGNUIN( LOW, HIGH ) -C GeNerate Uniform INteger -C INTEGER LOW, HIGH -C -C Generates an integer uniformly distributed between LOW and HIGH. -C -C********************************************************************** -C********************************************************************** -C -C SUBROUTINE PHRTSD( PHRASE, SEED1, SEED2 ) -C PHRase To SeeDs -C CHARACTER*(*) PHRASE -C INTEGER SEED1, SEED2 -C -C Uses a phrase (character string) to generate two seeds for the RGN -C random number generator. -C -C********************************************************************** -C********************************************************************** -C -C REAL FUNCTION RANF() -C RANDom number generator as a Function -C -C Returns a random floating point number from a uniform distribution -C over 0 - 1 (endpoints of this interval are not returned) using the -C current generator -C -C********************************************************************** -C********************************************************************** -C -C SUBROUTINE SETGMN( MEANV, COVM, LDCOVM, P, PARM) -C SET Generate Multivariate Normal random deviate -C INTEGER LDCOVM, P -C REAL MEANV(P), COVM(LDCOVM,P), PARM(P*(P+3)/2 + 1) -C -C P is the length of normal vectors to be generated, MEANV -C is the vector of their means and COVM(1:P,1:P) is their variance -C covariance matrix. LDCOVM is the leading actual dimension of -C COVM, which this routine needs to know although only the -C (1:P,1:P) slice of COVM is used. -C Places information necessary to generate the deviates in PARM. -C -C********************************************************************** - -II. Uniform Generator and Associated Routines - - - A. SETTING THE SEED OF ALL GENERATORS - -C********************************************************************** -C -C SUBROUTINE SETALL(ISEED1,ISEED2) -C SET ALL random number generators -C INTEGER ISEED1, ISEED2 -C -C********************************************************************** - - B. OBTAINING RANDOM NUMBERS - -C********************************************************************** -C -C INTEGER FUNCTION IGNLGI() -C GeNerate LarGe Integer -C -C Returns a random integer following a uniform distribution over -C (1, 2147483562) using the current generator. -C -C********************************************************************** - -C********************************************************************** -C -C REAL FUNCTION RANF() -C RANDom number generator as a Function -C -C Returns a random floating point number from a uniform distribution -C over 0 - 1 (endpoints of this interval are not returned) using the -C current generator -C -C********************************************************************** - - C. SETTING AND OBTAINING THE NUMBER OF THE CURRENT GENERATOR - -C********************************************************************** -C -C SUBROUTINE SETCGN( G ) -C Set GeNerator -C INTEGER G -C -C Sets the current generator to G. All references to a generator -C are to the current generator. -C -C********************************************************************** - -C********************************************************************** -C -C SUBROUTINE GETCGN(G) -C GET Current GeNerator -C INTEGER G -C -C Returns in G the number of the current random number generator -C -C********************************************************************** - - D. OBTAINING OR CHANGING SEEDS IN CURRENT GENERATOR - -C********************************************************************** -C -C SUBROUTINE ADVNST(K) -C ADV-a-N-ce ST-ate -C INTEGER K -C -C Advances the state of the current generator by 2^K values and -C resets the initial seed to that value. -C -C********************************************************************** - -C********************************************************************** -C -C SUBROUTINE GETSD(ISEED1,ISEED2) -C GET SeeD -C INTEGER ISEED1, ISEED2 -C -C Returns the value of two integer seeds of the current generator -C in ISEED1, ISEED2 -C -C********************************************************************** - -C********************************************************************** -C -C SUBROUTINE INITGN(ISDTYP) -C INIT-ialize current G-e-N-erator -C -C INTEGER ISDTYP The state to which the generator is to be set -C ISDTYP = -1 => sets the seeds to their initial value -C ISDTYP = 0 => sets the seeds to the first value of -C the current block -C ISDTYP = 1 => sets the seeds to the first value of -C the next block -C -C********************************************************************** - -C********************************************************************** -C -C SUBROUTINE SETSD(ISEED1,ISEED2) -C SET S-ee-D of current generator -C -C Resets the initial seed of the current generator to ISEED1 and -C ISEED2. The seeds of the other generators remain unchanged. -C -C********************************************************************** - - E. MISCELLANY - -C********************************************************************** -C -C INTEGER FUNCTION MLTMOD(A,S,M) -C Returns (A*S) MOD M -C INTEGER A, S, M -C -C********************************************************************** - -C********************************************************************** -C -C SUBROUTINE SETANT(QVALUE) -C SET ANTithetic -C LOGICAL QVALUE -C -C Sets whether the current generator produces antithetic values. If -C X is the value normally returned from a uniform [0,1] random -C number generator then 1 - X is the antithetic value. If X is the -C value normally returned from a uniform [0,N] random number -C generator then N - 1 - X is the antithetic value. -C -C All generators are initialized to NOT generate antithetic values. -C -C**********************************************************************
--- a/liboctave/cruft/ranlib/randlib.fdoc Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,961 +0,0 @@ - - - - - - - - - - - - RANDLIB - - Library of Fortran Routines for Random Number Generation - - - - - - - - - Full Documentation of Each Routine - - - - - - - - - Compiled and Written by: - - Barry W. Brown - James Lovato - - - - - - - - - - - Department of Biomathematics, Box 237 - The University of Texas, M.D. Anderson Cancer Center - 1515 Holcombe Boulevard - Houston, TX 77030 - - - This work was supported by grant CA-16672 from the National Cancer Institute. - -C********************************************************************** -C -C SUBROUTINE ADVNST(K) -C ADV-a-N-ce ST-ate -C -C Advances the state of the current generator by 2^K values and -C resets the initial seed to that value. -C -C This is a transcription from Pascal to Fortran of routine -C Advance_State from the paper -C -C L'Ecuyer, P. and Cote, S. "Implementing a Random Number Package -C with Splitting Facilities." ACM Transactions on Mathematical -C Software, 17:98-111 (1991) -C -C -C Arguments -C -C -C K -> The generator is advanced by2^K values -C INTEGER K -C -C********************************************************************** -C********************************************************************** -C -C REAL FUNCTION GENBET( A, B ) -C GeNerate BETa random deviate -C -C -C Function -C -C -C Returns a single random deviate from the beta distribution with -C parameters A and B. The density of the beta is -C x^(a-1) * (1-x)^(b-1) / B(a,b) for 0 < x < 1 -C -C -C Arguments -C -C -C A --> First parameter of the beta distribution -C REAL A -C (A >= 1.0E-37) -C -C B --> Second parameter of the beta distribution -C REAL B -C (B >= 1.0E-37) -C -C -C Method -C -C -C R. C. H. Cheng -C Generating Beta Variables with Nonintegral Shape Parameters -C Communications of the ACM, 21:317-322 (1978) -C (Algorithms BB and BC) -C -C********************************************************************** -C********************************************************************** -C -C REAL FUNCTION GENCHI( DF ) -C Generate random value of CHIsquare variable -C -C -C Function -C -C -C Generates random deviate from the distribution of a chisquare -C with DF degrees of freedom random variable. -C -C -C Arguments -C -C -C DF --> Degrees of freedom of the chisquare -C (Must be positive) -C REAL DF -C -C -C Method -C -C -C Uses relation between chisquare and gamma. -C -C********************************************************************** -C********************************************************************** -C -C REAL FUNCTION GENEXP( AV ) -C -C GENerate EXPonential random deviate -C -C -C Function -C -C -C Generates a single random deviate from an exponential -C distribution with mean AV. -C -C -C Arguments -C -C -C AV --> The mean of the exponential distribution from which -C a random deviate is to be generated. -C REAL AV -C (AV >= 0) -C -C GENEXP <-- The random deviate. -C REAL GENEXP -C -C -C Method -C -C -C Renames SEXPO from TOMS as slightly modified by BWB to use RANF -C instead of SUNIF. -C -C For details see: -C -C Ahrens, J.H. and Dieter, U. -C Computer Methods for Sampling From the -C Exponential and Normal Distributions. -C Comm. ACM, 15,10 (Oct. 1972), 873 - 882. -C -C********************************************************************** -C********************************************************************** -C -C REAL FUNCTION GENF( DFN, DFD ) -C GENerate random deviate from the F distribution -C -C -C Function -C -C -C Generates a random deviate from the F (variance ratio) -C distribution with DFN degrees of freedom in the numerator -C and DFD degrees of freedom in the denominator. -C -C -C Arguments -C -C -C DFN --> Numerator degrees of freedom -C (Must be positive) -C REAL DFN -C DFD --> Denominator degrees of freedom -C (Must be positive) -C REAL DFD -C -C -C Method -C -C -C Directly generates ratio of chisquare variates -C -C********************************************************************** -C********************************************************************** -C -C REAL FUNCTION GENGAM( A, R ) -C GENerates random deviates from GAMma distribution -C -C -C Function -C -C -C Generates random deviates from the gamma distribution whose -C density is -C (A**R)/Gamma(R) * X**(R-1) * Exp(-A*X) -C -C -C Arguments -C -C -C A --> Location parameter of Gamma distribution -C REAL A ( A > 0 ) -C -C R --> Shape parameter of Gamma distribution -C REAL R ( R > 0 ) -C -C -C Method -C -C -C Renames SGAMMA from TOMS as slightly modified by BWB to use RANF -C instead of SUNIF. -C -C For details see: -C (Case R >= 1.0) -C Ahrens, J.H. and Dieter, U. -C Generating Gamma Variates by a -C Modified Rejection Technique. -C Comm. ACM, 25,1 (Jan. 1982), 47 - 54. -C Algorithm GD -C -C (Case 0.0 < R < 1.0) -C Ahrens, J.H. and Dieter, U. -C Computer Methods for Sampling from Gamma, -C Beta, Poisson and Binomial Distributions. -C Computing, 12 (1974), 223-246/ -C Adapted algorithm GS. -C -C********************************************************************** -C********************************************************************** -C -C SUBROUTINE GENMN(PARM,X,WORK) -C GENerate Multivariate Normal random deviate -C -C -C Arguments -C -C -C PARM --> Parameters needed to generate multivariate normal -C deviates (MEANV and Cholesky decomposition of -C COVM). Set by a previous call to SETGMN. -C -C 1 : 1 - size of deviate, P -C 2 : P + 1 - mean vector -C P+2 : P*(P+3)/2 + 1 - upper half of cholesky -C decomposition of cov matrix -C REAL PARM(*) -C -C X <-- Vector deviate generated. -C REAL X(P) -C -C WORK <--> Scratch array -C REAL WORK(P) -C -C -C Method -C -C -C 1) Generate P independent standard normal deviates - Ei ~ N(0,1) -C -C 2) SETGMN uses Cholesky decomposition find A s.t. trans(A)*A = COV -C -C 3) Generate trans(A)*E + MEANV ~ N(MEANV,COVM) -C -C********************************************************************** -C********************************************************************** -C -C SUBROUTINE GENMUL( N, P, NCAT, IX ) -C GENerate an observation from the MULtinomial distribution -C -C -C Arguments -C -C -C N --> Number of events that will be classified into one of -C the categories 1..NCAT -C INTEGER N -C (N >= 0) -C -C P --> Vector of probabilities. P(i) is the probability that -C an event will be classified into category i. Thus, P(i) -C must be [0,1]. Only the first NCAT-1 P(i) must be defined -C since P(NCAT) is 1.0 minus the sum of the first -C NCAT-1 P(i). -C REAL P(NCAT-1) -C -C NCAT --> Number of categories. Length of P and IX. -C INTEGER NCAT -C (NCAT > 1) -C -C IX <-- Observation from multinomial distribution. All IX(i) -C will be nonnegative and their sum will be N. -C INTEGER IX(NCAT) -C -C -C Method -C -C -C Algorithm from page 559 of -C -C Devroye, Luc -C -C Non-Uniform Random Variate Generation. Springer-Verlag, -C New York, 1986. -C -C********************************************************************** -C********************************************************************** -C -C REAL FUNCTION GENNCH( DF, XNONC ) -C Generate random value of Noncentral CHIsquare variable -C -C -C Function -C -C -C -C Generates random deviate from the distribution of a noncentral -C chisquare with DF degrees of freedom and noncentrality parameter -C XNONC. -C -C -C Arguments -C -C -C DF --> Degrees of freedom of the chisquare -C (Must be >= 1.0) -C REAL DF -C -C XNONC --> Noncentrality parameter of the chisquare -C (Must be >= 0.0) -C REAL XNONC -C -C -C Method -C -C -C Uses fact that noncentral chisquare is the sum of a chisquare -C deviate with DF-1 degrees of freedom plus the square of a normal -C deviate with mean XNONC and standard deviation 1. -C -C********************************************************************** -C********************************************************************** -C -C REAL FUNCTION GENNF( DFN, DFD, XNONC ) -C GENerate random deviate from the Noncentral F distribution -C -C -C Function -C -C -C Generates a random deviate from the noncentral F (variance ratio) -C distribution with DFN degrees of freedom in the numerator, and DFD -C degrees of freedom in the denominator, and noncentrality parameter -C XNONC. -C -C -C Arguments -C -C -C DFN --> Numerator degrees of freedom -C (Must be >= 1.0) -C REAL DFN -C DFD --> Denominator degrees of freedom -C (Must be positive) -C REAL DFD -C -C XNONC --> Noncentrality parameter -C (Must be nonnegative) -C REAL XNONC -C -C -C Method -C -C -C Directly generates ratio of noncentral numerator chisquare variate -C to central denominator chisquare variate. -C -C********************************************************************** -C********************************************************************** -C -C REAL FUNCTION GENNOR( AV, SD ) -C -C GENerate random deviate from a NORmal distribution -C -C -C Function -C -C -C Generates a single random deviate from a normal distribution -C with mean, AV, and standard deviation, SD. -C -C -C Arguments -C -C -C AV --> Mean of the normal distribution. -C REAL AV -C -C SD --> Standard deviation of the normal distribution. -C REAL SD -C (SD >= 0) -C -C GENNOR <-- Generated normal deviate. -C REAL GENNOR -C -C -C Method -C -C -C Renames SNORM from TOMS as slightly modified by BWB to use RANF -C instead of SUNIF. -C -C For details see: -C Ahrens, J.H. and Dieter, U. -C Extensions of Forsythe's Method for Random -C Sampling from the Normal Distribution. -C Math. Comput., 27,124 (Oct. 1973), 927 - 937. -C -C -C********************************************************************** -C********************************************************************** -C -C SUBROUTINE GENPRM( IARRAY, LARRAY ) -C GENerate random PeRMutation of iarray -C -C -C Arguments -C -C -C IARRAY <--> On output IARRAY is a random permutation of its -C value on input -C INTEGER IARRAY( LARRAY ) -C -C LARRAY <--> Length of IARRAY -C INTEGER LARRAY -C -C********************************************************************** -C********************************************************************** -C -C REAL FUNCTION GENUNF( LOW, HIGH ) -C -C GeNerate Uniform Real between LOW and HIGH -C -C -C Function -C -C -C Generates a real uniformly distributed between LOW and HIGH. -C -C -C Arguments -C -C -C LOW --> Low bound (exclusive) on real value to be generated -C REAL LOW -C -C HIGH --> High bound (exclusive) on real value to be generated -C REAL HIGH -C -C********************************************************************** -C********************************************************************** -C -C SUBROUTINE GETCGN(G) -C Get GeNerator -C -C Returns in G the number of the current random number generator -C -C -C Arguments -C -C -C G <-- Number of the current random number generator (1..32) -C INTEGER G -C -C********************************************************************** -C********************************************************************** -C -C SUBROUTINE GETSD(ISEED1,ISEED2) -C GET SeeD -C -C Returns the value of two integer seeds of the current generator -C -C This is a transcription from Pascal to Fortran of routine -C Get_State from the paper -C -C L'Ecuyer, P. and Cote, S. "Implementing a Random Number Package -C with Splitting Facilities." ACM Transactions on Mathematical -C Software, 17:98-111 (1991) -C -C -C Arguments -C -C -C -C ISEED1 <- First integer seed of generator G -C INTEGER ISEED1 -C -C ISEED2 <- Second integer seed of generator G -C INTEGER ISEED1 -C -C********************************************************************** -C********************************************************************** -C -C INTEGER FUNCTION IGNBIN( N, P ) -C -C GENerate BINomial random deviate -C -C -C Function -C -C -C Generates a single random deviate from a binomial -C distribution whose number of trials is N and whose -C probability of an event in each trial is P. -C -C -C Arguments -C -C -C N --> The number of trials in the binomial distribution -C from which a random deviate is to be generated. -C INTEGER N -C (N >= 0) -C -C P --> The probability of an event in each trial of the -C binomial distribution from which a random deviate -C is to be generated. -C REAL P -C (0.0 <= P <= 1.0) -C -C IGNBIN <-- A random deviate yielding the number of events -C from N independent trials, each of which has -C a probability of event P. -C INTEGER IGNBIN -C -C -C Note -C -C -C Uses RANF so the value of the seeds, ISEED1 and ISEED2 must be set -C by a call similar to the following -C DUM = RANSET( ISEED1, ISEED2 ) -C -C -C Method -C -C -C This is algorithm BTPE from: -C -C Kachitvichyanukul, V. and Schmeiser, B. W. -C -C Binomial Random Variate Generation. -C Communications of the ACM, 31, 2 -C (February, 1988) 216. -C -C********************************************************************** -C********************************************************************** -C -C INTEGER FUNCTION IGNNBN( N, P ) -C -C GENerate Negative BiNomial random deviate -C -C -C Function -C -C -C Generates a single random deviate from a negative binomial -C distribution. -C -C -C Arguments -C -C -C N --> Required number of events. -C INTEGER N -C (N > 0) -C -C P --> The probability of an event during a Bernoulli trial. -C REAL P -C (0.0 < P < 1.0) -C -C -C -C Method -C -C -C Algorithm from page 480 of -C -C Devroye, Luc -C -C Non-Uniform Random Variate Generation. Springer-Verlag, -C New York, 1986. -C -C********************************************************************** -C********************************************************************** -C -C INTEGER FUNCTION IGNLGI() -C GeNerate LarGe Integer -C -C Returns a random integer following a uniform distribution over -C (1, 2147483562) using the current generator. -C -C This is a transcription from Pascal to Fortran of routine -C Random from the paper -C -C L'Ecuyer, P. and Cote, S. "Implementing a Random Number Package -C with Splitting Facilities." ACM Transactions on Mathematical -C Software, 17:98-111 (1991) -C -C********************************************************************** -C********************************************************************** -C -C INTEGER FUNCTION IGNPOI( MU ) -C -C GENerate POIsson random deviate -C -C -C Function -C -C -C Generates a single random deviate from a Poisson -C distribution with mean MU. -C -C -C Arguments -C -C -C MU --> The mean of the Poisson distribution from which -C a random deviate is to be generated. -C REAL MU -C (MU >= 0.0) -C -C IGNPOI <-- The random deviate. -C REAL IGNPOI (non-negative) -C -C -C Method -C -C -C Renames KPOIS from TOMS as slightly modified by BWB to use RANF -C instead of SUNIF. -C -C For details see: -C -C Ahrens, J.H. and Dieter, U. -C Computer Generation of Poisson Deviates -C From Modified Normal Distributions. -C ACM Trans. Math. Software, 8, 2 -C (June 1982),163-179 -C -C********************************************************************** -C********************************************************************** -C -C INTEGER FUNCTION IGNUIN( LOW, HIGH ) -C -C GeNerate Uniform INteger -C -C -C Function -C -C -C Generates an integer uniformly distributed between LOW and HIGH. -C -C -C Arguments -C -C -C LOW --> Low bound (inclusive) on integer value to be generated -C INTEGER LOW -C -C HIGH --> High bound (inclusive) on integer value to be generated -C INTEGER HIGH -C -C -C Note -C -C -C If (HIGH-LOW) > 2,147,483,561 prints error message on * unit and -C stops the program. -C -C********************************************************************** -C********************************************************************** -C -C SUBROUTINE INITGN(ISDTYP) -C INIT-ialize current G-e-N-erator -C -C Reinitializes the state of the current generator -C ISDTYP = -1 => sets the state to its initial seed -C ISDTYP = 0 => sets the state to its last (previous) seed -C ISDTYP = 1 => sets the state to a new seed 2^w values -C from its last seed -C -C This is a transcription from Pascal to Fortran of routine -C Init_Generator from the paper -C -C L'Ecuyer, P. and Cote, S. "Implementing a Random Number Package -C with Splitting Facilities." ACM Transactions on Mathematical -C Software, 17:98-111 (1991) -C -C -C Arguments -C -C -C ISDTYP -> The state to which the generator is to be set -C -C INTEGER ISDTYP -C -C********************************************************************** -C********************************************************************** -C -C SUBROUTINE INRGCM() -C INitialize Random number Generator CoMmon -C -C -C Function -C -C -C Initializes common area for random number generator. This saves -C the nuisance of a BLOCK DATA routine and the difficulty of -C assuring that the routine is loaded with the other routines. -C -C********************************************************************** -C********************************************************************** -C -C INTEGER FUNCTION MLTMOD(A,S,M) -C -C Returns (A*S) MOD M -C -C This is a transcription from Pascal to Fortran of routine -C MULtMod_Decompos from the paper -C -C L'Ecuyer, P. and Cote, S. "Implementing a Random Number Package -C with Splitting Facilities." ACM Transactions on Mathematical -C Software, 17:98-111 (1991) -C -C -C Arguments -C -C -C A, S, M --> -C INTEGER A,S,M -C -C********************************************************************** -C********************************************************************** -C -C SUBROUTINE PHRTSD( PHRASE, SEED1, SEED2 ) -C PHRase To SeeDs -C -C -C Function -C -C -C Uses a phrase (character string) to generate two seeds for the RGN -C random number generator. -C -C -C Arguments -C -C -C PHRASE --> Phrase to be used for random number generation -C CHARACTER*(*) PHRASE -C -C SEED1 <-- First seed for RGN generator -C INTEGER SEED1 -C -C SEED2 <-- Second seed for RGN generator -C INTEGER SEED2 -C -C -C Note -C -C -C Trailing blanks are eliminated before the seeds are generated. -C -C Generated seed values will fall in the range 1..2^30 -C (1..1,073,741,824) -C -C********************************************************************** -C********************************************************************** -C -C REAL FUNCTION RANF() -C RANDom number generator as a Function -C -C Returns a random floating point number from a uniform distribution -C over 0 - 1 (endpoints of this interval are not returned) using the -C current generator -C -C This is a transcription from Pascal to Fortran of routine -C Uniform_01 from the paper -C -C L'Ecuyer, P. and Cote, S. "Implementing a Random Number Package -C with Splitting Facilities." ACM Transactions on Mathematical -C Software, 17:98-111 (1991) -C -C********************************************************************** -C********************************************************************** -C -C SUBROUTINE SETALL(ISEED1,ISEED2) -C SET ALL random number generators -C -C Sets the initial seed of generator 1 to ISEED1 and ISEED2. The -C initial seeds of the other generators are set accordingly, and -C all generators states are set to these seeds. -C -C This is a transcription from Pascal to Fortran of routine -C Set_Initial_Seed from the paper -C -C L'Ecuyer, P. and Cote, S. "Implementing a Random Number Package -C with Splitting Facilities." ACM Transactions on Mathematical -C Software, 17:98-111 (1991) -C -C -C Arguments -C -C -C ISEED1 -> First of two integer seeds -C INTEGER ISEED1 -C -C ISEED2 -> Second of two integer seeds -C INTEGER ISEED1 -C -C********************************************************************** -C********************************************************************** -C -C SUBROUTINE SETANT(QVALUE) -C SET ANTithetic -C -C Sets whether the current generator produces antithetic values. If -C X is the value normally returned from a uniform [0,1] random -C number generator then 1 - X is the antithetic value. If X is the -C value normally returned from a uniform [0,N] random number -C generator then N - 1 - X is the antithetic value. -C -C All generators are initialized to NOT generate antithetic values. -C -C This is a transcription from Pascal to Fortran of routine -C Set_Antithetic from the paper -C -C L'Ecuyer, P. and Cote, S. "Implementing a Random Number Package -C with Splitting Facilities." ACM Transactions on Mathematical -C Software, 17:98-111 (1991) -C -C -C Arguments -C -C -C QVALUE -> .TRUE. if generator G is to generating antithetic -C values, otherwise .FALSE. -C LOGICAL QVALUE -C -C********************************************************************** -C********************************************************************** -C -C SUBROUTINE SETCGN( G ) -C Set GeNerator -C -C Sets the current generator to G. All references to a generato -C are to the current generator. -C -C -C Arguments -C -C -C G --> Number of the current random number generator (1..32) -C INTEGER G -C -C********************************************************************** -C********************************************************************** -C -C SUBROUTINE SETGMN( MEANV, COVM, LDCOVM, P, PARM) -C SET Generate Multivariate Normal random deviate -C -C -C Function -C -C -C Places P, MEANV, and the Cholesky factoriztion of COVM -C in PARM for GENMN. -C -C -C Arguments -C -C -C MEANV --> Mean vector of multivariate normal distribution. -C REAL MEANV(P) -C -C COVM <--> (Input) Covariance matrix of the multivariate -C normal distribution. This routine uses only the -C (1:P,1:P) slice of COVM, but needs to know LDCOVM. -C -C (Output) Destroyed on output -C REAL COVM(LDCOVM,P) -C -C LDCOVM --> Leading actual dimension of COVM. -C INTEGER LDCOVM -C -C P --> Dimension of the normal, or length of MEANV. -C INTEGER P -C -C PARM <-- Array of parameters needed to generate multivariate -C normal deviates (P, MEANV and Cholesky decomposition -C of COVM). -C 1 : 1 - P -C 2 : P + 1 - MEANV -C P+2 : P*(P+3)/2 + 1 - Cholesky decomposition of COVM -C REAL PARM(P*(P+3)/2 + 1) -C -C********************************************************************** -C********************************************************************** -C -C SUBROUTINE SETSD(ISEED1,ISEED2) -C SET S-ee-D of current generator -C -C Resets the initial seed and state of generator g to ISEED1 and -C ISEED2. The seeds and states of the other generators remain -C unchanged. -C -C This is a transcription from Pascal to Fortran of routine -C Set_Seed from the paper -C -C L'Ecuyer, P. and Cote, S. "Implementing a Random Number Package -C with Splitting Facilities." ACM Transactions on Mathematical -C Software, 17:98-111 (1991) -C -C -C Arguments -C -C -C ISEED1 -> First integer seed -C INTEGER ISEED1 -C -C ISEED2 -> Second integer seed -C INTEGER ISEED1 -C -C**********************************************************************
--- a/liboctave/cruft/ranlib/ranf.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,31 +0,0 @@ - REAL FUNCTION ranf() -C********************************************************************** -C -C REAL FUNCTION RANF() -C RANDom number generator as a Function -C -C Returns a random floating point number from a uniform distribution -C over 0 - 1 (endpoints of this interval are not returned) using the -C current generator -C -C This is a transcription from Pascal to Fortran of routine -C Uniform_01 from the paper -C -C L'Ecuyer, P. and Cote, S. "Implementing a Random Number Package -C with Splitting Facilities." ACM Transactions on Mathematical -C Software, 17:98-111 (1991) -C -C********************************************************************** -C .. External Functions .. - INTEGER ignlgi - EXTERNAL ignlgi -C .. -C .. Executable Statements .. -C -C 4.656613057E-10 is 1/M1 M1 is set in a data statement in IGNLGI -C and is currently 2147483563. If M1 changes, change this also. -C - ranf = ignlgi()*4.656613057E-10 - RETURN - - END
--- a/liboctave/cruft/ranlib/setall.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,103 +0,0 @@ - SUBROUTINE setall(iseed1,iseed2) -C********************************************************************** -C -C SUBROUTINE SETALL(ISEED1,ISEED2) -C SET ALL random number generators -C -C Sets the initial seed of generator 1 to ISEED1 and ISEED2. The -C initial seeds of the other generators are set accordingly, and -C all generators states are set to these seeds. -C -C This is a transcription from Pascal to Fortran of routine -C Set_Initial_Seed from the paper -C -C L'Ecuyer, P. and Cote, S. "Implementing a Random Number Package -C with Splitting Facilities." ACM Transactions on Mathematical -C Software, 17:98-111 (1991) -C -C -C Arguments -C -C -C ISEED1 -> First of two integer seeds -C INTEGER ISEED1 -C -C ISEED2 -> Second of two integer seeds -C INTEGER ISEED1 -C -C********************************************************************** -C .. Parameters .. - INTEGER numg - PARAMETER (numg=32) -C .. -C .. Scalar Arguments .. - INTEGER iseed1,iseed2 - LOGICAL qssd -C .. -C .. Scalars in Common .. - INTEGER a1,a1vw,a1w,a2,a2vw,a2w,m1,m2 -C .. -C .. Arrays in Common .. - INTEGER cg1(numg),cg2(numg),ig1(numg),ig2(numg),lg1(numg), - + lg2(numg) - LOGICAL qanti(numg) -C .. -C .. Local Scalars .. - INTEGER g,ocgn - LOGICAL qqssd -C .. -C .. External Functions .. - INTEGER mltmod - LOGICAL qrgnin - EXTERNAL mltmod,qrgnin -C .. -C .. External Subroutines .. - EXTERNAL getcgn,initgn,inrgcm,setcgn -C .. -C .. Common blocks .. - COMMON /globe/m1,m2,a1,a2,a1w,a2w,a1vw,a2vw,ig1,ig2,lg1,lg2,cg1, - + cg2,qanti -C .. -C .. Save statement .. - SAVE /globe/,qqssd -C .. -C .. Data statements .. - DATA qqssd/.FALSE./ -C .. -C .. Executable Statements .. -C -C TELL IGNLGI, THE ACTUAL NUMBER GENERATOR, THAT THIS ROUTINE -C HAS BEEN CALLED. -C - qqssd = .TRUE. - CALL getcgn(ocgn) -C -C Initialize Common Block if Necessary -C - IF (.NOT. (qrgnin())) CALL inrgcm() - ig1(1) = iseed1 - ig2(1) = iseed2 - CALL initgn(-1) - DO 10,g = 2,numg - ig1(g) = mltmod(a1vw,ig1(g-1),m1) - ig2(g) = mltmod(a2vw,ig2(g-1),m2) - CALL setcgn(g) - CALL initgn(-1) - 10 CONTINUE - CALL setcgn(ocgn) - RETURN - - ENTRY rgnqsd(qssd) -C********************************************************************** -C -C SUBROUTINE RGNQSD -C Random Number Generator Query SeeD set? -C -C Returns (LOGICAL) QSSD as .TRUE. if SETALL has been invoked, -C otherwise returns .FALSE. -C -C********************************************************************** - qssd = qqssd - RETURN - - END
--- a/liboctave/cruft/ranlib/setant.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,75 +0,0 @@ - SUBROUTINE setant(qvalue) -C********************************************************************** -C -C SUBROUTINE SETANT(QVALUE) -C SET ANTithetic -C -C Sets whether the current generator produces antithetic values. If -C X is the value normally returned from a uniform [0,1] random -C number generator then 1 - X is the antithetic value. If X is the -C value normally returned from a uniform [0,N] random number -C generator then N - 1 - X is the antithetic value. -C -C All generators are initialized to NOT generate antithetic values. -C -C This is a transcription from Pascal to Fortran of routine -C Set_Antithetic from the paper -C -C L'Ecuyer, P. and Cote, S. "Implementing a Random Number Package -C with Splitting Facilities." ACM Transactions on Mathematical -C Software, 17:98-111 (1991) -C -C -C Arguments -C -C -C QVALUE -> .TRUE. if generator G is to generating antithetic -C values, otherwise .FALSE. -C LOGICAL QVALUE -C -C********************************************************************** -C .. Parameters .. - INTEGER numg - PARAMETER (numg=32) -C .. -C .. Scalar Arguments .. - LOGICAL qvalue -C .. -C .. Scalars in Common .. - INTEGER a1,a1vw,a1w,a2,a2vw,a2w,m1,m2 -C .. -C .. Arrays in Common .. - INTEGER cg1(numg),cg2(numg),ig1(numg),ig2(numg),lg1(numg), - + lg2(numg) - LOGICAL qanti(numg) -C .. -C .. Local Scalars .. - INTEGER g -C .. -C .. External Functions .. - LOGICAL qrgnin - EXTERNAL qrgnin -C .. -C .. External Subroutines .. - EXTERNAL getcgn -C .. -C .. Common blocks .. - COMMON /globe/m1,m2,a1,a2,a1w,a2w,a1vw,a2vw,ig1,ig2,lg1,lg2,cg1, - + cg2,qanti -C .. -C .. Save statement .. - SAVE /globe/ -C .. -C .. Executable Statements .. -C Abort unless random number generator initialized - IF (qrgnin()) GO TO 10 - WRITE (*,*) ' SETANT called before random number generator ', - + ' initialized -- abort!' - CALL XSTOPX - + (' SETANT called before random number generator initialized') - - 10 CALL getcgn(g) - qanti(g) = qvalue - RETURN - - END
--- a/liboctave/cruft/ranlib/setgmn.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,107 +0,0 @@ - SUBROUTINE setgmn(meanv,covm,ldcovm,p,parm) -C SUBROUTINE setgmn(meanv,covm,p,parm) -C JJV changed this routine to take leading dimension of COVM -C JJV argument and pass it to SPOTRF, making it easier to use -C JJV if the COVM which is used is contained in a larger matrix -C JJV and to make the routine more consistent with LAPACK. -C JJV Changes are in comments, declarations, and the call to SPOTRF. -C********************************************************************** -C -C SUBROUTINE SETGMN( MEANV, COVM, LDCOVM, P, PARM) -C SET Generate Multivariate Normal random deviate -C -C -C Function -C -C -C Places P, MEANV, and the Cholesky factoriztion of COVM -C in PARM for GENMN. -C -C -C Arguments -C -C -C MEANV --> Mean vector of multivariate normal distribution. -C REAL MEANV(P) -C -C COVM <--> (Input) Covariance matrix of the multivariate -C normal distribution. This routine uses only the -C (1:P,1:P) slice of COVM, but needs to know LDCOVM. -C -C (Output) Destroyed on output -C REAL COVM(LDCOVM,P) -C -C LDCOVM --> Leading actual dimension of COVM. -C INTEGER LDCOVM -C -C P --> Dimension of the normal, or length of MEANV. -C INTEGER P -C -C PARM <-- Array of parameters needed to generate multivariate -C normal deviates (P, MEANV and Cholesky decomposition -C of COVM). -C 1 : 1 - P -C 2 : P + 1 - MEANV -C P+2 : P*(P+3)/2 + 1 - Cholesky decomposition of COVM -C REAL PARM(P*(P+3)/2 + 1) -C -C********************************************************************** -C .. Scalar Arguments .. -C INTEGER p - INTEGER p, ldcovm -C .. -C .. Array Arguments .. -C REAL covm(p,p),meanv(p),parm(p* (p+3)/2+1) - REAL covm(ldcovm,p),meanv(p),parm(p* (p+3)/2+1) -C .. -C .. Local Scalars .. - INTEGER i,icount,info,j -C .. -C .. External Subroutines .. - EXTERNAL spotrf -C .. -C .. Executable Statements .. -C -C -C TEST THE INPUT -C - IF (.NOT. (p.LE.0)) GO TO 10 - WRITE (*,*) 'P nonpositive in SETGMN' - WRITE (*,*) 'Value of P: ',p - CALL XSTOPX ('P nonpositive in SETGMN') - - 10 parm(1) = p -C -C PUT P AND MEANV INTO PARM -C - DO 20,i = 2,p + 1 - parm(i) = meanv(i-1) - 20 CONTINUE -C -C Cholesky decomposition to find A s.t. trans(A)*(A) = COVM -C -C CALL spofa(covm,p,p,info) -C CALL spofa(covm,ldcovm,p,info) - CALL spotrf ( 'Upper', p, covm, ldcovm, info) - IF (.NOT. (info.NE.0)) GO TO 30 - WRITE (*,*) ' COVM not positive definite in SETGMN' - CALL XSTOPX (' COVM not positive definite in SETGMN') - - 30 icount = p + 1 -C -C PUT UPPER HALF OF A, WHICH IS NOW THE CHOLESKY FACTOR, INTO PARM -C COVM(1,1) = PARM(P+2) -C COVM(1,2) = PARM(P+3) -C : -C COVM(1,P) = PARM(2P+1) -C COVM(2,2) = PARM(2P+2) ... -C - DO 50,i = 1,p - DO 40,j = i,p - icount = icount + 1 - parm(icount) = covm(i,j) - 40 CONTINUE - 50 CONTINUE - RETURN -C - END
--- a/liboctave/cruft/ranlib/setsd.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,74 +0,0 @@ - SUBROUTINE setsd(iseed1,iseed2) -C********************************************************************** -C -C SUBROUTINE SETSD(ISEED1,ISEED2) -C SET S-ee-D of current generator -C -C Resets the initial seed of the current generator to ISEED1 and -C ISEED2. The seeds of the other generators remain unchanged. -C -C This is a transcription from Pascal to Fortran of routine -C Set_Seed from the paper -C -C L'Ecuyer, P. and Cote, S. "Implementing a Random Number Package -C with Splitting Facilities." ACM Transactions on Mathematical -C Software, 17:98-111 (1991) -C -C -C Arguments -C -C -C ISEED1 -> First integer seed -C INTEGER ISEED1 -C -C ISEED2 -> Second integer seed -C INTEGER ISEED1 -C -C********************************************************************** -C .. Parameters .. - INTEGER numg - PARAMETER (numg=32) -C .. -C .. Scalar Arguments .. - INTEGER iseed1,iseed2 -C .. -C .. Scalars in Common .. - INTEGER a1,a1vw,a1w,a2,a2vw,a2w,m1,m2 -C .. -C .. Arrays in Common .. - INTEGER cg1(numg),cg2(numg),ig1(numg),ig2(numg),lg1(numg), - + lg2(numg) - LOGICAL qanti(numg) -C .. -C .. Local Scalars .. - INTEGER g -C .. -C .. External Functions .. - LOGICAL qrgnin - EXTERNAL qrgnin -C .. -C .. External Subroutines .. - EXTERNAL getcgn,initgn -C .. -C .. Common blocks .. - COMMON /globe/m1,m2,a1,a2,a1w,a2w,a1vw,a2vw,ig1,ig2,lg1,lg2,cg1, - + cg2,qanti -C .. -C .. Save statement .. - SAVE /globe/ -C .. -C .. Executable Statements .. -C Abort unless random number generator initialized - IF (qrgnin()) GO TO 10 - WRITE (*,*) ' SETSD called before random number generator ', - + ' initialized -- abort!' - CALL XSTOPX - + (' SETSD called before random number generator initialized') - - 10 CALL getcgn(g) - ig1(g) = iseed1 - ig2(g) = iseed2 - CALL initgn(-1) - RETURN - - END
--- a/liboctave/cruft/ranlib/sexpo.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,78 +0,0 @@ - REAL FUNCTION sexpo() -C**********************************************************************C -C C -C C -C (STANDARD-) E X P O N E N T I A L DISTRIBUTION C -C C -C C -C**********************************************************************C -C**********************************************************************C -C C -C FOR DETAILS SEE: C -C C -C AHRENS, J.H. AND DIETER, U. C -C COMPUTER METHODS FOR SAMPLING FROM THE C -C EXPONENTIAL AND NORMAL DISTRIBUTIONS. C -C COMM. ACM, 15,10 (OCT. 1972), 873 - 882. C -C C -C ALL STATEMENT NUMBERS CORRESPOND TO THE STEPS OF ALGORITHM C -C 'SA' IN THE ABOVE PAPER (SLIGHTLY MODIFIED IMPLEMENTATION) C -C C -C Modified by Barry W. Brown, Feb 3, 1988 to use RANF instead of C -C SUNIF. The argument IR thus goes away. C -C C -C**********************************************************************C -C -C -C Q(N) = SUM(ALOG(2.0)**K/K!) K=1,..,N , THE HIGHEST N -C (HERE 8) IS DETERMINED BY Q(N)=1.0 WITHIN STANDARD PRECISION -C -C JJV added a Save statement for q (in Data statement) -C .. Local Scalars .. - REAL a,q1,u,umin,ustar - INTEGER i -C .. -C .. Local Arrays .. - REAL q(8) -C .. -C .. External Functions .. - REAL ranf - EXTERNAL ranf -C .. -C .. Equivalences .. - EQUIVALENCE (q(1),q1) -C .. -C .. Save statement .. - SAVE q -C .. -C .. Data statements .. - DATA q/.6931472,.9333737,.9888778,.9984959,.9998293,.9999833, - + .9999986,.9999999/ -C .. -C - 10 a = 0.0 - u = ranf() - GO TO 30 - - 20 a = a + q1 - 30 u = u + u -C JJV changed the following to reflect the true algorithm and -C JJV prevent unpredictable behavior if U is initially 0.5. -C IF (u.LE.1.0) GO TO 20 - IF (u.LT.1.0) GO TO 20 - 40 u = u - 1.0 - IF (u.GT.q1) GO TO 60 - 50 sexpo = a + u - RETURN - - 60 i = 1 - ustar = ranf() - umin = ustar - 70 ustar = ranf() - IF (ustar.LT.umin) umin = ustar - 80 i = i + 1 - IF (u.GT.q(i)) GO TO 70 - 90 sexpo = a + umin*q1 - RETURN - - END
--- a/liboctave/cruft/ranlib/sgamma.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,235 +0,0 @@ - REAL FUNCTION sgamma(a) -C**********************************************************************C -C C -C C -C (STANDARD-) G A M M A DISTRIBUTION C -C C -C C -C**********************************************************************C -C**********************************************************************C -C C -C PARAMETER A >= 1.0 ! C -C C -C**********************************************************************C -C C -C FOR DETAILS SEE: C -C C -C AHRENS, J.H. AND DIETER, U. C -C GENERATING GAMMA VARIATES BY A C -C MODIFIED REJECTION TECHNIQUE. C -C COMM. ACM, 25,1 (JAN. 1982), 47 - 54. C -C C -C STEP NUMBERS CORRESPOND TO ALGORITHM 'GD' IN THE ABOVE PAPER C -C (STRAIGHTFORWARD IMPLEMENTATION) C -C C -C Modified by Barry W. Brown, Feb 3, 1988 to use RANF instead of C -C SUNIF. The argument IR thus goes away. C -C C -C**********************************************************************C -C C -C PARAMETER 0.0 < A < 1.0 ! C -C C -C**********************************************************************C -C C -C FOR DETAILS SEE: C -C C -C AHRENS, J.H. AND DIETER, U. C -C COMPUTER METHODS FOR SAMPLING FROM GAMMA, C -C BETA, POISSON AND BINOMIAL DISTRIBUTIONS. C -C COMPUTING, 12 (1974), 223 - 246. C -C C -C (ADAPTED IMPLEMENTATION OF ALGORITHM 'GS' IN THE ABOVE PAPER) C -C C -C**********************************************************************C -C -C -C INPUT: A =PARAMETER (MEAN) OF THE STANDARD GAMMA DISTRIBUTION -C OUTPUT: SGAMMA = SAMPLE FROM THE GAMMA-(A)-DISTRIBUTION -C -C COEFFICIENTS Q(K) - FOR Q0 = SUM(Q(K)*A**(-K)) -C COEFFICIENTS A(K) - FOR Q = Q0+(T*T/2)*SUM(A(K)*V**K) -C COEFFICIENTS E(K) - FOR EXP(Q)-1 = SUM(E(K)*Q**K) -C -C .. Scalar Arguments .. - REAL a -C .. -C .. Local Scalars .. (JJV added B0 to fix rare and subtle bug) - REAL a1,a2,a3,a4,a5,a6,a7,aa,aaa,b,b0,c,d,e,e1,e2,e3,e4,e5,p,q,q0, - + q1,q2,q3,q4,q5,q6,q7,r,s,s2,si,sqrt32,t,u,v,w,x -C .. -C .. External Functions .. - REAL ranf,sexpo,snorm - EXTERNAL ranf,sexpo,snorm -C .. -C .. Intrinsic Functions .. - INTRINSIC abs,alog,exp,sign,sqrt -C .. -C .. Save statement .. -C JJV added Save statement for vars in Data satatements - SAVE aa,aaa,s2,s,d,q0,b,si,c,q1,q2,q3,q4,q5,q6,q7,a1,a2,a3,a4,a5, - + a6,a7,e1,e2,e3,e4,e5,sqrt32 -C .. -C .. Data statements .. -C -C PREVIOUS A PRE-SET TO ZERO - AA IS A', AAA IS A" -C SQRT32 IS THE SQUAREROOT OF 32 = 5.656854249492380 -C - DATA q1,q2,q3,q4,q5,q6,q7/.04166669,.02083148,.00801191,.00144121, - + -.00007388,.00024511,.00024240/ - DATA a1,a2,a3,a4,a5,a6,a7/.3333333,-.2500030,.2000062,-.1662921, - + .1423657,-.1367177,.1233795/ - DATA e1,e2,e3,e4,e5/1.,.4999897,.1668290,.0407753,.0102930/ - DATA aa/0.0/,aaa/0.0/,sqrt32/5.656854/ -C .. -C .. Executable Statements .. -C - IF (a.EQ.aa) GO TO 10 - IF (a.LT.1.0) GO TO 130 -C -C STEP 1: RECALCULATIONS OF S2,S,D IF A HAS CHANGED -C - aa = a - s2 = a - 0.5 - s = sqrt(s2) - d = sqrt32 - 12.0*s -C -C STEP 2: T=STANDARD NORMAL DEVIATE, -C X=(S,1/2)-NORMAL DEVIATE. -C IMMEDIATE ACCEPTANCE (I) -C - 10 t = snorm() - x = s + 0.5*t - sgamma = x*x - IF (t.GE.0.0) RETURN -C -C STEP 3: U= 0,1 -UNIFORM SAMPLE. SQUEEZE ACCEPTANCE (S) -C - u = ranf() - IF (d*u.LE.t*t*t) RETURN -C -C STEP 4: RECALCULATIONS OF Q0,B,SI,C IF NECESSARY -C - IF (a.EQ.aaa) GO TO 40 - aaa = a - r = 1.0/a - q0 = ((((((q7*r+q6)*r+q5)*r+q4)*r+q3)*r+q2)*r+q1)*r -C -C APPROXIMATION DEPENDING ON SIZE OF PARAMETER A -C THE CONSTANTS IN THE EXPRESSIONS FOR B, SI AND -C C WERE ESTABLISHED BY NUMERICAL EXPERIMENTS -C - IF (a.LE.3.686) GO TO 30 - IF (a.LE.13.022) GO TO 20 -C -C CASE 3: A .GT. 13.022 -C - b = 1.77 - si = .75 - c = .1515/s - GO TO 40 -C -C CASE 2: 3.686 .LT. A .LE. 13.022 -C - 20 b = 1.654 + .0076*s2 - si = 1.68/s + .275 - c = .062/s + .024 - GO TO 40 -C -C CASE 1: A .LE. 3.686 -C - 30 b = .463 + s + .178*s2 - si = 1.235 - c = .195/s - .079 + .16*s -C -C STEP 5: NO QUOTIENT TEST IF X NOT POSITIVE -C - 40 IF (x.LE.0.0) GO TO 70 -C -C STEP 6: CALCULATION OF V AND QUOTIENT Q -C - v = t/ (s+s) - IF (abs(v).LE.0.25) GO TO 50 - q = q0 - s*t + 0.25*t*t + (s2+s2)*alog(1.0+v) - GO TO 60 - - 50 q = q0 + 0.5*t*t* ((((((a7*v+a6)*v+a5)*v+a4)*v+a3)*v+a2)*v+a1)*v -C -C STEP 7: QUOTIENT ACCEPTANCE (Q) -C - 60 IF (alog(1.0-u).LE.q) RETURN -C -C STEP 8: E=STANDARD EXPONENTIAL DEVIATE -C U= 0,1 -UNIFORM DEVIATE -C T=(B,SI)-DOUBLE EXPONENTIAL (LAPLACE) SAMPLE -C - 70 e = sexpo() - u = ranf() - u = u + u - 1.0 - t = b + sign(si*e,u) -C -C STEP 9: REJECTION IF T .LT. TAU(1) = -.71874483771719 -C - 80 IF (t.LT. (-.7187449)) GO TO 70 -C -C STEP 10: CALCULATION OF V AND QUOTIENT Q -C - v = t/ (s+s) - IF (abs(v).LE.0.25) GO TO 90 - q = q0 - s*t + 0.25*t*t + (s2+s2)*alog(1.0+v) - GO TO 100 - - 90 q = q0 + 0.5*t*t* ((((((a7*v+a6)*v+a5)*v+a4)*v+a3)*v+a2)*v+a1)*v -C -C STEP 11: HAT ACCEPTANCE (H) (IF Q NOT POSITIVE GO TO STEP 8) -C - 100 IF (q.LE.0.0) GO TO 70 - IF (q.LE.0.5) GO TO 110 -C -C JJV modified the code through line 125 to handle large Q case -C - IF (q.LT.15.0) GO TO 105 -C -C JJV Here Q is large enough that Q = log(exp(Q) - 1.0) (for real Q) -C JJV so reformulate test at 120 in terms of one EXP, if not too big -C JJV 87.49823 is close to the largest real which can be -C JJV exponentiated (87.49823 = log(1.0E38)) -C - IF ((q+e-0.5*t*t).GT.87.49823) GO TO 125 - IF (c*abs(u).GT.exp(q+e-0.5*t*t)) GO TO 70 - GO TO 125 - - 105 w = exp(q) - 1.0 - GO TO 120 - - 110 w = ((((e5*q+e4)*q+e3)*q+e2)*q+e1)*q -C -C IF T IS REJECTED, SAMPLE AGAIN AT STEP 8 -C - 120 IF (c*abs(u).GT.w*exp(e-0.5*t*t)) GO TO 70 - 125 x = s + 0.5*t - sgamma = x*x - RETURN -C -C ALTERNATE METHOD FOR PARAMETERS A BELOW 1 (.3678794=EXP(-1.)) -C -C JJV changed B to B0 (which was added to declarations for this) -C JJV in 130 to END to fix rare and subtle bug. -C JJV Line: '130 aa = 0.0' was removed (unnecessary, wasteful). -C JJV Reasons: the state of AA only serves to tell the A .GE. 1.0 -C JJV case if certain A-dependant constants need to be recalculated. -C JJV The A .LT. 1.0 case (here) no longer changes any of these, and -C JJV the recalculation of B (which used to change with an -C JJV A .LT. 1.0 call) is governed by the state of AAA anyway. -C - 130 b0 = 1.0 + .3678794*a - 140 p = b0*ranf() - IF (p.GE.1.0) GO TO 150 - sgamma = exp(alog(p)/a) - IF (sexpo().LT.sgamma) GO TO 140 - RETURN - - 150 sgamma = -alog((b0-p)/a) - IF (sexpo().LT. (1.0-a)*alog(sgamma)) GO TO 140 - RETURN - - END
--- a/liboctave/cruft/ranlib/snorm.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,138 +0,0 @@ - REAL FUNCTION snorm() -C**********************************************************************C -C C -C C -C (STANDARD-) N O R M A L DISTRIBUTION C -C C -C C -C**********************************************************************C -C**********************************************************************C -C C -C FOR DETAILS SEE: C -C C -C AHRENS, J.H. AND DIETER, U. C -C EXTENSIONS OF FORSYTHE'S METHOD FOR RANDOM C -C SAMPLING FROM THE NORMAL DISTRIBUTION. C -C MATH. COMPUT., 27,124 (OCT. 1973), 927 - 937. C -C C -C ALL STATEMENT NUMBERS CORRESPOND TO THE STEPS OF ALGORITHM 'FL' C -C (M=5) IN THE ABOVE PAPER (SLIGHTLY MODIFIED IMPLEMENTATION) C -C C -C Modified by Barry W. Brown, Feb 3, 1988 to use RANF instead of C -C SUNIF. The argument IR thus goes away. C -C C -C**********************************************************************C -C -C -C THE DEFINITIONS OF THE CONSTANTS A(K), D(K), T(K) AND -C H(K) ARE ACCORDING TO THE ABOVEMENTIONED ARTICLE -C -C .. Local Scalars .. - REAL aa,s,tt,u,ustar,w,y - INTEGER i -C .. -C .. Local Arrays .. - REAL a(32),d(31),h(31),t(31) -C .. -C .. External Functions .. - REAL ranf - EXTERNAL ranf -C .. -C .. Intrinsic Functions .. - INTRINSIC float,int -C .. -C .. Save statement .. -C JJV added a Save statement for arrays initialized in Data statmts - SAVE a,d,t,h -C .. -C .. Data statements .. - DATA a/0.0,.3917609E-1,.7841241E-1,.1177699,.1573107,.1970991, - + .2372021,.2776904,.3186394,.3601299,.4022501,.4450965, - + .4887764,.5334097,.5791322,.6260990,.6744898,.7245144, - + .7764218,.8305109,.8871466,.9467818,1.009990,1.077516, - + 1.150349,1.229859,1.318011,1.417797,1.534121,1.675940, - + 1.862732,2.153875/ - DATA d/5*0.0,.2636843,.2425085,.2255674,.2116342,.1999243, - + .1899108,.1812252,.1736014,.1668419,.1607967,.1553497, - + .1504094,.1459026,.1417700,.1379632,.1344418,.1311722, - + .1281260,.1252791,.1226109,.1201036,.1177417,.1155119, - + .1134023,.1114027,.1095039/ - DATA t/.7673828E-3,.2306870E-2,.3860618E-2,.5438454E-2, - + .7050699E-2,.8708396E-2,.1042357E-1,.1220953E-1,.1408125E-1, - + .1605579E-1,.1815290E-1,.2039573E-1,.2281177E-1,.2543407E-1, - + .2830296E-1,.3146822E-1,.3499233E-1,.3895483E-1,.4345878E-1, - + .4864035E-1,.5468334E-1,.6184222E-1,.7047983E-1,.8113195E-1, - + .9462444E-1,.1123001,.1364980,.1716886,.2276241,.3304980, - + .5847031/ - DATA h/.3920617E-1,.3932705E-1,.3950999E-1,.3975703E-1, - + .4007093E-1,.4045533E-1,.4091481E-1,.4145507E-1,.4208311E-1, - + .4280748E-1,.4363863E-1,.4458932E-1,.4567523E-1,.4691571E-1, - + .4833487E-1,.4996298E-1,.5183859E-1,.5401138E-1,.5654656E-1, - + .5953130E-1,.6308489E-1,.6737503E-1,.7264544E-1,.7926471E-1, - + .8781922E-1,.9930398E-1,.1155599,.1404344,.1836142,.2790016, - + .7010474/ -C .. -C .. Executable Statements .. -C - 10 u = ranf() - s = 0.0 - IF (u.GT.0.5) s = 1.0 - u = u + u - s - 20 u = 32.0*u - i = int(u) - IF (i.EQ.32) i = 31 - IF (i.EQ.0) GO TO 100 -C -C START CENTER -C - 30 ustar = u - float(i) - aa = a(i) - 40 IF (ustar.LE.t(i)) GO TO 60 - w = (ustar-t(i))*h(i) -C -C EXIT (BOTH CASES) -C - 50 y = aa + w - snorm = y - IF (s.EQ.1.0) snorm = -y - RETURN -C -C CENTER CONTINUED -C - 60 u = ranf() - w = u* (a(i+1)-aa) - tt = (0.5*w+aa)*w - GO TO 80 - - 70 tt = u - ustar = ranf() - 80 IF (ustar.GT.tt) GO TO 50 - 90 u = ranf() - IF (ustar.GE.u) GO TO 70 - ustar = ranf() - GO TO 40 -C -C START TAIL -C - 100 i = 6 - aa = a(32) - GO TO 120 - - 110 aa = aa + d(i) - i = i + 1 - 120 u = u + u - IF (u.LT.1.0) GO TO 110 - 130 u = u - 1.0 - 140 w = u*d(i) - tt = (0.5*w+aa)*w - GO TO 160 - - 150 tt = u - 160 ustar = ranf() - IF (ustar.GT.tt) GO TO 50 - 170 u = ranf() - IF (ustar.GE.u) GO TO 150 - u = ranf() - GO TO 140 - - END
--- a/liboctave/cruft/ranlib/tstbot.for Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,94 +0,0 @@ - PROGRAM tstbot -C********************************************************************** -C -C A test program for the bottom level routines -C -C********************************************************************** -C Set up the random number generator -C .. Local Scalars .. - INTEGER ians,iblock,igen,iseed1,iseed2,itmp,ix,ixgen,nbad -C .. -C .. Local Arrays .. - INTEGER answer(10000),genlst(5) -C .. -C .. External Functions .. - INTEGER ignlgi - EXTERNAL ignlgi -C .. -C .. External Subroutines .. - EXTERNAL getsd,initgn,setall,setcgn -C .. -C .. Data statements .. - DATA genlst/1,5,10,20,32/ -C .. -C .. Executable Statements .. - nbad = 0 - WRITE (*,9000) - - 9000 FORMAT (' For five virual generators of the 32'/ - + ' This test generates 10000 numbers then resets the block'/ - + ' and does it again'/ - + ' Any disagreements are reported -- there should be none'/) -C -C Set up Generators -C - CALL setall(12345,54321) -C -C For a selected set of generators -C - DO 60,ixgen = 1,5 - igen = genlst(ixgen) - CALL setcgn(igen) - WRITE (*,*) ' Testing generator ',igen -C -C Use 10 blocks -C - CALL initgn(-1) - CALL getsd(iseed1,iseed2) - DO 20,iblock = 1,10 -C -C Generate 1000 numbers -C - DO 10,ians = 1,1000 - ix = ians + (iblock-1)*1000 - answer(ix) = ignlgi() - 10 CONTINUE - CALL initgn(+1) - 20 CONTINUE - CALL initgn(-1) -C -C Do it again and compare answers -C - CALL getsd(iseed1,iseed2) -C -C Use 10 blocks -C - DO 50,iblock = 1,10 -C -C Generate 1000 numbers -C - DO 40,ians = 1,1000 - ix = ians + (iblock-1)*1000 -C ANSWER( IX ) = IGNLGI() - itmp = ignlgi() - IF (.NOT. (itmp.NE.answer(ix))) GO TO 30 - WRITE (*,9010) iblock,ians,ix,answer(ix),itmp - - 9010 FORMAT (' Disagreement on regeneration of numbers'/ - + ' Block ',I2,' N within Block ',I2, - + ' Index in answer ',I5/ - + ' Originally Generated ',I10,' Regenerated ', - + I10) - - nbad = nbad + 1 - IF (nbad.GT.10) STOP ' More than 10 mismatches' - 30 CONTINUE - 40 CONTINUE - CALL initgn(+1) - 50 CONTINUE - WRITE (*,*) ' Finished testing generator ',igen - WRITE (*,*) ' Test completed successfully' - 60 CONTINUE - STOP - - END
--- a/liboctave/cruft/ranlib/tstgmn.for Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,229 +0,0 @@ -C JJV changed name to ONECOV to avoid confusion with array COVAR -C JJV this was also changed in the body of the function -C REAL FUNCTION covar(x,y,n) - REAL FUNCTION onecov(x,y,n) -C .. Scalar Arguments .. - INTEGER n -C .. -C .. Array Arguments .. - REAL x(n),y(n) -C .. -C .. Local Scalars .. - REAL avx,avy,varx,vary,xmax,xmin - INTEGER i -C .. -C .. External Subroutines .. - EXTERNAL stat -C .. -C .. Intrinsic Functions .. - INTRINSIC real -C .. -C .. Executable Statements .. - CALL stat(x,n,avx,varx,xmin,xmax) - CALL stat(y,n,avy,vary,xmin,xmax) -C covar = 0.0 - onecov = 0.0 - DO 10,i = 1,n -C covar = covar + (x(i)-avx)* (y(i)-avy) - onecov = onecov + (x(i)-avx)* (y(i)-avy) - 10 CONTINUE -C covar = covar/real(n-1) - onecov = onecov/real(n-1) - RETURN - - END - -C JJV Added argument LDXCOV (leading dimension of XCOVAR) to be -C JJV consistent with the program TSTGMN, see comments below. -C JJV This change necessitated changes in the declarations. -C SUBROUTINE prcomp(p,mean,xcovar,answer) - SUBROUTINE prcomp(p,mean,xcovar,ldxcov,answer) - -C INTEGER p,maxp - INTEGER p,maxp,ldxcov - PARAMETER (maxp=10) -C REAL mean(p),xcovar(p,p),rcovar(maxp,maxp) - REAL mean(p),xcovar(ldxcov,p),rcovar(maxp,maxp) - REAL answer(1000,maxp) -C JJV added ONECOV because of name change to function COVAR -C REAL rmean(maxp),rvar(maxp) - REAL rmean(maxp),rvar(maxp),onecov - INTEGER maxobs - PARAMETER (maxobs=1000) - - DO 10,i = 1,p - CALL stat(answer(1,i),maxobs,rmean(i),rvar(i),dum1,dum2) - WRITE (*,*) ' Variable Number',i - WRITE (*,*) ' Mean ',mean(i),' Generated ',rmean(i) - WRITE (*,*) ' Variance ',xcovar(i,i),' Generated',rvar(i) - 10 CONTINUE - WRITE (*,*) ' Covariances' - DO 30,i = 1,p - DO 20,j = 1,i - 1 - WRITE (*,*) ' I = ',i,' J = ',j -C JJV changed COVAR to match new name -C rcovar(i,j) = covar(answer(1,i),answer(1,j),maxobs) - rcovar(i,j) = onecov(answer(1,i),answer(1,j),maxobs) - WRITE (*,*) ' Covariance ',xcovar(i,j),' Generated ', - + rcovar(i,j) - 20 CONTINUE - 30 CONTINUE - RETURN - - END - -C JJV added LDCOV (leading dimension of COVAR) to be -C JJV consistent with the program TSTGMN, see comments below. -C JJV This change necessitated changes in the declarations. -C SUBROUTINE setcov(p,var,corr,covar) - SUBROUTINE setcov(p,var,corr,covar,ldcov) -C Set covariance matrix from variance and common correlation -C .. Scalar Arguments .. - REAL corr -C INTEGER p - INTEGER p,ldcov -C .. -C .. Array Arguments .. -C REAL covar(p,p),var(p) - REAL covar(ldcov,p),var(p) -C .. -C .. Local Scalars .. - INTEGER i,j -C .. -C .. Intrinsic Functions .. - INTRINSIC sqrt -C .. -C .. Executable Statements .. - DO 40,i = 1,p - DO 30,j = 1,p - IF (.NOT. (i.EQ.j)) GO TO 10 - covar(i,j) = var(i) - GO TO 20 - - 10 covar(i,j) = corr*sqrt(var(i)*var(j)) - 20 CONTINUE - 30 CONTINUE - 40 CONTINUE - RETURN - - END - - SUBROUTINE stat(x,n,av,var,xmin,xmax) -C .. Scalar Arguments .. - REAL av,var,xmax,xmin - INTEGER n -C .. -C .. Array Arguments .. - REAL x(n) -C .. -C .. Local Scalars .. - REAL sum - INTEGER i -C .. -C .. Intrinsic Functions .. - INTRINSIC real -C .. -C .. Executable Statements .. - xmin = x(1) - xmax = x(1) - sum = 0.0 - DO 10,i = 1,n - sum = sum + x(i) - IF (x(i).LT.xmin) xmin = x(i) - IF (x(i).GT.xmax) xmax = x(i) - 10 CONTINUE - av = sum/real(n) - sum = 0.0 - DO 20,i = 1,n - sum = sum + (x(i)-av)**2 - 20 CONTINUE - var = sum/real(n-1) - RETURN - - END - - PROGRAM tstgmn -C Test Generation of Multivariate Normal Data -C JJV SETGMN was: SUBROUTINE setgmn(meanv,covm,p,parm) -C JJV is: SUBROUTINE setgmn(meanv,covm,ldcovm,p,parm) -C JJV So the covariance matrices have been changed to 2-dim'l -C JJV matrices, and the additional argument has been added to -C JJV the subroutine call. Additional changes have been made -C JJV to reflect this. (in declarations, the matrix copy routine, -C JJV and in subroutine calls.) -C .. Parameters .. - INTEGER maxp - PARAMETER (maxp=10) - INTEGER maxobs - PARAMETER (maxobs=1000) -C JJV this parameter is no longer needed -C INTEGER p2 -C PARAMETER (p2=maxp*maxp) -C .. -C .. Local Scalars .. - REAL corr - INTEGER i,iobs,is1,is2,j,p - CHARACTER phrase*100 -C .. -C .. Local Arrays .. -C REAL answer(1000,maxp),ccovar(p2),covar(p2),mean(maxp),param(500), -C + temp(maxp),var(maxp),work(maxp) - REAL answer(1000,maxp),ccovar(maxp,maxp),covar(maxp,maxp), - + mean(maxp),param(500),temp(maxp),var(maxp),work(maxp) -C .. -C .. External Subroutines .. - EXTERNAL genmn,phrtsd,prcomp,setall,setcov,setgmn -C .. -C .. Executable Statements .. - WRITE (*,9000) - - 9000 FORMAT ( - + ' Tests Multivariate Normal Generator for Up to 10 Variables' - + / - + ' User inputs means, variances, one correlation that is applied' - + /' to all pairs of variables'/ - + ' 1000 multivariate normal deviates are generated'/ - + ' Means, variances and covariances are calculated for these.' - + ) - - 10 WRITE (*,*) 'Enter number of variables for normal generator' - READ (*,*) p - WRITE (*,*) 'Enter mean vector of length ',p - READ (*,*) (mean(i),i=1,p) - WRITE (*,*) 'Enter variance vector of length ',p - READ (*,*) (var(i),i=1,p) - WRITE (*,*) 'Enter correlation of all variables' - READ (*,*) corr -C CALL setcov(p,var,corr,covar) - CALL setcov(p,var,corr,covar,maxp) - WRITE (*,*) ' Enter phrase to initialize rn generator' - READ (*,'(a)') phrase - CALL phrtsd(phrase,is1,is2) - CALL setall(is1,is2) -C DO 20,i = 1,p2 -C ccovar(i) = covar(i) -C 20 CONTINUE - DO 25,i = 1,maxp - DO 20,j = 1,maxp - ccovar(i,j) = covar(i,j) - 20 CONTINUE - 25 CONTINUE -C -C Generate Variables -C -C CALL setgmn(mean,ccovar,p,param) - CALL setgmn(mean,ccovar,maxp,p,param) - DO 40,iobs = 1,maxobs - CALL genmn(param,work,temp) - DO 30,j = 1,p - answer(iobs,j) = work(j) - 30 CONTINUE - 40 CONTINUE -C CALL prcomp(p,mean,covar,answer) - CALL prcomp(p,mean,covar,maxp,answer) -C -C Print Comparison of Generated and Reconstructed Values -C - GO TO 10 - - END
--- a/liboctave/cruft/ranlib/tstmid.for Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,611 +0,0 @@ - SUBROUTINE stat(x,n,av,var,xmin,xmax) -C********************************************************************** -C -C SUBROUTINE STAT( X, N, AV, VAR) -C -C compute STATistics -C -C -C Function -C -C -C Computes AVerage and VARiance of array X(N). -C -C********************************************************************** -C .. Scalar Arguments .. - REAL av,var,xmax,xmin - INTEGER n -C .. -C .. Array Arguments .. - REAL x(n) -C .. -C .. Local Scalars .. - REAL sum - INTEGER i -C .. -C .. Intrinsic Functions .. - INTRINSIC real -C .. -C .. Executable Statements .. - xmin = x(1) - xmax = x(1) - sum = 0.0 - DO 10,i = 1,n - sum = sum + x(i) - IF (x(i).LT.xmin) xmin = x(i) - IF (x(i).GT.xmax) xmax = x(i) - 10 CONTINUE - av = sum/real(n) - sum = 0.0 - DO 20,i = 1,n - sum = sum + (x(i)-av)**2 - 20 CONTINUE - var = sum/real(n-1) - RETURN - - END - PROGRAM tstall - IMPLICIT LOGICAL (q) -C Interactive test for PHRTSD -C .. Parameters .. - INTEGER mxwh,mxncat - PARAMETER (mxwh=15,mxncat=100) -C .. -C .. Local Scalars .. - REAL av,avtr,var,vartr,xmin,xmax,pevt,psum,rtry - INTEGER i,is1,is2,itmp,iwhich,j,mxint,nperm,nrep,ntot,ntry,ncat - CHARACTER ctype*4,phrase*100 -C .. -C .. Local Arrays .. - REAL array(1000),param(3),prob(mxncat) - INTEGER iarray(1000),perm(500) -C .. -C .. External Functions .. - REAL genbet,genchi,genf,gennch,gennf,genunf,genexp,gengam,gennor - INTEGER ignuin,ignnbn - EXTERNAL genbet,genchi,genf,gennch,gennf,genunf,ignuin -C .. -C .. External Subroutines .. - EXTERNAL genprm,phrtsd,setall,stat,trstat,genmul -C .. -C .. Executable Statements .. - WRITE (*,9000) - - 9000 FORMAT (' Tests most generators of specific distributions.'/ - + ' Generates 1000 deviates: reports mean and variance.'/ - + ' Also reports theoretical mean and variance.'/ - + ' If theoretical mean or var doesn''t exist prints -1.'/ - + ' For permutations, generates one permutation of 1..n'/ - + ' and prints it.'/ - + ' For uniform integers asks for upper bound, number of'/ - + ' replicates per integer in 1..upper bound.'/ - + ' Prints table of num times each integer generated.'/ - + ' For multinomial asks for number of events to be'/ - + ' classified, number of categories in which they'/ - + ' are to be classified, and the probabilities that'/ - + ' an event will be classified in the categories,'/ - + ' for all but the last category. Prints table of'/ - + ' number of events by category, true probability'/ - + ' associated with each category, and observed'/ - + ' proportion of events in each category.') -C -C Menu for choosing tests -C - 10 WRITE (*,9010) - - 9010 FORMAT (' Enter number corresponding to choice:'/ - + ' (0) Exit this program'/ - + ' (1) Generate Chi-Square deviates'/ - + ' (2) Generate noncentral Chi-Square deviates'/ - + ' (3) Generate F deviates'/ - + ' (4) Generate noncentral F deviates'/ - + ' (5) Generate random permutation'/ - + ' (6) Generate uniform integers'/ - + ' (7) Generate uniform reals'/ - + ' (8) Generate beta deviates'/ - + ' (9) Generate binomial outcomes'/ - + ' (10) Generate Poisson outcomes'/ - + ' (11) Generate exponential deviates'/ - + ' (12) Generate gamma deviates'/ - + ' (13) Generate multinomial outcomes'/ - + ' (14) Generate normal deviates'/ - + ' (15) Generate negative binomial outcomes'/) - - READ (*,*) iwhich - IF (.NOT. (iwhich.LT.0.OR.iwhich.GT.mxwh)) GO TO 20 - WRITE (*,*) ' Choices are 1..',mxwh,' - try again.' - GO TO 10 - - 20 IF (iwhich.EQ.0) STOP ' Normal termination rn tests' - WRITE (*,*) ' Enter phrase to initialize rn generator' - READ (*,'(a)') phrase - CALL phrtsd(phrase,is1,is2) - CALL setall(is1,is2) - - IF ((1).NE. (iwhich)) GO TO 40 -C -C Chi-square deviates -C - ctype = 'chis' - WRITE (*,*) ' Enter (real) df for the chi-square generation' - READ (*,*) param(1) - DO 30,i = 1,1000 - array(i) = genchi(param(1)) - 30 CONTINUE - CALL stat(array,1000,av,var,xmin,xmax) - CALL trstat(ctype,param,avtr,vartr) - WRITE (*,9020) av,avtr,var,vartr,xmin,xmax - - 9020 FORMAT (' Mean Generated: ',T30,G15.7,5X,'True:',T60, - + G15.7/' Variance Generated:',T30,G15.7,5X,'True:',T60, - + G15.7/' Minimum: ',T30,G15.7,5X,'Maximum:',T60,G15.7) - - GO TO 420 - - 40 IF ((2).NE. (iwhich)) GO TO 60 - -C -C Noncentral Chi-square deviates -C - ctype = 'ncch' - WRITE (*,*) ' Enter (real) df' - WRITE (*,*) ' (real) noncentrality parameter' - READ (*,*) param(1),param(2) - DO 50,i = 1,1000 - array(i) = gennch(param(1),param(2)) - 50 CONTINUE - CALL stat(array,1000,av,var,xmin,xmax) - CALL trstat(ctype,param,avtr,vartr) - WRITE (*,9020) av,avtr,var,vartr,xmin,xmax - GO TO 420 - - 60 IF ((3).NE. (iwhich)) GO TO 80 - -C -C F deviates -C - ctype = 'f' - WRITE (*,*) ' Enter (real) df of the numerator' - WRITE (*,*) ' (real) df of the denominator' - READ (*,*) param(1),param(2) - DO 70,i = 1,1000 - array(i) = genf(param(1),param(2)) - 70 CONTINUE - CALL stat(array,1000,av,var,xmin,xmax) - CALL trstat(ctype,param,avtr,vartr) - WRITE (*,9020) av,avtr,var,vartr,xmin,xmax - GO TO 420 - - 80 IF ((4).NE. (iwhich)) GO TO 100 - -C -C Noncentral F deviates -C - ctype = 'ncf' - WRITE (*,*) ' Enter (real) df of the numerator' - WRITE (*,*) ' (real) df of the denominator' - WRITE (*,*) ' (real) noncentrality parameter' - READ (*,*) param(1),param(2),param(3) - DO 90,i = 1,1000 - array(i) = gennf(param(1),param(2),param(3)) - 90 CONTINUE - CALL stat(array,1000,av,var,xmin,xmax) - CALL trstat(ctype,param,avtr,vartr) - WRITE (*,9020) av,avtr,var,vartr,xmin,xmax - GO TO 420 - - 100 IF ((5).NE. (iwhich)) GO TO 140 - -C -C Random permutation -C - 110 WRITE (*,*) ' Enter size of permutation' - READ (*,*) nperm - IF (.NOT. (nperm.LT.1.OR.nperm.GT.500)) GO TO 120 - WRITE (*,*) ' Permutation size must be between 1 and 500 ', - + '- try again!' - GO TO 110 - - 120 WRITE (*,*) ' Random Permutation Generated - Size',nperm - DO 130,i = 1,500 - perm(i) = i - 130 CONTINUE - CALL genprm(perm,nperm) - WRITE (*,*) ' Perm Generated' - WRITE (*,'(20I4)') (perm(i),i=1,nperm) - GO TO 420 - - 140 IF ((6).NE. (iwhich)) GO TO 170 - -C -C Uniform integer -C - WRITE (*,*) ' Enter maximum uniform integer' - READ (*,*) mxint - WRITE (*,*) ' Enter number of replications per integer' - READ (*,*) nrep - DO 150,i = 1,1000 - iarray(i) = 0 - 150 CONTINUE - ntot = mxint*nrep - DO 160,i = 1,ntot - itmp = ignuin(1,mxint) - iarray(itmp) = iarray(itmp) + 1 - 160 CONTINUE - WRITE (*,*) ' Counts of Integers Generated' - WRITE (*,'(20I4)') (iarray(j),j=1,mxint) - GO TO 420 - - 170 IF ((7).NE. (iwhich)) GO TO 190 - -C -C Uniform real -C - ctype = 'unif' - WRITE (*,*) ' Enter Low then High bound for uniforms' - READ (*,*) param(1),param(2) - DO 180,i = 1,1000 - array(i) = genunf(param(1),param(2)) - 180 CONTINUE - CALL stat(array,1000,av,var,xmin,xmax) - CALL trstat(ctype,param,avtr,vartr) - WRITE (*,9020) av,avtr,var,vartr,xmin,xmax - GO TO 420 - - 190 IF ((8).NE. (iwhich)) GO TO 210 - -C -C Beta deviate -C - ctype = 'beta' - WRITE (*,*) ' Enter A, B for Beta deviate' - READ (*,*) param(1),param(2) - DO 200,i = 1,1000 - array(i) = genbet(param(1),param(2)) - 200 CONTINUE - CALL stat(array,1000,av,var,xmin,xmax) - CALL trstat(ctype,param,avtr,vartr) - WRITE (*,9020) av,avtr,var,vartr,xmin,xmax - GO TO 420 - - 210 IF ((9).NE. (iwhich)) GO TO 240 - -C -C Binomial outcomes -C - ctype = 'bin' - WRITE (*,*) ' Enter number of trials, Prob event for ', - + 'binomial outcomes' - READ (*,*) ntry,pevt - DO 220,i = 1,1000 - iarray(i) = ignbin(ntry,pevt) - 220 CONTINUE - DO 230,i = 1,1000 - array(i) = iarray(i) - 230 CONTINUE - CALL stat(array,1000,av,var,xmin,xmax) - param(1) = ntry - param(2) = pevt - CALL trstat(ctype,param,avtr,vartr) - WRITE (*,9020) av,avtr,var,vartr,xmin,xmax - GO TO 420 - - 240 IF ((10).NE. (iwhich)) GO TO 270 - -C -C Poisson outcomes -C - ctype = 'pois' - WRITE (*,*) ' Enter mean for Poisson generation' - READ (*,*) param(1) - DO 250,i = 1,1000 - iarray(i) = ignpoi(param(1)) - 250 CONTINUE - DO 260,i = 1,1000 - array(i) = iarray(i) - 260 CONTINUE - CALL stat(array,1000,av,var,xmin,xmax) - CALL trstat(ctype,param,avtr,vartr) - WRITE (*,9020) av,avtr,var,vartr,xmin,xmax - GO TO 420 - - 270 IF ((11).NE. (iwhich)) GO TO 290 - -C -C Exponential deviates -C - ctype = 'expo' - WRITE (*,*) ' Enter (real) AV for Exponential' - READ (*,*) param(1) - DO 280,i = 1,1000 - array(i) = genexp(param(1)) - 280 CONTINUE - CALL stat(array,1000,av,var,xmin,xmax) - CALL trstat(ctype,param,avtr,vartr) - WRITE (*,9020) av,avtr,var,vartr,xmin,xmax - - GO TO 420 - - 290 IF ((12).NE. (iwhich)) GO TO 310 - -C -C Gamma deviates -C - ctype = 'gamm' - WRITE (*,*) ' Enter (real) A, (real) R for Gamma deviate' - READ (*,*) param(1),param(2) - DO 300,i = 1,1000 - array(i) = gengam(param(1),param(2)) - 300 CONTINUE - CALL stat(array,1000,av,var,xmin,xmax) - CALL trstat(ctype,param,avtr,vartr) - WRITE (*,9020) av,avtr,var,vartr,xmin,xmax - GO TO 420 - - 310 IF ((13).NE. (iwhich)) GO TO 360 - -C -C Multinomial outcomes -C - WRITE (*,*) ' Enter (int) number of observations: ' - READ (*,*) ntry - 320 WRITE (*,*) ' Enter (int) num. of categories: <= ',mxncat - READ (*,*) ncat - IF (ncat.GT.mxncat) THEN - WRITE (*,*) ' number of categories must be <= ',mxncat - WRITE (*,*) ' Try again ... ' - GO TO 320 - END IF - WRITE (*,*) ' Enter (real) prob. vector of length ',ncat-1 - READ (*,*) (prob(i),i=1,ncat-1) - CALL genmul(ntry,prob,ncat,iarray) - ntot = 0 - IF (ntry.GT.0) THEN - rtry = real(ntry) - DO 330, i = 1,ncat - ntot = ntot + iarray(i) - array(i) = iarray(i)/rtry - 330 CONTINUE - ELSE - DO 340, i = 1,ncat - ntot = ntot + iarray(i) - array(i) = 0.0 - 340 CONTINUE - ENDIF - psum = 0.0 - DO 350, i = 1,ncat-1 - psum = psum + prob(i) - 350 CONTINUE - prob(ncat) = 1.0 - psum - - WRITE (*,*) ' Total number of observations: ',ntot - WRITE (*,*) ' Total observations by category: ' - WRITE (*,'(10I8)') (iarray(i),i=1,ncat) - WRITE (*,*) ' True probabilities by category: ' - WRITE (*,'(8F10.7)') (prob(i),i=1,ncat) - WRITE (*,*) ' Observed proportions by category: ' - WRITE (*,'(8F10.7)') (array(i),i=1,ncat) - GO TO 420 - - 360 IF ((14).NE. (iwhich)) GO TO 380 - -C -C Normal deviates -C - ctype = 'norm' - WRITE (*,*) ' Enter (real) AV, (real) SD for Normal' - READ (*,*) param(1),param(2) - DO 370,i = 1,1000 - array(i) = gennor(param(1),param(2)) - 370 CONTINUE - CALL stat(array,1000,av,var,xmin,xmax) - CALL trstat(ctype,param,avtr,vartr) - WRITE (*,9020) av,avtr,var,vartr,xmin,xmax - GO TO 420 - - 380 IF ((15).NE. (iwhich)) GO TO 410 - -C -C Negative Binomial outcomes -C - ctype = 'nbin' - WRITE (*,*) ' Enter required (int) Number of events then ' - WRITE (*,*) ' (real) Prob of an event for negative binomial' - READ (*,*) ntry,pevt - DO 390,i = 1,1000 - iarray(i) = ignnbn(ntry,pevt) - 390 CONTINUE - DO 400,i = 1,1000 - array(i) = iarray(i) - 400 CONTINUE - CALL stat(array,1000,av,var,xmin,xmax) - param(1) = ntry - param(2) = pevt - CALL trstat(ctype,param,avtr,vartr) - WRITE (*,9020) av,avtr,var,vartr,xmin,xmax - GO TO 420 - - 410 CONTINUE - 420 GO TO 10 - - END - SUBROUTINE trstat(ctype,parin,av,var) - IMPLICIT INTEGER (i-n),REAL (a-h,o-p,r-z),LOGICAL (q) -C********************************************************************** -C -C SUBROUTINE TRSTAT( TYPE, PARIN, AV, VAR ) -C TRue STATistics -C -C Returns mean and variance for a number of statistical distribution -C as a function of their parameters. -C -C -C Arguments -C -C -C CTYPE --> Character string indicating type of distribution -C 'chis' chisquare -C 'ncch' noncentral chisquare -C 'f' F (variance ratio) -C 'ncf' noncentral f -C 'unif' uniform -C 'beta' beta distribution -C 'bin' binomial -C 'pois' poisson -C 'expo' exponential -C 'gamm' gamma -C 'norm' normal -C 'nbin' negative binomial -C CHARACTER*(4) TYPE -C -C PARIN --> Array containing parameters of distribution -C chisquare -C PARIN(1) is df -C noncentral chisquare -C PARIN(1) is df -C PARIN(2) is noncentrality parameter -C F (variance ratio) -C PARIN(1) is df numerator -C PARIN(2) is df denominator -C noncentral F -C PARIN(1) is df numerator -C PARIN(2) is df denominator -C PARIN(3) is noncentrality parameter -C uniform -C PARIN(1) is LOW bound -C PARIN(2) is HIGH bound -C beta -C PARIN(1) is A -C PARIN(2) is B -C binomial -C PARIN(1) is Number of trials -C PARIN(2) is Prob Event at Each Trial -C poisson -C PARIN(1) is Mean -C exponential -C PARIN(1) is Mean -C gamma -C PARIN(1) is A -C PARIN(2) is R -C normal -C PARIN(1) is Mean -C PARIN(2) is Standard Deviation -C negative binomial -C PARIN(1) is required Number of events -C PARIN(2) is Probability of event -C REAL PARIN(*) -C -C AV <-- Mean of specified distribution with specified parameters -C REAL AV -C -C VAR <-- Variance of specified distribution with specified paramete -C REAL VAR -C -C -C Note -C -C -C AV and Var will be returned -1 if mean or variance is infinite -C -C********************************************************************** -C .. Scalar Arguments .. - REAL av,var - CHARACTER ctype* (4) -C .. -C .. Array Arguments .. - REAL parin(*) -C .. -C .. Local Scalars .. - REAL a,b,range -C .. -C .. Executable Statements .. - IF (('chis').NE. (ctype)) GO TO 10 - av = parin(1) - var = 2.0*parin(1) - GO TO 210 - - 10 IF (('ncch').NE. (ctype)) GO TO 20 - a = parin(1) + parin(2) - b = parin(2)/a - av = a - var = 2.0*a* (1.0+b) - GO TO 210 - - 20 IF (('f').NE. (ctype)) GO TO 70 - IF (.NOT. (parin(2).LE.2.0001)) GO TO 30 - av = -1.0 - GO TO 40 - - 30 av = parin(2)/ (parin(2)-2.0) - 40 IF (.NOT. (parin(2).LE.4.0001)) GO TO 50 - var = -1.0 - GO TO 60 - - 50 var = (2.0*parin(2)**2* (parin(1)+parin(2)-2.0))/ - + (parin(1)* (parin(2)-2.0)**2* (parin(2)-4.0)) - 60 GO TO 210 - - 70 IF (('ncf').NE. (ctype)) GO TO 120 - IF (.NOT. (parin(2).LE.2.0001)) GO TO 80 - av = -1.0 - GO TO 90 - - 80 av = (parin(2)* (parin(1)+parin(3)))/ ((parin(2)-2.0)*parin(1)) - 90 IF (.NOT. (parin(2).LE.4.0001)) GO TO 100 - var = -1.0 - GO TO 110 - - 100 a = (parin(1)+parin(3))**2 + (parin(1)+2.0*parin(3))* - + (parin(2)-2.0) - b = (parin(2)-2.0)**2* (parin(2)-4.0) - var = 2.0* (parin(2)/parin(1))**2* (a/b) - 110 GO TO 210 - - 120 IF (('unif').NE. (ctype)) GO TO 130 - range = parin(2) - parin(1) - av = parin(1) + range/2.0 - var = range**2/12.0 - GO TO 210 - - 130 IF (('beta').NE. (ctype)) GO TO 140 - av = parin(1)/ (parin(1)+parin(2)) - var = (av*parin(2))/ ((parin(1)+parin(2))* - + (parin(1)+parin(2)+1.0)) - GO TO 210 - - 140 IF (('bin').NE. (ctype)) GO TO 150 - av = parin(1)*parin(2) - var = av* (1.0-parin(2)) - GO TO 210 - - 150 IF (('pois').NE. (ctype)) GO TO 160 - av = parin(1) - var = parin(1) - GO TO 210 - - 160 IF (('expo').NE. (ctype)) GO TO 170 - av = parin(1) - var = parin(1)**2 - GO TO 210 - - 170 IF (('gamm').NE. (ctype)) GO TO 180 - av = parin(2) / parin(1) - var = av / parin(1) - GO TO 210 - - 180 IF (('norm').NE. (ctype)) GO TO 190 - av = parin(1) - var = parin(2)**2 - GO TO 210 - - 190 IF (('nbin').NE. (ctype)) GO TO 200 - av = parin(1) * (1.0 - parin(2)) / parin(2) - var = av / parin(2) - GO TO 210 - - 200 WRITE (*,*) 'Unimplemented type ',ctype - STOP 'Unimplemented type in TRSTAT' - - 210 RETURN - - END
--- a/liboctave/cruft/ranlib/wrap.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,25 +0,0 @@ - subroutine dgennor (av, sd, result) - double precision av, sd, result - result = gennor (real (av), real (sd)) - return - end - subroutine dgenunf (low, high, result) - double precision low, high, result - result = genunf (real (low), real (high)) - return - end - subroutine dgenexp (av, result) - double precision av, result - result = genexp (real (av)) - return - end - subroutine dgengam (a, r, result) - double precision a, r, result - result = gengam (real (a), real (r)) - return - end - subroutine dignpoi (mu, result) - double precision mu, result - result = ignpoi (real (mu)) - return - end
--- a/liboctave/cruft/slatec-err/fdump.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,31 +0,0 @@ -*DECK FDUMP - SUBROUTINE FDUMP -C***BEGIN PROLOGUE FDUMP -C***PURPOSE Symbolic dump (should be locally written). -C***LIBRARY SLATEC (XERROR) -C***CATEGORY R3 -C***TYPE ALL (FDUMP-A) -C***KEYWORDS ERROR, XERMSG -C***AUTHOR Jones, R. E., (SNLA) -C***DESCRIPTION -C -C ***Note*** Machine Dependent Routine -C FDUMP is intended to be replaced by a locally written -C version which produces a symbolic dump. Failing this, -C it should be replaced by a version which prints the -C subprogram nesting list. Note that this dump must be -C printed on each of up to five files, as indicated by the -C XGETUA routine. See XSETUA and XGETUA for details. -C -C Written by Ron Jones, with SLATEC Common Math Library Subcommittee -C -C***REFERENCES (NONE) -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 790801 DATE WRITTEN -C 861211 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C***END PROLOGUE FDUMP -C***FIRST EXECUTABLE STATEMENT FDUMP - RETURN - END
--- a/liboctave/cruft/slatec-err/ixsav.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,70 +0,0 @@ -*DECK IXSAV - INTEGER FUNCTION IXSAV (IPAR, IVALUE, ISET) -C***BEGIN PROLOGUE IXSAV -C***SUBSIDIARY -C***PURPOSE Save and recall error message control parameters. -C***LIBRARY MATHLIB -C***CATEGORY R3C -C***TYPE ALL (IXSAV-A) -C***AUTHOR Hindmarsh, Alan C., (LLNL) -C***DESCRIPTION -C -C IXSAV saves and recalls one of two error message parameters: -C LUNIT, the logical unit number to which messages are printed, and -C MESFLG, the message print flag. -C This is a modification of the SLATEC library routine J4SAVE. -C -C Saved local variables.. -C LUNIT = Logical unit number for messages. -C LUNDEF = Default logical unit number, data-loaded to 6 below -C (may be machine-dependent). -C MESFLG = Print control flag.. -C 1 means print all messages (the default). -C 0 means no printing. -C -C On input.. -C IPAR = Parameter indicator (1 for LUNIT, 2 for MESFLG). -C IVALUE = The value to be set for the parameter, if ISET = .TRUE. -C ISET = Logical flag to indicate whether to read or write. -C If ISET = .TRUE., the parameter will be given -C the value IVALUE. If ISET = .FALSE., the parameter -C will be unchanged, and IVALUE is a dummy argument. -C -C On return.. -C IXSAV = The (old) value of the parameter. -C -C***SEE ALSO XERMSG, XERRWD, XERRWV -C***ROUTINES CALLED NONE -C***REVISION HISTORY (YYMMDD) -C 921118 DATE WRITTEN -C 930329 Modified prologue to SLATEC format. (FNF) -C 941025 Minor modification re default unit number. (ACH) -C***END PROLOGUE IXSAV -C -C**End - LOGICAL ISET - INTEGER IPAR, IVALUE -C----------------------------------------------------------------------- - INTEGER LUNIT, LUNDEF, MESFLG -C----------------------------------------------------------------------- -C The following Fortran-77 declaration is to cause the values of the -C listed (local) variables to be saved between calls to this routine. -C----------------------------------------------------------------------- - SAVE LUNIT, LUNDEF, MESFLG - DATA LUNIT/-1/, LUNDEF/6/, MESFLG/1/ -C -C***FIRST EXECUTABLE STATEMENT IXSAV - IF (IPAR .EQ. 1) THEN - IF (LUNIT .EQ. -1) LUNIT = LUNDEF - IXSAV = LUNIT - IF (ISET) LUNIT = IVALUE - ENDIF -C - IF (IPAR .EQ. 2) THEN - IXSAV = MESFLG - IF (ISET) MESFLG = IVALUE - ENDIF -C - RETURN -C----------------------- End of Function IXSAV ------------------------- - END
--- a/liboctave/cruft/slatec-err/j4save.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,65 +0,0 @@ -*DECK J4SAVE - FUNCTION J4SAVE (IWHICH, IVALUE, ISET) -C***BEGIN PROLOGUE J4SAVE -C***SUBSIDIARY -C***PURPOSE Save or recall global variables needed by error -C handling routines. -C***LIBRARY SLATEC (XERROR) -C***TYPE INTEGER (J4SAVE-I) -C***KEYWORDS ERROR MESSAGES, ERROR NUMBER, RECALL, SAVE, XERROR -C***AUTHOR Jones, R. E., (SNLA) -C***DESCRIPTION -C -C Abstract -C J4SAVE saves and recalls several global variables needed -C by the library error handling routines. -C -C Description of Parameters -C --Input-- -C IWHICH - Index of item desired. -C = 1 Refers to current error number. -C = 2 Refers to current error control flag. -C = 3 Refers to current unit number to which error -C messages are to be sent. (0 means use standard.) -C = 4 Refers to the maximum number of times any -C message is to be printed (as set by XERMAX). -C = 5 Refers to the total number of units to which -C each error message is to be written. -C = 6 Refers to the 2nd unit for error messages -C = 7 Refers to the 3rd unit for error messages -C = 8 Refers to the 4th unit for error messages -C = 9 Refers to the 5th unit for error messages -C IVALUE - The value to be set for the IWHICH-th parameter, -C if ISET is .TRUE. . -C ISET - If ISET=.TRUE., the IWHICH-th parameter will BE -C given the value, IVALUE. If ISET=.FALSE., the -C IWHICH-th parameter will be unchanged, and IVALUE -C is a dummy parameter. -C --Output-- -C The (old) value of the IWHICH-th parameter will be returned -C in the function value, J4SAVE. -C -C***SEE ALSO XERMSG -C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC -C Error-handling Package, SAND82-0800, Sandia -C Laboratories, 1982. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 790801 DATE WRITTEN -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900205 Minor modifications to prologue. (WRB) -C 900402 Added TYPE section. (WRB) -C 910411 Added KEYWORDS section. (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE J4SAVE - LOGICAL ISET - INTEGER IPARAM(9) - SAVE IPARAM - DATA IPARAM(1),IPARAM(2),IPARAM(3),IPARAM(4)/0,2,0,-1/ - DATA IPARAM(5)/1/ - DATA IPARAM(6),IPARAM(7),IPARAM(8),IPARAM(9)/0,0,0,0/ -C***FIRST EXECUTABLE STATEMENT J4SAVE - J4SAVE = IPARAM(IWHICH) - IF (ISET) IPARAM(IWHICH) = IVALUE - RETURN - END
--- a/liboctave/cruft/slatec-err/module.mk Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,15 +0,0 @@ -CRUFT_SOURCES += \ - liboctave/cruft/slatec-err/fdump.f \ - liboctave/cruft/slatec-err/ixsav.f \ - liboctave/cruft/slatec-err/j4save.f \ - liboctave/cruft/slatec-err/xerclr.f \ - liboctave/cruft/slatec-err/xercnt.f \ - liboctave/cruft/slatec-err/xerhlt.f \ - liboctave/cruft/slatec-err/xermsg.f \ - liboctave/cruft/slatec-err/xerprn.f \ - liboctave/cruft/slatec-err/xerrwd.f \ - liboctave/cruft/slatec-err/xersve.f \ - liboctave/cruft/slatec-err/xgetf.f \ - liboctave/cruft/slatec-err/xgetua.f \ - liboctave/cruft/slatec-err/xsetf.f \ - liboctave/cruft/slatec-err/xsetua.f
--- a/liboctave/cruft/slatec-err/xerclr.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,31 +0,0 @@ -*DECK XERCLR - SUBROUTINE XERCLR -C***BEGIN PROLOGUE XERCLR -C***PURPOSE Reset current error number to zero. -C***LIBRARY SLATEC (XERROR) -C***CATEGORY R3C -C***TYPE ALL (XERCLR-A) -C***KEYWORDS ERROR, XERROR -C***AUTHOR Jones, R. E., (SNLA) -C***DESCRIPTION -C -C Abstract -C This routine simply resets the current error number to zero. -C This may be necessary in order to determine that a certain -C error has occurred again since the last time NUMXER was -C referenced. -C -C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC -C Error-handling Package, SAND82-0800, Sandia -C Laboratories, 1982. -C***ROUTINES CALLED J4SAVE -C***REVISION HISTORY (YYMMDD) -C 790801 DATE WRITTEN -C 861211 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE XERCLR -C***FIRST EXECUTABLE STATEMENT XERCLR - JUNK = J4SAVE(1,0,.TRUE.) - RETURN - END
--- a/liboctave/cruft/slatec-err/xercnt.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,60 +0,0 @@ -*DECK XERCNT - SUBROUTINE XERCNT (LIBRAR, SUBROU, MESSG, NERR, LEVEL, KONTRL) -C***BEGIN PROLOGUE XERCNT -C***SUBSIDIARY -C***PURPOSE Allow user control over handling of errors. -C***LIBRARY SLATEC (XERROR) -C***CATEGORY R3C -C***TYPE ALL (XERCNT-A) -C***KEYWORDS ERROR, XERROR -C***AUTHOR Jones, R. E., (SNLA) -C***DESCRIPTION -C -C Abstract -C Allows user control over handling of individual errors. -C Just after each message is recorded, but before it is -C processed any further (i.e., before it is printed or -C a decision to abort is made), a call is made to XERCNT. -C If the user has provided his own version of XERCNT, he -C can then override the value of KONTROL used in processing -C this message by redefining its value. -C KONTRL may be set to any value from -2 to 2. -C The meanings for KONTRL are the same as in XSETF, except -C that the value of KONTRL changes only for this message. -C If KONTRL is set to a value outside the range from -2 to 2, -C it will be moved back into that range. -C -C Description of Parameters -C -C --Input-- -C LIBRAR - the library that the routine is in. -C SUBROU - the subroutine that XERMSG is being called from -C MESSG - the first 20 characters of the error message. -C NERR - same as in the call to XERMSG. -C LEVEL - same as in the call to XERMSG. -C KONTRL - the current value of the control flag as set -C by a call to XSETF. -C -C --Output-- -C KONTRL - the new value of KONTRL. If KONTRL is not -C defined, it will remain at its original value. -C This changed value of control affects only -C the current occurrence of the current message. -C -C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC -C Error-handling Package, SAND82-0800, Sandia -C Laboratories, 1982. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 790801 DATE WRITTEN -C 861211 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900206 Routine changed from user-callable to subsidiary. (WRB) -C 900510 Changed calling sequence to include LIBRARY and SUBROUTINE -C names, changed routine name from XERCTL to XERCNT. (RWC) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE XERCNT - CHARACTER*(*) LIBRAR, SUBROU, MESSG -C***FIRST EXECUTABLE STATEMENT XERCNT - RETURN - END
--- a/liboctave/cruft/slatec-err/xerhlt.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,39 +0,0 @@ -*DECK XERHLT - SUBROUTINE XERHLT (MESSG) -C***BEGIN PROLOGUE XERHLT -C***SUBSIDIARY -C***PURPOSE Abort program execution and print error message. -C***LIBRARY SLATEC (XERROR) -C***CATEGORY R3C -C***TYPE ALL (XERHLT-A) -C***KEYWORDS ABORT PROGRAM EXECUTION, ERROR, XERROR -C***AUTHOR Jones, R. E., (SNLA) -C***DESCRIPTION -C -C Abstract -C ***Note*** machine dependent routine -C XERHLT aborts the execution of the program. -C The error message causing the abort is given in the calling -C sequence, in case one needs it for printing on a dayfile, -C for example. -C -C Description of Parameters -C MESSG is as in XERMSG. -C -C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC -C Error-handling Package, SAND82-0800, Sandia -C Laboratories, 1982. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 790801 DATE WRITTEN -C 861211 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900206 Routine changed from user-callable to subsidiary. (WRB) -C 900510 Changed calling sequence to delete length of character -C and changed routine name from XERABT to XERHLT. (RWC) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE XERHLT - CHARACTER*(*) MESSG -C***FIRST EXECUTABLE STATEMENT XERHLT - CALL XSTOPX (MESSG) - END
--- a/liboctave/cruft/slatec-err/xermsg.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,368 +0,0 @@ -*DECK XERMSG - SUBROUTINE XERMSG (LIBRAR, SUBROU, MESSG, NERR, LEVEL) -C***BEGIN PROLOGUE XERMSG -C***PURPOSE Process error messages for SLATEC and other libraries. -C***LIBRARY SLATEC (XERROR) -C***CATEGORY R3C -C***TYPE ALL (XERMSG-A) -C***KEYWORDS ERROR MESSAGE, XERROR -C***AUTHOR Fong, Kirby, (NMFECC at LLNL) -C***DESCRIPTION -C -C XERMSG processes a diagnostic message in a manner determined by the -C value of LEVEL and the current value of the library error control -C flag, KONTRL. See subroutine XSETF for details. -C -C LIBRAR A character constant (or character variable) with the name -C of the library. This will be 'SLATEC' for the SLATEC -C Common Math Library. The error handling package is -C general enough to be used by many libraries -C simultaneously, so it is desirable for the routine that -C detects and reports an error to identify the library name -C as well as the routine name. -C -C SUBROU A character constant (or character variable) with the name -C of the routine that detected the error. Usually it is the -C name of the routine that is calling XERMSG. There are -C some instances where a user callable library routine calls -C lower level subsidiary routines where the error is -C detected. In such cases it may be more informative to -C supply the name of the routine the user called rather than -C the name of the subsidiary routine that detected the -C error. -C -C MESSG A character constant (or character variable) with the text -C of the error or warning message. In the example below, -C the message is a character constant that contains a -C generic message. -C -C CALL XERMSG ('SLATEC', 'MMPY', -C *'THE ORDER OF THE MATRIX EXCEEDS THE ROW DIMENSION', -C *3, 1) -C -C It is possible (and is sometimes desirable) to generate a -C specific message--e.g., one that contains actual numeric -C values. Specific numeric values can be converted into -C character strings using formatted WRITE statements into -C character variables. This is called standard Fortran -C internal file I/O and is exemplified in the first three -C lines of the following example. You can also catenate -C substrings of characters to construct the error message. -C Here is an example showing the use of both writing to -C an internal file and catenating character strings. -C -C CHARACTER*5 CHARN, CHARL -C WRITE (CHARN,10) N -C WRITE (CHARL,10) LDA -C 10 FORMAT(I5) -C CALL XERMSG ('SLATEC', 'MMPY', 'THE ORDER'//CHARN// -C * ' OF THE MATRIX EXCEEDS ITS ROW DIMENSION OF'// -C * CHARL, 3, 1) -C -C There are two subtleties worth mentioning. One is that -C the // for character catenation is used to construct the -C error message so that no single character constant is -C continued to the next line. This avoids confusion as to -C whether there are trailing blanks at the end of the line. -C The second is that by catenating the parts of the message -C as an actual argument rather than encoding the entire -C message into one large character variable, we avoid -C having to know how long the message will be in order to -C declare an adequate length for that large character -C variable. XERMSG calls XERPRN to print the message using -C multiple lines if necessary. If the message is very long, -C XERPRN will break it into pieces of 72 characters (as -C requested by XERMSG) for printing on multiple lines. -C Also, XERMSG asks XERPRN to prefix each line with ' * ' -C so that the total line length could be 76 characters. -C Note also that XERPRN scans the error message backwards -C to ignore trailing blanks. Another feature is that -C the substring '$$' is treated as a new line sentinel -C by XERPRN. If you want to construct a multiline -C message without having to count out multiples of 72 -C characters, just use '$$' as a separator. '$$' -C obviously must occur within 72 characters of the -C start of each line to have its intended effect since -C XERPRN is asked to wrap around at 72 characters in -C addition to looking for '$$'. -C -C NERR An integer value that is chosen by the library routine's -C author. It must be in the range -99 to 999 (three -C printable digits). Each distinct error should have its -C own error number. These error numbers should be described -C in the machine readable documentation for the routine. -C The error numbers need be unique only within each routine, -C so it is reasonable for each routine to start enumerating -C errors from 1 and proceeding to the next integer. -C -C LEVEL An integer value in the range 0 to 2 that indicates the -C level (severity) of the error. Their meanings are -C -C -1 A warning message. This is used if it is not clear -C that there really is an error, but the user's attention -C may be needed. An attempt is made to only print this -C message once. -C -C 0 A warning message. This is used if it is not clear -C that there really is an error, but the user's attention -C may be needed. -C -C 1 A recoverable error. This is used even if the error is -C so serious that the routine cannot return any useful -C answer. If the user has told the error package to -C return after recoverable errors, then XERMSG will -C return to the Library routine which can then return to -C the user's routine. The user may also permit the error -C package to terminate the program upon encountering a -C recoverable error. -C -C 2 A fatal error. XERMSG will not return to its caller -C after it receives a fatal error. This level should -C hardly ever be used; it is much better to allow the -C user a chance to recover. An example of one of the few -C cases in which it is permissible to declare a level 2 -C error is a reverse communication Library routine that -C is likely to be called repeatedly until it integrates -C across some interval. If there is a serious error in -C the input such that another step cannot be taken and -C the Library routine is called again without the input -C error having been corrected by the caller, the Library -C routine will probably be called forever with improper -C input. In this case, it is reasonable to declare the -C error to be fatal. -C -C Each of the arguments to XERMSG is input; none will be modified by -C XERMSG. A routine may make multiple calls to XERMSG with warning -C level messages; however, after a call to XERMSG with a recoverable -C error, the routine should return to the user. Do not try to call -C XERMSG with a second recoverable error after the first recoverable -C error because the error package saves the error number. The user -C can retrieve this error number by calling another entry point in -C the error handling package and then clear the error number when -C recovering from the error. Calling XERMSG in succession causes the -C old error number to be overwritten by the latest error number. -C This is considered harmless for error numbers associated with -C warning messages but must not be done for error numbers of serious -C errors. After a call to XERMSG with a recoverable error, the user -C must be given a chance to call NUMXER or XERCLR to retrieve or -C clear the error number. -C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC -C Error-handling Package, SAND82-0800, Sandia -C Laboratories, 1982. -C***ROUTINES CALLED FDUMP, J4SAVE, XERCNT, XERHLT, XERPRN, XERSVE -C***REVISION HISTORY (YYMMDD) -C 880101 DATE WRITTEN -C 880621 REVISED AS DIRECTED AT SLATEC CML MEETING OF FEBRUARY 1988. -C THERE ARE TWO BASIC CHANGES. -C 1. A NEW ROUTINE, XERPRN, IS USED INSTEAD OF XERPRT TO -C PRINT MESSAGES. THIS ROUTINE WILL BREAK LONG MESSAGES -C INTO PIECES FOR PRINTING ON MULTIPLE LINES. '$$' IS -C ACCEPTED AS A NEW LINE SENTINEL. A PREFIX CAN BE -C ADDED TO EACH LINE TO BE PRINTED. XERMSG USES EITHER -C ' ***' OR ' * ' AND LONG MESSAGES ARE BROKEN EVERY -C 72 CHARACTERS (AT MOST) SO THAT THE MAXIMUM LINE -C LENGTH OUTPUT CAN NOW BE AS GREAT AS 76. -C 2. THE TEXT OF ALL MESSAGES IS NOW IN UPPER CASE SINCE THE -C FORTRAN STANDARD DOCUMENT DOES NOT ADMIT THE EXISTENCE -C OF LOWER CASE. -C 880708 REVISED AFTER THE SLATEC CML MEETING OF JUNE 29 AND 30. -C THE PRINCIPAL CHANGES ARE -C 1. CLARIFY COMMENTS IN THE PROLOGUES -C 2. RENAME XRPRNT TO XERPRN -C 3. REWORK HANDLING OF '$$' IN XERPRN TO HANDLE BLANK LINES -C SIMILAR TO THE WAY FORMAT STATEMENTS HANDLE THE / -C CHARACTER FOR NEW RECORDS. -C 890706 REVISED WITH THE HELP OF FRED FRITSCH AND REG CLEMENS TO -C CLEAN UP THE CODING. -C 890721 REVISED TO USE NEW FEATURE IN XERPRN TO COUNT CHARACTERS IN -C PREFIX. -C 891013 REVISED TO CORRECT COMMENTS. -C 891214 Prologue converted to Version 4.0 format. (WRB) -C 900510 Changed test on NERR to be -9999999 < NERR < 99999999, but -C NERR .ne. 0, and on LEVEL to be -2 < LEVEL < 3. Added -C LEVEL=-1 logic, changed calls to XERSAV to XERSVE, and -C XERCTL to XERCNT. (RWC) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE XERMSG - CHARACTER*(*) LIBRAR, SUBROU, MESSG - CHARACTER*8 XLIBR, XSUBR - CHARACTER*72 TEMP - CHARACTER*20 LFIRST -C***FIRST EXECUTABLE STATEMENT XERMSG - LKNTRL = J4SAVE (2, 0, .FALSE.) - MAXMES = J4SAVE (4, 0, .FALSE.) -C -C LKNTRL IS A LOCAL COPY OF THE CONTROL FLAG KONTRL. -C MAXMES IS THE MAXIMUM NUMBER OF TIMES ANY PARTICULAR MESSAGE -C SHOULD BE PRINTED. IF MAXMES IS LESS THAN ZERO, THERE IS -C NO LIMIT. -C -C WE PRINT A FATAL ERROR MESSAGE AND TERMINATE FOR AN ERROR IN -C CALLING XERMSG. THE ERROR NUMBER SHOULD BE POSITIVE, -C AND THE LEVEL SHOULD BE BETWEEN 0 AND 2. -C - IF (NERR.LT.-9999999 .OR. NERR.GT.99999999 .OR. NERR.EQ.0 .OR. - * LEVEL.LT.-1 .OR. LEVEL.GT.2) THEN - CALL XERPRN (' ***', -1, 'FATAL ERROR IN...$$ ' // - * 'XERMSG -- INVALID ERROR NUMBER OR LEVEL$$ '// - * 'JOB ABORT DUE TO FATAL ERROR.', 72) - CALL XERSVE (' ', ' ', ' ', 0, 0, 0, KDUMMY) - CALL XERHLT (' ***XERMSG -- INVALID INPUT') - RETURN - ENDIF -C -C RECORD THE MESSAGE. -C - I = J4SAVE (1, NERR, .TRUE.) - CALL XERSVE (LIBRAR, SUBROU, MESSG, 1, NERR, LEVEL, KOUNT) -C -C HANDLE PRINT-ONCE WARNING MESSAGES. -C - IF (LEVEL.EQ.-1 .AND. KOUNT.GT.1) RETURN -C -C ALLOW TEMPORARY USER OVERRIDE OF THE CONTROL FLAG. -C - XLIBR = LIBRAR - XSUBR = SUBROU - LFIRST = MESSG - LERR = NERR - LLEVEL = LEVEL - CALL XERCNT (XLIBR, XSUBR, LFIRST, LERR, LLEVEL, LKNTRL) -C - LKNTRL = MAX(-2, MIN(2,LKNTRL)) - MKNTRL = ABS(LKNTRL) -C -C SKIP PRINTING IF THE CONTROL FLAG VALUE AS RESET IN XERCNT IS -C ZERO AND THE ERROR IS NOT FATAL. -C - IF (LEVEL.LT.2 .AND. LKNTRL.EQ.0) GO TO 30 - IF (LEVEL.EQ.0 .AND. MAXMES.GE.0 .AND. KOUNT.GT.MAXMES) GO TO 30 - IF (LEVEL.EQ.1 .AND. MAXMES.GE.0 .AND. KOUNT.GT.MAXMES - * .AND. MKNTRL.EQ.1) GO TO 30 - IF (LEVEL.EQ.2 .AND. MAXMES.GE.0 .AND. KOUNT.GT.MAX(1,MAXMES)) - * GO TO 30 -C -C ANNOUNCE THE NAMES OF THE LIBRARY AND SUBROUTINE BY BUILDING A -C MESSAGE IN CHARACTER VARIABLE TEMP (NOT EXCEEDING 66 CHARACTERS) -C AND SENDING IT OUT VIA XERPRN. PRINT ONLY IF CONTROL FLAG -C IS NOT ZERO. -C - IF (LKNTRL .NE. 0) THEN - TEMP(1:21) = 'MESSAGE FROM ROUTINE ' - I = MIN(LEN(SUBROU), 16) - TEMP(22:21+I) = SUBROU(1:I) - TEMP(22+I:33+I) = ' IN LIBRARY ' - LTEMP = 33 + I - I = MIN(LEN(LIBRAR), 16) - TEMP(LTEMP+1:LTEMP+I) = LIBRAR (1:I) - TEMP(LTEMP+I+1:LTEMP+I+1) = '.' - LTEMP = LTEMP + I + 1 - CALL XERPRN (' ***', -1, TEMP(1:LTEMP), 72) - ENDIF -C -C IF LKNTRL IS POSITIVE, PRINT AN INTRODUCTORY LINE BEFORE -C PRINTING THE MESSAGE. THE INTRODUCTORY LINE TELLS THE CHOICE -C FROM EACH OF THE FOLLOWING THREE OPTIONS. -C 1. LEVEL OF THE MESSAGE -C 'INFORMATIVE MESSAGE' -C 'POTENTIALLY RECOVERABLE ERROR' -C 'FATAL ERROR' -C 2. WHETHER CONTROL FLAG WILL ALLOW PROGRAM TO CONTINUE -C 'PROG CONTINUES' -C 'PROG ABORTED' -C 3. WHETHER OR NOT A TRACEBACK WAS REQUESTED. (THE TRACEBACK -C MAY NOT BE IMPLEMENTED AT SOME SITES, SO THIS ONLY TELLS -C WHAT WAS REQUESTED, NOT WHAT WAS DELIVERED.) -C 'TRACEBACK REQUESTED' -C 'TRACEBACK NOT REQUESTED' -C NOTICE THAT THE LINE INCLUDING FOUR PREFIX CHARACTERS WILL NOT -C EXCEED 74 CHARACTERS. -C WE SKIP THE NEXT BLOCK IF THE INTRODUCTORY LINE IS NOT NEEDED. -C - IF (LKNTRL .GT. 0) THEN -C -C THE FIRST PART OF THE MESSAGE TELLS ABOUT THE LEVEL. -C - IF (LEVEL .LE. 0) THEN - TEMP(1:20) = 'INFORMATIVE MESSAGE,' - LTEMP = 20 - ELSEIF (LEVEL .EQ. 1) THEN - TEMP(1:30) = 'POTENTIALLY RECOVERABLE ERROR,' - LTEMP = 30 - ELSE - TEMP(1:12) = 'FATAL ERROR,' - LTEMP = 12 - ENDIF -C -C THEN WHETHER THE PROGRAM WILL CONTINUE. -C - IF ((MKNTRL.EQ.2 .AND. LEVEL.GE.1) .OR. - * (MKNTRL.EQ.1 .AND. LEVEL.EQ.2)) THEN - TEMP(LTEMP+1:LTEMP+14) = ' PROG ABORTED,' - LTEMP = LTEMP + 14 - ELSE - TEMP(LTEMP+1:LTEMP+16) = ' PROG CONTINUES,' - LTEMP = LTEMP + 16 - ENDIF -C -C FINALLY TELL WHETHER THERE SHOULD BE A TRACEBACK. -C - IF (LKNTRL .GT. 0) THEN - TEMP(LTEMP+1:LTEMP+20) = ' TRACEBACK REQUESTED' - LTEMP = LTEMP + 20 - ELSE - TEMP(LTEMP+1:LTEMP+24) = ' TRACEBACK NOT REQUESTED' - LTEMP = LTEMP + 24 - ENDIF - CALL XERPRN (' ***', -1, TEMP(1:LTEMP), 72) - ENDIF -C -C NOW SEND OUT THE MESSAGE. -C - CALL XERPRN (' * ', -1, MESSG, 72) -C -C IF LKNTRL IS POSITIVE, WRITE THE ERROR NUMBER AND REQUEST A -C TRACEBACK. -C - IF (LKNTRL .GT. 0) THEN - WRITE (TEMP, '(''ERROR NUMBER = '', I8)') NERR - DO 10 I=16,22 - IF (TEMP(I:I) .NE. ' ') GO TO 20 - 10 CONTINUE -C - 20 CALL XERPRN (' * ', -1, TEMP(1:15) // TEMP(I:23), 72) - CALL FDUMP - ENDIF -C -C IF LKNTRL IS NOT ZERO, PRINT A BLANK LINE AND AN END OF MESSAGE. -C - IF (LKNTRL .NE. 0) THEN - CALL XERPRN (' * ', -1, ' ', 72) - CALL XERPRN (' ***', -1, 'END OF MESSAGE', 72) - CALL XERPRN (' ', 0, ' ', 72) - ENDIF -C -C IF THE ERROR IS NOT FATAL OR THE ERROR IS RECOVERABLE AND THE -C CONTROL FLAG IS SET FOR RECOVERY, THEN RETURN. -C - 30 IF (LEVEL.LE.0 .OR. (LEVEL.EQ.1 .AND. MKNTRL.LE.1)) RETURN -C -C THE PROGRAM WILL BE STOPPED DUE TO AN UNRECOVERED ERROR OR A -C FATAL ERROR. PRINT THE REASON FOR THE ABORT AND THE ERROR -C SUMMARY IF THE CONTROL FLAG AND THE MAXIMUM ERROR COUNT PERMIT. -C - IF (LKNTRL.GT.0 - * .AND. (MAXMES.LT.0 .OR. KOUNT.LT.MAX(1,MAXMES))) THEN - IF (LEVEL .EQ. 1) THEN - CALL XERPRN - * (' ***', -1, 'JOB ABORT DUE TO UNRECOVERED ERROR.', 72) - ELSE - CALL XERPRN(' ***', -1, 'JOB ABORT DUE TO FATAL ERROR.', 72) - ENDIF - CALL XERSVE (' ', ' ', ' ', -1, 0, 0, KDUMMY) - CALL XERHLT (' ') - ELSE - CALL XERHLT (MESSG) - ENDIF - RETURN - END
--- a/liboctave/cruft/slatec-err/xerprn.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,228 +0,0 @@ -*DECK XERPRN - SUBROUTINE XERPRN (PREFIX, NPREF, MESSG, NWRAP) -C***BEGIN PROLOGUE XERPRN -C***SUBSIDIARY -C***PURPOSE Print error messages processed by XERMSG. -C***LIBRARY SLATEC (XERROR) -C***CATEGORY R3C -C***TYPE ALL (XERPRN-A) -C***KEYWORDS ERROR MESSAGES, PRINTING, XERROR -C***AUTHOR Fong, Kirby, (NMFECC at LLNL) -C***DESCRIPTION -C -C This routine sends one or more lines to each of the (up to five) -C logical units to which error messages are to be sent. This routine -C is called several times by XERMSG, sometimes with a single line to -C print and sometimes with a (potentially very long) message that may -C wrap around into multiple lines. -C -C PREFIX Input argument of type CHARACTER. This argument contains -C characters to be put at the beginning of each line before -C the body of the message. No more than 16 characters of -C PREFIX will be used. -C -C NPREF Input argument of type INTEGER. This argument is the number -C of characters to use from PREFIX. If it is negative, the -C intrinsic function LEN is used to determine its length. If -C it is zero, PREFIX is not used. If it exceeds 16 or if -C LEN(PREFIX) exceeds 16, only the first 16 characters will be -C used. If NPREF is positive and the length of PREFIX is less -C than NPREF, a copy of PREFIX extended with blanks to length -C NPREF will be used. -C -C MESSG Input argument of type CHARACTER. This is the text of a -C message to be printed. If it is a long message, it will be -C broken into pieces for printing on multiple lines. Each line -C will start with the appropriate prefix and be followed by a -C piece of the message. NWRAP is the number of characters per -C piece; that is, after each NWRAP characters, we break and -C start a new line. In addition the characters '$$' embedded -C in MESSG are a sentinel for a new line. The counting of -C characters up to NWRAP starts over for each new line. The -C value of NWRAP typically used by XERMSG is 72 since many -C older error messages in the SLATEC Library are laid out to -C rely on wrap-around every 72 characters. -C -C NWRAP Input argument of type INTEGER. This gives the maximum size -C piece into which to break MESSG for printing on multiple -C lines. An embedded '$$' ends a line, and the count restarts -C at the following character. If a line break does not occur -C on a blank (it would split a word) that word is moved to the -C next line. Values of NWRAP less than 16 will be treated as -C 16. Values of NWRAP greater than 132 will be treated as 132. -C The actual line length will be NPREF + NWRAP after NPREF has -C been adjusted to fall between 0 and 16 and NWRAP has been -C adjusted to fall between 16 and 132. -C -C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC -C Error-handling Package, SAND82-0800, Sandia -C Laboratories, 1982. -C***ROUTINES CALLED I1MACH, XGETUA -C***REVISION HISTORY (YYMMDD) -C 880621 DATE WRITTEN -C 880708 REVISED AFTER THE SLATEC CML SUBCOMMITTEE MEETING OF -C JUNE 29 AND 30 TO CHANGE THE NAME TO XERPRN AND TO REWORK -C THE HANDLING OF THE NEW LINE SENTINEL TO BEHAVE LIKE THE -C SLASH CHARACTER IN FORMAT STATEMENTS. -C 890706 REVISED WITH THE HELP OF FRED FRITSCH AND REG CLEMENS TO -C STREAMLINE THE CODING AND FIX A BUG THAT CAUSED EXTRA BLANK -C LINES TO BE PRINTED. -C 890721 REVISED TO ADD A NEW FEATURE. A NEGATIVE VALUE OF NPREF -C CAUSES LEN(PREFIX) TO BE USED AS THE LENGTH. -C 891013 REVISED TO CORRECT ERROR IN CALCULATING PREFIX LENGTH. -C 891214 Prologue converted to Version 4.0 format. (WRB) -C 900510 Added code to break messages between words. (RWC) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE XERPRN - CHARACTER*(*) PREFIX, MESSG - INTEGER NPREF, NWRAP - CHARACTER*148 CBUFF - INTEGER IU(5), NUNIT - CHARACTER*2 NEWLIN - PARAMETER (NEWLIN = '$$') -C***FIRST EXECUTABLE STATEMENT XERPRN - CALL XGETUA(IU,NUNIT) -C -C A ZERO VALUE FOR A LOGICAL UNIT NUMBER MEANS TO USE THE STANDARD -C ERROR MESSAGE UNIT INSTEAD. I1MACH(4) RETRIEVES THE STANDARD -C ERROR MESSAGE UNIT. -C - N = I1MACH(4) - DO 10 I=1,NUNIT - IF (IU(I) .EQ. 0) IU(I) = N - 10 CONTINUE -C -C LPREF IS THE LENGTH OF THE PREFIX. THE PREFIX IS PLACED AT THE -C BEGINNING OF CBUFF, THE CHARACTER BUFFER, AND KEPT THERE DURING -C THE REST OF THIS ROUTINE. -C - IF ( NPREF .LT. 0 ) THEN - LPREF = LEN(PREFIX) - ELSE - LPREF = NPREF - ENDIF - LPREF = MIN(16, LPREF) - IF (LPREF .NE. 0) CBUFF(1:LPREF) = PREFIX -C -C LWRAP IS THE MAXIMUM NUMBER OF CHARACTERS WE WANT TO TAKE AT ONE -C TIME FROM MESSG TO PRINT ON ONE LINE. -C - LWRAP = MAX(16, MIN(132, NWRAP)) -C -C SET LENMSG TO THE LENGTH OF MESSG, IGNORE ANY TRAILING BLANKS. -C - LENMSG = LEN(MESSG) - N = LENMSG - DO 20 I=1,N - IF (MESSG(LENMSG:LENMSG) .NE. ' ') GO TO 30 - LENMSG = LENMSG - 1 - 20 CONTINUE - 30 CONTINUE -C -C IF THE MESSAGE IS ALL BLANKS, THEN PRINT ONE BLANK LINE. -C - IF (LENMSG .EQ. 0) THEN - CBUFF(LPREF+1:LPREF+1) = ' ' - DO 40 I=1,NUNIT - WRITE(IU(I), '(A)') CBUFF(1:LPREF+1) - 40 CONTINUE - RETURN - ENDIF -C -C SET NEXTC TO THE POSITION IN MESSG WHERE THE NEXT SUBSTRING -C STARTS. FROM THIS POSITION WE SCAN FOR THE NEW LINE SENTINEL. -C WHEN NEXTC EXCEEDS LENMSG, THERE IS NO MORE TO PRINT. -C WE LOOP BACK TO LABEL 50 UNTIL ALL PIECES HAVE BEEN PRINTED. -C -C WE LOOK FOR THE NEXT OCCURRENCE OF THE NEW LINE SENTINEL. THE -C INDEX INTRINSIC FUNCTION RETURNS ZERO IF THERE IS NO OCCURRENCE -C OR IF THE LENGTH OF THE FIRST ARGUMENT IS LESS THAN THE LENGTH -C OF THE SECOND ARGUMENT. -C -C THERE ARE SEVERAL CASES WHICH SHOULD BE CHECKED FOR IN THE -C FOLLOWING ORDER. WE ARE ATTEMPTING TO SET LPIECE TO THE NUMBER -C OF CHARACTERS THAT SHOULD BE TAKEN FROM MESSG STARTING AT -C POSITION NEXTC. -C -C LPIECE .EQ. 0 THE NEW LINE SENTINEL DOES NOT OCCUR IN THE -C REMAINDER OF THE CHARACTER STRING. LPIECE -C SHOULD BE SET TO LWRAP OR LENMSG+1-NEXTC, -C WHICHEVER IS LESS. -C -C LPIECE .EQ. 1 THE NEW LINE SENTINEL STARTS AT MESSG(NEXTC: -C NEXTC). LPIECE IS EFFECTIVELY ZERO, AND WE -C PRINT NOTHING TO AVOID PRODUCING UNNECESSARY -C BLANK LINES. THIS TAKES CARE OF THE SITUATION -C WHERE THE LIBRARY ROUTINE HAS A MESSAGE OF -C EXACTLY 72 CHARACTERS FOLLOWED BY A NEW LINE -C SENTINEL FOLLOWED BY MORE CHARACTERS. NEXTC -C SHOULD BE INCREMENTED BY 2. -C -C LPIECE .GT. LWRAP+1 REDUCE LPIECE TO LWRAP. -C -C ELSE THIS LAST CASE MEANS 2 .LE. LPIECE .LE. LWRAP+1 -C RESET LPIECE = LPIECE-1. NOTE THAT THIS -C PROPERLY HANDLES THE END CASE WHERE LPIECE .EQ. -C LWRAP+1. THAT IS, THE SENTINEL FALLS EXACTLY -C AT THE END OF A LINE. -C - NEXTC = 1 - 50 LPIECE = INDEX(MESSG(NEXTC:LENMSG), NEWLIN) - IF (LPIECE .EQ. 0) THEN -C -C THERE WAS NO NEW LINE SENTINEL FOUND. -C - IDELTA = 0 - LPIECE = MIN(LWRAP, LENMSG+1-NEXTC) - IF (LPIECE .LT. LENMSG+1-NEXTC) THEN - DO 52 I=LPIECE+1,2,-1 - IF (MESSG(NEXTC+I-1:NEXTC+I-1) .EQ. ' ') THEN - LPIECE = I-1 - IDELTA = 1 - GOTO 54 - ENDIF - 52 CONTINUE - ENDIF - 54 CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1) - NEXTC = NEXTC + LPIECE + IDELTA - ELSEIF (LPIECE .EQ. 1) THEN -C -C WE HAVE A NEW LINE SENTINEL AT MESSG(NEXTC:NEXTC+1). -C DON'T PRINT A BLANK LINE. -C - NEXTC = NEXTC + 2 - GO TO 50 - ELSEIF (LPIECE .GT. LWRAP+1) THEN -C -C LPIECE SHOULD BE SET DOWN TO LWRAP. -C - IDELTA = 0 - LPIECE = LWRAP - DO 56 I=LPIECE+1,2,-1 - IF (MESSG(NEXTC+I-1:NEXTC+I-1) .EQ. ' ') THEN - LPIECE = I-1 - IDELTA = 1 - GOTO 58 - ENDIF - 56 CONTINUE - 58 CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1) - NEXTC = NEXTC + LPIECE + IDELTA - ELSE -C -C IF WE ARRIVE HERE, IT MEANS 2 .LE. LPIECE .LE. LWRAP+1. -C WE SHOULD DECREMENT LPIECE BY ONE. -C - LPIECE = LPIECE - 1 - CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1) - NEXTC = NEXTC + LPIECE + 2 - ENDIF -C -C PRINT -C - DO 60 I=1,NUNIT - WRITE(IU(I), '(A)') CBUFF(1:LPREF+LPIECE) - 60 CONTINUE -C - IF (NEXTC .LE. LENMSG) GO TO 50 - RETURN - END
--- a/liboctave/cruft/slatec-err/xerrwd.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,97 +0,0 @@ - -*DECK XERRWD - SUBROUTINE XERRWD (MSG, NMES, NERR, LEVEL, NI, I1, I2, NR, R1, R2) -C***BEGIN PROLOGUE XERRWD -C***SUBSIDIARY -C***PURPOSE Write error message with values. -C***LIBRARY MATHLIB -C***CATEGORY R3C -C***TYPE DOUBLE PRECISION (XERRWV-S, XERRWD-D) -C***AUTHOR Hindmarsh, Alan C., (LLNL) -C***DESCRIPTION -C -C Subroutines XERRWD, XSETF, XSETUN, and the function routine IXSAV, -C as given here, constitute a simplified version of the SLATEC error -C handling package. -C -C All arguments are input arguments. -C -C MSG = The message (character array). -C NMES = The length of MSG (number of characters). -C NERR = The error number (not used). -C LEVEL = The error level.. -C 0 or 1 means recoverable (control returns to caller). -C 2 means fatal (run is aborted--see note below). -C NI = Number of integers (0, 1, or 2) to be printed with message. -C I1,I2 = Integers to be printed, depending on NI. -C NR = Number of reals (0, 1, or 2) to be printed with message. -C R1,R2 = Reals to be printed, depending on NR. -C -C Note.. this routine is machine-dependent and specialized for use -C in limited context, in the following ways.. -C 1. The argument MSG is assumed to be of type CHARACTER, and -C the message is printed with a format of (1X,A). -C 2. The message is assumed to take only one line. -C Multi-line messages are generated by repeated calls. -C 3. If LEVEL = 2, control passes to the statement STOP -C to abort the run. This statement may be machine-dependent. -C 4. R1 and R2 are assumed to be in double precision and are printed -C in D21.13 format. -C -C***ROUTINES CALLED IXSAV -C***REVISION HISTORY (YYMMDD) -C 920831 DATE WRITTEN -C 921118 Replaced MFLGSV/LUNSAV by IXSAV. (ACH) -C 930329 Modified prologue to SLATEC format. (FNF) -C 930407 Changed MSG from CHARACTER*1 array to variable. (FNF) -C 930922 Minor cosmetic change. (FNF) -C***END PROLOGUE XERRWD -C -C*Internal Notes: -C -C For a different default logical unit number, IXSAV (or a subsidiary -C routine that it calls) will need to be modified. -C For a different run-abort command, change the statement following -C statement 100 at the end. -C----------------------------------------------------------------------- -C Subroutines called by XERRWD.. None -C Function routine called by XERRWD.. IXSAV -C----------------------------------------------------------------------- -C**End -C -C Declare arguments. -C - DOUBLE PRECISION R1, R2 - INTEGER NMES, NERR, LEVEL, NI, I1, I2, NR - CHARACTER*(*) MSG -C -C Declare local variables. -C - INTEGER LUNIT, IXSAV, MESFLG -C -C Get logical unit number and message print flag. -C -C***FIRST EXECUTABLE STATEMENT XERRWD - LUNIT = IXSAV (1, 0, .FALSE.) - MESFLG = IXSAV (2, 0, .FALSE.) - IF (MESFLG .EQ. 0) GO TO 100 -C -C Write the message. -C - WRITE (LUNIT,10) MSG(1:NMES) - 10 FORMAT(1X,A) - IF (NI .EQ. 1) WRITE (LUNIT, 20) I1 - 20 FORMAT(6X,'In above message, I1 =',I10) - IF (NI .EQ. 2) WRITE (LUNIT, 30) I1,I2 - 30 FORMAT(6X,'In above message, I1 =',I10,3X,'I2 =',I10) - IF (NR .EQ. 1) WRITE (LUNIT, 40) R1 - 40 FORMAT(6X,'In above message, R1 =',D21.13) - IF (NR .EQ. 2) WRITE (LUNIT, 50) R1,R2 - 50 FORMAT(6X,'In above, R1 =',D21.13,3X,'R2 =',D21.13) -C -C Abort the run if LEVEL = 2. -C - 100 IF (LEVEL .NE. 2) RETURN - CALL XSTOPX (' ') -C----------------------- End of Subroutine XERRWD ---------------------- - END
--- a/liboctave/cruft/slatec-err/xersve.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,155 +0,0 @@ -*DECK XERSVE - SUBROUTINE XERSVE (LIBRAR, SUBROU, MESSG, KFLAG, NERR, LEVEL, - + ICOUNT) -C***BEGIN PROLOGUE XERSVE -C***SUBSIDIARY -C***PURPOSE Record that an error has occurred. -C***LIBRARY SLATEC (XERROR) -C***CATEGORY R3 -C***TYPE ALL (XERSVE-A) -C***KEYWORDS ERROR, XERROR -C***AUTHOR Jones, R. E., (SNLA) -C***DESCRIPTION -C -C *Usage: -C -C INTEGER KFLAG, NERR, LEVEL, ICOUNT -C CHARACTER * (len) LIBRAR, SUBROU, MESSG -C -C CALL XERSVE (LIBRAR, SUBROU, MESSG, KFLAG, NERR, LEVEL, ICOUNT) -C -C *Arguments: -C -C LIBRAR :IN is the library that the message is from. -C SUBROU :IN is the subroutine that the message is from. -C MESSG :IN is the message to be saved. -C KFLAG :IN indicates the action to be performed. -C when KFLAG > 0, the message in MESSG is saved. -C when KFLAG=0 the tables will be dumped and -C cleared. -C when KFLAG < 0, the tables will be dumped and -C not cleared. -C NERR :IN is the error number. -C LEVEL :IN is the error severity. -C ICOUNT :OUT the number of times this message has been seen, -C or zero if the table has overflowed and does not -C contain this message specifically. When KFLAG=0, -C ICOUNT will not be altered. -C -C *Description: -C -C Record that this error occurred and possibly dump and clear the -C tables. -C -C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC -C Error-handling Package, SAND82-0800, Sandia -C Laboratories, 1982. -C***ROUTINES CALLED I1MACH, XGETUA -C***REVISION HISTORY (YYMMDD) -C 800319 DATE WRITTEN -C 861211 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900413 Routine modified to remove reference to KFLAG. (WRB) -C 900510 Changed to add LIBRARY NAME and SUBROUTINE to calling -C sequence, use IF-THEN-ELSE, make number of saved entries -C easily changeable, changed routine name from XERSAV to -C XERSVE. (RWC) -C 910626 Added LIBTAB and SUBTAB to SAVE statement. (BKS) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE XERSVE - PARAMETER (LENTAB=10) - INTEGER LUN(5) - CHARACTER*(*) LIBRAR, SUBROU, MESSG - CHARACTER*8 LIBTAB(LENTAB), SUBTAB(LENTAB), LIB, SUB - CHARACTER*20 MESTAB(LENTAB), MES - DIMENSION NERTAB(LENTAB), LEVTAB(LENTAB), KOUNT(LENTAB) - SAVE LIBTAB, SUBTAB, MESTAB, NERTAB, LEVTAB, KOUNT, KOUNTX, NMSG - DATA KOUNTX/0/, NMSG/0/ -C***FIRST EXECUTABLE STATEMENT XERSVE -C - IF (KFLAG.LE.0) THEN -C -C Dump the table. -C - IF (NMSG.EQ.0) RETURN -C -C Print to each unit. -C - CALL XGETUA (LUN, NUNIT) - DO 20 KUNIT = 1,NUNIT - IUNIT = LUN(KUNIT) - IF (IUNIT.EQ.0) IUNIT = I1MACH(4) -C -C Print the table header. -C - WRITE (IUNIT,9000) -C -C Print body of table. -C - DO 10 I = 1,NMSG - WRITE (IUNIT,9010) LIBTAB(I), SUBTAB(I), MESTAB(I), - * NERTAB(I),LEVTAB(I),KOUNT(I) - 10 CONTINUE -C -C Print number of other errors. -C - IF (KOUNTX.NE.0) WRITE (IUNIT,9020) KOUNTX - WRITE (IUNIT,9030) - 20 CONTINUE -C -C Clear the error tables. -C - IF (KFLAG.EQ.0) THEN - NMSG = 0 - KOUNTX = 0 - ENDIF - ELSE -C -C PROCESS A MESSAGE... -C SEARCH FOR THIS MESSG, OR ELSE AN EMPTY SLOT FOR THIS MESSG, -C OR ELSE DETERMINE THAT THE ERROR TABLE IS FULL. -C - LIB = LIBRAR - SUB = SUBROU - MES = MESSG - DO 30 I = 1,NMSG - IF (LIB.EQ.LIBTAB(I) .AND. SUB.EQ.SUBTAB(I) .AND. - * MES.EQ.MESTAB(I) .AND. NERR.EQ.NERTAB(I) .AND. - * LEVEL.EQ.LEVTAB(I)) THEN - KOUNT(I) = KOUNT(I) + 1 - ICOUNT = KOUNT(I) - RETURN - ENDIF - 30 CONTINUE -C - IF (NMSG.LT.LENTAB) THEN -C -C Empty slot found for new message. -C - NMSG = NMSG + 1 - LIBTAB(I) = LIB - SUBTAB(I) = SUB - MESTAB(I) = MES - NERTAB(I) = NERR - LEVTAB(I) = LEVEL - KOUNT (I) = 1 - ICOUNT = 1 - ELSE -C -C Table is full. -C - KOUNTX = KOUNTX+1 - ICOUNT = 0 - ENDIF - ENDIF - RETURN -C -C Formats. -C - 9000 FORMAT ('0 ERROR MESSAGE SUMMARY' / - + ' LIBRARY SUBROUTINE MESSAGE START NERR', - + ' LEVEL COUNT') - 9010 FORMAT (1X,A,3X,A,3X,A,3I10) - 9020 FORMAT ('0OTHER ERRORS NOT INDIVIDUALLY TABULATED = ', I10) - 9030 FORMAT (1X) - END
--- a/liboctave/cruft/slatec-err/xgetf.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,30 +0,0 @@ -*DECK XGETF - SUBROUTINE XGETF (KONTRL) -C***BEGIN PROLOGUE XGETF -C***PURPOSE Return the current value of the error control flag. -C***LIBRARY SLATEC (XERROR) -C***CATEGORY R3C -C***TYPE ALL (XGETF-A) -C***KEYWORDS ERROR, XERROR -C***AUTHOR Jones, R. E., (SNLA) -C***DESCRIPTION -C -C Abstract -C XGETF returns the current value of the error control flag -C in KONTRL. See subroutine XSETF for flag value meanings. -C (KONTRL is an output parameter only.) -C -C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC -C Error-handling Package, SAND82-0800, Sandia -C Laboratories, 1982. -C***ROUTINES CALLED J4SAVE -C***REVISION HISTORY (YYMMDD) -C 790801 DATE WRITTEN -C 861211 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE XGETF -C***FIRST EXECUTABLE STATEMENT XGETF - KONTRL = J4SAVE(2,0,.FALSE.) - RETURN - END
--- a/liboctave/cruft/slatec-err/xgetua.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,51 +0,0 @@ -*DECK XGETUA - SUBROUTINE XGETUA (IUNITA, N) -C***BEGIN PROLOGUE XGETUA -C***PURPOSE Return unit number(s) to which error messages are being -C sent. -C***LIBRARY SLATEC (XERROR) -C***CATEGORY R3C -C***TYPE ALL (XGETUA-A) -C***KEYWORDS ERROR, XERROR -C***AUTHOR Jones, R. E., (SNLA) -C***DESCRIPTION -C -C Abstract -C XGETUA may be called to determine the unit number or numbers -C to which error messages are being sent. -C These unit numbers may have been set by a call to XSETUN, -C or a call to XSETUA, or may be a default value. -C -C Description of Parameters -C --Output-- -C IUNIT - an array of one to five unit numbers, depending -C on the value of N. A value of zero refers to the -C default unit, as defined by the I1MACH machine -C constant routine. Only IUNIT(1),...,IUNIT(N) are -C defined by XGETUA. The values of IUNIT(N+1),..., -C IUNIT(5) are not defined (for N .LT. 5) or altered -C in any way by XGETUA. -C N - the number of units to which copies of the -C error messages are being sent. N will be in the -C range from 1 to 5. -C -C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC -C Error-handling Package, SAND82-0800, Sandia -C Laboratories, 1982. -C***ROUTINES CALLED J4SAVE -C***REVISION HISTORY (YYMMDD) -C 790801 DATE WRITTEN -C 861211 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE XGETUA - DIMENSION IUNITA(5) -C***FIRST EXECUTABLE STATEMENT XGETUA - N = J4SAVE(5,0,.FALSE.) - DO 30 I=1,N - INDEX = I+4 - IF (I.EQ.1) INDEX = 3 - IUNITA(I) = J4SAVE(INDEX,0,.FALSE.) - 30 CONTINUE - RETURN - END
--- a/liboctave/cruft/slatec-err/xsetf.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,60 +0,0 @@ -*DECK XSETF - SUBROUTINE XSETF (KONTRL) -C***BEGIN PROLOGUE XSETF -C***PURPOSE Set the error control flag. -C***LIBRARY SLATEC (XERROR) -C***CATEGORY R3A -C***TYPE ALL (XSETF-A) -C***KEYWORDS ERROR, XERROR -C***AUTHOR Jones, R. E., (SNLA) -C***DESCRIPTION -C -C Abstract -C XSETF sets the error control flag value to KONTRL. -C (KONTRL is an input parameter only.) -C The following table shows how each message is treated, -C depending on the values of KONTRL and LEVEL. (See XERMSG -C for description of LEVEL.) -C -C If KONTRL is zero or negative, no information other than the -C message itself (including numeric values, if any) will be -C printed. If KONTRL is positive, introductory messages, -C trace-backs, etc., will be printed in addition to the message. -C -C ABS(KONTRL) -C LEVEL 0 1 2 -C value -C 2 fatal fatal fatal -C -C 1 not printed printed fatal -C -C 0 not printed printed printed -C -C -1 not printed printed printed -C only only -C once once -C -C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC -C Error-handling Package, SAND82-0800, Sandia -C Laboratories, 1982. -C***ROUTINES CALLED J4SAVE, XERMSG -C***REVISION HISTORY (YYMMDD) -C 790801 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890531 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900510 Change call to XERRWV to XERMSG. (RWC) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE XSETF - CHARACTER *8 XERN1 -C***FIRST EXECUTABLE STATEMENT XSETF - IF (ABS(KONTRL) .GT. 2) THEN - WRITE (XERN1, '(I8)') KONTRL - CALL XERMSG ('SLATEC', 'XSETF', - * 'INVALID ARGUMENT = ' // XERN1, 1, 2) - RETURN - ENDIF -C - JUNK = J4SAVE(2,KONTRL,.TRUE.) - RETURN - END
--- a/liboctave/cruft/slatec-err/xsetua.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,59 +0,0 @@ -*DECK XSETUA - SUBROUTINE XSETUA (IUNITA, N) -C***BEGIN PROLOGUE XSETUA -C***PURPOSE Set logical unit numbers (up to 5) to which error -C messages are to be sent. -C***LIBRARY SLATEC (XERROR) -C***CATEGORY R3B -C***TYPE ALL (XSETUA-A) -C***KEYWORDS ERROR, XERROR -C***AUTHOR Jones, R. E., (SNLA) -C***DESCRIPTION -C -C Abstract -C XSETUA may be called to declare a list of up to five -C logical units, each of which is to receive a copy of -C each error message processed by this package. -C The purpose of XSETUA is to allow simultaneous printing -C of each error message on, say, a main output file, -C an interactive terminal, and other files such as graphics -C communication files. -C -C Description of Parameters -C --Input-- -C IUNIT - an array of up to five unit numbers. -C Normally these numbers should all be different -C (but duplicates are not prohibited.) -C N - the number of unit numbers provided in IUNIT -C must have 1 .LE. N .LE. 5. -C -C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC -C Error-handling Package, SAND82-0800, Sandia -C Laboratories, 1982. -C***ROUTINES CALLED J4SAVE, XERMSG -C***REVISION HISTORY (YYMMDD) -C 790801 DATE WRITTEN -C 861211 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900510 Change call to XERRWV to XERMSG. (RWC) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE XSETUA - DIMENSION IUNITA(5) - CHARACTER *8 XERN1 -C***FIRST EXECUTABLE STATEMENT XSETUA -C - IF (N.LT.1 .OR. N.GT.5) THEN - WRITE (XERN1, '(I8)') N - CALL XERMSG ('SLATEC', 'XSETUA', - * 'INVALID NUMBER OF UNITS, N = ' // XERN1, 1, 2) - RETURN - ENDIF -C - DO 10 I=1,N - INDEX = I+4 - IF (I.EQ.1) INDEX = 3 - JUNK = J4SAVE(INDEX,IUNITA(I),.TRUE.) - 10 CONTINUE - JUNK = J4SAVE(5,N,.TRUE.) - RETURN - END
--- a/liboctave/cruft/slatec-fn/acosh.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,39 +0,0 @@ -*DECK ACOSH - FUNCTION ACOSH (X) -C***BEGIN PROLOGUE ACOSH -C***PURPOSE Compute the arc hyperbolic cosine. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C4C -C***TYPE SINGLE PRECISION (ACOSH-S, DACOSH-D, CACOSH-C) -C***KEYWORDS ACOSH, ARC HYPERBOLIC COSINE, ELEMENTARY FUNCTIONS, FNLIB, -C INVERSE HYPERBOLIC COSINE -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C ACOSH(X) computes the arc hyperbolic cosine of X. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED R1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770401 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890531 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C***END PROLOGUE ACOSH - SAVE ALN2,XMAX - DATA ALN2 / 0.6931471805 5994530942E0/ - DATA XMAX /0./ -C***FIRST EXECUTABLE STATEMENT ACOSH - IF (XMAX.EQ.0.) XMAX = 1.0/SQRT(R1MACH(3)) -C - IF (X .LT. 1.0) CALL XERMSG ('SLATEC', 'ACOSH', 'X LESS THAN 1', - + 1, 2) -C - IF (X.LT.XMAX) ACOSH = LOG (X + SQRT(X*X-1.0)) - IF (X.GE.XMAX) ACOSH = ALN2 + LOG(X) -C - RETURN - END
--- a/liboctave/cruft/slatec-fn/albeta.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,63 +0,0 @@ -*DECK ALBETA - FUNCTION ALBETA (A, B) -C***BEGIN PROLOGUE ALBETA -C***PURPOSE Compute the natural logarithm of the complete Beta -C function. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C7B -C***TYPE SINGLE PRECISION (ALBETA-S, DLBETA-D, CLBETA-C) -C***KEYWORDS FNLIB, LOGARITHM OF THE COMPLETE BETA FUNCTION, -C SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C ALBETA computes the natural log of the complete beta function. -C -C Input Parameters: -C A real and positive -C B real and positive -C -C***REFERENCES (NONE) -C***ROUTINES CALLED ALNGAM, ALNREL, GAMMA, R9LGMC, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770701 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890531 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 900727 Added EXTERNAL statement. (WRB) -C***END PROLOGUE ALBETA - EXTERNAL GAMMA - SAVE SQ2PIL - DATA SQ2PIL / 0.9189385332 0467274 E0 / -C***FIRST EXECUTABLE STATEMENT ALBETA - P = MIN (A, B) - Q = MAX (A, B) -C - IF (P .LE. 0.0) CALL XERMSG ('SLATEC', 'ALBETA', - + 'BOTH ARGUMENTS MUST BE GT ZERO', 1, 2) - IF (P.GE.10.0) GO TO 30 - IF (Q.GE.10.0) GO TO 20 -C -C P AND Q ARE SMALL. -C - ALBETA = LOG(GAMMA(P) * (GAMMA(Q)/GAMMA(P+Q)) ) - RETURN -C -C P IS SMALL, BUT Q IS BIG. -C - 20 CORR = R9LGMC(Q) - R9LGMC(P+Q) - ALBETA = ALNGAM(P) + CORR + P - P*LOG(P+Q) + - 1 (Q-0.5)*ALNREL(-P/(P+Q)) - RETURN -C -C P AND Q ARE BIG. -C - 30 CORR = R9LGMC(P) + R9LGMC(Q) - R9LGMC(P+Q) - ALBETA = -0.5*LOG(Q) + SQ2PIL + CORR + (P-0.5)*LOG(P/(P+Q)) - 1 + Q*ALNREL(-P/(P+Q)) - RETURN -C - END
--- a/liboctave/cruft/slatec-fn/algams.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,38 +0,0 @@ -*DECK ALGAMS - SUBROUTINE ALGAMS (X, ALGAM, SGNGAM) -C***BEGIN PROLOGUE ALGAMS -C***PURPOSE Compute the logarithm of the absolute value of the Gamma -C function. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C7A -C***TYPE SINGLE PRECISION (ALGAMS-S, DLGAMS-D) -C***KEYWORDS ABSOLUTE VALUE OF THE LOGARITHM OF THE GAMMA FUNCTION, -C FNLIB, SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C Evaluates the logarithm of the absolute value of the gamma -C function. -C X - input argument -C ALGAM - result -C SGNGAM - is set to the sign of GAMMA(X) and will -C be returned at +1.0 or -1.0. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED ALNGAM -C***REVISION HISTORY (YYMMDD) -C 770701 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890531 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C***END PROLOGUE ALGAMS -C***FIRST EXECUTABLE STATEMENT ALGAMS - ALGAM = ALNGAM(X) - SGNGAM = 1.0 - IF (X.GT.0.0) RETURN -C - INT = MOD (-AINT(X), 2.0) + 0.1 - IF (INT.EQ.0) SGNGAM = -1.0 -C - RETURN - END
--- a/liboctave/cruft/slatec-fn/alngam.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,70 +0,0 @@ -*DECK ALNGAM - FUNCTION ALNGAM (X) -C***BEGIN PROLOGUE ALNGAM -C***PURPOSE Compute the logarithm of the absolute value of the Gamma -C function. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C7A -C***TYPE SINGLE PRECISION (ALNGAM-S, DLNGAM-D, CLNGAM-C) -C***KEYWORDS ABSOLUTE VALUE, COMPLETE GAMMA FUNCTION, FNLIB, LOGARITHM, -C SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C ALNGAM(X) computes the logarithm of the absolute value of the -C gamma function at X. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED GAMMA, R1MACH, R9LGMC, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770601 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890531 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 900727 Added EXTERNAL statement. (WRB) -C***END PROLOGUE ALNGAM - LOGICAL FIRST - EXTERNAL GAMMA - SAVE SQ2PIL, SQPI2L, PI, XMAX, DXREL, FIRST - DATA SQ2PIL / 0.9189385332 0467274E0/ - DATA SQPI2L / 0.2257913526 4472743E0/ - DATA PI / 3.1415926535 8979324E0/ - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT ALNGAM - IF (FIRST) THEN - XMAX = R1MACH(2)/LOG(R1MACH(2)) - DXREL = SQRT (R1MACH(4)) - ENDIF - FIRST = .FALSE. -C - Y = ABS(X) - IF (Y.GT.10.0) GO TO 20 -C -C LOG (ABS (GAMMA(X))) FOR ABS(X) .LE. 10.0 -C - ALNGAM = LOG (ABS (GAMMA(X))) - RETURN -C -C LOG (ABS (GAMMA(X))) FOR ABS(X) .GT. 10.0 -C - 20 IF (Y .GT. XMAX) CALL XERMSG ('SLATEC', 'ALNGAM', - + 'ABS(X) SO BIG ALNGAM OVERFLOWS', 2, 2) -C - IF (X.GT.0.) ALNGAM = SQ2PIL + (X-0.5)*LOG(X) - X + R9LGMC(Y) - IF (X.GT.0.) RETURN -C - SINPIY = ABS (SIN(PI*Y)) - IF (SINPIY .EQ. 0.) CALL XERMSG ('SLATEC', 'ALNGAM', - + 'X IS A NEGATIVE INTEGER', 3, 2) -C - IF (ABS((X-AINT(X-0.5))/X) .LT. DXREL) CALL XERMSG ('SLATEC', - + 'ALNGAM', 'ANSWER LT HALF PRECISION BECAUSE X TOO NEAR ' // - + 'NEGATIVE INTEGER', 1, 1) -C - ALNGAM = SQPI2L + (X-0.5)*LOG(Y) - X - LOG(SINPIY) - R9LGMC(Y) - RETURN -C - END
--- a/liboctave/cruft/slatec-fn/alnrel.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,78 +0,0 @@ -*DECK ALNREL - FUNCTION ALNREL (X) -C***BEGIN PROLOGUE ALNREL -C***PURPOSE Evaluate ln(1+X) accurate in the sense of relative error. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C4B -C***TYPE SINGLE PRECISION (ALNREL-S, DLNREL-D, CLNREL-C) -C***KEYWORDS ELEMENTARY FUNCTIONS, FNLIB, LOGARITHM -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C ALNREL(X) evaluates ln(1+X) accurately in the sense of relative -C error when X is very small. This routine must be used to -C maintain relative error accuracy whenever X is small and -C accurately known. -C -C Series for ALNR on the interval -3.75000D-01 to 3.75000D-01 -C with weighted error 1.93E-17 -C log weighted error 16.72 -C significant figures required 16.44 -C decimal places required 17.40 -C -C***REFERENCES (NONE) -C***ROUTINES CALLED CSEVL, INITS, R1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770401 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890531 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C***END PROLOGUE ALNREL - DIMENSION ALNRCS(23) - LOGICAL FIRST - SAVE ALNRCS, NLNREL, XMIN, FIRST - DATA ALNRCS( 1) / 1.0378693562 743770E0 / - DATA ALNRCS( 2) / -.1336430150 4908918E0 / - DATA ALNRCS( 3) / .0194082491 35520563E0 / - DATA ALNRCS( 4) / -.0030107551 12753577E0 / - DATA ALNRCS( 5) / .0004869461 47971548E0 / - DATA ALNRCS( 6) / -.0000810548 81893175E0 / - DATA ALNRCS( 7) / .0000137788 47799559E0 / - DATA ALNRCS( 8) / -.0000023802 21089435E0 / - DATA ALNRCS( 9) / .0000004164 04162138E0 / - DATA ALNRCS(10) / -.0000000735 95828378E0 / - DATA ALNRCS(11) / .0000000131 17611876E0 / - DATA ALNRCS(12) / -.0000000023 54670931E0 / - DATA ALNRCS(13) / .0000000004 25227732E0 / - DATA ALNRCS(14) / -.0000000000 77190894E0 / - DATA ALNRCS(15) / .0000000000 14075746E0 / - DATA ALNRCS(16) / -.0000000000 02576907E0 / - DATA ALNRCS(17) / .0000000000 00473424E0 / - DATA ALNRCS(18) / -.0000000000 00087249E0 / - DATA ALNRCS(19) / .0000000000 00016124E0 / - DATA ALNRCS(20) / -.0000000000 00002987E0 / - DATA ALNRCS(21) / .0000000000 00000554E0 / - DATA ALNRCS(22) / -.0000000000 00000103E0 / - DATA ALNRCS(23) / .0000000000 00000019E0 / - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT ALNREL - IF (FIRST) THEN - NLNREL = INITS (ALNRCS, 23, 0.1*R1MACH(3)) - XMIN = -1.0 + SQRT(R1MACH(4)) - ENDIF - FIRST = .FALSE. -C - IF (X .LE. (-1.0)) CALL XERMSG ('SLATEC', 'ALNREL', 'X IS LE -1', - + 2, 2) - IF (X .LT. XMIN) CALL XERMSG ('SLATEC', 'ALNREL', - + 'ANSWER LT HALF PRECISION BECAUSE X TOO NEAR -1', 1, 1) -C - IF (ABS(X).LE.0.375) ALNREL = X*(1. - - 1 X*CSEVL (X/.375, ALNRCS, NLNREL)) - IF (ABS(X).GT.0.375) ALNREL = LOG (1.0+X) -C - RETURN - END
--- a/liboctave/cruft/slatec-fn/asinh.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,74 +0,0 @@ -*DECK ASINH - FUNCTION ASINH (X) -C***BEGIN PROLOGUE ASINH -C***PURPOSE Compute the arc hyperbolic sine. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C4C -C***TYPE SINGLE PRECISION (ASINH-S, DASINH-D, CASINH-C) -C***KEYWORDS ARC HYPERBOLIC SINE, ASINH, ELEMENTARY FUNCTIONS, FNLIB, -C INVERSE HYPERBOLIC SINE -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C ASINH(X) computes the arc hyperbolic sine of X. -C -C Series for ASNH on the interval 0. to 1.00000D+00 -C with weighted error 2.19E-17 -C log weighted error 16.66 -C significant figures required 15.60 -C decimal places required 17.31 -C -C***REFERENCES (NONE) -C***ROUTINES CALLED CSEVL, INITS, R1MACH -C***REVISION HISTORY (YYMMDD) -C 770401 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890531 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C***END PROLOGUE ASINH - DIMENSION ASNHCS(20) - LOGICAL FIRST - SAVE ALN2, ASNHCS, NTERMS, XMAX, SQEPS, FIRST - DATA ALN2 /0.6931471805 5994530942E0/ - DATA ASNHCS( 1) / -.1282003991 1738186E0 / - DATA ASNHCS( 2) / -.0588117611 89951768E0 / - DATA ASNHCS( 3) / .0047274654 32212481E0 / - DATA ASNHCS( 4) / -.0004938363 16265361E0 / - DATA ASNHCS( 5) / .0000585062 07058557E0 / - DATA ASNHCS( 6) / -.0000074669 98328931E0 / - DATA ASNHCS( 7) / .0000010011 69358355E0 / - DATA ASNHCS( 8) / -.0000001390 35438587E0 / - DATA ASNHCS( 9) / .0000000198 23169483E0 / - DATA ASNHCS(10) / -.0000000028 84746841E0 / - DATA ASNHCS(11) / .0000000004 26729654E0 / - DATA ASNHCS(12) / -.0000000000 63976084E0 / - DATA ASNHCS(13) / .0000000000 09699168E0 / - DATA ASNHCS(14) / -.0000000000 01484427E0 / - DATA ASNHCS(15) / .0000000000 00229037E0 / - DATA ASNHCS(16) / -.0000000000 00035588E0 / - DATA ASNHCS(17) / .0000000000 00005563E0 / - DATA ASNHCS(18) / -.0000000000 00000874E0 / - DATA ASNHCS(19) / .0000000000 00000138E0 / - DATA ASNHCS(20) / -.0000000000 00000021E0 / - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT ASINH - IF (FIRST) THEN - NTERMS = INITS (ASNHCS, 20, 0.1*R1MACH(3)) - SQEPS = SQRT (R1MACH(3)) - XMAX = 1.0/SQEPS - ENDIF - FIRST = .FALSE. -C - Y = ABS(X) - IF (Y.GT.1.0) GO TO 20 -C - ASINH = X - IF (Y.GT.SQEPS) ASINH = X*(1.0 + CSEVL (2.*X*X-1., ASNHCS,NTERMS)) - RETURN -C - 20 IF (Y.LT.XMAX) ASINH = LOG (Y + SQRT(Y**2+1.)) - IF (Y.GE.XMAX) ASINH = ALN2 + LOG(Y) - ASINH = SIGN (ASINH, X) -C - RETURN - END
--- a/liboctave/cruft/slatec-fn/atanh.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,78 +0,0 @@ -*DECK ATANH - FUNCTION ATANH (X) -C***BEGIN PROLOGUE ATANH -C***PURPOSE Compute the arc hyperbolic tangent. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C4C -C***TYPE SINGLE PRECISION (ATANH-S, DATANH-D, CATANH-C) -C***KEYWORDS ARC HYPERBOLIC TANGENT, ATANH, ELEMENTARY FUNCTIONS, -C FNLIB, INVERSE HYPERBOLIC TANGENT -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C ATANH(X) computes the arc hyperbolic tangent of X. -C -C Series for ATNH on the interval 0. to 2.50000D-01 -C with weighted error 6.70E-18 -C log weighted error 17.17 -C significant figures required 16.01 -C decimal places required 17.76 -C -C***REFERENCES (NONE) -C***ROUTINES CALLED CSEVL, INITS, R1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770401 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890531 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C***END PROLOGUE ATANH - DIMENSION ATNHCS(15) - LOGICAL FIRST - SAVE ATNHCS, NTERMS, DXREL, SQEPS, FIRST - DATA ATNHCS( 1) / .0943951023 93195492E0 / - DATA ATNHCS( 2) / .0491984370 55786159E0 / - DATA ATNHCS( 3) / .0021025935 22455432E0 / - DATA ATNHCS( 4) / .0001073554 44977611E0 / - DATA ATNHCS( 5) / .0000059782 67249293E0 / - DATA ATNHCS( 6) / .0000003505 06203088E0 / - DATA ATNHCS( 7) / .0000000212 63743437E0 / - DATA ATNHCS( 8) / .0000000013 21694535E0 / - DATA ATNHCS( 9) / .0000000000 83658755E0 / - DATA ATNHCS(10) / .0000000000 05370503E0 / - DATA ATNHCS(11) / .0000000000 00348665E0 / - DATA ATNHCS(12) / .0000000000 00022845E0 / - DATA ATNHCS(13) / .0000000000 00001508E0 / - DATA ATNHCS(14) / .0000000000 00000100E0 / - DATA ATNHCS(15) / .0000000000 00000006E0 / - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT ATANH - IF (FIRST) THEN - NTERMS = INITS (ATNHCS, 15, 0.1*R1MACH(3)) - DXREL = SQRT (R1MACH(4)) - SQEPS = SQRT (3.0*R1MACH(3)) - ENDIF - FIRST = .FALSE. -C - Y = ABS(X) - IF (Y .GE. 1.0) THEN - IF (Y .GT. 1.0) THEN - ATANH = (X - X) / (X - X) - ELSE - ATANH = X / 0.0 - ENDIF - RETURN - ENDIF -C - IF (1.0-Y .LT. DXREL) CALL XERMSG ('SLATEC', 'ATANH', - + 'ANSWER LT HALF PRECISION BECAUSE ABS(X) TOO NEAR 1', 1, 1) -C - ATANH = X - IF (Y.GT.SQEPS .AND. Y.LE.0.5) ATANH = X*(1.0 + CSEVL (8.*X*X-1., - 1 ATNHCS, NTERMS)) - IF (Y.GT.0.5) ATANH = 0.5*LOG((1.0+X)/(1.0-X)) -C - RETURN - END
--- a/liboctave/cruft/slatec-fn/betai.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,118 +0,0 @@ -*DECK BETAI - REAL FUNCTION BETAI (X, PIN, QIN) -C***BEGIN PROLOGUE BETAI -C***PURPOSE Calculate the incomplete Beta function. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C7F -C***TYPE SINGLE PRECISION (BETAI-S, DBETAI-D) -C***KEYWORDS FNLIB, INCOMPLETE BETA FUNCTION, SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C BETAI calculates the REAL incomplete beta function. -C -C The incomplete beta function ratio is the probability that a -C random variable from a beta distribution having parameters PIN and -C QIN will be less than or equal to X. -C -C -- Input Arguments -- All arguments are REAL. -C X upper limit of integration. X must be in (0,1) inclusive. -C PIN first beta distribution parameter. PIN must be .GT. 0.0. -C QIN second beta distribution parameter. QIN must be .GT. 0.0. -C -C***REFERENCES Nancy E. Bosten and E. L. Battiste, Remark on Algorithm -C 179, Communications of the ACM 17, 3 (March 1974), -C pp. 156. -C***ROUTINES CALLED ALBETA, R1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770401 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890531 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920528 DESCRIPTION and REFERENCES sections revised. (WRB) -C***END PROLOGUE BETAI - LOGICAL FIRST - SAVE EPS, ALNEPS, SML, ALNSML, FIRST - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT BETAI - IF (FIRST) THEN - EPS = R1MACH(3) - ALNEPS = LOG(EPS) - SML = R1MACH(1) - ALNSML = LOG(SML) - ENDIF - FIRST = .FALSE. -C - IF (X .LT. 0. .OR. X .GT. 1.0) CALL XERMSG ('SLATEC', 'BETAI', - + 'X IS NOT IN THE RANGE (0,1)', 1, 2) - IF (PIN .LE. 0. .OR. QIN .LE. 0.) CALL XERMSG ('SLATEC', 'BETAI', - + 'P AND/OR Q IS LE ZERO', 2, 2) -C - Y = X - P = PIN - Q = QIN - IF (Q.LE.P .AND. X.LT.0.8) GO TO 20 - IF (X.LT.0.2) GO TO 20 - Y = 1.0 - Y - P = QIN - Q = PIN -C - 20 IF ((P+Q)*Y/(P+1.).LT.EPS) GO TO 80 -C -C EVALUATE THE INFINITE SUM FIRST. -C TERM WILL EQUAL Y**P/BETA(PS,P) * (1.-PS)I * Y**I / FAC(I) -C - PS = Q - AINT(Q) - IF (PS.EQ.0.) PS = 1.0 - XB = P*LOG(Y) - ALBETA(PS, P) - LOG(P) - BETAI = 0.0 - IF (XB.LT.ALNSML) GO TO 40 -C - BETAI = EXP (XB) - TERM = BETAI*P - IF (PS.EQ.1.0) GO TO 40 -C - N = MAX (ALNEPS/LOG(Y), 4.0E0) - DO 30 I=1,N - TERM = TERM*(I-PS)*Y/I - BETAI = BETAI + TERM/(P+I) - 30 CONTINUE -C -C NOW EVALUATE THE FINITE SUM, MAYBE. -C - 40 IF (Q.LE.1.0) GO TO 70 -C - XB = P*LOG(Y) + Q*LOG(1.0-Y) - ALBETA(P,Q) - LOG(Q) - IB = MAX (XB/ALNSML, 0.0E0) - TERM = EXP (XB - IB*ALNSML) - C = 1.0/(1.0-Y) - P1 = Q*C/(P+Q-1.) -C - FINSUM = 0.0 - N = Q - IF (Q.EQ.REAL(N)) N = N - 1 - DO 50 I=1,N - IF (P1.LE.1.0 .AND. TERM/EPS.LE.FINSUM) GO TO 60 - TERM = (Q-I+1)*C*TERM/(P+Q-I) -C - IF (TERM.GT.1.0) IB = IB - 1 - IF (TERM.GT.1.0) TERM = TERM*SML -C - IF (IB.EQ.0) FINSUM = FINSUM + TERM - 50 CONTINUE -C - 60 BETAI = BETAI + FINSUM - 70 IF (Y.NE.X .OR. P.NE.PIN) BETAI = 1.0 - BETAI - BETAI = MAX (MIN (BETAI, 1.0), 0.0) - RETURN -C - 80 BETAI = 0.0 - XB = P*LOG(MAX(Y,SML)) - LOG(P) - ALBETA(P,Q) - IF (XB.GT.ALNSML .AND. Y.NE.0.) BETAI = EXP (XB) - IF (Y.NE.X .OR. P.NE.PIN) BETAI = 1.0 - BETAI - RETURN -C - END
--- a/liboctave/cruft/slatec-fn/csevl.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,65 +0,0 @@ -*DECK CSEVL - FUNCTION CSEVL (X, CS, N) -C***BEGIN PROLOGUE CSEVL -C***PURPOSE Evaluate a Chebyshev series. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C3A2 -C***TYPE SINGLE PRECISION (CSEVL-S, DCSEVL-D) -C***KEYWORDS CHEBYSHEV SERIES, FNLIB, SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C Evaluate the N-term Chebyshev series CS at X. Adapted from -C a method presented in the paper by Broucke referenced below. -C -C Input Arguments -- -C X value at which the series is to be evaluated. -C CS array of N terms of a Chebyshev series. In evaluating -C CS, only half the first coefficient is summed. -C N number of terms in array CS. -C -C***REFERENCES R. Broucke, Ten subroutines for the manipulation of -C Chebyshev series, Algorithm 446, Communications of -C the A.C.M. 16, (1973) pp. 254-256. -C L. Fox and I. B. Parker, Chebyshev Polynomials in -C Numerical Analysis, Oxford University Press, 1968, -C page 56. -C***ROUTINES CALLED R1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770401 DATE WRITTEN -C 890831 Modified array declarations. (WRB) -C 890831 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900329 Prologued revised extensively and code rewritten to allow -C X to be slightly outside interval (-1,+1). (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE CSEVL - REAL B0, B1, B2, CS(*), ONEPL, TWOX, X - LOGICAL FIRST - SAVE FIRST, ONEPL - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT CSEVL - IF (FIRST) ONEPL = 1.0E0 + R1MACH(4) - FIRST = .FALSE. - IF (N .LT. 1) CALL XERMSG ('SLATEC', 'CSEVL', - + 'NUMBER OF TERMS .LE. 0', 2, 2) - IF (N .GT. 1000) CALL XERMSG ('SLATEC', 'CSEVL', - + 'NUMBER OF TERMS .GT. 1000', 3, 2) - IF (ABS(X) .GT. ONEPL) CALL XERMSG ('SLATEC', 'CSEVL', - + 'X OUTSIDE THE INTERVAL (-1,+1)', 1, 1) -C - B1 = 0.0E0 - B0 = 0.0E0 - TWOX = 2.0*X - DO 10 I = 1,N - B2 = B1 - B1 = B0 - NI = N + 1 - I - B0 = TWOX*B1 - B2 + CS(NI) - 10 CONTINUE -C - CSEVL = 0.5E0*(B0-B2) -C - RETURN - END
--- a/liboctave/cruft/slatec-fn/d9gmit.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,91 +0,0 @@ -*DECK D9GMIT - DOUBLE PRECISION FUNCTION D9GMIT (A, X, ALGAP1, SGNGAM, ALX) -C***BEGIN PROLOGUE D9GMIT -C***SUBSIDIARY -C***PURPOSE Compute Tricomi's incomplete Gamma function for small -C arguments. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C7E -C***TYPE DOUBLE PRECISION (R9GMIT-S, D9GMIT-D) -C***KEYWORDS COMPLEMENTARY INCOMPLETE GAMMA FUNCTION, FNLIB, SMALL X, -C SPECIAL FUNCTIONS, TRICOMI -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C Compute Tricomi's incomplete gamma function for small X. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH, DLNGAM, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770701 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890911 Removed unnecessary intrinsics. (WRB) -C 890911 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900720 Routine changed from user-callable to subsidiary. (WRB) -C***END PROLOGUE D9GMIT - DOUBLE PRECISION A, X, ALGAP1, SGNGAM, ALX, AE, AEPS, ALGS, ALG2, - 1 BOT, EPS, FK, S, SGNG2, T, TE, D1MACH, DLNGAM - LOGICAL FIRST - SAVE EPS, BOT, FIRST - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT D9GMIT - IF (FIRST) THEN - EPS = 0.5D0*D1MACH(3) - BOT = LOG (D1MACH(1)) - ENDIF - FIRST = .FALSE. -C - IF (X .LE. 0.D0) CALL XERMSG ('SLATEC', 'D9GMIT', - + 'X SHOULD BE GT 0', 1, 2) -C - MA = A + 0.5D0 - IF (A.LT.0.D0) MA = A - 0.5D0 - AEPS = A - MA -C - AE = A - IF (A.LT.(-0.5D0)) AE = AEPS -C - T = 1.D0 - TE = AE - S = T - DO 20 K=1,200 - FK = K - TE = -X*TE/FK - T = TE/(AE+FK) - S = S + T - IF (ABS(T).LT.EPS*ABS(S)) GO TO 30 - 20 CONTINUE - CALL XERMSG ('SLATEC', 'D9GMIT', - + 'NO CONVERGENCE IN 200 TERMS OF TAYLOR-S SERIES', 2, 2) -C - 30 IF (A.GE.(-0.5D0)) ALGS = -ALGAP1 + LOG(S) - IF (A.GE.(-0.5D0)) GO TO 60 -C - ALGS = -DLNGAM(1.D0+AEPS) + LOG(S) - S = 1.0D0 - M = -MA - 1 - IF (M.EQ.0) GO TO 50 - T = 1.0D0 - DO 40 K=1,M - T = X*T/(AEPS-(M+1-K)) - S = S + T - IF (ABS(T).LT.EPS*ABS(S)) GO TO 50 - 40 CONTINUE -C - 50 D9GMIT = 0.0D0 - ALGS = -MA*LOG(X) + ALGS - IF (S.EQ.0.D0 .OR. AEPS.EQ.0.D0) GO TO 60 -C - SGNG2 = SGNGAM * SIGN (1.0D0, S) - ALG2 = -X - ALGAP1 + LOG(ABS(S)) -C - IF (ALG2.GT.BOT) D9GMIT = SGNG2 * EXP(ALG2) - IF (ALGS.GT.BOT) D9GMIT = D9GMIT + EXP(ALGS) - RETURN -C - 60 D9GMIT = EXP (ALGS) - RETURN -C - END
--- a/liboctave/cruft/slatec-fn/d9lgic.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,54 +0,0 @@ -*DECK D9LGIC - DOUBLE PRECISION FUNCTION D9LGIC (A, X, ALX) -C***BEGIN PROLOGUE D9LGIC -C***SUBSIDIARY -C***PURPOSE Compute the log complementary incomplete Gamma function -C for large X and for A .LE. X. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C7E -C***TYPE DOUBLE PRECISION (R9LGIC-S, D9LGIC-D) -C***KEYWORDS COMPLEMENTARY INCOMPLETE GAMMA FUNCTION, FNLIB, LARGE X, -C LOGARITHM, SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C Compute the log complementary incomplete gamma function for large X -C and for A .LE. X. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770701 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890531 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900720 Routine changed from user-callable to subsidiary. (WRB) -C***END PROLOGUE D9LGIC - DOUBLE PRECISION A, X, ALX, EPS, FK, P, R, S, T, XMA, XPA, D1MACH - SAVE EPS - DATA EPS / 0.D0 / -C***FIRST EXECUTABLE STATEMENT D9LGIC - IF (EPS.EQ.0.D0) EPS = 0.5D0*D1MACH(3) -C - XPA = X + 1.0D0 - A - XMA = X - 1.D0 - A -C - R = 0.D0 - P = 1.D0 - S = P - DO 10 K=1,300 - FK = K - T = FK*(A-FK)*(1.D0+R) - R = -T/((XMA+2.D0*FK)*(XPA+2.D0*FK)+T) - P = R*P - S = S + P - IF (ABS(P).LT.EPS*S) GO TO 20 - 10 CONTINUE - CALL XERMSG ('SLATEC', 'D9LGIC', - + 'NO CONVERGENCE IN 300 TERMS OF CONTINUED FRACTION', 1, 2) -C - 20 D9LGIC = A*ALX - X + LOG(S/XPA) -C - RETURN - END
--- a/liboctave/cruft/slatec-fn/d9lgit.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,67 +0,0 @@ -*DECK D9LGIT - DOUBLE PRECISION FUNCTION D9LGIT (A, X, ALGAP1) -C***BEGIN PROLOGUE D9LGIT -C***SUBSIDIARY -C***PURPOSE Compute the logarithm of Tricomi's incomplete Gamma -C function with Perron's continued fraction for large X and -C A .GE. X. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C7E -C***TYPE DOUBLE PRECISION (R9LGIT-S, D9LGIT-D) -C***KEYWORDS FNLIB, INCOMPLETE GAMMA FUNCTION, LOGARITHM, -C PERRON'S CONTINUED FRACTION, SPECIAL FUNCTIONS, TRICOMI -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C Compute the log of Tricomi's incomplete gamma function with Perron's -C continued fraction for large X and for A .GE. X. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770701 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890531 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900720 Routine changed from user-callable to subsidiary. (WRB) -C***END PROLOGUE D9LGIT - DOUBLE PRECISION A, X, ALGAP1, AX, A1X, EPS, FK, HSTAR, P, R, S, - 1 SQEPS, T, D1MACH - LOGICAL FIRST - SAVE EPS, SQEPS, FIRST - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT D9LGIT - IF (FIRST) THEN - EPS = 0.5D0*D1MACH(3) - SQEPS = SQRT(D1MACH(4)) - ENDIF - FIRST = .FALSE. -C - IF (X .LE. 0.D0 .OR. A .LT. X) CALL XERMSG ('SLATEC', 'D9LGIT', - + 'X SHOULD BE GT 0.0 AND LE A', 2, 2) -C - AX = A + X - A1X = AX + 1.0D0 - R = 0.D0 - P = 1.D0 - S = P - DO 20 K=1,200 - FK = K - T = (A+FK)*X*(1.D0+R) - R = T/((AX+FK)*(A1X+FK)-T) - P = R*P - S = S + P - IF (ABS(P).LT.EPS*S) GO TO 30 - 20 CONTINUE - CALL XERMSG ('SLATEC', 'D9LGIT', - + 'NO CONVERGENCE IN 200 TERMS OF CONTINUED FRACTION', 3, 2) -C - 30 HSTAR = 1.0D0 - X*S/A1X - IF (HSTAR .LT. SQEPS) CALL XERMSG ('SLATEC', 'D9LGIT', - + 'RESULT LESS THAN HALF PRECISION', 1, 1) -C - D9LGIT = -X - ALGAP1 - LOG(HSTAR) - RETURN -C - END
--- a/liboctave/cruft/slatec-fn/d9lgmc.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,76 +0,0 @@ -*DECK D9LGMC - DOUBLE PRECISION FUNCTION D9LGMC (X) -C***BEGIN PROLOGUE D9LGMC -C***SUBSIDIARY -C***PURPOSE Compute the log Gamma correction factor so that -C LOG(DGAMMA(X)) = LOG(SQRT(2*PI)) + (X-5.)*LOG(X) - X -C + D9LGMC(X). -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C7E -C***TYPE DOUBLE PRECISION (R9LGMC-S, D9LGMC-D, C9LGMC-C) -C***KEYWORDS COMPLETE GAMMA FUNCTION, CORRECTION TERM, FNLIB, -C LOG GAMMA, LOGARITHM, SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C Compute the log gamma correction factor for X .GE. 10. so that -C LOG (DGAMMA(X)) = LOG(SQRT(2*PI)) + (X-.5)*LOG(X) - X + D9lGMC(X) -C -C Series for ALGM on the interval 0. to 1.00000E-02 -C with weighted error 1.28E-31 -C log weighted error 30.89 -C significant figures required 29.81 -C decimal places required 31.48 -C -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH, DCSEVL, INITDS, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770601 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890531 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900720 Routine changed from user-callable to subsidiary. (WRB) -C***END PROLOGUE D9LGMC - DOUBLE PRECISION X, ALGMCS(15), XBIG, XMAX, DCSEVL, D1MACH - LOGICAL FIRST - SAVE ALGMCS, NALGM, XBIG, XMAX, FIRST - DATA ALGMCS( 1) / +.1666389480 4518632472 0572965082 2 D+0 / - DATA ALGMCS( 2) / -.1384948176 0675638407 3298605913 5 D-4 / - DATA ALGMCS( 3) / +.9810825646 9247294261 5717154748 7 D-8 / - DATA ALGMCS( 4) / -.1809129475 5724941942 6330626671 9 D-10 / - DATA ALGMCS( 5) / +.6221098041 8926052271 2601554341 6 D-13 / - DATA ALGMCS( 6) / -.3399615005 4177219443 0333059966 6 D-15 / - DATA ALGMCS( 7) / +.2683181998 4826987489 5753884666 6 D-17 / - DATA ALGMCS( 8) / -.2868042435 3346432841 4462239999 9 D-19 / - DATA ALGMCS( 9) / +.3962837061 0464348036 7930666666 6 D-21 / - DATA ALGMCS( 10) / -.6831888753 9857668701 1199999999 9 D-23 / - DATA ALGMCS( 11) / +.1429227355 9424981475 7333333333 3 D-24 / - DATA ALGMCS( 12) / -.3547598158 1010705471 9999999999 9 D-26 / - DATA ALGMCS( 13) / +.1025680058 0104709120 0000000000 0 D-27 / - DATA ALGMCS( 14) / -.3401102254 3167487999 9999999999 9 D-29 / - DATA ALGMCS( 15) / +.1276642195 6300629333 3333333333 3 D-30 / - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT D9LGMC - IF (FIRST) THEN - NALGM = INITDS (ALGMCS, 15, REAL(D1MACH(3)) ) - XBIG = 1.0D0/SQRT(D1MACH(3)) - XMAX = EXP (MIN(LOG(D1MACH(2)/12.D0), -LOG(12.D0*D1MACH(1)))) - ENDIF - FIRST = .FALSE. -C - IF (X .LT. 10.D0) CALL XERMSG ('SLATEC', 'D9LGMC', - + 'X MUST BE GE 10', 1, 2) - IF (X.GE.XMAX) GO TO 20 -C - D9LGMC = 1.D0/(12.D0*X) - IF (X.LT.XBIG) D9LGMC = DCSEVL (2.0D0*(10.D0/X)**2-1.D0, ALGMCS, - 1 NALGM) / X - RETURN -C - 20 D9LGMC = 0.D0 - CALL XERMSG ('SLATEC', 'D9LGMC', 'X SO BIG D9LGMC UNDERFLOWS', 2, - + 1) - RETURN -C - END
--- a/liboctave/cruft/slatec-fn/dacosh.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,40 +0,0 @@ -*DECK DACOSH - DOUBLE PRECISION FUNCTION DACOSH (X) -C***BEGIN PROLOGUE DACOSH -C***PURPOSE Compute the arc hyperbolic cosine. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C4C -C***TYPE DOUBLE PRECISION (ACOSH-S, DACOSH-D, CACOSH-C) -C***KEYWORDS ACOSH, ARC HYPERBOLIC COSINE, ELEMENTARY FUNCTIONS, FNLIB, -C INVERSE HYPERBOLIC COSINE -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C DACOSH(X) calculates the double precision arc hyperbolic cosine for -C double precision argument X. The result is returned on the -C positive branch. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770601 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890531 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C***END PROLOGUE DACOSH - DOUBLE PRECISION X, DLN2, XMAX, D1MACH - SAVE DLN2, XMAX - DATA DLN2 / 0.6931471805 5994530941 7232121458 18 D0 / - DATA XMAX / 0.D0 / -C***FIRST EXECUTABLE STATEMENT DACOSH - IF (XMAX.EQ.0.D0) XMAX = 1.0D0/SQRT(D1MACH(3)) -C - IF (X .LT. 1.D0) CALL XERMSG ('SLATEC', 'DACOSH', - + 'X LESS THAN 1', 1, 2) -C - IF (X.LT.XMAX) DACOSH = LOG (X+SQRT(X*X-1.0D0)) - IF (X.GE.XMAX) DACOSH = DLN2 + LOG(X) -C - RETURN - END
--- a/liboctave/cruft/slatec-fn/dasinh.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,89 +0,0 @@ -*DECK DASINH - DOUBLE PRECISION FUNCTION DASINH (X) -C***BEGIN PROLOGUE DASINH -C***PURPOSE Compute the arc hyperbolic sine. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C4C -C***TYPE DOUBLE PRECISION (ASINH-S, DASINH-D, CASINH-C) -C***KEYWORDS ARC HYPERBOLIC SINE, ASINH, ELEMENTARY FUNCTIONS, FNLIB, -C INVERSE HYPERBOLIC SINE -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C DASINH(X) calculates the double precision arc hyperbolic -C sine for double precision argument X. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH, DCSEVL, INITDS -C***REVISION HISTORY (YYMMDD) -C 770601 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890531 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C***END PROLOGUE DASINH - DOUBLE PRECISION X, ASNHCS(39), ALN2, SQEPS, XMAX, Y, - 1 DCSEVL, D1MACH - LOGICAL FIRST - SAVE ASNHCS, ALN2, NTERMS, XMAX, SQEPS, FIRST - DATA ASNHCS( 1) / -.1282003991 1738186343 3721273592 68 D+0 / - DATA ASNHCS( 2) / -.5881176118 9951767565 2117571383 62 D-1 / - DATA ASNHCS( 3) / +.4727465432 2124815640 7252497560 29 D-2 / - DATA ASNHCS( 4) / -.4938363162 6536172101 3601747902 73 D-3 / - DATA ASNHCS( 5) / +.5850620705 8557412287 4948352593 21 D-4 / - DATA ASNHCS( 6) / -.7466998328 9313681354 7550692171 88 D-5 / - DATA ASNHCS( 7) / +.1001169358 3558199265 9661920158 12 D-5 / - DATA ASNHCS( 8) / -.1390354385 8708333608 6164722588 86 D-6 / - DATA ASNHCS( 9) / +.1982316948 3172793547 3173602371 48 D-7 / - DATA ASNHCS( 10) / -.2884746841 7848843612 7472728003 17 D-8 / - DATA ASNHCS( 11) / +.4267296546 7159937953 4575149959 07 D-9 / - DATA ASNHCS( 12) / -.6397608465 4366357868 7526323096 81 D-10 / - DATA ASNHCS( 13) / +.9699168608 9064704147 8782931311 79 D-11 / - DATA ASNHCS( 14) / -.1484427697 2043770830 2466583656 96 D-11 / - DATA ASNHCS( 15) / +.2290373793 9027447988 0401843789 83 D-12 / - DATA ASNHCS( 16) / -.3558839513 2732645159 9789426513 10 D-13 / - DATA ASNHCS( 17) / +.5563969408 0056789953 3745390885 54 D-14 / - DATA ASNHCS( 18) / -.8746250959 9624678045 6665935201 62 D-15 / - DATA ASNHCS( 19) / +.1381524884 4526692155 8688022981 29 D-15 / - DATA ASNHCS( 20) / -.2191668828 2900363984 9551422641 49 D-16 / - DATA ASNHCS( 21) / +.3490465852 4827565638 3139237068 80 D-17 / - DATA ASNHCS( 22) / -.5578578840 0895742439 6301570321 06 D-18 / - DATA ASNHCS( 23) / +.8944514661 7134012551 0508827989 33 D-19 / - DATA ASNHCS( 24) / -.1438342634 6571317305 5518452394 66 D-19 / - DATA ASNHCS( 25) / +.2319181187 2169963036 3261446826 66 D-20 / - DATA ASNHCS( 26) / -.3748700795 3314343674 5706045439 99 D-21 / - DATA ASNHCS( 27) / +.6073210982 2064279404 5492428800 00 D-22 / - DATA ASNHCS( 28) / -.9859940276 4633583177 3701734400 00 D-23 / - DATA ASNHCS( 29) / +.1603921745 2788496315 2326382933 33 D-23 / - DATA ASNHCS( 30) / -.2613884735 0287686596 7161343999 99 D-24 / - DATA ASNHCS( 31) / +.4267084960 6857390833 3581653333 33 D-25 / - DATA ASNHCS( 32) / -.6977021703 9185243299 7307733333 33 D-26 / - DATA ASNHCS( 33) / +.1142508833 6806858659 8126933333 33 D-26 / - DATA ASNHCS( 34) / -.1873529207 8860968933 0210133333 33 D-27 / - DATA ASNHCS( 35) / +.3076358441 4464922794 0659200000 00 D-28 / - DATA ASNHCS( 36) / -.5057736403 1639824787 0463999999 99 D-29 / - DATA ASNHCS( 37) / +.8325075471 2689142224 2133333333 33 D-30 / - DATA ASNHCS( 38) / -.1371845728 2501044163 9253333333 33 D-30 / - DATA ASNHCS( 39) / +.2262986842 6552784104 1066666666 66 D-31 / - DATA ALN2 / 0.6931471805 5994530941 7232121458 18D0 / - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT DASINH - IF (FIRST) THEN - NTERMS = INITDS (ASNHCS, 39, 0.1*REAL(D1MACH(3)) ) - SQEPS = SQRT(D1MACH(3)) - XMAX = 1.0D0/SQEPS - ENDIF - FIRST = .FALSE. -C - Y = ABS(X) - IF (Y.GT.1.0D0) GO TO 20 -C - DASINH = X - IF (Y.GT.SQEPS) DASINH = X*(1.0D0 + DCSEVL (2.D0*X*X-1.D0, - 1 ASNHCS, NTERMS) ) - RETURN - 20 IF (Y.LT.XMAX) DASINH = LOG (Y+SQRT(Y*Y+1.D0)) - IF (Y.GE.XMAX) DASINH = ALN2 + LOG(Y) - DASINH = SIGN (DASINH, X) - RETURN -C - END
--- a/liboctave/cruft/slatec-fn/datanh.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,89 +0,0 @@ -*DECK DATANH - DOUBLE PRECISION FUNCTION DATANH (X) -C***BEGIN PROLOGUE DATANH -C***PURPOSE Compute the arc hyperbolic tangent. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C4C -C***TYPE DOUBLE PRECISION (ATANH-S, DATANH-D, CATANH-C) -C***KEYWORDS ARC HYPERBOLIC TANGENT, ATANH, ELEMENTARY FUNCTIONS, -C FNLIB, INVERSE HYPERBOLIC TANGENT -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C DATANH(X) calculates the double precision arc hyperbolic -C tangent for double precision argument X. -C -C Series for ATNH on the interval 0. to 2.50000E-01 -C with weighted error 6.86E-32 -C log weighted error 31.16 -C significant figures required 30.00 -C decimal places required 31.88 -C -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH, DCSEVL, INITDS, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770601 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890531 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C***END PROLOGUE DATANH - DOUBLE PRECISION X, ATNHCS(27), DXREL, SQEPS, Y, DCSEVL, D1MACH - LOGICAL FIRST - SAVE ATNHCS, NTERMS, DXREL, SQEPS, FIRST - DATA ATNHCS( 1) / +.9439510239 3195492308 4289221863 3 D-1 / - DATA ATNHCS( 2) / +.4919843705 5786159472 0003457666 8 D-1 / - DATA ATNHCS( 3) / +.2102593522 4554327634 7932733175 2 D-2 / - DATA ATNHCS( 4) / +.1073554449 7761165846 4073104527 6 D-3 / - DATA ATNHCS( 5) / +.5978267249 2930314786 4278751787 2 D-5 / - DATA ATNHCS( 6) / +.3505062030 8891348459 6683488620 0 D-6 / - DATA ATNHCS( 7) / +.2126374343 7653403508 9621931443 1 D-7 / - DATA ATNHCS( 8) / +.1321694535 7155271921 2980172305 5 D-8 / - DATA ATNHCS( 9) / +.8365875501 1780703646 2360405295 9 D-10 / - DATA ATNHCS( 10) / +.5370503749 3110021638 8143458777 2 D-11 / - DATA ATNHCS( 11) / +.3486659470 1571079229 7124578429 0 D-12 / - DATA ATNHCS( 12) / +.2284549509 6034330155 2402411972 2 D-13 / - DATA ATNHCS( 13) / +.1508407105 9447930448 7422906755 8 D-14 / - DATA ATNHCS( 14) / +.1002418816 8041091261 3699572283 7 D-15 / - DATA ATNHCS( 15) / +.6698674738 1650695397 1552688298 6 D-17 / - DATA ATNHCS( 16) / +.4497954546 4949310830 8332762453 3 D-18 / - DATA ATNHCS( 17) / +.3032954474 2794535416 8236714666 6 D-19 / - DATA ATNHCS( 18) / +.2052702064 1909368264 6386141866 6 D-20 / - DATA ATNHCS( 19) / +.1393848977 0538377131 9301461333 3 D-21 / - DATA ATNHCS( 20) / +.9492580637 2245769719 5895466666 6 D-23 / - DATA ATNHCS( 21) / +.6481915448 2423076049 8244266666 6 D-24 / - DATA ATNHCS( 22) / +.4436730205 7236152726 3232000000 0 D-25 / - DATA ATNHCS( 23) / +.3043465618 5431616389 1200000000 0 D-26 / - DATA ATNHCS( 24) / +.2091881298 7923934740 4799999999 9 D-27 / - DATA ATNHCS( 25) / +.1440445411 2340505613 6533333333 3 D-28 / - DATA ATNHCS( 26) / +.9935374683 1416404650 6666666666 6 D-30 / - DATA ATNHCS( 27) / +.6863462444 3582600533 3333333333 3 D-31 / - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT DATANH - IF (FIRST) THEN - NTERMS = INITDS (ATNHCS, 27, 0.1*REAL(D1MACH(3)) ) - DXREL = SQRT(D1MACH(4)) - SQEPS = SQRT(3.0D0*D1MACH(3)) - ENDIF - FIRST = .FALSE. -C - Y = ABS(X) - IF (Y .GE. 1.D0) THEN - IF (Y .GT. 1.D0) THEN - DATANH = (X - X) / (X - X) - ELSE - DATANH = X / 0.D0 - ENDIF - RETURN - ENDIF -C - IF (1.D0-Y .LT. DXREL) CALL XERMSG ('SLATEC', 'DATANH', - + 'ANSWER LT HALF PRECISION BECAUSE ABS(X) TOO NEAR 1', 1, 1) -C - DATANH = X - IF (Y.GT.SQEPS .AND. Y.LE.0.5D0) DATANH = X*(1.0D0 + - 1 DCSEVL (8.D0*X*X-1.D0, ATNHCS, NTERMS) ) - IF (Y.GT.0.5D0) DATANH = 0.5D0*LOG ((1.0D0+X)/(1.0D0-X)) -C - RETURN - END
--- a/liboctave/cruft/slatec-fn/dbetai.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,121 +0,0 @@ - -*DECK DBETAI - DOUBLE PRECISION FUNCTION DBETAI (X, PIN, QIN) -C***BEGIN PROLOGUE DBETAI -C***PURPOSE Calculate the incomplete Beta function. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C7F -C***TYPE DOUBLE PRECISION (BETAI-S, DBETAI-D) -C***KEYWORDS FNLIB, INCOMPLETE BETA FUNCTION, SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C DBETAI calculates the DOUBLE PRECISION incomplete beta function. -C -C The incomplete beta function ratio is the probability that a -C random variable from a beta distribution having parameters PIN and -C QIN will be less than or equal to X. -C -C -- Input Arguments -- All arguments are DOUBLE PRECISION. -C X upper limit of integration. X must be in (0,1) inclusive. -C PIN first beta distribution parameter. PIN must be .GT. 0.0. -C QIN second beta distribution parameter. QIN must be .GT. 0.0. -C -C***REFERENCES Nancy E. Bosten and E. L. Battiste, Remark on Algorithm -C 179, Communications of the ACM 17, 3 (March 1974), -C pp. 156. -C***ROUTINES CALLED D1MACH, DLBETA, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770701 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890911 Removed unnecessary intrinsics. (WRB) -C 890911 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 920528 DESCRIPTION and REFERENCES sections revised. (WRB) -C***END PROLOGUE DBETAI - DOUBLE PRECISION X, PIN, QIN, ALNEPS, ALNSML, C, EPS, FINSUM, P, - 1 PS, Q, SML, TERM, XB, XI, Y, D1MACH, DLBETA, P1 - LOGICAL FIRST - SAVE EPS, ALNEPS, SML, ALNSML, FIRST - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT DBETAI - IF (FIRST) THEN - EPS = D1MACH(3) - ALNEPS = LOG (EPS) - SML = D1MACH(1) - ALNSML = LOG (SML) - ENDIF - FIRST = .FALSE. -C - IF (X .LT. 0.D0 .OR. X .GT. 1.D0) CALL XERMSG ('SLATEC', 'DBETAI', - + 'X IS NOT IN THE RANGE (0,1)', 1, 2) - IF (PIN .LE. 0.D0 .OR. QIN .LE. 0.D0) CALL XERMSG ('SLATEC', - + 'DBETAI', 'P AND/OR Q IS LE ZERO', 2, 2) -C - Y = X - P = PIN - Q = QIN - IF (Q.LE.P .AND. X.LT.0.8D0) GO TO 20 - IF (X.LT.0.2D0) GO TO 20 - Y = 1.0D0 - Y - P = QIN - Q = PIN -C - 20 IF ((P+Q)*Y/(P+1.D0).LT.EPS) GO TO 80 -C -C EVALUATE THE INFINITE SUM FIRST. TERM WILL EQUAL -C Y**P/BETA(PS,P) * (1.-PS)-SUB-I * Y**I / FAC(I) . -C - PS = Q - AINT(Q) - IF (PS.EQ.0.D0) PS = 1.0D0 - XB = P*LOG(Y) - DLBETA(PS,P) - LOG(P) - DBETAI = 0.0D0 - IF (XB.LT.ALNSML) GO TO 40 -C - DBETAI = EXP (XB) - TERM = DBETAI*P - IF (PS.EQ.1.0D0) GO TO 40 - N = MAX (ALNEPS/LOG(Y), 4.0D0) - DO 30 I=1,N - XI = I - TERM = TERM * (XI-PS)*Y/XI - DBETAI = DBETAI + TERM/(P+XI) - 30 CONTINUE -C -C NOW EVALUATE THE FINITE SUM, MAYBE. -C - 40 IF (Q.LE.1.0D0) GO TO 70 -C - XB = P*LOG(Y) + Q*LOG(1.0D0-Y) - DLBETA(P,Q) - LOG(Q) - IB = MAX (XB/ALNSML, 0.0D0) - TERM = EXP(XB - IB*ALNSML) - C = 1.0D0/(1.D0-Y) - P1 = Q*C/(P+Q-1.D0) -C - FINSUM = 0.0D0 - N = Q - IF (Q.EQ.DBLE(N)) N = N - 1 - DO 50 I=1,N - IF (P1.LE.1.0D0 .AND. TERM/EPS.LE.FINSUM) GO TO 60 - XI = I - TERM = (Q-XI+1.0D0)*C*TERM/(P+Q-XI) -C - IF (TERM.GT.1.0D0) IB = IB - 1 - IF (TERM.GT.1.0D0) TERM = TERM*SML -C - IF (IB.EQ.0) FINSUM = FINSUM + TERM - 50 CONTINUE -C - 60 DBETAI = DBETAI + FINSUM - 70 IF (Y.NE.X .OR. P.NE.PIN) DBETAI = 1.0D0 - DBETAI - DBETAI = MAX (MIN (DBETAI, 1.0D0), 0.0D0) - RETURN -C - 80 DBETAI = 0.0D0 - XB = P*LOG(MAX(Y,SML)) - LOG(P) - DLBETA(P,Q) - IF (XB.GT.ALNSML .AND. Y.NE.0.0D0) DBETAI = EXP(XB) - IF (Y.NE.X .OR. P.NE.PIN) DBETAI = 1.0D0 - DBETAI -C - RETURN - END
--- a/liboctave/cruft/slatec-fn/dcsevl.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,65 +0,0 @@ -*DECK DCSEVL - DOUBLE PRECISION FUNCTION DCSEVL (X, CS, N) -C***BEGIN PROLOGUE DCSEVL -C***PURPOSE Evaluate a Chebyshev series. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C3A2 -C***TYPE DOUBLE PRECISION (CSEVL-S, DCSEVL-D) -C***KEYWORDS CHEBYSHEV SERIES, FNLIB, SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C Evaluate the N-term Chebyshev series CS at X. Adapted from -C a method presented in the paper by Broucke referenced below. -C -C Input Arguments -- -C X value at which the series is to be evaluated. -C CS array of N terms of a Chebyshev series. In evaluating -C CS, only half the first coefficient is summed. -C N number of terms in array CS. -C -C***REFERENCES R. Broucke, Ten subroutines for the manipulation of -C Chebyshev series, Algorithm 446, Communications of -C the A.C.M. 16, (1973) pp. 254-256. -C L. Fox and I. B. Parker, Chebyshev Polynomials in -C Numerical Analysis, Oxford University Press, 1968, -C page 56. -C***ROUTINES CALLED D1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770401 DATE WRITTEN -C 890831 Modified array declarations. (WRB) -C 890831 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900329 Prologued revised extensively and code rewritten to allow -C X to be slightly outside interval (-1,+1). (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DCSEVL - DOUBLE PRECISION B0, B1, B2, CS(*), ONEPL, TWOX, X, D1MACH - LOGICAL FIRST - SAVE FIRST, ONEPL - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT DCSEVL - IF (FIRST) ONEPL = 1.0D0 + D1MACH(4) - FIRST = .FALSE. - IF (N .LT. 1) CALL XERMSG ('SLATEC', 'DCSEVL', - + 'NUMBER OF TERMS .LE. 0', 2, 2) - IF (N .GT. 1000) CALL XERMSG ('SLATEC', 'DCSEVL', - + 'NUMBER OF TERMS .GT. 1000', 3, 2) - IF (ABS(X) .GT. ONEPL) CALL XERMSG ('SLATEC', 'DCSEVL', - + 'X OUTSIDE THE INTERVAL (-1,+1)', 1, 1) -C - B1 = 0.0D0 - B0 = 0.0D0 - TWOX = 2.0D0*X - DO 10 I = 1,N - B2 = B1 - B1 = B0 - NI = N + 1 - I - B0 = TWOX*B1 - B2 + CS(NI) - 10 CONTINUE -C - DCSEVL = 0.5D0*(B0-B2) -C - RETURN - END
--- a/liboctave/cruft/slatec-fn/derf.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,83 +0,0 @@ -*DECK DERF - DOUBLE PRECISION FUNCTION DERF (X) -C***BEGIN PROLOGUE DERF -C***PURPOSE Compute the error function. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C8A, L5A1E -C***TYPE DOUBLE PRECISION (ERF-S, DERF-D) -C***KEYWORDS ERF, ERROR FUNCTION, FNLIB, SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C DERF(X) calculates the double precision error function for double -C precision argument X. -C -C Series for ERF on the interval 0. to 1.00000E+00 -C with weighted error 1.28E-32 -C log weighted error 31.89 -C significant figures required 31.05 -C decimal places required 32.55 -C -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH, DCSEVL, DERFC, INITDS -C***REVISION HISTORY (YYMMDD) -C 770701 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890531 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900727 Added EXTERNAL statement. (WRB) -C 920618 Removed space from variable name. (RWC, WRB) -C***END PROLOGUE DERF - DOUBLE PRECISION X, ERFCS(21), SQEPS, SQRTPI, XBIG, Y, D1MACH, - 1 DCSEVL, DERFC - LOGICAL FIRST - EXTERNAL DERFC - SAVE ERFCS, SQRTPI, NTERF, XBIG, SQEPS, FIRST - DATA ERFCS( 1) / -.4904612123 4691808039 9845440333 76 D-1 / - DATA ERFCS( 2) / -.1422612051 0371364237 8247418996 31 D+0 / - DATA ERFCS( 3) / +.1003558218 7599795575 7546767129 33 D-1 / - DATA ERFCS( 4) / -.5768764699 7674847650 8270255091 67 D-3 / - DATA ERFCS( 5) / +.2741993125 2196061034 4221607914 71 D-4 / - DATA ERFCS( 6) / -.1104317550 7344507604 1353812959 05 D-5 / - DATA ERFCS( 7) / +.3848875542 0345036949 9613114981 74 D-7 / - DATA ERFCS( 8) / -.1180858253 3875466969 6317518015 81 D-8 / - DATA ERFCS( 9) / +.3233421582 6050909646 4029309533 54 D-10 / - DATA ERFCS( 10) / -.7991015947 0045487581 6073747085 95 D-12 / - DATA ERFCS( 11) / +.1799072511 3961455611 9672454866 34 D-13 / - DATA ERFCS( 12) / -.3718635487 8186926382 3168282094 93 D-15 / - DATA ERFCS( 13) / +.7103599003 7142529711 6899083946 66 D-17 / - DATA ERFCS( 14) / -.1261245511 9155225832 4954248533 33 D-18 / - DATA ERFCS( 15) / +.2091640694 1769294369 1705002666 66 D-20 / - DATA ERFCS( 16) / -.3253973102 9314072982 3641600000 00 D-22 / - DATA ERFCS( 17) / +.4766867209 7976748332 3733333333 33 D-24 / - DATA ERFCS( 18) / -.6598012078 2851343155 1999999999 99 D-26 / - DATA ERFCS( 19) / +.8655011469 9637626197 3333333333 33 D-28 / - DATA ERFCS( 20) / -.1078892517 7498064213 3333333333 33 D-29 / - DATA ERFCS( 21) / +.1281188399 3017002666 6666666666 66 D-31 / - DATA SQRTPI / 1.772453850 9055160272 9816748334 115D0 / - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT DERF - IF (FIRST) THEN - NTERF = INITDS (ERFCS, 21, 0.1*REAL(D1MACH(3))) - XBIG = SQRT(-LOG(SQRTPI*D1MACH(3))) - SQEPS = SQRT(2.0D0*D1MACH(3)) - ENDIF - FIRST = .FALSE. -C - Y = ABS(X) - IF (Y.GT.1.D0) GO TO 20 -C -C ERF(X) = 1.0 - ERFC(X) FOR -1.0 .LE. X .LE. 1.0 -C - IF (Y.LE.SQEPS) DERF = 2.0D0*X/SQRTPI - IF (Y.GT.SQEPS) DERF = X*(1.0D0 + DCSEVL (2.D0*X*X-1.D0, - 1 ERFCS, NTERF)) - RETURN -C -C ERF(X) = 1.0 - ERFC(X) FOR ABS(X) .GT. 1.0 -C - 20 IF (Y.LE.XBIG) DERF = SIGN (1.0D0-DERFC(Y), X) - IF (Y.GT.XBIG) DERF = SIGN (1.0D0, X) -C - RETURN - END
--- a/liboctave/cruft/slatec-fn/derfc.in.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,230 +0,0 @@ -*DECK DERFC - DOUBLE PRECISION FUNCTION DERFC (X) -C***BEGIN PROLOGUE DERFC -C***PURPOSE Compute the complementary error function. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C8A, L5A1E -C***TYPE DOUBLE PRECISION (ERFC-S, DERFC-D) -C***KEYWORDS COMPLEMENTARY ERROR FUNCTION, ERFC, FNLIB, -C SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C DERFC(X) calculates the double precision complementary error function -C for double precision argument X. -C -C Series for ERF on the interval 0. to 1.00000E+00 -C with weighted Error 1.28E-32 -C log weighted Error 31.89 -C significant figures required 31.05 -C decimal places required 32.55 -C -C Series for ERC2 on the interval 2.50000E-01 to 1.00000E+00 -C with weighted Error 2.67E-32 -C log weighted Error 31.57 -C significant figures required 30.31 -C decimal places required 32.42 -C -C Series for ERFC on the interval 0. to 2.50000E-01 -C with weighted error 1.53E-31 -C log weighted error 30.82 -C significant figures required 29.47 -C decimal places required 31.70 -C -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH, DCSEVL, INITDS, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770701 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890531 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 920618 Removed space from variable names. (RWC, WRB) -C***END PROLOGUE DERFC - DOUBLE PRECISION X, ERFCS(21), ERFCCS(59), ERC2CS(49), SQEPS, - 1 SQRTPI, XMAX, TXMAX, XSML, Y, D1MACH, DCSEVL - LOGICAL FIRST - SAVE ERFCS, ERC2CS, ERFCCS, SQRTPI, NTERF, - 1 NTERFC, NTERC2, XSML, XMAX, SQEPS, FIRST - DATA ERFCS( 1) / -.4904612123 4691808039 9845440333 76 D-1 / - DATA ERFCS( 2) / -.1422612051 0371364237 8247418996 31 D+0 / - DATA ERFCS( 3) / +.1003558218 7599795575 7546767129 33 D-1 / - DATA ERFCS( 4) / -.5768764699 7674847650 8270255091 67 D-3 / - DATA ERFCS( 5) / +.2741993125 2196061034 4221607914 71 D-4 / - DATA ERFCS( 6) / -.1104317550 7344507604 1353812959 05 D-5 / - DATA ERFCS( 7) / +.3848875542 0345036949 9613114981 74 D-7 / - DATA ERFCS( 8) / -.1180858253 3875466969 6317518015 81 D-8 / - DATA ERFCS( 9) / +.3233421582 6050909646 4029309533 54 D-10 / - DATA ERFCS( 10) / -.7991015947 0045487581 6073747085 95 D-12 / - DATA ERFCS( 11) / +.1799072511 3961455611 9672454866 34 D-13 / - DATA ERFCS( 12) / -.3718635487 8186926382 3168282094 93 D-15 / - DATA ERFCS( 13) / +.7103599003 7142529711 6899083946 66 D-17 / - DATA ERFCS( 14) / -.1261245511 9155225832 4954248533 33 D-18 / - DATA ERFCS( 15) / +.2091640694 1769294369 1705002666 66 D-20 / - DATA ERFCS( 16) / -.3253973102 9314072982 3641600000 00 D-22 / - DATA ERFCS( 17) / +.4766867209 7976748332 3733333333 33 D-24 / - DATA ERFCS( 18) / -.6598012078 2851343155 1999999999 99 D-26 / - DATA ERFCS( 19) / +.8655011469 9637626197 3333333333 33 D-28 / - DATA ERFCS( 20) / -.1078892517 7498064213 3333333333 33 D-29 / - DATA ERFCS( 21) / +.1281188399 3017002666 6666666666 66 D-31 / - DATA ERC2CS( 1) / -.6960134660 2309501127 3915082619 7 D-1 / - DATA ERC2CS( 2) / -.4110133936 2620893489 8221208466 6 D-1 / - DATA ERC2CS( 3) / +.3914495866 6896268815 6114370524 4 D-2 / - DATA ERC2CS( 4) / -.4906395650 5489791612 8093545077 4 D-3 / - DATA ERC2CS( 5) / +.7157479001 3770363807 6089414182 5 D-4 / - DATA ERC2CS( 6) / -.1153071634 1312328338 0823284791 2 D-4 / - DATA ERC2CS( 7) / +.1994670590 2019976350 5231486770 9 D-5 / - DATA ERC2CS( 8) / -.3642666471 5992228739 3611843071 1 D-6 / - DATA ERC2CS( 9) / +.6944372610 0050125899 3127721463 3 D-7 / - DATA ERC2CS( 10) / -.1371220902 1043660195 3460514121 0 D-7 / - DATA ERC2CS( 11) / +.2788389661 0071371319 6386034808 7 D-8 / - DATA ERC2CS( 12) / -.5814164724 3311615518 6479105031 6 D-9 / - DATA ERC2CS( 13) / +.1238920491 7527531811 8016881795 0 D-9 / - DATA ERC2CS( 14) / -.2690639145 3067434323 9042493788 9 D-10 / - DATA ERC2CS( 15) / +.5942614350 8479109824 4470968384 0 D-11 / - DATA ERC2CS( 16) / -.1332386735 7581195792 8775442057 0 D-11 / - DATA ERC2CS( 17) / +.3028046806 1771320171 7369724330 4 D-12 / - DATA ERC2CS( 18) / -.6966648814 9410325887 9586758895 4 D-13 / - DATA ERC2CS( 19) / +.1620854541 0539229698 1289322762 8 D-13 / - DATA ERC2CS( 20) / -.3809934465 2504919998 7691305772 9 D-14 / - DATA ERC2CS( 21) / +.9040487815 9788311493 6897101297 5 D-15 / - DATA ERC2CS( 22) / -.2164006195 0896073478 0981204700 3 D-15 / - DATA ERC2CS( 23) / +.5222102233 9958549846 0798024417 2 D-16 / - DATA ERC2CS( 24) / -.1269729602 3645553363 7241552778 0 D-16 / - DATA ERC2CS( 25) / +.3109145504 2761975838 3622741295 1 D-17 / - DATA ERC2CS( 26) / -.7663762920 3203855240 0956671481 1 D-18 / - DATA ERC2CS( 27) / +.1900819251 3627452025 3692973329 0 D-18 / - DATA ERC2CS( 28) / -.4742207279 0690395452 2565599996 5 D-19 / - DATA ERC2CS( 29) / +.1189649200 0765283828 8068307845 1 D-19 / - DATA ERC2CS( 30) / -.3000035590 3257802568 4527131306 6 D-20 / - DATA ERC2CS( 31) / +.7602993453 0432461730 1938527709 8 D-21 / - DATA ERC2CS( 32) / -.1935909447 6068728815 6981104913 0 D-21 / - DATA ERC2CS( 33) / +.4951399124 7733378810 0004238677 3 D-22 / - DATA ERC2CS( 34) / -.1271807481 3363718796 0862198988 8 D-22 / - DATA ERC2CS( 35) / +.3280049600 4695130433 1584165205 3 D-23 / - DATA ERC2CS( 36) / -.8492320176 8228965689 2479242239 9 D-24 / - DATA ERC2CS( 37) / +.2206917892 8075602235 1987998719 9 D-24 / - DATA ERC2CS( 38) / -.5755617245 6965284983 1281950719 9 D-25 / - DATA ERC2CS( 39) / +.1506191533 6392342503 5414405119 9 D-25 / - DATA ERC2CS( 40) / -.3954502959 0187969531 0428569599 9 D-26 / - DATA ERC2CS( 41) / +.1041529704 1515009799 8464505173 3 D-26 / - DATA ERC2CS( 42) / -.2751487795 2787650794 5017890133 3 D-27 / - DATA ERC2CS( 43) / +.7290058205 4975574089 9770368000 0 D-28 / - DATA ERC2CS( 44) / -.1936939645 9159478040 7750109866 6 D-28 / - DATA ERC2CS( 45) / +.5160357112 0514872983 7005482666 6 D-29 / - DATA ERC2CS( 46) / -.1378419322 1930940993 8964480000 0 D-29 / - DATA ERC2CS( 47) / +.3691326793 1070690422 5109333333 3 D-30 / - DATA ERC2CS( 48) / -.9909389590 6243654206 5322666666 6 D-31 / - DATA ERC2CS( 49) / +.2666491705 1953884133 2394666666 6 D-31 / - DATA ERFCCS( 1) / +.7151793102 0292477450 3697709496 D-1 / - DATA ERFCCS( 2) / -.2653243433 7606715755 8893386681 D-1 / - DATA ERFCCS( 3) / +.1711153977 9208558833 2699194606 D-2 / - DATA ERFCCS( 4) / -.1637516634 5851788416 3746404749 D-3 / - DATA ERFCCS( 5) / +.1987129350 0552036499 5974806758 D-4 / - DATA ERFCCS( 6) / -.2843712412 7665550875 0175183152 D-5 / - DATA ERFCCS( 7) / +.4606161308 9631303696 9379968464 D-6 / - DATA ERFCCS( 8) / -.8227753025 8792084205 7766536366 D-7 / - DATA ERFCCS( 9) / +.1592141872 7709011298 9358340826 D-7 / - DATA ERFCCS( 10) / -.3295071362 2528432148 6631665072 D-8 / - DATA ERFCCS( 11) / +.7223439760 4005554658 1261153890 D-9 / - DATA ERFCCS( 12) / -.1664855813 3987295934 4695966886 D-9 / - DATA ERFCCS( 13) / +.4010392588 2376648207 7671768814 D-10 / - DATA ERFCCS( 14) / -.1004816214 4257311327 2170176283 D-10 / - DATA ERFCCS( 15) / +.2608275913 3003338085 9341009439 D-11 / - DATA ERFCCS( 16) / -.6991110560 4040248655 7697812476 D-12 / - DATA ERFCCS( 17) / +.1929492333 2617070862 4205749803 D-12 / - DATA ERFCCS( 18) / -.5470131188 7543310649 0125085271 D-13 / - DATA ERFCCS( 19) / +.1589663309 7626974483 9084032762 D-13 / - DATA ERFCCS( 20) / -.4726893980 1975548392 0369584290 D-14 / - DATA ERFCCS( 21) / +.1435873376 7849847867 2873997840 D-14 / - DATA ERFCCS( 22) / -.4449510561 8173583941 7250062829 D-15 / - DATA ERFCCS( 23) / +.1404810884 7682334373 7305537466 D-15 / - DATA ERFCCS( 24) / -.4513818387 7642108962 5963281623 D-16 / - DATA ERFCCS( 25) / +.1474521541 0451330778 7018713262 D-16 / - DATA ERFCCS( 26) / -.4892621406 9457761543 6841552532 D-17 / - DATA ERFCCS( 27) / +.1647612141 4106467389 5301522827 D-17 / - DATA ERFCCS( 28) / -.5626817176 3294080929 9928521323 D-18 / - DATA ERFCCS( 29) / +.1947443382 2320785142 9197867821 D-18 / - DATA ERFCCS( 30) / -.6826305642 9484207295 6664144723 D-19 / - DATA ERFCCS( 31) / +.2421988887 2986492401 8301125438 D-19 / - DATA ERFCCS( 32) / -.8693414133 5030704256 3800861857 D-20 / - DATA ERFCCS( 33) / +.3155180346 2280855712 2363401262 D-20 / - DATA ERFCCS( 34) / -.1157372324 0496087426 1239486742 D-20 / - DATA ERFCCS( 35) / +.4288947161 6056539462 3737097442 D-21 / - DATA ERFCCS( 36) / -.1605030742 0576168500 5737770964 D-21 / - DATA ERFCCS( 37) / +.6063298757 4538026449 5069923027 D-22 / - DATA ERFCCS( 38) / -.2311404251 6979584909 8840801367 D-22 / - DATA ERFCCS( 39) / +.8888778540 6618855255 4702955697 D-23 / - DATA ERFCCS( 40) / -.3447260576 6513765223 0718495566 D-23 / - DATA ERFCCS( 41) / +.1347865460 2069650682 7582774181 D-23 / - DATA ERFCCS( 42) / -.5311794071 1250217364 5873201807 D-24 / - DATA ERFCCS( 43) / +.2109341058 6197831682 8954734537 D-24 / - DATA ERFCCS( 44) / -.8438365587 9237891159 8133256738 D-25 / - DATA ERFCCS( 45) / +.3399982524 9452089062 7359576337 D-25 / - DATA ERFCCS( 46) / -.1379452388 0732420900 2238377110 D-25 / - DATA ERFCCS( 47) / +.5634490311 8332526151 3392634811 D-26 / - DATA ERFCCS( 48) / -.2316490434 4770654482 3427752700 D-26 / - DATA ERFCCS( 49) / +.9584462844 6018101526 3158381226 D-27 / - DATA ERFCCS( 50) / -.3990722880 3301097262 4224850193 D-27 / - DATA ERFCCS( 51) / +.1672129225 9444773601 7228709669 D-27 / - DATA ERFCCS( 52) / -.7045991522 7660138563 8803782587 D-28 / - DATA ERFCCS( 53) / +.2979768402 8642063541 2357989444 D-28 / - DATA ERFCCS( 54) / -.1262522466 4606192972 2422632994 D-28 / - DATA ERFCCS( 55) / +.5395438704 5424879398 5299653154 D-29 / - DATA ERFCCS( 56) / -.2380992882 5314591867 5346190062 D-29 / - DATA ERFCCS( 57) / +.1099052830 1027615735 9726683750 D-29 / - DATA ERFCCS( 58) / -.4867713741 6449657273 2518677435 D-30 / - DATA ERFCCS( 59) / +.1525877264 1103575676 3200828211 D-30 / - DATA SQRTPI / 1.772453850 9055160272 9816748334 115D0 / - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT DERFC - IF (FIRST) THEN - ETA = 0.1*REAL(D1MACH(3)) - NTERF = INITDS (ERFCS, 21, ETA) - NTERFC = INITDS (ERFCCS, 59, ETA) - NTERC2 = INITDS (ERC2CS, 49, ETA) -C - XSML = -SQRT(-LOG(SQRTPI*D1MACH(3))) - TXMAX = SQRT(-LOG(SQRTPI*D1MACH(1))) - XMAX = TXMAX - 0.5D0*LOG(TXMAX)/TXMAX - 0.01D0 - SQEPS = SQRT(2.0D0*D1MACH(3)) - ENDIF - FIRST = .FALSE. -C - IF (ISNAN(X)) THEN - DERFC = X - RETURN - ENDIF -C - IF (X.GT.XSML) GO TO 20 -C -C ERFC(X) = 1.0 - ERF(X) FOR X .LT. XSML -C - DERFC = 2.0D0 - RETURN -C - 20 IF (X.GT.XMAX) GO TO 40 - Y = ABS(X) - IF (Y.GT.1.0D0) GO TO 30 -C -C ERFC(X) = 1.0 - ERF(X) FOR ABS(X) .LE. 1.0 -C - IF (Y.LT.SQEPS) DERFC = 1.0D0 - 2.0D0*X/SQRTPI - IF (Y.GE.SQEPS) DERFC = 1.0D0 - X*(1.0D0 + DCSEVL (2.D0*X*X-1.D0, - 1 ERFCS, NTERF)) - RETURN -C -C ERFC(X) = 1.0 - ERF(X) FOR 1.0 .LT. ABS(X) .LE. XMAX -C - 30 Y = Y*Y - IF (Y.LE.4.D0) DERFC = EXP(-Y)/ABS(X) * (0.5D0 + DCSEVL ( - 1 (8.D0/Y-5.D0)/3.D0, ERC2CS, NTERC2) ) - IF (Y.GT.4.D0) DERFC = EXP(-Y)/ABS(X) * (0.5D0 + DCSEVL ( - 1 8.D0/Y-1.D0, ERFCCS, NTERFC) ) - IF (X.LT.0.D0) DERFC = 2.0D0 - DERFC - RETURN -C - 40 DERFC = 0.D0 - RETURN -C - END
--- a/liboctave/cruft/slatec-fn/dgami.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,47 +0,0 @@ - -*DECK DGAMI - DOUBLE PRECISION FUNCTION DGAMI (A, X) -C***BEGIN PROLOGUE DGAMI -C***PURPOSE Evaluate the incomplete Gamma function. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C7E -C***TYPE DOUBLE PRECISION (GAMI-S, DGAMI-D) -C***KEYWORDS FNLIB, INCOMPLETE GAMMA FUNCTION, SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C Evaluate the incomplete gamma function defined by -C -C DGAMI = integral from T = 0 to X of EXP(-T) * T**(A-1.0) . -C -C DGAMI is evaluated for positive values of A and non-negative values -C of X. A slight deterioration of 2 or 3 digits accuracy will occur -C when DGAMI is very large or very small, because logarithmic variables -C are used. The function and both arguments are double precision. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED DGAMIT, DLNGAM, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770701 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890531 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C***END PROLOGUE DGAMI - DOUBLE PRECISION A, X, FACTOR, DLNGAM, DGAMIT -C***FIRST EXECUTABLE STATEMENT DGAMI - IF (A .LE. 0.D0) CALL XERMSG ('SLATEC', 'DGAMI', - + 'A MUST BE GT ZERO', 1, 2) - IF (X .LT. 0.D0) CALL XERMSG ('SLATEC', 'DGAMI', - + 'X MUST BE GE ZERO', 2, 2) -C - DGAMI = 0.D0 - IF (X.EQ.0.0D0) RETURN -C -C THE ONLY ERROR POSSIBLE IN THE EXPRESSION BELOW IS A FATAL OVERFLOW. - FACTOR = EXP (DLNGAM(A) + A*LOG(X)) -C - DGAMI = FACTOR * DGAMIT (A, X) -C - RETURN - END
--- a/liboctave/cruft/slatec-fn/dgamit.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,119 +0,0 @@ -*DECK DGAMIT - DOUBLE PRECISION FUNCTION DGAMIT (A, X) -C***BEGIN PROLOGUE DGAMIT -C***PURPOSE Calculate Tricomi's form of the incomplete Gamma function. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C7E -C***TYPE DOUBLE PRECISION (GAMIT-S, DGAMIT-D) -C***KEYWORDS COMPLEMENTARY INCOMPLETE GAMMA FUNCTION, FNLIB, -C SPECIAL FUNCTIONS, TRICOMI -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C Evaluate Tricomi's incomplete Gamma function defined by -C -C DGAMIT = X**(-A)/GAMMA(A) * integral from 0 to X of EXP(-T) * -C T**(A-1.) -C -C for A .GT. 0.0 and by analytic continuation for A .LE. 0.0. -C GAMMA(X) is the complete gamma function of X. -C -C DGAMIT is evaluated for arbitrary real values of A and for non- -C negative values of X (even though DGAMIT is defined for X .LT. -C 0.0), except that for X = 0 and A .LE. 0.0, DGAMIT is infinite, -C which is a fatal error. -C -C The function and both arguments are DOUBLE PRECISION. -C -C A slight deterioration of 2 or 3 digits accuracy will occur when -C DGAMIT is very large or very small in absolute value, because log- -C arithmic variables are used. Also, if the parameter A is very -C close to a negative integer (but not a negative integer), there is -C a loss of accuracy, which is reported if the result is less than -C half machine precision. -C -C***REFERENCES W. Gautschi, A computational procedure for incomplete -C gamma functions, ACM Transactions on Mathematical -C Software 5, 4 (December 1979), pp. 466-481. -C W. Gautschi, Incomplete gamma functions, Algorithm 542, -C ACM Transactions on Mathematical Software 5, 4 -C (December 1979), pp. 482-489. -C***ROUTINES CALLED D1MACH, D9GMIT, D9LGIC, D9LGIT, DGAMR, DLGAMS, -C DLNGAM, XERCLR, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770701 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890531 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 920528 DESCRIPTION and REFERENCES sections revised. (WRB) -C***END PROLOGUE DGAMIT - DOUBLE PRECISION A, X, AEPS, AINTA, ALGAP1, ALNEPS, ALNG, ALX, - 1 BOT, H, SGA, SGNGAM, SQEPS, T, D1MACH, DGAMR, D9GMIT, D9LGIT, - 2 DLNGAM, D9LGIC - LOGICAL FIRST - SAVE ALNEPS, SQEPS, BOT, FIRST - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT DGAMIT - IF (FIRST) THEN - ALNEPS = -LOG (D1MACH(3)) - SQEPS = SQRT(D1MACH(4)) - BOT = LOG (D1MACH(1)) - ENDIF - FIRST = .FALSE. -C - IF (X .LT. 0.D0) CALL XERMSG ('SLATEC', 'DGAMIT', 'X IS NEGATIVE' - + , 2, 2) -C - IF (X.NE.0.D0) ALX = LOG (X) - SGA = 1.0D0 - IF (A.NE.0.D0) SGA = SIGN (1.0D0, A) - AINTA = AINT (A + 0.5D0*SGA) - AEPS = A - AINTA -C - IF (X.GT.0.D0) GO TO 20 - DGAMIT = 0.0D0 - IF (AINTA.GT.0.D0 .OR. AEPS.NE.0.D0) DGAMIT = DGAMR(A+1.0D0) - RETURN -C - 20 IF (X.GT.1.D0) GO TO 30 - IF (A.GE.(-0.5D0) .OR. AEPS.NE.0.D0) CALL DLGAMS (A+1.0D0, ALGAP1, - 1 SGNGAM) - DGAMIT = D9GMIT (A, X, ALGAP1, SGNGAM, ALX) - RETURN -C - 30 IF (A.LT.X) GO TO 40 - T = D9LGIT (A, X, DLNGAM(A+1.0D0)) - IF (T.LT.BOT) CALL XERCLR - DGAMIT = EXP (T) - RETURN -C - 40 ALNG = D9LGIC (A, X, ALX) -C -C EVALUATE DGAMIT IN TERMS OF LOG (DGAMIC (A, X)) -C - H = 1.0D0 - IF (AEPS.EQ.0.D0 .AND. AINTA.LE.0.D0) GO TO 50 -C - CALL DLGAMS (A+1.0D0, ALGAP1, SGNGAM) - T = LOG (ABS(A)) + ALNG - ALGAP1 - IF (T.GT.ALNEPS) GO TO 60 -C - IF (T.GT.(-ALNEPS)) H = 1.0D0 - SGA * SGNGAM * EXP(T) - IF (ABS(H).GT.SQEPS) GO TO 50 -C - CALL XERCLR - CALL XERMSG ('SLATEC', 'DGAMIT', 'RESULT LT HALF PRECISION', 1, - + 1) -C - 50 T = -A*ALX + LOG(ABS(H)) - IF (T.LT.BOT) CALL XERCLR - DGAMIT = SIGN (EXP(T), H) - RETURN -C - 60 T = T - A*ALX - IF (T.LT.BOT) CALL XERCLR - DGAMIT = -SGA * SGNGAM * EXP(T) - RETURN -C - END
--- a/liboctave/cruft/slatec-fn/dgamlm.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,62 +0,0 @@ -*DECK DGAMLM - SUBROUTINE DGAMLM (XMIN, XMAX) -C***BEGIN PROLOGUE DGAMLM -C***PURPOSE Compute the minimum and maximum bounds for the argument in -C the Gamma function. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C7A, R2 -C***TYPE DOUBLE PRECISION (GAMLIM-S, DGAMLM-D) -C***KEYWORDS COMPLETE GAMMA FUNCTION, FNLIB, LIMITS, SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C Calculate the minimum and maximum legal bounds for X in gamma(X). -C XMIN and XMAX are not the only bounds, but they are the only non- -C trivial ones to calculate. -C -C Output Arguments -- -C XMIN double precision minimum legal value of X in gamma(X). Any -C smaller value of X might result in underflow. -C XMAX double precision maximum legal value of X in gamma(X). Any -C larger value of X might cause overflow. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770601 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890531 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C***END PROLOGUE DGAMLM - DOUBLE PRECISION XMIN, XMAX, ALNBIG, ALNSML, XLN, XOLD, D1MACH -C***FIRST EXECUTABLE STATEMENT DGAMLM - ALNSML = LOG(D1MACH(1)) - XMIN = -ALNSML - DO 10 I=1,10 - XOLD = XMIN - XLN = LOG(XMIN) - XMIN = XMIN - XMIN*((XMIN+0.5D0)*XLN - XMIN - 0.2258D0 + ALNSML) - 1 / (XMIN*XLN+0.5D0) - IF (ABS(XMIN-XOLD).LT.0.005D0) GO TO 20 - 10 CONTINUE - CALL XERMSG ('SLATEC', 'DGAMLM', 'UNABLE TO FIND XMIN', 1, 2) -C - 20 XMIN = -XMIN + 0.01D0 -C - ALNBIG = LOG (D1MACH(2)) - XMAX = ALNBIG - DO 30 I=1,10 - XOLD = XMAX - XLN = LOG(XMAX) - XMAX = XMAX - XMAX*((XMAX-0.5D0)*XLN - XMAX + 0.9189D0 - ALNBIG) - 1 / (XMAX*XLN-0.5D0) - IF (ABS(XMAX-XOLD).LT.0.005D0) GO TO 40 - 30 CONTINUE - CALL XERMSG ('SLATEC', 'DGAMLM', 'UNABLE TO FIND XMAX', 2, 2) -C - 40 XMAX = XMAX - 0.01D0 - XMIN = MAX (XMIN, -XMAX+1.D0) -C - RETURN - END
--- a/liboctave/cruft/slatec-fn/dgamma.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,153 +0,0 @@ -*DECK DGAMMA - DOUBLE PRECISION FUNCTION DGAMMA (X) -C***BEGIN PROLOGUE DGAMMA -C***PURPOSE Compute the complete Gamma function. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C7A -C***TYPE DOUBLE PRECISION (GAMMA-S, DGAMMA-D, CGAMMA-C) -C***KEYWORDS COMPLETE GAMMA FUNCTION, FNLIB, SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C DGAMMA(X) calculates the double precision complete Gamma function -C for double precision argument X. -C -C Series for GAM on the interval 0. to 1.00000E+00 -C with weighted error 5.79E-32 -C log weighted error 31.24 -C significant figures required 30.00 -C decimal places required 32.05 -C -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH, D9LGMC, DCSEVL, DGAMLM, INITDS, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770601 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890911 Removed unnecessary intrinsics. (WRB) -C 890911 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 920618 Removed space from variable name. (RWC, WRB) -C***END PROLOGUE DGAMMA - DOUBLE PRECISION X, GAMCS(42), DXREL, PI, SINPIY, SQ2PIL, XMAX, - 1 XMIN, Y, D9LGMC, DCSEVL, D1MACH - LOGICAL FIRST -C - SAVE GAMCS, PI, SQ2PIL, NGAM, XMIN, XMAX, DXREL, FIRST - DATA GAMCS( 1) / +.8571195590 9893314219 2006239994 2 D-2 / - DATA GAMCS( 2) / +.4415381324 8410067571 9131577165 2 D-2 / - DATA GAMCS( 3) / +.5685043681 5993633786 3266458878 9 D-1 / - DATA GAMCS( 4) / -.4219835396 4185605010 1250018662 4 D-2 / - DATA GAMCS( 5) / +.1326808181 2124602205 8400679635 2 D-2 / - DATA GAMCS( 6) / -.1893024529 7988804325 2394702388 6 D-3 / - DATA GAMCS( 7) / +.3606925327 4412452565 7808221722 5 D-4 / - DATA GAMCS( 8) / -.6056761904 4608642184 8554829036 5 D-5 / - DATA GAMCS( 9) / +.1055829546 3022833447 3182350909 3 D-5 / - DATA GAMCS( 10) / -.1811967365 5423840482 9185589116 6 D-6 / - DATA GAMCS( 11) / +.3117724964 7153222777 9025459316 9 D-7 / - DATA GAMCS( 12) / -.5354219639 0196871408 7408102434 7 D-8 / - DATA GAMCS( 13) / +.9193275519 8595889468 8778682594 0 D-9 / - DATA GAMCS( 14) / -.1577941280 2883397617 6742327395 3 D-9 / - DATA GAMCS( 15) / +.2707980622 9349545432 6654043308 9 D-10 / - DATA GAMCS( 16) / -.4646818653 8257301440 8166105893 3 D-11 / - DATA GAMCS( 17) / +.7973350192 0074196564 6076717535 9 D-12 / - DATA GAMCS( 18) / -.1368078209 8309160257 9949917230 9 D-12 / - DATA GAMCS( 19) / +.2347319486 5638006572 3347177168 8 D-13 / - DATA GAMCS( 20) / -.4027432614 9490669327 6657053469 9 D-14 / - DATA GAMCS( 21) / +.6910051747 3721009121 3833697525 7 D-15 / - DATA GAMCS( 22) / -.1185584500 2219929070 5238712619 2 D-15 / - DATA GAMCS( 23) / +.2034148542 4963739552 0102605193 2 D-16 / - DATA GAMCS( 24) / -.3490054341 7174058492 7401294910 8 D-17 / - DATA GAMCS( 25) / +.5987993856 4853055671 3505106602 6 D-18 / - DATA GAMCS( 26) / -.1027378057 8722280744 9006977843 1 D-18 / - DATA GAMCS( 27) / +.1762702816 0605298249 4275966074 8 D-19 / - DATA GAMCS( 28) / -.3024320653 7353062609 5877211204 2 D-20 / - DATA GAMCS( 29) / +.5188914660 2183978397 1783355050 6 D-21 / - DATA GAMCS( 30) / -.8902770842 4565766924 4925160106 6 D-22 / - DATA GAMCS( 31) / +.1527474068 4933426022 7459689130 6 D-22 / - DATA GAMCS( 32) / -.2620731256 1873629002 5732833279 9 D-23 / - DATA GAMCS( 33) / +.4496464047 8305386703 3104657066 6 D-24 / - DATA GAMCS( 34) / -.7714712731 3368779117 0390152533 3 D-25 / - DATA GAMCS( 35) / +.1323635453 1260440364 8657271466 6 D-25 / - DATA GAMCS( 36) / -.2270999412 9429288167 0231381333 3 D-26 / - DATA GAMCS( 37) / +.3896418998 0039914493 2081663999 9 D-27 / - DATA GAMCS( 38) / -.6685198115 1259533277 9212799999 9 D-28 / - DATA GAMCS( 39) / +.1146998663 1400243843 4761386666 6 D-28 / - DATA GAMCS( 40) / -.1967938586 3451346772 9510399999 9 D-29 / - DATA GAMCS( 41) / +.3376448816 5853380903 3489066666 6 D-30 / - DATA GAMCS( 42) / -.5793070335 7821357846 2549333333 3 D-31 / - DATA PI / 3.1415926535 8979323846 2643383279 50 D0 / - DATA SQ2PIL / 0.9189385332 0467274178 0329736405 62 D0 / - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT DGAMMA - IF (FIRST) THEN - NGAM = INITDS (GAMCS, 42, 0.1*REAL(D1MACH(3)) ) -C - CALL DGAMLM (XMIN, XMAX) - DXREL = SQRT(D1MACH(4)) - ENDIF - FIRST = .FALSE. -C - Y = ABS(X) - IF (Y.GT.10.D0) GO TO 50 -C -C COMPUTE GAMMA(X) FOR -XBND .LE. X .LE. XBND. REDUCE INTERVAL AND FIND -C GAMMA(1+Y) FOR 0.0 .LE. Y .LT. 1.0 FIRST OF ALL. -C - N = X - IF (X.LT.0.D0) N = N - 1 - Y = X - N - N = N - 1 - DGAMMA = 0.9375D0 + DCSEVL (2.D0*Y-1.D0, GAMCS, NGAM) - IF (N.EQ.0) RETURN -C - IF (N.GT.0) GO TO 30 -C -C COMPUTE GAMMA(X) FOR X .LT. 1.0 -C - N = -N - IF (X .EQ. 0.D0) CALL XERMSG ('SLATEC', 'DGAMMA', 'X IS 0', 4, 2) - IF (X .LT. 0.0 .AND. X+N-2 .EQ. 0.D0) CALL XERMSG ('SLATEC', - + 'DGAMMA', 'X IS A NEGATIVE INTEGER', 4, 2) - IF (X .LT. (-0.5D0) .AND. ABS((X-AINT(X-0.5D0))/X) .LT. DXREL) - + CALL XERMSG ('SLATEC', 'DGAMMA', - + 'ANSWER LT HALF PRECISION BECAUSE X TOO NEAR NEGATIVE INTEGER', - + 1, 1) -C - DO 20 I=1,N - DGAMMA = DGAMMA/(X+I-1 ) - 20 CONTINUE - RETURN -C -C GAMMA(X) FOR X .GE. 2.0 AND X .LE. 10.0 -C - 30 DO 40 I=1,N - DGAMMA = (Y+I) * DGAMMA - 40 CONTINUE - RETURN -C -C GAMMA(X) FOR ABS(X) .GT. 10.0. RECALL Y = ABS(X). -C - 50 IF (X .GT. XMAX) CALL XERMSG ('SLATEC', 'DGAMMA', - + 'X SO BIG GAMMA OVERFLOWS', 3, 2) -C - DGAMMA = 0.D0 - IF (X .LT. XMIN) CALL XERMSG ('SLATEC', 'DGAMMA', - + 'X SO SMALL GAMMA UNDERFLOWS', 2, 1) - IF (X.LT.XMIN) RETURN -C - DGAMMA = EXP ((Y-0.5D0)*LOG(Y) - Y + SQ2PIL + D9LGMC(Y) ) - IF (X.GT.0.D0) RETURN -C - IF (ABS((X-AINT(X-0.5D0))/X) .LT. DXREL) CALL XERMSG ('SLATEC', - + 'DGAMMA', - + 'ANSWER LT HALF PRECISION, X TOO NEAR NEGATIVE INTEGER', 1, 1) -C - SINPIY = SIN (PI*Y) - IF (SINPIY .EQ. 0.D0) CALL XERMSG ('SLATEC', 'DGAMMA', - + 'X IS A NEGATIVE INTEGER', 4, 2) -C - DGAMMA = -PI/(Y*SINPIY*DGAMMA) -C - RETURN - END
--- a/liboctave/cruft/slatec-fn/dgamr.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,44 +0,0 @@ -*DECK DGAMR - DOUBLE PRECISION FUNCTION DGAMR (X) -C***BEGIN PROLOGUE DGAMR -C***PURPOSE Compute the reciprocal of the Gamma function. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C7A -C***TYPE DOUBLE PRECISION (GAMR-S, DGAMR-D, CGAMR-C) -C***KEYWORDS FNLIB, RECIPROCAL GAMMA FUNCTION, SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C DGAMR(X) calculates the double precision reciprocal of the -C complete Gamma function for double precision argument X. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED DGAMMA, DLGAMS, XERCLR, XGETF, XSETF -C***REVISION HISTORY (YYMMDD) -C 770701 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890531 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900727 Added EXTERNAL statement. (WRB) -C***END PROLOGUE DGAMR - DOUBLE PRECISION X, ALNGX, SGNGX, DGAMMA - EXTERNAL DGAMMA -C***FIRST EXECUTABLE STATEMENT DGAMR - DGAMR = 0.0D0 - IF (X.LE.0.0D0 .AND. AINT(X).EQ.X) RETURN -C - CALL XGETF (IROLD) - CALL XSETF (1) - IF (ABS(X).GT.10.0D0) GO TO 10 - DGAMR = 1.0D0/DGAMMA(X) - CALL XERCLR - CALL XSETF (IROLD) - RETURN -C - 10 CALL DLGAMS (X, ALNGX, SGNGX) - CALL XERCLR - CALL XSETF (IROLD) - DGAMR = SGNGX * EXP(-ALNGX) - RETURN -C - END
--- a/liboctave/cruft/slatec-fn/dlbeta.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,62 +0,0 @@ -*DECK DLBETA - DOUBLE PRECISION FUNCTION DLBETA (A, B) -C***BEGIN PROLOGUE DLBETA -C***PURPOSE Compute the natural logarithm of the complete Beta -C function. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C7B -C***TYPE DOUBLE PRECISION (ALBETA-S, DLBETA-D, CLBETA-C) -C***KEYWORDS FNLIB, LOGARITHM OF THE COMPLETE BETA FUNCTION, -C SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C DLBETA(A,B) calculates the double precision natural logarithm of -C the complete beta function for double precision arguments -C A and B. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED D9LGMC, DGAMMA, DLNGAM, DLNREL, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770701 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890531 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900727 Added EXTERNAL statement. (WRB) -C***END PROLOGUE DLBETA - DOUBLE PRECISION A, B, P, Q, CORR, SQ2PIL, D9LGMC, DGAMMA, DLNGAM, - 1 DLNREL - EXTERNAL DGAMMA - SAVE SQ2PIL - DATA SQ2PIL / 0.9189385332 0467274178 0329736405 62 D0 / -C***FIRST EXECUTABLE STATEMENT DLBETA - P = MIN (A, B) - Q = MAX (A, B) -C - IF (P .LE. 0.D0) CALL XERMSG ('SLATEC', 'DLBETA', - + 'BOTH ARGUMENTS MUST BE GT ZERO', 1, 2) -C - IF (P.GE.10.D0) GO TO 30 - IF (Q.GE.10.D0) GO TO 20 -C -C P AND Q ARE SMALL. -C - DLBETA = LOG (DGAMMA(P) * (DGAMMA(Q)/DGAMMA(P+Q)) ) - RETURN -C -C P IS SMALL, BUT Q IS BIG. -C - 20 CORR = D9LGMC(Q) - D9LGMC(P+Q) - DLBETA = DLNGAM(P) + CORR + P - P*LOG(P+Q) - 1 + (Q-0.5D0)*DLNREL(-P/(P+Q)) - RETURN -C -C P AND Q ARE BIG. -C - 30 CORR = D9LGMC(P) + D9LGMC(Q) - D9LGMC(P+Q) - DLBETA = -0.5D0*LOG(Q) + SQ2PIL + CORR + (P-0.5D0)*LOG(P/(P+Q)) - 1 + Q*DLNREL(-P/(P+Q)) - RETURN -C - END
--- a/liboctave/cruft/slatec-fn/dlgams.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,37 +0,0 @@ -*DECK DLGAMS - SUBROUTINE DLGAMS (X, DLGAM, SGNGAM) -C***BEGIN PROLOGUE DLGAMS -C***PURPOSE Compute the logarithm of the absolute value of the Gamma -C function. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C7A -C***TYPE DOUBLE PRECISION (ALGAMS-S, DLGAMS-D) -C***KEYWORDS ABSOLUTE VALUE OF THE LOGARITHM OF THE GAMMA FUNCTION, -C FNLIB, SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C DLGAMS(X,DLGAM,SGNGAM) calculates the double precision natural -C logarithm of the absolute value of the Gamma function for -C double precision argument X and stores the result in double -C precision argument DLGAM. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED DLNGAM -C***REVISION HISTORY (YYMMDD) -C 770701 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890531 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C***END PROLOGUE DLGAMS - DOUBLE PRECISION X, DLGAM, SGNGAM, DLNGAM -C***FIRST EXECUTABLE STATEMENT DLGAMS - DLGAM = DLNGAM(X) - SGNGAM = 1.0D0 - IF (X.GT.0.D0) RETURN -C - INT = MOD (-AINT(X), 2.0D0) + 0.1D0 - IF (INT.EQ.0) SGNGAM = -1.0D0 -C - RETURN - END
--- a/liboctave/cruft/slatec-fn/dlngam.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,73 +0,0 @@ -*DECK DLNGAM - DOUBLE PRECISION FUNCTION DLNGAM (X) -C***BEGIN PROLOGUE DLNGAM -C***PURPOSE Compute the logarithm of the absolute value of the Gamma -C function. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C7A -C***TYPE DOUBLE PRECISION (ALNGAM-S, DLNGAM-D, CLNGAM-C) -C***KEYWORDS ABSOLUTE VALUE, COMPLETE GAMMA FUNCTION, FNLIB, LOGARITHM, -C SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C DLNGAM(X) calculates the double precision logarithm of the -C absolute value of the Gamma function for double precision -C argument X. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH, D9LGMC, DGAMMA, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770601 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890531 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900727 Added EXTERNAL statement. (WRB) -C***END PROLOGUE DLNGAM - DOUBLE PRECISION X, DXREL, PI, SINPIY, SQPI2L, SQ2PIL, XMAX, - 1 Y, DGAMMA, D9LGMC, D1MACH, TEMP - LOGICAL FIRST - EXTERNAL DGAMMA - SAVE SQ2PIL, SQPI2L, PI, XMAX, DXREL, FIRST - DATA SQ2PIL / 0.9189385332 0467274178 0329736405 62 D0 / - DATA SQPI2L / +.2257913526 4472743236 3097614947 441 D+0 / - DATA PI / 3.1415926535 8979323846 2643383279 50 D0 / - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT DLNGAM - IF (FIRST) THEN - TEMP = 1.D0/LOG(D1MACH(2)) - XMAX = TEMP*D1MACH(2) - DXREL = SQRT(D1MACH(4)) - ENDIF - FIRST = .FALSE. -C - Y = ABS (X) - IF (Y.GT.10.D0) GO TO 20 -C -C LOG (ABS (DGAMMA(X)) ) FOR ABS(X) .LE. 10.0 -C - DLNGAM = LOG (ABS (DGAMMA(X)) ) - RETURN -C -C LOG ( ABS (DGAMMA(X)) ) FOR ABS(X) .GT. 10.0 -C - 20 IF (Y .GT. XMAX) CALL XERMSG ('SLATEC', 'DLNGAM', - + 'ABS(X) SO BIG DLNGAM OVERFLOWS', 2, 2) -C - IF (X.GT.0.D0) DLNGAM = SQ2PIL + (X-0.5D0)*LOG(X) - X + D9LGMC(Y) - IF (X.GT.0.D0) RETURN -C - SINPIY = ABS (SIN(PI*Y)) - IF (SINPIY .EQ. 0.D0) CALL XERMSG ('SLATEC', 'DLNGAM', - + 'X IS A NEGATIVE INTEGER', 3, 2) -C - IF (ABS((X-AINT(X-0.5D0))/X) .LT. DXREL) CALL XERMSG ('SLATEC', - + 'DLNGAM', - + 'ANSWER LT HALF PRECISION BECAUSE X TOO NEAR NEGATIVE INTEGER', - + 1, 1) -C - DLNGAM = SQPI2L + (X-0.5D0)*LOG(Y) - X - LOG(SINPIY) - D9LGMC(Y) - RETURN -C - END
--- a/liboctave/cruft/slatec-fn/dlnrel.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,98 +0,0 @@ -*DECK DLNREL - DOUBLE PRECISION FUNCTION DLNREL (X) -C***BEGIN PROLOGUE DLNREL -C***PURPOSE Evaluate ln(1+X) accurate in the sense of relative error. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C4B -C***TYPE DOUBLE PRECISION (ALNREL-S, DLNREL-D, CLNREL-C) -C***KEYWORDS ELEMENTARY FUNCTIONS, FNLIB, LOGARITHM -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C DLNREL(X) calculates the double precision natural logarithm of -C (1.0+X) for double precision argument X. This routine should -C be used when X is small and accurate to calculate the logarithm -C accurately (in the relative error sense) in the neighborhood -C of 1.0. -C -C Series for ALNR on the interval -3.75000E-01 to 3.75000E-01 -C with weighted error 6.35E-32 -C log weighted error 31.20 -C significant figures required 30.93 -C decimal places required 32.01 -C -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH, DCSEVL, INITDS, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770601 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890531 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C***END PROLOGUE DLNREL - DOUBLE PRECISION ALNRCS(43), X, XMIN, DCSEVL, D1MACH - LOGICAL FIRST - SAVE ALNRCS, NLNREL, XMIN, FIRST - DATA ALNRCS( 1) / +.1037869356 2743769800 6862677190 98 D+1 / - DATA ALNRCS( 2) / -.1336430150 4908918098 7660415531 33 D+0 / - DATA ALNRCS( 3) / +.1940824913 5520563357 9261993747 50 D-1 / - DATA ALNRCS( 4) / -.3010755112 7535777690 3765377765 92 D-2 / - DATA ALNRCS( 5) / +.4869461479 7154850090 4563665091 37 D-3 / - DATA ALNRCS( 6) / -.8105488189 3175356066 8099430086 22 D-4 / - DATA ALNRCS( 7) / +.1377884779 9559524782 9382514960 59 D-4 / - DATA ALNRCS( 8) / -.2380221089 4358970251 3699929149 35 D-5 / - DATA ALNRCS( 9) / +.4164041621 3865183476 3918599019 89 D-6 / - DATA ALNRCS( 10) / -.7359582837 8075994984 2668370319 98 D-7 / - DATA ALNRCS( 11) / +.1311761187 6241674949 1522943450 11 D-7 / - DATA ALNRCS( 12) / -.2354670931 7742425136 6960923301 75 D-8 / - DATA ALNRCS( 13) / +.4252277327 6034997775 6380529625 67 D-9 / - DATA ALNRCS( 14) / -.7719089413 4840796826 1081074933 00 D-10 / - DATA ALNRCS( 15) / +.1407574648 1359069909 2153564721 91 D-10 / - DATA ALNRCS( 16) / -.2576907205 8024680627 5370786275 84 D-11 / - DATA ALNRCS( 17) / +.4734240666 6294421849 1543950059 38 D-12 / - DATA ALNRCS( 18) / -.8724901267 4742641745 3012632926 75 D-13 / - DATA ALNRCS( 19) / +.1612461490 2740551465 7398331191 15 D-13 / - DATA ALNRCS( 20) / -.2987565201 5665773006 7107924168 15 D-14 / - DATA ALNRCS( 21) / +.5548070120 9082887983 0413216972 79 D-15 / - DATA ALNRCS( 22) / -.1032461915 8271569595 1413339619 32 D-15 / - DATA ALNRCS( 23) / +.1925023920 3049851177 8785032448 68 D-16 / - DATA ALNRCS( 24) / -.3595507346 5265150011 1897078442 66 D-17 / - DATA ALNRCS( 25) / +.6726454253 7876857892 1945742267 73 D-18 / - DATA ALNRCS( 26) / -.1260262416 8735219252 0824256375 46 D-18 / - DATA ALNRCS( 27) / +.2364488440 8606210044 9161589555 19 D-19 / - DATA ALNRCS( 28) / -.4441937705 0807936898 8783891797 33 D-20 / - DATA ALNRCS( 29) / +.8354659446 4034259016 2412939946 66 D-21 / - DATA ALNRCS( 30) / -.1573155941 6479562574 8992535210 66 D-21 / - DATA ALNRCS( 31) / +.2965312874 0247422686 1543697066 66 D-22 / - DATA ALNRCS( 32) / -.5594958348 1815947292 1560132266 66 D-23 / - DATA ALNRCS( 33) / +.1056635426 8835681048 1872841386 66 D-23 / - DATA ALNRCS( 34) / -.1997248368 0670204548 3149994666 66 D-24 / - DATA ALNRCS( 35) / +.3778297781 8839361421 0498559999 99 D-25 / - DATA ALNRCS( 36) / -.7153158688 9081740345 0381653333 33 D-26 / - DATA ALNRCS( 37) / +.1355248846 3674213646 5020245333 33 D-26 / - DATA ALNRCS( 38) / -.2569467304 8487567430 0798293333 33 D-27 / - DATA ALNRCS( 39) / +.4874775606 6216949076 4595199999 99 D-28 / - DATA ALNRCS( 40) / -.9254211253 0849715321 1323733333 33 D-29 / - DATA ALNRCS( 41) / +.1757859784 1760239233 2697600000 00 D-29 / - DATA ALNRCS( 42) / -.3341002667 7731010351 3770666666 66 D-30 / - DATA ALNRCS( 43) / +.6353393618 0236187354 1802666666 66 D-31 / - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT DLNREL - IF (FIRST) THEN - NLNREL = INITDS (ALNRCS, 43, 0.1*REAL(D1MACH(3))) - XMIN = -1.0D0 + SQRT(D1MACH(4)) - ENDIF - FIRST = .FALSE. -C - IF (X .LE. (-1.D0)) CALL XERMSG ('SLATEC', 'DLNREL', 'X IS LE -1' - + , 2, 2) - IF (X .LT. XMIN) CALL XERMSG ('SLATEC', 'DLNREL', - + 'ANSWER LT HALF PRECISION BECAUSE X TOO NEAR -1', 1, 1) -C - IF (ABS(X).LE.0.375D0) DLNREL = X*(1.D0 - - 1 X*DCSEVL (X/.375D0, ALNRCS, NLNREL)) -C - IF (ABS(X).GT.0.375D0) DLNREL = LOG (1.0D0+X) -C - RETURN - END
--- a/liboctave/cruft/slatec-fn/dpchim.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,285 +0,0 @@ -*DECK DPCHIM - SUBROUTINE DPCHIM (N, X, F, D, INCFD, IERR) -C***BEGIN PROLOGUE DPCHIM -C***PURPOSE Set derivatives needed to determine a monotone piecewise -C cubic Hermite interpolant to given data. Boundary values -C are provided which are compatible with monotonicity. The -C interpolant will have an extremum at each point where mono- -C tonicity switches direction. (See DPCHIC if user control -C is desired over boundary or switch conditions.) -C***LIBRARY SLATEC (PCHIP) -C***CATEGORY E1A -C***TYPE DOUBLE PRECISION (PCHIM-S, DPCHIM-D) -C***KEYWORDS CUBIC HERMITE INTERPOLATION, MONOTONE INTERPOLATION, -C PCHIP, PIECEWISE CUBIC INTERPOLATION -C***AUTHOR Fritsch, F. N., (LLNL) -C Lawrence Livermore National Laboratory -C P.O. Box 808 (L-316) -C Livermore, CA 94550 -C FTS 532-4275, (510) 422-4275 -C***DESCRIPTION -C -C DPCHIM: Piecewise Cubic Hermite Interpolation to -C Monotone data. -C -C Sets derivatives needed to determine a monotone piecewise cubic -C Hermite interpolant to the data given in X and F. -C -C Default boundary conditions are provided which are compatible -C with monotonicity. (See DPCHIC if user control of boundary con- -C ditions is desired.) -C -C If the data are only piecewise monotonic, the interpolant will -C have an extremum at each point where monotonicity switches direc- -C tion. (See DPCHIC if user control is desired in such cases.) -C -C To facilitate two-dimensional applications, includes an increment -C between successive values of the F- and D-arrays. -C -C The resulting piecewise cubic Hermite function may be evaluated -C by DPCHFE or DPCHFD. -C -C ---------------------------------------------------------------------- -C -C Calling sequence: -C -C PARAMETER (INCFD = ...) -C INTEGER N, IERR -C DOUBLE PRECISION X(N), F(INCFD,N), D(INCFD,N) -C -C CALL DPCHIM (N, X, F, D, INCFD, IERR) -C -C Parameters: -C -C N -- (input) number of data points. (Error return if N.LT.2 .) -C If N=2, simply does linear interpolation. -C -C X -- (input) real*8 array of independent variable values. The -C elements of X must be strictly increasing: -C X(I-1) .LT. X(I), I = 2(1)N. -C (Error return if not.) -C -C F -- (input) real*8 array of dependent variable values to be -C interpolated. F(1+(I-1)*INCFD) is value corresponding to -C X(I). DPCHIM is designed for monotonic data, but it will -C work for any F-array. It will force extrema at points where -C monotonicity switches direction. If some other treatment of -C switch points is desired, DPCHIC should be used instead. -C ----- -C D -- (output) real*8 array of derivative values at the data -C points. If the data are monotonic, these values will -C determine a monotone cubic Hermite function. -C The value corresponding to X(I) is stored in -C D(1+(I-1)*INCFD), I=1(1)N. -C No other entries in D are changed. -C -C INCFD -- (input) increment between successive values in F and D. -C This argument is provided primarily for 2-D applications. -C (Error return if INCFD.LT.1 .) -C -C IERR -- (output) error flag. -C Normal return: -C IERR = 0 (no errors). -C Warning error: -C IERR.GT.0 means that IERR switches in the direction -C of monotonicity were detected. -C "Recoverable" errors: -C IERR = -1 if N.LT.2 . -C IERR = -2 if INCFD.LT.1 . -C IERR = -3 if the X-array is not strictly increasing. -C (The D-array has not been changed in any of these cases.) -C NOTE: The above errors are checked in the order listed, -C and following arguments have **NOT** been validated. -C -C***REFERENCES 1. F. N. Fritsch and J. Butland, A method for construc- -C ting local monotone piecewise cubic interpolants, SIAM -C Journal on Scientific and Statistical Computing 5, 2 -C (June 1984), pp. 300-304. -C 2. F. N. Fritsch and R. E. Carlson, Monotone piecewise -C cubic interpolation, SIAM Journal on Numerical Ana- -C lysis 17, 2 (April 1980), pp. 238-246. -C***ROUTINES CALLED DPCHST, XERMSG -C***REVISION HISTORY (YYMMDD) -C 811103 DATE WRITTEN -C 820201 1. Introduced DPCHST to reduce possible over/under- -C flow problems. -C 2. Rearranged derivative formula for same reason. -C 820602 1. Modified end conditions to be continuous functions -C of data when monotonicity switches in next interval. -C 2. Modified formulas so end conditions are less prone -C of over/underflow problems. -C 820803 Minor cosmetic changes for release 1. -C 870707 Corrected XERROR calls for d.p. name(s). -C 870813 Updated Reference 1. -C 890206 Corrected XERROR calls. -C 890411 Added SAVE statements (Vers. 3.2). -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890703 Corrected category record. (WRB) -C 890831 Modified array declarations. (WRB) -C 891006 Cosmetic changes to prologue. (WRB) -C 891006 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 920429 Revised format and order of references. (WRB,FNF) -C***END PROLOGUE DPCHIM -C Programming notes: -C -C 1. The function DPCHST(ARG1,ARG2) is assumed to return zero if -C either argument is zero, +1 if they are of the same sign, and -C -1 if they are of opposite sign. -C 2. To produce a single precision version, simply: -C a. Change DPCHIM to PCHIM wherever it occurs, -C b. Change DPCHST to PCHST wherever it occurs, -C c. Change all references to the Fortran intrinsics to their -C single precision equivalents, -C d. Change the double precision declarations to real, and -C e. Change the constants ZERO and THREE to single precision. -C -C DECLARE ARGUMENTS. -C - INTEGER N, INCFD, IERR - DOUBLE PRECISION X(*), F(INCFD,*), D(INCFD,*) -C -C DECLARE LOCAL VARIABLES. -C - INTEGER I, NLESS1 - DOUBLE PRECISION DEL1, DEL2, DMAX, DMIN, DRAT1, DRAT2, DSAVE, - * H1, H2, HSUM, HSUMT3, THREE, W1, W2, ZERO - SAVE ZERO, THREE - DOUBLE PRECISION DPCHST - DATA ZERO /0.D0/, THREE/3.D0/ -C -C VALIDITY-CHECK ARGUMENTS. -C -C***FIRST EXECUTABLE STATEMENT DPCHIM - IF ( N.LT.2 ) GO TO 5001 - IF ( INCFD.LT.1 ) GO TO 5002 - DO 1 I = 2, N - IF ( X(I).LE.X(I-1) ) GO TO 5003 - 1 CONTINUE -C -C FUNCTION DEFINITION IS OK, GO ON. -C - IERR = 0 - NLESS1 = N - 1 - H1 = X(2) - X(1) - DEL1 = (F(1,2) - F(1,1))/H1 - DSAVE = DEL1 -C -C SPECIAL CASE N=2 -- USE LINEAR INTERPOLATION. -C - IF (NLESS1 .GT. 1) GO TO 10 - D(1,1) = DEL1 - D(1,N) = DEL1 - GO TO 5000 -C -C NORMAL CASE (N .GE. 3). -C - 10 CONTINUE - H2 = X(3) - X(2) - DEL2 = (F(1,3) - F(1,2))/H2 -C -C SET D(1) VIA NON-CENTERED THREE-POINT FORMULA, ADJUSTED TO BE -C SHAPE-PRESERVING. -C - HSUM = H1 + H2 - W1 = (H1 + HSUM)/HSUM - W2 = -H1/HSUM - D(1,1) = W1*DEL1 + W2*DEL2 - IF ( DPCHST(D(1,1),DEL1) .LE. ZERO) THEN - D(1,1) = ZERO - ELSE IF ( DPCHST(DEL1,DEL2) .LT. ZERO) THEN -C NEED DO THIS CHECK ONLY IF MONOTONICITY SWITCHES. - DMAX = THREE*DEL1 - IF (ABS(D(1,1)) .GT. ABS(DMAX)) D(1,1) = DMAX - ENDIF -C -C LOOP THROUGH INTERIOR POINTS. -C - DO 50 I = 2, NLESS1 - IF (I .EQ. 2) GO TO 40 -C - H1 = H2 - H2 = X(I+1) - X(I) - HSUM = H1 + H2 - DEL1 = DEL2 - DEL2 = (F(1,I+1) - F(1,I))/H2 - 40 CONTINUE -C -C SET D(I)=0 UNLESS DATA ARE STRICTLY MONOTONIC. -C - D(1,I) = ZERO - IF ( DPCHST(DEL1,DEL2) .LT. 0.) GO TO 42 - IF ( DPCHST(DEL1,DEL2) .EQ. 0.) GO TO 41 - GO TO 45 -C -C COUNT NUMBER OF CHANGES IN DIRECTION OF MONOTONICITY. -C - 41 CONTINUE - IF (DEL2 .EQ. ZERO) GO TO 50 - IF ( DPCHST(DSAVE,DEL2) .LT. ZERO) IERR = IERR + 1 - DSAVE = DEL2 - GO TO 50 -C - 42 CONTINUE - IERR = IERR + 1 - DSAVE = DEL2 - GO TO 50 -C -C USE BRODLIE MODIFICATION OF BUTLAND FORMULA. -C - 45 CONTINUE - HSUMT3 = HSUM+HSUM+HSUM - W1 = (HSUM + H1)/HSUMT3 - W2 = (HSUM + H2)/HSUMT3 - DMAX = MAX( ABS(DEL1), ABS(DEL2) ) - DMIN = MIN( ABS(DEL1), ABS(DEL2) ) - DRAT1 = DEL1/DMAX - DRAT2 = DEL2/DMAX - D(1,I) = DMIN/(W1*DRAT1 + W2*DRAT2) -C - 50 CONTINUE -C -C SET D(N) VIA NON-CENTERED THREE-POINT FORMULA, ADJUSTED TO BE -C SHAPE-PRESERVING. -C - W1 = -H2/HSUM - W2 = (H2 + HSUM)/HSUM - D(1,N) = W1*DEL1 + W2*DEL2 - IF ( DPCHST(D(1,N),DEL2) .LE. ZERO) THEN - D(1,N) = ZERO - ELSE IF ( DPCHST(DEL1,DEL2) .LT. ZERO) THEN -C NEED DO THIS CHECK ONLY IF MONOTONICITY SWITCHES. - DMAX = THREE*DEL2 - IF (ABS(D(1,N)) .GT. ABS(DMAX)) D(1,N) = DMAX - ENDIF -C -C NORMAL RETURN. -C - 5000 CONTINUE - RETURN -C -C ERROR RETURNS. -C - 5001 CONTINUE -C N.LT.2 RETURN. - IERR = -1 - CALL XERMSG ('SLATEC', 'DPCHIM', - + 'NUMBER OF DATA POINTS LESS THAN TWO', IERR, 1) - RETURN -C - 5002 CONTINUE -C INCFD.LT.1 RETURN. - IERR = -2 - CALL XERMSG ('SLATEC', 'DPCHIM', 'INCREMENT LESS THAN ONE', IERR, - + 1) - RETURN -C - 5003 CONTINUE -C X-ARRAY NOT STRICTLY INCREASING. - IERR = -3 - CALL XERMSG ('SLATEC', 'DPCHIM', - + 'X-ARRAY NOT STRICTLY INCREASING', IERR, 1) - RETURN -C------------- LAST LINE OF DPCHIM FOLLOWS ----------------------------- - END
--- a/liboctave/cruft/slatec-fn/dpchst.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,59 +0,0 @@ -*DECK DPCHST - DOUBLE PRECISION FUNCTION DPCHST (ARG1, ARG2) -C***BEGIN PROLOGUE DPCHST -C***SUBSIDIARY -C***PURPOSE DPCHIP Sign-Testing Routine -C***LIBRARY SLATEC (PCHIP) -C***TYPE DOUBLE PRECISION (PCHST-S, DPCHST-D) -C***AUTHOR Fritsch, F. N., (LLNL) -C***DESCRIPTION -C -C DPCHST: DPCHIP Sign-Testing Routine. -C -C -C Returns: -C -1. if ARG1 and ARG2 are of opposite sign. -C 0. if either argument is zero. -C +1. if ARG1 and ARG2 are of the same sign. -C -C The object is to do this without multiplying ARG1*ARG2, to avoid -C possible over/underflow problems. -C -C Fortran intrinsics used: SIGN. -C -C***SEE ALSO DPCHCE, DPCHCI, DPCHCS, DPCHIM -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 811103 DATE WRITTEN -C 820805 Converted to SLATEC library version. -C 870813 Minor cosmetic changes. -C 890411 Added SAVE statements (Vers. 3.2). -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890531 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 910408 Updated AUTHOR and DATE WRITTEN sections in prologue. (WRB) -C 930503 Improved purpose. (FNF) -C***END PROLOGUE DPCHST -C -C**End -C -C DECLARE ARGUMENTS. -C - DOUBLE PRECISION ARG1, ARG2 -C -C DECLARE LOCAL VARIABLES. -C - DOUBLE PRECISION ONE, ZERO - SAVE ZERO, ONE - DATA ZERO /0.D0/, ONE/1.D0/ -C -C PERFORM THE TEST. -C -C***FIRST EXECUTABLE STATEMENT DPCHST - DPCHST = SIGN(ONE,ARG1) * SIGN(ONE,ARG2) - IF ((ARG1.EQ.ZERO) .OR. (ARG2.EQ.ZERO)) DPCHST = ZERO -C - RETURN -C------------- LAST LINE OF DPCHST FOLLOWS ----------------------------- - END
--- a/liboctave/cruft/slatec-fn/dpsifn.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,368 +0,0 @@ -*DECK DPSIFN - SUBROUTINE DPSIFN (X, N, KODE, M, ANS, NZ, IERR) -C***BEGIN PROLOGUE DPSIFN -C***PURPOSE Compute derivatives of the Psi function. -C***LIBRARY SLATEC -C***CATEGORY C7C -C***TYPE DOUBLE PRECISION (PSIFN-S, DPSIFN-D) -C***KEYWORDS DERIVATIVES OF THE GAMMA FUNCTION, POLYGAMMA FUNCTION, -C PSI FUNCTION -C***AUTHOR Amos, D. E., (SNLA) -C***DESCRIPTION -C -C The following definitions are used in DPSIFN: -C -C Definition 1 -C PSI(X) = d/dx (ln(GAMMA(X)), the first derivative of -C the log GAMMA function. -C Definition 2 -C K K -C PSI(K,X) = d /dx (PSI(X)), the K-th derivative of PSI(X). -C ___________________________________________________________________ -C DPSIFN computes a sequence of SCALED derivatives of -C the PSI function; i.e. for fixed X and M it computes -C the M-member sequence -C -C ((-1)**(K+1)/GAMMA(K+1))*PSI(K,X) -C for K = N,...,N+M-1 -C -C where PSI(K,X) is as defined above. For KODE=1, DPSIFN returns -C the scaled derivatives as described. KODE=2 is operative only -C when K=0 and in that case DPSIFN returns -PSI(X) + LN(X). That -C is, the logarithmic behavior for large X is removed when KODE=2 -C and K=0. When sums or differences of PSI functions are computed -C the logarithmic terms can be combined analytically and computed -C separately to help retain significant digits. -C -C Note that CALL DPSIFN(X,0,1,1,ANS) results in -C ANS = -PSI(X) -C -C Input X is DOUBLE PRECISION -C X - Argument, X .gt. 0.0D0 -C N - First member of the sequence, 0 .le. N .le. 100 -C N=0 gives ANS(1) = -PSI(X) for KODE=1 -C -PSI(X)+LN(X) for KODE=2 -C KODE - Selection parameter -C KODE=1 returns scaled derivatives of the PSI -C function. -C KODE=2 returns scaled derivatives of the PSI -C function EXCEPT when N=0. In this case, -C ANS(1) = -PSI(X) + LN(X) is returned. -C M - Number of members of the sequence, M.ge.1 -C -C Output ANS is DOUBLE PRECISION -C ANS - A vector of length at least M whose first M -C components contain the sequence of derivatives -C scaled according to KODE. -C NZ - Underflow flag -C NZ.eq.0, A normal return -C NZ.ne.0, Underflow, last NZ components of ANS are -C set to zero, ANS(M-K+1)=0.0, K=1,...,NZ -C IERR - Error flag -C IERR=0, A normal return, computation completed -C IERR=1, Input error, no computation -C IERR=2, Overflow, X too small or N+M-1 too -C large or both -C IERR=3, Error, N too large. Dimensioned -C array TRMR(NMAX) is not large enough for N -C -C The nominal computational accuracy is the maximum of unit -C roundoff (=D1MACH(4)) and 1.0D-18 since critical constants -C are given to only 18 digits. -C -C PSIFN is the single precision version of DPSIFN. -C -C *Long Description: -C -C The basic method of evaluation is the asymptotic expansion -C for large X.ge.XMIN followed by backward recursion on a two -C term recursion relation -C -C W(X+1) + X**(-N-1) = W(X). -C -C This is supplemented by a series -C -C SUM( (X+K)**(-N-1) , K=0,1,2,... ) -C -C which converges rapidly for large N. Both XMIN and the -C number of terms of the series are calculated from the unit -C roundoff of the machine environment. -C -C***REFERENCES Handbook of Mathematical Functions, National Bureau -C of Standards Applied Mathematics Series 55, edited -C by M. Abramowitz and I. A. Stegun, equations 6.3.5, -C 6.3.18, 6.4.6, 6.4.9 and 6.4.10, pp.258-260, 1964. -C D. E. Amos, A portable Fortran subroutine for -C derivatives of the Psi function, Algorithm 610, ACM -C Transactions on Mathematical Software 9, 4 (1983), -C pp. 494-502. -C***ROUTINES CALLED D1MACH, I1MACH -C***REVISION HISTORY (YYMMDD) -C 820601 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890911 Removed unnecessary intrinsics. (WRB) -C 891006 Cosmetic changes to prologue. (WRB) -C 891006 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DPSIFN - INTEGER I, IERR, J, K, KODE, M, MM, MX, N, NMAX, NN, NP, NX, NZ, - * FN - INTEGER I1MACH - DOUBLE PRECISION ANS, ARG, B, DEN, ELIM, EPS, FLN, - * FX, RLN, RXSQ, R1M4, R1M5, S, SLOPE, T, TA, TK, TOL, TOLS, TRM, - * TRMR, TSS, TST, TT, T1, T2, WDTOL, X, XDMLN, XDMY, XINC, XLN, - * XM, XMIN, XQ, YINT - DOUBLE PRECISION D1MACH - DIMENSION B(22), TRM(22), TRMR(100), ANS(*) - SAVE NMAX, B - DATA NMAX /100/ -C----------------------------------------------------------------------- -C BERNOULLI NUMBERS -C----------------------------------------------------------------------- - DATA B(1), B(2), B(3), B(4), B(5), B(6), B(7), B(8), B(9), B(10), - * B(11), B(12), B(13), B(14), B(15), B(16), B(17), B(18), B(19), - * B(20), B(21), B(22) /1.00000000000000000D+00, - * -5.00000000000000000D-01,1.66666666666666667D-01, - * -3.33333333333333333D-02,2.38095238095238095D-02, - * -3.33333333333333333D-02,7.57575757575757576D-02, - * -2.53113553113553114D-01,1.16666666666666667D+00, - * -7.09215686274509804D+00,5.49711779448621554D+01, - * -5.29124242424242424D+02,6.19212318840579710D+03, - * -8.65802531135531136D+04,1.42551716666666667D+06, - * -2.72982310678160920D+07,6.01580873900642368D+08, - * -1.51163157670921569D+10,4.29614643061166667D+11, - * -1.37116552050883328D+13,4.88332318973593167D+14, - * -1.92965793419400681D+16/ -C -C***FIRST EXECUTABLE STATEMENT DPSIFN - IERR = 0 - NZ=0 - IF (X.LE.0.0D0) IERR=1 - IF (N.LT.0) IERR=1 - IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1 - IF (M.LT.1) IERR=1 - IF (IERR.NE.0) RETURN - MM=M - NX = MIN(-I1MACH(15),I1MACH(16)) - R1M5 = D1MACH(5) - R1M4 = D1MACH(4)*0.5D0 - WDTOL = MAX(R1M4,0.5D-18) -C----------------------------------------------------------------------- -C ELIM = APPROXIMATE EXPONENTIAL OVER AND UNDERFLOW LIMIT -C----------------------------------------------------------------------- - ELIM = 2.302D0*(NX*R1M5-3.0D0) - XLN = LOG(X) - 41 CONTINUE - NN = N + MM - 1 - FN = NN - T = (FN+1)*XLN -C----------------------------------------------------------------------- -C OVERFLOW AND UNDERFLOW TEST FOR SMALL AND LARGE X -C----------------------------------------------------------------------- - IF (ABS(T).GT.ELIM) GO TO 290 - IF (X.LT.WDTOL) GO TO 260 -C----------------------------------------------------------------------- -C COMPUTE XMIN AND THE NUMBER OF TERMS OF THE SERIES, FLN+1 -C----------------------------------------------------------------------- - RLN = R1M5*I1MACH(14) - RLN = MIN(RLN,18.06D0) - FLN = MAX(RLN,3.0D0) - 3.0D0 - YINT = 3.50D0 + 0.40D0*FLN - SLOPE = 0.21D0 + FLN*(0.0006038D0*FLN+0.008677D0) - XM = YINT + SLOPE*FN - MX = INT(XM) + 1 - XMIN = MX - IF (N.EQ.0) GO TO 50 - XM = -2.302D0*RLN - MIN(0.0D0,XLN) - ARG = XM/N - ARG = MIN(0.0D0,ARG) - EPS = EXP(ARG) - XM = 1.0D0 - EPS - IF (ABS(ARG).LT.1.0D-3) XM = -ARG - FLN = X*XM/EPS - XM = XMIN - X - IF (XM.GT.7.0D0 .AND. FLN.LT.15.0D0) GO TO 200 - 50 CONTINUE - XDMY = X - XDMLN = XLN - XINC = 0.0D0 - IF (X.GE.XMIN) GO TO 60 - NX = INT(X) - XINC = XMIN - NX - XDMY = X + XINC - XDMLN = LOG(XDMY) - 60 CONTINUE -C----------------------------------------------------------------------- -C GENERATE W(N+MM-1,X) BY THE ASYMPTOTIC EXPANSION -C----------------------------------------------------------------------- - T = FN*XDMLN - T1 = XDMLN + XDMLN - T2 = T + XDMLN - TK = MAX(ABS(T),ABS(T1),ABS(T2)) - IF (TK.GT.ELIM) GO TO 380 - TSS = EXP(-T) - TT = 0.5D0/XDMY - T1 = TT - TST = WDTOL*TT - IF (NN.NE.0) T1 = TT + 1.0D0/FN - RXSQ = 1.0D0/(XDMY*XDMY) - TA = 0.5D0*RXSQ - T = (FN+1)*TA - S = T*B(3) - IF (ABS(S).LT.TST) GO TO 80 - TK = 2.0D0 - DO 70 K=4,22 - T = T*((TK+FN+1)/(TK+1.0D0))*((TK+FN)/(TK+2.0D0))*RXSQ - TRM(K) = T*B(K) - IF (ABS(TRM(K)).LT.TST) GO TO 80 - S = S + TRM(K) - TK = TK + 2.0D0 - 70 CONTINUE - 80 CONTINUE - S = (S+T1)*TSS - IF (XINC.EQ.0.0D0) GO TO 100 -C----------------------------------------------------------------------- -C BACKWARD RECUR FROM XDMY TO X -C----------------------------------------------------------------------- - NX = INT(XINC) - NP = NN + 1 - IF (NX.GT.NMAX) GO TO 390 - IF (NN.EQ.0) GO TO 160 - XM = XINC - 1.0D0 - FX = X + XM -C----------------------------------------------------------------------- -C THIS LOOP SHOULD NOT BE CHANGED. FX IS ACCURATE WHEN X IS SMALL -C----------------------------------------------------------------------- - DO 90 I=1,NX - TRMR(I) = FX**(-NP) - S = S + TRMR(I) - XM = XM - 1.0D0 - FX = X + XM - 90 CONTINUE - 100 CONTINUE - ANS(MM) = S - IF (FN.EQ.0) GO TO 180 -C----------------------------------------------------------------------- -C GENERATE LOWER DERIVATIVES, J.LT.N+MM-1 -C----------------------------------------------------------------------- - IF (MM.EQ.1) RETURN - DO 150 J=2,MM - FN = FN - 1 - TSS = TSS*XDMY - T1 = TT - IF (FN.NE.0) T1 = TT + 1.0D0/FN - T = (FN+1)*TA - S = T*B(3) - IF (ABS(S).LT.TST) GO TO 120 - TK = 4 + FN - DO 110 K=4,22 - TRM(K) = TRM(K)*(FN+1)/TK - IF (ABS(TRM(K)).LT.TST) GO TO 120 - S = S + TRM(K) - TK = TK + 2.0D0 - 110 CONTINUE - 120 CONTINUE - S = (S+T1)*TSS - IF (XINC.EQ.0.0D0) GO TO 140 - IF (FN.EQ.0) GO TO 160 - XM = XINC - 1.0D0 - FX = X + XM - DO 130 I=1,NX - TRMR(I) = TRMR(I)*FX - S = S + TRMR(I) - XM = XM - 1.0D0 - FX = X + XM - 130 CONTINUE - 140 CONTINUE - MX = MM - J + 1 - ANS(MX) = S - IF (FN.EQ.0) GO TO 180 - 150 CONTINUE - RETURN -C----------------------------------------------------------------------- -C RECURSION FOR N = 0 -C----------------------------------------------------------------------- - 160 CONTINUE - DO 170 I=1,NX - S = S + 1.0D0/(X+NX-I) - 170 CONTINUE - 180 CONTINUE - IF (KODE.EQ.2) GO TO 190 - ANS(1) = S - XDMLN - RETURN - 190 CONTINUE - IF (XDMY.EQ.X) RETURN - XQ = XDMY/X - ANS(1) = S - LOG(XQ) - RETURN -C----------------------------------------------------------------------- -C COMPUTE BY SERIES (X+K)**(-(N+1)) , K=0,1,2,... -C----------------------------------------------------------------------- - 200 CONTINUE - NN = INT(FLN) + 1 - NP = N + 1 - T1 = (N+1)*XLN - T = EXP(-T1) - S = T - DEN = X - DO 210 I=1,NN - DEN = DEN + 1.0D0 - TRM(I) = DEN**(-NP) - S = S + TRM(I) - 210 CONTINUE - ANS(1) = S - IF (N.NE.0) GO TO 220 - IF (KODE.EQ.2) ANS(1) = S + XLN - 220 CONTINUE - IF (MM.EQ.1) RETURN -C----------------------------------------------------------------------- -C GENERATE HIGHER DERIVATIVES, J.GT.N -C----------------------------------------------------------------------- - TOL = WDTOL/5.0D0 - DO 250 J=2,MM - T = T/X - S = T - TOLS = T*TOL - DEN = X - DO 230 I=1,NN - DEN = DEN + 1.0D0 - TRM(I) = TRM(I)/DEN - S = S + TRM(I) - IF (TRM(I).LT.TOLS) GO TO 240 - 230 CONTINUE - 240 CONTINUE - ANS(J) = S - 250 CONTINUE - RETURN -C----------------------------------------------------------------------- -C SMALL X.LT.UNIT ROUND OFF -C----------------------------------------------------------------------- - 260 CONTINUE - ANS(1) = X**(-N-1) - IF (MM.EQ.1) GO TO 280 - K = 1 - DO 270 I=2,MM - ANS(K+1) = ANS(K)/X - K = K + 1 - 270 CONTINUE - 280 CONTINUE - IF (N.NE.0) RETURN - IF (KODE.EQ.2) ANS(1) = ANS(1) + XLN - RETURN - 290 CONTINUE - IF (T.GT.0.0D0) GO TO 380 - NZ=0 - IERR=2 - RETURN - 380 CONTINUE - NZ=NZ+1 - ANS(MM)=0.0D0 - MM=MM-1 - IF (MM.EQ.0) RETURN - GO TO 41 - 390 CONTINUE - NZ=0 - IERR=3 - RETURN - END
--- a/liboctave/cruft/slatec-fn/erf.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,73 +0,0 @@ -*DECK ERF - FUNCTION ERF (X) -C***BEGIN PROLOGUE ERF -C***PURPOSE Compute the error function. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C8A, L5A1E -C***TYPE SINGLE PRECISION (ERF-S, DERF-D) -C***KEYWORDS ERF, ERROR FUNCTION, FNLIB, SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C ERF(X) calculates the single precision error function for -C single precision argument X. -C -C Series for ERF on the interval 0. to 1.00000D+00 -C with weighted error 7.10E-18 -C log weighted error 17.15 -C significant figures required 16.31 -C decimal places required 17.71 -C -C***REFERENCES (NONE) -C***ROUTINES CALLED CSEVL, ERFC, INITS, R1MACH -C***REVISION HISTORY (YYMMDD) -C 770401 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890531 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900727 Added EXTERNAL statement. (WRB) -C 920618 Removed space from variable name. (RWC, WRB) -C***END PROLOGUE ERF - DIMENSION ERFCS(13) - LOGICAL FIRST - EXTERNAL ERFC - SAVE ERFCS, SQRTPI, NTERF, XBIG, SQEPS, FIRST - DATA ERFCS( 1) / -.0490461212 34691808E0 / - DATA ERFCS( 2) / -.1422612051 0371364E0 / - DATA ERFCS( 3) / .0100355821 87599796E0 / - DATA ERFCS( 4) / -.0005768764 69976748E0 / - DATA ERFCS( 5) / .0000274199 31252196E0 / - DATA ERFCS( 6) / -.0000011043 17550734E0 / - DATA ERFCS( 7) / .0000000384 88755420E0 / - DATA ERFCS( 8) / -.0000000011 80858253E0 / - DATA ERFCS( 9) / .0000000000 32334215E0 / - DATA ERFCS(10) / -.0000000000 00799101E0 / - DATA ERFCS(11) / .0000000000 00017990E0 / - DATA ERFCS(12) / -.0000000000 00000371E0 / - DATA ERFCS(13) / .0000000000 00000007E0 / - DATA SQRTPI /1.772453850 9055160E0/ - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT ERF - IF (FIRST) THEN - NTERF = INITS (ERFCS, 13, 0.1*R1MACH(3)) - XBIG = SQRT(-LOG(SQRTPI*R1MACH(3))) - SQEPS = SQRT(2.0*R1MACH(3)) - ENDIF - FIRST = .FALSE. -C - Y = ABS(X) - IF (Y.GT.1.) GO TO 20 -C -C ERF(X) = 1. - ERFC(X) FOR -1. .LE. X .LE. 1. -C - IF (Y.LE.SQEPS) ERF = 2.0*X/SQRTPI - IF (Y.GT.SQEPS) ERF = X*(1.0 + CSEVL(2.*X**2-1., ERFCS, NTERF)) - RETURN -C -C ERF(X) = 1. - ERFC(X) FOR ABS(X) .GT. 1. -C - 20 IF (Y.LE.XBIG) ERF = SIGN (1.0-ERFC(Y), X) - IF (Y.GT.XBIG) ERF = SIGN (1.0, X) -C - RETURN - END
--- a/liboctave/cruft/slatec-fn/erfc.in.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,160 +0,0 @@ -*DECK ERFC - FUNCTION ERFC (X) -C***BEGIN PROLOGUE ERFC -C***PURPOSE Compute the complementary error function. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C8A, L5A1E -C***TYPE SINGLE PRECISION (ERFC-S, DERFC-D) -C***KEYWORDS COMPLEMENTARY ERROR FUNCTION, ERFC, FNLIB, -C SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C ERFC(X) calculates the single precision complementary error -C function for single precision argument X. -C -C Series for ERF on the interval 0. to 1.00000D+00 -C with weighted error 7.10E-18 -C log weighted error 17.15 -C significant figures required 16.31 -C decimal places required 17.71 -C -C Series for ERFC on the interval 0. to 2.50000D-01 -C with weighted error 4.81E-17 -C log weighted error 16.32 -C approx significant figures required 15.0 -C -C -C Series for ERC2 on the interval 2.50000D-01 to 1.00000D+00 -C with weighted error 5.22E-17 -C log weighted error 16.28 -C approx significant figures required 15.0 -C decimal places required 16.96 -C -C***REFERENCES (NONE) -C***ROUTINES CALLED CSEVL, INITS, R1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770701 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890531 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 920618 Removed space from variable names. (RWC, WRB) -C***END PROLOGUE ERFC - DIMENSION ERFCS(13), ERFCCS(24), ERC2CS(23) - LOGICAL FIRST - SAVE ERFCS, ERC2CS, ERFCCS, SQRTPI, NTERF, NTERFC, - 1 NTERC2, XSML, XMAX, SQEPS, FIRST - DATA ERFCS( 1) / -.0490461212 34691808E0 / - DATA ERFCS( 2) / -.1422612051 0371364E0 / - DATA ERFCS( 3) / .0100355821 87599796E0 / - DATA ERFCS( 4) / -.0005768764 69976748E0 / - DATA ERFCS( 5) / .0000274199 31252196E0 / - DATA ERFCS( 6) / -.0000011043 17550734E0 / - DATA ERFCS( 7) / .0000000384 88755420E0 / - DATA ERFCS( 8) / -.0000000011 80858253E0 / - DATA ERFCS( 9) / .0000000000 32334215E0 / - DATA ERFCS(10) / -.0000000000 00799101E0 / - DATA ERFCS(11) / .0000000000 00017990E0 / - DATA ERFCS(12) / -.0000000000 00000371E0 / - DATA ERFCS(13) / .0000000000 00000007E0 / - DATA ERC2CS( 1) / -.0696013466 02309501E0 / - DATA ERC2CS( 2) / -.0411013393 62620893E0 / - DATA ERC2CS( 3) / .0039144958 66689626E0 / - DATA ERC2CS( 4) / -.0004906395 65054897E0 / - DATA ERC2CS( 5) / .0000715747 90013770E0 / - DATA ERC2CS( 6) / -.0000115307 16341312E0 / - DATA ERC2CS( 7) / .0000019946 70590201E0 / - DATA ERC2CS( 8) / -.0000003642 66647159E0 / - DATA ERC2CS( 9) / .0000000694 43726100E0 / - DATA ERC2CS(10) / -.0000000137 12209021E0 / - DATA ERC2CS(11) / .0000000027 88389661E0 / - DATA ERC2CS(12) / -.0000000005 81416472E0 / - DATA ERC2CS(13) / .0000000001 23892049E0 / - DATA ERC2CS(14) / -.0000000000 26906391E0 / - DATA ERC2CS(15) / .0000000000 05942614E0 / - DATA ERC2CS(16) / -.0000000000 01332386E0 / - DATA ERC2CS(17) / .0000000000 00302804E0 / - DATA ERC2CS(18) / -.0000000000 00069666E0 / - DATA ERC2CS(19) / .0000000000 00016208E0 / - DATA ERC2CS(20) / -.0000000000 00003809E0 / - DATA ERC2CS(21) / .0000000000 00000904E0 / - DATA ERC2CS(22) / -.0000000000 00000216E0 / - DATA ERC2CS(23) / .0000000000 00000052E0 / - DATA ERFCCS( 1) / 0.0715179310 202925E0 / - DATA ERFCCS( 2) / -.0265324343 37606719E0 / - DATA ERFCCS( 3) / .0017111539 77920853E0 / - DATA ERFCCS( 4) / -.0001637516 63458512E0 / - DATA ERFCCS( 5) / .0000198712 93500549E0 / - DATA ERFCCS( 6) / -.0000028437 12412769E0 / - DATA ERFCCS( 7) / .0000004606 16130901E0 / - DATA ERFCCS( 8) / -.0000000822 77530261E0 / - DATA ERFCCS( 9) / .0000000159 21418724E0 / - DATA ERFCCS(10) / -.0000000032 95071356E0 / - DATA ERFCCS(11) / .0000000007 22343973E0 / - DATA ERFCCS(12) / -.0000000001 66485584E0 / - DATA ERFCCS(13) / .0000000000 40103931E0 / - DATA ERFCCS(14) / -.0000000000 10048164E0 / - DATA ERFCCS(15) / .0000000000 02608272E0 / - DATA ERFCCS(16) / -.0000000000 00699105E0 / - DATA ERFCCS(17) / .0000000000 00192946E0 / - DATA ERFCCS(18) / -.0000000000 00054704E0 / - DATA ERFCCS(19) / .0000000000 00015901E0 / - DATA ERFCCS(20) / -.0000000000 00004729E0 / - DATA ERFCCS(21) / .0000000000 00001432E0 / - DATA ERFCCS(22) / -.0000000000 00000439E0 / - DATA ERFCCS(23) / .0000000000 00000138E0 / - DATA ERFCCS(24) / -.0000000000 00000048E0 / - DATA SQRTPI /1.772453850 9055160E0/ - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT ERFC - IF (FIRST) THEN - ETA = 0.1*R1MACH(3) - NTERF = INITS (ERFCS, 13, ETA) - NTERFC = INITS (ERFCCS, 24, ETA) - NTERC2 = INITS (ERC2CS, 23, ETA) -C - XSML = -SQRT (-LOG(SQRTPI*R1MACH(3))) - TXMAX = SQRT (-LOG(SQRTPI*R1MACH(1))) - XMAX = TXMAX - 0.5*LOG(TXMAX)/TXMAX - 0.01 - SQEPS = SQRT (2.0*R1MACH(3)) - ENDIF - FIRST = .FALSE. -C - IF (ISNAN(X)) THEN - ERFC = X - RETURN - ENDIF -C - IF (X.GT.XSML) GO TO 20 -C -C ERFC(X) = 1.0 - ERF(X) FOR X .LT. XSML -C - ERFC = 2. - RETURN -C - 20 IF (X.GT.XMAX) GO TO 40 - Y = ABS(X) - IF (Y.GT.1.0) GO TO 30 -C -C ERFC(X) = 1.0 - ERF(X) FOR -1. .LE. X .LE. 1. -C - IF (Y.LT.SQEPS) ERFC = 1.0 - 2.0*X/SQRTPI - IF (Y.GE.SQEPS) ERFC = 1.0 - - 1 X*(1.0 + CSEVL (2.*X*X-1., ERFCS, NTERF) ) - RETURN -C -C ERFC(X) = 1.0 - ERF(X) FOR 1. .LT. ABS(X) .LE. XMAX -C - 30 Y = Y*Y - IF (Y.LE.4.) ERFC = EXP(-Y)/ABS(X) * (0.5 + CSEVL ((8./Y-5.)/3., - 1 ERC2CS, NTERC2) ) - IF (Y.GT.4.) ERFC = EXP(-Y)/ABS(X) * (0.5 + CSEVL (8./Y-1., - 1 ERFCCS, NTERFC) ) - IF (X.LT.0.) ERFC = 2.0 - ERFC - RETURN -C - 40 ERFC = 0. - RETURN -C - END
--- a/liboctave/cruft/slatec-fn/gami.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,45 +0,0 @@ -*DECK GAMI - FUNCTION GAMI (A, X) -C***BEGIN PROLOGUE GAMI -C***PURPOSE Evaluate the incomplete Gamma function. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C7E -C***TYPE SINGLE PRECISION (GAMI-S, DGAMI-D) -C***KEYWORDS FNLIB, INCOMPLETE GAMMA FUNCTION, SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C Evaluate the incomplete gamma function defined by -C -C GAMI = integral from T = 0 to X of EXP(-T) * T**(A-1.0) . -C -C GAMI is evaluated for positive values of A and non-negative values -C of X. A slight deterioration of 2 or 3 digits accuracy will occur -C when GAMI is very large or very small, because logarithmic variables -C are used. GAMI, A, and X are single precision. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED ALNGAM, GAMIT, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770701 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890531 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C***END PROLOGUE GAMI -C***FIRST EXECUTABLE STATEMENT GAMI - IF (A .LE. 0.0) CALL XERMSG ('SLATEC', 'GAMI', - + 'A MUST BE GT ZERO', 1, 2) - IF (X .LT. 0.0) CALL XERMSG ('SLATEC', 'GAMI', - + 'X MUST BE GE ZERO', 2, 2) -C - GAMI = 0.0 - IF (X.EQ.0.0) RETURN -C -C THE ONLY ERROR POSSIBLE IN THE EXPRESSION BELOW IS A FATAL OVERFLOW. - FACTOR = EXP (ALNGAM(A) + A*LOG(X) ) -C - GAMI = FACTOR * GAMIT(A, X) -C - RETURN - END
--- a/liboctave/cruft/slatec-fn/gamit.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,112 +0,0 @@ -*DECK GAMIT - REAL FUNCTION GAMIT (A, X) -C***BEGIN PROLOGUE GAMIT -C***PURPOSE Calculate Tricomi's form of the incomplete Gamma function. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C7E -C***TYPE SINGLE PRECISION (GAMIT-S, DGAMIT-D) -C***KEYWORDS COMPLEMENTARY INCOMPLETE GAMMA FUNCTION, FNLIB, -C SPECIAL FUNCTIONS, TRICOMI -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C Evaluate Tricomi's incomplete gamma function defined by -C -C GAMIT = X**(-A)/GAMMA(A) * integral from 0 to X of EXP(-T) * -C T**(A-1.) -C -C for A .GT. 0.0 and by analytic continuation for A .LE. 0.0. -C GAMMA(X) is the complete gamma function of X. -C -C GAMIT is evaluated for arbitrary real values of A and for non- -C negative values of X (even though GAMIT is defined for X .LT. -C 0.0), except that for X = 0 and A .LE. 0.0, GAMIT is infinite, -C which is a fatal error. -C -C The function and both arguments are REAL. -C -C A slight deterioration of 2 or 3 digits accuracy will occur when -C GAMIT is very large or very small in absolute value, because log- -C arithmic variables are used. Also, if the parameter A is very -C close to a negative integer (but not a negative integer), there is -C a loss of accuracy, which is reported if the result is less than -C half machine precision. -C -C***REFERENCES W. Gautschi, A computational procedure for incomplete -C gamma functions, ACM Transactions on Mathematical -C Software 5, 4 (December 1979), pp. 466-481. -C W. Gautschi, Incomplete gamma functions, Algorithm 542, -C ACM Transactions on Mathematical Software 5, 4 -C (December 1979), pp. 482-489. -C***ROUTINES CALLED ALGAMS, ALNGAM, GAMR, R1MACH, R9GMIT, R9LGIC, -C R9LGIT, XERCLR, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770701 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890531 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 920528 DESCRIPTION and REFERENCES sections revised. (WRB) -C***END PROLOGUE GAMIT - LOGICAL FIRST - SAVE ALNEPS, SQEPS, BOT, FIRST - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT GAMIT - IF (FIRST) THEN - ALNEPS = -LOG(R1MACH(3)) - SQEPS = SQRT(R1MACH(4)) - BOT = LOG(R1MACH(1)) - ENDIF - FIRST = .FALSE. -C - IF (X .LT. 0.0) CALL XERMSG ('SLATEC', 'GAMIT', 'X IS NEGATIVE', - + 2, 2) -C - IF (X.NE.0.0) ALX = LOG(X) - SGA = 1.0 - IF (A.NE.0.0) SGA = SIGN (1.0, A) - AINTA = AINT (A+0.5*SGA) - AEPS = A - AINTA -C - IF (X.GT.0.0) GO TO 20 - GAMIT = 0.0 - IF (AINTA.GT.0.0 .OR. AEPS.NE.0.0) GAMIT = GAMR(A+1.0) - RETURN -C - 20 IF (X.GT.1.0) GO TO 40 - IF (A.GE.(-0.5) .OR. AEPS.NE.0.0) CALL ALGAMS (A+1.0, ALGAP1, - 1 SGNGAM) - GAMIT = R9GMIT (A, X, ALGAP1, SGNGAM, ALX) - RETURN -C - 40 IF (A.LT.X) GO TO 50 - T = R9LGIT (A, X, ALNGAM(A+1.0)) - IF (T.LT.BOT) CALL XERCLR - GAMIT = EXP(T) - RETURN -C - 50 ALNG = R9LGIC (A, X, ALX) -C -C EVALUATE GAMIT IN TERMS OF LOG(GAMIC(A,X)) -C - H = 1.0 - IF (AEPS.EQ.0.0 .AND. AINTA.LE.0.0) GO TO 60 - CALL ALGAMS (A+1.0, ALGAP1, SGNGAM) - T = LOG(ABS(A)) + ALNG - ALGAP1 - IF (T.GT.ALNEPS) GO TO 70 - IF (T.GT.(-ALNEPS)) H = 1.0 - SGA*SGNGAM*EXP(T) - IF (ABS(H).GT.SQEPS) GO TO 60 - CALL XERCLR - CALL XERMSG ('SLATEC', 'GAMIT', 'RESULT LT HALF PRECISION', 1, 1) -C - 60 T = -A*ALX + LOG(ABS(H)) - IF (T.LT.BOT) CALL XERCLR - GAMIT = SIGN (EXP(T), H) - RETURN -C - 70 T = T - A*ALX - IF (T.LT.BOT) CALL XERCLR - GAMIT = -SGA*SGNGAM*EXP(T) - RETURN -C - END
--- a/liboctave/cruft/slatec-fn/gamlim.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,61 +0,0 @@ -*DECK GAMLIM - SUBROUTINE GAMLIM (XMIN, XMAX) -C***BEGIN PROLOGUE GAMLIM -C***PURPOSE Compute the minimum and maximum bounds for the argument in -C the Gamma function. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C7A, R2 -C***TYPE SINGLE PRECISION (GAMLIM-S, DGAMLM-D) -C***KEYWORDS COMPLETE GAMMA FUNCTION, FNLIB, LIMITS, SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C Calculate the minimum and maximum legal bounds for X in GAMMA(X). -C XMIN and XMAX are not the only bounds, but they are the only non- -C trivial ones to calculate. -C -C Output Arguments -- -C XMIN minimum legal value of X in GAMMA(X). Any smaller value of -C X might result in underflow. -C XMAX maximum legal value of X in GAMMA(X). Any larger value will -C cause overflow. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED R1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770401 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890531 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C***END PROLOGUE GAMLIM -C***FIRST EXECUTABLE STATEMENT GAMLIM - ALNSML = LOG(R1MACH(1)) - XMIN = -ALNSML - DO 10 I=1,10 - XOLD = XMIN - XLN = LOG(XMIN) - XMIN = XMIN - XMIN*((XMIN+0.5)*XLN - XMIN - 0.2258 + ALNSML) - 1 / (XMIN*XLN + 0.5) - IF (ABS(XMIN-XOLD).LT.0.005) GO TO 20 - 10 CONTINUE - CALL XERMSG ('SLATEC', 'GAMLIM', 'UNABLE TO FIND XMIN', 1, 2) -C - 20 XMIN = -XMIN + 0.01 -C - ALNBIG = LOG(R1MACH(2)) - XMAX = ALNBIG - DO 30 I=1,10 - XOLD = XMAX - XLN = LOG(XMAX) - XMAX = XMAX - XMAX*((XMAX-0.5)*XLN - XMAX + 0.9189 - ALNBIG) - 1 / (XMAX*XLN - 0.5) - IF (ABS(XMAX-XOLD).LT.0.005) GO TO 40 - 30 CONTINUE - CALL XERMSG ('SLATEC', 'GAMLIM', 'UNABLE TO FIND XMAX', 2, 2) -C - 40 XMAX = XMAX - 0.01 - XMIN = MAX (XMIN, -XMAX+1.) -C - RETURN - END
--- a/liboctave/cruft/slatec-fn/gamma.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,138 +0,0 @@ -*DECK GAMMA - FUNCTION GAMMA (X) -C***BEGIN PROLOGUE GAMMA -C***PURPOSE Compute the complete Gamma function. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C7A -C***TYPE SINGLE PRECISION (GAMMA-S, DGAMMA-D, CGAMMA-C) -C***KEYWORDS COMPLETE GAMMA FUNCTION, FNLIB, SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C GAMMA computes the gamma function at X, where X is not 0, -1, -2, .... -C GAMMA and X are single precision. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED CSEVL, GAMLIM, INITS, R1MACH, R9LGMC, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770601 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890531 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C***END PROLOGUE GAMMA - DIMENSION GCS(23) - LOGICAL FIRST - SAVE GCS, PI, SQ2PIL, NGCS, XMIN, XMAX, DXREL, FIRST - DATA GCS ( 1) / .0085711955 90989331E0/ - DATA GCS ( 2) / .0044153813 24841007E0/ - DATA GCS ( 3) / .0568504368 1599363E0/ - DATA GCS ( 4) /-.0042198353 96418561E0/ - DATA GCS ( 5) / .0013268081 81212460E0/ - DATA GCS ( 6) /-.0001893024 529798880E0/ - DATA GCS ( 7) / .0000360692 532744124E0/ - DATA GCS ( 8) /-.0000060567 619044608E0/ - DATA GCS ( 9) / .0000010558 295463022E0/ - DATA GCS (10) /-.0000001811 967365542E0/ - DATA GCS (11) / .0000000311 772496471E0/ - DATA GCS (12) /-.0000000053 542196390E0/ - DATA GCS (13) / .0000000009 193275519E0/ - DATA GCS (14) /-.0000000001 577941280E0/ - DATA GCS (15) / .0000000000 270798062E0/ - DATA GCS (16) /-.0000000000 046468186E0/ - DATA GCS (17) / .0000000000 007973350E0/ - DATA GCS (18) /-.0000000000 001368078E0/ - DATA GCS (19) / .0000000000 000234731E0/ - DATA GCS (20) /-.0000000000 000040274E0/ - DATA GCS (21) / .0000000000 000006910E0/ - DATA GCS (22) /-.0000000000 000001185E0/ - DATA GCS (23) / .0000000000 000000203E0/ - DATA PI /3.14159 26535 89793 24E0/ -C SQ2PIL IS LOG (SQRT (2.*PI) ) - DATA SQ2PIL /0.91893 85332 04672 74E0/ - DATA FIRST /.TRUE./ -C -C LANL DEPENDENT CODE REMOVED 81.02.04 -C -C***FIRST EXECUTABLE STATEMENT GAMMA - IF (FIRST) THEN -C -C --------------------------------------------------------------------- -C INITIALIZE. FIND LEGAL BOUNDS FOR X, AND DETERMINE THE NUMBER OF -C TERMS IN THE SERIES REQUIRED TO ATTAIN AN ACCURACY TEN TIMES BETTER -C THAN MACHINE PRECISION. -C - NGCS = INITS (GCS, 23, 0.1*R1MACH(3)) -C - CALL GAMLIM (XMIN, XMAX) - DXREL = SQRT (R1MACH(4)) -C -C --------------------------------------------------------------------- -C FINISH INITIALIZATION. START EVALUATING GAMMA(X). -C - ENDIF - FIRST = .FALSE. -C - Y = ABS(X) - IF (Y.GT.10.0) GO TO 50 -C -C COMPUTE GAMMA(X) FOR ABS(X) .LE. 10.0. REDUCE INTERVAL AND -C FIND GAMMA(1+Y) FOR 0. .LE. Y .LT. 1. FIRST OF ALL. -C - N = X - IF (X.LT.0.) N = N - 1 - Y = X - N - N = N - 1 - GAMMA = 0.9375 + CSEVL(2.*Y-1., GCS, NGCS) - IF (N.EQ.0) RETURN -C - IF (N.GT.0) GO TO 30 -C -C COMPUTE GAMMA(X) FOR X .LT. 1. -C - N = -N - IF (X .EQ. 0.) CALL XERMSG ('SLATEC', 'GAMMA', 'X IS 0', 4, 2) - IF (X .LT. 0. .AND. X+N-2 .EQ. 0.) CALL XERMSG ('SLATEC', 'GAMMA' - 1, 'X IS A NEGATIVE INTEGER', 4, 2) - IF (X .LT. (-0.5) .AND. ABS((X-AINT(X-0.5))/X) .LT. DXREL) CALL - 1XERMSG ( 'SLATEC', 'GAMMA', - 2'ANSWER LT HALF PRECISION BECAUSE X TOO NEAR NEGATIVE INTEGER' - 3, 1, 1) -C - DO 20 I=1,N - GAMMA = GAMMA / (X+I-1) - 20 CONTINUE - RETURN -C -C GAMMA(X) FOR X .GE. 2. -C - 30 DO 40 I=1,N - GAMMA = (Y+I)*GAMMA - 40 CONTINUE - RETURN -C -C COMPUTE GAMMA(X) FOR ABS(X) .GT. 10.0. RECALL Y = ABS(X). -C - 50 IF (X .GT. XMAX) CALL XERMSG ('SLATEC', 'GAMMA', - + 'X SO BIG GAMMA OVERFLOWS', 3, 2) -C - GAMMA = 0. - IF (X .LT. XMIN) CALL XERMSG ('SLATEC', 'GAMMA', - + 'X SO SMALL GAMMA UNDERFLOWS', 2, 1) - IF (X.LT.XMIN) RETURN -C - GAMMA = EXP((Y-0.5)*LOG(Y) - Y + SQ2PIL + R9LGMC(Y) ) - IF (X.GT.0.) RETURN -C - IF (ABS((X-AINT(X-0.5))/X) .LT. DXREL) CALL XERMSG ('SLATEC', - + 'GAMMA', - + 'ANSWER LT HALF PRECISION, X TOO NEAR NEGATIVE INTEGER', 1, 1) -C - SINPIY = SIN (PI*Y) - IF (SINPIY .EQ. 0.) CALL XERMSG ('SLATEC', 'GAMMA', - + 'X IS A NEGATIVE INTEGER', 4, 2) -C - GAMMA = -PI / (Y*SINPIY*GAMMA) -C - RETURN - END
--- a/liboctave/cruft/slatec-fn/gamr.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,42 +0,0 @@ -*DECK GAMR - FUNCTION GAMR (X) -C***BEGIN PROLOGUE GAMR -C***PURPOSE Compute the reciprocal of the Gamma function. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C7A -C***TYPE SINGLE PRECISION (GAMR-S, DGAMR-D, CGAMR-C) -C***KEYWORDS FNLIB, RECIPROCAL GAMMA FUNCTION, SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C GAMR is a single precision function that evaluates the reciprocal -C of the gamma function for single precision argument X. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED ALGAMS, GAMMA, XERCLR, XGETF, XSETF -C***REVISION HISTORY (YYMMDD) -C 770701 DATE WRITTEN -C 861211 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900727 Added EXTERNAL statement. (WRB) -C***END PROLOGUE GAMR - EXTERNAL GAMMA -C***FIRST EXECUTABLE STATEMENT GAMR - GAMR = 0.0 - IF (X.LE.0.0 .AND. AINT(X).EQ.X) RETURN -C - CALL XGETF (IROLD) - CALL XSETF (1) - IF (ABS(X).GT.10.0) GO TO 10 - GAMR = 1.0/GAMMA(X) - CALL XERCLR - CALL XSETF (IROLD) - RETURN -C - 10 CALL ALGAMS (X, ALNGX, SGNGX) - CALL XERCLR - CALL XSETF (IROLD) - GAMR = SGNGX * EXP(-ALNGX) - RETURN -C - END
--- a/liboctave/cruft/slatec-fn/initds.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,54 +0,0 @@ -*DECK INITDS - FUNCTION INITDS (OS, NOS, ETA) -C***BEGIN PROLOGUE INITDS -C***PURPOSE Determine the number of terms needed in an orthogonal -C polynomial series so that it meets a specified accuracy. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C3A2 -C***TYPE DOUBLE PRECISION (INITS-S, INITDS-D) -C***KEYWORDS CHEBYSHEV, FNLIB, INITIALIZE, ORTHOGONAL POLYNOMIAL, -C ORTHOGONAL SERIES, SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C Initialize the orthogonal series, represented by the array OS, so -C that INITDS is the number of terms needed to insure the error is no -C larger than ETA. Ordinarily, ETA will be chosen to be one-tenth -C machine precision. -C -C Input Arguments -- -C OS double precision array of NOS coefficients in an orthogonal -C series. -C NOS number of coefficients in OS. -C ETA single precision scalar containing requested accuracy of -C series. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED XERMSG -C***REVISION HISTORY (YYMMDD) -C 770601 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891115 Modified error message. (WRB) -C 891115 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C***END PROLOGUE INITDS - DOUBLE PRECISION OS(*) -C***FIRST EXECUTABLE STATEMENT INITDS - IF (NOS .LT. 1) CALL XERMSG ('SLATEC', 'INITDS', - + 'Number of coefficients is less than 1', 2, 1) -C - ERR = 0. - DO 10 II = 1,NOS - I = NOS + 1 - II - ERR = ERR + ABS(REAL(OS(I))) - IF (ERR.GT.ETA) GO TO 20 - 10 CONTINUE -C - 20 IF (I .EQ. NOS) CALL XERMSG ('SLATEC', 'INITDS', - + 'Chebyshev series too short for specified accuracy', 1, 1) - INITDS = I -C - RETURN - END
--- a/liboctave/cruft/slatec-fn/inits.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,53 +0,0 @@ -*DECK INITS - FUNCTION INITS (OS, NOS, ETA) -C***BEGIN PROLOGUE INITS -C***PURPOSE Determine the number of terms needed in an orthogonal -C polynomial series so that it meets a specified accuracy. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C3A2 -C***TYPE SINGLE PRECISION (INITS-S, INITDS-D) -C***KEYWORDS CHEBYSHEV, FNLIB, INITIALIZE, ORTHOGONAL POLYNOMIAL, -C ORTHOGONAL SERIES, SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C Initialize the orthogonal series, represented by the array OS, so -C that INITS is the number of terms needed to insure the error is no -C larger than ETA. Ordinarily, ETA will be chosen to be one-tenth -C machine precision. -C -C Input Arguments -- -C OS single precision array of NOS coefficients in an orthogonal -C series. -C NOS number of coefficients in OS. -C ETA single precision scalar containing requested accuracy of -C series. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED XERMSG -C***REVISION HISTORY (YYMMDD) -C 770401 DATE WRITTEN -C 890831 Modified array declarations. (WRB) -C 891115 Modified error message. (WRB) -C 891115 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C***END PROLOGUE INITS - REAL OS(*) -C***FIRST EXECUTABLE STATEMENT INITS - IF (NOS .LT. 1) CALL XERMSG ('SLATEC', 'INITS', - + 'Number of coefficients is less than 1', 2, 1) -C - ERR = 0. - DO 10 II = 1,NOS - I = NOS + 1 - II - ERR = ERR + ABS(OS(I)) - IF (ERR.GT.ETA) GO TO 20 - 10 CONTINUE -C - 20 IF (I .EQ. NOS) CALL XERMSG ('SLATEC', 'INITS', - + 'Chebyshev series too short for specified accuracy', 1, 1) - INITS = I -C - RETURN - END
--- a/liboctave/cruft/slatec-fn/module.mk Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,81 +0,0 @@ -CRUFT_SOURCES += \ - liboctave/cruft/slatec-fn/albeta.f \ - liboctave/cruft/slatec-fn/alngam.f \ - liboctave/cruft/slatec-fn/alnrel.f \ - liboctave/cruft/slatec-fn/algams.f \ - liboctave/cruft/slatec-fn/acosh.f \ - liboctave/cruft/slatec-fn/asinh.f \ - liboctave/cruft/slatec-fn/atanh.f \ - liboctave/cruft/slatec-fn/betai.f \ - liboctave/cruft/slatec-fn/csevl.f \ - liboctave/cruft/slatec-fn/d9gmit.f \ - liboctave/cruft/slatec-fn/d9lgic.f \ - liboctave/cruft/slatec-fn/d9lgit.f \ - liboctave/cruft/slatec-fn/d9lgmc.f \ - liboctave/cruft/slatec-fn/dacosh.f \ - liboctave/cruft/slatec-fn/dasinh.f \ - liboctave/cruft/slatec-fn/datanh.f \ - liboctave/cruft/slatec-fn/dbetai.f \ - liboctave/cruft/slatec-fn/dcsevl.f \ - liboctave/cruft/slatec-fn/derf.f \ - liboctave/cruft/slatec-fn/dgami.f \ - liboctave/cruft/slatec-fn/dgamit.f \ - liboctave/cruft/slatec-fn/dgamlm.f \ - liboctave/cruft/slatec-fn/dgamma.f \ - liboctave/cruft/slatec-fn/dgamr.f \ - liboctave/cruft/slatec-fn/dlbeta.f \ - liboctave/cruft/slatec-fn/dlgams.f \ - liboctave/cruft/slatec-fn/dlngam.f \ - liboctave/cruft/slatec-fn/dlnrel.f \ - liboctave/cruft/slatec-fn/dpchim.f \ - liboctave/cruft/slatec-fn/dpchst.f \ - liboctave/cruft/slatec-fn/dpsifn.f \ - liboctave/cruft/slatec-fn/erf.f \ - liboctave/cruft/slatec-fn/gami.f \ - liboctave/cruft/slatec-fn/gamit.f \ - liboctave/cruft/slatec-fn/gamlim.f \ - liboctave/cruft/slatec-fn/gamma.f \ - liboctave/cruft/slatec-fn/gamr.f \ - liboctave/cruft/slatec-fn/initds.f \ - liboctave/cruft/slatec-fn/inits.f \ - liboctave/cruft/slatec-fn/pchim.f \ - liboctave/cruft/slatec-fn/pchst.f \ - liboctave/cruft/slatec-fn/psifn.f \ - liboctave/cruft/slatec-fn/r9lgmc.f \ - liboctave/cruft/slatec-fn/r9lgit.f \ - liboctave/cruft/slatec-fn/r9gmit.f \ - liboctave/cruft/slatec-fn/r9lgic.f \ - liboctave/cruft/slatec-fn/xdacosh.f \ - liboctave/cruft/slatec-fn/xdasinh.f \ - liboctave/cruft/slatec-fn/xdatanh.f \ - liboctave/cruft/slatec-fn/xdbetai.f \ - liboctave/cruft/slatec-fn/xderf.f \ - liboctave/cruft/slatec-fn/xderfc.f \ - liboctave/cruft/slatec-fn/xdgami.f \ - liboctave/cruft/slatec-fn/xdgamit.f \ - liboctave/cruft/slatec-fn/xdgamma.f \ - liboctave/cruft/slatec-fn/xgmainc.f \ - liboctave/cruft/slatec-fn/xacosh.f \ - liboctave/cruft/slatec-fn/xasinh.f \ - liboctave/cruft/slatec-fn/xatanh.f \ - liboctave/cruft/slatec-fn/xerf.f \ - liboctave/cruft/slatec-fn/xerfc.f \ - liboctave/cruft/slatec-fn/xsgmainc.f \ - liboctave/cruft/slatec-fn/xgamma.f \ - liboctave/cruft/slatec-fn/xbetai.f - -nodist_liboctave_cruft_libcruft_la_SOURCES += \ - liboctave/cruft/slatec-fn/derfc.f \ - liboctave/cruft/slatec-fn/erfc.f - -liboctave/cruft/slatec-fn/erfc.f: liboctave/cruft/slatec-fn/erfc.in.f build-aux/subst-f77-isnan-macro.sh | liboctave/cruft/slatec-fn/$(octave_dirstamp) - $(AM_V_GEN)$(call simple-filter-rule,build-aux/subst-f77-isnan-macro.sh) - -liboctave/cruft/slatec-fn/derfc.f: liboctave/cruft/slatec-fn/derfc.in.f build-aux/subst-f77-isnan-macro.sh | liboctave/cruft/slatec-fn/$(octave_dirstamp) - $(AM_V_GEN)$(call simple-filter-rule,build-aux/subst-f77-isnan-macro.sh) - -liboctave_EXTRA_DIST += \ - liboctave/cruft/slatec-fn/derfc.in.f \ - liboctave/cruft/slatec-fn/erfc.in.f - -DIRSTAMP_FILES += liboctave/cruft/slatec-fn/$(octave_dirstamp)
--- a/liboctave/cruft/slatec-fn/pchim.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,280 +0,0 @@ -*DECK PCHIM - SUBROUTINE PCHIM (N, X, F, D, INCFD, IERR) -C***BEGIN PROLOGUE PCHIM -C***PURPOSE Set derivatives needed to determine a monotone piecewise -C cubic Hermite interpolant to given data. Boundary values -C are provided which are compatible with monotonicity. The -C interpolant will have an extremum at each point where mono- -C tonicity switches direction. (See PCHIC if user control is -C desired over boundary or switch conditions.) -C***LIBRARY SLATEC (PCHIP) -C***CATEGORY E1A -C***TYPE SINGLE PRECISION (PCHIM-S, DPCHIM-D) -C***KEYWORDS CUBIC HERMITE INTERPOLATION, MONOTONE INTERPOLATION, -C PCHIP, PIECEWISE CUBIC INTERPOLATION -C***AUTHOR Fritsch, F. N., (LLNL) -C Lawrence Livermore National Laboratory -C P.O. Box 808 (L-316) -C Livermore, CA 94550 -C FTS 532-4275, (510) 422-4275 -C***DESCRIPTION -C -C PCHIM: Piecewise Cubic Hermite Interpolation to -C Monotone data. -C -C Sets derivatives needed to determine a monotone piecewise cubic -C Hermite interpolant to the data given in X and F. -C -C Default boundary conditions are provided which are compatible -C with monotonicity. (See PCHIC if user control of boundary con- -C ditions is desired.) -C -C If the data are only piecewise monotonic, the interpolant will -C have an extremum at each point where monotonicity switches direc- -C tion. (See PCHIC if user control is desired in such cases.) -C -C To facilitate two-dimensional applications, includes an increment -C between successive values of the F- and D-arrays. -C -C The resulting piecewise cubic Hermite function may be evaluated -C by PCHFE or PCHFD. -C -C ---------------------------------------------------------------------- -C -C Calling sequence: -C -C PARAMETER (INCFD = ...) -C INTEGER N, IERR -C REAL X(N), F(INCFD,N), D(INCFD,N) -C -C CALL PCHIM (N, X, F, D, INCFD, IERR) -C -C Parameters: -C -C N -- (input) number of data points. (Error return if N.LT.2 .) -C If N=2, simply does linear interpolation. -C -C X -- (input) real array of independent variable values. The -C elements of X must be strictly increasing: -C X(I-1) .LT. X(I), I = 2(1)N. -C (Error return if not.) -C -C F -- (input) real array of dependent variable values to be inter- -C polated. F(1+(I-1)*INCFD) is value corresponding to X(I). -C PCHIM is designed for monotonic data, but it will work for -C any F-array. It will force extrema at points where mono- -C tonicity switches direction. If some other treatment of -C switch points is desired, PCHIC should be used instead. -C ----- -C D -- (output) real array of derivative values at the data points. -C If the data are monotonic, these values will determine a -C a monotone cubic Hermite function. -C The value corresponding to X(I) is stored in -C D(1+(I-1)*INCFD), I=1(1)N. -C No other entries in D are changed. -C -C INCFD -- (input) increment between successive values in F and D. -C This argument is provided primarily for 2-D applications. -C (Error return if INCFD.LT.1 .) -C -C IERR -- (output) error flag. -C Normal return: -C IERR = 0 (no errors). -C Warning error: -C IERR.GT.0 means that IERR switches in the direction -C of monotonicity were detected. -C "Recoverable" errors: -C IERR = -1 if N.LT.2 . -C IERR = -2 if INCFD.LT.1 . -C IERR = -3 if the X-array is not strictly increasing. -C (The D-array has not been changed in any of these cases.) -C NOTE: The above errors are checked in the order listed, -C and following arguments have **NOT** been validated. -C -C***REFERENCES 1. F. N. Fritsch and J. Butland, A method for construc- -C ting local monotone piecewise cubic interpolants, SIAM -C Journal on Scientific and Statistical Computing 5, 2 -C (June 1984), pp. 300-304. -C 2. F. N. Fritsch and R. E. Carlson, Monotone piecewise -C cubic interpolation, SIAM Journal on Numerical Ana- -C lysis 17, 2 (April 1980), pp. 238-246. -C***ROUTINES CALLED PCHST, XERMSG -C***REVISION HISTORY (YYMMDD) -C 811103 DATE WRITTEN -C 820201 1. Introduced PCHST to reduce possible over/under- -C flow problems. -C 2. Rearranged derivative formula for same reason. -C 820602 1. Modified end conditions to be continuous functions -C of data when monotonicity switches in next interval. -C 2. Modified formulas so end conditions are less prone -C of over/underflow problems. -C 820803 Minor cosmetic changes for release 1. -C 870813 Updated Reference 1. -C 890411 Added SAVE statements (Vers. 3.2). -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890703 Corrected category record. (WRB) -C 890831 Modified array declarations. (WRB) -C 890831 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 920429 Revised format and order of references. (WRB,FNF) -C***END PROLOGUE PCHIM -C Programming notes: -C -C 1. The function PCHST(ARG1,ARG2) is assumed to return zero if -C either argument is zero, +1 if they are of the same sign, and -C -1 if they are of opposite sign. -C 2. To produce a double precision version, simply: -C a. Change PCHIM to DPCHIM wherever it occurs, -C b. Change PCHST to DPCHST wherever it occurs, -C c. Change all references to the Fortran intrinsics to their -C double precision equivalents, -C d. Change the real declarations to double precision, and -C e. Change the constants ZERO and THREE to double precision. -C -C DECLARE ARGUMENTS. -C - INTEGER N, INCFD, IERR - REAL X(*), F(INCFD,*), D(INCFD,*) -C -C DECLARE LOCAL VARIABLES. -C - INTEGER I, NLESS1 - REAL DEL1, DEL2, DMAX, DMIN, DRAT1, DRAT2, DSAVE, - * H1, H2, HSUM, HSUMT3, THREE, W1, W2, ZERO - SAVE ZERO, THREE - REAL PCHST - DATA ZERO /0./, THREE /3./ -C -C VALIDITY-CHECK ARGUMENTS. -C -C***FIRST EXECUTABLE STATEMENT PCHIM - IF ( N.LT.2 ) GO TO 5001 - IF ( INCFD.LT.1 ) GO TO 5002 - DO 1 I = 2, N - IF ( X(I).LE.X(I-1) ) GO TO 5003 - 1 CONTINUE -C -C FUNCTION DEFINITION IS OK, GO ON. -C - IERR = 0 - NLESS1 = N - 1 - H1 = X(2) - X(1) - DEL1 = (F(1,2) - F(1,1))/H1 - DSAVE = DEL1 -C -C SPECIAL CASE N=2 -- USE LINEAR INTERPOLATION. -C - IF (NLESS1 .GT. 1) GO TO 10 - D(1,1) = DEL1 - D(1,N) = DEL1 - GO TO 5000 -C -C NORMAL CASE (N .GE. 3). -C - 10 CONTINUE - H2 = X(3) - X(2) - DEL2 = (F(1,3) - F(1,2))/H2 -C -C SET D(1) VIA NON-CENTERED THREE-POINT FORMULA, ADJUSTED TO BE -C SHAPE-PRESERVING. -C - HSUM = H1 + H2 - W1 = (H1 + HSUM)/HSUM - W2 = -H1/HSUM - D(1,1) = W1*DEL1 + W2*DEL2 - IF ( PCHST(D(1,1),DEL1) .LE. ZERO) THEN - D(1,1) = ZERO - ELSE IF ( PCHST(DEL1,DEL2) .LT. ZERO) THEN -C NEED DO THIS CHECK ONLY IF MONOTONICITY SWITCHES. - DMAX = THREE*DEL1 - IF (ABS(D(1,1)) .GT. ABS(DMAX)) D(1,1) = DMAX - ENDIF -C -C LOOP THROUGH INTERIOR POINTS. -C - DO 50 I = 2, NLESS1 - IF (I .EQ. 2) GO TO 40 -C - H1 = H2 - H2 = X(I+1) - X(I) - HSUM = H1 + H2 - DEL1 = DEL2 - DEL2 = (F(1,I+1) - F(1,I))/H2 - 40 CONTINUE -C -C SET D(I)=0 UNLESS DATA ARE STRICTLY MONOTONIC. -C - D(1,I) = ZERO - IF ( PCHST(DEL1,DEL2) ) 42, 41, 45 -C -C COUNT NUMBER OF CHANGES IN DIRECTION OF MONOTONICITY. -C - 41 CONTINUE - IF (DEL2 .EQ. ZERO) GO TO 50 - IF ( PCHST(DSAVE,DEL2) .LT. ZERO) IERR = IERR + 1 - DSAVE = DEL2 - GO TO 50 -C - 42 CONTINUE - IERR = IERR + 1 - DSAVE = DEL2 - GO TO 50 -C -C USE BRODLIE MODIFICATION OF BUTLAND FORMULA. -C - 45 CONTINUE - HSUMT3 = HSUM+HSUM+HSUM - W1 = (HSUM + H1)/HSUMT3 - W2 = (HSUM + H2)/HSUMT3 - DMAX = MAX( ABS(DEL1), ABS(DEL2) ) - DMIN = MIN( ABS(DEL1), ABS(DEL2) ) - DRAT1 = DEL1/DMAX - DRAT2 = DEL2/DMAX - D(1,I) = DMIN/(W1*DRAT1 + W2*DRAT2) -C - 50 CONTINUE -C -C SET D(N) VIA NON-CENTERED THREE-POINT FORMULA, ADJUSTED TO BE -C SHAPE-PRESERVING. -C - W1 = -H2/HSUM - W2 = (H2 + HSUM)/HSUM - D(1,N) = W1*DEL1 + W2*DEL2 - IF ( PCHST(D(1,N),DEL2) .LE. ZERO) THEN - D(1,N) = ZERO - ELSE IF ( PCHST(DEL1,DEL2) .LT. ZERO) THEN -C NEED DO THIS CHECK ONLY IF MONOTONICITY SWITCHES. - DMAX = THREE*DEL2 - IF (ABS(D(1,N)) .GT. ABS(DMAX)) D(1,N) = DMAX - ENDIF -C -C NORMAL RETURN. -C - 5000 CONTINUE - RETURN -C -C ERROR RETURNS. -C - 5001 CONTINUE -C N.LT.2 RETURN. - IERR = -1 - CALL XERMSG ('SLATEC', 'PCHIM', - + 'NUMBER OF DATA POINTS LESS THAN TWO', IERR, 1) - RETURN -C - 5002 CONTINUE -C INCFD.LT.1 RETURN. - IERR = -2 - CALL XERMSG ('SLATEC', 'PCHIM', 'INCREMENT LESS THAN ONE', IERR, - + 1) - RETURN -C - 5003 CONTINUE -C X-ARRAY NOT STRICTLY INCREASING. - IERR = -3 - CALL XERMSG ('SLATEC', 'PCHIM', 'X-ARRAY NOT STRICTLY INCREASING' - + , IERR, 1) - RETURN -C------------- LAST LINE OF PCHIM FOLLOWS ------------------------------ - END
--- a/liboctave/cruft/slatec-fn/pchst.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,57 +0,0 @@ -*DECK PCHST - REAL FUNCTION PCHST (ARG1, ARG2) -C***BEGIN PROLOGUE PCHST -C***SUBSIDIARY -C***PURPOSE PCHIP Sign-Testing Routine -C***LIBRARY SLATEC (PCHIP) -C***TYPE SINGLE PRECISION (PCHST-S, DPCHST-D) -C***AUTHOR Fritsch, F. N., (LLNL) -C***DESCRIPTION -C -C PCHST: PCHIP Sign-Testing Routine. -C -C Returns: -C -1. if ARG1 and ARG2 are of opposite sign. -C 0. if either argument is zero. -C +1. if ARG1 and ARG2 are of the same sign. -C -C The object is to do this without multiplying ARG1*ARG2, to avoid -C possible over/underflow problems. -C -C Fortran intrinsics used: SIGN. -C -C***SEE ALSO PCHCE, PCHCI, PCHCS, PCHIM -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 811103 DATE WRITTEN -C 820805 Converted to SLATEC library version. -C 870813 Minor cosmetic changes. -C 890411 Added SAVE statements (Vers. 3.2). -C 890411 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 910408 Updated AUTHOR and DATE WRITTEN sections in prologue. (WRB) -C 930503 Improved purpose. (FNF) -C***END PROLOGUE PCHST -C -C**End -C -C DECLARE ARGUMENTS. -C - REAL ARG1, ARG2 -C -C DECLARE LOCAL VARIABLES. -C - REAL ONE, ZERO - SAVE ZERO, ONE - DATA ZERO /0./, ONE /1./ -C -C PERFORM THE TEST. -C -C***FIRST EXECUTABLE STATEMENT PCHST - PCHST = SIGN(ONE,ARG1) * SIGN(ONE,ARG2) - IF ((ARG1.EQ.ZERO) .OR. (ARG2.EQ.ZERO)) PCHST = ZERO -C - RETURN -C------------- LAST LINE OF PCHST FOLLOWS ------------------------------ - END
--- a/liboctave/cruft/slatec-fn/psifn.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,368 +0,0 @@ -*DECK PSIFN - SUBROUTINE PSIFN (X, N, KODE, M, ANS, NZ, IERR) -C***BEGIN PROLOGUE PSIFN -C***PURPOSE Compute derivatives of the Psi function. -C***LIBRARY SLATEC -C***CATEGORY C7C -C***TYPE SINGLE PRECISION (PSIFN-S, DPSIFN-D) -C***KEYWORDS DERIVATIVES OF THE GAMMA FUNCTION, POLYGAMMA FUNCTION, -C PSI FUNCTION -C***AUTHOR Amos, D. E., (SNLA) -C***DESCRIPTION -C -C The following definitions are used in PSIFN: -C -C Definition 1 -C PSI(X) = d/dx (ln(GAMMA(X)), the first derivative of -C the LOG GAMMA function. -C Definition 2 -C K K -C PSI(K,X) = d /dx (PSI(X)), the K-th derivative of PSI(X). -C ___________________________________________________________________ -C PSIFN computes a sequence of SCALED derivatives of -C the PSI function; i.e. for fixed X and M it computes -C the M-member sequence -C -C ((-1)**(K+1)/GAMMA(K+1))*PSI(K,X) -C for K = N,...,N+M-1 -C -C where PSI(K,X) is as defined above. For KODE=1, PSIFN returns -C the scaled derivatives as described. KODE=2 is operative only -C when K=0 and in that case PSIFN returns -PSI(X) + LN(X). That -C is, the logarithmic behavior for large X is removed when KODE=1 -C and K=0. When sums or differences of PSI functions are computed -C the logarithmic terms can be combined analytically and computed -C separately to help retain significant digits. -C -C Note that CALL PSIFN(X,0,1,1,ANS) results in -C ANS = -PSI(X) -C -C Input -C X - Argument, X .gt. 0.0E0 -C N - First member of the sequence, 0 .le. N .le. 100 -C N=0 gives ANS(1) = -PSI(X) for KODE=1 -C -PSI(X)+LN(X) for KODE=2 -C KODE - Selection parameter -C KODE=1 returns scaled derivatives of the PSI -C function. -C KODE=2 returns scaled derivatives of the PSI -C function EXCEPT when N=0. In this case, -C ANS(1) = -PSI(X) + LN(X) is returned. -C M - Number of members of the sequence, M .ge. 1 -C -C Output -C ANS - A vector of length at least M whose first M -C components contain the sequence of derivatives -C scaled according to KODE. -C NZ - Underflow flag -C NZ.eq.0, A normal return -C NZ.ne.0, Underflow, last NZ components of ANS are -C set to zero, ANS(M-K+1)=0.0, K=1,...,NZ -C IERR - Error flag -C IERR=0, A normal return, computation completed -C IERR=1, Input error, no computation -C IERR=2, Overflow, X too small or N+M-1 too -C large or both -C IERR=3, Error, N too large. Dimensioned -C array TRMR(NMAX) is not large enough for N -C -C The nominal computational accuracy is the maximum of unit -C roundoff (=R1MACH(4)) and 1.0E-18 since critical constants -C are given to only 18 digits. -C -C DPSIFN is the Double Precision version of PSIFN. -C -C *Long Description: -C -C The basic method of evaluation is the asymptotic expansion -C for large X.ge.XMIN followed by backward recursion on a two -C term recursion relation -C -C W(X+1) + X**(-N-1) = W(X). -C -C This is supplemented by a series -C -C SUM( (X+K)**(-N-1) , K=0,1,2,... ) -C -C which converges rapidly for large N. Both XMIN and the -C number of terms of the series are calculated from the unit -C roundoff of the machine environment. -C -C***REFERENCES Handbook of Mathematical Functions, National Bureau -C of Standards Applied Mathematics Series 55, edited -C by M. Abramowitz and I. A. Stegun, equations 6.3.5, -C 6.3.18, 6.4.6, 6.4.9 and 6.4.10, pp.258-260, 1964. -C D. E. Amos, A portable Fortran subroutine for -C derivatives of the Psi function, Algorithm 610, ACM -C Transactions on Mathematical Software 9, 4 (1983), -C pp. 494-502. -C***ROUTINES CALLED I1MACH, R1MACH -C***REVISION HISTORY (YYMMDD) -C 820601 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890531 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE PSIFN - INTEGER I, IERR, J, K, KODE, M, MM, MX, N, NMAX, NN, NP, NX, NZ - INTEGER I1MACH - REAL ANS, ARG, B, DEN, ELIM, EPS, FLN, FN, FNP, FNS, FX, RLN, - * RXSQ, R1M4, R1M5, S, SLOPE, T, TA, TK, TOL, TOLS, TRM, TRMR, - * TSS, TST, TT, T1, T2, WDTOL, X, XDMLN, XDMY, XINC, XLN, XM, - * XMIN, XQ, YINT - REAL R1MACH - DIMENSION B(22), TRM(22), TRMR(100), ANS(*) - SAVE NMAX, B - DATA NMAX /100/ -C----------------------------------------------------------------------- -C BERNOULLI NUMBERS -C----------------------------------------------------------------------- - DATA B(1), B(2), B(3), B(4), B(5), B(6), B(7), B(8), B(9), B(10), - * B(11), B(12), B(13), B(14), B(15), B(16), B(17), B(18), B(19), - * B(20), B(21), B(22) /1.00000000000000000E+00, - * -5.00000000000000000E-01,1.66666666666666667E-01, - * -3.33333333333333333E-02,2.38095238095238095E-02, - * -3.33333333333333333E-02,7.57575757575757576E-02, - * -2.53113553113553114E-01,1.16666666666666667E+00, - * -7.09215686274509804E+00,5.49711779448621554E+01, - * -5.29124242424242424E+02,6.19212318840579710E+03, - * -8.65802531135531136E+04,1.42551716666666667E+06, - * -2.72982310678160920E+07,6.01580873900642368E+08, - * -1.51163157670921569E+10,4.29614643061166667E+11, - * -1.37116552050883328E+13,4.88332318973593167E+14, - * -1.92965793419400681E+16/ -C -C***FIRST EXECUTABLE STATEMENT PSIFN - IERR = 0 - NZ=0 - IF (X.LE.0.0E0) IERR=1 - IF (N.LT.0) IERR=1 - IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1 - IF (M.LT.1) IERR=1 - IF (IERR.NE.0) RETURN - MM=M - NX = MIN(-I1MACH(12),I1MACH(13)) - R1M5 = R1MACH(5) - R1M4 = R1MACH(4)*0.5E0 - WDTOL = MAX(R1M4,0.5E-18) -C----------------------------------------------------------------------- -C ELIM = APPROXIMATE EXPONENTIAL OVER AND UNDERFLOW LIMIT -C----------------------------------------------------------------------- - ELIM = 2.302E0*(NX*R1M5-3.0E0) - XLN = LOG(X) - 41 CONTINUE - NN = N + MM - 1 - FN = NN - FNP = FN + 1.0E0 - T = FNP*XLN -C----------------------------------------------------------------------- -C OVERFLOW AND UNDERFLOW TEST FOR SMALL AND LARGE X -C----------------------------------------------------------------------- - IF (ABS(T).GT.ELIM) GO TO 290 - IF (X.LT.WDTOL) GO TO 260 -C----------------------------------------------------------------------- -C COMPUTE XMIN AND THE NUMBER OF TERMS OF THE SERIES, FLN+1 -C----------------------------------------------------------------------- - RLN = R1M5*I1MACH(11) - RLN = MIN(RLN,18.06E0) - FLN = MAX(RLN,3.0E0) - 3.0E0 - YINT = 3.50E0 + 0.40E0*FLN - SLOPE = 0.21E0 + FLN*(0.0006038E0*FLN+0.008677E0) - XM = YINT + SLOPE*FN - MX = INT(XM) + 1 - XMIN = MX - IF (N.EQ.0) GO TO 50 - XM = -2.302E0*RLN - MIN(0.0E0,XLN) - FNS = N - ARG = XM/FNS - ARG = MIN(0.0E0,ARG) - EPS = EXP(ARG) - XM = 1.0E0 - EPS - IF (ABS(ARG).LT.1.0E-3) XM = -ARG - FLN = X*XM/EPS - XM = XMIN - X - IF (XM.GT.7.0E0 .AND. FLN.LT.15.0E0) GO TO 200 - 50 CONTINUE - XDMY = X - XDMLN = XLN - XINC = 0.0E0 - IF (X.GE.XMIN) GO TO 60 - NX = INT(X) - XINC = XMIN - NX - XDMY = X + XINC - XDMLN = LOG(XDMY) - 60 CONTINUE -C----------------------------------------------------------------------- -C GENERATE W(N+MM-1,X) BY THE ASYMPTOTIC EXPANSION -C----------------------------------------------------------------------- - T = FN*XDMLN - T1 = XDMLN + XDMLN - T2 = T + XDMLN - TK = MAX(ABS(T),ABS(T1),ABS(T2)) - IF (TK.GT.ELIM) GO TO 380 - TSS = EXP(-T) - TT = 0.5E0/XDMY - T1 = TT - TST = WDTOL*TT - IF (NN.NE.0) T1 = TT + 1.0E0/FN - RXSQ = 1.0E0/(XDMY*XDMY) - TA = 0.5E0*RXSQ - T = FNP*TA - S = T*B(3) - IF (ABS(S).LT.TST) GO TO 80 - TK = 2.0E0 - DO 70 K=4,22 - T = T*((TK+FN+1.0E0)/(TK+1.0E0))*((TK+FN)/(TK+2.0E0))*RXSQ - TRM(K) = T*B(K) - IF (ABS(TRM(K)).LT.TST) GO TO 80 - S = S + TRM(K) - TK = TK + 2.0E0 - 70 CONTINUE - 80 CONTINUE - S = (S+T1)*TSS - IF (XINC.EQ.0.0E0) GO TO 100 -C----------------------------------------------------------------------- -C BACKWARD RECUR FROM XDMY TO X -C----------------------------------------------------------------------- - NX = INT(XINC) - NP = NN + 1 - IF (NX.GT.NMAX) GO TO 390 - IF (NN.EQ.0) GO TO 160 - XM = XINC - 1.0E0 - FX = X + XM -C----------------------------------------------------------------------- -C THIS LOOP SHOULD NOT BE CHANGED. FX IS ACCURATE WHEN X IS SMALL -C----------------------------------------------------------------------- - DO 90 I=1,NX - TRMR(I) = FX**(-NP) - S = S + TRMR(I) - XM = XM - 1.0E0 - FX = X + XM - 90 CONTINUE - 100 CONTINUE - ANS(MM) = S - IF (FN.EQ.0.0E0) GO TO 180 -C----------------------------------------------------------------------- -C GENERATE LOWER DERIVATIVES, J.LT.N+MM-1 -C----------------------------------------------------------------------- - IF (MM.EQ.1) RETURN - DO 150 J=2,MM - FNP = FN - FN = FN - 1.0E0 - TSS = TSS*XDMY - T1 = TT - IF (FN.NE.0.0E0) T1 = TT + 1.0E0/FN - T = FNP*TA - S = T*B(3) - IF (ABS(S).LT.TST) GO TO 120 - TK = 3.0E0 + FNP - DO 110 K=4,22 - TRM(K) = TRM(K)*FNP/TK - IF (ABS(TRM(K)).LT.TST) GO TO 120 - S = S + TRM(K) - TK = TK + 2.0E0 - 110 CONTINUE - 120 CONTINUE - S = (S+T1)*TSS - IF (XINC.EQ.0.0E0) GO TO 140 - IF (FN.EQ.0.0E0) GO TO 160 - XM = XINC - 1.0E0 - FX = X + XM - DO 130 I=1,NX - TRMR(I) = TRMR(I)*FX - S = S + TRMR(I) - XM = XM - 1.0E0 - FX = X + XM - 130 CONTINUE - 140 CONTINUE - MX = MM - J + 1 - ANS(MX) = S - IF (FN.EQ.0.0E0) GO TO 180 - 150 CONTINUE - RETURN -C----------------------------------------------------------------------- -C RECURSION FOR N = 0 -C----------------------------------------------------------------------- - 160 CONTINUE - DO 170 I=1,NX - S = S + 1.0E0/(X+NX-I) - 170 CONTINUE - 180 CONTINUE - IF (KODE.EQ.2) GO TO 190 - ANS(1) = S - XDMLN - RETURN - 190 CONTINUE - IF (XDMY.EQ.X) RETURN - XQ = XDMY/X - ANS(1) = S - LOG(XQ) - RETURN -C----------------------------------------------------------------------- -C COMPUTE BY SERIES (X+K)**(-(N+1)) , K=0,1,2,... -C----------------------------------------------------------------------- - 200 CONTINUE - NN = INT(FLN) + 1 - NP = N + 1 - T1 = (FNS+1.0E0)*XLN - T = EXP(-T1) - S = T - DEN = X - DO 210 I=1,NN - DEN = DEN + 1.0E0 - TRM(I) = DEN**(-NP) - S = S + TRM(I) - 210 CONTINUE - ANS(1) = S - IF (N.NE.0) GO TO 220 - IF (KODE.EQ.2) ANS(1) = S + XLN - 220 CONTINUE - IF (MM.EQ.1) RETURN -C----------------------------------------------------------------------- -C GENERATE HIGHER DERIVATIVES, J.GT.N -C----------------------------------------------------------------------- - TOL = WDTOL/5.0E0 - DO 250 J=2,MM - T = T/X - S = T - TOLS = T*TOL - DEN = X - DO 230 I=1,NN - DEN = DEN + 1.0E0 - TRM(I) = TRM(I)/DEN - S = S + TRM(I) - IF (TRM(I).LT.TOLS) GO TO 240 - 230 CONTINUE - 240 CONTINUE - ANS(J) = S - 250 CONTINUE - RETURN -C----------------------------------------------------------------------- -C SMALL X.LT.UNIT ROUND OFF -C----------------------------------------------------------------------- - 260 CONTINUE - ANS(1) = X**(-N-1) - IF (MM.EQ.1) GO TO 280 - K = 1 - DO 270 I=2,MM - ANS(K+1) = ANS(K)/X - K = K + 1 - 270 CONTINUE - 280 CONTINUE - IF (N.NE.0) RETURN - IF (KODE.EQ.2) ANS(1) = ANS(1) + XLN - RETURN - 290 CONTINUE - IF (T.GT.0.0E0) GO TO 380 - NZ=0 - IERR=2 - RETURN - 380 CONTINUE - NZ=NZ+1 - ANS(MM)=0.0E0 - MM=MM-1 - IF(MM.EQ.0) RETURN - GO TO 41 - 390 CONTINUE - IERR=3 - NZ=0 - RETURN - END
--- a/liboctave/cruft/slatec-fn/r9gmit.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,84 +0,0 @@ -*DECK R9GMIT - FUNCTION R9GMIT (A, X, ALGAP1, SGNGAM, ALX) -C***BEGIN PROLOGUE R9GMIT -C***SUBSIDIARY -C***PURPOSE Compute Tricomi's incomplete Gamma function for small -C arguments. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C7E -C***TYPE SINGLE PRECISION (R9GMIT-S, D9GMIT-D) -C***KEYWORDS COMPLEMENTARY INCOMPLETE GAMMA FUNCTION, FNLIB, SMALL X, -C SPECIAL FUNCTIONS, TRICOMI -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C Compute Tricomi's incomplete gamma function for small X. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED ALNGAM, R1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770701 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890531 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900720 Routine changed from user-callable to subsidiary. (WRB) -C***END PROLOGUE R9GMIT - SAVE EPS, BOT - DATA EPS, BOT / 2*0.0 / -C***FIRST EXECUTABLE STATEMENT R9GMIT - IF (EPS.EQ.0.0) EPS = 0.5*R1MACH(3) - IF (BOT.EQ.0.0) BOT = LOG(R1MACH(1)) -C - IF (X .LE. 0.0) CALL XERMSG ('SLATEC', 'R9GMIT', - + 'X SHOULD BE GT 0', 1, 2) -C - MA = A + 0.5 - IF (A.LT.0.0) MA = A - 0.5 - AEPS = A - MA -C - AE = A - IF (A.LT.(-0.5)) AE = AEPS -C - T = 1.0 - TE = AE - S = T - DO 20 K=1,200 - FK = K - TE = -X*TE/FK - T = TE/(AE+FK) - S = S + T - IF (ABS(T).LT.EPS*ABS(S)) GO TO 30 - 20 CONTINUE - CALL XERMSG ('SLATEC', 'R9GMIT', - + 'NO CONVERGENCE IN 200 TERMS OF TAYLOR-S SERIES', 2, 2) -C - 30 IF (A.GE.(-0.5)) ALGS = -ALGAP1 + LOG(S) - IF (A.GE.(-0.5)) GO TO 60 -C - ALGS = -ALNGAM(1.0+AEPS) + LOG(S) - S = 1.0 - M = -MA - 1 - IF (M.EQ.0) GO TO 50 - T = 1.0 - DO 40 K=1,M - T = X*T/(AEPS-M-1+K) - S = S + T - IF (ABS(T).LT.EPS*ABS(S)) GO TO 50 - 40 CONTINUE -C - 50 R9GMIT = 0.0 - ALGS = -MA*LOG(X) + ALGS - IF (S.EQ.0.0 .OR. AEPS.EQ.0.0) GO TO 60 -C - SGNG2 = SGNGAM*SIGN(1.0,S) - ALG2 = -X - ALGAP1 + LOG(ABS(S)) -C - IF (ALG2.GT.BOT) R9GMIT = SGNG2*EXP(ALG2) - IF (ALGS.GT.BOT) R9GMIT = R9GMIT + EXP(ALGS) - RETURN -C - 60 R9GMIT = EXP(ALGS) - RETURN -C - END
--- a/liboctave/cruft/slatec-fn/r9lgic.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,53 +0,0 @@ -*DECK R9LGIC - FUNCTION R9LGIC (A, X, ALX) -C***BEGIN PROLOGUE R9LGIC -C***SUBSIDIARY -C***PURPOSE Compute the log complementary incomplete Gamma function -C for large X and for A .LE. X. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C7E -C***TYPE SINGLE PRECISION (R9LGIC-S, D9LGIC-D) -C***KEYWORDS COMPLEMENTARY INCOMPLETE GAMMA FUNCTION, FNLIB, LARGE X, -C LOGARITHM, SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C Compute the log complementary incomplete gamma function for large X -C and for A .LE. X. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED R1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770701 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890531 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900720 Routine changed from user-callable to subsidiary. (WRB) -C***END PROLOGUE R9LGIC - SAVE EPS - DATA EPS / 0.0 / -C***FIRST EXECUTABLE STATEMENT R9LGIC - IF (EPS.EQ.0.0) EPS = 0.5*R1MACH(3) -C - XPA = X + 1.0 - A - XMA = X - 1.0 - A -C - R = 0.0 - P = 1.0 - S = P - DO 10 K=1,200 - FK = K - T = FK*(A-FK)*(1.0+R) - R = -T/((XMA+2.0*FK)*(XPA+2.0*FK)+T) - P = R*P - S = S + P - IF (ABS(P).LT.EPS*S) GO TO 20 - 10 CONTINUE - CALL XERMSG ('SLATEC', 'R9LGIC', - + 'NO CONVERGENCE IN 200 TERMS OF CONTINUED FRACTION', 1, 2) -C - 20 R9LGIC = A*ALX - X + LOG(S/XPA) -C - RETURN - END
--- a/liboctave/cruft/slatec-fn/r9lgit.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,61 +0,0 @@ -*DECK R9LGIT - FUNCTION R9LGIT (A, X, ALGAP1) -C***BEGIN PROLOGUE R9LGIT -C***SUBSIDIARY -C***PURPOSE Compute the logarithm of Tricomi's incomplete Gamma -C function with Perron's continued fraction for large X and -C A .GE. X. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C7E -C***TYPE SINGLE PRECISION (R9LGIT-S, D9LGIT-D) -C***KEYWORDS FNLIB, INCOMPLETE GAMMA FUNCTION, LOGARITHM, -C PERRON'S CONTINUED FRACTION, SPECIAL FUNCTIONS, TRICOMI -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C Compute the log of Tricomi's incomplete gamma function with Perron's -C continued fraction for large X and for A .GE. X. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED R1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770701 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890531 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900720 Routine changed from user-callable to subsidiary. (WRB) -C***END PROLOGUE R9LGIT - SAVE EPS, SQEPS - DATA EPS, SQEPS / 2*0.0 / -C***FIRST EXECUTABLE STATEMENT R9LGIT - IF (EPS.EQ.0.0) EPS = 0.5*R1MACH(3) - IF (SQEPS.EQ.0.0) SQEPS = SQRT(R1MACH(4)) -C - IF (X .LE. 0.0 .OR. A .LT. X) CALL XERMSG ('SLATEC', 'R9LGIT', - + 'X SHOULD BE GT 0.0 AND LE A', 2, 2) -C - AX = A + X - A1X = AX + 1.0 - R = 0.0 - P = 1.0 - S = P - DO 20 K=1,200 - FK = K - T = (A+FK)*X*(1.0+R) - R = T/((AX+FK)*(A1X+FK)-T) - P = R*P - S = S + P - IF (ABS(P).LT.EPS*S) GO TO 30 - 20 CONTINUE - CALL XERMSG ('SLATEC', 'R9LGIT', - + 'NO CONVERGENCE IN 200 TERMS OF CONTINUED FRACTION', 3, 2) -C - 30 HSTAR = 1.0 - X*S/A1X - IF (HSTAR .LT. SQEPS) CALL XERMSG ('SLATEC', 'R9LGIT', - + 'RESULT LESS THAN HALF PRECISION', 1, 1) -C - R9LGIT = -X - ALGAP1 - LOG(HSTAR) -C - RETURN - END
--- a/liboctave/cruft/slatec-fn/r9lgmc.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,66 +0,0 @@ -*DECK R9LGMC - FUNCTION R9LGMC (X) -C***BEGIN PROLOGUE R9LGMC -C***SUBSIDIARY -C***PURPOSE Compute the log Gamma correction factor so that -C LOG(GAMMA(X)) = LOG(SQRT(2*PI)) + (X-.5)*LOG(X) - X -C + R9LGMC(X). -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C7E -C***TYPE SINGLE PRECISION (R9LGMC-S, D9LGMC-D, C9LGMC-C) -C***KEYWORDS COMPLETE GAMMA FUNCTION, CORRECTION TERM, FNLIB, -C LOG GAMMA, LOGARITHM, SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C Compute the log gamma correction factor for X .GE. 10.0 so that -C LOG (GAMMA(X)) = LOG(SQRT(2*PI)) + (X-.5)*LOG(X) - X + R9LGMC(X) -C -C Series for ALGM on the interval 0. to 1.00000D-02 -C with weighted error 3.40E-16 -C log weighted error 15.47 -C significant figures required 14.39 -C decimal places required 15.86 -C -C***REFERENCES (NONE) -C***ROUTINES CALLED CSEVL, INITS, R1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770801 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890531 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900720 Routine changed from user-callable to subsidiary. (WRB) -C***END PROLOGUE R9LGMC - DIMENSION ALGMCS(6) - LOGICAL FIRST - SAVE ALGMCS, NALGM, XBIG, XMAX, FIRST - DATA ALGMCS( 1) / .1666389480 45186E0 / - DATA ALGMCS( 2) / -.0000138494 817606E0 / - DATA ALGMCS( 3) / .0000000098 108256E0 / - DATA ALGMCS( 4) / -.0000000000 180912E0 / - DATA ALGMCS( 5) / .0000000000 000622E0 / - DATA ALGMCS( 6) / -.0000000000 000003E0 / - DATA FIRST /.TRUE./ -C***FIRST EXECUTABLE STATEMENT R9LGMC - IF (FIRST) THEN - NALGM = INITS (ALGMCS, 6, R1MACH(3)) - XBIG = 1.0/SQRT(R1MACH(3)) - XMAX = EXP (MIN(LOG(R1MACH(2)/12.0), -LOG(12.0*R1MACH(1))) ) - ENDIF - FIRST = .FALSE. -C - IF (X .LT. 10.0) CALL XERMSG ('SLATEC', 'R9LGMC', - + 'X MUST BE GE 10', 1, 2) - IF (X.GE.XMAX) GO TO 20 -C - R9LGMC = 1.0/(12.0*X) - IF (X.LT.XBIG) R9LGMC = CSEVL (2.0*(10./X)**2-1., ALGMCS, NALGM)/X - RETURN -C - 20 R9LGMC = 0.0 - CALL XERMSG ('SLATEC', 'R9LGMC', 'X SO BIG R9LGMC UNDERFLOWS', 2, - + 1) - RETURN -C - END
--- a/liboctave/cruft/slatec-fn/xacosh.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,6 +0,0 @@ - subroutine xacosh (x, result) - external acosh - real x, result, acosh - result = acosh (x) - return - end
--- a/liboctave/cruft/slatec-fn/xasinh.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,6 +0,0 @@ - subroutine xasinh (x, result) - external asinh - real x, result, asinh - result = asinh (x) - return - end
--- a/liboctave/cruft/slatec-fn/xatanh.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,6 +0,0 @@ - subroutine xatanh (x, result) - external atanh - real x, result, atanh - result = atanh (x) - return - end
--- a/liboctave/cruft/slatec-fn/xbetai.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,6 +0,0 @@ - subroutine xbetai (x, a, b, result) - external betai - real x, a, b, result, betai - result = betai (x, a, b) - return - end
--- a/liboctave/cruft/slatec-fn/xdacosh.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,6 +0,0 @@ - subroutine xdacosh (x, result) - external dacosh - double precision x, result, dacosh - result = dacosh (x) - return - end
--- a/liboctave/cruft/slatec-fn/xdasinh.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,6 +0,0 @@ - subroutine xdasinh (x, result) - external dasinh - double precision x, result, dasinh - result = dasinh (x) - return - end
--- a/liboctave/cruft/slatec-fn/xdatanh.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,6 +0,0 @@ - subroutine xdatanh (x, result) - external datanh - double precision x, result, datanh - result = datanh (x) - return - end
--- a/liboctave/cruft/slatec-fn/xdbetai.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,6 +0,0 @@ - subroutine xdbetai (x, a, b, result) - external dbetai - double precision x, a, b, result, dbetai - result = dbetai (x, a, b) - return - end
--- a/liboctave/cruft/slatec-fn/xderf.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,6 +0,0 @@ - subroutine xderf (x, result) - external derf - double precision x, result, derf - result = derf (x) - return - end
--- a/liboctave/cruft/slatec-fn/xderfc.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,6 +0,0 @@ - subroutine xderfc (x, result) - external derfc - double precision x, result, derfc - result = derfc (x) - return - end
--- a/liboctave/cruft/slatec-fn/xdgami.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,6 +0,0 @@ - subroutine xdgami (a, x, result) - external dgami - double precision a, x, result, dgami - result = dgami (a, x) - return - end
--- a/liboctave/cruft/slatec-fn/xdgamit.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,6 +0,0 @@ - subroutine xdgamit (a, x, result) - external dgamit - double precision a, x, result, dgamit - result = dgamit (a, x) - return - end
--- a/liboctave/cruft/slatec-fn/xdgamma.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,6 +0,0 @@ - subroutine xdgamma (x, result) - external dgamma - double precision x, result, dgamma - result = dgamma (x) - return - end
--- a/liboctave/cruft/slatec-fn/xerf.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,6 +0,0 @@ - subroutine xerf (x, result) - external erf - real x, result, erf - result = erf (x) - return - end
--- a/liboctave/cruft/slatec-fn/xerfc.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,6 +0,0 @@ - subroutine xerfc (x, result) - external erfc - real x, result, erfc - result = erfc (x) - return - end
--- a/liboctave/cruft/slatec-fn/xgamma.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,6 +0,0 @@ - subroutine xgamma (x, result) - external gamma - real x, result, gamma - result = gamma (x) - return - end
--- a/liboctave/cruft/slatec-fn/xgmainc.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,100 +0,0 @@ - subroutine xgammainc (a, x, result) - -c -- jwe, based on DGAMIT. -c -c -- Do a better job than dgami for large values of x. - - double precision a, x, result - intrinsic exp, log, sqrt, sign, aint - external dgami, dlngam, d9lgit, d9lgic, d9gmit - -C external dgamr -C DOUBLE PRECISION DGAMR - - DOUBLE PRECISION AEPS, AINTA, ALGAP1, ALNEPS, ALNG, ALX, - $ BOT, H, SGA, SGNGAM, SQEPS, T, D1MACH, D9GMIT, - $ D9LGIC, D9LGIT, DLNGAM, DGAMI - - LOGICAL FIRST - - SAVE ALNEPS, SQEPS, BOT, FIRST - - DATA FIRST /.TRUE./ - - if (x .eq. 0.0d0) then - - if (a .eq. 0.0d0) then - result = 1.0d0 - else - result = 0.0d0 - endif - - else - - IF (FIRST) THEN - ALNEPS = -LOG (D1MACH(3)) - SQEPS = SQRT(D1MACH(4)) - BOT = LOG (D1MACH(1)) - ENDIF - FIRST = .FALSE. -C - IF (X .LT. 0.D0) CALL XERMSG ('SLATEC', 'XGMAINC', 'X IS NEGATIVE' - + , 2, 2) -C - IF (X.NE.0.D0) ALX = LOG (X) - SGA = 1.0D0 - IF (A.NE.0.D0) SGA = SIGN (1.0D0, A) - AINTA = AINT (A + 0.5D0*SGA) - AEPS = A - AINTA -C -C IF (X.GT.0.D0) GO TO 20 -C DGAMIT = 0.0D0 -C IF (AINTA.GT.0.D0 .OR. AEPS.NE.0.D0) DGAMIT = DGAMR(A+1.0D0) -C RETURN -C - 20 IF (X.GT.1.D0) GO TO 30 - IF (A.GE.(-0.5D0) .OR. AEPS.NE.0.D0) CALL DLGAMS (A+1.0D0, ALGAP1, - 1 SGNGAM) -C DGAMIT = D9GMIT (A, X, ALGAP1, SGNGAM, ALX) - result = exp (a*alx + log (D9GMIT (A, X, ALGAP1, SGNGAM, ALX))) - RETURN -C - 30 IF (A.LT.X) GO TO 40 - T = D9LGIT (A, X, DLNGAM(A+1.0D0)) - IF (T.LT.BOT) CALL XERCLR -C DGAMIT = EXP (T) - result = EXP (a*alx + T) - RETURN -C - 40 ALNG = D9LGIC (A, X, ALX) -C -C EVALUATE DGAMIT IN TERMS OF LOG (DGAMIC (A, X)) -C - H = 1.0D0 - IF (AEPS.EQ.0.D0 .AND. AINTA.LE.0.D0) GO TO 50 -C - CALL DLGAMS (A+1.0D0, ALGAP1, SGNGAM) - T = LOG (ABS(A)) + ALNG - ALGAP1 - IF (T.GT.ALNEPS) GO TO 60 -C - IF (T.GT.(-ALNEPS)) H = 1.0D0 - SGA * SGNGAM * EXP(T) - IF (ABS(H).GT.SQEPS) GO TO 50 -C - CALL XERCLR - CALL XERMSG ('SLATEC', 'XGMAINC', 'RESULT LT HALF PRECISION', 1, - + 1) -C -C 50 T = -A*ALX + LOG(ABS(H)) -C IF (T.LT.BOT) CALL XERCLR -C DGAMIT = SIGN (EXP(T), H) - 50 result = H - RETURN -C -C 60 T = T - A*ALX - 60 IF (T.LT.BOT) CALL XERCLR - result = -SGA * SGNGAM * EXP(T) - RETURN - - endif - return - end
--- a/liboctave/cruft/slatec-fn/xsgmainc.f Mon Apr 24 17:20:37 2017 -0700 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,100 +0,0 @@ - subroutine xsgammainc (a, x, result) - -c -- jwe, based on GAMIT. -c -c -- Do a better job than gami for large values of x. - - real a, x, result - intrinsic exp, log, sqrt, sign, aint - external gami, alngam, r9lgit, r9lgic, r9gmit - -C external gamr -C real GAMR - - REAL AEPS, AINTA, ALGAP1, ALNEPS, ALNG, ALX, - $ BOT, H, SGA, SGNGAM, SQEPS, T, R1MACH, R9GMIT, - $ R9LGIC, R9LGIT, ALNGAM, GAMI - - LOGICAL FIRST - - SAVE ALNEPS, SQEPS, BOT, FIRST - - DATA FIRST /.TRUE./ - - if (x .eq. 0.0e0) then - - if (a .eq. 0.0e0) then - result = 1.0e0 - else - result = 0.0e0 - endif - - else - - IF (FIRST) THEN - ALNEPS = -LOG (R1MACH(3)) - SQEPS = SQRT(R1MACH(4)) - BOT = LOG (R1MACH(1)) - ENDIF - FIRST = .FALSE. -C - IF (X .LT. 0.E0) CALL XERMSG ('SLATEC', 'XGMAINC', 'X IS NEGATIVE' - + , 2, 2) -C - IF (X.NE.0.E0) ALX = LOG (X) - SGA = 1.0E0 - IF (A.NE.0.E0) SGA = SIGN (1.0E0, A) - AINTA = AINT (A + 0.5E0*SGA) - AEPS = A - AINTA -C -C IF (X.GT.0.E0) GO TO 20 -C GAMIT = 0.0E0 -C IF (AINTA.GT.0.E0 .OR. AEPS.NE.0.E0) GAMIT = GAMR(A+1.0E0) -C RETURN -C - 20 IF (X.GT.1.E0) GO TO 30 - IF (A.GE.(-0.5E0) .OR. AEPS.NE.0.E0) CALL ALGAMS (A+1.0E0, ALGAP1, - 1 SGNGAM) -C GAMIT = R9GMIT (A, X, ALGAP1, SGNGAM, ALX) - result = exp (a*alx + log (R9GMIT (A, X, ALGAP1, SGNGAM, ALX))) - RETURN -C - 30 IF (A.LT.X) GO TO 40 - T = R9LGIT (A, X, ALNGAM(A+1.0E0)) - IF (T.LT.BOT) CALL XERCLR -C GAMIT = EXP (T) - result = EXP (a*alx + T) - RETURN -C - 40 ALNG = R9LGIC (A, X, ALX) -C -C EVALUATE GAMIT IN TERMS OF LOG (DGAMIC (A, X)) -C - H = 1.0E0 - IF (AEPS.EQ.0.E0 .AND. AINTA.LE.0.E0) GO TO 50 -C - CALL ALGAMS (A+1.0E0, ALGAP1, SGNGAM) - T = LOG (ABS(A)) + ALNG - ALGAP1 - IF (T.GT.ALNEPS) GO TO 60 -C - IF (T.GT.(-ALNEPS)) H = 1.0E0 - SGA * SGNGAM * EXP(T) - IF (ABS(H).GT.SQEPS) GO TO 50 -C - CALL XERCLR - CALL XERMSG ('SLATEC', 'XGMAINC', 'RESULT LT HALF PRECISION', 1, - + 1) -C -C 50 T = -A*ALX + LOG(ABS(H)) -C IF (T.LT.BOT) CALL XERCLR -C GAMIT = SIGN (EXP(T), H) - 50 result = H - RETURN -C -C 60 T = T - A*ALX - 60 IF (T.LT.BOT) CALL XERCLR - result = -SGA * SGNGAM * EXP(T) - RETURN - - endif - return - end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/Faddeeva/Faddeeva.cc Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,2508 @@ +// -*- 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<double>, 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 <cmath> 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<x<26. Performance improvements. Prototype + now supplies default value for relerr. + 24 October 2012: Switch to continued-fraction expansion for + sufficiently large z, for performance reasons. + Also, avoid spurious overflow for |z| > 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). */ + +#if defined (HAVE_CONFIG_H) +# include "config.h" +#endif + +///////////////////////////////////////////////////////////////////////// +// macros to allow us to use either C++ or C (with C99 features) + +#if defined (__cplusplus) + +# include "lo-ieee.h" + +# include "Faddeeva.hh" + +# include <cfloat> +# include <cmath> +# include <limits> + +// use std::numeric_limits, since 1./0. and 0./0. fail with some compilers (MS) +# define Inf octave::numeric_limits<double>::Inf () +# define NaN octave::numeric_limits<double>::NaN () + +typedef std::complex<double> 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 defined (lo_ieee_isnan) && defined (lo_ieee_isinf) +# define isnan lo_ieee_isnan +# define isinf lo_ieee_isinf +# elif (__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 (__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 + +#else // !__cplusplus, i.e., pure C (requires C99 features) + +# include "Faddeeva.h" + +# define _GNU_SOURCE // enable GNU libc NAN extension if possible + +# include <float.h> +# include <math.h> + +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 + +# if defined (CMPLX) // C11 +# define C(a,b) CMPLX(a,b) +# define Inf INFINITY // C99 infinity +# if defined (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 (static_cast<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 (static_cast<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 +#if defined (TEST_FADDEEVA) + +#if defined (__cplusplus) +# include <cstdio> +#else +# include <stdio.h> +#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
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/Faddeeva/Faddeeva.hh Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,62 @@ +/* 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.cc; see that file for more information. */ + +#ifndef FADDEEVA_HH +#define FADDEEVA_HH 1 + +#include <complex> + +namespace Faddeeva { + +// compute w(z) = exp(-z^2) erfc(-iz) [ Faddeeva / scaled complex error func ] +extern std::complex<double> w(std::complex<double> z,double relerr=0); +extern double 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 std::complex<double> erfcx(std::complex<double> z, double relerr=0); +extern double erfcx(double x); // special case for real x + +// compute erf(z), the error function of complex arguments +extern std::complex<double> erf(std::complex<double> z, double relerr=0); +extern double erf(double x); // special case for real x + +// compute erfi(z) = -i erf(iz), the imaginary error function +extern std::complex<double> erfi(std::complex<double> z, double relerr=0); +extern double erfi(double x); // special case for real x + +// compute erfc(z) = 1 - erf(z), the complementary error function +extern std::complex<double> erfc(std::complex<double> z, double relerr=0); +extern double erfc(double x); // special case for real x + +// compute Dawson(z) = sqrt(pi)/2 * exp(-z^2) * erfi(z) +extern std::complex<double> Dawson(std::complex<double> z, double relerr=0); +extern double Dawson(double x); // special case for real x + +} // namespace Faddeeva + +#endif // FADDEEVA_HH
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/Faddeeva/module.mk Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,3 @@ +EXTERNAL_SOURCES += \ + liboctave/external/Faddeeva/Faddeeva.cc \ + liboctave/external/Faddeeva/Faddeeva.hh
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/amos/README Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,15 @@ +The files in this directory have been modified from those found on +netlib by changing the following subroutine names + + zabs --> xzabs + zexp --> xzexp + zlog --> xzlog + zsqrt --> xzsqrt + +to avoid conflicts with non-standard but commonly used Fortran +intrinsic function names. + +John W. Eaton +jwe@octave.org + +Wed Nov 11 17:29:50 1998
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/amos/cacai.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,90 @@ + SUBROUTINE CACAI(Z, FNU, KODE, MR, N, Y, NZ, RL, TOL, ELIM, ALIM) +C***BEGIN PROLOGUE CACAI +C***REFER TO CAIRY +C +C CACAI 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 CAIRY WHERE FNU=1/3 OR 2/3 AND N=1. +C CACAI IS THE SAME AS CACON WITH THE PARTS FOR LARGER ORDERS AND +C RECURRENCE REMOVED. A RECURSIVE CALL TO CACON CAN RESULT IF CACON +C IS CALLED FROM CAIRY. +C +C***ROUTINES CALLED CASYI,CBKNU,CMLRI,CSERI,CS1S2,R1MACH +C***END PROLOGUE CACAI + COMPLEX CSGN, CSPN, C1, C2, Y, Z, ZN, CY + REAL ALIM, ARG, ASCLE, AZ, CPN, DFNU, ELIM, FMR, FNU, PI, RL, + * SGN, SPN, TOL, YY, R1MACH + INTEGER INU, IUF, KODE, MR, N, NN, NW, NZ + DIMENSION Y(N), CY(2) + DATA PI / 3.14159265358979324E0 / + NZ = 0 + ZN = -Z + AZ = CABS(Z) + NN = N + DFNU = FNU + FLOAT(N-1) + IF (AZ.LE.2.0E0) GO TO 10 + IF (AZ*AZ*0.25E0.GT.DFNU+1.0E0) GO TO 20 + 10 CONTINUE +C----------------------------------------------------------------------- +C POWER SERIES FOR THE I FUNCTION +C----------------------------------------------------------------------- + CALL CSERI(ZN, FNU, KODE, NN, Y, 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 CASYI(ZN, FNU, KODE, NN, Y, NW, RL, TOL, ELIM, ALIM) + IF (NW.LT.0) GO TO 70 + GO TO 40 + 30 CONTINUE +C----------------------------------------------------------------------- +C MILLER ALGORITHM NORMALIZED BY THE SERIES FOR THE I FUNCTION +C----------------------------------------------------------------------- + CALL CMLRI(ZN, FNU, KODE, NN, Y, NW, TOL) + IF(NW.LT.0) GO TO 70 + 40 CONTINUE +C----------------------------------------------------------------------- +C ANALYTIC CONTINUATION TO THE LEFT HALF PLANE FOR THE K FUNCTION +C----------------------------------------------------------------------- + CALL CBKNU(ZN, FNU, KODE, 1, CY, NW, TOL, ELIM, ALIM) + IF (NW.NE.0) GO TO 70 + FMR = FLOAT(MR) + SGN = -SIGN(PI,FMR) + CSGN = CMPLX(0.0E0,SGN) + IF (KODE.EQ.1) GO TO 50 + YY = -AIMAG(ZN) + CPN = COS(YY) + SPN = SIN(YY) + CSGN = CSGN*CMPLX(CPN,SPN) + 50 CONTINUE +C----------------------------------------------------------------------- +C CALCULATE CSPN=EXP(FNU*PI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE +C WHEN FNU IS LARGE +C----------------------------------------------------------------------- + INU = INT(FNU) + ARG = (FNU-FLOAT(INU))*SGN + CPN = COS(ARG) + SPN = SIN(ARG) + CSPN = CMPLX(CPN,SPN) + IF (MOD(INU,2).EQ.1) CSPN = -CSPN + C1 = CY(1) + C2 = Y(1) + IF (KODE.EQ.1) GO TO 60 + IUF = 0 + ASCLE = 1.0E+3*R1MACH(1)/TOL + CALL CS1S2(ZN, C1, C2, NW, ASCLE, ALIM, IUF) + NZ = NZ + NW + 60 CONTINUE + Y(1) = CSPN*C1 + CSGN*C2 + RETURN + 70 CONTINUE + NZ = -1 + IF(NW.EQ.(-2)) NZ=-2 + RETURN + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/amos/cacon.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,149 @@ + SUBROUTINE CACON(Z, FNU, KODE, MR, N, Y, NZ, RL, FNUL, TOL, ELIM, + * ALIM) +C***BEGIN PROLOGUE CACON +C***REFER TO CBESK,CBESH +C +C CACON 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 CBINU,CBKNU,CS1S2,R1MACH +C***END PROLOGUE CACON + COMPLEX CK, CONE, CS, CSCL, CSCR, CSGN, CSPN, CSS, CSR, C1, C2, + * RZ, SC1, SC2, ST, S1, S2, Y, Z, ZN, CY + REAL ALIM, ARG, ASCLE, AS2, BSCLE, BRY, CPN, C1I, C1M, C1R, ELIM, + * FMR, FNU, FNUL, PI, RL, SGN, SPN, TOL, YY, R1MACH + INTEGER I, INU, IUF, KFLAG, KODE, MR, N, NN, NW, NZ + DIMENSION Y(N), CY(2), CSS(3), CSR(3), BRY(3) + DATA PI / 3.14159265358979324E0 / + DATA CONE / (1.0E0,0.0E0) / + NZ = 0 + ZN = -Z + NN = N + CALL CBINU(ZN, FNU, KODE, NN, Y, NW, RL, FNUL, TOL, ELIM, ALIM) + IF (NW.LT.0) GO TO 80 +C----------------------------------------------------------------------- +C ANALYTIC CONTINUATION TO THE LEFT HALF PLANE FOR THE K FUNCTION +C----------------------------------------------------------------------- + NN = MIN0(2,N) + CALL CBKNU(ZN, FNU, KODE, NN, CY, NW, TOL, ELIM, ALIM) + IF (NW.NE.0) GO TO 80 + S1 = CY(1) + FMR = FLOAT(MR) + SGN = -SIGN(PI,FMR) + CSGN = CMPLX(0.0E0,SGN) + IF (KODE.EQ.1) GO TO 10 + YY = -AIMAG(ZN) + CPN = COS(YY) + SPN = SIN(YY) + CSGN = CSGN*CMPLX(CPN,SPN) + 10 CONTINUE +C----------------------------------------------------------------------- +C CALCULATE CSPN=EXP(FNU*PI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE +C WHEN FNU IS LARGE +C----------------------------------------------------------------------- + INU = INT(FNU) + ARG = (FNU-FLOAT(INU))*SGN + CPN = COS(ARG) + SPN = SIN(ARG) + CSPN = CMPLX(CPN,SPN) + IF (MOD(INU,2).EQ.1) CSPN = -CSPN + IUF = 0 + C1 = S1 + C2 = Y(1) + ASCLE = 1.0E+3*R1MACH(1)/TOL + IF (KODE.EQ.1) GO TO 20 + CALL CS1S2(ZN, C1, C2, NW, ASCLE, ALIM, IUF) + NZ = NZ + NW + SC1 = C1 + 20 CONTINUE + Y(1) = CSPN*C1 + CSGN*C2 + IF (N.EQ.1) RETURN + CSPN = -CSPN + S2 = CY(2) + C1 = S2 + C2 = Y(2) + IF (KODE.EQ.1) GO TO 30 + CALL CS1S2(ZN, C1, C2, NW, ASCLE, ALIM, IUF) + NZ = NZ + NW + SC2 = C1 + 30 CONTINUE + Y(2) = CSPN*C1 + CSGN*C2 + IF (N.EQ.2) RETURN + CSPN = -CSPN + RZ = CMPLX(2.0E0,0.0E0)/ZN + CK = CMPLX(FNU+1.0E0,0.0E0)*RZ +C----------------------------------------------------------------------- +C SCALE NEAR EXPONENT EXTREMES DURING RECURRENCE ON K FUNCTIONS +C----------------------------------------------------------------------- + CSCL = CMPLX(1.0E0/TOL,0.0E0) + CSCR = CMPLX(TOL,0.0E0) + CSS(1) = CSCL + CSS(2) = CONE + CSS(3) = CSCR + CSR(1) = CSCR + CSR(2) = CONE + CSR(3) = CSCL + BRY(1) = ASCLE + BRY(2) = 1.0E0/ASCLE + BRY(3) = R1MACH(2) + AS2 = CABS(S2) + KFLAG = 2 + IF (AS2.GT.BRY(1)) GO TO 40 + KFLAG = 1 + GO TO 50 + 40 CONTINUE + IF (AS2.LT.BRY(2)) GO TO 50 + KFLAG = 3 + 50 CONTINUE + BSCLE = BRY(KFLAG) + S1 = S1*CSS(KFLAG) + S2 = S2*CSS(KFLAG) + CS = CSR(KFLAG) + DO 70 I=3,N + ST = S2 + S2 = CK*S2 + S1 + S1 = ST + C1 = S2*CS + ST = C1 + C2 = Y(I) + IF (KODE.EQ.1) GO TO 60 + IF (IUF.LT.0) GO TO 60 + CALL CS1S2(ZN, C1, C2, NW, ASCLE, ALIM, IUF) + NZ = NZ + NW + SC1 = SC2 + SC2 = C1 + IF (IUF.NE.3) GO TO 60 + IUF = -4 + S1 = SC1*CSS(KFLAG) + S2 = SC2*CSS(KFLAG) + ST = SC2 + 60 CONTINUE + Y(I) = CSPN*C1 + CSGN*C2 + CK = CK + RZ + CSPN = -CSPN + IF (KFLAG.GE.3) GO TO 70 + C1R = REAL(C1) + C1I = AIMAG(C1) + C1R = ABS(C1R) + C1I = ABS(C1I) + C1M = AMAX1(C1R,C1I) + IF (C1M.LE.BSCLE) GO TO 70 + KFLAG = KFLAG + 1 + BSCLE = BRY(KFLAG) + S1 = S1*CS + S2 = ST + S1 = S1*CSS(KFLAG) + S2 = S2*CSS(KFLAG) + CS = CSR(KFLAG) + 70 CONTINUE + RETURN + 80 CONTINUE + NZ = -1 + IF(NW.EQ.(-2)) NZ=-2 + RETURN + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/amos/cairy.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,336 @@ + SUBROUTINE CAIRY(Z, ID, KODE, AI, NZ, IERR) +C***BEGIN PROLOGUE CAIRY +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 ON KODE=1, CAIRY 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 DEFINITIONS AND NOTATION ARE FOUND IN THE NBS HANDBOOK OF +C MATHEMATICAL FUNCTIONS (REF. 1). +C +C INPUT +C Z - Z=CMPLX(X,Y) +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 +C AI - 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.0,0.0) 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 WITH 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 +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=R1MACH(4)=UNIT ROUNDOFF. +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 CACAI,CBKNU,I1MACH,R1MACH +C***END PROLOGUE CAIRY + COMPLEX AI, CONE, CSQ, CY, S1, S2, TRM1, TRM2, Z, ZTA, Z3 + REAL AA, AD, AK, ALIM, ATRM, AZ, AZ3, BK, CK, COEF, C1, C2, DIG, + * DK, D1, D2, ELIM, FID, FNU, RL, R1M5, SFAC, TOL, TTH, ZI, ZR, + * Z3I, Z3R, R1MACH, BB, ALAZ + INTEGER ID, IERR, IFLAG, K, KODE, K1, K2, MR, NN, NZ, I1MACH + DIMENSION CY(1) + DATA TTH, C1, C2, COEF /6.66666666666666667E-01, + * 3.55028053887817240E-01,2.58819403792806799E-01, + * 1.83776298473930683E-01/ + DATA CONE / (1.0E0,0.0E0) / +C***FIRST EXECUTABLE STATEMENT CAIRY + 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 = CABS(Z) + TOL = AMAX1(R1MACH(4),1.0E-18) + FID = FLOAT(ID) + IF (AZ.GT.1.0E0) GO TO 60 +C----------------------------------------------------------------------- +C POWER SERIES FOR CABS(Z).LE.1. +C----------------------------------------------------------------------- + S1 = CONE + S2 = CONE + IF (AZ.LT.TOL) GO TO 160 + AA = AZ*AZ + IF (AA.LT.TOL/AZ) GO TO 40 + TRM1 = CONE + TRM2 = CONE + ATRM = 1.0E0 + Z3 = Z*Z*Z + AZ3 = AZ*AA + AK = 2.0E0 + FID + BK = 3.0E0 - FID - FID + CK = 4.0E0 - FID + DK = 3.0E0 + FID + FID + D1 = AK*DK + D2 = BK*CK + AD = AMIN1(D1,D2) + AK = 24.0E0 + 9.0E0*FID + BK = 30.0E0 - 9.0E0*FID + Z3R = REAL(Z3) + Z3I = AIMAG(Z3) + DO 30 K=1,25 + TRM1 = TRM1*CMPLX(Z3R/D1,Z3I/D1) + S1 = S1 + TRM1 + TRM2 = TRM2*CMPLX(Z3R/D2,Z3I/D2) + S2 = S2 + TRM2 + ATRM = ATRM*AZ3/AD + D1 = D1 + AK + D2 = D2 + BK + AD = AMIN1(D1,D2) + IF (ATRM.LT.TOL*AD) GO TO 40 + AK = AK + 18.0E0 + BK = BK + 18.0E0 + 30 CONTINUE + 40 CONTINUE + IF (ID.EQ.1) GO TO 50 + AI = S1*CMPLX(C1,0.0E0) - Z*S2*CMPLX(C2,0.0E0) + IF (KODE.EQ.1) RETURN + ZTA = Z*CSQRT(Z)*CMPLX(TTH,0.0E0) + AI = AI*CEXP(ZTA) + RETURN + 50 CONTINUE + AI = -S2*CMPLX(C2,0.0E0) + IF (AZ.GT.TOL) AI = AI + Z*Z*S1*CMPLX(C1/(1.0E0+FID),0.0E0) + IF (KODE.EQ.1) RETURN + ZTA = Z*CSQRT(Z)*CMPLX(TTH,0.0E0) + AI = AI*CEXP(ZTA) + RETURN +C----------------------------------------------------------------------- +C CASE FOR CABS(Z).GT.1.0 +C----------------------------------------------------------------------- + 60 CONTINUE + FNU = (1.0E0+FID)/3.0E0 +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----------------------------------------------------------------------- + K1 = I1MACH(12) + K2 = I1MACH(13) + R1M5 = R1MACH(5) + K = MIN0(IABS(K1),IABS(K2)) + ELIM = 2.303E0*(FLOAT(K)*R1M5-3.0E0) + K1 = I1MACH(11) - 1 + AA = R1M5*FLOAT(K1) + DIG = AMIN1(AA,18.0E0) + AA = AA*2.303E0 + ALIM = ELIM + AMAX1(-AA,-41.45E0) + RL = 1.2E0*DIG + 3.0E0 + ALAZ=ALOG(AZ) +C----------------------------------------------------------------------- +C TEST FOR RANGE +C----------------------------------------------------------------------- + AA=0.5E0/TOL + BB=FLOAT(I1MACH(9))*0.5E0 + AA=AMIN1(AA,BB) + AA=AA**TTH + IF (AZ.GT.AA) GO TO 260 + AA=SQRT(AA) + IF (AZ.GT.AA) IERR=3 + CSQ=CSQRT(Z) + ZTA=Z*CSQ*CMPLX(TTH,0.0E0) +C----------------------------------------------------------------------- +C RE(ZTA).LE.0 WHEN RE(Z).LT.0, ESPECIALLY WHEN IM(Z) IS SMALL +C----------------------------------------------------------------------- + IFLAG = 0 + SFAC = 1.0E0 + ZI = AIMAG(Z) + ZR = REAL(Z) + AK = AIMAG(ZTA) + IF (ZR.GE.0.0E0) GO TO 70 + BK = REAL(ZTA) + CK = -ABS(BK) + ZTA = CMPLX(CK,AK) + 70 CONTINUE + IF (ZI.NE.0.0E0) GO TO 80 + IF (ZR.GT.0.0E0) GO TO 80 + ZTA = CMPLX(0.0E0,AK) + 80 CONTINUE + AA = REAL(ZTA) + IF (AA.GE.0.0E0 .AND. ZR.GT.0.0E0) GO TO 100 + IF (KODE.EQ.2) GO TO 90 +C----------------------------------------------------------------------- +C OVERFLOW TEST +C----------------------------------------------------------------------- + IF (AA.GT.(-ALIM)) GO TO 90 + AA = -AA + 0.25E0*ALAZ + IFLAG = 1 + SFAC = TOL + IF (AA.GT.ELIM) GO TO 240 + 90 CONTINUE +C----------------------------------------------------------------------- +C CBKNU AND CACAI RETURN EXP(ZTA)*K(FNU,ZTA) ON KODE=2 +C----------------------------------------------------------------------- + MR = 1 + IF (ZI.LT.0.0E0) MR = -1 + CALL CACAI(ZTA, FNU, KODE, MR, 1, CY, NN, RL, TOL, ELIM, ALIM) + IF (NN.LT.0) GO TO 250 + NZ = NZ + NN + GO TO 120 + 100 CONTINUE + IF (KODE.EQ.2) GO TO 110 +C----------------------------------------------------------------------- +C UNDERFLOW TEST +C----------------------------------------------------------------------- + IF (AA.LT.ALIM) GO TO 110 + AA = -AA - 0.25E0*ALAZ + IFLAG = 2 + SFAC = 1.0E0/TOL + IF (AA.LT.(-ELIM)) GO TO 180 + 110 CONTINUE + CALL CBKNU(ZTA, FNU, KODE, 1, CY, NZ, TOL, ELIM, ALIM) + 120 CONTINUE + S1 = CY(1)*CMPLX(COEF,0.0E0) + IF (IFLAG.NE.0) GO TO 140 + IF (ID.EQ.1) GO TO 130 + AI = CSQ*S1 + RETURN + 130 AI = -Z*S1 + RETURN + 140 CONTINUE + S1 = S1*CMPLX(SFAC,0.0E0) + IF (ID.EQ.1) GO TO 150 + S1 = S1*CSQ + AI = S1*CMPLX(1.0E0/SFAC,0.0E0) + RETURN + 150 CONTINUE + S1 = -S1*Z + AI = S1*CMPLX(1.0E0/SFAC,0.0E0) + RETURN + 160 CONTINUE + AA = 1.0E+3*R1MACH(1) + S1 = CMPLX(0.0E0,0.0E0) + IF (ID.EQ.1) GO TO 170 + IF (AZ.GT.AA) S1 = CMPLX(C2,0.0E0)*Z + AI = CMPLX(C1,0.0E0) - S1 + RETURN + 170 CONTINUE + AI = -CMPLX(C2,0.0E0) + AA = SQRT(AA) + IF (AZ.GT.AA) S1 = Z*Z*CMPLX(0.5E0,0.0E0) + AI = AI + S1*CMPLX(C1,0.0E0) + RETURN + 180 CONTINUE + NZ = 1 + AI = CMPLX(0.0E0,0.0E0) + RETURN + 240 CONTINUE + NZ = 0 + IERR=2 + RETURN + 250 CONTINUE + IF(NN.EQ.(-1)) GO TO 240 + NZ=0 + IERR=5 + RETURN + 260 CONTINUE + IERR=4 + NZ=0 + RETURN + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/amos/casyi.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,126 @@ + SUBROUTINE CASYI(Z, FNU, KODE, N, Y, NZ, RL, TOL, ELIM, ALIM) +C***BEGIN PROLOGUE CASYI +C***REFER TO CBESI,CBESK +C +C CASYI 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 R1MACH +C***END PROLOGUE CASYI + COMPLEX AK1, CK, CONE, CS1, CS2, CZ, CZERO, DK, EZ, P1, RZ, S2, + * Y, Z + REAL AA, ACZ, AEZ, AK, ALIM, ARG, ARM, ATOL, AZ, BB, BK, DFNU, + * DNU2, ELIM, FDN, FNU, PI, RL, RTPI, RTR1, S, SGN, SQK, TOL, X, + * YY, R1MACH + INTEGER I, IB, IL, INU, J, JL, K, KODE, KODED, M, N, NN, NZ + DIMENSION Y(N) + DATA PI, RTPI /3.14159265358979324E0 , 0.159154943091895336E0 / + DATA CZERO, CONE / (0.0E0,0.0E0), (1.0E0,0.0E0) / +C + NZ = 0 + AZ = CABS(Z) + X = REAL(Z) + ARM = 1.0E+3*R1MACH(1) + RTR1 = SQRT(ARM) + IL = MIN0(2,N) + DFNU = FNU + FLOAT(N-IL) +C----------------------------------------------------------------------- +C OVERFLOW TEST +C----------------------------------------------------------------------- + AK1 = CMPLX(RTPI,0.0E0)/Z + AK1 = CSQRT(AK1) + CZ = Z + IF (KODE.EQ.2) CZ = Z - CMPLX(X,0.0E0) + ACZ = REAL(CZ) + IF (ABS(ACZ).GT.ELIM) GO TO 80 + DNU2 = DFNU + DFNU + KODED = 1 + IF ((ABS(ACZ).GT.ALIM) .AND. (N.GT.2)) GO TO 10 + KODED = 0 + AK1 = AK1*CEXP(CZ) + 10 CONTINUE + FDN = 0.0E0 + IF (DNU2.GT.RTR1) FDN = DNU2*DNU2 + EZ = Z*CMPLX(8.0E0,0.0E0) +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.0E0*AZ + S = TOL/AEZ + JL = INT(RL+RL) + 2 + YY = AIMAG(Z) + P1 = CZERO + IF (YY.EQ.0.0E0) GO TO 20 +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(FNU) + ARG = (FNU-FLOAT(INU))*PI + INU = INU + N - IL + AK = -SIN(ARG) + BK = COS(ARG) + IF (YY.LT.0.0E0) BK = -BK + P1 = CMPLX(AK,BK) + IF (MOD(INU,2).EQ.1) P1 = -P1 + 20 CONTINUE + DO 50 K=1,IL + SQK = FDN - 1.0E0 + ATOL = S*ABS(SQK) + SGN = 1.0E0 + CS1 = CONE + CS2 = CONE + CK = CONE + AK = 0.0E0 + AA = 1.0E0 + BB = AEZ + DK = EZ + DO 30 J=1,JL + CK = CK*CMPLX(SQK,0.0E0)/DK + CS2 = CS2 + CK + SGN = -SGN + CS1 = CS1 + CK*CMPLX(SGN,0.0E0) + DK = DK + EZ + AA = AA*ABS(SQK)/BB + BB = BB + AEZ + AK = AK + 8.0E0 + SQK = SQK - AK + IF (AA.LE.ATOL) GO TO 40 + 30 CONTINUE + GO TO 90 + 40 CONTINUE + S2 = CS1 + IF (X+X.LT.ELIM) S2 = S2 + P1*CS2*CEXP(-Z-Z) + FDN = FDN + 8.0E0*DFNU + 4.0E0 + P1 = -P1 + M = N - IL + K + Y(M) = S2*AK1 + 50 CONTINUE + IF (N.LE.2) RETURN + NN = N + K = NN - 2 + AK = FLOAT(K) + RZ = (CONE+CONE)/Z + IB = 3 + DO 60 I=IB,NN + Y(K) = CMPLX(AK+FNU,0.0E0)*RZ*Y(K+1) + Y(K+2) + AK = AK - 1.0E0 + K = K - 1 + 60 CONTINUE + IF (KODED.EQ.0) RETURN + CK = CEXP(CZ) + DO 70 I=1,NN + Y(I) = Y(I)*CK + 70 CONTINUE + RETURN + 80 CONTINUE + NZ = -1 + RETURN + 90 CONTINUE + NZ=-2 + RETURN + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/amos/cbesh.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,331 @@ + SUBROUTINE CBESH(Z, FNU, KODE, M, N, CY, NZ, IERR) +C***BEGIN PROLOGUE CBESH +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 ON KODE=1, CBESH 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.0E0,0.0E0) IN THE CUT PLANE -PI.LT.ARG(Z).LE.PI. +C ON KODE=2, CBESH COMPUTES THE SCALED HANKEL FUNCTIONS +C +C CY(I)=H(M,FNU+J-1,Z)*EXP(-MM*Z*I) MM=3-2M, I**2=-1. +C +C WHICH REMOVES THE EXPONENTIAL BEHAVIOR IN BOTH THE UPPER +C AND LOWER HALF PLANES. DEFINITIONS AND NOTATION ARE FOUND IN +C THE NBS HANDBOOK OF MATHEMATICAL FUNCTIONS (REF. 1). +C +C INPUT +C Z - Z=CMPLX(X,Y), Z.NE.CMPLX(0.,0.),-PI.LT.ARG(Z).LE.PI +C FNU - ORDER OF INITIAL H FUNCTION, FNU.GE.0.0E0 +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 OF THE SEQUENCE, N.GE.1 +C +C OUTPUT +C CY - A COMPLEX VECTOR WHOSE FIRST N COMPONENTS CONTAIN +C VALUES 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 +C DUE TO UNDERFLOW, CY(J)=CMPLX(0.0,0.0) +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+N-1 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=R1MACH(4)=UNIT ROUNDOFF. ALSO +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 CACON,CBKNU,CBUNK,CUOIK,I1MACH,R1MACH +C***END PROLOGUE CBESH +C + COMPLEX CY, Z, ZN, ZT, CSGN + REAL AA, ALIM, ALN, ARG, AZ, CPN, DIG, ELIM, FMM, FN, FNU, FNUL, + * HPI, RHPI, RL, R1M5, SGN, SPN, TOL, UFL, XN, XX, YN, YY, R1MACH, + * BB, ASCLE, RTOL, ATOL + INTEGER I, IERR, INU, INUH, IR, K, KODE, K1, K2, M, + * MM, MR, N, NN, NUF, NW, NZ, I1MACH + DIMENSION CY(N) +C + DATA HPI /1.57079632679489662E0/ +C +C***FIRST EXECUTABLE STATEMENT CBESH + NZ=0 + XX = REAL(Z) + YY = AIMAG(Z) + IERR = 0 + IF (XX.EQ.0.0E0 .AND. YY.EQ.0.0E0) IERR=1 + IF (FNU.LT.0.0E0) 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 = AMAX1(R1MACH(4),1.0E-18) + K1 = I1MACH(12) + K2 = I1MACH(13) + R1M5 = R1MACH(5) + K = MIN0(IABS(K1),IABS(K2)) + ELIM = 2.303E0*(FLOAT(K)*R1M5-3.0E0) + K1 = I1MACH(11) - 1 + AA = R1M5*FLOAT(K1) + DIG = AMIN1(AA,18.0E0) + AA = AA*2.303E0 + ALIM = ELIM + AMAX1(-AA,-41.45E0) + FNUL = 10.0E0 + 6.0E0*(DIG-3.0E0) + RL = 1.2E0*DIG + 3.0E0 + FN = FNU + FLOAT(NN-1) + MM = 3 - M - M + FMM = FLOAT(MM) + ZN = Z*CMPLX(0.0E0,-FMM) + XN = REAL(ZN) + YN = AIMAG(ZN) + AZ = CABS(Z) +C----------------------------------------------------------------------- +C TEST FOR RANGE +C----------------------------------------------------------------------- + AA = 0.5E0/TOL + BB=FLOAT(I1MACH(9))*0.5E0 + AA=AMIN1(AA,BB) + IF(AZ.GT.AA) GO TO 240 + IF(FN.GT.AA) GO TO 240 + AA=SQRT(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 = R1MACH(1)*1.0E+3 + IF (AZ.LT.UFL) GO TO 220 + IF (FNU.GT.FNUL) GO TO 90 + IF (FN.LE.1.0E0) GO TO 70 + IF (FN.GT.2.0E0) GO TO 60 + IF (AZ.GT.TOL) GO TO 70 + ARG = 0.5E0*AZ + ALN = -FN*ALOG(ARG) + IF (ALN.GT.ELIM) GO TO 220 + GO TO 70 + 60 CONTINUE + CALL CUOIK(ZN, FNU, KODE, 2, NN, CY, NUF, TOL, ELIM, ALIM) + IF (NUF.LT.0) GO TO 220 + 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 130 + 70 CONTINUE + IF ((XN.LT.0.0E0) .OR. (XN.EQ.0.0E0 .AND. YN.LT.0.0E0 .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 CBKNU(ZN, FNU, KODE, NN, CY, NZ, TOL, ELIM, ALIM) + GO TO 110 +C----------------------------------------------------------------------- +C LEFT HALF PLANE COMPUTATION +C----------------------------------------------------------------------- + 80 CONTINUE + MR = -MM + CALL CACON(ZN, FNU, KODE, MR, NN, CY, NW, RL, FNUL, TOL, ELIM, + * ALIM) + IF (NW.LT.0) GO TO 230 + NZ=NW + GO TO 110 + 90 CONTINUE +C----------------------------------------------------------------------- +C UNIFORM ASYMPTOTIC EXPANSIONS FOR FNU.GT.FNUL +C----------------------------------------------------------------------- + MR = 0 + IF ((XN.GE.0.0E0) .AND. (XN.NE.0.0E0 .OR. YN.GE.0.0E0 .OR. + * M.NE.2)) GO TO 100 + MR = -MM + IF (XN.EQ.0.0E0 .AND. YN.LT.0.0E0) ZN = -ZN + 100 CONTINUE + CALL CBUNK(ZN, FNU, KODE, MR, NN, CY, NW, TOL, ELIM, ALIM) + IF (NW.LT.0) GO TO 230 + 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 = SIGN(HPI,-FMM) +C----------------------------------------------------------------------- +C CALCULATE EXP(FNU*HPI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE +C WHEN FNU IS LARGE +C----------------------------------------------------------------------- + INU = INT(FNU) + INUH = INU/2 + IR = INU - 2*INUH + ARG = (FNU-FLOAT(INU-IR))*SGN + RHPI = 1.0E0/SGN + CPN = RHPI*COS(ARG) + SPN = RHPI*SIN(ARG) +C ZN = CMPLX(-SPN,CPN) + CSGN = CMPLX(-SPN,CPN) +C IF (MOD(INUH,2).EQ.1) ZN = -ZN + IF (MOD(INUH,2).EQ.1) CSGN = -CSGN + ZT = CMPLX(0.0E0,-FMM) + RTOL = 1.0E0/TOL + ASCLE = UFL*RTOL + DO 120 I=1,NN +C CY(I) = CY(I)*ZN +C ZN = ZN*ZT + ZN=CY(I) + AA=REAL(ZN) + BB=AIMAG(ZN) + ATOL=1.0E0 + IF (AMAX1(ABS(AA),ABS(BB)).GT.ASCLE) GO TO 125 + ZN = ZN*CMPLX(RTOL,0.0E0) + ATOL = TOL + 125 CONTINUE + ZN = ZN*CSGN + CY(I) = ZN*CMPLX(ATOL,0.0E0) + CSGN = CSGN*ZT + 120 CONTINUE + RETURN + 130 CONTINUE + IF (XN.LT.0.0E0) GO TO 220 + RETURN + 220 CONTINUE + IERR=2 + NZ=0 + RETURN + 230 CONTINUE + IF(NW.EQ.(-1)) GO TO 220 + NZ=0 + IERR=5 + RETURN + 240 CONTINUE + NZ=0 + IERR=4 + RETURN + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/amos/cbesi.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,258 @@ + SUBROUTINE CBESI(Z, FNU, KODE, N, CY, NZ, IERR) +C***BEGIN PROLOGUE CBESI +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 ON KODE=1, CBESI 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, CBESI 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 +C NOTATION ARE FOUND IN THE NBS HANDBOOK OF MATHEMATICAL +C FUNCTIONS (REF.1) +C +C INPUT +C Z - Z=CMPLX(X,Y), -PI.LT.ARG(Z).LE.PI +C FNU - ORDER OF INITIAL I FUNCTION, FNU.GE.0.0E0 +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 +C CY - A COMPLEX VECTOR WHOSE FIRST N COMPONENTS CONTAIN +C VALUES 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 DUE TO UNDERFLOW, CY(J)=CMPLX(0.0,0.0), +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=R1MACH(4)=UNIT ROUNDOFF. ALSO +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 CBINU,I1MACH,R1MACH +C***END PROLOGUE CBESI + COMPLEX CONE, CSGN, CY, Z, ZN + REAL AA, ALIM, ARG, DIG, ELIM, FNU, FNUL, PI, RL, R1M5, S1, S2, + * TOL, XX, YY, R1MACH, AZ, FN, BB, ASCLE, RTOL, ATOL + INTEGER I, IERR, INU, K, KODE, K1, K2, N, NN, NZ, I1MACH + DIMENSION CY(N) + DATA PI /3.14159265358979324E0/ + DATA CONE / (1.0E0,0.0E0) / +C +C***FIRST EXECUTABLE STATEMENT CBESI + IERR = 0 + NZ=0 + IF (FNU.LT.0.0E0) IERR=1 + IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1 + IF (N.LT.1) IERR=1 + IF (IERR.NE.0) RETURN + XX = REAL(Z) + YY = AIMAG(Z) +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 = AMAX1(R1MACH(4),1.0E-18) + K1 = I1MACH(12) + K2 = I1MACH(13) + R1M5 = R1MACH(5) + K = MIN0(IABS(K1),IABS(K2)) + ELIM = 2.303E0*(FLOAT(K)*R1M5-3.0E0) + K1 = I1MACH(11) - 1 + AA = R1M5*FLOAT(K1) + DIG = AMIN1(AA,18.0E0) + AA = AA*2.303E0 + ALIM = ELIM + AMAX1(-AA,-41.45E0) + RL = 1.2E0*DIG + 3.0E0 + FNUL = 10.0E0 + 6.0E0*(DIG-3.0E0) + AZ = CABS(Z) +C----------------------------------------------------------------------- +C TEST FOR RANGE +C----------------------------------------------------------------------- + AA = 0.5E0/TOL + BB=FLOAT(I1MACH(9))*0.5E0 + AA=AMIN1(AA,BB) + IF(AZ.GT.AA) GO TO 140 + FN=FNU+FLOAT(N-1) + IF(FN.GT.AA) GO TO 140 + AA=SQRT(AA) + IF(AZ.GT.AA) IERR=3 + IF(FN.GT.AA) IERR=3 + ZN = Z + CSGN = CONE + IF (XX.GE.0.0E0) GO TO 40 + ZN = -Z +C----------------------------------------------------------------------- +C CALCULATE CSGN=EXP(FNU*PI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE +C WHEN FNU IS LARGE +C----------------------------------------------------------------------- + INU = INT(FNU) + ARG = (FNU-FLOAT(INU))*PI + IF (YY.LT.0.0E0) ARG = -ARG + S1 = COS(ARG) + S2 = SIN(ARG) + CSGN = CMPLX(S1,S2) + IF (MOD(INU,2).EQ.1) CSGN = -CSGN + 40 CONTINUE + CALL CBINU(ZN, FNU, KODE, N, CY, NZ, RL, FNUL, TOL, ELIM, ALIM) + IF (NZ.LT.0) GO TO 120 + IF (XX.GE.0.0E0) RETURN +C----------------------------------------------------------------------- +C ANALYTIC CONTINUATION TO THE LEFT HALF PLANE +C----------------------------------------------------------------------- + NN = N - NZ + IF (NN.EQ.0) RETURN + RTOL = 1.0E0/TOL + ASCLE = R1MACH(1)*RTOL*1.0E+3 + DO 50 I=1,NN +C CY(I) = CY(I)*CSGN + ZN=CY(I) + AA=REAL(ZN) + BB=AIMAG(ZN) + ATOL=1.0E0 + IF (AMAX1(ABS(AA),ABS(BB)).GT.ASCLE) GO TO 55 + ZN = ZN*CMPLX(RTOL,0.0E0) + ATOL = TOL + 55 CONTINUE + ZN = ZN*CSGN + CY(I) = ZN*CMPLX(ATOL,0.0E0) + CSGN = -CSGN + 50 CONTINUE + RETURN + 120 CONTINUE + IF(NZ.EQ.(-2)) GO TO 130 + NZ = 0 + IERR=2 + RETURN + 130 CONTINUE + NZ=0 + IERR=5 + RETURN + 140 CONTINUE + NZ=0 + IERR=4 + RETURN + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/amos/cbesj.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,253 @@ + SUBROUTINE CBESJ(Z, FNU, KODE, N, CY, NZ, IERR) +C***BEGIN PROLOGUE CBESJ +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 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 +C Z - Z=CMPLX(X,Y), -PI.LT.ARG(Z).LE.PI +C FNU - ORDER OF INITIAL J FUNCTION, FNU.GE.0.0E0 +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,... +C N - NUMBER OF MEMBERS OF THE SEQUENCE, N.GE.1 +C +C OUTPUT +C CY - A COMPLEX VECTOR WHOSE FIRST N COMPONENTS CONTAIN +C VALUES 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 TO ZERO +C DUE TO UNDERFLOW, CY(I)=CMPLX(0.0,0.0), +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=R1MACH(4)=UNIT ROUNDOFF. ALSO +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 CBINU,I1MACH,R1MACH +C***END PROLOGUE CBESJ +C + COMPLEX CI, CSGN, CY, Z, ZN + REAL AA, ALIM, ARG, DIG, ELIM, FNU, FNUL, HPI, RL, R1, R1M5, R2, + * TOL, YY, R1MACH, AZ, FN, BB, ASCLE, RTOL, ATOL + INTEGER I, IERR, INU, INUH, IR, KODE, K1, K2, N, NL, NZ, I1MACH, K + DIMENSION CY(N) + DATA HPI /1.57079632679489662E0/ +C +C***FIRST EXECUTABLE STATEMENT CBESJ + IERR = 0 + NZ=0 + IF (FNU.LT.0.0E0) 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 = AMAX1(R1MACH(4),1.0E-18) + K1 = I1MACH(12) + K2 = I1MACH(13) + R1M5 = R1MACH(5) + K = MIN0(IABS(K1),IABS(K2)) + ELIM = 2.303E0*(FLOAT(K)*R1M5-3.0E0) + K1 = I1MACH(11) - 1 + AA = R1M5*FLOAT(K1) + DIG = AMIN1(AA,18.0E0) + AA = AA*2.303E0 + ALIM = ELIM + AMAX1(-AA,-41.45E0) + RL = 1.2E0*DIG + 3.0E0 + FNUL = 10.0E0 + 6.0E0*(DIG-3.0E0) + CI = CMPLX(0.0E0,1.0E0) + YY = AIMAG(Z) + AZ = CABS(Z) +C----------------------------------------------------------------------- +C TEST FOR RANGE +C----------------------------------------------------------------------- + AA = 0.5E0/TOL + BB=FLOAT(I1MACH(9))*0.5E0 + AA=AMIN1(AA,BB) + FN=FNU+FLOAT(N-1) + IF(AZ.GT.AA) GO TO 140 + IF(FN.GT.AA) GO TO 140 + AA=SQRT(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----------------------------------------------------------------------- + INU = INT(FNU) + INUH = INU/2 + IR = INU - 2*INUH + ARG = (FNU-FLOAT(INU-IR))*HPI + R1 = COS(ARG) + R2 = SIN(ARG) + CSGN = CMPLX(R1,R2) + IF (MOD(INUH,2).EQ.1) CSGN = -CSGN +C----------------------------------------------------------------------- +C ZN IS IN THE RIGHT HALF PLANE +C----------------------------------------------------------------------- + ZN = -Z*CI + IF (YY.GE.0.0E0) GO TO 40 + ZN = -ZN + CSGN = CONJG(CSGN) + CI = CONJG(CI) + 40 CONTINUE + CALL CBINU(ZN, FNU, KODE, N, CY, NZ, RL, FNUL, TOL, ELIM, ALIM) + IF (NZ.LT.0) GO TO 120 + NL = N - NZ + IF (NL.EQ.0) RETURN + RTOL = 1.0E0/TOL + ASCLE = R1MACH(1)*RTOL*1.0E+3 + DO 50 I=1,NL +C CY(I)=CY(I)*CSGN + ZN=CY(I) + AA=REAL(ZN) + BB=AIMAG(ZN) + ATOL=1.0E0 + IF (AMAX1(ABS(AA),ABS(BB)).GT.ASCLE) GO TO 55 + ZN = ZN*CMPLX(RTOL,0.0E0) + ATOL = TOL + 55 CONTINUE + ZN = ZN*CSGN + CY(I) = ZN*CMPLX(ATOL,0.0E0) + CSGN = CSGN*CI + 50 CONTINUE + RETURN + 120 CONTINUE + IF(NZ.EQ.(-2)) GO TO 130 + NZ = 0 + IERR = 2 + RETURN + 130 CONTINUE + NZ=0 + IERR=5 + RETURN + 140 CONTINUE + NZ=0 + IERR=4 + RETURN + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/amos/cbesk.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,276 @@ + SUBROUTINE CBESK(Z, FNU, KODE, N, CY, NZ, IERR) +C***BEGIN PROLOGUE CBESK +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 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 +C Z - Z=CMPLX(X,Y),Z.NE.CMPLX(0.,0.),-PI.LT.ARG(Z).LE.PI +C FNU - ORDER OF INITIAL K FUNCTION, FNU.GE.0.0E0 +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 +C CY - A COMPLEX VECTOR WHOSE FIRST N COMPONENTS CONTAIN +C VALUES 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 +C DUE TO UNDERFLOW, CY(I)=CMPLX(0.0,0.0), +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 IERR - ERROR FLAG +C IERR=0, NORMAL RETURN - COMPUTATION COMPLETED +C IERR=1, INPUT ERROR - NO COMPUTATION +C IERR=2, OVERFLOW - NO COMPUTATION, FNU+N-1 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=R1MACH(4)=UNIT ROUNDOFF. ALSO +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 CACON,CBKNU,CBUNK,CUOIK,I1MACH,R1MACH +C***END PROLOGUE CBESK +C + COMPLEX CY, Z + REAL AA, ALIM, ALN, ARG, AZ, DIG, ELIM, FN, FNU, FNUL, RL, R1M5, + * TOL, UFL, XX, YY, R1MACH, BB + INTEGER IERR, K, KODE, K1, K2, MR, N, NN, NUF, NW, NZ, I1MACH + DIMENSION CY(N) +C***FIRST EXECUTABLE STATEMENT CBESK + IERR = 0 + NZ=0 + XX = REAL(Z) + YY = AIMAG(Z) + IF (YY.EQ.0.0E0 .AND. XX.EQ.0.0E0) IERR=1 + IF (FNU.LT.0.0E0) 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 = AMAX1(R1MACH(4),1.0E-18) + K1 = I1MACH(12) + K2 = I1MACH(13) + R1M5 = R1MACH(5) + K = MIN0(IABS(K1),IABS(K2)) + ELIM = 2.303E0*(FLOAT(K)*R1M5-3.0E0) + K1 = I1MACH(11) - 1 + AA = R1M5*FLOAT(K1) + DIG = AMIN1(AA,18.0E0) + AA = AA*2.303E0 + ALIM = ELIM + AMAX1(-AA,-41.45E0) + FNUL = 10.0E0 + 6.0E0*(DIG-3.0E0) + RL = 1.2E0*DIG + 3.0E0 + AZ = CABS(Z) + FN = FNU + FLOAT(NN-1) +C----------------------------------------------------------------------- +C TEST FOR RANGE +C----------------------------------------------------------------------- + AA = 0.5E0/TOL + BB=FLOAT(I1MACH(9))*0.5E0 + AA=AMIN1(AA,BB) + IF(AZ.GT.AA) GO TO 210 + IF(FN.GT.AA) GO TO 210 + AA=SQRT(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 = EXP(-ELIM) + UFL = R1MACH(1)*1.0E+3 + IF (AZ.LT.UFL) GO TO 180 + IF (FNU.GT.FNUL) GO TO 80 + IF (FN.LE.1.0E0) GO TO 60 + IF (FN.GT.2.0E0) GO TO 50 + IF (AZ.GT.TOL) GO TO 60 + ARG = 0.5E0*AZ + ALN = -FN*ALOG(ARG) + IF (ALN.GT.ELIM) GO TO 180 + GO TO 60 + 50 CONTINUE + CALL CUOIK(Z, FNU, KODE, 2, NN, CY, 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 (XX.LT.0.0E0) GO TO 70 +C----------------------------------------------------------------------- +C RIGHT HALF PLANE COMPUTATION, REAL(Z).GE.0. +C----------------------------------------------------------------------- + CALL CBKNU(Z, FNU, KODE, NN, CY, 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 (YY.LT.0.0E0) MR = -1 + CALL CACON(Z, FNU, KODE, MR, NN, CY, 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 (XX.GE.0.0E0) GO TO 90 + MR = 1 + IF (YY.LT.0.0E0) MR = -1 + 90 CONTINUE + CALL CBUNK(Z, FNU, KODE, MR, NN, CY, NW, TOL, ELIM, ALIM) + IF (NW.LT.0) GO TO 200 + NZ = NZ + NW + RETURN + 100 CONTINUE + IF (XX.LT.0.0E0) 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 + 210 CONTINUE + NZ=0 + IERR=4 + RETURN + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/amos/cbesy.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,226 @@ + SUBROUTINE CBESY(Z, FNU, KODE, N, CY, NZ, CWRK, IERR) +C***BEGIN PROLOGUE CBESY +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 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 +C Z - Z=CMPLX(X,Y), Z.NE.CMPLX(0.,0.),-PI.LT.ARG(Z).LE.PI +C FNU - ORDER OF INITIAL Y FUNCTION, FNU.GE.0.0E0 +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 CWRK - A COMPLEX WORK VECTOR OF DIMENSION AT LEAST N +C +C OUTPUT +C CY - A COMPLEX VECTOR WHOSE FIRST N COMPONENTS CONTAIN +C VALUES 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+N-1 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=R1MACH(4)=UNIT ROUNDOFF. ALSO +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 CBESH,I1MACH,R1MACH +C***END PROLOGUE CBESY +C + COMPLEX CWRK, CY, C1, C2, EX, HCI, Z, ZU, ZV + REAL ELIM, EY, FNU, R1, R2, TAY, XX, YY, R1MACH, ASCLE, RTOL, + * ATOL, AA, BB + INTEGER I, IERR, K, KODE, K1, K2, N, NZ, NZ1, NZ2, I1MACH + DIMENSION CY(N), CWRK(N) +C***FIRST EXECUTABLE STATEMENT CBESY + XX = REAL(Z) + YY = AIMAG(Z) + IERR = 0 + NZ=0 + IF (XX.EQ.0.0E0 .AND. YY.EQ.0.0E0) IERR=1 + IF (FNU.LT.0.0E0) IERR=1 + IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1 + IF (N.LT.1) IERR=1 + IF (IERR.NE.0) RETURN + HCI = CMPLX(0.0E0,0.5E0) + CALL CBESH(Z, FNU, KODE, 1, N, CY, NZ1, IERR) + IF (IERR.NE.0.AND.IERR.NE.3) GO TO 170 + CALL CBESH(Z, FNU, KODE, 2, N, CWRK, 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 + CY(I) = HCI*(CWRK(I)-CY(I)) + 50 CONTINUE + RETURN + 60 CONTINUE + TOL = AMAX1(R1MACH(4),1.0E-18) + K1 = I1MACH(12) + K2 = I1MACH(13) + K = MIN0(IABS(K1),IABS(K2)) + R1M5 = R1MACH(5) +C----------------------------------------------------------------------- +C ELIM IS THE APPROXIMATE EXPONENTIAL UNDER- AND OVERFLOW LIMIT +C----------------------------------------------------------------------- + ELIM = 2.303E0*(FLOAT(K)*R1M5-3.0E0) + R1 = COS(XX) + R2 = SIN(XX) + EX = CMPLX(R1,R2) + EY = 0.0E0 + TAY = ABS(YY+YY) + IF (TAY.LT.ELIM) EY = EXP(-TAY) + IF (YY.LT.0.0E0) GO TO 90 + C1 = EX*CMPLX(EY,0.0E0) + C2 = CONJG(EX) + 70 CONTINUE + NZ = 0 + RTOL = 1.0E0/TOL + ASCLE = R1MACH(1)*RTOL*1.0E+3 + DO 80 I=1,N +C CY(I) = HCI*(C2*CWRK(I)-C1*CY(I)) + ZV = CWRK(I) + AA=REAL(ZV) + BB=AIMAG(ZV) + ATOL=1.0E0 + IF (AMAX1(ABS(AA),ABS(BB)).GT.ASCLE) GO TO 75 + ZV = ZV*CMPLX(RTOL,0.0E0) + ATOL = TOL + 75 CONTINUE + ZV = ZV*C2*HCI + ZV = ZV*CMPLX(ATOL,0.0E0) + ZU=CY(I) + AA=REAL(ZU) + BB=AIMAG(ZU) + ATOL=1.0E0 + IF (AMAX1(ABS(AA),ABS(BB)).GT.ASCLE) GO TO 85 + ZU = ZU*CMPLX(RTOL,0.0E0) + ATOL = TOL + 85 CONTINUE + ZU = ZU*C1*HCI + ZU = ZU*CMPLX(ATOL,0.0E0) + CY(I) = ZV - ZU + IF (CY(I).EQ.CMPLX(0.0E0,0.0E0) .AND. EY.EQ.0.0E0) NZ = NZ + 1 + 80 CONTINUE + RETURN + 90 CONTINUE + C1 = EX + C2 = CONJG(EX)*CMPLX(EY,0.0E0) + GO TO 70 + 170 CONTINUE + NZ = 0 + RETURN + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/amos/cbinu.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,105 @@ + SUBROUTINE CBINU(Z, FNU, KODE, N, CY, NZ, RL, FNUL, TOL, ELIM, + * ALIM) +C***BEGIN PROLOGUE CBINU +C***REFER TO CBESH,CBESI,CBESJ,CBESK,CAIRY,CBIRY +C +C CBINU COMPUTES THE I FUNCTION IN THE RIGHT HALF Z PLANE +C +C***ROUTINES CALLED CASYI,CBUNI,CMLRI,CSERI,CUOIK,CWRSK +C***END PROLOGUE CBINU + COMPLEX CW, CY, CZERO, Z + REAL ALIM, AZ, DFNU, ELIM, FNU, FNUL, RL, TOL + INTEGER I, INW, KODE, N, NLAST, NN, NUI, NW, NZ + DIMENSION CY(N), CW(2) + DATA CZERO / (0.0E0,0.0E0) / +C + NZ = 0 + AZ = CABS(Z) + NN = N + DFNU = FNU + FLOAT(N-1) + IF (AZ.LE.2.0E0) GO TO 10 + IF (AZ*AZ*0.25E0.GT.DFNU+1.0E0) GO TO 20 + 10 CONTINUE +C----------------------------------------------------------------------- +C POWER SERIES +C----------------------------------------------------------------------- + CALL CSERI(Z, FNU, KODE, NN, CY, 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 + FLOAT(NN-1) + 20 CONTINUE + IF (AZ.LT.RL) GO TO 40 + IF (DFNU.LE.1.0E0) GO TO 30 + IF (AZ+AZ.LT.DFNU*DFNU) GO TO 50 +C----------------------------------------------------------------------- +C ASYMPTOTIC EXPANSION FOR LARGE Z +C----------------------------------------------------------------------- + 30 CONTINUE + CALL CASYI(Z, FNU, KODE, NN, CY, NW, RL, TOL, ELIM, ALIM) + IF (NW.LT.0) GO TO 130 + GO TO 120 + 40 CONTINUE + IF (DFNU.LE.1.0E0) GO TO 70 + 50 CONTINUE +C----------------------------------------------------------------------- +C OVERFLOW AND UNDERFLOW TEST ON I SEQUENCE FOR MILLER ALGORITHM +C----------------------------------------------------------------------- + CALL CUOIK(Z, FNU, KODE, 1, NN, CY, NW, TOL, ELIM, ALIM) + IF (NW.LT.0) GO TO 130 + NZ = NZ + NW + NN = NN - NW + IF (NN.EQ.0) RETURN + DFNU = FNU+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 CMLRI(Z, FNU, KODE, NN, CY, 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 CUOIK(Z, FNU, KODE, 2, 2, CW, NW, TOL, ELIM, ALIM) + IF (NW.GE.0) GO TO 100 + NZ = NN + DO 90 I=1,NN + CY(I) = CZERO + 90 CONTINUE + RETURN + 100 CONTINUE + IF (NW.GT.0) GO TO 130 + CALL CWRSK(Z, FNU, KODE, NN, CY, NW, CW, 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(FNUL-DFNU) + 1 + NUI = MAX0(NUI,0) + CALL CBUNI(Z, FNU, KODE, NN, CY, 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
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/amos/cbiry.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,309 @@ + SUBROUTINE CBIRY(Z, ID, KODE, BI, IERR) +C***BEGIN PROLOGUE CBIRY +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 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 DEFINITIONS AND NOTATION ARE FOUND IN THE NBS HANDBOOK OF +C MATHEMATICAL FUNCTIONS (REF. 1). +C +C INPUT +C Z - Z=CMPLX(X,Y) +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 +C BI - 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 WITH 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=R1MACH(4)=UNIT ROUNDOFF. +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. +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 CBINU,I1MACH,R1MACH +C***END PROLOGUE CBIRY + COMPLEX BI, CONE, CSQ, CY, S1, S2, TRM1, TRM2, Z, ZTA, Z3 + REAL AA, AD, AK, ALIM, ATRM, AZ, AZ3, BB, BK, CK, COEF, C1, C2, + * DIG, DK, D1, D2, ELIM, FID, FMR, FNU, FNUL, PI, RL, R1M5, SFAC, + * TOL, TTH, ZI, ZR, Z3I, Z3R, R1MACH + INTEGER ID, IERR, K, KODE, K1, K2, NZ, I1MACH + DIMENSION CY(2) + DATA TTH, C1, C2, COEF, PI /6.66666666666666667E-01, + * 6.14926627446000736E-01,4.48288357353826359E-01, + * 5.77350269189625765E-01,3.14159265358979324E+00/ + DATA CONE / (1.0E0,0.0E0) / +C***FIRST EXECUTABLE STATEMENT CBIRY + 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 = CABS(Z) + TOL = AMAX1(R1MACH(4),1.0E-18) + FID = FLOAT(ID) + IF (AZ.GT.1.0E0) GO TO 60 +C----------------------------------------------------------------------- +C POWER SERIES FOR CABS(Z).LE.1. +C----------------------------------------------------------------------- + S1 = CONE + S2 = CONE + IF (AZ.LT.TOL) GO TO 110 + AA = AZ*AZ + IF (AA.LT.TOL/AZ) GO TO 40 + TRM1 = CONE + TRM2 = CONE + ATRM = 1.0E0 + Z3 = Z*Z*Z + AZ3 = AZ*AA + AK = 2.0E0 + FID + BK = 3.0E0 - FID - FID + CK = 4.0E0 - FID + DK = 3.0E0 + FID + FID + D1 = AK*DK + D2 = BK*CK + AD = AMIN1(D1,D2) + AK = 24.0E0 + 9.0E0*FID + BK = 30.0E0 - 9.0E0*FID + Z3R = REAL(Z3) + Z3I = AIMAG(Z3) + DO 30 K=1,25 + TRM1 = TRM1*CMPLX(Z3R/D1,Z3I/D1) + S1 = S1 + TRM1 + TRM2 = TRM2*CMPLX(Z3R/D2,Z3I/D2) + S2 = S2 + TRM2 + ATRM = ATRM*AZ3/AD + D1 = D1 + AK + D2 = D2 + BK + AD = AMIN1(D1,D2) + IF (ATRM.LT.TOL*AD) GO TO 40 + AK = AK + 18.0E0 + BK = BK + 18.0E0 + 30 CONTINUE + 40 CONTINUE + IF (ID.EQ.1) GO TO 50 + BI = S1*CMPLX(C1,0.0E0) + Z*S2*CMPLX(C2,0.0E0) + IF (KODE.EQ.1) RETURN + ZTA = Z*CSQRT(Z)*CMPLX(TTH,0.0E0) + AA = REAL(ZTA) + AA = -ABS(AA) + BI = BI*CMPLX(EXP(AA),0.0E0) + RETURN + 50 CONTINUE + BI = S2*CMPLX(C2,0.0E0) + IF (AZ.GT.TOL) BI = BI + Z*Z*S1*CMPLX(C1/(1.0E0+FID),0.0E0) + IF (KODE.EQ.1) RETURN + ZTA = Z*CSQRT(Z)*CMPLX(TTH,0.0E0) + AA = REAL(ZTA) + AA = -ABS(AA) + BI = BI*CMPLX(EXP(AA),0.0E0) + RETURN +C----------------------------------------------------------------------- +C CASE FOR CABS(Z).GT.1.0 +C----------------------------------------------------------------------- + 60 CONTINUE + FNU = (1.0E0+FID)/3.0E0 +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(12) + K2 = I1MACH(13) + R1M5 = R1MACH(5) + K = MIN0(IABS(K1),IABS(K2)) + ELIM = 2.303E0*(FLOAT(K)*R1M5-3.0E0) + K1 = I1MACH(11) - 1 + AA = R1M5*FLOAT(K1) + DIG = AMIN1(AA,18.0E0) + AA = AA*2.303E0 + ALIM = ELIM + AMAX1(-AA,-41.45E0) + RL = 1.2E0*DIG + 3.0E0 + FNUL = 10.0E0 + 6.0E0*(DIG-3.0E0) +C----------------------------------------------------------------------- +C TEST FOR RANGE +C----------------------------------------------------------------------- + AA=0.5E0/TOL + BB=FLOAT(I1MACH(9))*0.5E0 + AA=AMIN1(AA,BB) + AA=AA**TTH + IF (AZ.GT.AA) GO TO 190 + AA=SQRT(AA) + IF (AZ.GT.AA) IERR=3 + CSQ=CSQRT(Z) + ZTA=Z*CSQ*CMPLX(TTH,0.0E0) +C----------------------------------------------------------------------- +C RE(ZTA).LE.0 WHEN RE(Z).LT.0, ESPECIALLY WHEN IM(Z) IS SMALL +C----------------------------------------------------------------------- + SFAC = 1.0E0 + ZI = AIMAG(Z) + ZR = REAL(Z) + AK = AIMAG(ZTA) + IF (ZR.GE.0.0E0) GO TO 70 + BK = REAL(ZTA) + CK = -ABS(BK) + ZTA = CMPLX(CK,AK) + 70 CONTINUE + IF (ZI.EQ.0.0E0 .AND. ZR.LE.0.0E0) ZTA = CMPLX(0.0E0,AK) + AA = REAL(ZTA) + IF (KODE.EQ.2) GO TO 80 +C----------------------------------------------------------------------- +C OVERFLOW TEST +C----------------------------------------------------------------------- + BB = ABS(AA) + IF (BB.LT.ALIM) GO TO 80 + BB = BB + 0.25E0*ALOG(AZ) + SFAC = TOL + IF (BB.GT.ELIM) GO TO 170 + 80 CONTINUE + FMR = 0.0E0 + IF (AA.GE.0.0E0 .AND. ZR.GT.0.0E0) GO TO 90 + FMR = PI + IF (ZI.LT.0.0E0) FMR = -PI + ZTA = -ZTA + 90 CONTINUE +C----------------------------------------------------------------------- +C AA=FACTOR FOR ANALYTIC CONTINUATION OF I(FNU,ZTA) +C KODE=2 RETURNS EXP(-ABS(XZTA))*I(FNU,ZTA) FROM CBINU +C----------------------------------------------------------------------- + CALL CBINU(ZTA, FNU, KODE, 1, CY, NZ, RL, FNUL, TOL, ELIM, ALIM) + IF (NZ.LT.0) GO TO 180 + AA = FMR*FNU + Z3 = CMPLX(SFAC,0.0E0) + S1 = CY(1)*CMPLX(COS(AA),SIN(AA))*Z3 + FNU = (2.0E0-FID)/3.0E0 + CALL CBINU(ZTA, FNU, KODE, 2, CY, NZ, RL, FNUL, TOL, ELIM, ALIM) + CY(1) = CY(1)*Z3 + CY(2) = CY(2)*Z3 +C----------------------------------------------------------------------- +C BACKWARD RECUR ONE STEP FOR ORDERS -1/3 OR -2/3 +C----------------------------------------------------------------------- + S2 = CY(1)*CMPLX(FNU+FNU,0.0E0)/ZTA + CY(2) + AA = FMR*(FNU-1.0E0) + S1 = (S1+S2*CMPLX(COS(AA),SIN(AA)))*CMPLX(COEF,0.0E0) + IF (ID.EQ.1) GO TO 100 + S1 = CSQ*S1 + BI = S1*CMPLX(1.0E0/SFAC,0.0E0) + RETURN + 100 CONTINUE + S1 = Z*S1 + BI = S1*CMPLX(1.0E0/SFAC,0.0E0) + RETURN + 110 CONTINUE + AA = C1*(1.0E0-FID) + FID*C2 + BI = CMPLX(AA,0.0E0) + RETURN + 170 CONTINUE + NZ=0 + IERR=2 + RETURN + 180 CONTINUE + IF(NZ.EQ.(-1)) GO TO 170 + NZ=0 + IERR=5 + RETURN + 190 CONTINUE + IERR=4 + NZ=0 + RETURN + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/amos/cbknu.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,455 @@ + SUBROUTINE CBKNU(Z, FNU, KODE, N, Y, NZ, TOL, ELIM, ALIM) +C***BEGIN PROLOGUE CBKNU +C***REFER TO CBESI,CBESK,CAIRY,CBESH +C +C CBKNU COMPUTES THE K BESSEL FUNCTION IN THE RIGHT HALF Z PLANE +C +C***ROUTINES CALLED CKSCL,CSHCH,GAMLN,I1MACH,R1MACH,CUCHK +C***END PROLOGUE CBKNU +C + COMPLEX CCH, CK, COEF, CONE, CRSC, CS, CSCL, CSH, CSR, CSS, CTWO, + * CZ, CZERO, F, FMU, P, PT, P1, P2, Q, RZ, SMU, ST, S1, S2, Y, Z, + * ZD, CELM, CY + REAL AA, AK, ALIM, ASCLE, A1, A2, BB, BK, BRY, CAZ, CC, DNU, + * DNU2, ELIM, ETEST, FC, FHS, FK, FKS, FNU, FPI, G1, G2, HPI, PI, + * P2I, P2M, P2R, RK, RTHPI, R1, S, SPI, TM, TOL, TTH, T1, T2, XX, + * YY, GAMLN, R1MACH, HELIM, ELM, XD, YD, ALAS, AS + INTEGER I, IDUM, IFLAG, INU, K, KFLAG, KK, KMAX, KODE, KODED, N, + * NZ, I1MACH, NW, J, IC, INUB + DIMENSION BRY(3), CC(8), CSS(3), CSR(3), Y(N), CY(2) +C + DATA KMAX / 30 / + DATA R1 / 2.0E0 / + DATA CZERO,CONE,CTWO /(0.0E0,0.0E0),(1.0E0,0.0E0),(2.0E0,0.0E0)/ +C + DATA PI, RTHPI, SPI ,HPI, FPI, TTH / + 1 3.14159265358979324E0, 1.25331413731550025E0, + 2 1.90985931710274403E0, 1.57079632679489662E0, + 3 1.89769999331517738E0, 6.66666666666666666E-01/ +C + DATA CC(1), CC(2), CC(3), CC(4), CC(5), CC(6), CC(7), CC(8)/ + 1 5.77215664901532861E-01, -4.20026350340952355E-02, + 2 -4.21977345555443367E-02, 7.21894324666309954E-03, + 3 -2.15241674114950973E-04, -2.01348547807882387E-05, + 4 1.13302723198169588E-06, 6.11609510448141582E-09/ +C + XX = REAL(Z) + YY = AIMAG(Z) + CAZ = CABS(Z) + CSCL = CMPLX(1.0E0/TOL,0.0E0) + CRSC = CMPLX(TOL,0.0E0) + CSS(1) = CSCL + CSS(2) = CONE + CSS(3) = CRSC + CSR(1) = CRSC + CSR(2) = CONE + CSR(3) = CSCL + BRY(1) = 1.0E+3*R1MACH(1)/TOL + BRY(2) = 1.0E0/BRY(1) + BRY(3) = R1MACH(2) + NZ = 0 + IFLAG = 0 + KODED = KODE + RZ = CTWO/Z + INU = INT(FNU+0.5E0) + DNU = FNU - FLOAT(INU) + IF (ABS(DNU).EQ.0.5E0) GO TO 110 + DNU2 = 0.0E0 + IF (ABS(DNU).GT.TOL) DNU2 = DNU*DNU + IF (CAZ.GT.R1) GO TO 110 +C----------------------------------------------------------------------- +C SERIES FOR CABS(Z).LE.R1 +C----------------------------------------------------------------------- + FC = 1.0E0 + SMU = CLOG(RZ) + FMU = SMU*CMPLX(DNU,0.0E0) + CALL CSHCH(FMU, CSH, CCH) + IF (DNU.EQ.0.0E0) GO TO 10 + FC = DNU*PI + FC = FC/SIN(FC) + SMU = CSH*CMPLX(1.0E0/DNU,0.0E0) + 10 CONTINUE + A2 = 1.0E0 + 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 = EXP(-GAMLN(A2,IDUM)) + T1 = 1.0E0/(T2*FC) + IF (ABS(DNU).GT.0.1E0) GO TO 40 +C----------------------------------------------------------------------- +C SERIES FOR F0 TO RESOLVE INDETERMINACY FOR SMALL ABS(DNU) +C----------------------------------------------------------------------- + AK = 1.0E0 + S = CC(1) + DO 20 K=2,8 + AK = AK*DNU2 + TM = CC(K)*AK + S = S + TM + IF (ABS(TM).LT.TOL) GO TO 30 + 20 CONTINUE + 30 G1 = -S + GO TO 50 + 40 CONTINUE + G1 = (T1-T2)/(DNU+DNU) + 50 CONTINUE + G2 = 0.5E0*(T1+T2)*FC + G1 = G1*FC + F = CMPLX(G1,0.0E0)*CCH + SMU*CMPLX(G2,0.0E0) + PT = CEXP(FMU) + P = CMPLX(0.5E0/T2,0.0E0)*PT + Q = CMPLX(0.5E0/T1,0.0E0)/PT + S1 = F + S2 = P + AK = 1.0E0 + A1 = 1.0E0 + CK = CONE + BK = 1.0E0 - 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 + CZ = Z*Z*CMPLX(0.25E0,0.0E0) + T1 = 0.25E0*CAZ*CAZ + 60 CONTINUE + F = (F*CMPLX(AK,0.0E0)+P+Q)*CMPLX(1.0E0/BK,0.0E0) + P = P*CMPLX(1.0E0/(AK-DNU),0.0E0) + Q = Q*CMPLX(1.0E0/(AK+DNU),0.0E0) + RK = 1.0E0/AK + CK = CK*CZ*CMPLX(RK,0.0) + S1 = S1 + CK*F + A1 = A1*T1*RK + BK = BK + AK + AK + 1.0E0 + AK = AK + 1.0E0 + IF (A1.GT.TOL) GO TO 60 + 70 CONTINUE + Y(1) = S1 + IF (KODED.EQ.1) RETURN + Y(1) = S1*CEXP(Z) + 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 + CZ = Z*Z*CMPLX(0.25E0,0.0E0) + T1 = 0.25E0*CAZ*CAZ + 90 CONTINUE + F = (F*CMPLX(AK,0.0E0)+P+Q)*CMPLX(1.0E0/BK,0.0E0) + P = P*CMPLX(1.0E0/(AK-DNU),0.0E0) + Q = Q*CMPLX(1.0E0/(AK+DNU),0.0E0) + RK = 1.0E0/AK + CK = CK*CZ*CMPLX(RK,0.0E0) + S1 = S1 + CK*F + S2 = S2 + CK*(P-F*CMPLX(AK,0.0E0)) + A1 = A1*T1*RK + BK = BK + AK + AK + 1.0E0 + AK = AK + 1.0E0 + IF (A1.GT.TOL) GO TO 90 + 100 CONTINUE + KFLAG = 2 + BK = REAL(SMU) + A1 = FNU + 1.0E0 + AK = A1*ABS(BK) + IF (AK.GT.ALIM) KFLAG = 3 + P2 = S2*CSS(KFLAG) + S2 = P2*RZ + S1 = S1*CSS(KFLAG) + IF (KODED.EQ.1) GO TO 210 + F = CEXP(Z) + S1 = S1*F + S2 = S2*F + 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 + COEF = CMPLX(RTHPI,0.0E0)/CSQRT(Z) + KFLAG = 2 + IF (KODED.EQ.2) GO TO 120 + IF (XX.GT.ALIM) GO TO 290 +C BLANK LINE + A1 = EXP(-XX)*REAL(CSS(KFLAG)) + PT = CMPLX(A1,0.0E0)*CMPLX(COS(YY),-SIN(YY)) + COEF = COEF*PT + 120 CONTINUE + IF (ABS(DNU).EQ.0.5E0) GO TO 300 +C----------------------------------------------------------------------- +C MILLER ALGORITHM FOR CABS(Z).GT.R1 +C----------------------------------------------------------------------- + AK = COS(PI*DNU) + AK = ABS(AK) + IF (AK.EQ.0.0E0) GO TO 300 + FHS = ABS(0.25E0-DNU2) + IF (FHS.EQ.0.0E0) 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(11))= +C TOL WHERE B IS THE BASE OF THE ARITHMETIC. +C----------------------------------------------------------------------- + T1 = FLOAT(I1MACH(11)-1)*R1MACH(5)*3.321928094E0 + T1 = AMAX1(T1,12.0E0) + T1 = AMIN1(T1,60.0E0) + T2 = TTH*T1 - 6.0E0 + IF (XX.NE.0.0E0) GO TO 130 + T1 = HPI + GO TO 140 + 130 CONTINUE + T1 = ATAN(YY/XX) + T1 = ABS(T1) + 140 CONTINUE + IF (T2.GT.CAZ) GO TO 170 +C----------------------------------------------------------------------- +C FORWARD RECURRENCE LOOP WHEN CABS(Z).GE.R2 +C----------------------------------------------------------------------- + ETEST = AK/(PI*CAZ*TOL) + FK = 1.0E0 + IF (ETEST.LT.1.0E0) GO TO 180 + FKS = 2.0E0 + RK = CAZ + CAZ + 2.0E0 + A1 = 0.0E0 + A2 = 1.0E0 + DO 150 I=1,KMAX + AK = FHS/FKS + BK = RK/(FK+1.0E0) + TM = A2 + A2 = BK*A2 - AK*A1 + A1 = TM + RK = RK + 2.0E0 + FKS = FKS + FK + FK + 2.0E0 + FHS = FHS + FK + FK + FK = FK + 1.0E0 + TM = ABS(A2)*FK + IF (ETEST.LT.TM) GO TO 160 + 150 CONTINUE + GO TO 310 + 160 CONTINUE + FK = FK + SPI*T1*SQRT(T2/CAZ) + FHS = ABS(0.25E0-DNU2) + GO TO 180 + 170 CONTINUE +C----------------------------------------------------------------------- +C COMPUTE BACKWARD INDEX K FOR CABS(Z).LT.R2 +C----------------------------------------------------------------------- + A2 = SQRT(CAZ) + AK = FPI*AK/(TOL*SQRT(A2)) + AA = 3.0E0*T1/(1.0E0+CAZ) + BB = 14.7E0*T1/(28.0E0+CAZ) + AK = (ALOG(AK)+CAZ*COS(AA)/(1.0E0+0.008E0*CAZ))/COS(BB) + FK = 0.12125E0*AK*AK/CAZ + 1.5E0 + 180 CONTINUE + K = INT(FK) +C----------------------------------------------------------------------- +C BACKWARD RECURRENCE LOOP FOR MILLER ALGORITHM +C----------------------------------------------------------------------- + FK = FLOAT(K) + FKS = FK*FK + P1 = CZERO + P2 = CMPLX(TOL,0.0E0) + CS = P2 + DO 190 I=1,K + A1 = FKS - FK + A2 = (FKS+FK)/(A1+FHS) + RK = 2.0E0/(FK+1.0E0) + T1 = (FK+XX)*RK + T2 = YY*RK + PT = P2 + P2 = (P2*CMPLX(T1,T2)-P1)*CMPLX(A2,0.0E0) + P1 = PT + CS = CS + P2 + FKS = A1 - FK + 1.0E0 + FK = FK - 1.0E0 + 190 CONTINUE +C----------------------------------------------------------------------- +C COMPUTE (P2/CS)=(P2/CABS(CS))*(CONJG(CS)/CABS(CS)) FOR BETTER +C SCALING +C----------------------------------------------------------------------- + TM = CABS(CS) + PT = CMPLX(1.0E0/TM,0.0E0) + S1 = PT*P2 + CS = CONJG(CS)*PT + S1 = COEF*S1*CS + IF (INU.GT.0 .OR. N.GT.1) GO TO 200 + ZD = Z + 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 = CABS(P2) + PT = CMPLX(1.0E0/TM,0.0E0) + P1 = PT*P1 + P2 = CONJG(P2)*PT + PT = P1*P2 + S2 = S1*(CONE+(CMPLX(DNU+0.5E0,0.0E0)-PT)/Z) +C----------------------------------------------------------------------- +C FORWARD RECURSION ON THE THREE TERM RECURSION RELATION WITH +C SCALING NEAR EXPONENT EXTREMES ON KFLAG=1 OR KFLAG=3 +C----------------------------------------------------------------------- + 210 CONTINUE + CK = CMPLX(DNU+1.0E0,0.0E0)*RZ + IF (N.EQ.1) INU = INU - 1 + IF (INU.GT.0) GO TO 220 + IF (N.EQ.1) S1=S2 + ZD = Z + IF(IFLAG.EQ.1) GO TO 270 + GO TO 240 + 220 CONTINUE + INUB = 1 + IF (IFLAG.EQ.1) GO TO 261 + 225 CONTINUE + P1 = CSR(KFLAG) + ASCLE = BRY(KFLAG) + DO 230 I=INUB,INU + ST = S2 + S2 = CK*S2 + S1 + S1 = ST + CK = CK + RZ + IF (KFLAG.GE.3) GO TO 230 + P2 = S2*P1 + P2R = REAL(P2) + P2I = AIMAG(P2) + P2R = ABS(P2R) + P2I = ABS(P2I) + P2M = AMAX1(P2R,P2I) + IF (P2M.LE.ASCLE) GO TO 230 + KFLAG = KFLAG + 1 + ASCLE = BRY(KFLAG) + S1 = S1*P1 + S2 = P2 + S1 = S1*CSS(KFLAG) + S2 = S2*CSS(KFLAG) + P1 = CSR(KFLAG) + 230 CONTINUE + IF (N.EQ.1) S1 = S2 + 240 CONTINUE + Y(1) = S1*CSR(KFLAG) + IF (N.EQ.1) RETURN + Y(2) = S2*CSR(KFLAG) + IF (N.EQ.2) RETURN + KK = 2 + 250 CONTINUE + KK = KK + 1 + IF (KK.GT.N) RETURN + P1 = CSR(KFLAG) + ASCLE = BRY(KFLAG) + DO 260 I=KK,N + P2 = S2 + S2 = CK*S2 + S1 + S1 = P2 + CK = CK + RZ + P2 = S2*P1 + Y(I) = P2 + IF (KFLAG.GE.3) GO TO 260 + P2R = REAL(P2) + P2I = AIMAG(P2) + P2R = ABS(P2R) + P2I = ABS(P2I) + P2M = AMAX1(P2R,P2I) + IF (P2M.LE.ASCLE) GO TO 260 + KFLAG = KFLAG + 1 + ASCLE = BRY(KFLAG) + S1 = S1*P1 + S2 = P2 + S1 = S1*CSS(KFLAG) + S2 = S2*CSS(KFLAG) + P1 = CSR(KFLAG) + 260 CONTINUE + RETURN +C----------------------------------------------------------------------- +C IFLAG=1 CASES, FORWARD RECURRENCE ON SCALED VALUES ON UNDERFLOW +C----------------------------------------------------------------------- + 261 CONTINUE + HELIM = 0.5E0*ELIM + ELM = EXP(-ELIM) + CELM = CMPLX(ELM,0.0) + ASCLE = BRY(1) + ZD = Z + XD = XX + YD = YY + IC = -1 + J = 2 + DO 262 I=1,INU + ST = S2 + S2 = CK*S2+S1 + S1 = ST + CK = CK+RZ + AS = CABS(S2) + ALAS = ALOG(AS) + P2R = -XD+ALAS + IF(P2R.LT.(-ELIM)) GO TO 263 + P2 = -ZD+CLOG(S2) + P2R = REAL(P2) + P2I = AIMAG(P2) + P2M = EXP(P2R)/TOL + P1 = CMPLX(P2M,0.0E0)*CMPLX(COS(P2I),SIN(P2I)) + CALL CUCHK(P1,NW,ASCLE,TOL) + IF(NW.NE.0) GO TO 263 + J=3-J + CY(J) = P1 + IF(IC.EQ.(I-1)) GO TO 264 + IC = I + GO TO 262 + 263 CONTINUE + IF(ALAS.LT.HELIM) GO TO 262 + XD = XD-ELIM + S1 = S1*CELM + S2 = S2*CELM + ZD = CMPLX(XD,YD) + 262 CONTINUE + IF(N.EQ.1) S1 = S2 + GO TO 270 + 264 CONTINUE + KFLAG = 1 + INUB = I+1 + S2 = CY(J) + J = 3 - J + S1 = CY(J) + IF(INUB.LE.INU) GO TO 225 + IF(N.EQ.1) S1 = S2 + GO TO 240 + 270 CONTINUE + Y(1) = S1 + IF (N.EQ.1) GO TO 280 + Y(2) = S2 + 280 CONTINUE + ASCLE = BRY(1) + CALL CKSCL(ZD, FNU, N, Y, NZ, RZ, ASCLE, TOL, ELIM) + INU = N - NZ + IF (INU.LE.0) RETURN + KK = NZ + 1 + S1 = Y(KK) + Y(KK) = S1*CSR(1) + IF (INU.EQ.1) RETURN + KK = NZ + 2 + S2 = Y(KK) + Y(KK) = S2*CSR(1) + IF (INU.EQ.2) RETURN + T2 = FNU + FLOAT(KK-1) + CK = CMPLX(T2,0.0E0)*RZ + KFLAG = 1 + GO TO 250 + 290 CONTINUE +C----------------------------------------------------------------------- +C SCALE BY EXP(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 + S1 = COEF + S2 = COEF + GO TO 210 + 310 CONTINUE + NZ=-2 + RETURN + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/amos/cbuni.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,158 @@ + SUBROUTINE CBUNI(Z, FNU, KODE, N, Y, NZ, NUI, NLAST, FNUL, TOL, + * ELIM, ALIM) +C***BEGIN PROLOGUE CBUNI +C***REFER TO CBESI,CBESK +C +C CBUNI 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 CUNI1,CUNI2,R1MACH +C***END PROLOGUE CBUNI + COMPLEX CSCL, CSCR, CY, RZ, ST, S1, S2, Y, Z + REAL ALIM, AX, AY, DFNU, ELIM, FNU, FNUI, FNUL, GNU, TOL, XX, YY, + * ASCLE, BRY, STR, STI, STM, R1MACH + INTEGER I, IFLAG, IFORM, K, KODE, N, NL, NLAST, NUI, NW, NZ + DIMENSION Y(N), CY(2), BRY(3) + NZ = 0 + XX = REAL(Z) + YY = AIMAG(Z) + AX = ABS(XX)*1.7321E0 + AY = ABS(YY) + IFORM = 1 + IF (AY.GT.AX) IFORM = 2 + IF (NUI.EQ.0) GO TO 60 + FNUI = FLOAT(NUI) + DFNU = FNU + 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 CUNI1(Z, GNU, KODE, 2, CY, 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 CUNI2(Z, GNU, KODE, 2, CY, NW, NLAST, FNUL, TOL, ELIM, ALIM) + 20 CONTINUE + IF (NW.LT.0) GO TO 50 + IF (NW.NE.0) GO TO 90 + AY = CABS(CY(1)) +C---------------------------------------------------------------------- +C SCALE BACKWARD RECURRENCE, BRY(3) IS DEFINED BUT NEVER USED +C---------------------------------------------------------------------- + BRY(1) = 1.0E+3*R1MACH(1)/TOL + BRY(2) = 1.0E0/BRY(1) + BRY(3) = BRY(2) + IFLAG = 2 + ASCLE = BRY(2) + AX = 1.0E0 + CSCL = CMPLX(AX,0.0E0) + IF (AY.GT.BRY(1)) GO TO 21 + IFLAG = 1 + ASCLE = BRY(1) + AX = 1.0E0/TOL + CSCL = CMPLX(AX,0.0E0) + GO TO 25 + 21 CONTINUE + IF (AY.LT.BRY(2)) GO TO 25 + IFLAG = 3 + ASCLE = BRY(3) + AX = TOL + CSCL = CMPLX(AX,0.0E0) + 25 CONTINUE + AY = 1.0E0/AX + CSCR = CMPLX(AY,0.0E0) + S1 = CY(2)*CSCL + S2 = CY(1)*CSCL + RZ = CMPLX(2.0E0,0.0E0)/Z + DO 30 I=1,NUI + ST = S2 + S2 = CMPLX(DFNU+FNUI,0.0E0)*RZ*S2 + S1 + S1 = ST + FNUI = FNUI - 1.0E0 + IF (IFLAG.GE.3) GO TO 30 + ST = S2*CSCR + STR = REAL(ST) + STI = AIMAG(ST) + STR = ABS(STR) + STI = ABS(STI) + STM = AMAX1(STR,STI) + IF (STM.LE.ASCLE) GO TO 30 + IFLAG = IFLAG+1 + ASCLE = BRY(IFLAG) + S1 = S1*CSCR + S2 = ST + AX = AX*TOL + AY = 1.0E0/AX + CSCL = CMPLX(AX,0.0E0) + CSCR = CMPLX(AY,0.0E0) + S1 = S1*CSCL + S2 = S2*CSCL + 30 CONTINUE + Y(N) = S2*CSCR + IF (N.EQ.1) RETURN + NL = N - 1 + FNUI = FLOAT(NL) + K = NL + DO 40 I=1,NL + ST = S2 + S2 = CMPLX(FNU+FNUI,0.0E0)*RZ*S2 + S1 + S1 = ST + ST = S2*CSCR + Y(K) = ST + FNUI = FNUI - 1.0E0 + K = K - 1 + IF (IFLAG.GE.3) GO TO 40 + STR = REAL(ST) + STI = AIMAG(ST) + STR = ABS(STR) + STI = ABS(STI) + STM = AMAX1(STR,STI) + IF (STM.LE.ASCLE) GO TO 40 + IFLAG = IFLAG+1 + ASCLE = BRY(IFLAG) + S1 = S1*CSCR + S2 = ST + AX = AX*TOL + AY = 1.0E0/AX + CSCL = CMPLX(AX,0.0E0) + CSCR = CMPLX(AY,0.0E0) + S1 = S1*CSCL + S2 = S2*CSCL + 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 CUNI1(Z, FNU, KODE, N, Y, 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 CUNI2(Z, FNU, KODE, N, Y, NW, NLAST, FNUL, TOL, ELIM, ALIM) + 80 CONTINUE + IF (NW.LT.0) GO TO 50 + NZ = NW + RETURN + 90 CONTINUE + NLAST = N + RETURN + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/amos/cbunk.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,36 @@ + SUBROUTINE CBUNK(Z, FNU, KODE, MR, N, Y, NZ, TOL, ELIM, ALIM) +C***BEGIN PROLOGUE CBUNK +C***REFER TO CBESK,CBESH +C +C CBUNK COMPUTES THE K BESSEL FUNCTION FOR FNU.GT.FNUL. +C ACCORDING TO THE UNIFORM ASYMPTOTIC EXPANSION FOR K(FNU,Z) +C IN CUNK1 AND THE EXPANSION FOR H(2,FNU,Z) IN CUNK2 +C +C***ROUTINES CALLED CUNK1,CUNK2 +C***END PROLOGUE CBUNK + COMPLEX Y, Z + REAL ALIM, AX, AY, ELIM, FNU, TOL, XX, YY + INTEGER KODE, MR, N, NZ + DIMENSION Y(N) + NZ = 0 + XX = REAL(Z) + YY = AIMAG(Z) + AX = ABS(XX)*1.7321E0 + AY = ABS(YY) + 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 CUNK1(Z, FNU, KODE, MR, N, Y, 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 CUNK2(Z, FNU, KODE, MR, N, Y, NZ, TOL, ELIM, ALIM) + 20 CONTINUE + RETURN + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/amos/ckscl.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,102 @@ + SUBROUTINE CKSCL(ZR, FNU, N, Y, NZ, RZ, ASCLE, TOL, ELIM) +C***BEGIN PROLOGUE CKSCL +C***REFER TO CBKNU,CUNK1,CUNK2 +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 CUCHK +C***END PROLOGUE CKSCL + COMPLEX CK, CS, CY, CZERO, RZ, S1, S2, Y, ZR, ZD, CELM + REAL AA, ASCLE, ACS, AS, CSI, CSR, ELIM, FN, FNU, TOL, XX, ZRI, + * ELM, ALAS, HELIM + INTEGER I, IC, K, KK, N, NN, NW, NZ + DIMENSION Y(N), CY(2) + DATA CZERO / (0.0E0,0.0E0) / +C + NZ = 0 + IC = 0 + XX = REAL(ZR) + NN = MIN0(2,N) + DO 10 I=1,NN + S1 = Y(I) + CY(I) = S1 + AS = CABS(S1) + ACS = -XX + ALOG(AS) + NZ = NZ + 1 + Y(I) = CZERO + IF (ACS.LT.(-ELIM)) GO TO 10 + CS = -ZR + CLOG(S1) + CSR = REAL(CS) + CSI = AIMAG(CS) + AA = EXP(CSR)/TOL + CS = CMPLX(AA,0.0E0)*CMPLX(COS(CSI),SIN(CSI)) + CALL CUCHK(CS, NW, ASCLE, TOL) + IF (NW.NE.0) GO TO 10 + Y(I) = CS + NZ = NZ - 1 + IC = I + 10 CONTINUE + IF (N.EQ.1) RETURN + IF (IC.GT.1) GO TO 20 + Y(1) = CZERO + NZ = 2 + 20 CONTINUE + IF (N.EQ.2) RETURN + IF (NZ.EQ.0) RETURN + FN = FNU + 1.0E0 + CK = CMPLX(FN,0.0E0)*RZ + S1 = CY(1) + S2 = CY(2) + HELIM = 0.5E0*ELIM + ELM = EXP(-ELIM) + CELM = CMPLX(ELM,0.0E0) + ZRI =AIMAG(ZR) + ZD = ZR +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 + CS = S2 + S2 = CK*S2 + S1 + S1 = CS + CK = CK + RZ + AS = CABS(S2) + ALAS = ALOG(AS) + ACS = -XX + ALAS + NZ = NZ + 1 + Y(I) = CZERO + IF (ACS.LT.(-ELIM)) GO TO 25 + CS = -ZD + CLOG(S2) + CSR = REAL(CS) + CSI = AIMAG(CS) + AA = EXP(CSR)/TOL + CS = CMPLX(AA,0.0E0)*CMPLX(COS(CSI),SIN(CSI)) + CALL CUCHK(CS, NW, ASCLE, TOL) + IF (NW.NE.0) GO TO 25 + Y(I) = CS + 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 + XX = XX-ELIM + S1 = S1*CELM + S2 = S2*CELM + ZD = CMPLX(XX,ZRI) + 30 CONTINUE + NZ = N + IF(IC.EQ.N) NZ=N-1 + GO TO 45 + 40 CONTINUE + NZ = KK - 2 + 45 CONTINUE + DO 50 K=1,NZ + Y(K) = CZERO + 50 CONTINUE + RETURN + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/amos/cmlri.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,155 @@ + SUBROUTINE CMLRI(Z, FNU, KODE, N, Y, NZ, TOL) +C***BEGIN PROLOGUE CMLRI +C***REFER TO CBESI,CBESK +C +C CMLRI 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 GAMLN,R1MACH +C***END PROLOGUE CMLRI + COMPLEX CK, CNORM, CONE, CTWO, CZERO, PT, P1, P2, RZ, SUM, Y, Z + REAL ACK, AK, AP, AT, AZ, BK, FKAP, FKK, FLAM, FNF, FNU, RHO, + * RHO2, SCLE, TFNF, TOL, TST, X, GAMLN, R1MACH + INTEGER I, IAZ, IDUM, IFNU, INU, ITIME, K, KK, KM, KODE, M, N + DIMENSION Y(N) + DATA CZERO,CONE,CTWO /(0.0E0,0.0E0),(1.0E0,0.0E0),(2.0E0,0.0E0)/ + SCLE = 1.0E+3*R1MACH(1)/TOL + NZ=0 + AZ = CABS(Z) + X = REAL(Z) + IAZ = INT(AZ) + IFNU = INT(FNU) + INU = IFNU + N - 1 + AT = FLOAT(IAZ) + 1.0E0 + CK = CMPLX(AT,0.0E0)/Z + RZ = CTWO/Z + P1 = CZERO + P2 = CONE + ACK = (AT+1.0E0)/AZ + RHO = ACK + SQRT(ACK*ACK-1.0E0) + RHO2 = RHO*RHO + TST = (RHO2+RHO2)/((RHO2-1.0E0)*(RHO-1.0E0)) + TST = TST/TOL +C----------------------------------------------------------------------- +C COMPUTE RELATIVE TRUNCATION ERROR INDEX FOR SERIES +C----------------------------------------------------------------------- + AK = AT + DO 10 I=1,80 + PT = P2 + P2 = P1 - CK*P2 + P1 = PT + CK = CK + RZ + AP = CABS(P2) + IF (AP.GT.TST*AK*AK) GO TO 20 + AK = AK + 1.0E0 + 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----------------------------------------------------------------------- + P1 = CZERO + P2 = CONE + AT = FLOAT(INU) + 1.0E0 + CK = CMPLX(AT,0.0E0)/Z + ACK = AT/AZ + TST = SQRT(ACK/TOL) + ITIME = 1 + DO 30 K=1,80 + PT = P2 + P2 = P1 - CK*P2 + P1 = PT + CK = CK + RZ + AP = CABS(P2) + IF (AP.LT.TST) GO TO 30 + IF (ITIME.EQ.2) GO TO 40 + ACK = CABS(CK) + FLAM = ACK + SQRT(ACK*ACK-1.0E0) + FKAP = AP/CABS(P1) + RHO = AMIN1(FLAM,FKAP) + TST = TST*SQRT(RHO/(RHO*RHO-1.0E0)) + 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 = FLOAT(KK) + P1 = CZERO +C----------------------------------------------------------------------- +C SCALE P2 AND SUM BY SCLE +C----------------------------------------------------------------------- + P2 = CMPLX(SCLE,0.0E0) + FNF = FNU - FLOAT(IFNU) + TFNF = FNF + FNF + BK = GAMLN(FKK+TFNF+1.0E0,IDUM) - GAMLN(FKK+1.0E0,IDUM) + * -GAMLN(TFNF+1.0E0,IDUM) + BK = EXP(BK) + SUM = CZERO + KM = KK - INU + DO 50 I=1,KM + PT = P2 + P2 = P1 + CMPLX(FKK+FNF,0.0E0)*RZ*P2 + P1 = PT + AK = 1.0E0 - TFNF/(FKK+TFNF) + ACK = BK*AK + SUM = SUM + CMPLX(ACK+BK,0.0E0)*P1 + BK = ACK + FKK = FKK - 1.0E0 + 50 CONTINUE + Y(N) = P2 + IF (N.EQ.1) GO TO 70 + DO 60 I=2,N + PT = P2 + P2 = P1 + CMPLX(FKK+FNF,0.0E0)*RZ*P2 + P1 = PT + AK = 1.0E0 - TFNF/(FKK+TFNF) + ACK = BK*AK + SUM = SUM + CMPLX(ACK+BK,0.0E0)*P1 + BK = ACK + FKK = FKK - 1.0E0 + M = N - I + 1 + Y(M) = P2 + 60 CONTINUE + 70 CONTINUE + IF (IFNU.LE.0) GO TO 90 + DO 80 I=1,IFNU + PT = P2 + P2 = P1 + CMPLX(FKK+FNF,0.0E0)*RZ*P2 + P1 = PT + AK = 1.0E0 - TFNF/(FKK+TFNF) + ACK = BK*AK + SUM = SUM + CMPLX(ACK+BK,0.0E0)*P1 + BK = ACK + FKK = FKK - 1.0E0 + 80 CONTINUE + 90 CONTINUE + PT = Z + IF (KODE.EQ.2) PT = PT - CMPLX(X,0.0E0) + P1 = -CMPLX(FNF,0.0E0)*CLOG(RZ) + PT + AP = GAMLN(1.0E0+FNF,IDUM) + PT = P1 - CMPLX(AP,0.0E0) +C----------------------------------------------------------------------- +C THE DIVISION CEXP(PT)/(SUM+P2) IS ALTERED TO AVOID OVERFLOW +C IN THE DENOMINATOR BY SQUARING LARGE QUANTITIES +C----------------------------------------------------------------------- + P2 = P2 + SUM + AP = CABS(P2) + P1 = CMPLX(1.0E0/AP,0.0E0) + CK = CEXP(PT)*P1 + PT = CONJG(P2)*P1 + CNORM = CK*PT + DO 100 I=1,N + Y(I) = Y(I)*CNORM + 100 CONTINUE + RETURN + 110 CONTINUE + NZ=-2 + RETURN + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/amos/crati.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,100 @@ + SUBROUTINE CRATI(Z, FNU, N, CY, TOL) +C***BEGIN PROLOGUE CRATI +C***REFER TO CBESI,CBESK,CBESH +C +C CRATI 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 (NONE) +C***END PROLOGUE CRATI + COMPLEX CDFNU, CONE, CY, CZERO, PT, P1, P2, RZ, T1, Z + REAL AK, AMAGZ, AP1, AP2, ARG, AZ, DFNU, FDNU, FLAM, FNU, FNUP, + * RAP1, RHO, TEST, TEST1, TOL + INTEGER I, ID, IDNU, INU, ITIME, K, KK, MAGZ, N + DIMENSION CY(N) + DATA CZERO, CONE / (0.0E0,0.0E0), (1.0E0,0.0E0) / + AZ = CABS(Z) + INU = INT(FNU) + IDNU = INU + N - 1 + FDNU = FLOAT(IDNU) + MAGZ = INT(AZ) + AMAGZ = FLOAT(MAGZ+1) + FNUP = AMAX1(AMAGZ,FDNU) + ID = IDNU - MAGZ - 1 + ITIME = 1 + K = 1 + RZ = (CONE+CONE)/Z + T1 = CMPLX(FNUP,0.0E0)*RZ + P2 = -T1 + P1 = CONE + T1 = T1 + RZ + IF (ID.GT.0) ID = 0 + AP2 = CABS(P2) + AP1 = CABS(P1) +C----------------------------------------------------------------------- +C THE OVERFLOW TEST ON K(FNU+I-1,Z) BEFORE THE CALL TO CBKNX +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 = SQRT(ARG) + TEST = TEST1 + RAP1 = 1.0E0/AP1 + P1 = P1*CMPLX(RAP1,0.0E0) + P2 = P2*CMPLX(RAP1,0.0E0) + AP2 = AP2*RAP1 + 10 CONTINUE + K = K + 1 + AP1 = AP2 + PT = P2 + P2 = P1 - T1*P2 + P1 = PT + T1 = T1 + RZ + AP2 = CABS(P2) + IF (AP1.LE.TEST) GO TO 10 + IF (ITIME.EQ.2) GO TO 20 + AK = CABS(T1)*0.5E0 + FLAM = AK + SQRT(AK*AK-1.0E0) + RHO = AMIN1(AP2/AP1,FLAM) + TEST = TEST1*SQRT(RHO/(RHO*RHO-1.0E0)) + ITIME = 2 + GO TO 10 + 20 CONTINUE + KK = K + 1 - ID + AK = FLOAT(KK) + DFNU = FNU + FLOAT(N-1) + CDFNU = CMPLX(DFNU,0.0E0) + T1 = CMPLX(AK,0.0E0) + P1 = CMPLX(1.0E0/AP2,0.0E0) + P2 = CZERO + DO 30 I=1,KK + PT = P1 + P1 = RZ*(CDFNU+T1)*P1 + P2 + P2 = PT + T1 = T1 - CONE + 30 CONTINUE + IF (REAL(P1).NE.0.0E0 .OR. AIMAG(P1).NE.0.0E0) GO TO 40 + P1 = CMPLX(TOL,TOL) + 40 CONTINUE + CY(N) = P2/P1 + IF (N.EQ.1) RETURN + K = N - 1 + AK = FLOAT(K) + T1 = CMPLX(AK,0.0E0) + CDFNU = CMPLX(FNU,0.0E0)*RZ + DO 60 I=2,N + PT = CDFNU + T1*RZ + CY(K+1) + IF (REAL(PT).NE.0.0E0 .OR. AIMAG(PT).NE.0.0E0) GO TO 50 + PT = CMPLX(TOL,TOL) + 50 CONTINUE + CY(K) = CONE/PT + T1 = T1 - CONE + K = K - 1 + 60 CONTINUE + RETURN + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/amos/cs1s2.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,44 @@ + SUBROUTINE CS1S2(ZR, S1, S2, NZ, ASCLE, ALIM, IUF) +C***BEGIN PROLOGUE CS1S2 +C***REFER TO CBESK,CAIRY +C +C CS1S2 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 (NONE) +C***END PROLOGUE CS1S2 + COMPLEX CZERO, C1, S1, S1D, S2, ZR + REAL AA, ALIM, ALN, ASCLE, AS1, AS2, XX + INTEGER IUF, NZ + DATA CZERO / (0.0E0,0.0E0) / + NZ = 0 + AS1 = CABS(S1) + AS2 = CABS(S2) + AA = REAL(S1) + ALN = AIMAG(S1) + IF (AA.EQ.0.0E0 .AND. ALN.EQ.0.0E0) GO TO 10 + IF (AS1.EQ.0.0E0) GO TO 10 + XX = REAL(ZR) + ALN = -XX - XX + ALOG(AS1) + S1D = S1 + S1 = CZERO + AS1 = 0.0E0 + IF (ALN.LT.(-ALIM)) GO TO 10 + C1 = CLOG(S1D) - ZR - ZR + S1 = CEXP(C1) + AS1 = CABS(S1) + IUF = IUF + 1 + 10 CONTINUE + AA = AMAX1(AS1,AS2) + IF (AA.GT.ASCLE) RETURN + S1 = CZERO + S2 = CZERO + NZ = 1 + IUF = 0 + RETURN + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/amos/cseri.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,154 @@ + SUBROUTINE CSERI(Z, FNU, KODE, N, Y, NZ, TOL, ELIM, ALIM) +C***BEGIN PROLOGUE CSERI +C***REFER TO CBESI,CBESK +C +C CSERI 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 CUCHK,GAMLN,R1MACH +C***END PROLOGUE CSERI + COMPLEX AK1, CK, COEF, CONE, CRSC, CZ, CZERO, HZ, RZ, S1, S2, W, + * Y, Z + REAL AA, ACZ, AK, ALIM, ARM, ASCLE, ATOL, AZ, DFNU, ELIM, FNU, + * FNUP, RAK1, RS, RTR1, S, SS, TOL, X, GAMLN, R1MACH + INTEGER I, IB, IDUM, IFLAG, IL, K, KODE, L, M, N, NN, NW, NZ + DIMENSION Y(N), W(2) + DATA CZERO, CONE / (0.0E0,0.0E0), (1.0E0,0.0E0) / +C + NZ = 0 + AZ = CABS(Z) + IF (AZ.EQ.0.0E0) GO TO 150 + X = REAL(Z) + ARM = 1.0E+3*R1MACH(1) + RTR1 = SQRT(ARM) + CRSC = CMPLX(1.0E0,0.0E0) + IFLAG = 0 + IF (AZ.LT.ARM) GO TO 140 + HZ = Z*CMPLX(0.5E0,0.0E0) + CZ = CZERO + IF (AZ.GT.RTR1) CZ = HZ*HZ + ACZ = CABS(CZ) + NN = N + CK = CLOG(HZ) + 10 CONTINUE + DFNU = FNU + FLOAT(NN-1) + FNUP = DFNU + 1.0E0 +C----------------------------------------------------------------------- +C UNDERFLOW TEST +C----------------------------------------------------------------------- + AK1 = CK*CMPLX(DFNU,0.0E0) + AK = GAMLN(FNUP,IDUM) + AK1 = AK1 - CMPLX(AK,0.0E0) + IF (KODE.EQ.2) AK1 = AK1 - CMPLX(X,0.0E0) + RAK1 = REAL(AK1) + IF (RAK1.GT.(-ELIM)) GO TO 30 + 20 CONTINUE + NZ = NZ + 1 + Y(NN) = CZERO + IF (ACZ.GT.DFNU) GO TO 170 + NN = NN - 1 + IF (NN.EQ.0) RETURN + GO TO 10 + 30 CONTINUE + IF (RAK1.GT.(-ALIM)) GO TO 40 + IFLAG = 1 + SS = 1.0E0/TOL + CRSC = CMPLX(TOL,0.0E0) + ASCLE = ARM*SS + 40 CONTINUE + AK = AIMAG(AK1) + AA = EXP(RAK1) + IF (IFLAG.EQ.1) AA = AA*SS + COEF = CMPLX(AA,0.0E0)*CMPLX(COS(AK),SIN(AK)) + ATOL = TOL*ACZ/FNUP + IL = MIN0(2,NN) + DO 80 I=1,IL + DFNU = FNU + FLOAT(NN-I) + FNUP = DFNU + 1.0E0 + S1 = CONE + IF (ACZ.LT.TOL*FNUP) GO TO 60 + AK1 = CONE + AK = FNUP + 2.0E0 + S = FNUP + AA = 2.0E0 + 50 CONTINUE + RS = 1.0E0/S + AK1 = AK1*CZ*CMPLX(RS,0.0E0) + S1 = S1 + AK1 + S = S + AK + AK = AK + 2.0E0 + AA = AA*ACZ*RS + IF (AA.GT.ATOL) GO TO 50 + 60 CONTINUE + M = NN - I + 1 + S2 = S1*COEF + W(I) = S2 + IF (IFLAG.EQ.0) GO TO 70 + CALL CUCHK(S2, NW, ASCLE, TOL) + IF (NW.NE.0) GO TO 20 + 70 CONTINUE + Y(M) = S2*CRSC + IF (I.NE.IL) COEF = COEF*CMPLX(DFNU,0.0E0)/HZ + 80 CONTINUE + IF (NN.LE.2) RETURN + K = NN - 2 + AK = FLOAT(K) + RZ = (CONE+CONE)/Z + IF (IFLAG.EQ.1) GO TO 110 + IB = 3 + 90 CONTINUE + DO 100 I=IB,NN + Y(K) = CMPLX(AK+FNU,0.0E0)*RZ*Y(K+1) + Y(K+2) + AK = AK - 1.0E0 + K = K - 1 + 100 CONTINUE + RETURN +C----------------------------------------------------------------------- +C RECUR BACKWARD WITH SCALED VALUES +C----------------------------------------------------------------------- + 110 CONTINUE +C----------------------------------------------------------------------- +C EXP(-ALIM)=EXP(-ELIM)/TOL=APPROX. ONE PRECISION ABOVE THE +C UNDERFLOW LIMIT = ASCLE = R1MACH(1)*CSCL*1.0E+3 +C----------------------------------------------------------------------- + S1 = W(1) + S2 = W(2) + DO 120 L=3,NN + CK = S2 + S2 = S1 + CMPLX(AK+FNU,0.0E0)*RZ*S2 + S1 = CK + CK = S2*CRSC + Y(K) = CK + AK = AK - 1.0E0 + K = K - 1 + IF (CABS(CK).GT.ASCLE) GO TO 130 + 120 CONTINUE + RETURN + 130 CONTINUE + IB = L + 1 + IF (IB.GT.NN) RETURN + GO TO 90 + 140 CONTINUE + NZ = N + IF (FNU.EQ.0.0E0) NZ = NZ - 1 + 150 CONTINUE + Y(1) = CZERO + IF (FNU.EQ.0.0E0) Y(1) = CONE + IF (N.EQ.1) RETURN + DO 160 I=2,N + Y(I) = CZERO + 160 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----------------------------------------------------------------------- + 170 CONTINUE + NZ = -NZ + RETURN + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/amos/cshch.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,25 @@ + SUBROUTINE CSHCH(Z, CSH, CCH) +C***BEGIN PROLOGUE CSHCH +C***REFER TO CBESK,CBESH +C +C CSHCH 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 CSHCH + COMPLEX CCH, CSH, Z + REAL CCHI, CCHR, CH, CN, CSHI, CSHR, SH, SN, X, Y, COSH, SINH + X = REAL(Z) + Y = AIMAG(Z) + SH = SINH(X) + CH = COSH(X) + SN = SIN(Y) + CN = COS(Y) + CSHR = SH*CN + CSHI = CH*SN + CSH = CMPLX(CSHR,CSHI) + CCHR = CH*CN + CCHI = SH*SN + CCH = CMPLX(CCHR,CCHI) + RETURN + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/amos/cuchk.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,30 @@ + SUBROUTINE CUCHK(Y, NZ, ASCLE, TOL) +C***BEGIN PROLOGUE CUCHK +C***REFER TO CSERI,CUOIK,CUNK1,CUNK2,CUNI1,CUNI2,CKSCL +C +C Y ENTERS AS A SCALED QUANTITY WHOSE MAGNITUDE IS GREATER THAN +C EXP(-ALIM)=ASCLE=1.0E+3*R1MACH(1)/TOL. THE TEST IS MADE TO SEE +C IF THE MAGNITUDE OF THE REAL OR IMAGINARY PART WOULD UNDER FLOW +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 CUCHK +C + COMPLEX Y + REAL ASCLE, SS, ST, TOL, YR, YI + INTEGER NZ + NZ = 0 + YR = REAL(Y) + YI = AIMAG(Y) + YR = ABS(YR) + YI = ABS(YI) + ST = AMIN1(YR,YI) + IF (ST.GT.ASCLE) RETURN + SS = AMAX1(YR,YI) + ST=ST/TOL + IF (SS.LT.ST) NZ = 1 + RETURN + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/amos/cunhj.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,648 @@ + SUBROUTINE CUNHJ(Z, FNU, IPMTR, TOL, PHI, ARG, ZETA1, ZETA2, + * ASUM, BSUM) +C***BEGIN PROLOGUE CUNHJ +C***REFER TO CBESI,CBESK +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 CUNHJ 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 (NONE) +C***END PROLOGUE CUNHJ + COMPLEX ARG, ASUM, BSUM, CFNU, CONE, CR, CZERO, DR, P, PHI, + * PRZTH, PTFN, RFN13, RTZTA, RZTH, SUMA, SUMB, TFN, T2, UP, W, W2, + * Z, ZA, ZB, ZC, ZETA, ZETA1, ZETA2, ZTH + REAL ALFA, ANG, AP, AR, ATOL, AW2, AZTH, BETA, BR, BTOL, C, EX1, + * EX2, FNU, FN13, FN23, GAMA, HPI, PI, PP, RFNU, RFNU2, THPI, TOL, + * WI, WR, ZCI, ZCR, ZETAI, ZETAR, ZTHI, ZTHR, ASUMR, ASUMI, BSUMR, + * BSUMI, TEST, TSTR, TSTI, AC + INTEGER IAS, IBS, IPMTR, IS, J, JR, JU, K, KMAX, KP1, KS, L, LR, + * LRP1, L1, L2, M + DIMENSION AR(14), BR(14), C(105), ALFA(180), BETA(210), GAMA(30), + * AP(30), P(30), UP(14), CR(14), DR(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.00000000000000000E+00, 1.04166666666666667E-01, + 3 8.35503472222222222E-02, 1.28226574556327160E-01, + 4 2.91849026464140464E-01, 8.81627267443757652E-01, + 5 3.32140828186276754E+00, 1.49957629868625547E+01, + 6 7.89230130115865181E+01, 4.74451538868264323E+02, + 7 3.20749009089066193E+03, 2.40865496408740049E+04, + 8 1.98923119169509794E+05, 1.79190200777534383E+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.00000000000000000E+00, -1.45833333333333333E-01, + 3 -9.87413194444444444E-02, -1.43312053915895062E-01, + 4 -3.17227202678413548E-01, -9.42429147957120249E-01, + 5 -3.51120304082635426E+00, -1.57272636203680451E+01, + 6 -8.22814390971859444E+01, -4.92355370523670524E+02, + 7 -3.31621856854797251E+03, -2.48276742452085896E+04, + 8 -2.04526587315129788E+05, -1.83844491706820990E+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.00000000000000000E+00, -2.08333333333333333E-01, + 4 1.25000000000000000E-01, 3.34201388888888889E-01, + 5 -4.01041666666666667E-01, 7.03125000000000000E-02, + 6 -1.02581259645061728E+00, 1.84646267361111111E+00, + 7 -8.91210937500000000E-01, 7.32421875000000000E-02, + 8 4.66958442342624743E+00, -1.12070026162229938E+01, + 9 8.78912353515625000E+00, -2.36408691406250000E+00, + A 1.12152099609375000E-01, -2.82120725582002449E+01, + B 8.46362176746007346E+01, -9.18182415432400174E+01, + C 4.25349987453884549E+01, -7.36879435947963170E+00, + D 2.27108001708984375E-01, 2.12570130039217123E+02, + E -7.65252468141181642E+02, 1.05999045252799988E+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.99579627376132541E+02, 2.18190511744211590E+02, + 4 -2.64914304869515555E+01, 5.72501420974731445E-01, + 5 -1.91945766231840700E+03, 8.06172218173730938E+03, + 6 -1.35865500064341374E+04, 1.16553933368645332E+04, + 7 -5.30564697861340311E+03, 1.20090291321635246E+03, + 8 -1.08090919788394656E+02, 1.72772750258445740E+00, + 9 2.02042913309661486E+04, -9.69805983886375135E+04, + A 1.92547001232531532E+05, -2.03400177280415534E+05, + B 1.22200464983017460E+05, -4.11926549688975513E+04, + C 7.10951430248936372E+03, -4.93915304773088012E+02, + D 6.07404200127348304E+00, -2.42919187900551333E+05, + E 1.31176361466297720E+06, -2.99801591853810675E+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.76327129765640400E+06, -2.81356322658653411E+06, + 4 1.26836527332162478E+06, -3.31645172484563578E+05, + 5 4.52187689813627263E+04, -2.49983048181120962E+03, + 6 2.43805296995560639E+01, 3.28446985307203782E+06, + 7 -1.97068191184322269E+07, 5.09526024926646422E+07, + 8 -7.41051482115326577E+07, 6.63445122747290267E+07, + 9 -3.75671766607633513E+07, 1.32887671664218183E+07, + A -2.78561812808645469E+06, 3.08186404612662398E+05, + B -1.38860897537170405E+04, 1.10017140269246738E+02, + C -4.93292536645099620E+07, 3.25573074185765749E+08, + D -9.39462359681578403E+08, 1.55359689957058006E+09, + E -1.62108055210833708E+09, 1.10684281682301447E+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.95889784275030309E+08, 1.42062907797533095E+08, + 4 -2.44740627257387285E+07, 2.24376817792244943E+06, + 5 -8.40054336030240853E+04, 5.51335896122020586E+02, + 6 8.14789096118312115E+08, -5.86648149205184723E+09, + 7 1.86882075092958249E+10, -3.46320433881587779E+10, + 8 4.12801855797539740E+10, -3.30265997498007231E+10, + 9 1.79542137311556001E+10, -6.56329379261928433E+09, + A 1.55927986487925751E+09, -2.25105661889415278E+08, + B 1.73951075539781645E+07, -5.49842327572288687E+05, + C 3.03809051092238427E+03, -1.46792612476956167E+10, + D 1.14498237732025810E+11, -3.99096175224466498E+11, + E 8.19218669548577329E+11, -1.09837515608122331E+12/ + DATA C(97), C(98), C(99), C(100), C(101), C(102), C(103), C(104), + 1 C(105)/ + 2 1.00815810686538209E+12, -6.45364869245376503E+11, + 3 2.87900649906150589E+11, -8.78670721780232657E+10, + 4 1.76347306068349694E+10, -2.16716498322379509E+09, + 5 1.43157876718888981E+08, -3.87183344257261262E+06, + 6 1.82577554742931747E+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.44444444444444444E-03, -9.22077922077922078E-04, + 5 -8.84892884892884893E-05, 1.65927687832449737E-04, + 6 2.46691372741792910E-04, 2.65995589346254780E-04, + 7 2.61824297061500945E-04, 2.48730437344655609E-04, + 8 2.32721040083232098E-04, 2.16362485712365082E-04, + 9 2.00738858762752355E-04, 1.86267636637545172E-04, + A 1.73060775917876493E-04, 1.61091705929015752E-04, + B 1.50274774160908134E-04, 1.40503497391269794E-04, + C 1.31668816545922806E-04, 1.23667445598253261E-04, + D 1.16405271474737902E-04, 1.09798298372713369E-04, + E 1.03772410422992823E-04, 9.82626078369363448E-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.32120517249503256E-05, 8.85710852478711718E-05, + 5 8.42963105715700223E-05, 8.03497548407791151E-05, + 6 7.66981345359207388E-05, 7.33122157481777809E-05, + 7 7.01662625163141333E-05, 6.72375633790160292E-05, + 8 6.93735541354588974E-04, 2.32241745182921654E-04, + 9 -1.41986273556691197E-05, -1.16444931672048640E-04, + A -1.50803558053048762E-04, -1.55121924918096223E-04, + B -1.46809756646465549E-04, -1.33815503867491367E-04, + C -1.19744975684254051E-04, -1.06184319207974020E-04, + D -9.37699549891194492E-05, -8.26923045588193274E-05, + E -7.29374348155221211E-05, -6.44042357721016283E-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.69611566009369048E-05, -5.04731044303561628E-05, + 5 -4.48134868008882786E-05, -3.98688727717598864E-05, + 6 -3.55400532972042498E-05, -3.17414256609022480E-05, + 7 -2.83996793904174811E-05, -2.54522720634870566E-05, + 8 -2.28459297164724555E-05, -2.05352753106480604E-05, + 9 -1.84816217627666085E-05, -1.66519330021393806E-05, + A -1.50179412980119482E-05, -1.35554031379040526E-05, + B -1.22434746473858131E-05, -1.10641884811308169E-05, + C -3.54211971457743841E-04, -1.56161263945159416E-04, + D 3.04465503594936410E-05, 1.30198655773242693E-04, + E 1.67471106699712269E-04, 1.70222587683592569E-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.56501427608594704E-04, 1.36339170977445120E-04, + 5 1.14886692029825128E-04, 9.45869093034688111E-05, + 6 7.64498419250898258E-05, 6.07570334965197354E-05, + 7 4.74394299290508799E-05, 3.62757512005344297E-05, + 8 2.69939714979224901E-05, 1.93210938247939253E-05, + 9 1.30056674793963203E-05, 7.82620866744496661E-06, + A 3.59257485819351583E-06, 1.44040049814251817E-07, + B -2.65396769697939116E-06, -4.91346867098485910E-06, + C -6.72739296091248287E-06, -8.17269379678657923E-06, + D -9.31304715093561232E-06, -1.02011418798016441E-05, + E -1.08805962510592880E-05, -1.13875481509603555E-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.17519675674556414E-05, -1.19987364870944141E-05, + 5 3.78194199201772914E-04, 2.02471952761816167E-04, + 6 -6.37938506318862408E-05, -2.38598230603005903E-04, + 7 -3.10916256027361568E-04, -3.13680115247576316E-04, + 8 -2.78950273791323387E-04, -2.28564082619141374E-04, + 9 -1.75245280340846749E-04, -1.25544063060690348E-04, + A -8.22982872820208365E-05, -4.62860730588116458E-05, + B -1.72334302366962267E-05, 5.60690482304602267E-06, + C 2.31395443148286800E-05, 3.62642745856793957E-05, + D 4.58006124490188752E-05, 5.24595294959114050E-05, + E 5.68396208545815266E-05, 5.94349820393104052E-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.06478527578421742E-05, 6.08023907788436497E-05, + 5 6.01577894539460388E-05, 5.89199657344698500E-05, + 6 5.72515823777593053E-05, 5.52804375585852577E-05, + 7 5.31063773802880170E-05, 5.08069302012325706E-05, + 8 4.84418647620094842E-05, 4.60568581607475370E-05, + 9 -6.91141397288294174E-04, -4.29976633058871912E-04, + A 1.83067735980039018E-04, 6.60088147542014144E-04, + B 8.75964969951185931E-04, 8.77335235958235514E-04, + C 7.49369585378990637E-04, 5.63832329756980918E-04, + D 3.68059319971443156E-04, 1.88464535514455599E-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.70663057664904149E-05, -8.28520220232137023E-05, + 5 -1.72751952869172998E-04, -2.36314873605872983E-04, + 6 -2.77966150694906658E-04, -3.02079514155456919E-04, + 7 -3.12594712643820127E-04, -3.12872558758067163E-04, + 8 -3.05678038466324377E-04, -2.93226470614557331E-04, + 9 -2.77255655582934777E-04, -2.59103928467031709E-04, + A -2.39784014396480342E-04, -2.20048260045422848E-04, + B -2.00443911094971498E-04, -1.81358692210970687E-04, + C -1.63057674478657464E-04, -1.45712672175205844E-04, + D -1.29425421983924587E-04, -1.14245691942445952E-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.92821964248775885E-03, 1.35592576302022234E-03, + 5 -7.17858090421302995E-04, -2.58084802575270346E-03, + 6 -3.49271130826168475E-03, -3.46986299340960628E-03, + 7 -2.82285233351310182E-03, -1.88103076404891354E-03, + 8 -8.89531718383947600E-04, 3.87912102631035228E-06, + 9 7.28688540119691412E-04, 1.26566373053457758E-03, + A 1.62518158372674427E-03, 1.83203153216373172E-03, + B 1.91588388990527909E-03, 1.90588846755546138E-03, + C 1.82798982421825727E-03, 1.70389506421121530E-03, + D 1.55097127171097686E-03, 1.38261421852276159E-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.20881424230064774E-03, 1.03676532638344962E-03, + 3 8.71437918068619115E-04, 7.16080155297701002E-04, + 4 5.72637002558129372E-04, 4.42089819465802277E-04, + 5 3.24724948503090564E-04, 2.20342042730246599E-04, + 6 1.28412898401353882E-04, 4.82005924552095464E-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.79988721413553309E-02, 5.59964911064388073E-03, + 5 2.88501402231132779E-03, 1.80096606761053941E-03, + 6 1.24753110589199202E-03, 9.22878876572938311E-04, + 7 7.14430421727287357E-04, 5.71787281789704872E-04, + 8 4.69431007606481533E-04, 3.93232835462916638E-04, + 9 3.34818889318297664E-04, 2.88952148495751517E-04, + A 2.52211615549573284E-04, 2.22280580798883327E-04, + B 1.97541838033062524E-04, 1.76836855019718004E-04, + C 1.59316899661821081E-04, 1.44347930197333986E-04, + D 1.31448068119965379E-04, 1.20245444949302884E-04, + E 1.10449144504599392E-04, 1.01828770740567258E-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.41998224204237509E-05, 8.74130545753834437E-05, + 5 8.13466262162801467E-05, 7.59002269646219339E-05, + 6 7.09906300634153481E-05, 6.65482874842468183E-05, + 7 6.25146958969275078E-05, 5.88403394426251749E-05, + 8 -1.49282953213429172E-03, -8.78204709546389328E-04, + 9 -5.02916549572034614E-04, -2.94822138512746025E-04, + A -1.75463996970782828E-04, -1.04008550460816434E-04, + B -5.96141953046457895E-05, -3.12038929076098340E-05, + C -1.26089735980230047E-05, -2.42892608575730389E-07, + D 8.05996165414273571E-06, 1.36507009262147391E-05, + E 1.73964125472926261E-05, 1.98672978842133780E-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.14463263790822639E-05, 2.23954659232456514E-05, + 5 2.28967783814712629E-05, 2.30785389811177817E-05, + 6 2.30321976080909144E-05, 2.28236073720348722E-05, + 7 2.25005881105292418E-05, 2.20981015361991429E-05, + 8 2.16418427448103905E-05, 2.11507649256220843E-05, + 9 2.06388749782170737E-05, 2.01165241997081666E-05, + A 1.95913450141179244E-05, 1.90689367910436740E-05, + B 1.85533719641636667E-05, 1.80475722259674218E-05, + C 5.52213076721292790E-04, 4.47932581552384646E-04, + D 2.79520653992020589E-04, 1.52468156198446602E-04, + E 6.93271105657043598E-05, 1.76258683069991397E-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.35744996343269136E-05, -3.17972413350427135E-05, + 5 -4.18861861696693365E-05, -4.69004889379141029E-05, + 6 -4.87665447413787352E-05, -4.87010031186735069E-05, + 7 -4.74755620890086638E-05, -4.55813058138628452E-05, + 8 -4.33309644511266036E-05, -4.09230193157750364E-05, + 9 -3.84822638603221274E-05, -3.60857167535410501E-05, + A -3.37793306123367417E-05, -3.15888560772109621E-05, + B -2.95269561750807315E-05, -2.75978914828335759E-05, + C -2.58006174666883713E-05, -2.41308356761280200E-05, + D -2.25823509518346033E-05, -2.11479656768912971E-05, + E -1.98200638885294927E-05, -1.85909870801065077E-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.74532699844210224E-05, -1.63997823854497997E-05, + 5 -4.74617796559959808E-04, -4.77864567147321487E-04, + 6 -3.20390228067037603E-04, -1.61105016119962282E-04, + 7 -4.25778101285435204E-05, 3.44571294294967503E-05, + 8 7.97092684075674924E-05, 1.03138236708272200E-04, + 9 1.12466775262204158E-04, 1.13103642108481389E-04, + A 1.08651634848774268E-04, 1.01437951597661973E-04, + B 9.29298396593363896E-05, 8.40293133016089978E-05, + C 7.52727991349134062E-05, 6.69632521975730872E-05, + D 5.92564547323194704E-05, 5.22169308826975567E-05, + E 4.58539485165360646E-05, 4.01445513891486808E-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.50481730031328081E-05, 3.05157995034346659E-05, + 5 2.64956119950516039E-05, 2.29363633690998152E-05, + 6 1.97893056664021636E-05, 1.70091984636412623E-05, + 7 1.45547428261524004E-05, 1.23886640995878413E-05, + 8 1.04775876076583236E-05, 8.79179954978479373E-06, + 9 7.36465810572578444E-04, 8.72790805146193976E-04, + A 6.22614862573135066E-04, 2.85998154194304147E-04, + B 3.84737672879366102E-06, -1.87906003636971558E-04, + C -2.97603646594554535E-04, -3.45998126832656348E-04, + D -3.53382470916037712E-04, -3.35715635775048757E-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.04321124789039809E-04, -2.66722723047612821E-04, + 5 -2.27654214122819527E-04, -1.89922611854562356E-04, + 6 -1.55058918599093870E-04, -1.23778240761873630E-04, + 7 -9.62926147717644187E-05, -7.25178327714425337E-05, + 8 -5.22070028895633801E-05, -3.50347750511900522E-05, + 9 -2.06489761035551757E-05, -8.70106096849767054E-06, + A 1.13698686675100290E-06, 9.16426474122778849E-06, + B 1.56477785428872620E-05, 2.08223629482466847E-05, + C 2.48923381004595156E-05, 2.80340509574146325E-05, + D 3.03987774629861915E-05, 3.21156731406700616E-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.80182191963885708E-03, -2.43402962938042533E-03, + 5 -1.83422663549856802E-03, -7.62204596354009765E-04, + 6 2.39079475256927218E-04, 9.49266117176881141E-04, + 7 1.34467449701540359E-03, 1.48457495259449178E-03, + 8 1.44732339830617591E-03, 1.30268261285657186E-03, + 9 1.10351597375642682E-03, 8.86047440419791759E-04, + A 6.73073208165665473E-04, 4.77603872856582378E-04, + B 3.05991926358789362E-04, 1.60315694594721630E-04, + C 4.00749555270613286E-05, -5.66607461635251611E-05, + D -1.32506186772982638E-04, -1.90296187989614057E-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.32811450376937408E-04, -2.62628811464668841E-04, + 5 -2.82050469867598672E-04, -2.93081563192861167E-04, + 6 -2.97435962176316616E-04, -2.96557334239348078E-04, + 7 -2.91647363312090861E-04, -2.83696203837734166E-04, + 8 -2.73512317095673346E-04, -2.61750155806768580E-04, + 9 6.38585891212050914E-03, 9.62374215806377941E-03, + A 7.61878061207001043E-03, 2.83219055545628054E-03, + B -2.09841352012720090E-03, -5.73826764216626498E-03, + C -7.70804244495414620E-03, -8.21011692264844401E-03, + D -7.65824520346905413E-03, -6.47209729391045177E-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.99132412004966473E-03, -3.45612289713133280E-03, + 5 -2.01785580014170775E-03, -7.59430686781961401E-04, + 6 2.84173631523859138E-04, 1.10891667586337403E-03, + 7 1.72901493872728771E-03, 2.16812590802684701E-03, + 8 2.45357710494539735E-03, 2.61281821058334862E-03, + 9 2.67141039656276912E-03, 2.65203073395980430E-03, + A 2.57411652877287315E-03, 2.45389126236094427E-03, + B 2.30460058071795494E-03, 2.13684837686712662E-03, + C 1.95896528478870911E-03, 1.77737008679454412E-03, + D 1.59690280765839059E-03, 1.42111975664438546E-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.29960524947436582E-01, 2.51984209978974633E-01, + 5 1.54790300415655846E-01, 1.10713062416159013E-01, + 6 8.57309395527394825E-02, 6.97161316958684292E-02, + 7 5.86085671893713576E-02, 5.04698873536310685E-02, + 8 4.42600580689154809E-02, 3.93720661543509966E-02, + 9 3.54283195924455368E-02, 3.21818857502098231E-02, + A 2.94646240791157679E-02, 2.71581677112934479E-02, + B 2.51768272973861779E-02, 2.34570755306078891E-02, + C 2.19508390134907203E-02, 2.06210828235646240E-02, + D 1.94388240897880846E-02, 1.83810633800683158E-02, + E 1.74293213231963172E-02, 1.65685837786612353E-02/ + DATA GAMA(23), GAMA(24), GAMA(25), GAMA(26), GAMA(27), GAMA(28), + 1 GAMA(29), GAMA(30)/ + 2 1.57865285987918445E-02, 1.50729501494095594E-02, + 3 1.44193250839954639E-02, 1.38184805735341786E-02, + 4 1.32643378994276568E-02, 1.27517121970498651E-02, + 5 1.22761545318762767E-02, 1.18338262398482403E-02/ + DATA EX1, EX2, HPI, PI, THPI / + 1 3.33333333333333333E-01, 6.66666666666666667E-01, + 2 1.57079632679489662E+00, 3.14159265358979324E+00, + 3 4.71238898038468986E+00/ + DATA CZERO, CONE / (0.0E0,0.0E0), (1.0E0,0.0E0) / +C + RFNU = 1.0E0/FNU +C ZB = Z*CMPLX(RFNU,0.0E0) +C----------------------------------------------------------------------- +C OVERFLOW TEST (Z/FNU TOO SMALL) +C----------------------------------------------------------------------- + TSTR = REAL(Z) + TSTI = AIMAG(Z) + TEST = R1MACH(1)*1.0E+3 + AC = FNU*TEST + IF (ABS(TSTR).GT.AC .OR. ABS(TSTI).GT.AC) GO TO 15 + AC = 2.0E0*ABS(ALOG(TEST))+FNU + ZETA1 = CMPLX(AC,0.0E0) + ZETA2 = CMPLX(FNU,0.0E0) + PHI=CONE + ARG=CONE + RETURN + 15 CONTINUE + ZB = Z*CMPLX(RFNU,0.0E0) + RFNU2 = RFNU*RFNU +C----------------------------------------------------------------------- +C COMPUTE IN THE FOURTH QUADRANT +C----------------------------------------------------------------------- + FN13 = FNU**EX1 + FN23 = FN13*FN13 + RFN13 = CMPLX(1.0E0/FN13,0.0E0) + W2 = CONE - ZB*ZB + AW2 = CABS(W2) + IF (AW2.GT.0.25E0) GO TO 130 +C----------------------------------------------------------------------- +C POWER SERIES FOR CABS(W2).LE.0.25E0 +C----------------------------------------------------------------------- + K = 1 + P(1) = CONE + SUMA = CMPLX(GAMA(1),0.0E0) + AP(1) = 1.0E0 + IF (AW2.LT.TOL) GO TO 20 + DO 10 K=2,30 + P(K) = P(K-1)*W2 + SUMA = SUMA + P(K)*CMPLX(GAMA(K),0.0E0) + AP(K) = AP(K-1)*AW2 + IF (AP(K).LT.TOL) GO TO 20 + 10 CONTINUE + K = 30 + 20 CONTINUE + KMAX = K + ZETA = W2*SUMA + ARG = ZETA*CMPLX(FN23,0.0E0) + ZA = CSQRT(SUMA) + ZETA2 = CSQRT(W2)*CMPLX(FNU,0.0E0) + ZETA1 = ZETA2*(CONE+ZETA*ZA*CMPLX(EX2,0.0E0)) + ZA = ZA + ZA + PHI = CSQRT(ZA)*RFN13 + IF (IPMTR.EQ.1) GO TO 120 +C----------------------------------------------------------------------- +C SUM SERIES FOR ASUM AND BSUM +C----------------------------------------------------------------------- + SUMB = CZERO + DO 30 K=1,KMAX + SUMB = SUMB + P(K)*CMPLX(BETA(K),0.0E0) + 30 CONTINUE + ASUM = CZERO + BSUM = SUMB + L1 = 0 + L2 = 30 + BTOL = TOL*CABS(BSUM) + ATOL = TOL + PP = 1.0E0 + 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 + SUMA = CZERO + DO 40 K=1,KMAX + M = L1 + K + SUMA = SUMA + P(K)*CMPLX(ALFA(M),0.0E0) + IF (AP(K).LT.ATOL) GO TO 50 + 40 CONTINUE + 50 CONTINUE + ASUM = ASUM + SUMA*CMPLX(PP,0.0E0) + IF (PP.LT.TOL) IAS = 1 + 60 CONTINUE + IF (IBS.EQ.1) GO TO 90 + SUMB = CZERO + DO 70 K=1,KMAX + M = L2 + K + SUMB = SUMB + P(K)*CMPLX(BETA(M),0.0E0) + IF (AP(K).LT.ATOL) GO TO 80 + 70 CONTINUE + 80 CONTINUE + BSUM = BSUM + SUMB*CMPLX(PP,0.0E0) + 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 + ASUM = ASUM + CONE + PP = RFNU*REAL(RFN13) + BSUM = BSUM*CMPLX(PP,0.0E0) + 120 CONTINUE + RETURN +C----------------------------------------------------------------------- +C CABS(W2).GT.0.25E0 +C----------------------------------------------------------------------- + 130 CONTINUE + W = CSQRT(W2) + WR = REAL(W) + WI = AIMAG(W) + IF (WR.LT.0.0E0) WR = 0.0E0 + IF (WI.LT.0.0E0) WI = 0.0E0 + W = CMPLX(WR,WI) + ZA = (CONE+W)/ZB + ZC = CLOG(ZA) + ZCR = REAL(ZC) + ZCI = AIMAG(ZC) + IF (ZCI.LT.0.0E0) ZCI = 0.0E0 + IF (ZCI.GT.HPI) ZCI = HPI + IF (ZCR.LT.0.0E0) ZCR = 0.0E0 + ZC = CMPLX(ZCR,ZCI) + ZTH = (ZC-W)*CMPLX(1.5E0,0.0E0) + CFNU = CMPLX(FNU,0.0E0) + ZETA1 = ZC*CFNU + ZETA2 = W*CFNU + AZTH = CABS(ZTH) + ZTHR = REAL(ZTH) + ZTHI = AIMAG(ZTH) + ANG = THPI + IF (ZTHR.GE.0.0E0 .AND. ZTHI.LT.0.0E0) GO TO 140 + ANG = HPI + IF (ZTHR.EQ.0.0E0) GO TO 140 + ANG = ATAN(ZTHI/ZTHR) + IF (ZTHR.LT.0.0E0) ANG = ANG + PI + 140 CONTINUE + PP = AZTH**EX2 + ANG = ANG*EX2 + ZETAR = PP*COS(ANG) + ZETAI = PP*SIN(ANG) + IF (ZETAI.LT.0.0E0) ZETAI = 0.0E0 + ZETA = CMPLX(ZETAR,ZETAI) + ARG = ZETA*CMPLX(FN23,0.0E0) + RTZTA = ZTH/ZETA + ZA = RTZTA/W + PHI = CSQRT(ZA+ZA)*RFN13 + IF (IPMTR.EQ.1) GO TO 120 + TFN = CMPLX(RFNU,0.0E0)/W + RZTH = CMPLX(RFNU,0.0E0)/ZTH + ZC = RZTH*CMPLX(AR(2),0.0E0) + T2 = CONE/W2 + UP(2) = (T2*CMPLX(C(2),0.0E0)+CMPLX(C(3),0.0E0))*TFN + BSUM = UP(2) + ZC + ASUM = CZERO + IF (RFNU.LT.TOL) GO TO 220 + PRZTH = RZTH + PTFN = TFN + UP(1) = CONE + PP = 1.0E0 + BSUMR = REAL(BSUM) + BSUMI = AIMAG(BSUM) + BTOL = TOL*(ABS(BSUMR)+ABS(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 + ZA = CMPLX(C(L),0.0E0) + DO 150 J=2,KP1 + L = L + 1 + ZA = ZA*T2 + CMPLX(C(L),0.0E0) + 150 CONTINUE + PTFN = PTFN*TFN + UP(KP1) = PTFN*ZA + CR(KS) = PRZTH*CMPLX(BR(KS+1),0.0E0) + PRZTH = PRZTH*RZTH + DR(KS) = PRZTH*CMPLX(AR(KS+2),0.0E0) + 160 CONTINUE + PP = PP*RFNU2 + IF (IAS.EQ.1) GO TO 180 + SUMA = UP(LRP1) + JU = LRP1 + DO 170 JR=1,LR + JU = JU - 1 + SUMA = SUMA + CR(JR)*UP(JU) + 170 CONTINUE + ASUM = ASUM + SUMA + ASUMR = REAL(ASUM) + ASUMI = AIMAG(ASUM) + TEST = ABS(ASUMR) + ABS(ASUMI) + IF (PP.LT.TOL .AND. TEST.LT.TOL) IAS = 1 + 180 CONTINUE + IF (IBS.EQ.1) GO TO 200 + SUMB = UP(LR+2) + UP(LRP1)*ZC + JU = LRP1 + DO 190 JR=1,LR + JU = JU - 1 + SUMB = SUMB + DR(JR)*UP(JU) + 190 CONTINUE + BSUM = BSUM + SUMB + BSUMR = REAL(BSUM) + BSUMI = AIMAG(BSUM) + TEST = ABS(BSUMR) + ABS(BSUMI) + IF (PP.LT.BTOL .AND. TEST.LT.TOL) IBS = 1 + 200 CONTINUE + IF (IAS.EQ.1 .AND. IBS.EQ.1) GO TO 220 + 210 CONTINUE + 220 CONTINUE + ASUM = ASUM + CONE + BSUM = -BSUM*RFN13/RTZTA + GO TO 120 + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/amos/cuni1.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,168 @@ + SUBROUTINE CUNI1(Z, FNU, KODE, N, Y, NZ, NLAST, FNUL, TOL, ELIM, + * ALIM) +C***BEGIN PROLOGUE CUNI1 +C***REFER TO CBESI,CBESK +C +C CUNI1 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 CUCHK,CUNIK,CUOIK,R1MACH +C***END PROLOGUE CUNI1 + COMPLEX CFN, CONE, CRSC, CSCL, CSR, CSS, CWRK, CZERO, C1, C2, + * PHI, RZ, SUM, S1, S2, Y, Z, ZETA1, ZETA2, CY + REAL ALIM, APHI, ASCLE, BRY, C2I, C2M, C2R, ELIM, FN, FNU, FNUL, + * RS1, TOL, YY, R1MACH + INTEGER I, IFLAG, INIT, K, KODE, M, N, ND, NLAST, NN, NUF, NW, NZ + DIMENSION BRY(3), Y(N), CWRK(16), CSS(3), CSR(3), CY(2) + DATA CZERO, CONE / (0.0E0,0.0E0), (1.0E0,0.0E0) / +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 = CMPLX(1.0E0/TOL,0.0E0) + CRSC = CMPLX(TOL,0.0E0) + CSS(1) = CSCL + CSS(2) = CONE + CSS(3) = CRSC + CSR(1) = CRSC + CSR(2) = CONE + CSR(3) = CSCL + BRY(1) = 1.0E+3*R1MACH(1)/TOL +C----------------------------------------------------------------------- +C CHECK FOR UNDERFLOW AND OVERFLOW ON FIRST MEMBER +C----------------------------------------------------------------------- + FN = AMAX1(FNU,1.0E0) + INIT = 0 + CALL CUNIK(Z, FN, 1, 1, TOL, INIT, PHI, ZETA1, ZETA2, SUM, CWRK) + IF (KODE.EQ.1) GO TO 10 + CFN = CMPLX(FN,0.0E0) + S1 = -ZETA1 + CFN*(CFN/(Z+ZETA2)) + GO TO 20 + 10 CONTINUE + S1 = -ZETA1 + ZETA2 + 20 CONTINUE + RS1 = REAL(S1) + IF (ABS(RS1).GT.ELIM) GO TO 130 + 30 CONTINUE + NN = MIN0(2,ND) + DO 80 I=1,NN + FN = FNU + FLOAT(ND-I) + INIT = 0 + CALL CUNIK(Z, FN, 1, 0, TOL, INIT, PHI, ZETA1, ZETA2, SUM, CWRK) + IF (KODE.EQ.1) GO TO 40 + CFN = CMPLX(FN,0.0E0) + YY = AIMAG(Z) + S1 = -ZETA1 + CFN*(CFN/(Z+ZETA2)) + CMPLX(0.0E0,YY) + GO TO 50 + 40 CONTINUE + S1 = -ZETA1 + ZETA2 + 50 CONTINUE +C----------------------------------------------------------------------- +C TEST FOR UNDERFLOW AND OVERFLOW +C----------------------------------------------------------------------- + RS1 = REAL(S1) + IF (ABS(RS1).GT.ELIM) GO TO 110 + IF (I.EQ.1) IFLAG = 2 + IF (ABS(RS1).LT.ALIM) GO TO 60 +C----------------------------------------------------------------------- +C REFINE TEST AND SCALE +C----------------------------------------------------------------------- + APHI = CABS(PHI) + RS1 = RS1 + ALOG(APHI) + IF (ABS(RS1).GT.ELIM) GO TO 110 + IF (I.EQ.1) IFLAG = 1 + IF (RS1.LT.0.0E0) GO TO 60 + IF (I.EQ.1) IFLAG = 3 + 60 CONTINUE +C----------------------------------------------------------------------- +C SCALE S1 IF CABS(S1).LT.ASCLE +C----------------------------------------------------------------------- + S2 = PHI*SUM + C2R = REAL(S1) + C2I = AIMAG(S1) + C2M = EXP(C2R)*REAL(CSS(IFLAG)) + S1 = CMPLX(C2M,0.0E0)*CMPLX(COS(C2I),SIN(C2I)) + S2 = S2*S1 + IF (IFLAG.NE.1) GO TO 70 + CALL CUCHK(S2, NW, BRY(1), TOL) + IF (NW.NE.0) GO TO 110 + 70 CONTINUE + M = ND - I + 1 + CY(I) = S2 + Y(M) = S2*CSR(IFLAG) + 80 CONTINUE + IF (ND.LE.2) GO TO 100 + RZ = CMPLX(2.0E0,0.0E0)/Z + BRY(2) = 1.0E0/BRY(1) + BRY(3) = R1MACH(2) + S1 = CY(1) + S2 = CY(2) + C1 = CSR(IFLAG) + ASCLE = BRY(IFLAG) + K = ND - 2 + FN = FLOAT(K) + DO 90 I=3,ND + C2 = S2 + S2 = S1 + CMPLX(FNU+FN,0.0E0)*RZ*S2 + S1 = C2 + C2 = S2*C1 + Y(K) = C2 + K = K - 1 + FN = FN - 1.0E0 + IF (IFLAG.GE.3) GO TO 90 + C2R = REAL(C2) + C2I = AIMAG(C2) + C2R = ABS(C2R) + C2I = ABS(C2I) + C2M = AMAX1(C2R,C2I) + IF (C2M.LE.ASCLE) GO TO 90 + IFLAG = IFLAG + 1 + ASCLE = BRY(IFLAG) + S1 = S1*C1 + S2 = C2 + S1 = S1*CSS(IFLAG) + S2 = S2*CSS(IFLAG) + C1 = CSR(IFLAG) + 90 CONTINUE + 100 CONTINUE + RETURN +C----------------------------------------------------------------------- +C SET UNDERFLOW AND UPDATE PARAMETERS +C----------------------------------------------------------------------- + 110 CONTINUE + IF (RS1.GT.0.0E0) GO TO 120 + Y(ND) = CZERO + NZ = NZ + 1 + ND = ND - 1 + IF (ND.EQ.0) GO TO 100 + CALL CUOIK(Z, FNU, KODE, 1, ND, Y, 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 + FLOAT(ND-1) + IF (FN.GE.FNUL) GO TO 30 + NLAST = ND + RETURN + 120 CONTINUE + NZ = -1 + RETURN + 130 CONTINUE + IF (RS1.GT.0.0E0) GO TO 120 + NZ = N + DO 140 I=1,N + Y(I) = CZERO + 140 CONTINUE + RETURN + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/amos/cuni2.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,215 @@ + SUBROUTINE CUNI2(Z, FNU, KODE, N, Y, NZ, NLAST, FNUL, TOL, ELIM, + * ALIM) +C***BEGIN PROLOGUE CUNI2 +C***REFER TO CBESI,CBESK +C +C CUNI2 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 CAIRY,CUCHK,CUNHJ,CUOIK,R1MACH +C***END PROLOGUE CUNI2 + COMPLEX AI, ARG, ASUM, BSUM, CFN, CI, CID, CIP, CONE, CRSC, CSCL, + * CSR, CSS, CY, CZERO, C1, C2, DAI, PHI, RZ, S1, S2, Y, Z, ZB, + * ZETA1, ZETA2, ZN, ZAR + REAL AARG, AIC, ALIM, ANG, APHI, ASCLE, AY, BRY, CAR, C2I, C2M, + * C2R, ELIM, FN, FNU, FNUL, HPI, RS1, SAR, TOL, YY, R1MACH + INTEGER I, IFLAG, IN, INU, J, K, KODE, N, NAI, ND, NDAI, NLAST, + * NN, NUF, NW, NZ, IDUM + DIMENSION BRY(3), Y(N), CIP(4), CSS(3), CSR(3), CY(2) + DATA CZERO,CONE,CI/(0.0E0,0.0E0),(1.0E0,0.0E0),(0.0E0,1.0E0)/ + DATA CIP(1),CIP(2),CIP(3),CIP(4)/ + 1 (1.0E0,0.0E0), (0.0E0,1.0E0), (-1.0E0,0.0E0), (0.0E0,-1.0E0)/ + DATA HPI, AIC / + 1 1.57079632679489662E+00, 1.265512123484645396E+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 = CMPLX(1.0E0/TOL,0.0E0) + CRSC = CMPLX(TOL,0.0E0) + CSS(1) = CSCL + CSS(2) = CONE + CSS(3) = CRSC + CSR(1) = CRSC + CSR(2) = CONE + CSR(3) = CSCL + BRY(1) = 1.0E+3*R1MACH(1)/TOL + YY = AIMAG(Z) +C----------------------------------------------------------------------- +C ZN IS IN THE RIGHT HALF PLANE AFTER ROTATION BY CI OR -CI +C----------------------------------------------------------------------- + ZN = -Z*CI + ZB = Z + CID = -CI + INU = INT(FNU) + ANG = HPI*(FNU-FLOAT(INU)) + CAR = COS(ANG) + SAR = SIN(ANG) + C2 = CMPLX(CAR,SAR) + ZAR = C2 + IN = INU + N - 1 + IN = MOD(IN,4) + C2 = C2*CIP(IN+1) + IF (YY.GT.0.0E0) GO TO 10 + ZN = CONJG(-ZN) + ZB = CONJG(ZB) + CID = -CID + C2 = CONJG(C2) + 10 CONTINUE +C----------------------------------------------------------------------- +C CHECK FOR UNDERFLOW AND OVERFLOW ON FIRST MEMBER +C----------------------------------------------------------------------- + FN = AMAX1(FNU,1.0E0) + CALL CUNHJ(ZN, FN, 1, TOL, PHI, ARG, ZETA1, ZETA2, ASUM, BSUM) + IF (KODE.EQ.1) GO TO 20 + CFN = CMPLX(FNU,0.0E0) + S1 = -ZETA1 + CFN*(CFN/(ZB+ZETA2)) + GO TO 30 + 20 CONTINUE + S1 = -ZETA1 + ZETA2 + 30 CONTINUE + RS1 = REAL(S1) + IF (ABS(RS1).GT.ELIM) GO TO 150 + 40 CONTINUE + NN = MIN0(2,ND) + DO 90 I=1,NN + FN = FNU + FLOAT(ND-I) + CALL CUNHJ(ZN, FN, 0, TOL, PHI, ARG, ZETA1, ZETA2, ASUM, BSUM) + IF (KODE.EQ.1) GO TO 50 + CFN = CMPLX(FN,0.0E0) + AY = ABS(YY) + S1 = -ZETA1 + CFN*(CFN/(ZB+ZETA2)) + CMPLX(0.0E0,AY) + GO TO 60 + 50 CONTINUE + S1 = -ZETA1 + ZETA2 + 60 CONTINUE +C----------------------------------------------------------------------- +C TEST FOR UNDERFLOW AND OVERFLOW +C----------------------------------------------------------------------- + RS1 = REAL(S1) + IF (ABS(RS1).GT.ELIM) GO TO 120 + IF (I.EQ.1) IFLAG = 2 + IF (ABS(RS1).LT.ALIM) GO TO 70 +C----------------------------------------------------------------------- +C REFINE TEST AND SCALE +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + APHI = CABS(PHI) + AARG = CABS(ARG) + RS1 = RS1 + ALOG(APHI) - 0.25E0*ALOG(AARG) - AIC + IF (ABS(RS1).GT.ELIM) GO TO 120 + IF (I.EQ.1) IFLAG = 1 + IF (RS1.LT.0.0E0) 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 CAIRY(ARG, 0, 2, AI, NAI, IDUM) + CALL CAIRY(ARG, 1, 2, DAI, NDAI, IDUM) + S2 = PHI*(AI*ASUM+DAI*BSUM) + C2R = REAL(S1) + C2I = AIMAG(S1) + C2M = EXP(C2R)*REAL(CSS(IFLAG)) + S1 = CMPLX(C2M,0.0E0)*CMPLX(COS(C2I),SIN(C2I)) + S2 = S2*S1 + IF (IFLAG.NE.1) GO TO 80 + CALL CUCHK(S2, NW, BRY(1), TOL) + IF (NW.NE.0) GO TO 120 + 80 CONTINUE + IF (YY.LE.0.0E0) S2 = CONJG(S2) + J = ND - I + 1 + S2 = S2*C2 + CY(I) = S2 + Y(J) = S2*CSR(IFLAG) + C2 = C2*CID + 90 CONTINUE + IF (ND.LE.2) GO TO 110 + RZ = CMPLX(2.0E0,0.0E0)/Z + BRY(2) = 1.0E0/BRY(1) + BRY(3) = R1MACH(2) + S1 = CY(1) + S2 = CY(2) + C1 = CSR(IFLAG) + ASCLE = BRY(IFLAG) + K = ND - 2 + FN = FLOAT(K) + DO 100 I=3,ND + C2 = S2 + S2 = S1 + CMPLX(FNU+FN,0.0E0)*RZ*S2 + S1 = C2 + C2 = S2*C1 + Y(K) = C2 + K = K - 1 + FN = FN - 1.0E0 + IF (IFLAG.GE.3) GO TO 100 + C2R = REAL(C2) + C2I = AIMAG(C2) + C2R = ABS(C2R) + C2I = ABS(C2I) + C2M = AMAX1(C2R,C2I) + IF (C2M.LE.ASCLE) GO TO 100 + IFLAG = IFLAG + 1 + ASCLE = BRY(IFLAG) + S1 = S1*C1 + S2 = C2 + S1 = S1*CSS(IFLAG) + S2 = S2*CSS(IFLAG) + C1 = CSR(IFLAG) + 100 CONTINUE + 110 CONTINUE + RETURN + 120 CONTINUE + IF (RS1.GT.0.0E0) GO TO 140 +C----------------------------------------------------------------------- +C SET UNDERFLOW AND UPDATE PARAMETERS +C----------------------------------------------------------------------- + Y(ND) = CZERO + NZ = NZ + 1 + ND = ND - 1 + IF (ND.EQ.0) GO TO 110 + CALL CUOIK(Z, FNU, KODE, 1, ND, Y, 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 + FLOAT(ND-1) + IF (FN.LT.FNUL) GO TO 130 +C FN = AIMAG(CID) +C J = NUF + 1 +C K = MOD(J,4) + 1 +C S1 = CIP(K) +C IF (FN.LT.0.0E0) S1 = CONJG(S1) +C C2 = C2*S1 + IN = INU + ND - 1 + IN = MOD(IN,4) + 1 + C2 = ZAR*CIP(IN) + IF (YY.LE.0.0E0)C2=CONJG(C2) + GO TO 40 + 130 CONTINUE + NLAST = ND + RETURN + 140 CONTINUE + NZ = -1 + RETURN + 150 CONTINUE + IF (RS1.GT.0.0E0) GO TO 140 + NZ = N + DO 160 I=1,N + Y(I) = CZERO + 160 CONTINUE + RETURN + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/amos/cunik.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,188 @@ + SUBROUTINE CUNIK(ZR, FNU, IKFLG, IPMTR, TOL, INIT, PHI, ZETA1, + * ZETA2, SUM, CWRK) +C***BEGIN PROLOGUE CUNIK +C***REFER TO CBESI,CBESK +C +C CUNIK 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 (NONE) +C***END PROLOGUE CUNIK + COMPLEX CFN, CON, CONE, CRFN, CWRK, CZERO, PHI, S, SR, SUM, T, + * T2, ZETA1, ZETA2, ZN, ZR + REAL AC, C, FNU, RFN, TEST, TOL, TSTR, TSTI + INTEGER I, IKFLG, INIT, IPMTR, J, K, L + DIMENSION C(120), CWRK(16), CON(2) + DATA CZERO, CONE / (0.0E0,0.0E0), (1.0E0,0.0E0) / + DATA CON(1), CON(2) / + 1(3.98942280401432678E-01,0.0E0),(1.25331413731550025E+00,0.0E0)/ + 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.00000000000000000E+00, -2.08333333333333333E-01, + 4 1.25000000000000000E-01, 3.34201388888888889E-01, + 5 -4.01041666666666667E-01, 7.03125000000000000E-02, + 6 -1.02581259645061728E+00, 1.84646267361111111E+00, + 7 -8.91210937500000000E-01, 7.32421875000000000E-02, + 8 4.66958442342624743E+00, -1.12070026162229938E+01, + 9 8.78912353515625000E+00, -2.36408691406250000E+00, + A 1.12152099609375000E-01, -2.82120725582002449E+01, + B 8.46362176746007346E+01, -9.18182415432400174E+01, + C 4.25349987453884549E+01, -7.36879435947963170E+00, + D 2.27108001708984375E-01, 2.12570130039217123E+02, + E -7.65252468141181642E+02, 1.05999045252799988E+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.99579627376132541E+02, 2.18190511744211590E+02, + 4 -2.64914304869515555E+01, 5.72501420974731445E-01, + 5 -1.91945766231840700E+03, 8.06172218173730938E+03, + 6 -1.35865500064341374E+04, 1.16553933368645332E+04, + 7 -5.30564697861340311E+03, 1.20090291321635246E+03, + 8 -1.08090919788394656E+02, 1.72772750258445740E+00, + 9 2.02042913309661486E+04, -9.69805983886375135E+04, + A 1.92547001232531532E+05, -2.03400177280415534E+05, + B 1.22200464983017460E+05, -4.11926549688975513E+04, + C 7.10951430248936372E+03, -4.93915304773088012E+02, + D 6.07404200127348304E+00, -2.42919187900551333E+05, + E 1.31176361466297720E+06, -2.99801591853810675E+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.76327129765640400E+06, -2.81356322658653411E+06, + 4 1.26836527332162478E+06, -3.31645172484563578E+05, + 5 4.52187689813627263E+04, -2.49983048181120962E+03, + 6 2.43805296995560639E+01, 3.28446985307203782E+06, + 7 -1.97068191184322269E+07, 5.09526024926646422E+07, + 8 -7.41051482115326577E+07, 6.63445122747290267E+07, + 9 -3.75671766607633513E+07, 1.32887671664218183E+07, + A -2.78561812808645469E+06, 3.08186404612662398E+05, + B -1.38860897537170405E+04, 1.10017140269246738E+02, + C -4.93292536645099620E+07, 3.25573074185765749E+08, + D -9.39462359681578403E+08, 1.55359689957058006E+09, + E -1.62108055210833708E+09, 1.10684281682301447E+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.95889784275030309E+08, 1.42062907797533095E+08, + 4 -2.44740627257387285E+07, 2.24376817792244943E+06, + 5 -8.40054336030240853E+04, 5.51335896122020586E+02, + 6 8.14789096118312115E+08, -5.86648149205184723E+09, + 7 1.86882075092958249E+10, -3.46320433881587779E+10, + 8 4.12801855797539740E+10, -3.30265997498007231E+10, + 9 1.79542137311556001E+10, -6.56329379261928433E+09, + A 1.55927986487925751E+09, -2.25105661889415278E+08, + B 1.73951075539781645E+07, -5.49842327572288687E+05, + C 3.03809051092238427E+03, -1.46792612476956167E+10, + D 1.14498237732025810E+11, -3.99096175224466498E+11, + E 8.19218669548577329E+11, -1.09837515608122331E+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.00815810686538209E+12, -6.45364869245376503E+11, + 4 2.87900649906150589E+11, -8.78670721780232657E+10, + 5 1.76347306068349694E+10, -2.16716498322379509E+09, + 6 1.43157876718888981E+08, -3.87183344257261262E+06, + 7 1.82577554742931747E+04, 2.86464035717679043E+11, + 8 -2.40629790002850396E+12, 9.10934118523989896E+12, + 9 -2.05168994109344374E+13, 3.05651255199353206E+13, + A -3.16670885847851584E+13, 2.33483640445818409E+13, + B -1.23204913055982872E+13, 4.61272578084913197E+12, + C -1.19655288019618160E+12, 2.05914503232410016E+11, + D -2.18229277575292237E+10, 1.24700929351271032E+09/ + DATA C(119), C(120)/ + 1 -2.91883881222208134E+07, 1.18838426256783253E+05/ +C + IF (INIT.NE.0) GO TO 40 +C----------------------------------------------------------------------- +C INITIALIZE ALL VARIABLES +C----------------------------------------------------------------------- + RFN = 1.0E0/FNU + CRFN = CMPLX(RFN,0.0E0) +C T = ZR*CRFN +C----------------------------------------------------------------------- +C OVERFLOW TEST (ZR/FNU TOO SMALL) +C----------------------------------------------------------------------- + TSTR = REAL(ZR) + TSTI = AIMAG(ZR) + TEST = R1MACH(1)*1.0E+3 + AC = FNU*TEST + IF (ABS(TSTR).GT.AC .OR. ABS(TSTI).GT.AC) GO TO 15 + AC = 2.0E0*ABS(ALOG(TEST))+FNU + ZETA1 = CMPLX(AC,0.0E0) + ZETA2 = CMPLX(FNU,0.0E0) + PHI=CONE + RETURN + 15 CONTINUE + T=ZR*CRFN + S = CONE + T*T + SR = CSQRT(S) + CFN = CMPLX(FNU,0.0E0) + ZN = (CONE+SR)/T + ZETA1 = CFN*CLOG(ZN) + ZETA2 = CFN*SR + T = CONE/SR + SR = T*CRFN + CWRK(16) = CSQRT(SR) + PHI = CWRK(16)*CON(IKFLG) + IF (IPMTR.NE.0) RETURN + T2 = CONE/S + CWRK(1) = CONE + CRFN = CONE + AC = 1.0E0 + L = 1 + DO 20 K=2,15 + S = CZERO + DO 10 J=1,K + L = L + 1 + S = S*T2 + CMPLX(C(L),0.0E0) + 10 CONTINUE + CRFN = CRFN*SR + CWRK(K) = CRFN*S + AC = AC*RFN + TSTR = REAL(CWRK(K)) + TSTI = AIMAG(CWRK(K)) + TEST = ABS(TSTR) + ABS(TSTI) + 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----------------------------------------------------------------------- + S = CZERO + DO 50 I=1,INIT + S = S + CWRK(I) + 50 CONTINUE + SUM = S + PHI = CWRK(16)*CON(1) + RETURN + 60 CONTINUE +C----------------------------------------------------------------------- +C COMPUTE SUM FOR THE K FUNCTION +C----------------------------------------------------------------------- + S = CZERO + T = CONE + DO 70 I=1,INIT + S = S + T*CWRK(I) + T = -T + 70 CONTINUE + SUM = S + PHI = CWRK(16)*CON(2) + RETURN + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/amos/cunk1.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,343 @@ + SUBROUTINE CUNK1(Z, FNU, KODE, MR, N, Y, NZ, TOL, ELIM, ALIM) +C***BEGIN PROLOGUE CUNK1 +C***REFER TO CBESK +C +C CUNK1 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 CS1S2,CUCHK,CUNIK,R1MACH +C***END PROLOGUE CUNK1 + COMPLEX CFN, CK, CONE, CRSC, CS, CSCL, CSGN, CSPN, CSR, CSS, + * CWRK, CY, CZERO, C1, C2, PHI, RZ, SUM, S1, S2, Y, Z, + * ZETA1, ZETA2, ZR, PHID, ZETA1D, ZETA2D, SUMD + REAL ALIM, ANG, APHI, ASC, ASCLE, BRY, CPN, C2I, C2M, C2R, ELIM, + * FMR, FN, FNF, FNU, PI, RS1, SGN, SPN, TOL, X, R1MACH + INTEGER I, IB, IFLAG, IFN, IL, INIT, INU, IUF, K, KDFLG, KFLAG, + * KK, KODE, MR, N, NW, NZ, J, IPARD, INITD, IC + DIMENSION BRY(3), INIT(2), Y(N), SUM(2), PHI(2), ZETA1(2), + * ZETA2(2), CY(2), CWRK(16,3), CSS(3), CSR(3) + DATA CZERO, CONE / (0.0E0,0.0E0) , (1.0E0,0.0E0) / + DATA PI / 3.14159265358979324E0 / +C + KDFLG = 1 + NZ = 0 +C----------------------------------------------------------------------- +C EXP(-ALIM)=EXP(-ELIM)/TOL=APPROX. ONE PRECISION GREATER THAN +C THE UNDERFLOW LIMIT +C----------------------------------------------------------------------- + CSCL = CMPLX(1.0E0/TOL,0.0E0) + CRSC = CMPLX(TOL,0.0E0) + CSS(1) = CSCL + CSS(2) = CONE + CSS(3) = CRSC + CSR(1) = CRSC + CSR(2) = CONE + CSR(3) = CSCL + BRY(1) = 1.0E+3*R1MACH(1)/TOL + BRY(2) = 1.0E0/BRY(1) + BRY(3) = R1MACH(2) + X = REAL(Z) + ZR = Z + IF (X.LT.0.0E0) ZR = -Z + 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 + FLOAT(I-1) + INIT(J) = 0 + CALL CUNIK(ZR, FN, 2, 0, TOL, INIT(J), PHI(J), ZETA1(J), + * ZETA2(J), SUM(J), CWRK(1,J)) + IF (KODE.EQ.1) GO TO 20 + CFN = CMPLX(FN,0.0E0) + S1 = ZETA1(J) - CFN*(CFN/(ZR+ZETA2(J))) + GO TO 30 + 20 CONTINUE + S1 = ZETA1(J) - ZETA2(J) + 30 CONTINUE +C----------------------------------------------------------------------- +C TEST FOR UNDERFLOW AND OVERFLOW +C----------------------------------------------------------------------- + RS1 = REAL(S1) + IF (ABS(RS1).GT.ELIM) GO TO 60 + IF (KDFLG.EQ.1) KFLAG = 2 + IF (ABS(RS1).LT.ALIM) GO TO 40 +C----------------------------------------------------------------------- +C REFINE TEST AND SCALE +C----------------------------------------------------------------------- + APHI = CABS(PHI(J)) + RS1 = RS1 + ALOG(APHI) + IF (ABS(RS1).GT.ELIM) GO TO 60 + IF (KDFLG.EQ.1) KFLAG = 1 + IF (RS1.LT.0.0E0) 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----------------------------------------------------------------------- + S2 = PHI(J)*SUM(J) + C2R = REAL(S1) + C2I = AIMAG(S1) + C2M = EXP(C2R)*REAL(CSS(KFLAG)) + S1 = CMPLX(C2M,0.0E0)*CMPLX(COS(C2I),SIN(C2I)) + S2 = S2*S1 + IF (KFLAG.NE.1) GO TO 50 + CALL CUCHK(S2, NW, BRY(1), TOL) + IF (NW.NE.0) GO TO 60 + 50 CONTINUE + CY(KDFLG) = S2 + Y(I) = S2*CSR(KFLAG) + IF (KDFLG.EQ.2) GO TO 75 + KDFLG = 2 + GO TO 70 + 60 CONTINUE + IF (RS1.GT.0.0E0) GO TO 290 +C----------------------------------------------------------------------- +C FOR X.LT.0.0, THE I FUNCTION TO BE ADDED WILL OVERFLOW +C----------------------------------------------------------------------- + IF (X.LT.0.0E0) GO TO 290 + KDFLG = 1 + Y(I) = CZERO + NZ=NZ+1 + IF (I.EQ.1) GO TO 70 + IF (Y(I-1).EQ.CZERO) GO TO 70 + Y(I-1) = CZERO + NZ=NZ+1 + 70 CONTINUE + I=N + 75 CONTINUE + RZ = CMPLX(2.0E0,0.0E0)/ZR + CK = CMPLX(FN,0.0E0)*RZ + 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+FLOAT(N-1) + IPARD = 1 + IF (MR.NE.0) IPARD = 0 + INITD = 0 + CALL CUNIK(ZR,FN,2,IPARD,TOL,INITD,PHID,ZETA1D,ZETA2D,SUMD, + *CWRK(1,3)) + IF (KODE.EQ.1) GO TO 80 + CFN=CMPLX(FN,0.0E0) + S1=ZETA1D-CFN*(CFN/(ZR+ZETA2D)) + GO TO 90 + 80 CONTINUE + S1=ZETA1D-ZETA2D + 90 CONTINUE + RS1=REAL(S1) + IF (ABS(RS1).GT.ELIM) GO TO 95 + IF (ABS(RS1).LT.ALIM) GO TO 100 +C----------------------------------------------------------------------- +C REFINE ESTIMATE AND TEST +C----------------------------------------------------------------------- + APHI=CABS(PHID) + RS1=RS1+ALOG(APHI) + IF (ABS(RS1).LT.ELIM) GO TO 100 + 95 CONTINUE + IF (RS1.GT.0.0E0) GO TO 290 +C----------------------------------------------------------------------- +C FOR X.LT.0.0, THE I FUNCTION TO BE ADDED WILL OVERFLOW +C----------------------------------------------------------------------- + IF (X.LT.0.0E0) GO TO 290 + NZ=N + DO 96 I=1,N + Y(I) = CZERO + 96 CONTINUE + RETURN + 100 CONTINUE +C----------------------------------------------------------------------- +C RECUR FORWARD FOR REMAINDER OF THE SEQUENCE +C----------------------------------------------------------------------- + S1 = CY(1) + S2 = CY(2) + C1 = CSR(KFLAG) + ASCLE = BRY(KFLAG) + DO 120 I=IB,N + C2 = S2 + S2 = CK*S2 + S1 + S1 = C2 + CK = CK + RZ + C2 = S2*C1 + Y(I) = C2 + IF (KFLAG.GE.3) GO TO 120 + C2R = REAL(C2) + C2I = AIMAG(C2) + C2R = ABS(C2R) + C2I = ABS(C2I) + C2M = AMAX1(C2R,C2I) + IF (C2M.LE.ASCLE) GO TO 120 + KFLAG = KFLAG + 1 + ASCLE = BRY(KFLAG) + S1 = S1*C1 + S2 = C2 + S1 = S1*CSS(KFLAG) + S2 = S2*CSS(KFLAG) + C1 = CSR(KFLAG) + 120 CONTINUE + 160 CONTINUE + IF (MR.EQ.0) RETURN +C----------------------------------------------------------------------- +C ANALYTIC CONTINUATION FOR RE(Z).LT.0.0E0 +C----------------------------------------------------------------------- + NZ = 0 + FMR = FLOAT(MR) + SGN = -SIGN(PI,FMR) +C----------------------------------------------------------------------- +C CSPN AND CSGN ARE COEFF OF K AND I FUNCIONS RESP. +C----------------------------------------------------------------------- + CSGN = CMPLX(0.0E0,SGN) + INU = INT(FNU) + FNF = FNU - FLOAT(INU) + IFN = INU + N - 1 + ANG = FNF*SGN + CPN = COS(ANG) + SPN = SIN(ANG) + CSPN = CMPLX(CPN,SPN) + IF (MOD(IFN,2).EQ.1) CSPN = -CSPN + ASC = BRY(1) + KK = N + IUF = 0 + KDFLG = 1 + IB = IB-1 + IC = IB-1 + DO 260 K=1,N + FN = FNU + 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 + 170 CONTINUE + INITD = INIT(J) + PHID = PHI(J) + ZETA1D = ZETA1(J) + ZETA2D = ZETA2(J) + SUMD = SUM(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 170 + INITD = 0 + 180 CONTINUE + CALL CUNIK(ZR, FN, 1, 0, TOL, INITD, PHID, ZETA1D, + * ZETA2D, SUMD, CWRK(1,M)) + IF (KODE.EQ.1) GO TO 190 + CFN = CMPLX(FN,0.0E0) + S1 = -ZETA1D + CFN*(CFN/(ZR+ZETA2D)) + GO TO 200 + 190 CONTINUE + S1 = -ZETA1D + ZETA2D + 200 CONTINUE +C----------------------------------------------------------------------- +C TEST FOR UNDERFLOW AND OVERFLOW +C----------------------------------------------------------------------- + RS1 = REAL(S1) + IF (ABS(RS1).GT.ELIM) GO TO 250 + IF (KDFLG.EQ.1) IFLAG = 2 + IF (ABS(RS1).LT.ALIM) GO TO 210 +C----------------------------------------------------------------------- +C REFINE TEST AND SCALE +C----------------------------------------------------------------------- + APHI = CABS(PHID) + RS1 = RS1 + ALOG(APHI) + IF (ABS(RS1).GT.ELIM) GO TO 250 + IF (KDFLG.EQ.1) IFLAG = 1 + IF (RS1.LT.0.0E0) GO TO 210 + IF (KDFLG.EQ.1) IFLAG = 3 + 210 CONTINUE + S2 = CSGN*PHID*SUMD + C2R = REAL(S1) + C2I = AIMAG(S1) + C2M = EXP(C2R)*REAL(CSS(IFLAG)) + S1 = CMPLX(C2M,0.0E0)*CMPLX(COS(C2I),SIN(C2I)) + S2 = S2*S1 + IF (IFLAG.NE.1) GO TO 220 + CALL CUCHK(S2, NW, BRY(1), TOL) + IF (NW.NE.0) S2 = CMPLX(0.0E0,0.0E0) + 220 CONTINUE + CY(KDFLG) = S2 + C2 = S2 + S2 = S2*CSR(IFLAG) +C----------------------------------------------------------------------- +C ADD I AND K FUNCTIONS, K SEQUENCE IN Y(I), I=1,N +C----------------------------------------------------------------------- + S1 = Y(KK) + IF (KODE.EQ.1) GO TO 240 + CALL CS1S2(ZR, S1, S2, NW, ASC, ALIM, IUF) + NZ = NZ + NW + 240 CONTINUE + Y(KK) = S1*CSPN + S2 + KK = KK - 1 + CSPN = -CSPN + IF (C2.NE.CZERO) GO TO 245 + KDFLG = 1 + GO TO 260 + 245 CONTINUE + IF (KDFLG.EQ.2) GO TO 265 + KDFLG = 2 + GO TO 260 + 250 CONTINUE + IF (RS1.GT.0.0E0) GO TO 290 + S2 = CZERO + GO TO 220 + 260 CONTINUE + K = N + 265 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----------------------------------------------------------------------- + S1 = CY(1) + S2 = CY(2) + CS = CSR(IFLAG) + ASCLE = BRY(IFLAG) + FN = FLOAT(INU+IL) + DO 280 I=1,IL + C2 = S2 + S2 = S1 + CMPLX(FN+FNF,0.0E0)*RZ*S2 + S1 = C2 + FN = FN - 1.0E0 + C2 = S2*CS + CK = C2 + C1 = Y(KK) + IF (KODE.EQ.1) GO TO 270 + CALL CS1S2(ZR, C1, C2, NW, ASC, ALIM, IUF) + NZ = NZ + NW + 270 CONTINUE + Y(KK) = C1*CSPN + C2 + KK = KK - 1 + CSPN = -CSPN + IF (IFLAG.GE.3) GO TO 280 + C2R = REAL(CK) + C2I = AIMAG(CK) + C2R = ABS(C2R) + C2I = ABS(C2I) + C2M = AMAX1(C2R,C2I) + IF (C2M.LE.ASCLE) GO TO 280 + IFLAG = IFLAG + 1 + ASCLE = BRY(IFLAG) + S1 = S1*CS + S2 = CK + S1 = S1*CSS(IFLAG) + S2 = S2*CSS(IFLAG) + CS = CSR(IFLAG) + 280 CONTINUE + RETURN + 290 CONTINUE + NZ = -1 + RETURN + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/amos/cunk2.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,393 @@ + SUBROUTINE CUNK2(Z, FNU, KODE, MR, N, Y, NZ, TOL, ELIM, ALIM) +C***BEGIN PROLOGUE CUNK2 +C***REFER TO CBESK +C +C CUNK2 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 CAIRY,CS1S2,CUCHK,CUNHJ,R1MACH +C***END PROLOGUE CUNK2 + COMPLEX AI, ARG, ASUM, BSUM, CFN, CI, CIP, + * CK, CONE, CRSC, CR1, CR2, CS, CSCL, CSGN, CSPN, CSR, CSS, CY, + * CZERO, C1, C2, DAI, PHI, RZ, S1, S2, Y, Z, ZB, ZETA1, + * ZETA2, ZN, ZR, PHID, ARGD, ZETA1D, ZETA2D, ASUMD, BSUMD + REAL AARG, AIC, ALIM, ANG, APHI, ASC, ASCLE, BRY, CAR, CPN, C2I, + * C2M, C2R, ELIM, FMR, FN, FNF, FNU, HPI, PI, RS1, SAR, SGN, SPN, + * TOL, X, YY, R1MACH + 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), Y(N), ASUM(2), BSUM(2), PHI(2), ARG(2), + * ZETA1(2), ZETA2(2), CY(2), CIP(4), CSS(3), CSR(3) + DATA CZERO, CONE, CI, CR1, CR2 / + 1 (0.0E0,0.0E0),(1.0E0,0.0E0),(0.0E0,1.0E0), + 1(1.0E0,1.73205080756887729E0),(-0.5E0,-8.66025403784438647E-01)/ + DATA HPI, PI, AIC / + 1 1.57079632679489662E+00, 3.14159265358979324E+00, + 1 1.26551212348464539E+00/ + DATA CIP(1),CIP(2),CIP(3),CIP(4)/ + 1 (1.0E0,0.0E0), (0.0E0,-1.0E0), (-1.0E0,0.0E0), (0.0E0,1.0E0)/ +C + KDFLG = 1 + NZ = 0 +C----------------------------------------------------------------------- +C EXP(-ALIM)=EXP(-ELIM)/TOL=APPROX. ONE PRECISION GREATER THAN +C THE UNDERFLOW LIMIT +C----------------------------------------------------------------------- + CSCL = CMPLX(1.0E0/TOL,0.0E0) + CRSC = CMPLX(TOL,0.0E0) + CSS(1) = CSCL + CSS(2) = CONE + CSS(3) = CRSC + CSR(1) = CRSC + CSR(2) = CONE + CSR(3) = CSCL + BRY(1) = 1.0E+3*R1MACH(1)/TOL + BRY(2) = 1.0E0/BRY(1) + BRY(3) = R1MACH(2) + X = REAL(Z) + ZR = Z + IF (X.LT.0.0E0) ZR = -Z + YY = AIMAG(ZR) + ZN = -ZR*CI + ZB = ZR + INU = INT(FNU) + FNF = FNU - FLOAT(INU) + ANG = -HPI*FNF + CAR = COS(ANG) + SAR = SIN(ANG) + CPN = -HPI*CAR + SPN = -HPI*SAR + C2 = CMPLX(-SPN,CPN) + KK = MOD(INU,4) + 1 + CS = CR1*C2*CIP(KK) + IF (YY.GT.0.0E0) GO TO 10 + ZN = CONJG(-ZN) + ZB = CONJG(ZB) + 10 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 70 I=1,N +C----------------------------------------------------------------------- +C J FLIP FLOPS BETWEEN 1 AND 2 IN J = 3 - J +C----------------------------------------------------------------------- + J = 3 - J + FN = FNU + FLOAT(I-1) + CALL CUNHJ(ZN, FN, 0, TOL, PHI(J), ARG(J), ZETA1(J), ZETA2(J), + * ASUM(J), BSUM(J)) + IF (KODE.EQ.1) GO TO 20 + CFN = CMPLX(FN,0.0E0) + S1 = ZETA1(J) - CFN*(CFN/(ZB+ZETA2(J))) + GO TO 30 + 20 CONTINUE + S1 = ZETA1(J) - ZETA2(J) + 30 CONTINUE +C----------------------------------------------------------------------- +C TEST FOR UNDERFLOW AND OVERFLOW +C----------------------------------------------------------------------- + RS1 = REAL(S1) + IF (ABS(RS1).GT.ELIM) GO TO 60 + IF (KDFLG.EQ.1) KFLAG = 2 + IF (ABS(RS1).LT.ALIM) GO TO 40 +C----------------------------------------------------------------------- +C REFINE TEST AND SCALE +C----------------------------------------------------------------------- + APHI = CABS(PHI(J)) + AARG = CABS(ARG(J)) + RS1 = RS1 + ALOG(APHI) - 0.25E0*ALOG(AARG) - AIC + IF (ABS(RS1).GT.ELIM) GO TO 60 + IF (KDFLG.EQ.1) KFLAG = 1 + IF (RS1.LT.0.0E0) 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----------------------------------------------------------------------- + C2 = ARG(J)*CR2 + CALL CAIRY(C2, 0, 2, AI, NAI, IDUM) + CALL CAIRY(C2, 1, 2, DAI, NDAI, IDUM) + S2 = CS*PHI(J)*(AI*ASUM(J)+CR2*DAI*BSUM(J)) + C2R = REAL(S1) + C2I = AIMAG(S1) + C2M = EXP(C2R)*REAL(CSS(KFLAG)) + S1 = CMPLX(C2M,0.0E0)*CMPLX(COS(C2I),SIN(C2I)) + S2 = S2*S1 + IF (KFLAG.NE.1) GO TO 50 + CALL CUCHK(S2, NW, BRY(1), TOL) + IF (NW.NE.0) GO TO 60 + 50 CONTINUE + IF (YY.LE.0.0E0) S2 = CONJG(S2) + CY(KDFLG) = S2 + Y(I) = S2*CSR(KFLAG) + CS = -CI*CS + IF (KDFLG.EQ.2) GO TO 75 + KDFLG = 2 + GO TO 70 + 60 CONTINUE + IF (RS1.GT.0.0E0) GO TO 300 +C----------------------------------------------------------------------- +C FOR X.LT.0.0, THE I FUNCTION TO BE ADDED WILL OVERFLOW +C----------------------------------------------------------------------- + IF (X.LT.0.0E0) GO TO 300 + KDFLG = 1 + Y(I) = CZERO + CS = -CI*CS + NZ=NZ+1 + IF (I.EQ.1) GO TO 70 + IF (Y(I-1).EQ.CZERO) GO TO 70 + Y(I-1) = CZERO + NZ=NZ+1 + 70 CONTINUE + I=N + 75 CONTINUE + RZ = CMPLX(2.0E0,0.0E0)/ZR + CK = CMPLX(FN,0.0E0)*RZ + IB = I + 1 + IF (N.LT.IB) GO TO 170 +C----------------------------------------------------------------------- +C TEST LAST MEMBER FOR UNDERFLOW AND OVERFLOW, SET SEQUENCE TO ZERO +C ON UNDERFLOW +C----------------------------------------------------------------------- + FN = FNU+FLOAT(N-1) + IPARD = 1 + IF (MR.NE.0) IPARD = 0 + CALL CUNHJ(ZN,FN,IPARD,TOL,PHID,ARGD,ZETA1D,ZETA2D,ASUMD,BSUMD) + IF (KODE.EQ.1) GO TO 80 + CFN=CMPLX(FN,0.0E0) + S1=ZETA1D-CFN*(CFN/(ZB+ZETA2D)) + GO TO 90 + 80 CONTINUE + S1=ZETA1D-ZETA2D + 90 CONTINUE + RS1=REAL(S1) + IF (ABS(RS1).GT.ELIM) GO TO 95 + IF (ABS(RS1).LT.ALIM) GO TO 100 +C----------------------------------------------------------------------- +C REFINE ESTIMATE AND TEST +C----------------------------------------------------------------------- + APHI=CABS(PHID) + AARG = CABS(ARGD) + RS1=RS1+ALOG(APHI)-0.25E0*ALOG(AARG)-AIC + IF (ABS(RS1).LT.ELIM) GO TO 100 + 95 CONTINUE + IF (RS1.GT.0.0E0) GO TO 300 +C----------------------------------------------------------------------- +C FOR X.LT.0.0, THE I FUNCTION TO BE ADDED WILL OVERFLOW +C----------------------------------------------------------------------- + IF (X.LT.0.0E0) GO TO 300 + NZ=N + DO 96 I=1,N + Y(I) = CZERO + 96 CONTINUE + RETURN + 100 CONTINUE +C----------------------------------------------------------------------- +C SCALED FORWARD RECURRENCE FOR REMAINDER OF THE SEQUENCE +C----------------------------------------------------------------------- + S1 = CY(1) + S2 = CY(2) + C1 = CSR(KFLAG) + ASCLE = BRY(KFLAG) + DO 120 I=IB,N + C2 = S2 + S2 = CK*S2 + S1 + S1 = C2 + CK = CK + RZ + C2 = S2*C1 + Y(I) = C2 + IF (KFLAG.GE.3) GO TO 120 + C2R = REAL(C2) + C2I = AIMAG(C2) + C2R = ABS(C2R) + C2I = ABS(C2I) + C2M = AMAX1(C2R,C2I) + IF (C2M.LE.ASCLE) GO TO 120 + KFLAG = KFLAG + 1 + ASCLE = BRY(KFLAG) + S1 = S1*C1 + S2 = C2 + S1 = S1*CSS(KFLAG) + S2 = S2*CSS(KFLAG) + C1 = CSR(KFLAG) + 120 CONTINUE + 170 CONTINUE + IF (MR.EQ.0) RETURN +C----------------------------------------------------------------------- +C ANALYTIC CONTINUATION FOR RE(Z).LT.0.0E0 +C----------------------------------------------------------------------- + NZ = 0 + FMR = FLOAT(MR) + SGN = -SIGN(PI,FMR) +C----------------------------------------------------------------------- +C CSPN AND CSGN ARE COEFF OF K AND I FUNCTIONS RESP. +C----------------------------------------------------------------------- + CSGN = CMPLX(0.0E0,SGN) + IF (YY.LE.0.0E0) CSGN = CONJG(CSGN) + IFN = INU + N - 1 + ANG = FNF*SGN + CPN = COS(ANG) + SPN = SIN(ANG) + CSPN = CMPLX(CPN,SPN) + IF (MOD(IFN,2).EQ.1) CSPN = -CSPN +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----------------------------------------------------------------------- + CS = CMPLX(CAR,-SAR)*CSGN + IN = MOD(IFN,4) + 1 + C2 = CIP(IN) + CS = CS*CONJG(C2) + ASC = BRY(1) + KK = N + KDFLG = 1 + IB = IB-1 + IC = IB-1 + IUF = 0 + DO 270 K=1,N +C----------------------------------------------------------------------- +C LOGIC TO SORT OUT CASES WHOSE PARAMETERS WERE SET FOR THE K +C FUNCTION ABOVE +C----------------------------------------------------------------------- + FN = FNU+FLOAT(KK-1) + IF (N.GT.2) GO TO 180 + 175 CONTINUE + PHID = PHI(J) + ARGD = ARG(J) + ZETA1D = ZETA1(J) + ZETA2D = ZETA2(J) + ASUMD = ASUM(J) + BSUMD = BSUM(J) + J = 3 - J + GO TO 190 + 180 CONTINUE + IF ((KK.EQ.N).AND.(IB.LT.N)) GO TO 190 + IF ((KK.EQ.IB).OR.(KK.EQ.IC)) GO TO 175 + CALL CUNHJ(ZN, FN, 0, TOL, PHID, ARGD, ZETA1D, ZETA2D, + * ASUMD, BSUMD) + 190 CONTINUE + IF (KODE.EQ.1) GO TO 200 + CFN = CMPLX(FN,0.0E0) + S1 = -ZETA1D + CFN*(CFN/(ZB+ZETA2D)) + GO TO 210 + 200 CONTINUE + S1 = -ZETA1D + ZETA2D + 210 CONTINUE +C----------------------------------------------------------------------- +C TEST FOR UNDERFLOW AND OVERFLOW +C----------------------------------------------------------------------- + RS1 = REAL(S1) + IF (ABS(RS1).GT.ELIM) GO TO 260 + IF (KDFLG.EQ.1) IFLAG = 2 + IF (ABS(RS1).LT.ALIM) GO TO 220 +C----------------------------------------------------------------------- +C REFINE TEST AND SCALE +C----------------------------------------------------------------------- + APHI = CABS(PHID) + AARG = CABS(ARGD) + RS1 = RS1 + ALOG(APHI) - 0.25E0*ALOG(AARG) - AIC + IF (ABS(RS1).GT.ELIM) GO TO 260 + IF (KDFLG.EQ.1) IFLAG = 1 + IF (RS1.LT.0.0E0) GO TO 220 + IF (KDFLG.EQ.1) IFLAG = 3 + 220 CONTINUE + CALL CAIRY(ARGD, 0, 2, AI, NAI, IDUM) + CALL CAIRY(ARGD, 1, 2, DAI, NDAI, IDUM) + S2 = CS*PHID*(AI*ASUMD+DAI*BSUMD) + C2R = REAL(S1) + C2I = AIMAG(S1) + C2M = EXP(C2R)*REAL(CSS(IFLAG)) + S1 = CMPLX(C2M,0.0E0)*CMPLX(COS(C2I),SIN(C2I)) + S2 = S2*S1 + IF (IFLAG.NE.1) GO TO 230 + CALL CUCHK(S2, NW, BRY(1), TOL) + IF (NW.NE.0) S2 = CMPLX(0.0E0,0.0E0) + 230 CONTINUE + IF (YY.LE.0.0E0) S2 = CONJG(S2) + CY(KDFLG) = S2 + C2 = S2 + S2 = S2*CSR(IFLAG) +C----------------------------------------------------------------------- +C ADD I AND K FUNCTIONS, K SEQUENCE IN Y(I), I=1,N +C----------------------------------------------------------------------- + S1 = Y(KK) + IF (KODE.EQ.1) GO TO 250 + CALL CS1S2(ZR, S1, S2, NW, ASC, ALIM, IUF) + NZ = NZ + NW + 250 CONTINUE + Y(KK) = S1*CSPN + S2 + KK = KK - 1 + CSPN = -CSPN + CS = -CS*CI + IF (C2.NE.CZERO) 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.0E0) GO TO 300 + S2 = CZERO + 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----------------------------------------------------------------------- + S1 = CY(1) + S2 = CY(2) + CS = CSR(IFLAG) + ASCLE = BRY(IFLAG) + FN = FLOAT(INU+IL) + DO 290 I=1,IL + C2 = S2 + S2 = S1 + CMPLX(FN+FNF,0.0E0)*RZ*S2 + S1 = C2 + FN = FN - 1.0E0 + C2 = S2*CS + CK = C2 + C1 = Y(KK) + IF (KODE.EQ.1) GO TO 280 + CALL CS1S2(ZR, C1, C2, NW, ASC, ALIM, IUF) + NZ = NZ + NW + 280 CONTINUE + Y(KK) = C1*CSPN + C2 + KK = KK - 1 + CSPN = -CSPN + IF (IFLAG.GE.3) GO TO 290 + C2R = REAL(CK) + C2I = AIMAG(CK) + C2R = ABS(C2R) + C2I = ABS(C2I) + C2M = AMAX1(C2R,C2I) + IF (C2M.LE.ASCLE) GO TO 290 + IFLAG = IFLAG + 1 + ASCLE = BRY(IFLAG) + S1 = S1*CS + S2 = CK + S1 = S1*CSS(IFLAG) + S2 = S2*CSS(IFLAG) + CS = CSR(IFLAG) + 290 CONTINUE + RETURN + 300 CONTINUE + NZ = -1 + RETURN + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/amos/cuoik.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,159 @@ + SUBROUTINE CUOIK(Z, FNU, KODE, IKFLG, N, Y, NUF, TOL, ELIM, ALIM) +C***BEGIN PROLOGUE CUOIK +C***REFER TO CBESI,CBESK,CBESH +C +C CUOIK 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 CUCHK,CUNHJ,CUNIK,R1MACH +C***END PROLOGUE CUOIK + COMPLEX ARG, ASUM, BSUM, CWRK, CZ, CZERO, PHI, SUM, Y, Z, ZB, + * ZETA1, ZETA2, ZN, ZR + REAL AARG, AIC, ALIM, APHI, ASCLE, AX, AY, ELIM, FNN, FNU, GNN, + * GNU, RCZ, TOL, X, YY + INTEGER I, IFORM, IKFLG, INIT, KODE, N, NN, NUF, NW + DIMENSION Y(N), CWRK(16) + DATA CZERO / (0.0E0,0.0E0) / + DATA AIC / 1.265512123484645396E+00 / + NUF = 0 + NN = N + X = REAL(Z) + ZR = Z + IF (X.LT.0.0E0) ZR = -Z + ZB = ZR + YY = AIMAG(ZR) + AX = ABS(X)*1.7321E0 + AY = ABS(YY) + IFORM = 1 + IF (AY.GT.AX) IFORM = 2 + GNU = AMAX1(FNU,1.0E0) + IF (IKFLG.EQ.1) GO TO 10 + FNN = FLOAT(NN) + GNN = FNU + FNN - 1.0E0 + GNU = AMAX1(GNN,FNN) + 10 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 20 + INIT = 0 + CALL CUNIK(ZR, GNU, IKFLG, 1, TOL, INIT, PHI, ZETA1, ZETA2, SUM, + * CWRK) + CZ = -ZETA1 + ZETA2 + GO TO 40 + 20 CONTINUE + ZN = -ZR*CMPLX(0.0E0,1.0E0) + IF (YY.GT.0.0E0) GO TO 30 + ZN = CONJG(-ZN) + 30 CONTINUE + CALL CUNHJ(ZN, GNU, 1, TOL, PHI, ARG, ZETA1, ZETA2, ASUM, BSUM) + CZ = -ZETA1 + ZETA2 + AARG = CABS(ARG) + 40 CONTINUE + IF (KODE.EQ.2) CZ = CZ - ZB + IF (IKFLG.EQ.2) CZ = -CZ + APHI = CABS(PHI) + RCZ = REAL(CZ) +C----------------------------------------------------------------------- +C OVERFLOW TEST +C----------------------------------------------------------------------- + IF (RCZ.GT.ELIM) GO TO 170 + IF (RCZ.LT.ALIM) GO TO 50 + RCZ = RCZ + ALOG(APHI) + IF (IFORM.EQ.2) RCZ = RCZ - 0.25E0*ALOG(AARG) - AIC + IF (RCZ.GT.ELIM) GO TO 170 + GO TO 100 + 50 CONTINUE +C----------------------------------------------------------------------- +C UNDERFLOW TEST +C----------------------------------------------------------------------- + IF (RCZ.LT.(-ELIM)) GO TO 60 + IF (RCZ.GT.(-ALIM)) GO TO 100 + RCZ = RCZ + ALOG(APHI) + IF (IFORM.EQ.2) RCZ = RCZ - 0.25E0*ALOG(AARG) - AIC + IF (RCZ.GT.(-ELIM)) GO TO 80 + 60 CONTINUE + DO 70 I=1,NN + Y(I) = CZERO + 70 CONTINUE + NUF = NN + RETURN + 80 CONTINUE + ASCLE = 1.0E+3*R1MACH(1)/TOL + CZ = CZ + CLOG(PHI) + IF (IFORM.EQ.1) GO TO 90 + CZ = CZ - CMPLX(0.25E0,0.0E0)*CLOG(ARG) - CMPLX(AIC,0.0E0) + 90 CONTINUE + AX = EXP(RCZ)/TOL + AY = AIMAG(CZ) + CZ = CMPLX(AX,0.0E0)*CMPLX(COS(AY),SIN(AY)) + CALL CUCHK(CZ, NW, ASCLE, TOL) + IF (NW.EQ.1) GO TO 60 + 100 CONTINUE + IF (IKFLG.EQ.2) RETURN + IF (N.EQ.1) RETURN +C----------------------------------------------------------------------- +C SET UNDERFLOWS ON I SEQUENCE +C----------------------------------------------------------------------- + 110 CONTINUE + GNU = FNU + FLOAT(NN-1) + IF (IFORM.EQ.2) GO TO 120 + INIT = 0 + CALL CUNIK(ZR, GNU, IKFLG, 1, TOL, INIT, PHI, ZETA1, ZETA2, SUM, + * CWRK) + CZ = -ZETA1 + ZETA2 + GO TO 130 + 120 CONTINUE + CALL CUNHJ(ZN, GNU, 1, TOL, PHI, ARG, ZETA1, ZETA2, ASUM, BSUM) + CZ = -ZETA1 + ZETA2 + AARG = CABS(ARG) + 130 CONTINUE + IF (KODE.EQ.2) CZ = CZ - ZB + APHI = CABS(PHI) + RCZ = REAL(CZ) + IF (RCZ.LT.(-ELIM)) GO TO 140 + IF (RCZ.GT.(-ALIM)) RETURN + RCZ = RCZ + ALOG(APHI) + IF (IFORM.EQ.2) RCZ = RCZ - 0.25E0*ALOG(AARG) - AIC + IF (RCZ.GT.(-ELIM)) GO TO 150 + 140 CONTINUE + Y(NN) = CZERO + NN = NN - 1 + NUF = NUF + 1 + IF (NN.EQ.0) RETURN + GO TO 110 + 150 CONTINUE + ASCLE = 1.0E+3*R1MACH(1)/TOL + CZ = CZ + CLOG(PHI) + IF (IFORM.EQ.1) GO TO 160 + CZ = CZ - CMPLX(0.25E0,0.0E0)*CLOG(ARG) - CMPLX(AIC,0.0E0) + 160 CONTINUE + AX = EXP(RCZ)/TOL + AY = AIMAG(CZ) + CZ = CMPLX(AX,0.0E0)*CMPLX(COS(AY),SIN(AY)) + CALL CUCHK(CZ, NW, ASCLE, TOL) + IF (NW.EQ.1) GO TO 140 + RETURN + 170 CONTINUE + NUF = -1 + RETURN + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/amos/cwrsk.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,75 @@ + SUBROUTINE CWRSK(ZR, FNU, KODE, N, Y, NZ, CW, TOL, ELIM, ALIM) +C***BEGIN PROLOGUE CWRSK +C***REFER TO CBESI,CBESK +C +C CWRSK COMPUTES THE I BESSEL FUNCTION FOR RE(Z).GE.0.0 BY +C NORMALIZING THE I FUNCTION RATIOS FROM CRATI BY THE WRONSKIAN +C +C***ROUTINES CALLED CBKNU,CRATI,R1MACH +C***END PROLOGUE CWRSK + COMPLEX CINU, CSCL, CT, CW, C1, C2, RCT, ST, Y, ZR + REAL ACT, ACW, ALIM, ASCLE, ELIM, FNU, S1, S2, TOL, YY + INTEGER I, KODE, N, NW, NZ + DIMENSION Y(N), CW(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 CBKNU(ZR, FNU, KODE, 2, CW, NW, TOL, ELIM, ALIM) + IF (NW.NE.0) GO TO 50 + CALL CRATI(ZR, FNU, N, Y, 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----------------------------------------------------------------------- + CINU = CMPLX(1.0E0,0.0E0) + IF (KODE.EQ.1) GO TO 10 + YY = AIMAG(ZR) + S1 = COS(YY) + S2 = SIN(YY) + CINU = CMPLX(S1,S2) + 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 = CABS(CW(2)) + ASCLE = 1.0E+3*R1MACH(1)/TOL + CSCL = CMPLX(1.0E0,0.0E0) + IF (ACW.GT.ASCLE) GO TO 20 + CSCL = CMPLX(1.0E0/TOL,0.0E0) + GO TO 30 + 20 CONTINUE + ASCLE = 1.0E0/ASCLE + IF (ACW.LT.ASCLE) GO TO 30 + CSCL = CMPLX(TOL,0.0E0) + 30 CONTINUE + C1 = CW(1)*CSCL + C2 = CW(2)*CSCL + ST = Y(1) +C----------------------------------------------------------------------- +C CINU=CINU*(CONJG(CT)/CABS(CT))*(1.0E0/CABS(CT) PREVENTS +C UNDER- OR OVERFLOW PREMATURELY BY SQUARING CABS(CT) +C----------------------------------------------------------------------- + CT = ZR*(C2+ST*C1) + ACT = CABS(CT) + RCT = CMPLX(1.0E0/ACT,0.0E0) + CT = CONJG(CT)*RCT + CINU = CINU*RCT*CT + Y(1) = CINU*CSCL + IF (N.EQ.1) RETURN + DO 40 I=2,N + CINU = ST*CINU + ST = Y(I) + Y(I) = CINU*CSCL + 40 CONTINUE + RETURN + 50 CONTINUE + NZ = -1 + IF(NW.EQ.(-2)) NZ=-2 + RETURN + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/amos/dgamln.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,189 @@ + 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
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/amos/gamln.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,189 @@ + FUNCTION GAMLN(Z,IERR) +C***BEGIN PROLOGUE GAMLN +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 GAMLN 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 +C Z - REAL ARGUMENT, Z.GT.0.0E0 +C +C OUTPUT +C GAMLN - NATURAL LOG OF THE GAMMA FUNCTION AT Z +C IERR - ERROR FLAG +C IERR=0, NORMAL RETURN, COMPUTATION COMPLETED +C IERR=1, Z.LE.0.0E0, NO COMPUTATION +C +C***REFERENCES COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT +C BY D. E. AMOS, SAND83-0083, MAY, 1983. +C***ROUTINES CALLED I1MACH,R1MACH +C***END PROLOGUE GAMLN +C + INTEGER I, I1M, K, MZ, NZ, IERR, I1MACH + REAL CF, CON, FLN, FZ, GLN, RLN, S, TLG, TRM, TST, T1, WDTOL, Z, + * ZDMY, ZINC, ZM, ZMIN, ZP, ZSQ + REAL R1MACH + 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.00000000000000000E+00, 0.00000000000000000E+00, + 5 6.93147180559945309E-01, 1.79175946922805500E+00, + 6 3.17805383034794562E+00, 4.78749174278204599E+00, + 7 6.57925121201010100E+00, 8.52516136106541430E+00, + 8 1.06046029027452502E+01, 1.28018274800814696E+01, + 9 1.51044125730755153E+01, 1.75023078458738858E+01, + A 1.99872144956618861E+01, 2.25521638531234229E+01, + B 2.51912211827386815E+01, 2.78992713838408916E+01, + C 3.06718601060806728E+01, 3.35050734501368889E+01, + D 3.63954452080330536E+01, 3.93398841871994940E+01, + E 4.23356164607534850E+01, 4.53801388984769080E+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.84711813518352239E+01, 5.16066755677643736E+01, + 5 5.47847293981123192E+01, 5.80036052229805199E+01, + 6 6.12617017610020020E+01, 6.45575386270063311E+01, + 7 6.78897431371815350E+01, 7.12570389671680090E+01, + 8 7.46582363488301644E+01, 7.80922235533153106E+01, + 9 8.15579594561150372E+01, 8.50544670175815174E+01, + A 8.85808275421976788E+01, 9.21361756036870925E+01, + B 9.57196945421432025E+01, 9.93306124547874269E+01, + C 1.02968198614513813E+02, 1.06631760260643459E+02, + D 1.10320639714757395E+02, 1.14034211781461703E+02, + E 1.17771881399745072E+02, 1.21533081515438634E+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.25317271149356895E+02, 1.29123933639127215E+02, + 5 1.32952575035616310E+02, 1.36802722637326368E+02, + 6 1.40673923648234259E+02, 1.44565743946344886E+02, + 7 1.48477766951773032E+02, 1.52409592584497358E+02, + 8 1.56360836303078785E+02, 1.60331128216630907E+02, + 9 1.64320112263195181E+02, 1.68327445448427652E+02, + A 1.72352797139162802E+02, 1.76395848406997352E+02, + B 1.80456291417543771E+02, 1.84533828861449491E+02, + C 1.88628173423671591E+02, 1.92739047287844902E+02, + D 1.96866181672889994E+02, 2.01009316399281527E+02, + E 2.05168199482641199E+02, 2.09342586752536836E+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.13532241494563261E+02, 2.17736934113954227E+02, + 5 2.21956441819130334E+02, 2.26190548323727593E+02, + 6 2.30439043565776952E+02, 2.34701723442818268E+02, + 7 2.38978389561834323E+02, 2.43268849002982714E+02, + 8 2.47572914096186884E+02, 2.51890402209723194E+02, + 9 2.56221135550009525E+02, 2.60564940971863209E+02, + A 2.64921649798552801E+02, 2.69291097651019823E+02, + B 2.73673124285693704E+02, 2.78067573440366143E+02, + C 2.82474292687630396E+02, 2.86893133295426994E+02, + D 2.91323950094270308E+02, 2.95766601350760624E+02, + E 3.00220948647014132E+02, 3.04686856765668715E+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.09164193580146922E+02, 3.13652829949879062E+02, + 3 3.18152639620209327E+02, 3.22663499126726177E+02, + 4 3.27185287703775217E+02, 3.31717887196928473E+02, + 5 3.36261181979198477E+02, 3.40815058870799018E+02, + 6 3.45379407062266854E+02, 3.49954118040770237E+02, + 7 3.54539085519440809E+02, 3.59134205369575399E+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.33333333333333333E-02, -2.77777777777777778E-03, + 4 7.93650793650793651E-04, -5.95238095238095238E-04, + 5 8.41750841750841751E-04, -1.91752691752691753E-03, + 6 6.41025641025641026E-03, -2.95506535947712418E-02, + 7 1.79644372368830573E-01, -1.39243221690590112E+00, + 8 1.34028640441683920E+01, -1.56848284626002017E+02, + 9 2.19310333333333333E+03, -3.61087712537249894E+04, + A 6.91472268851313067E+05, -1.52382215394074162E+07, + B 3.82900751391414141E+08, -1.08822660357843911E+10, + C 3.47320283765002252E+11, -1.23696021422692745E+13, + D 4.88788064793079335E+14, -2.13203339609193739E+16/ +C +C LN(2*PI) + DATA CON / 1.83787706640934548E+00/ +C +C***FIRST EXECUTABLE STATEMENT GAMLN + IERR=0 + IF (Z.LE.0.0E0) GO TO 70 + IF (Z.GT.101.0E0) GO TO 10 + NZ = INT(Z) + FZ = Z - FLOAT(NZ) + IF (FZ.GT.0.0E0) GO TO 10 + IF (NZ.GT.100) GO TO 10 + GAMLN = GLN(NZ) + RETURN + 10 CONTINUE + WDTOL = R1MACH(4) + WDTOL = AMAX1(WDTOL,0.5E-18) + I1M = I1MACH(11) + RLN = R1MACH(5)*FLOAT(I1M) + FLN = AMIN1(RLN,20.0E0) + FLN = AMAX1(FLN,3.0E0) + FLN = FLN - 3.0E0 + ZM = 1.8000E0 + 0.3875E0*FLN + MZ = INT(ZM) + 1 + ZMIN = FLOAT(MZ) + ZDMY = Z + ZINC = 0.0E0 + IF (Z.GE.ZMIN) GO TO 20 + ZINC = ZMIN - FLOAT(NZ) + ZDMY = Z + ZINC + 20 CONTINUE + ZP = 1.0E0/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 (ABS(TRM).LT.TST) GO TO 40 + S = S + TRM + 30 CONTINUE + 40 CONTINUE + IF (ZINC.NE.0.0E0) GO TO 50 + TLG = ALOG(Z) + GAMLN = Z*(TLG-1.0E0) + 0.5E0*(CON-TLG) + S + RETURN + 50 CONTINUE + ZP = 1.0E0 + NZ = INT(ZINC) + DO 60 I=1,NZ + ZP = ZP*(Z+FLOAT(I-1)) + 60 CONTINUE + TLG = ALOG(ZDMY) + GAMLN = ZDMY*(TLG-1.0E0) - ALOG(ZP) + 0.5E0*(CON-TLG) + S + RETURN +C +C + 70 CONTINUE + IERR=1 + RETURN + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/amos/module.mk Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,70 @@ +EXTERNAL_SOURCES += \ + liboctave/external/amos/cacai.f \ + liboctave/external/amos/cacon.f \ + liboctave/external/amos/cbesh.f \ + liboctave/external/amos/cbesi.f \ + liboctave/external/amos/cbesj.f \ + liboctave/external/amos/cbesk.f \ + liboctave/external/amos/cbesy.f \ + liboctave/external/amos/cbinu.f \ + liboctave/external/amos/cbuni.f \ + liboctave/external/amos/cbunk.f \ + liboctave/external/amos/cunk1.f \ + liboctave/external/amos/cunk2.f \ + liboctave/external/amos/crati.f \ + liboctave/external/amos/cshch.f \ + liboctave/external/amos/cuni1.f \ + liboctave/external/amos/cuoik.f \ + liboctave/external/amos/cairy.f \ + liboctave/external/amos/cbiry.f \ + liboctave/external/amos/ckscl.f \ + liboctave/external/amos/cs1s2.f \ + liboctave/external/amos/cuchk.f \ + liboctave/external/amos/cuni2.f \ + liboctave/external/amos/cwrsk.f \ + liboctave/external/amos/casyi.f \ + liboctave/external/amos/cbknu.f \ + liboctave/external/amos/cmlri.f \ + liboctave/external/amos/cseri.f \ + liboctave/external/amos/cunhj.f \ + liboctave/external/amos/cunik.f \ + liboctave/external/amos/dgamln.f \ + liboctave/external/amos/gamln.f \ + liboctave/external/amos/xzabs.f \ + liboctave/external/amos/xzexp.f \ + liboctave/external/amos/xzlog.f \ + liboctave/external/amos/xzsqrt.f \ + liboctave/external/amos/zacai.f \ + liboctave/external/amos/zacon.f \ + liboctave/external/amos/zairy.f \ + liboctave/external/amos/zasyi.f \ + liboctave/external/amos/zbesh.f \ + liboctave/external/amos/zbesi.f \ + liboctave/external/amos/zbesj.f \ + liboctave/external/amos/zbesk.f \ + liboctave/external/amos/zbesy.f \ + liboctave/external/amos/zbinu.f \ + liboctave/external/amos/zbiry.f \ + liboctave/external/amos/zbknu.f \ + liboctave/external/amos/zbuni.f \ + liboctave/external/amos/zbunk.f \ + liboctave/external/amos/zdiv.f \ + liboctave/external/amos/zkscl.f \ + liboctave/external/amos/zmlri.f \ + liboctave/external/amos/zmlt.f \ + liboctave/external/amos/zrati.f \ + liboctave/external/amos/zs1s2.f \ + liboctave/external/amos/zseri.f \ + liboctave/external/amos/zshch.f \ + liboctave/external/amos/zuchk.f \ + liboctave/external/amos/zunhj.f \ + liboctave/external/amos/zuni1.f \ + liboctave/external/amos/zuni2.f \ + liboctave/external/amos/zunik.f \ + liboctave/external/amos/zunk1.f \ + liboctave/external/amos/zunk2.f \ + liboctave/external/amos/zuoik.f \ + liboctave/external/amos/zwrsk.f + +liboctave_EXTRA_DIST += \ + liboctave/external/amos/README
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/amos/xzabs.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,29 @@ + DOUBLE PRECISION FUNCTION XZABS(ZR, ZI) +C***BEGIN PROLOGUE XZABS +C***REFER TO ZBESH,ZBESI,ZBESJ,ZBESK,ZBESY,ZAIRY,ZBIRY +C +C XZABS COMPUTES THE ABSOLUTE VALUE OR MAGNITUDE OF A DOUBLE +C PRECISION COMPLEX VARIABLE CMPLX(ZR,ZI) +C +C***ROUTINES CALLED (NONE) +C***END PROLOGUE XZABS + 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 + XZABS = V*DSQRT(1.D+0+Q*Q) + RETURN + 10 Q = V/U + XZABS = U*DSQRT(1.D+0+Q*Q) + RETURN + 20 XZABS = 0.0D+0 + RETURN + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/amos/xzexp.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,16 @@ + SUBROUTINE XZEXP(AR, AI, BR, BI) +C***BEGIN PROLOGUE XZEXP +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 XZEXP + 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
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/amos/xzlog.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,41 @@ + SUBROUTINE XZLOG(AR, AI, BR, BI, IERR) +C***BEGIN PROLOGUE XZLOG +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 XZABS +C***END PROLOGUE XZLOG + DOUBLE PRECISION AR, AI, BR, BI, ZM, DTHETA, DPI, DHPI + DOUBLE PRECISION XZABS + 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 = XZABS(AR,AI) + BR = DLOG(ZM) + BI = DTHETA + RETURN + 60 CONTINUE + IERR=1 + RETURN + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/amos/xzsqrt.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,44 @@ + SUBROUTINE XZSQRT(AR, AI, BR, BI) +C***BEGIN PROLOGUE XZSQRT +C***REFER TO ZBESH,ZBESI,ZBESJ,ZBESK,ZBESY,ZAIRY,ZBIRY +C +C DOUBLE PRECISION COMPLEX SQUARE ROOT, B=CSQRT(A) +C +C***ROUTINES CALLED XZABS +C***END PROLOGUE XZSQRT + DOUBLE PRECISION AR, AI, BR, BI, ZM, DTHETA, DPI, DRT + DOUBLE PRECISION XZABS + DATA DRT , DPI / 7.071067811865475244008443621D-1, + 1 3.141592653589793238462643383D+0/ + ZM = XZABS(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
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/amos/zacai.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,99 @@ + 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,XZABS +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, XZABS + 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 = XZABS(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
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/amos/zacon.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,203 @@ + 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,XZABS,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, XZABS + 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 = XZABS(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 = XZABS(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
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/amos/zairy.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,393 @@ + 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,XZEXP,XZSQRT,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, XZABS, 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 = XZABS(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 XZSQRT(ZR, ZI, STR, STI) + ZTAR = TTH*(ZR*STR-ZI*STI) + ZTAI = TTH*(ZR*STI+ZI*STR) + CALL XZEXP(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 XZSQRT(ZR, ZI, STR, STI) + ZTAR = TTH*(ZR*STR-ZI*STI) + ZTAI = TTH*(ZR*STI+ZI*STR) + CALL XZEXP(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 XZSQRT(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
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/amos/zasyi.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,165 @@ + 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,XZABS,ZDIV,XZEXP,ZMLT,XZSQRT +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, XZABS + 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 = XZABS(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 XZSQRT(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 XZEXP(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 XZEXP(-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 XZEXP(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
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/amos/zbesh.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,348 @@ + 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,XZABS,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, XZABS, 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 = XZABS(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
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/amos/zbesi.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,269 @@ + 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, XZABS, 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 = XZABS(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
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/amos/zbesj.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,266 @@ + 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, XZABS, 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 = XZABS(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
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/amos/zbesk.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,281 @@ + 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,XZABS,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, XZABS, 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 = XZABS(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
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/amos/zbesy.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,244 @@ + 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
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/amos/zbinu.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,110 @@ + 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 XZABS,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, XZABS + 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 = XZABS(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
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/amos/zbiry.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,364 @@ + 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,XZABS,ZDIV,XZSQRT,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, XZABS + 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 = XZABS(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 XZSQRT(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 XZSQRT(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 XZSQRT(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
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/amos/zbknu.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,568 @@ + 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,XZABS,ZDIV, +C XZEXP,XZLOG,ZMLT,XZSQRT +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, XZABS, 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 = XZABS(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 XZLOG(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 XZEXP(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 XZEXP(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 XZEXP(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 XZSQRT(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 = XZABS(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 = XZABS(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 = XZABS(S2R,S2I) + ALAS = DLOG(AS) + P2R = -ZDR+ALAS + IF(P2R.LT.(-ELIM)) GO TO 263 + CALL XZLOG(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
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/amos/zbuni.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,174 @@ + 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,XZABS,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, XZABS, 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 = XZABS(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/XZABS(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
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/amos/zbunk.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,35 @@ + 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
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/amos/zdiv.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,19 @@ + 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 XZABS +C***END PROLOGUE ZDIV + DOUBLE PRECISION AR, AI, BR, BI, CR, CI, BM, CA, CB, CC, CD + DOUBLE PRECISION XZABS + BM = 1.0D0/XZABS(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
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/amos/zkscl.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,121 @@ + 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,XZABS,XZLOG +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, XZABS, + * 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 = XZABS(S1R,S1I) + ACS = -ZRR + DLOG(AS) + NZ = NZ + 1 + YR(I) = ZEROR + YI(I) = ZEROI + IF (ACS.LT.(-ELIM)) GO TO 10 + CALL XZLOG(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 = XZABS(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 XZLOG(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
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/amos/zmlri.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,204 @@ + 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,XZABS,XZEXP,XZLOG,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, XZABS + 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 = XZABS(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 = XZABS(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 = XZABS(P2R,P2I) + IF (AP.LT.TST) GO TO 30 + IF (ITIME.EQ.2) GO TO 40 + ACK = XZABS(CKR,CKI) + FLAM = ACK + DSQRT(ACK*ACK-1.0D0) + FKAP = AP/XZABS(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 XZLOG(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 = XZABS(P2R,P2I) + P1R = 1.0D0/AP + CALL XZEXP(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
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/amos/zmlt.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,15 @@ + 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
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/amos/zrati.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,132 @@ + 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 XZABS,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, XZABS + 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 = XZABS(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 = XZABS(P2R,P2I) + AP1 = XZABS(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 = XZABS(P2R,P2I) + IF (AP1.LE.TEST) GO TO 10 + IF (ITIME.EQ.2) GO TO 20 + AK = XZABS(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 = XZABS(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
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/amos/zs1s2.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,49 @@ + 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 XZABS,XZEXP,XZLOG +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, XZABS + INTEGER IUF, IDUM, NZ + DATA ZEROR,ZEROI / 0.0D0 , 0.0D0 / + NZ = 0 + AS1 = XZABS(S1R,S1I) + AS2 = XZABS(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 XZLOG(S1DR, S1DI, C1R, C1I, IDUM) + C1R = C1R - ZRR - ZRR + C1I = C1I - ZRI - ZRI + CALL XZEXP(C1R, C1I, S1R, S1I) + AS1 = XZABS(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
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/amos/zseri.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,190 @@ + 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,XZABS,ZDIV,XZLOG,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, XZABS + 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 = XZABS(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 = XZABS(CZR,CZI) + NN = N + CALL XZLOG(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 (XZABS(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
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/amos/zshch.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,22 @@ + 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
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/amos/zuchk.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,28 @@ + 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
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/amos/zunhj.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,714 @@ + 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 XZABS,ZDIV,XZLOG,XZSQRT,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, XZABS, 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 = XZABS(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 XZSQRT(SUMAR, SUMAI, ZAR, ZAI) + CALL XZSQRT(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 XZSQRT(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 XZSQRT(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 XZLOG(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 = XZABS(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 XZSQRT(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
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/amos/zuni1.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,204 @@ + 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,XZABS +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, XZABS + 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/XZABS(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/XZABS(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 = XZABS(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/XZABS(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
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/amos/zuni2.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,267 @@ + 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,XZABS +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, XZABS, 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/XZABS(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/XZABS(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 = XZABS(PHIR,PHII) + AARG = XZABS(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/XZABS(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
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/amos/zunik.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,211 @@ + 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,XZLOG,XZSQRT,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 XZSQRT(SR, SI, SRR, SRI) + STR = CONER + SRR + STI = CONEI + SRI + CALL ZDIV(STR, STI, TR, TI, ZNR, ZNI) + CALL XZLOG(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 XZSQRT(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
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/amos/zunk1.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,426 @@ + 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,XZABS +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, XZABS + 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/XZABS(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 = XZABS(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/XZABS(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/XZABS(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 = XZABS(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/XZABS(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 = XZABS(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
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/amos/zunk2.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,505 @@ + 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,XZABS +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, XZABS + 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/XZABS(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 = XZABS(PHIR(J),PHII(J)) + AARG = XZABS(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/XZABS(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/XZABS(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 = XZABS(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/XZABS(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 = XZABS(PHIDR,PHIDI) + AARG = XZABS(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
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/amos/zuoik.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,194 @@ + 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,XZABS,XZLOG +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, XZABS + 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 = XZABS(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 = XZABS(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 XZLOG(PHIR, PHII, STR, STI, IDUM) + CZR = CZR + STR + CZI = CZI + STI + IF (IFORM.EQ.1) GO TO 120 + CALL XZLOG(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 = XZABS(ARGR,ARGI) + 160 CONTINUE + IF (KODE.EQ.1) GO TO 170 + CZR = CZR - ZBR + CZI = CZI - ZBI + 170 CONTINUE + APHI = XZABS(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 XZLOG(PHIR, PHII, STR, STI, IDUM) + CZR = CZR + STR + CZI = CZI + STI + IF (IFORM.EQ.1) GO TO 200 + CALL XZLOG(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
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/amos/zwrsk.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,94 @@ + 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,XZABS +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, XZABS, 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 = XZABS(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 = XZABS(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
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/blas-xtra/cconv2.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,77 @@ +c Copyright (C) 2010-2017 VZLU Prague, a.s., Czech Republic +c +c Author: Jaroslav Hajek <highegg@gmail.com> +c +c This file is part of Octave. +c +c Octave is free software; you can redistribute it and/or modify it +c under the terms of the GNU General Public License as published by +c the Free Software Foundation; either version 3 of the License, or +c (at your option) any later version. +c +c Octave is distributed in the hope that it will be useful, but +c WITHOUT ANY WARRANTY; without even the implied warranty of +c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +c GNU General Public License for more details. +c +c You should have received a copy of the GNU General Public License +c along with Octave; see the file COPYING. If not, see +c <http://www.gnu.org/licenses/>. +c + subroutine cconv2o(ma,na,a,mb,nb,b,c) +c purpose: a 2-dimensional outer additive convolution. +c equivalent to the following: +c for i = 1:ma +c for j = 1:na +c c(i:i+mb-1,j:j+mb-1) += a(i,j)*b +c endfor +c endfor +c arguments: +c ma,na (in) dimensions of a +c a (in) 1st matrix +c mb,nb (in) dimensions of b +c b (in) 2nd matrix +c c (inout) accumulator matrix, size (ma+mb-1, na+nb-1) +c + integer ma,na,mb,nb + complex a(ma,na),b(mb,nb) + complex c(ma+mb-1,na+nb-1) + integer i,j,k + external caxpy + do k = 1,na + do j = 1,nb + do i = 1,mb + call caxpy(ma,b(i,j),a(1,k),1,c(i,j+k-1),1) + end do + end do + end do + end subroutine + + subroutine cconv2i(ma,na,a,mb,nb,b,c) +c purpose: a 2-dimensional inner additive convolution. +c equivalent to the following: +c for i = 1:ma-mb+1 +c for j = 1:na-nb+1 +c c(i,j) = sum (sum (a(i+mb-1:-1:i,j+nb-1:-1:j) .* b)) +c endfor +c endfor +c arguments: +c ma,na (in) dimensions of a +c a (in) 1st matrix +c mb,nb (in) dimensions of b +c b (in) 2nd matrix +c c (inout) accumulator matrix, size (ma+mb-1, na+nb-1) +c + integer ma,na,mb,nb + complex a(ma,na),b(mb,nb) + complex c(ma-mb+1,na-nb+1) + integer i,j,k + external caxpy + do k = 1,na-nb+1 + do j = 1,nb + do i = 1,mb + call caxpy(ma-mb+1,b(i,j),a(mb+1-i,k+nb-j),1,c(1,k),1) + end do + end do + end do + end subroutine
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/blas-xtra/cdotc3.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,59 @@ +c Copyright (C) 2009-2017 VZLU Prague, a.s., Czech Republic +c +c Author: Jaroslav Hajek <highegg@gmail.com> +c +c This file is part of Octave. +c +c Octave is free software; you can redistribute it and/or modify it +c under the terms of the GNU General Public License as published by +c the Free Software Foundation; either version 3 of the License, or +c (at your option) any later version. +c +c Octave is distributed in the hope that it will be useful, but +c WITHOUT ANY WARRANTY; without even the implied warranty of +c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +c GNU General Public License for more details. +c +c You should have received a copy of the GNU General Public License +c along with Octave; see the file COPYING. If not, see +c <http://www.gnu.org/licenses/>. +c + subroutine cdotc3(m,n,k,a,b,c) +c purpose: a 3-dimensional dot product. +c c = sum (conj (a) .* b, 2), where a and b are 3d arrays. +c arguments: +c m,n,k (in) the dimensions of a and b +c a,b (in) complex input arrays of size (m,k,n) +c c (out) complex output array, size (m,n) + integer m,n,k,i,j,l + complex a(m,k,n),b(m,k,n) + complex c(m,n) + + complex cdotc + external cdotc + +c quick return if possible. + if (m <= 0 .or. n <= 0) return + + if (m == 1) then +c the column-major case. + do j = 1,n + c(1,j) = cdotc(k,a(1,1,j),1,b(1,1,j),1) + end do + else +c We prefer performance here, because that's what we generally +c do by default in reduction functions. Besides, the accuracy +c of xDOT is questionable. Hence, do a cache-aligned nested loop. + do j = 1,n + do i = 1,m + c(i,j) = 0e0 + end do + do l = 1,k + do i = 1,m + c(i,j) = c(i,j) + conjg(a(i,l,j))*b(i,l,j) + end do + end do + end do + end if + + end subroutine
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/blas-xtra/cmatm3.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,69 @@ +c Copyright (C) 2009-2017 VZLU Prague, a.s., Czech Republic +c +c Author: Jaroslav Hajek <highegg@gmail.com> +c +c This file is part of Octave. +c +c Octave is free software; you can redistribute it and/or modify it +c under the terms of the GNU General Public License as published by +c the Free Software Foundation; either version 3 of the License, or +c (at your option) any later version. +c +c Octave is distributed in the hope that it will be useful, but +c WITHOUT ANY WARRANTY; without even the implied warranty of +c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +c GNU General Public License for more details. +c +c You should have received a copy of the GNU General Public License +c along with Octave; see the file COPYING. If not, see +c <http://www.gnu.org/licenses/>. +c + subroutine cmatm3(m,n,k,np,a,b,c) +c purpose: a 3-dimensional matrix product. +c given a (m,k,np) array a and (k,n,np) array b, +c calculates a (m,n,np) array c such that +c for i = 1:np +c c(:,:,i) = a(:,:,i) * b(:,:,i) +c +c arguments: +c m,n,k (in) the dimensions +c np (in) number of multiplications +c a (in) a complex input array, size (m,k,np) +c b (in) a complex input array, size (k,n,np) +c c (out) a complex output array, size (m,n,np) + integer m,n,k,np + complex a(m*k,np),b(k*n,np) + complex c(m*n,np) + + complex cdotu,one,zero + parameter (one = 1e0, zero = 0e0) + external cdotu,cgemv,cgemm + integer i + +c quick return if possible. + if (np <= 0) return + + if (m == 1) then + if (n == 1) then + do i = 1,np + c(1,i) = cdotu(k,a(1,i),1,b(1,i),1) + end do + else + do i = 1,np + call cgemv("T",k,n,one,b(1,i),k,a(1,i),1,zero,c(1,i),1) + end do + end if + else + if (n == 1) then + do i = 1,np + call cgemv("N",m,k,one,a(1,i),m,b(1,i),1,zero,c(1,i),1) + end do + else + do i = 1,np + call cgemm("N","N",m,n,k, + + one,a(1,i),m,b(1,i),k,zero,c(1,i),m) + end do + end if + end if + + end subroutine
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/blas-xtra/csconv2.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,83 @@ +c Copyright (C) 2010-2017 VZLU Prague, a.s., Czech Republic +c +c Author: Jaroslav Hajek <highegg@gmail.com> +c +c This file is part of Octave. +c +c Octave is free software; you can redistribute it and/or modify it +c under the terms of the GNU General Public License as published by +c the Free Software Foundation; either version 3 of the License, or +c (at your option) any later version. +c +c Octave is distributed in the hope that it will be useful, but +c WITHOUT ANY WARRANTY; without even the implied warranty of +c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +c GNU General Public License for more details. +c +c You should have received a copy of the GNU General Public License +c along with Octave; see the file COPYING. If not, see +c <http://www.gnu.org/licenses/>. +c + subroutine csconv2o(ma,na,a,mb,nb,b,c) +c purpose: a 2-dimensional outer additive convolution. +c equivalent to the following: +c for i = 1:ma +c for j = 1:na +c c(i:i+mb-1,j:j+mb-1) += a(i,j)*b +c endfor +c endfor +c arguments: +c ma,na (in) dimensions of a +c a (in) 1st matrix +c mb,nb (in) dimensions of b +c b (in) 2nd matrix +c c (inout) accumulator matrix, size (ma+mb-1, na+nb-1) +c + integer ma,na,mb,nb + complex a(ma,na) + real b(mb,nb) + complex c(ma+mb-1,na+nb-1) + complex btmp + integer i,j,k + external caxpy + do k = 1,na + do j = 1,nb + do i = 1,mb + btmp = b(i,j) + call caxpy(ma,btmp,a(1,k),1,c(i,j+k-1),1) + end do + end do + end do + end subroutine + + subroutine csconv2i(ma,na,a,mb,nb,b,c) +c purpose: a 2-dimensional inner additive convolution. +c equivalent to the following: +c for i = 1:ma-mb+1 +c for j = 1:na-nb+1 +c c(i,j) = sum (sum (a(i:i+mb-1,j:j+nb-1) .* b)) +c endfor +c endfor +c arguments: +c ma,na (in) dimensions of a +c a (in) 1st matrix +c mb,nb (in) dimensions of b +c b (in) 2nd matrix +c c (inout) accumulator matrix, size (ma+mb-1, na+nb-1) +c + integer ma,na,mb,nb + complex a(ma,na) + real b(mb,nb) + complex c(ma-mb+1,na-nb+1) + complex btmp + integer i,j,k + external caxpy + do k = 1,na-nb+1 + do j = 1,nb + do i = 1,mb + btmp = b(i,j) + call caxpy(ma-mb+1,btmp,a(mb+1-i,k+nb-j),1,c(1,k),1) + end do + end do + end do + end subroutine
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/blas-xtra/dconv2.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,77 @@ +c Copyright (C) 2010-2017 VZLU Prague, a.s., Czech Republic +c +c Author: Jaroslav Hajek <highegg@gmail.com> +c +c This file is part of Octave. +c +c Octave is free software; you can redistribute it and/or modify it +c under the terms of the GNU General Public License as published by +c the Free Software Foundation; either version 3 of the License, or +c (at your option) any later version. +c +c Octave is distributed in the hope that it will be useful, but +c WITHOUT ANY WARRANTY; without even the implied warranty of +c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +c GNU General Public License for more details. +c +c You should have received a copy of the GNU General Public License +c along with Octave; see the file COPYING. If not, see +c <http://www.gnu.org/licenses/>. +c + subroutine dconv2o(ma,na,a,mb,nb,b,c) +c purpose: a 2-dimensional outer additive convolution. +c equivalent to the following: +c for i = 1:ma +c for j = 1:na +c c(i:i+mb-1,j:j+mb-1) += a(i,j)*b +c endfor +c endfor +c arguments: +c ma,na (in) dimensions of a +c a (in) 1st matrix +c mb,nb (in) dimensions of b +c b (in) 2nd matrix +c c (inout) accumulator matrix, size (ma+mb-1, na+nb-1) +c + integer ma,na,mb,nb + double precision a(ma,na),b(mb,nb) + double precision c(ma+mb-1,na+nb-1) + integer i,j,k + external daxpy + do k = 1,na + do j = 1,nb + do i = 1,mb + call daxpy(ma,b(i,j),a(1,k),1,c(i,j+k-1),1) + end do + end do + end do + end subroutine + + subroutine dconv2i(ma,na,a,mb,nb,b,c) +c purpose: a 2-dimensional inner additive convolution. +c equivalent to the following: +c for i = 1:ma-mb+1 +c for j = 1:na-nb+1 +c c(i,j) = sum (sum (a(i+mb-1:-1:i,j+nb-1:-1:j) .* b)) +c endfor +c endfor +c arguments: +c ma,na (in) dimensions of a +c a (in) 1st matrix +c mb,nb (in) dimensions of b +c b (in) 2nd matrix +c c (inout) accumulator matrix, size (ma+mb-1, na+nb-1) +c + integer ma,na,mb,nb + double precision a(ma,na),b(mb,nb) + double precision c(ma-mb+1,na-nb+1) + integer i,j,k + external daxpy + do k = 1,na-nb+1 + do j = 1,nb + do i = 1,mb + call daxpy(ma-mb+1,b(i,j),a(mb+1-i,k+nb-j),1,c(1,k),1) + end do + end do + end do + end subroutine
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/blas-xtra/ddot3.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,60 @@ +c Copyright (C) 2009-2017 VZLU Prague, a.s., Czech Republic +c +c Author: Jaroslav Hajek <highegg@gmail.com> +c +c This file is part of Octave. +c +c Octave is free software; you can redistribute it and/or modify it +c under the terms of the GNU General Public License as published by +c the Free Software Foundation; either version 3 of the License, or +c (at your option) any later version. +c +c Octave is distributed in the hope that it will be useful, but +c WITHOUT ANY WARRANTY; without even the implied warranty of +c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +c GNU General Public License for more details. +c +c You should have received a copy of the GNU General Public License +c along with Octave; see the file COPYING. If not, see +c <http://www.gnu.org/licenses/>. +c + subroutine ddot3(m,n,k,a,b,c) +c purpose: a 3-dimensional dot product. +c c = sum (a .* b, 2), where a and b are 3d arrays. +c arguments: +c m,n,k (in) the dimensions of a and b +c a,b (in) double prec. input arrays of size (m,k,n) +c c (out) double prec. output array, size (m,n) + integer m,n,k,i,j,l + double precision a(m,k,n),b(m,k,n) + double precision c(m,n) + + double precision ddot + external ddot + + +c quick return if possible. + if (m <= 0 .or. n <= 0) return + + if (m == 1) then +c the column-major case. + do j = 1,n + c(1,j) = ddot(k,a(1,1,j),1,b(1,1,j),1) + end do + else +c We prefer performance here, because that's what we generally +c do by default in reduction functions. Besides, the accuracy +c of xDOT is questionable. Hence, do a cache-aligned nested loop. + do j = 1,n + do i = 1,m + c(i,j) = 0d0 + end do + do l = 1,k + do i = 1,m + c(i,j) = c(i,j) + a(i,l,j)*b(i,l,j) + end do + end do + end do + end if + + end subroutine
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/blas-xtra/dmatm3.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,69 @@ +c Copyright (C) 2009-2017 VZLU Prague, a.s., Czech Republic +c +c Author: Jaroslav Hajek <highegg@gmail.com> +c +c This file is part of Octave. +c +c Octave is free software; you can redistribute it and/or modify it +c under the terms of the GNU General Public License as published by +c the Free Software Foundation; either version 3 of the License, or +c (at your option) any later version. +c +c Octave is distributed in the hope that it will be useful, but +c WITHOUT ANY WARRANTY; without even the implied warranty of +c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +c GNU General Public License for more details. +c +c You should have received a copy of the GNU General Public License +c along with Octave; see the file COPYING. If not, see +c <http://www.gnu.org/licenses/>. +c + subroutine dmatm3(m,n,k,np,a,b,c) +c purpose: a 3-dimensional matrix product. +c given a (m,k,np) array a and (k,n,np) array b, +c calculates a (m,n,np) array c such that +c for i = 1:np +c c(:,:,i) = a(:,:,i) * b(:,:,i) +c +c arguments: +c m,n,k (in) the dimensions +c np (in) number of multiplications +c a (in) a double prec. input array, size (m,k,np) +c b (in) a double prec. input array, size (k,n,np) +c c (out) a double prec. output array, size (m,n,np) + integer m,n,k,np + double precision a(m*k,np),b(k*n,np) + double precision c(m*n,np) + + double precision ddot,one,zero + parameter (one = 1d0, zero = 0d0) + external ddot,dgemv,dgemm + integer i + +c quick return if possible. + if (np <= 0) return + + if (m == 1) then + if (n == 1) then + do i = 1,np + c(1,i) = ddot(k,a(1,i),1,b(1,i),1) + end do + else + do i = 1,np + call dgemv("T",k,n,one,b(1,i),k,a(1,i),1,zero,c(1,i),1) + end do + end if + else + if (n == 1) then + do i = 1,np + call dgemv("N",m,k,one,a(1,i),m,b(1,i),1,zero,c(1,i),1) + end do + else + do i = 1,np + call dgemm("N","N",m,n,k, + + one,a(1,i),m,b(1,i),k,zero,c(1,i),m) + end do + end if + end if + + end subroutine
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/blas-xtra/module.mk Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,26 @@ +EXTERNAL_SOURCES += \ + liboctave/external/blas-xtra/ddot3.f \ + liboctave/external/blas-xtra/zdotc3.f \ + liboctave/external/blas-xtra/sdot3.f \ + liboctave/external/blas-xtra/cdotc3.f \ + liboctave/external/blas-xtra/dmatm3.f \ + liboctave/external/blas-xtra/zmatm3.f \ + liboctave/external/blas-xtra/smatm3.f \ + liboctave/external/blas-xtra/cmatm3.f \ + liboctave/external/blas-xtra/xddot.f \ + liboctave/external/blas-xtra/xdnrm2.f \ + liboctave/external/blas-xtra/xdznrm2.f \ + liboctave/external/blas-xtra/xzdotc.f \ + liboctave/external/blas-xtra/xzdotu.f \ + liboctave/external/blas-xtra/xsdot.f \ + liboctave/external/blas-xtra/xsnrm2.f \ + liboctave/external/blas-xtra/xscnrm2.f \ + liboctave/external/blas-xtra/xcdotc.f \ + liboctave/external/blas-xtra/xcdotu.f \ + liboctave/external/blas-xtra/xerbla.f \ + liboctave/external/blas-xtra/cconv2.f \ + liboctave/external/blas-xtra/csconv2.f \ + liboctave/external/blas-xtra/dconv2.f \ + liboctave/external/blas-xtra/sconv2.f \ + liboctave/external/blas-xtra/zconv2.f \ + liboctave/external/blas-xtra/zdconv2.f
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/blas-xtra/sconv2.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,77 @@ +c Copyright (C) 2010-2017 VZLU Prague, a.s., Czech Republic +c +c Author: Jaroslav Hajek <highegg@gmail.com> +c +c This file is part of Octave. +c +c Octave is free software; you can redistribute it and/or modify it +c under the terms of the GNU General Public License as published by +c the Free Software Foundation; either version 3 of the License, or +c (at your option) any later version. +c +c Octave is distributed in the hope that it will be useful, but +c WITHOUT ANY WARRANTY; without even the implied warranty of +c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +c GNU General Public License for more details. +c +c You should have received a copy of the GNU General Public License +c along with Octave; see the file COPYING. If not, see +c <http://www.gnu.org/licenses/>. +c + subroutine sconv2o(ma,na,a,mb,nb,b,c) +c purpose: a 2-dimensional outer additive convolution. +c equivalent to the following: +c for i = 1:ma +c for j = 1:na +c c(i:i+mb-1,j:j+mb-1) += a(i,j)*b +c endfor +c endfor +c arguments: +c ma,na (in) dimensions of a +c a (in) 1st matrix +c mb,nb (in) dimensions of b +c b (in) 2nd matrix +c c (inout) accumulator matrix, size (ma+mb-1, na+nb-1) +c + integer ma,na,mb,nb + real a(ma,na),b(mb,nb) + real c(ma+mb-1,na+nb-1) + integer i,j,k + external saxpy + do k = 1,na + do j = 1,nb + do i = 1,mb + call saxpy(ma,b(i,j),a(1,k),1,c(i,j+k-1),1) + end do + end do + end do + end subroutine + + subroutine sconv2i(ma,na,a,mb,nb,b,c) +c purpose: a 2-dimensional inner additive convolution. +c equivalent to the following: +c for i = 1:ma-mb+1 +c for j = 1:na-nb+1 +c c(i,j) = sum (sum (a(i+mb-1:-1:i,j+nb-1:-1:j) .* b)) +c endfor +c endfor +c arguments: +c ma,na (in) dimensions of a +c a (in) 1st matrix +c mb,nb (in) dimensions of b +c b (in) 2nd matrix +c c (inout) accumulator matrix, size (ma+mb-1, na+nb-1) +c + integer ma,na,mb,nb + real a(ma,na),b(mb,nb) + real c(ma-mb+1,na-nb+1) + integer i,j,k + external saxpy + do k = 1,na-nb+1 + do j = 1,nb + do i = 1,mb + call saxpy(ma-mb+1,b(i,j),a(mb+1-i,k+nb-j),1,c(1,k),1) + end do + end do + end do + end subroutine
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/blas-xtra/sdot3.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,59 @@ +c Copyright (C) 2009-2017 VZLU Prague, a.s., Czech Republic +c +c Author: Jaroslav Hajek <highegg@gmail.com> +c +c This file is part of Octave. +c +c Octave is free software; you can redistribute it and/or modify it +c under the terms of the GNU General Public License as published by +c the Free Software Foundation; either version 3 of the License, or +c (at your option) any later version. +c +c Octave is distributed in the hope that it will be useful, but +c WITHOUT ANY WARRANTY; without even the implied warranty of +c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +c GNU General Public License for more details. +c +c You should have received a copy of the GNU General Public License +c along with Octave; see the file COPYING. If not, see +c <http://www.gnu.org/licenses/>. +c + subroutine sdot3(m,n,k,a,b,c) +c purpose: a 3-dimensional dot product. +c c = sum (a .* b, 2), where a and b are 3d arrays. +c arguments: +c m,n,k (in) the dimensions of a and b +c a,b (in) real input arrays of size (m,k,n) +c c (out) real output array, size (m,n) + integer m,n,k,i,j,l + real a(m,k,n),b(m,k,n) + real c(m,n) + + real sdot + external sdot + +c quick return if possible. + if (m <= 0 .or. n <= 0) return + + if (m == 1) then +c the column-major case. + do j = 1,n + c(1,j) = sdot(k,a(1,1,j),1,b(1,1,j),1) + end do + else +c We prefer performance here, because that's what we generally +c do by default in reduction functions. Besides, the accuracy +c of xDOT is questionable. Hence, do a cache-aligned nested loop. + do j = 1,n + do i = 1,m + c(i,j) = 0d0 + end do + do l = 1,k + do i = 1,m + c(i,j) = c(i,j) + a(i,l,j)*b(i,l,j) + end do + end do + end do + end if + + end subroutine
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/blas-xtra/smatm3.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,69 @@ +c Copyright (C) 2009-2017 VZLU Prague, a.s., Czech Republic +c +c Author: Jaroslav Hajek <highegg@gmail.com> +c +c This file is part of Octave. +c +c Octave is free software; you can redistribute it and/or modify it +c under the terms of the GNU General Public License as published by +c the Free Software Foundation; either version 3 of the License, or +c (at your option) any later version. +c +c Octave is distributed in the hope that it will be useful, but +c WITHOUT ANY WARRANTY; without even the implied warranty of +c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +c GNU General Public License for more details. +c +c You should have received a copy of the GNU General Public License +c along with Octave; see the file COPYING. If not, see +c <http://www.gnu.org/licenses/>. +c + subroutine smatm3(m,n,k,np,a,b,c) +c purpose: a 3-dimensional matrix product. +c given a (m,k,np) array a and (k,n,np) array b, +c calculates a (m,n,np) array c such that +c for i = 1:np +c c(:,:,i) = a(:,:,i) * b(:,:,i) +c +c arguments: +c m,n,k (in) the dimensions +c np (in) number of multiplications +c a (in) a real input array, size (m,k,np) +c b (in) a real input array, size (k,n,np) +c c (out) a real output array, size (m,n,np) + integer m,n,k,np + real a(m*k,np),b(k*n,np) + real c(m*n,np) + + real sdot,one,zero + parameter (one = 1e0, zero = 0e0) + external sdot,sgemv,sgemm + integer i + +c quick return if possible. + if (np <= 0) return + + if (m == 1) then + if (n == 1) then + do i = 1,np + c(1,i) = sdot(k,a(1,i),1,b(1,i),1) + end do + else + do i = 1,np + call sgemv("T",k,n,one,b(1,i),k,a(1,i),1,zero,c(1,i),1) + end do + end if + else + if (n == 1) then + do i = 1,np + call sgemv("N",m,k,one,a(1,i),m,b(1,i),1,zero,c(1,i),1) + end do + else + do i = 1,np + call sgemm("N","N",m,n,k, + + one,a(1,i),m,b(1,i),k,zero,c(1,i),m) + end do + end if + end if + + end subroutine
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/blas-xtra/xcdotc.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,7 @@ + subroutine xcdotc (n, zx, incx, zy, incy, retval) + complex cdotc, zx(*), zy(*), retval + integer n, incx, incy + external cdotc + retval = cdotc (n, zx, incx, zy, incy) + return + end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/blas-xtra/xcdotu.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,7 @@ + subroutine xcdotu (n, zx, incx, zy, incy, retval) + complex cdotu, zx(*), zy(*), retval + integer n, incx, incy + external cdotu + retval = cdotu (n, zx, incx, zy, incy) + return + end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/blas-xtra/xddot.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,6 @@ + subroutine xddot (n, dx, incx, dy, incy, retval) + double precision ddot, dx(*), dy(*), retval + integer n, incx, incy + retval = ddot (n, dx, incx, dy, incy) + return + end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/blas-xtra/xdnrm2.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,6 @@ + subroutine xdnrm2 (n, x, incx, retval) + double precision dnrm2, x(*), retval + integer n, incx + retval = dnrm2 (n, x, incx) + return + end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/blas-xtra/xdznrm2.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,7 @@ + subroutine xdznrm2 (n, x, incx, retval) + double precision dznrm2, retval + double complex x(*) + integer n, incx + retval = dznrm2 (n, x, incx) + return + end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/blas-xtra/xerbla.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,43 @@ + SUBROUTINE XERBLA( SRNAME, INFO ) +* +* -- LAPACK auxiliary routine (preliminary version) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* February 29, 1992 +* +* .. Scalar Arguments .. + CHARACTER*6 SRNAME + INTEGER INFO +* .. +* +* Purpose +* ======= +* +* XERBLA is an error handler for the LAPACK routines. +* It is called by an LAPACK routine if an input parameter has an +* invalid value. A message is printed and execution stops. +* +* Installers may consider modifying the STOP statement in order to +* call system-specific exception-handling facilities. +* +* Arguments +* ========= +* +* SRNAME (input) CHARACTER*6 +* The name of the routine which called XERBLA. +* +* INFO (input) INTEGER +* The position of the invalid parameter in the parameter list +* of the calling routine. +* +* + WRITE( *, FMT = 9999 )SRNAME, INFO +* + CALL XSTOPX (' ') +* + 9999 FORMAT( ' ** On entry to ', A6, ' parameter number ', I2, ' had ', + $ 'an illegal value' ) +* +* End of XERBLA +* + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/blas-xtra/xscnrm2.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,7 @@ + subroutine xscnrm2 (n, x, incx, retval) + real scnrm2, retval + complex x(*) + integer n, incx + retval = scnrm2 (n, x, incx) + return + end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/blas-xtra/xsdot.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,6 @@ + subroutine xsdot (n, dx, incx, dy, incy, retval) + real ddot, dx(*), dy(*), retval, sdot + integer n, incx, incy + retval = sdot (n, dx, incx, dy, incy) + return + end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/blas-xtra/xsnrm2.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,6 @@ + subroutine xsnrm2 (n, x, incx, retval) + real snrm2, x(*), retval + integer n, incx + retval = snrm2 (n, x, incx) + return + end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/blas-xtra/xzdotc.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,7 @@ + subroutine xzdotc (n, zx, incx, zy, incy, retval) + double complex zdotc, zx(*), zy(*), retval + integer n, incx, incy + external zdotc + retval = zdotc (n, zx, incx, zy, incy) + return + end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/blas-xtra/xzdotu.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,7 @@ + subroutine xzdotu (n, zx, incx, zy, incy, retval) + double complex zdotu, zx(*), zy(*), retval + integer n, incx, incy + external zdotu + retval = zdotu (n, zx, incx, zy, incy) + return + end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/blas-xtra/zconv2.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,77 @@ +c Copyright (C) 2010-2017 VZLU Prague, a.s., Czech Republic +c +c Author: Jaroslav Hajek <highegg@gmail.com> +c +c This file is part of Octave. +c +c Octave is free software; you can redistribute it and/or modify it +c under the terms of the GNU General Public License as published by +c the Free Software Foundation; either version 3 of the License, or +c (at your option) any later version. +c +c Octave is distributed in the hope that it will be useful, but +c WITHOUT ANY WARRANTY; without even the implied warranty of +c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +c GNU General Public License for more details. +c +c You should have received a copy of the GNU General Public License +c along with Octave; see the file COPYING. If not, see +c <http://www.gnu.org/licenses/>. +c + subroutine zconv2o(ma,na,a,mb,nb,b,c) +c purpose: a 2-dimensional outer additive convolution. +c equivalent to the following: +c for i = 1:ma +c for j = 1:na +c c(i:i+mb-1,j:j+mb-1) += a(i,j)*b +c endfor +c endfor +c arguments: +c ma,na (in) dimensions of a +c a (in) 1st matrix +c mb,nb (in) dimensions of b +c b (in) 2nd matrix +c c (inout) accumulator matrix, size (ma+mb-1, na+nb-1) +c + integer ma,na,mb,nb + double complex a(ma,na),b(mb,nb) + double complex c(ma+mb-1,na+nb-1) + integer i,j,k + external zaxpy + do k = 1,na + do j = 1,nb + do i = 1,mb + call zaxpy(ma,b(i,j),a(1,k),1,c(i,j+k-1),1) + end do + end do + end do + end subroutine + + subroutine zconv2i(ma,na,a,mb,nb,b,c) +c purpose: a 2-dimensional inner additive convolution. +c equivalent to the following: +c for i = 1:ma-mb+1 +c for j = 1:na-nb+1 +c c(i,j) = sum (sum (a(i+mb-1:-1:i,j+nb-1:-1:j) .* b)) +c endfor +c endfor +c arguments: +c ma,na (in) dimensions of a +c a (in) 1st matrix +c mb,nb (in) dimensions of b +c b (in) 2nd matrix +c c (inout) accumulator matrix, size (ma+mb-1, na+nb-1) +c + integer ma,na,mb,nb + double complex a(ma,na),b(mb,nb) + double complex c(ma-mb+1,na-nb+1) + integer i,j,k + external zaxpy + do k = 1,na-nb+1 + do j = 1,nb + do i = 1,mb + call zaxpy(ma-mb+1,b(i,j),a(mb+1-i,k+nb-j),1,c(1,k),1) + end do + end do + end do + end subroutine
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/blas-xtra/zdconv2.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,83 @@ +c Copyright (C) 2010-2017 VZLU Prague, a.s., Czech Republic +c +c Author: Jaroslav Hajek <highegg@gmail.com> +c +c This file is part of Octave. +c +c Octave is free software; you can redistribute it and/or modify it +c under the terms of the GNU General Public License as published by +c the Free Software Foundation; either version 3 of the License, or +c (at your option) any later version. +c +c Octave is distributed in the hope that it will be useful, but +c WITHOUT ANY WARRANTY; without even the implied warranty of +c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +c GNU General Public License for more details. +c +c You should have received a copy of the GNU General Public License +c along with Octave; see the file COPYING. If not, see +c <http://www.gnu.org/licenses/>. +c + subroutine zdconv2o(ma,na,a,mb,nb,b,c) +c purpose: a 2-dimensional outer additive convolution. +c equivalent to the following: +c for i = 1:ma +c for j = 1:na +c c(i:i+mb-1,j:j+mb-1) += a(i,j)*b +c endfor +c endfor +c arguments: +c ma,na (in) dimensions of a +c a (in) 1st matrix +c mb,nb (in) dimensions of b +c b (in) 2nd matrix +c c (inout) accumulator matrix, size (ma+mb-1, na+nb-1) +c + integer ma,na,mb,nb + double complex a(ma,na) + double precision b(mb,nb) + double complex c(ma+mb-1,na+nb-1) + double complex btmp + integer i,j,k + external zaxpy + do k = 1,na + do j = 1,nb + do i = 1,mb + btmp = b(i,j) + call zaxpy(ma,btmp,a(1,k),1,c(i,j+k-1),1) + end do + end do + end do + end subroutine + + subroutine zdconv2i(ma,na,a,mb,nb,b,c) +c purpose: a 2-dimensional inner additive convolution. +c equivalent to the following: +c for i = 1:ma-mb+1 +c for j = 1:na-nb+1 +c c(i,j) = sum (sum (a(i:i+mb-1,j:j+nb-1) .* b)) +c endfor +c endfor +c arguments: +c ma,na (in) dimensions of a +c a (in) 1st matrix +c mb,nb (in) dimensions of b +c b (in) 2nd matrix +c c (inout) accumulator matrix, size (ma+mb-1, na+nb-1) +c + integer ma,na,mb,nb + double complex a(ma,na) + double precision b(mb,nb) + double complex c(ma-mb+1,na-nb+1) + double complex btmp + integer i,j,k + external zaxpy + do k = 1,na-nb+1 + do j = 1,nb + do i = 1,mb + btmp = b(i,j) + call zaxpy(ma-mb+1,btmp,a(mb+1-i,k+nb-j),1,c(1,k),1) + end do + end do + end do + end subroutine
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/blas-xtra/zdotc3.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,59 @@ +c Copyright (C) 2009-2017 VZLU Prague, a.s., Czech Republic +c +c Author: Jaroslav Hajek <highegg@gmail.com> +c +c This file is part of Octave. +c +c Octave is free software; you can redistribute it and/or modify it +c under the terms of the GNU General Public License as published by +c the Free Software Foundation; either version 3 of the License, or +c (at your option) any later version. +c +c Octave is distributed in the hope that it will be useful, but +c WITHOUT ANY WARRANTY; without even the implied warranty of +c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +c GNU General Public License for more details. +c +c You should have received a copy of the GNU General Public License +c along with Octave; see the file COPYING. If not, see +c <http://www.gnu.org/licenses/>. +c + subroutine zdotc3(m,n,k,a,b,c) +c purpose: a 3-dimensional dot product. +c c = sum (conj (a) .* b, 2), where a and b are 3d arrays. +c arguments: +c m,n,k (in) the dimensions of a and b +c a,b (in) double complex input arrays of size (m,k,n) +c c (out) double complex output array, size (m,n) + integer m,n,k,i,j,l + double complex a(m,k,n),b(m,k,n) + double complex c(m,n) + + double complex zdotc + external zdotc + +c quick return if possible. + if (m <= 0 .or. n <= 0) return + + if (m == 1) then +c the column-major case. + do j = 1,n + c(1,j) = zdotc(k,a(1,1,j),1,b(1,1,j),1) + end do + else +c We prefer performance here, because that's what we generally +c do by default in reduction functions. Besides, the accuracy +c of xDOT is questionable. Hence, do a cache-aligned nested loop. + do j = 1,n + do i = 1,m + c(i,j) = 0d0 + end do + do l = 1,k + do i = 1,m + c(i,j) = c(i,j) + conjg(a(i,l,j))*b(i,l,j) + end do + end do + end do + end if + + end subroutine
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/blas-xtra/zmatm3.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,69 @@ +c Copyright (C) 2009-2017 VZLU Prague, a.s., Czech Republic +c +c Author: Jaroslav Hajek <highegg@gmail.com> +c +c This file is part of Octave. +c +c Octave is free software; you can redistribute it and/or modify it +c under the terms of the GNU General Public License as published by +c the Free Software Foundation; either version 3 of the License, or +c (at your option) any later version. +c +c Octave is distributed in the hope that it will be useful, but +c WITHOUT ANY WARRANTY; without even the implied warranty of +c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +c GNU General Public License for more details. +c +c You should have received a copy of the GNU General Public License +c along with Octave; see the file COPYING. If not, see +c <http://www.gnu.org/licenses/>. +c + subroutine zmatm3(m,n,k,np,a,b,c) +c purpose: a 3-dimensional matrix product. +c given a (m,k,np) array a and (k,n,np) array b, +c calculates a (m,n,np) array c such that +c for i = 1:np +c c(:,:,i) = a(:,:,i) * b(:,:,i) +c +c arguments: +c m,n,k (in) the dimensions +c np (in) number of multiplications +c a (in) a double complex input array, size (m,k,np) +c b (in) a double complex input array, size (k,n,np) +c c (out) a double complex output array, size (m,n,np) + integer m,n,k,np + double complex a(m*k,np),b(k*n,np) + double complex c(m*n,np) + + double complex zdotu,one,zero + parameter (one = 1d0, zero = 0d0) + external zdotu,zgemv,zgemm + integer i + +c quick return if possible. + if (np <= 0) return + + if (m == 1) then + if (n == 1) then + do i = 1,np + c(1,i) = zdotu(k,a(1,i),1,b(1,i),1) + end do + else + do i = 1,np + call zgemv("T",k,n,one,b(1,i),k,a(1,i),1,zero,c(1,i),1) + end do + end if + else + if (n == 1) then + do i = 1,np + call zgemv("N",m,k,one,a(1,i),m,b(1,i),1,zero,c(1,i),1) + end do + else + do i = 1,np + call zgemm("N","N",m,n,k, + + one,a(1,i),m,b(1,i),k,zero,c(1,i),m) + end do + end if + end if + + end subroutine
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/daspk/datv.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,130 @@ +C Work performed under the auspices of the U.S. Department of Energy +C by Lawrence Livermore National Laboratory under contract number +C W-7405-Eng-48. +C + SUBROUTINE DATV (NEQ, Y, TN, YPRIME, SAVR, V, WGHT, YPTEM, RES, + * IRES, PSOL, Z, VTEM, WP, IWP, CJ, EPLIN, IER, NRE, NPSL, + * RPAR,IPAR) +C +C***BEGIN PROLOGUE DATV +C***DATE WRITTEN 890101 (YYMMDD) +C***REVISION DATE 900926 (YYMMDD) +C +C +C----------------------------------------------------------------------- +C***DESCRIPTION +C +C This routine computes the product +C +C Z = (D-inverse)*(P-inverse)*(dF/dY)*(D*V), +C +C where F(Y) = G(T, Y, CJ*(Y-A)), CJ is a scalar proportional to 1/H, +C and A involves the past history of Y. The quantity CJ*(Y-A) is +C an approximation to the first derivative of Y and is stored +C in the array YPRIME. Note that dF/dY = dG/dY + CJ*dG/dYPRIME. +C +C D is a diagonal scaling matrix, and P is the left preconditioning +C matrix. V is assumed to have L2 norm equal to 1. +C The product is stored in Z and is computed by means of a +C difference quotient, a call to RES, and one call to PSOL. +C +C On entry +C +C NEQ = Problem size, passed to RES and PSOL. +C +C Y = Array containing current dependent variable vector. +C +C YPRIME = Array containing current first derivative of y. +C +C SAVR = Array containing current value of G(T,Y,YPRIME). +C +C V = Real array of length NEQ (can be the same array as Z). +C +C WGHT = Array of length NEQ containing scale factors. +C 1/WGHT(I) are the diagonal elements of the matrix D. +C +C YPTEM = Work array of length NEQ. +C +C VTEM = Work array of length NEQ used to store the +C unscaled version of V. +C +C WP = Real work array used by preconditioner PSOL. +C +C IWP = Integer work array used by preconditioner PSOL. +C +C CJ = Scalar proportional to current value of +C 1/(step size H). +C +C +C On return +C +C Z = Array of length NEQ containing desired scaled +C matrix-vector product. +C +C IRES = Error flag from RES. +C +C IER = Error flag from PSOL. +C +C NRE = The number of calls to RES. +C +C NPSL = The number of calls to PSOL. +C +C----------------------------------------------------------------------- +C***ROUTINES CALLED +C RES, PSOL +C +C***END PROLOGUE DATV +C + INTEGER NEQ, IRES, IWP, IER, NRE, NPSL, IPAR + DOUBLE PRECISION Y, TN, YPRIME, SAVR, V, WGHT, YPTEM, Z, VTEM, + 1 WP, CJ, RPAR + DIMENSION Y(*), YPRIME(*), SAVR(*), V(*), WGHT(*), YPTEM(*), + 1 Z(*), VTEM(*), WP(*), IWP(*), RPAR(*), IPAR(*) + INTEGER I + DOUBLE PRECISION EPLIN + EXTERNAL RES, PSOL +C + IRES = 0 +C----------------------------------------------------------------------- +C Set VTEM = D * V. +C----------------------------------------------------------------------- + DO 10 I = 1,NEQ + 10 VTEM(I) = V(I)/WGHT(I) + IER = 0 +C----------------------------------------------------------------------- +C Store Y in Z and increment Z by VTEM. +C Store YPRIME in YPTEM and increment YPTEM by VTEM*CJ. +C----------------------------------------------------------------------- + DO 20 I = 1,NEQ + YPTEM(I) = YPRIME(I) + VTEM(I)*CJ + 20 Z(I) = Y(I) + VTEM(I) +C----------------------------------------------------------------------- +C Call RES with incremented Y, YPRIME arguments +C stored in Z, YPTEM. VTEM is overwritten with new residual. +C----------------------------------------------------------------------- + CONTINUE + CALL RES(TN,Z,YPTEM,CJ,VTEM,IRES,RPAR,IPAR) + NRE = NRE + 1 + IF (IRES .LT. 0) RETURN +C----------------------------------------------------------------------- +C Set Z = (dF/dY) * VBAR using difference quotient. +C (VBAR is old value of VTEM before calling RES) +C----------------------------------------------------------------------- + DO 70 I = 1,NEQ + 70 Z(I) = VTEM(I) - SAVR(I) +C----------------------------------------------------------------------- +C Apply inverse of left preconditioner to Z. +C----------------------------------------------------------------------- + CALL PSOL (NEQ, TN, Y, YPRIME, SAVR, YPTEM, CJ, WGHT, WP, IWP, + 1 Z, EPLIN, IER, RPAR, IPAR) + NPSL = NPSL + 1 + IF (IER .NE. 0) RETURN +C----------------------------------------------------------------------- +C Apply D-inverse to Z and return. +C----------------------------------------------------------------------- + DO 90 I = 1,NEQ + 90 Z(I) = Z(I)*WGHT(I) + RETURN +C +C------END OF SUBROUTINE DATV------------------------------------------- + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/daspk/dcnst0.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,75 @@ +C Work performed under the auspices of the U.S. Department of Energy +C by Lawrence Livermore National Laboratory under contract number +C W-7405-Eng-48. +C + SUBROUTINE DCNST0 (NEQ, Y, ICNSTR, IRET) +C +C***BEGIN PROLOGUE DCNST0 +C***DATE WRITTEN 950808 (YYMMDD) +C***REVISION DATE 950808 (YYMMDD) +C +C +C----------------------------------------------------------------------- +C***DESCRIPTION +C +C This subroutine checks for constraint violations in the initial +C approximate solution u. +C +C On entry +C +C NEQ -- size of the nonlinear system, and the length of arrays +C Y and ICNSTR. +C +C Y -- real array containing the initial approximate root. +C +C ICNSTR -- INTEGER array of length NEQ containing flags indicating +C which entries in Y are to be constrained. +C if ICNSTR(I) = 2, then Y(I) must be .GT. 0, +C if ICNSTR(I) = 1, then Y(I) must be .GE. 0, +C if ICNSTR(I) = -1, then Y(I) must be .LE. 0, while +C if ICNSTR(I) = -2, then Y(I) must be .LT. 0, while +C if ICNSTR(I) = 0, then Y(I) is not constrained. +C +C On return +C +C IRET -- output flag. +C IRET=0 means that u satisfied all constraints. +C IRET.NE.0 means that Y(IRET) failed to satisfy its +C constraint. +C +C----------------------------------------------------------------------- + IMPLICIT DOUBLE PRECISION(A-H,O-Z) + DIMENSION Y(NEQ), ICNSTR(NEQ) + SAVE ZERO + DATA ZERO/0.D0/ +C----------------------------------------------------------------------- +C Check constraints for initial Y. If a constraint has been violated, +C set IRET = I to signal an error return to calling routine. +C----------------------------------------------------------------------- + IRET = 0 + DO 100 I = 1,NEQ + IF (ICNSTR(I) .EQ. 2) THEN + IF (Y(I) .LE. ZERO) THEN + IRET = I + RETURN + ENDIF + ELSEIF (ICNSTR(I) .EQ. 1) THEN + IF (Y(I) .LT. ZERO) THEN + IRET = I + RETURN + ENDIF + ELSEIF (ICNSTR(I) .EQ. -1) THEN + IF (Y(I) .GT. ZERO) THEN + IRET = I + RETURN + ENDIF + ELSEIF (ICNSTR(I) .EQ. -2) THEN + IF (Y(I) .GE. ZERO) THEN + IRET = I + RETURN + ENDIF + ENDIF + 100 CONTINUE + RETURN +C----------------------- END OF SUBROUTINE DCNST0 ---------------------- + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/daspk/dcnstr.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,124 @@ +C Work performed under the auspices of the U.S. Department of Energy +C by Lawrence Livermore National Laboratory under contract number +C W-7405-Eng-48. +C + SUBROUTINE DCNSTR (NEQ, Y, YNEW, ICNSTR, TAU, RLX, IRET, IVAR) +C +C***BEGIN PROLOGUE DCNSTR +C***DATE WRITTEN 950808 (YYMMDD) +C***REVISION DATE 950814 (YYMMDD) +C +C +C----------------------------------------------------------------------- +C***DESCRIPTION +C +C This subroutine checks for constraint violations in the proposed +C new approximate solution YNEW. +C If a constraint violation occurs, then a new step length, TAU, +C is calculated, and this value is to be given to the linesearch routine +C to calculate a new approximate solution YNEW. +C +C On entry: +C +C NEQ -- size of the nonlinear system, and the length of arrays +C Y, YNEW and ICNSTR. +C +C Y -- real array containing the current approximate y. +C +C YNEW -- real array containing the new approximate y. +C +C ICNSTR -- INTEGER array of length NEQ containing flags indicating +C which entries in YNEW are to be constrained. +C if ICNSTR(I) = 2, then YNEW(I) must be .GT. 0, +C if ICNSTR(I) = 1, then YNEW(I) must be .GE. 0, +C if ICNSTR(I) = -1, then YNEW(I) must be .LE. 0, while +C if ICNSTR(I) = -2, then YNEW(I) must be .LT. 0, while +C if ICNSTR(I) = 0, then YNEW(I) is not constrained. +C +C RLX -- real scalar restricting update, if ICNSTR(I) = 2 or -2, +C to ABS( (YNEW-Y)/Y ) < FAC2*RLX in component I. +C +C TAU -- the current size of the step length for the linesearch. +C +C On return +C +C TAU -- the adjusted size of the step length if a constraint +C violation occurred (otherwise, it is unchanged). it is +C the step length to give to the linesearch routine. +C +C IRET -- output flag. +C IRET=0 means that YNEW satisfied all constraints. +C IRET=1 means that YNEW failed to satisfy all the +C constraints, and a new linesearch step +C must be computed. +C +C IVAR -- index of variable causing constraint to be violated. +C +C----------------------------------------------------------------------- + IMPLICIT DOUBLE PRECISION(A-H,O-Z) + DIMENSION Y(NEQ), YNEW(NEQ), ICNSTR(NEQ) + SAVE FAC, FAC2, ZERO + DATA FAC /0.6D0/, FAC2 /0.9D0/, ZERO/0.0D0/ +C----------------------------------------------------------------------- +C Check constraints for proposed new step YNEW. If a constraint has +C been violated, then calculate a new step length, TAU, to be +C used in the linesearch routine. +C----------------------------------------------------------------------- + IRET = 0 + RDYMX = ZERO + IVAR = 0 + DO 100 I = 1,NEQ +C + IF (ICNSTR(I) .EQ. 2) THEN + RDY = ABS( (YNEW(I)-Y(I))/Y(I) ) + IF (RDY .GT. RDYMX) THEN + RDYMX = RDY + IVAR = I + ENDIF + IF (YNEW(I) .LE. ZERO) THEN + TAU = FAC*TAU + IVAR = I + IRET = 1 + RETURN + ENDIF +C + ELSEIF (ICNSTR(I) .EQ. 1) THEN + IF (YNEW(I) .LT. ZERO) THEN + TAU = FAC*TAU + IVAR = I + IRET = 1 + RETURN + ENDIF +C + ELSEIF (ICNSTR(I) .EQ. -1) THEN + IF (YNEW(I) .GT. ZERO) THEN + TAU = FAC*TAU + IVAR = I + IRET = 1 + RETURN + ENDIF +C + ELSEIF (ICNSTR(I) .EQ. -2) THEN + RDY = ABS( (YNEW(I)-Y(I))/Y(I) ) + IF (RDY .GT. RDYMX) THEN + RDYMX = RDY + IVAR = I + ENDIF + IF (YNEW(I) .GE. ZERO) THEN + TAU = FAC*TAU + IVAR = I + IRET = 1 + RETURN + ENDIF +C + ENDIF + 100 CONTINUE + + IF(RDYMX .GE. RLX) THEN + TAU = FAC2*TAU*RLX/RDYMX + IRET = 1 + ENDIF +C + RETURN +C----------------------- END OF SUBROUTINE DCNSTR ---------------------- + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/daspk/ddasic.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,169 @@ +C Work performed under the auspices of the U.S. Department of Energy +C by Lawrence Livermore National Laboratory under contract number +C W-7405-Eng-48. +C + SUBROUTINE DDASIC (X, Y, YPRIME, NEQ, ICOPT, ID, RES, JAC, PSOL, + * H, WT, NIC, IDID, RPAR, IPAR, PHI, SAVR, DELTA, E, YIC, YPIC, + * PWK, WM, IWM, HMIN, UROUND, EPLI, SQRTN, RSQRTN, EPCONI, + * STPTOL, JFLG, ICNFLG, ICNSTR, NLSIC) +C +C***BEGIN PROLOGUE DDASIC +C***REFER TO DDASPK +C***DATE WRITTEN 940628 (YYMMDD) +C***REVISION DATE 941206 (YYMMDD) +C***REVISION DATE 950714 (YYMMDD) +C +C----------------------------------------------------------------------- +C***DESCRIPTION +C +C DDASIC is a driver routine to compute consistent initial values +C for Y and YPRIME. There are two different options: +C Denoting the differential variables in Y by Y_d, and +C the algebraic variables by Y_a, the problem solved is either: +C 1. Given Y_d, calculate Y_a and Y_d', or +C 2. Given Y', calculate Y. +C In either case, initial values for the given components +C are input, and initial guesses for the unknown components +C must also be provided as input. +C +C The external routine NLSIC solves the resulting nonlinear system. +C +C The parameters represent +C +C X -- Independent variable. +C Y -- Solution vector at X. +C YPRIME -- Derivative of solution vector. +C NEQ -- Number of equations to be integrated. +C ICOPT -- Flag indicating initial condition option chosen. +C ICOPT = 1 for option 1 above. +C ICOPT = 2 for option 2. +C ID -- Array of dimension NEQ, which must be initialized +C if option 1 is chosen. +C ID(i) = +1 if Y_i is a differential variable, +C ID(i) = -1 if Y_i is an algebraic variable. +C RES -- External user-supplied subroutine to evaluate the +C residual. See RES description in DDASPK prologue. +C JAC -- External user-supplied routine to update Jacobian +C or preconditioner information in the nonlinear solver +C (optional). See JAC description in DDASPK prologue. +C PSOL -- External user-supplied routine to solve +C a linear system using preconditioning. +C See PSOL in DDASPK prologue. +C H -- Scaling factor in iteration matrix. DDASIC may +C reduce H to achieve convergence. +C WT -- Vector of weights for error criterion. +C NIC -- Input number of initial condition calculation call +C (= 1 or 2). +C IDID -- Completion code. See IDID in DDASPK prologue. +C RPAR,IPAR -- Real and integer parameter arrays that +C are used for communication between the +C calling program and external user routines. +C They are not altered by DNSK +C PHI -- Work space for DDASIC of length at least 2*NEQ. +C SAVR -- Work vector for DDASIC of length NEQ. +C DELTA -- Work vector for DDASIC of length NEQ. +C E -- Work vector for DDASIC of length NEQ. +C YIC,YPIC -- Work vectors for DDASIC, each of length NEQ. +C PWK -- Work vector for DDASIC of length NEQ. +C WM,IWM -- Real and integer arrays storing +C information required by the linear solver. +C EPCONI -- Test constant for Newton iteration convergence. +C ICNFLG -- Flag showing whether constraints on Y are to apply. +C ICNSTR -- Integer array of length NEQ with constraint types. +C +C The other parameters are for use internally by DDASIC. +C +C----------------------------------------------------------------------- +C***ROUTINES CALLED +C DCOPY, NLSIC +C +C***END PROLOGUE DDASIC +C +C + IMPLICIT DOUBLE PRECISION(A-H,O-Z) + DIMENSION Y(*),YPRIME(*),ID(*),WT(*),PHI(NEQ,*) + DIMENSION SAVR(*),DELTA(*),E(*),YIC(*),YPIC(*),PWK(*) + DIMENSION WM(*),IWM(*), RPAR(*),IPAR(*), ICNSTR(*) + EXTERNAL RES, JAC, PSOL, NLSIC +C + PARAMETER (LCFN=15) + PARAMETER (LMXNH=34) +C +C The following parameters are data-loaded here: +C RHCUT = factor by which H is reduced on retry of Newton solve. +C RATEMX = maximum convergence rate for which Newton iteration +C is considered converging. +C + SAVE RHCUT, RATEMX + DATA RHCUT/0.1D0/, RATEMX/0.8D0/ +C +C +C----------------------------------------------------------------------- +C BLOCK 1. +C Initializations. +C JSKIP is a flag set to 1 when NIC = 2 and NH = 1, to signal that +C the initial call to the JAC routine is to be skipped then. +C Save Y and YPRIME in PHI. Initialize IDID, NH, and CJ. +C----------------------------------------------------------------------- +C + MXNH = IWM(LMXNH) + IDID = 1 + NH = 1 + JSKIP = 0 + IF (NIC .EQ. 2) JSKIP = 1 + CALL DCOPY (NEQ, Y, 1, PHI(1,1), 1) + CALL DCOPY (NEQ, YPRIME, 1, PHI(1,2), 1) +C + IF (ICOPT .EQ. 2) THEN + CJ = 0.0D0 + ELSE + CJ = 1.0D0/H + ENDIF +C +C----------------------------------------------------------------------- +C BLOCK 2 +C Call the nonlinear system solver to obtain +C consistent initial values for Y and YPRIME. +C----------------------------------------------------------------------- +C + 200 CONTINUE + CALL NLSIC(X,Y,YPRIME,NEQ,ICOPT,ID,RES,JAC,PSOL,H,WT,JSKIP, + * RPAR,IPAR,SAVR,DELTA,E,YIC,YPIC,PWK,WM,IWM,CJ,UROUND, + * EPLI,SQRTN,RSQRTN,EPCONI,RATEMX,STPTOL,JFLG,ICNFLG,ICNSTR, + * IERNLS) +C + IF (IERNLS .EQ. 0) RETURN +C +C----------------------------------------------------------------------- +C BLOCK 3 +C The nonlinear solver was unsuccessful. Increment NCFN. +C Return with IDID = -12 if either +C IERNLS = -1: error is considered unrecoverable, +C ICOPT = 2: we are doing initialization problem type 2, or +C NH = MXNH: the maximum number of H values has been tried. +C Otherwise (problem 1 with IERNLS .GE. 1), reduce H and try again. +C If IERNLS > 1, restore Y and YPRIME to their original values. +C----------------------------------------------------------------------- +C + IWM(LCFN) = IWM(LCFN) + 1 + JSKIP = 0 +C + IF (IERNLS .EQ. -1) GO TO 350 + IF (ICOPT .EQ. 2) GO TO 350 + IF (NH .EQ. MXNH) GO TO 350 +C + NH = NH + 1 + H = H*RHCUT + CJ = 1.0D0/H +C + IF (IERNLS .EQ. 1) GO TO 200 +C + CALL DCOPY (NEQ, PHI(1,1), 1, Y, 1) + CALL DCOPY (NEQ, PHI(1,2), 1, YPRIME, 1) + GO TO 200 +C + 350 IDID = -12 + RETURN +C +C------END OF SUBROUTINE DDASIC----------------------------------------- + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/daspk/ddasid.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,168 @@ +C Work performed under the auspices of the U.S. Department of Energy +C by Lawrence Livermore National Laboratory under contract number +C W-7405-Eng-48. +C + SUBROUTINE DDASID(X,Y,YPRIME,NEQ,ICOPT,ID,RES,JACD,PDUM,H,WT, + * JSDUM,RPAR,IPAR,DUMSVR,DELTA,R,YIC,YPIC,DUMPWK,WM,IWM,CJ,UROUND, + * DUME,DUMS,DUMR,EPCON,RATEMX,STPTOL,JFDUM, + * ICNFLG,ICNSTR,IERNLS) +C +C***BEGIN PROLOGUE DDASID +C***REFER TO DDASPK +C***DATE WRITTEN 940701 (YYMMDD) +C***REVISION DATE 950808 (YYMMDD) +C***REVISION DATE 951110 Removed unreachable block 390. +C +C +C----------------------------------------------------------------------- +C***DESCRIPTION +C +C +C DDASID solves a nonlinear system of algebraic equations of the +C form G(X,Y,YPRIME) = 0 for the unknown parts of Y and YPRIME in +C the initial conditions. +C +C The method used is a modified Newton scheme. +C +C The parameters represent +C +C X -- Independent variable. +C Y -- Solution vector. +C YPRIME -- Derivative of solution vector. +C NEQ -- Number of unknowns. +C ICOPT -- Initial condition option chosen (1 or 2). +C ID -- Array of dimension NEQ, which must be initialized +C if ICOPT = 1. See DDASIC. +C RES -- External user-supplied subroutine to evaluate the +C residual. See RES description in DDASPK prologue. +C JACD -- External user-supplied routine to evaluate the +C Jacobian. See JAC description for the case +C INFO(12) = 0 in the DDASPK prologue. +C PDUM -- Dummy argument. +C H -- Scaling factor for this initial condition calc. +C WT -- Vector of weights for error criterion. +C JSDUM -- Dummy argument. +C RPAR,IPAR -- Real and integer arrays used for communication +C between the calling program and external user +C routines. They are not altered within DASPK. +C DUMSVR -- Dummy argument. +C DELTA -- Work vector for NLS of length NEQ. +C R -- Work vector for NLS of length NEQ. +C YIC,YPIC -- Work vectors for NLS, each of length NEQ. +C DUMPWK -- Dummy argument. +C WM,IWM -- Real and integer arrays storing matrix information +C such as the matrix of partial derivatives, +C permutation vector, and various other information. +C CJ -- Matrix parameter = 1/H (ICOPT = 1) or 0 (ICOPT = 2). +C UROUND -- Unit roundoff. +C DUME -- Dummy argument. +C DUMS -- Dummy argument. +C DUMR -- Dummy argument. +C EPCON -- Tolerance to test for convergence of the Newton +C iteration. +C RATEMX -- Maximum convergence rate for which Newton iteration +C is considered converging. +C JFDUM -- Dummy argument. +C STPTOL -- Tolerance used in calculating the minimum lambda +C value allowed. +C ICNFLG -- Integer scalar. If nonzero, then constraint +C violations in the proposed new approximate solution +C will be checked for, and the maximum step length +C will be adjusted accordingly. +C ICNSTR -- Integer array of length NEQ containing flags for +C checking constraints. +C IERNLS -- Error flag for nonlinear solver. +C 0 ==> nonlinear solver converged. +C 1,2 ==> recoverable error inside nonlinear solver. +C 1 => retry with current Y, YPRIME +C 2 => retry with original Y, YPRIME +C -1 ==> unrecoverable error in nonlinear solver. +C +C All variables with "DUM" in their names are dummy variables +C which are not used in this routine. +C +C----------------------------------------------------------------------- +C +C***ROUTINES CALLED +C RES, DMATD, DNSID +C +C***END PROLOGUE DDASID +C +C + IMPLICIT DOUBLE PRECISION(A-H,O-Z) + DIMENSION Y(*),YPRIME(*),ID(*),WT(*),ICNSTR(*) + DIMENSION DELTA(*),R(*),YIC(*),YPIC(*) + DIMENSION WM(*),IWM(*), RPAR(*),IPAR(*) + EXTERNAL RES, JACD +C + PARAMETER (LNRE=12, LNJE=13, LMXNIT=32, LMXNJ=33) +C +C +C Perform initializations. +C + MXNIT = IWM(LMXNIT) + MXNJ = IWM(LMXNJ) + IERNLS = 0 + NJ = 0 +C +C Call RES to initialize DELTA. +C + IRES = 0 + IWM(LNRE) = IWM(LNRE) + 1 + CALL RES(X,Y,YPRIME,CJ,DELTA,IRES,RPAR,IPAR) + IF (IRES .LT. 0) GO TO 370 +C +C Looping point for updating the Jacobian. +C +300 CONTINUE +C +C Initialize all error flags to zero. +C + IERJ = 0 + IRES = 0 + IERNEW = 0 +C +C Reevaluate the iteration matrix, J = dG/dY + CJ*dG/dYPRIME, +C where G(X,Y,YPRIME) = 0. +C + NJ = NJ + 1 + IWM(LNJE)=IWM(LNJE)+1 + CALL DMATD(NEQ,X,Y,YPRIME,DELTA,CJ,H,IERJ,WT,R, + * WM,IWM,RES,IRES,UROUND,JACD,RPAR,IPAR) + IF (IRES .LT. 0 .OR. IERJ .NE. 0) GO TO 370 +C +C Call the nonlinear Newton solver for up to MXNIT iterations. +C + CALL DNSID(X,Y,YPRIME,NEQ,ICOPT,ID,RES,WT,RPAR,IPAR,DELTA,R, + * YIC,YPIC,WM,IWM,CJ,EPCON,RATEMX,MXNIT,STPTOL, + * ICNFLG,ICNSTR,IERNEW) +C + IF (IERNEW .EQ. 1 .AND. NJ .LT. MXNJ) THEN +C +C MXNIT iterations were done, the convergence rate is < 1, +C and the number of Jacobian evaluations is less than MXNJ. +C Call RES, reevaluate the Jacobian, and try again. +C + IWM(LNRE)=IWM(LNRE)+1 + CALL RES(X,Y,YPRIME,CJ,DELTA,IRES,RPAR,IPAR) + IF (IRES .LT. 0) GO TO 370 + GO TO 300 + ENDIF +C + IF (IERNEW .NE. 0) GO TO 380 + + RETURN +C +C +C Unsuccessful exits from nonlinear solver. +C Compute IERNLS accordingly. +C +370 IERNLS = 2 + IF (IRES .LE. -2) IERNLS = -1 + RETURN +C +380 IERNLS = MIN(IERNEW,2) + RETURN +C +C------END OF SUBROUTINE DDASID----------------------------------------- + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/daspk/ddasik.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,176 @@ +C Work perfored under the auspices of the U.S. Department of Energy +C by Lawrence Livermore National Laboratory under contract number +C W-7405-Eng-48. +C + SUBROUTINE DDASIK(X,Y,YPRIME,NEQ,ICOPT,ID,RES,JACK,PSOL,H,WT, + * JSKIP,RPAR,IPAR,SAVR,DELTA,R,YIC,YPIC,PWK,WM,IWM,CJ,UROUND, + * EPLI,SQRTN,RSQRTN,EPCON,RATEMX,STPTOL,JFLG, + * ICNFLG,ICNSTR,IERNLS) +C +C***BEGIN PROLOGUE DDASIK +C***REFER TO DDASPK +C***DATE WRITTEN 941026 (YYMMDD) +C***REVISION DATE 950808 (YYMMDD) +C***REVISION DATE 951110 Removed unreachable block 390. +C +C +C----------------------------------------------------------------------- +C***DESCRIPTION +C +C +C DDASIK solves a nonlinear system of algebraic equations of the +C form G(X,Y,YPRIME) = 0 for the unknown parts of Y and YPRIME in +C the initial conditions. +C +C An initial value for Y and initial guess for YPRIME are input. +C +C The method used is a Newton scheme with Krylov iteration and a +C linesearch algorithm. +C +C The parameters represent +C +C X -- Independent variable. +C Y -- Solution vector at x. +C YPRIME -- Derivative of solution vector. +C NEQ -- Number of equations to be integrated. +C ICOPT -- Initial condition option chosen (1 or 2). +C ID -- Array of dimension NEQ, which must be initialized +C if ICOPT = 1. See DDASIC. +C RES -- External user-supplied subroutine +C to evaluate the residual. See RES description +C in DDASPK prologue. +C JACK -- External user-supplied routine to update +C the preconditioner. (This is optional). +C See JAC description for the case +C INFO(12) = 1 in the DDASPK prologue. +C PSOL -- External user-supplied routine to solve +C a linear system using preconditioning. +C (This is optional). See explanation inside DDASPK. +C H -- Scaling factor for this initial condition calc. +C WT -- Vector of weights for error criterion. +C JSKIP -- input flag to signal if initial JAC call is to be +C skipped. 1 => skip the call, 0 => do not skip call. +C RPAR,IPAR -- Real and integer arrays used for communication +C between the calling program and external user +C routines. They are not altered within DASPK. +C SAVR -- Work vector for DDASIK of length NEQ. +C DELTA -- Work vector for DDASIK of length NEQ. +C R -- Work vector for DDASIK of length NEQ. +C YIC,YPIC -- Work vectors for DDASIK, each of length NEQ. +C PWK -- Work vector for DDASIK of length NEQ. +C WM,IWM -- Real and integer arrays storing +C matrix information for linear system +C solvers, and various other information. +C CJ -- Matrix parameter = 1/H (ICOPT = 1) or 0 (ICOPT = 2). +C UROUND -- Unit roundoff. +C EPLI -- convergence test constant. +C See DDASPK prologue for more details. +C SQRTN -- Square root of NEQ. +C RSQRTN -- reciprical of square root of NEQ. +C EPCON -- Tolerance to test for convergence of the Newton +C iteration. +C RATEMX -- Maximum convergence rate for which Newton iteration +C is considered converging. +C JFLG -- Flag showing whether a Jacobian routine is supplied. +C ICNFLG -- Integer scalar. If nonzero, then constraint +C violations in the proposed new approximate solution +C will be checked for, and the maximum step length +C will be adjusted accordingly. +C ICNSTR -- Integer array of length NEQ containing flags for +C checking constraints. +C IERNLS -- Error flag for nonlinear solver. +C 0 ==> nonlinear solver converged. +C 1,2 ==> recoverable error inside nonlinear solver. +C 1 => retry with current Y, YPRIME +C 2 => retry with original Y, YPRIME +C -1 ==> unrecoverable error in nonlinear solver. +C +C----------------------------------------------------------------------- +C +C***ROUTINES CALLED +C RES, JACK, DNSIK, DCOPY +C +C***END PROLOGUE DDASIK +C +C + IMPLICIT DOUBLE PRECISION(A-H,O-Z) + DIMENSION Y(*),YPRIME(*),ID(*),WT(*),ICNSTR(*) + DIMENSION SAVR(*),DELTA(*),R(*),YIC(*),YPIC(*),PWK(*) + DIMENSION WM(*),IWM(*), RPAR(*),IPAR(*) + EXTERNAL RES, JACK, PSOL +C + PARAMETER (LNRE=12, LNJE=13, LLOCWP=29, LLCIWP=30) + PARAMETER (LMXNIT=32, LMXNJ=33) +C +C +C Perform initializations. +C + LWP = IWM(LLOCWP) + LIWP = IWM(LLCIWP) + MXNIT = IWM(LMXNIT) + MXNJ = IWM(LMXNJ) + IERNLS = 0 + NJ = 0 + EPLIN = EPLI*EPCON +C +C Call RES to initialize DELTA. +C + IRES = 0 + IWM(LNRE) = IWM(LNRE) + 1 + CALL RES(X,Y,YPRIME,CJ,DELTA,IRES,RPAR,IPAR) + IF (IRES .LT. 0) GO TO 370 +C +C Looping point for updating the preconditioner. +C + 300 CONTINUE +C +C Initialize all error flags to zero. +C + IERPJ = 0 + IRES = 0 + IERNEW = 0 +C +C If a Jacobian routine was supplied, call it. +C + IF (JFLG .EQ. 1 .AND. JSKIP .EQ. 0) THEN + NJ = NJ + 1 + IWM(LNJE)=IWM(LNJE)+1 + CALL JACK (RES, IRES, NEQ, X, Y, YPRIME, WT, DELTA, R, H, CJ, + * WM(LWP), IWM(LIWP), IERPJ, RPAR, IPAR) + IF (IRES .LT. 0 .OR. IERPJ .NE. 0) GO TO 370 + ENDIF + JSKIP = 0 +C +C Call the nonlinear Newton solver for up to MXNIT iterations. +C + CALL DNSIK(X,Y,YPRIME,NEQ,ICOPT,ID,RES,PSOL,WT,RPAR,IPAR, + * SAVR,DELTA,R,YIC,YPIC,PWK,WM,IWM,CJ,SQRTN,RSQRTN, + * EPLIN,EPCON,RATEMX,MXNIT,STPTOL,ICNFLG,ICNSTR,IERNEW) +C + IF (IERNEW .EQ. 1 .AND. NJ .LT. MXNJ .AND. JFLG .EQ. 1) THEN +C +C Up to MXNIT iterations were done, the convergence rate is < 1, +C a Jacobian routine is supplied, and the number of JACK calls +C is less than MXNJ. +C Copy the residual SAVR to DELTA, call JACK, and try again. +C + CALL DCOPY (NEQ, SAVR, 1, DELTA, 1) + GO TO 300 + ENDIF +C + IF (IERNEW .NE. 0) GO TO 380 + RETURN +C +C +C Unsuccessful exits from nonlinear solver. +C Set IERNLS accordingly. +C + 370 IERNLS = 2 + IF (IRES .LE. -2) IERNLS = -1 + RETURN +C + 380 IERNLS = MIN(IERNEW,2) + RETURN +C +C----------------------- END OF SUBROUTINE DDASIK----------------------- + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/daspk/ddaspk.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,2360 @@ +C Work performed under the auspices of the U.S. Department of Energy +C by Lawrence Livermore National Laboratory under contract number +C W-7405-Eng-48. +C + SUBROUTINE DDASPK (RES, NEQ, T, Y, YPRIME, TOUT, INFO, RTOL, ATOL, + * IDID, RWORK, LRW, IWORK, LIW, RPAR, IPAR, JAC, PSOL) +C +C***BEGIN PROLOGUE DDASPK +C***DATE WRITTEN 890101 (YYMMDD) +C***REVISION DATE 910624 +C***REVISION DATE 920929 (CJ in RES call, RES counter fix.) +C***REVISION DATE 921215 (Warnings on poor iteration performance) +C***REVISION DATE 921216 (NRMAX as optional input) +C***REVISION DATE 930315 (Name change: DDINI to DDINIT) +C***REVISION DATE 940822 (Replaced initial condition calculation) +C***REVISION DATE 941101 (Added linesearch in I.C. calculations) +C***REVISION DATE 941220 (Misc. corrections throughout) +C***REVISION DATE 950125 (Added DINVWT routine) +C***REVISION DATE 950714 (Misc. corrections throughout) +C***REVISION DATE 950802 (Default NRMAX = 5, based on tests.) +C***REVISION DATE 950808 (Optional error test added.) +C***REVISION DATE 950814 (Added I.C. constraints and INFO(14)) +C***REVISION DATE 950828 (Various minor corrections.) +C***REVISION DATE 951006 (Corrected WT scaling in DFNRMK.) +C***REVISION DATE 960129 (Corrected RL bug in DLINSD, DLINSK.) +C***REVISION DATE 960301 (Added NONNEG to SAVE statement.) +C***CATEGORY NO. I1A2 +C***KEYWORDS DIFFERENTIAL/ALGEBRAIC, BACKWARD DIFFERENTIATION FORMULAS, +C IMPLICIT DIFFERENTIAL SYSTEMS, KRYLOV ITERATION +C***AUTHORS Linda R. Petzold, Peter N. Brown, Alan C. Hindmarsh, and +C Clement W. Ulrich +C Center for Computational Sciences & Engineering, L-316 +C Lawrence Livermore National Laboratory +C P.O. Box 808, +C Livermore, CA 94551 +C***PURPOSE This code solves a system of differential/algebraic +C equations of the form +C G(t,y,y') = 0 , +C using a combination of Backward Differentiation Formula +C (BDF) methods and a choice of two linear system solution +C methods: direct (dense or band) or Krylov (iterative). +C This version is in double precision. +C----------------------------------------------------------------------- +C***DESCRIPTION +C +C *Usage: +C +C IMPLICIT DOUBLE PRECISION(A-H,O-Z) +C INTEGER NEQ, INFO(N), IDID, LRW, LIW, IWORK(LIW), IPAR(*) +C DOUBLE PRECISION T, Y(*), YPRIME(*), TOUT, RTOL(*), ATOL(*), +C RWORK(LRW), RPAR(*) +C EXTERNAL RES, JAC, PSOL +C +C CALL DDASPK (RES, NEQ, T, Y, YPRIME, TOUT, INFO, RTOL, ATOL, +C * IDID, RWORK, LRW, IWORK, LIW, RPAR, IPAR, JAC, PSOL) +C +C Quantities which may be altered by the code are: +C T, Y(*), YPRIME(*), INFO(*), RTOL, ATOL, IDID, RWORK(*), IWORK(*) +C +C +C *Arguments: +C +C RES:EXT This is the name of a subroutine which you +C provide to define the residual function G(t,y,y') +C of the differential/algebraic system. +C +C NEQ:IN This is the number of equations in the system. +C +C T:INOUT This is the current value of the independent +C variable. +C +C Y(*):INOUT This array contains the solution components at T. +C +C YPRIME(*):INOUT This array contains the derivatives of the solution +C components at T. +C +C TOUT:IN This is a point at which a solution is desired. +C +C INFO(N):IN This is an integer array used to communicate details +C of how the solution is to be carried out, such as +C tolerance type, matrix structure, step size and +C order limits, and choice of nonlinear system method. +C N must be at least 20. +C +C RTOL,ATOL:INOUT These quantities represent absolute and relative +C error tolerances (on local error) which you provide +C to indicate how accurately you wish the solution to +C be computed. You may choose them to be both scalars +C or else both arrays of length NEQ. +C +C IDID:OUT This integer scalar is an indicator reporting what +C the code did. You must monitor this variable to +C decide what action to take next. +C +C RWORK:WORK A real work array of length LRW which provides the +C code with needed storage space. +C +C LRW:IN The length of RWORK. +C +C IWORK:WORK An integer work array of length LIW which provides +C the code with needed storage space. +C +C LIW:IN The length of IWORK. +C +C RPAR,IPAR:IN These are real and integer parameter arrays which +C you can use for communication between your calling +C program and the RES, JAC, and PSOL subroutines. +C +C JAC:EXT This is the name of a subroutine which you may +C provide (optionally) for calculating Jacobian +C (partial derivative) data involved in solving linear +C systems within DDASPK. +C +C PSOL:EXT This is the name of a subroutine which you must +C provide for solving linear systems if you selected +C a Krylov method. The purpose of PSOL is to solve +C linear systems involving a left preconditioner P. +C +C *Overview +C +C The DDASPK solver uses the backward differentiation formulas of +C orders one through five to solve a system of the form G(t,y,y') = 0 +C for y = Y and y' = YPRIME. Values for Y and YPRIME at the initial +C time must be given as input. These values should be consistent, +C that is, if T, Y, YPRIME are the given initial values, they should +C satisfy G(T,Y,YPRIME) = 0. However, if consistent values are not +C known, in many cases you can have DDASPK solve for them -- see INFO(11). +C (This and other options are described in more detail below.) +C +C Normally, DDASPK solves the system from T to TOUT. It is easy to +C continue the solution to get results at additional TOUT. This is +C the interval mode of operation. Intermediate results can also be +C obtained easily by specifying INFO(3). +C +C On each step taken by DDASPK, a sequence of nonlinear algebraic +C systems arises. These are solved by one of two types of +C methods: +C * a Newton iteration with a direct method for the linear +C systems involved (INFO(12) = 0), or +C * a Newton iteration with a preconditioned Krylov iterative +C method for the linear systems involved (INFO(12) = 1). +C +C The direct method choices are dense and band matrix solvers, +C with either a user-supplied or an internal difference quotient +C Jacobian matrix, as specified by INFO(5) and INFO(6). +C In the band case, INFO(6) = 1, you must supply half-bandwidths +C in IWORK(1) and IWORK(2). +C +C The Krylov method is the Generalized Minimum Residual (GMRES) +C method, in either complete or incomplete form, and with +C scaling and preconditioning. The method is implemented +C in an algorithm called SPIGMR. Certain options in the Krylov +C method case are specified by INFO(13) and INFO(15). +C +C If the Krylov method is chosen, you may supply a pair of routines, +C JAC and PSOL, to apply preconditioning to the linear system. +C If the system is A*x = b, the matrix is A = dG/dY + CJ*dG/dYPRIME +C (of order NEQ). This system can then be preconditioned in the form +C (P-inverse)*A*x = (P-inverse)*b, with left preconditioner P. +C (DDASPK does not allow right preconditioning.) +C Then the Krylov method is applied to this altered, but equivalent, +C linear system, hopefully with much better performance than without +C preconditioning. (In addition, a diagonal scaling matrix based on +C the tolerances is also introduced into the altered system.) +C +C The JAC routine evaluates any data needed for solving systems +C with coefficient matrix P, and PSOL carries out that solution. +C In any case, in order to improve convergence, you should try to +C make P approximate the matrix A as much as possible, while keeping +C the system P*x = b reasonably easy and inexpensive to solve for x, +C given a vector b. +C +C +C *Description +C +C------INPUT - WHAT TO DO ON THE FIRST CALL TO DDASPK------------------- +C +C +C The first call of the code is defined to be the start of each new +C problem. Read through the descriptions of all the following items, +C provide sufficient storage space for designated arrays, set +C appropriate variables for the initialization of the problem, and +C give information about how you want the problem to be solved. +C +C +C RES -- Provide a subroutine of the form +C +C SUBROUTINE RES (T, Y, YPRIME, CJ, DELTA, IRES, RPAR, IPAR) +C +C to define the system of differential/algebraic +C equations which is to be solved. For the given values +C of T, Y and YPRIME, the subroutine should return +C the residual of the differential/algebraic system +C DELTA = G(T,Y,YPRIME) +C DELTA is a vector of length NEQ which is output from RES. +C +C Subroutine RES must not alter T, Y, YPRIME, or CJ. +C You must declare the name RES in an EXTERNAL +C statement in your program that calls DDASPK. +C You must dimension Y, YPRIME, and DELTA in RES. +C +C The input argument CJ can be ignored, or used to rescale +C constraint equations in the system (see Ref. 2, p. 145). +C Note: In this respect, DDASPK is not downward-compatible +C with DDASSL, which does not have the RES argument CJ. +C +C IRES is an integer flag which is always equal to zero +C on input. Subroutine RES should alter IRES only if it +C encounters an illegal value of Y or a stop condition. +C Set IRES = -1 if an input value is illegal, and DDASPK +C will try to solve the problem without getting IRES = -1. +C If IRES = -2, DDASPK will return control to the calling +C program with IDID = -11. +C +C RPAR and IPAR are real and integer parameter arrays which +C you can use for communication between your calling program +C and subroutine RES. They are not altered by DDASPK. If you +C do not need RPAR or IPAR, ignore these parameters by treat- +C ing them as dummy arguments. If you do choose to use them, +C dimension them in your calling program and in RES as arrays +C of appropriate length. +C +C NEQ -- Set it to the number of equations in the system (NEQ .GE. 1). +C +C T -- Set it to the initial point of the integration. (T must be +C a variable.) +C +C Y(*) -- Set this array to the initial values of the NEQ solution +C components at the initial point. You must dimension Y of +C length at least NEQ in your calling program. +C +C YPRIME(*) -- Set this array to the initial values of the NEQ first +C derivatives of the solution components at the initial +C point. You must dimension YPRIME at least NEQ in your +C calling program. +C +C TOUT - Set it to the first point at which a solution is desired. +C You cannot take TOUT = T. Integration either forward in T +C (TOUT .GT. T) or backward in T (TOUT .LT. T) is permitted. +C +C The code advances the solution from T to TOUT using step +C sizes which are automatically selected so as to achieve the +C desired accuracy. If you wish, the code will return with the +C solution and its derivative at intermediate steps (the +C intermediate-output mode) so that you can monitor them, +C but you still must provide TOUT in accord with the basic +C aim of the code. +C +C The first step taken by the code is a critical one because +C it must reflect how fast the solution changes near the +C initial point. The code automatically selects an initial +C step size which is practically always suitable for the +C problem. By using the fact that the code will not step past +C TOUT in the first step, you could, if necessary, restrict the +C length of the initial step. +C +C For some problems it may not be permissible to integrate +C past a point TSTOP, because a discontinuity occurs there +C or the solution or its derivative is not defined beyond +C TSTOP. When you have declared a TSTOP point (see INFO(4) +C and RWORK(1)), you have told the code not to integrate past +C TSTOP. In this case any tout beyond TSTOP is invalid input. +C +C INFO(*) - Use the INFO array to give the code more details about +C how you want your problem solved. This array should be +C dimensioned of length 20, though DDASPK uses only the +C first 15 entries. You must respond to all of the following +C items, which are arranged as questions. The simplest use +C of DDASPK corresponds to setting all entries of INFO to 0. +C +C INFO(1) - This parameter enables the code to initialize itself. +C You must set it to indicate the start of every new +C problem. +C +C **** Is this the first call for this problem ... +C yes - set INFO(1) = 0 +C no - not applicable here. +C See below for continuation calls. **** +C +C INFO(2) - How much accuracy you want of your solution +C is specified by the error tolerances RTOL and ATOL. +C The simplest use is to take them both to be scalars. +C To obtain more flexibility, they can both be arrays. +C The code must be told your choice. +C +C **** Are both error tolerances RTOL, ATOL scalars ... +C yes - set INFO(2) = 0 +C and input scalars for both RTOL and ATOL +C no - set INFO(2) = 1 +C and input arrays for both RTOL and ATOL **** +C +C INFO(3) - The code integrates from T in the direction of TOUT +C by steps. If you wish, it will return the computed +C solution and derivative at the next intermediate step +C (the intermediate-output mode) or TOUT, whichever comes +C first. This is a good way to proceed if you want to +C see the behavior of the solution. If you must have +C solutions at a great many specific TOUT points, this +C code will compute them efficiently. +C +C **** Do you want the solution only at +C TOUT (and not at the next intermediate step) ... +C yes - set INFO(3) = 0 +C no - set INFO(3) = 1 **** +C +C INFO(4) - To handle solutions at a great many specific +C values TOUT efficiently, this code may integrate past +C TOUT and interpolate to obtain the result at TOUT. +C Sometimes it is not possible to integrate beyond some +C point TSTOP because the equation changes there or it is +C not defined past TSTOP. Then you must tell the code +C this stop condition. +C +C **** Can the integration be carried out without any +C restrictions on the independent variable T ... +C yes - set INFO(4) = 0 +C no - set INFO(4) = 1 +C and define the stopping point TSTOP by +C setting RWORK(1) = TSTOP **** +C +C INFO(5) - used only when INFO(12) = 0 (direct methods). +C To solve differential/algebraic systems you may wish +C to use a matrix of partial derivatives of the +C system of differential equations. If you do not +C provide a subroutine to evaluate it analytically (see +C description of the item JAC in the call list), it will +C be approximated by numerical differencing in this code. +C Although it is less trouble for you to have the code +C compute partial derivatives by numerical differencing, +C the solution will be more reliable if you provide the +C derivatives via JAC. Usually numerical differencing is +C more costly than evaluating derivatives in JAC, but +C sometimes it is not - this depends on your problem. +C +C **** Do you want the code to evaluate the partial deriv- +C atives automatically by numerical differences ... +C yes - set INFO(5) = 0 +C no - set INFO(5) = 1 +C and provide subroutine JAC for evaluating the +C matrix of partial derivatives **** +C +C INFO(6) - used only when INFO(12) = 0 (direct methods). +C DDASPK will perform much better if the matrix of +C partial derivatives, dG/dY + CJ*dG/dYPRIME (here CJ is +C a scalar determined by DDASPK), is banded and the code +C is told this. In this case, the storage needed will be +C greatly reduced, numerical differencing will be performed +C much cheaper, and a number of important algorithms will +C execute much faster. The differential equation is said +C to have half-bandwidths ML (lower) and MU (upper) if +C equation i involves only unknowns Y(j) with +C i-ML .le. j .le. i+MU . +C For all i=1,2,...,NEQ. Thus, ML and MU are the widths +C of the lower and upper parts of the band, respectively, +C with the main diagonal being excluded. If you do not +C indicate that the equation has a banded matrix of partial +C derivatives the code works with a full matrix of NEQ**2 +C elements (stored in the conventional way). Computations +C with banded matrices cost less time and storage than with +C full matrices if 2*ML+MU .lt. NEQ. If you tell the +C code that the matrix of partial derivatives has a banded +C structure and you want to provide subroutine JAC to +C compute the partial derivatives, then you must be careful +C to store the elements of the matrix in the special form +C indicated in the description of JAC. +C +C **** Do you want to solve the problem using a full (dense) +C matrix (and not a special banded structure) ... +C yes - set INFO(6) = 0 +C no - set INFO(6) = 1 +C and provide the lower (ML) and upper (MU) +C bandwidths by setting +C IWORK(1)=ML +C IWORK(2)=MU **** +C +C INFO(7) - You can specify a maximum (absolute value of) +C stepsize, so that the code will avoid passing over very +C large regions. +C +C **** Do you want the code to decide on its own the maximum +C stepsize ... +C yes - set INFO(7) = 0 +C no - set INFO(7) = 1 +C and define HMAX by setting +C RWORK(2) = HMAX **** +C +C INFO(8) - Differential/algebraic problems may occasionally +C suffer from severe scaling difficulties on the first +C step. If you know a great deal about the scaling of +C your problem, you can help to alleviate this problem +C by specifying an initial stepsize H0. +C +C **** Do you want the code to define its own initial +C stepsize ... +C yes - set INFO(8) = 0 +C no - set INFO(8) = 1 +C and define H0 by setting +C RWORK(3) = H0 **** +C +C INFO(9) - If storage is a severe problem, you can save some +C storage by restricting the maximum method order MAXORD. +C The default value is 5. For each order decrease below 5, +C the code requires NEQ fewer locations, but it is likely +C to be slower. In any case, you must have +C 1 .le. MAXORD .le. 5. +C **** Do you want the maximum order to default to 5 ... +C yes - set INFO(9) = 0 +C no - set INFO(9) = 1 +C and define MAXORD by setting +C IWORK(3) = MAXORD **** +C +C INFO(10) - If you know that certain components of the +C solutions to your equations are always nonnegative +C (or nonpositive), it may help to set this +C parameter. There are three options that are +C available: +C 1. To have constraint checking only in the initial +C condition calculation. +C 2. To enforce nonnegativity in Y during the integration. +C 3. To enforce both options 1 and 2. +C +C When selecting option 2 or 3, it is probably best to try the +C code without using this option first, and only use +C this option if that does not work very well. +C +C **** Do you want the code to solve the problem without +C invoking any special inequality constraints ... +C yes - set INFO(10) = 0 +C no - set INFO(10) = 1 to have option 1 enforced +C no - set INFO(10) = 2 to have option 2 enforced +C no - set INFO(10) = 3 to have option 3 enforced **** +C +C If you have specified INFO(10) = 1 or 3, then you +C will also need to identify how each component of Y +C in the initial condition calculation is constrained. +C You must set: +C IWORK(40+I) = +1 if Y(I) must be .GE. 0, +C IWORK(40+I) = +2 if Y(I) must be .GT. 0, +C IWORK(40+I) = -1 if Y(I) must be .LE. 0, while +C IWORK(40+I) = -2 if Y(I) must be .LT. 0, while +C IWORK(40+I) = 0 if Y(I) is not constrained. +C +C INFO(11) - DDASPK normally requires the initial T, Y, and +C YPRIME to be consistent. That is, you must have +C G(T,Y,YPRIME) = 0 at the initial T. If you do not know +C the initial conditions precisely, in some cases +C DDASPK may be able to compute it. +C +C Denoting the differential variables in Y by Y_d +C and the algebraic variables by Y_a, DDASPK can solve +C one of two initialization problems: +C 1. Given Y_d, calculate Y_a and Y'_d, or +C 2. Given Y', calculate Y. +C In either case, initial values for the given +C components are input, and initial guesses for +C the unknown components must also be provided as input. +C +C **** Are the initial T, Y, YPRIME consistent ... +C +C yes - set INFO(11) = 0 +C no - set INFO(11) = 1 to calculate option 1 above, +C or set INFO(11) = 2 to calculate option 2 **** +C +C If you have specified INFO(11) = 1, then you +C will also need to identify which are the +C differential and which are the algebraic +C components (algebraic components are components +C whose derivatives do not appear explicitly +C in the function G(T,Y,YPRIME)). You must set: +C IWORK(LID+I) = +1 if Y(I) is a differential variable +C IWORK(LID+I) = -1 if Y(I) is an algebraic variable, +C where LID = 40 if INFO(10) = 0 or 2 and LID = 40+NEQ +C if INFO(10) = 1 or 3. +C +C INFO(12) - Except for the addition of the RES argument CJ, +C DDASPK by default is downward-compatible with DDASSL, +C which uses only direct (dense or band) methods to solve +C the linear systems involved. You must set INFO(12) to +C indicate whether you want the direct methods or the +C Krylov iterative method. +C **** Do you want DDASPK to use standard direct methods +C (dense or band) or the Krylov (iterative) method ... +C direct methods - set INFO(12) = 0. +C Krylov method - set INFO(12) = 1, +C and check the settings of INFO(13) and INFO(15). +C +C INFO(13) - used when INFO(12) = 1 (Krylov methods). +C DDASPK uses scalars MAXL, KMP, NRMAX, and EPLI for the +C iterative solution of linear systems. INFO(13) allows +C you to override the default values of these parameters. +C These parameters and their defaults are as follows: +C MAXL = maximum number of iterations in the SPIGMR +C algorithm (MAXL .le. NEQ). The default is +C MAXL = MIN(5,NEQ). +C KMP = number of vectors on which orthogonalization is +C done in the SPIGMR algorithm. The default is +C KMP = MAXL, which corresponds to complete GMRES +C iteration, as opposed to the incomplete form. +C NRMAX = maximum number of restarts of the SPIGMR +C algorithm per nonlinear iteration. The default is +C NRMAX = 5. +C EPLI = convergence test constant in SPIGMR algorithm. +C The default is EPLI = 0.05. +C Note that the length of RWORK depends on both MAXL +C and KMP. See the definition of LRW below. +C **** Are MAXL, KMP, and EPLI to be given their +C default values ... +C yes - set INFO(13) = 0 +C no - set INFO(13) = 1, +C and set all of the following: +C IWORK(24) = MAXL (1 .le. MAXL .le. NEQ) +C IWORK(25) = KMP (1 .le. KMP .le. MAXL) +C IWORK(26) = NRMAX (NRMAX .ge. 0) +C RWORK(10) = EPLI (0 .lt. EPLI .lt. 1.0) **** +C +C INFO(14) - used with INFO(11) > 0 (initial condition +C calculation is requested). In this case, you may +C request control to be returned to the calling program +C immediately after the initial condition calculation, +C before proceeding to the integration of the system +C (e.g. to examine the computed Y and YPRIME). +C If this is done, and if the initialization succeeded +C (IDID = 4), you should reset INFO(11) to 0 for the +C next call, to prevent the solver from repeating the +C initialization (and to avoid an infinite loop). +C **** Do you want to proceed to the integration after +C the initial condition calculation is done ... +C yes - set INFO(14) = 0 +C no - set INFO(14) = 1 **** +C +C INFO(15) - used when INFO(12) = 1 (Krylov methods). +C When using preconditioning in the Krylov method, +C you must supply a subroutine, PSOL, which solves the +C associated linear systems using P. +C The usage of DDASPK is simpler if PSOL can carry out +C the solution without any prior calculation of data. +C However, if some partial derivative data is to be +C calculated in advance and used repeatedly in PSOL, +C then you must supply a JAC routine to do this, +C and set INFO(15) to indicate that JAC is to be called +C for this purpose. For example, P might be an +C approximation to a part of the matrix A which can be +C calculated and LU-factored for repeated solutions of +C the preconditioner system. The arrays WP and IWP +C (described under JAC and PSOL) can be used to +C communicate data between JAC and PSOL. +C **** Does PSOL operate with no prior preparation ... +C yes - set INFO(15) = 0 (no JAC routine) +C no - set INFO(15) = 1 +C and supply a JAC routine to evaluate and +C preprocess any required Jacobian data. **** +C +C INFO(16) - option to exclude algebraic variables from +C the error test. +C **** Do you wish to control errors locally on +C all the variables... +C yes - set INFO(16) = 0 +C no - set INFO(16) = 1 +C If you have specified INFO(16) = 1, then you +C will also need to identify which are the +C differential and which are the algebraic +C components (algebraic components are components +C whose derivatives do not appear explicitly +C in the function G(T,Y,YPRIME)). You must set: +C IWORK(LID+I) = +1 if Y(I) is a differential +C variable, and +C IWORK(LID+I) = -1 if Y(I) is an algebraic +C variable, +C where LID = 40 if INFO(10) = 0 or 2 and +C LID = 40 + NEQ if INFO(10) = 1 or 3. +C +C INFO(17) - used when INFO(11) > 0 (DDASPK is to do an +C initial condition calculation). +C DDASPK uses several heuristic control quantities in the +C initial condition calculation. They have default values, +C but can also be set by the user using INFO(17). +C These parameters and their defaults are as follows: +C MXNIT = maximum number of Newton iterations +C per Jacobian or preconditioner evaluation. +C The default is: +C MXNIT = 5 in the direct case (INFO(12) = 0), and +C MXNIT = 15 in the Krylov case (INFO(12) = 1). +C MXNJ = maximum number of Jacobian or preconditioner +C evaluations. The default is: +C MXNJ = 6 in the direct case (INFO(12) = 0), and +C MXNJ = 2 in the Krylov case (INFO(12) = 1). +C MXNH = maximum number of values of the artificial +C stepsize parameter H to be tried if INFO(11) = 1. +C The default is MXNH = 5. +C NOTE: the maximum number of Newton iterations +C allowed in all is MXNIT*MXNJ*MXNH if INFO(11) = 1, +C and MXNIT*MXNJ if INFO(11) = 2. +C LSOFF = flag to turn off the linesearch algorithm +C (LSOFF = 0 means linesearch is on, LSOFF = 1 means +C it is turned off). The default is LSOFF = 0. +C STPTOL = minimum scaled step in linesearch algorithm. +C The default is STPTOL = (unit roundoff)**(2/3). +C EPINIT = swing factor in the Newton iteration convergence +C test. The test is applied to the residual vector, +C premultiplied by the approximate Jacobian (in the +C direct case) or the preconditioner (in the Krylov +C case). For convergence, the weighted RMS norm of +C this vector (scaled by the error weights) must be +C less than EPINIT*EPCON, where EPCON = .33 is the +C analogous test constant used in the time steps. +C The default is EPINIT = .01. +C **** Are the initial condition heuristic controls to be +C given their default values... +C yes - set INFO(17) = 0 +C no - set INFO(17) = 1, +C and set all of the following: +C IWORK(32) = MXNIT (.GT. 0) +C IWORK(33) = MXNJ (.GT. 0) +C IWORK(34) = MXNH (.GT. 0) +C IWORK(35) = LSOFF ( = 0 or 1) +C RWORK(14) = STPTOL (.GT. 0.0) +C RWORK(15) = EPINIT (.GT. 0.0) **** +C +C INFO(18) - option to get extra printing in initial condition +C calculation. +C **** Do you wish to have extra printing... +C no - set INFO(18) = 0 +C yes - set INFO(18) = 1 for minimal printing, or +C set INFO(18) = 2 for full printing. +C If you have specified INFO(18) .ge. 1, data +C will be printed with the error handler routines. +C To print to a non-default unit number L, include +C the line CALL XSETUN(L) in your program. **** +C +C RTOL, ATOL -- You must assign relative (RTOL) and absolute (ATOL) +C error tolerances to tell the code how accurately you +C want the solution to be computed. They must be defined +C as variables because the code may change them. +C you have two choices -- +C Both RTOL and ATOL are scalars (INFO(2) = 0), or +C both RTOL and ATOL are vectors (INFO(2) = 1). +C In either case all components must be non-negative. +C +C The tolerances are used by the code in a local error +C test at each step which requires roughly that +C abs(local error in Y(i)) .le. EWT(i) , +C where EWT(i) = RTOL*abs(Y(i)) + ATOL is an error weight +C quantity, for each vector component. +C (More specifically, a root-mean-square norm is used to +C measure the size of vectors, and the error test uses the +C magnitude of the solution at the beginning of the step.) +C +C The true (global) error is the difference between the +C true solution of the initial value problem and the +C computed approximation. Practically all present day +C codes, including this one, control the local error at +C each step and do not even attempt to control the global +C error directly. +C +C Usually, but not always, the true accuracy of +C the computed Y is comparable to the error tolerances. +C This code will usually, but not always, deliver a more +C accurate solution if you reduce the tolerances and +C integrate again. By comparing two such solutions you +C can get a fairly reliable idea of the true error in the +C solution at the larger tolerances. +C +C Setting ATOL = 0. results in a pure relative error test +C on that component. Setting RTOL = 0. results in a pure +C absolute error test on that component. A mixed test +C with non-zero RTOL and ATOL corresponds roughly to a +C relative error test when the solution component is +C much bigger than ATOL and to an absolute error test +C when the solution component is smaller than the +C threshold ATOL. +C +C The code will not attempt to compute a solution at an +C accuracy unreasonable for the machine being used. It +C will advise you if you ask for too much accuracy and +C inform you as to the maximum accuracy it believes +C possible. +C +C RWORK(*) -- a real work array, which should be dimensioned in your +C calling program with a length equal to the value of +C LRW (or greater). +C +C LRW -- Set it to the declared length of the RWORK array. The +C minimum length depends on the options you have selected, +C given by a base value plus additional storage as described +C below. +C +C If INFO(12) = 0 (standard direct method), the base value is +C base = 50 + max(MAXORD+4,7)*NEQ. +C The default value is MAXORD = 5 (see INFO(9)). With the +C default MAXORD, base = 50 + 9*NEQ. +C Additional storage must be added to the base value for +C any or all of the following options: +C if INFO(6) = 0 (dense matrix), add NEQ**2 +C if INFO(6) = 1 (banded matrix), then +C if INFO(5) = 0, add (2*ML+MU+1)*NEQ + 2*(NEQ/(ML+MU+1)+1), +C if INFO(5) = 1, add (2*ML+MU+1)*NEQ, +C if INFO(16) = 1, add NEQ. +C +C If INFO(12) = 1 (Krylov method), the base value is +C base = 50 + (MAXORD+5)*NEQ + (MAXL+3+MIN0(1,MAXL-KMP))*NEQ + +C + (MAXL+3)*MAXL + 1 + LENWP. +C See PSOL for description of LENWP. The default values are: +C MAXORD = 5 (see INFO(9)), MAXL = min(5,NEQ) and KMP = MAXL +C (see INFO(13)). +C With the default values for MAXORD, MAXL and KMP, +C base = 91 + 18*NEQ + LENWP. +C Additional storage must be added to the base value for +C any or all of the following options: +C if INFO(16) = 1, add NEQ. +C +C +C IWORK(*) -- an integer work array, which should be dimensioned in +C your calling program with a length equal to the value +C of LIW (or greater). +C +C LIW -- Set it to the declared length of the IWORK array. The +C minimum length depends on the options you have selected, +C given by a base value plus additional storage as described +C below. +C +C If INFO(12) = 0 (standard direct method), the base value is +C base = 40 + NEQ. +C IF INFO(10) = 1 or 3, add NEQ to the base value. +C If INFO(11) = 1 or INFO(16) =1, add NEQ to the base value. +C +C If INFO(12) = 1 (Krylov method), the base value is +C base = 40 + LENIWP. +C See PSOL for description of LENIWP. +C IF INFO(10) = 1 or 3, add NEQ to the base value. +C If INFO(11) = 1 or INFO(16) = 1, add NEQ to the base value. +C +C +C RPAR, IPAR -- These are arrays of double precision and integer type, +C respectively, which are available for you to use +C for communication between your program that calls +C DDASPK and the RES subroutine (and the JAC and PSOL +C subroutines). They are not altered by DDASPK. +C If you do not need RPAR or IPAR, ignore these +C parameters by treating them as dummy arguments. +C If you do choose to use them, dimension them in +C your calling program and in RES (and in JAC and PSOL) +C as arrays of appropriate length. +C +C JAC -- This is the name of a routine that you may supply +C (optionally) that relates to the Jacobian matrix of the +C nonlinear system that the code must solve at each T step. +C The role of JAC (and its call sequence) depends on whether +C a direct (INFO(12) = 0) or Krylov (INFO(12) = 1) method +C is selected. +C +C **** INFO(12) = 0 (direct methods): +C If you are letting the code generate partial derivatives +C numerically (INFO(5) = 0), then JAC can be absent +C (or perhaps a dummy routine to satisfy the loader). +C Otherwise you must supply a JAC routine to compute +C the matrix A = dG/dY + CJ*dG/dYPRIME. It must have +C the form +C +C SUBROUTINE JAC (T, Y, YPRIME, PD, CJ, RPAR, IPAR) +C +C The JAC routine must dimension Y, YPRIME, and PD (and RPAR +C and IPAR if used). CJ is a scalar which is input to JAC. +C For the given values of T, Y, and YPRIME, the JAC routine +C must evaluate the nonzero elements of the matrix A, and +C store these values in the array PD. The elements of PD are +C set to zero before each call to JAC, so that only nonzero +C elements need to be defined. +C The way you store the elements into the PD array depends +C on the structure of the matrix indicated by INFO(6). +C *** INFO(6) = 0 (full or dense matrix) *** +C Give PD a first dimension of NEQ. When you evaluate the +C nonzero partial derivatives of equation i (i.e. of G(i)) +C with respect to component j (of Y and YPRIME), you must +C store the element in PD according to +C PD(i,j) = dG(i)/dY(j) + CJ*dG(i)/dYPRIME(j). +C *** INFO(6) = 1 (banded matrix with half-bandwidths ML, MU +C as described under INFO(6)) *** +C Give PD a first dimension of 2*ML+MU+1. When you +C evaluate the nonzero partial derivatives of equation i +C (i.e. of G(i)) with respect to component j (of Y and +C YPRIME), you must store the element in PD according to +C IROW = i - j + ML + MU + 1 +C PD(IROW,j) = dG(i)/dY(j) + CJ*dG(i)/dYPRIME(j). +C +C **** INFO(12) = 1 (Krylov method): +C If you are not calculating Jacobian data in advance for use +C in PSOL (INFO(15) = 0), JAC can be absent (or perhaps a +C dummy routine to satisfy the loader). Otherwise, you may +C supply a JAC routine to compute and preprocess any parts of +C of the Jacobian matrix A = dG/dY + CJ*dG/dYPRIME that are +C involved in the preconditioner matrix P. +C It is to have the form +C +C SUBROUTINE JAC (RES, IRES, NEQ, T, Y, YPRIME, REWT, SAVR, +C WK, H, CJ, WP, IWP, IER, RPAR, IPAR) +C +C The JAC routine must dimension Y, YPRIME, REWT, SAVR, WK, +C and (if used) WP, IWP, RPAR, and IPAR. +C The Y, YPRIME, and SAVR arrays contain the current values +C of Y, YPRIME, and the residual G, respectively. +C The array WK is work space of length NEQ. +C H is the step size. CJ is a scalar, input to JAC, that is +C normally proportional to 1/H. REWT is an array of +C reciprocal error weights, 1/EWT(i), where EWT(i) is +C RTOL*abs(Y(i)) + ATOL (unless you supplied routine DDAWTS +C instead), for use in JAC if needed. For example, if JAC +C computes difference quotient approximations to partial +C derivatives, the REWT array may be useful in setting the +C increments used. The JAC routine should do any +C factorization operations called for, in preparation for +C solving linear systems in PSOL. The matrix P should +C be an approximation to the Jacobian, +C A = dG/dY + CJ*dG/dYPRIME. +C +C WP and IWP are real and integer work arrays which you may +C use for communication between your JAC routine and your +C PSOL routine. These may be used to store elements of the +C preconditioner P, or related matrix data (such as factored +C forms). They are not altered by DDASPK. +C If you do not need WP or IWP, ignore these parameters by +C treating them as dummy arguments. If you do use them, +C dimension them appropriately in your JAC and PSOL routines. +C See the PSOL description for instructions on setting +C the lengths of WP and IWP. +C +C On return, JAC should set the error flag IER as follows.. +C IER = 0 if JAC was successful, +C IER .ne. 0 if JAC was unsuccessful (e.g. if Y or YPRIME +C was illegal, or a singular matrix is found). +C (If IER .ne. 0, a smaller stepsize will be tried.) +C IER = 0 on entry to JAC, so need be reset only on a failure. +C If RES is used within JAC, then a nonzero value of IRES will +C override any nonzero value of IER (see the RES description). +C +C Regardless of the method type, subroutine JAC must not +C alter T, Y(*), YPRIME(*), H, CJ, or REWT(*). +C You must declare the name JAC in an EXTERNAL statement in +C your program that calls DDASPK. +C +C PSOL -- This is the name of a routine you must supply if you have +C selected a Krylov method (INFO(12) = 1) with preconditioning. +C In the direct case (INFO(12) = 0), PSOL can be absent +C (a dummy routine may have to be supplied to satisfy the +C loader). Otherwise, you must provide a PSOL routine to +C solve linear systems arising from preconditioning. +C When supplied with INFO(12) = 1, the PSOL routine is to +C have the form +C +C SUBROUTINE PSOL (NEQ, T, Y, YPRIME, SAVR, WK, CJ, WGHT, +C WP, IWP, B, EPLIN, IER, RPAR, IPAR) +C +C The PSOL routine must solve linear systems of the form +C P*x = b where P is the left preconditioner matrix. +C +C The right-hand side vector b is in the B array on input, and +C PSOL must return the solution vector x in B. +C The Y, YPRIME, and SAVR arrays contain the current values +C of Y, YPRIME, and the residual G, respectively. +C +C Work space required by JAC and/or PSOL, and space for data to +C be communicated from JAC to PSOL is made available in the form +C of arrays WP and IWP, which are parts of the RWORK and IWORK +C arrays, respectively. The lengths of these real and integer +C work spaces WP and IWP must be supplied in LENWP and LENIWP, +C respectively, as follows.. +C IWORK(27) = LENWP = length of real work space WP +C IWORK(28) = LENIWP = length of integer work space IWP. +C +C WK is a work array of length NEQ for use by PSOL. +C CJ is a scalar, input to PSOL, that is normally proportional +C to 1/H (H = stepsize). If the old value of CJ +C (at the time of the last JAC call) is needed, it must have +C been saved by JAC in WP. +C +C WGHT is an array of weights, to be used if PSOL uses an +C iterative method and performs a convergence test. (In terms +C of the argument REWT to JAC, WGHT is REWT/sqrt(NEQ).) +C If PSOL uses an iterative method, it should use EPLIN +C (a heuristic parameter) as the bound on the weighted norm of +C the residual for the computed solution. Specifically, the +C residual vector R should satisfy +C SQRT (SUM ( (R(i)*WGHT(i))**2 ) ) .le. EPLIN +C +C PSOL must not alter NEQ, T, Y, YPRIME, SAVR, CJ, WGHT, EPLIN. +C +C On return, PSOL should set the error flag IER as follows.. +C IER = 0 if PSOL was successful, +C IER .lt. 0 if an unrecoverable error occurred, meaning +C control will be passed to the calling routine, +C IER .gt. 0 if a recoverable error occurred, meaning that +C the step will be retried with the same step size +C but with a call to JAC to update necessary data, +C unless the Jacobian data is current, in which case +C the step will be retried with a smaller step size. +C IER = 0 on entry to PSOL so need be reset only on a failure. +C +C You must declare the name PSOL in an EXTERNAL statement in +C your program that calls DDASPK. +C +C +C OPTIONALLY REPLACEABLE SUBROUTINE: +C +C DDASPK uses a weighted root-mean-square norm to measure the +C size of various error vectors. The weights used in this norm +C are set in the following subroutine: +C +C SUBROUTINE DDAWTS (NEQ, IWT, RTOL, ATOL, Y, EWT, RPAR, IPAR) +C DIMENSION RTOL(*), ATOL(*), Y(*), EWT(*), RPAR(*), IPAR(*) +C +C A DDAWTS routine has been included with DDASPK which sets the +C weights according to +C EWT(I) = RTOL*ABS(Y(I)) + ATOL +C in the case of scalar tolerances (IWT = 0) or +C EWT(I) = RTOL(I)*ABS(Y(I)) + ATOL(I) +C in the case of array tolerances (IWT = 1). (IWT is INFO(2).) +C In some special cases, it may be appropriate for you to define +C your own error weights by writing a subroutine DDAWTS to be +C called instead of the version supplied. However, this should +C be attempted only after careful thought and consideration. +C If you supply this routine, you may use the tolerances and Y +C as appropriate, but do not overwrite these variables. You +C may also use RPAR and IPAR to communicate data as appropriate. +C ***Note: Aside from the values of the weights, the choice of +C norm used in DDASPK (weighted root-mean-square) is not subject +C to replacement by the user. In this respect, DDASPK is not +C downward-compatible with the original DDASSL solver (in which +C the norm routine was optionally user-replaceable). +C +C +C------OUTPUT - AFTER ANY RETURN FROM DDASPK---------------------------- +C +C The principal aim of the code is to return a computed solution at +C T = TOUT, although it is also possible to obtain intermediate +C results along the way. To find out whether the code achieved its +C goal or if the integration process was interrupted before the task +C was completed, you must check the IDID parameter. +C +C +C T -- The output value of T is the point to which the solution +C was successfully advanced. +C +C Y(*) -- contains the computed solution approximation at T. +C +C YPRIME(*) -- contains the computed derivative approximation at T. +C +C IDID -- reports what the code did, described as follows: +C +C *** TASK COMPLETED *** +C Reported by positive values of IDID +C +C IDID = 1 -- a step was successfully taken in the +C intermediate-output mode. The code has not +C yet reached TOUT. +C +C IDID = 2 -- the integration to TSTOP was successfully +C completed (T = TSTOP) by stepping exactly to TSTOP. +C +C IDID = 3 -- the integration to TOUT was successfully +C completed (T = TOUT) by stepping past TOUT. +C Y(*) and YPRIME(*) are obtained by interpolation. +C +C IDID = 4 -- the initial condition calculation, with +C INFO(11) > 0, was successful, and INFO(14) = 1. +C No integration steps were taken, and the solution +C is not considered to have been started. +C +C *** TASK INTERRUPTED *** +C Reported by negative values of IDID +C +C IDID = -1 -- a large amount of work has been expended +C (about 500 steps). +C +C IDID = -2 -- the error tolerances are too stringent. +C +C IDID = -3 -- the local error test cannot be satisfied +C because you specified a zero component in ATOL +C and the corresponding computed solution component +C is zero. Thus, a pure relative error test is +C impossible for this component. +C +C IDID = -5 -- there were repeated failures in the evaluation +C or processing of the preconditioner (in JAC). +C +C IDID = -6 -- DDASPK had repeated error test failures on the +C last attempted step. +C +C IDID = -7 -- the nonlinear system solver in the time integration +C could not converge. +C +C IDID = -8 -- the matrix of partial derivatives appears +C to be singular (direct method). +C +C IDID = -9 -- the nonlinear system solver in the time integration +C failed to achieve convergence, and there were repeated +C error test failures in this step. +C +C IDID =-10 -- the nonlinear system solver in the time integration +C failed to achieve convergence because IRES was equal +C to -1. +C +C IDID =-11 -- IRES = -2 was encountered and control is +C being returned to the calling program. +C +C IDID =-12 -- DDASPK failed to compute the initial Y, YPRIME. +C +C IDID =-13 -- unrecoverable error encountered inside user's +C PSOL routine, and control is being returned to +C the calling program. +C +C IDID =-14 -- the Krylov linear system solver could not +C achieve convergence. +C +C IDID =-15,..,-32 -- Not applicable for this code. +C +C *** TASK TERMINATED *** +C reported by the value of IDID=-33 +C +C IDID = -33 -- the code has encountered trouble from which +C it cannot recover. A message is printed +C explaining the trouble and control is returned +C to the calling program. For example, this occurs +C when invalid input is detected. +C +C RTOL, ATOL -- these quantities remain unchanged except when +C IDID = -2. In this case, the error tolerances have been +C increased by the code to values which are estimated to +C be appropriate for continuing the integration. However, +C the reported solution at T was obtained using the input +C values of RTOL and ATOL. +C +C RWORK, IWORK -- contain information which is usually of no interest +C to the user but necessary for subsequent calls. +C However, you may be interested in the performance data +C listed below. These quantities are accessed in RWORK +C and IWORK but have internal mnemonic names, as follows.. +C +C RWORK(3)--contains H, the step size h to be attempted +C on the next step. +C +C RWORK(4)--contains TN, the current value of the +C independent variable, i.e. the farthest point +C integration has reached. This will differ +C from T if interpolation has been performed +C (IDID = 3). +C +C RWORK(7)--contains HOLD, the stepsize used on the last +C successful step. If INFO(11) = INFO(14) = 1, +C this contains the value of H used in the +C initial condition calculation. +C +C IWORK(7)--contains K, the order of the method to be +C attempted on the next step. +C +C IWORK(8)--contains KOLD, the order of the method used +C on the last step. +C +C IWORK(11)--contains NST, the number of steps (in T) +C taken so far. +C +C IWORK(12)--contains NRE, the number of calls to RES +C so far. +C +C IWORK(13)--contains NJE, the number of calls to JAC so +C far (Jacobian or preconditioner evaluations). +C +C IWORK(14)--contains NETF, the total number of error test +C failures so far. +C +C IWORK(15)--contains NCFN, the total number of nonlinear +C convergence failures so far (includes counts +C of singular iteration matrix or singular +C preconditioners). +C +C IWORK(16)--contains NCFL, the number of convergence +C failures of the linear iteration so far. +C +C IWORK(17)--contains LENIW, the length of IWORK actually +C required. This is defined on normal returns +C and on an illegal input return for +C insufficient storage. +C +C IWORK(18)--contains LENRW, the length of RWORK actually +C required. This is defined on normal returns +C and on an illegal input return for +C insufficient storage. +C +C IWORK(19)--contains NNI, the total number of nonlinear +C iterations so far (each of which calls a +C linear solver). +C +C IWORK(20)--contains NLI, the total number of linear +C (Krylov) iterations so far. +C +C IWORK(21)--contains NPS, the number of PSOL calls so +C far, for preconditioning solve operations or +C for solutions with the user-supplied method. +C +C Note: The various counters in IWORK do not include +C counts during a call made with INFO(11) > 0 and +C INFO(14) = 1. +C +C +C------INPUT - WHAT TO DO TO CONTINUE THE INTEGRATION ----------------- +C (CALLS AFTER THE FIRST) +C +C This code is organized so that subsequent calls to continue the +C integration involve little (if any) additional effort on your +C part. You must monitor the IDID parameter in order to determine +C what to do next. +C +C Recalling that the principal task of the code is to integrate +C from T to TOUT (the interval mode), usually all you will need +C to do is specify a new TOUT upon reaching the current TOUT. +C +C Do not alter any quantity not specifically permitted below. In +C particular do not alter NEQ, T, Y(*), YPRIME(*), RWORK(*), +C IWORK(*), or the differential equation in subroutine RES. Any +C such alteration constitutes a new problem and must be treated +C as such, i.e. you must start afresh. +C +C You cannot change from array to scalar error control or vice +C versa (INFO(2)), but you can change the size of the entries of +C RTOL or ATOL. Increasing a tolerance makes the equation easier +C to integrate. Decreasing a tolerance will make the equation +C harder to integrate and should generally be avoided. +C +C You can switch from the intermediate-output mode to the +C interval mode (INFO(3)) or vice versa at any time. +C +C If it has been necessary to prevent the integration from going +C past a point TSTOP (INFO(4), RWORK(1)), keep in mind that the +C code will not integrate to any TOUT beyond the currently +C specified TSTOP. Once TSTOP has been reached, you must change +C the value of TSTOP or set INFO(4) = 0. You may change INFO(4) +C or TSTOP at any time but you must supply the value of TSTOP in +C RWORK(1) whenever you set INFO(4) = 1. +C +C Do not change INFO(5), INFO(6), INFO(12-17) or their associated +C IWORK/RWORK locations unless you are going to restart the code. +C +C *** FOLLOWING A COMPLETED TASK *** +C +C If.. +C IDID = 1, call the code again to continue the integration +C another step in the direction of TOUT. +C +C IDID = 2 or 3, define a new TOUT and call the code again. +C TOUT must be different from T. You cannot change +C the direction of integration without restarting. +C +C IDID = 4, reset INFO(11) = 0 and call the code again to begin +C the integration. (If you leave INFO(11) > 0 and +C INFO(14) = 1, you may generate an infinite loop.) +C In this situation, the next call to DASPK is +C considered to be the first call for the problem, +C in that all initializations are done. +C +C *** FOLLOWING AN INTERRUPTED TASK *** +C +C To show the code that you realize the task was interrupted and +C that you want to continue, you must take appropriate action and +C set INFO(1) = 1. +C +C If.. +C IDID = -1, the code has taken about 500 steps. If you want to +C continue, set INFO(1) = 1 and call the code again. +C An additional 500 steps will be allowed. +C +C +C IDID = -2, the error tolerances RTOL, ATOL have been increased +C to values the code estimates appropriate for +C continuing. You may want to change them yourself. +C If you are sure you want to continue with relaxed +C error tolerances, set INFO(1) = 1 and call the code +C again. +C +C IDID = -3, a solution component is zero and you set the +C corresponding component of ATOL to zero. If you +C are sure you want to continue, you must first alter +C the error criterion to use positive values of ATOL +C for those components corresponding to zero solution +C components, then set INFO(1) = 1 and call the code +C again. +C +C IDID = -4 --- cannot occur with this code. +C +C IDID = -5, your JAC routine failed with the Krylov method. Check +C for errors in JAC and restart the integration. +C +C IDID = -6, repeated error test failures occurred on the last +C attempted step in DDASPK. A singularity in the +C solution may be present. If you are absolutely +C certain you want to continue, you should restart +C the integration. (Provide initial values of Y and +C YPRIME which are consistent.) +C +C IDID = -7, repeated convergence test failures occurred on the last +C attempted step in DDASPK. An inaccurate or ill- +C conditioned Jacobian or preconditioner may be the +C problem. If you are absolutely certain you want +C to continue, you should restart the integration. +C +C +C IDID = -8, the matrix of partial derivatives is singular, with +C the use of direct methods. Some of your equations +C may be redundant. DDASPK cannot solve the problem +C as stated. It is possible that the redundant +C equations could be removed, and then DDASPK could +C solve the problem. It is also possible that a +C solution to your problem either does not exist +C or is not unique. +C +C IDID = -9, DDASPK had multiple convergence test failures, preceded +C by multiple error test failures, on the last +C attempted step. It is possible that your problem is +C ill-posed and cannot be solved using this code. Or, +C there may be a discontinuity or a singularity in the +C solution. If you are absolutely certain you want to +C continue, you should restart the integration. +C +C IDID = -10, DDASPK had multiple convergence test failures +C because IRES was equal to -1. If you are +C absolutely certain you want to continue, you +C should restart the integration. +C +C IDID = -11, there was an unrecoverable error (IRES = -2) from RES +C inside the nonlinear system solver. Determine the +C cause before trying again. +C +C IDID = -12, DDASPK failed to compute the initial Y and YPRIME +C vectors. This could happen because the initial +C approximation to Y or YPRIME was not very good, or +C because no consistent values of these vectors exist. +C The problem could also be caused by an inaccurate or +C singular iteration matrix, or a poor preconditioner. +C +C IDID = -13, there was an unrecoverable error encountered inside +C your PSOL routine. Determine the cause before +C trying again. +C +C IDID = -14, the Krylov linear system solver failed to achieve +C convergence. This may be due to ill-conditioning +C in the iteration matrix, or a singularity in the +C preconditioner (if one is being used). +C Another possibility is that there is a better +C choice of Krylov parameters (see INFO(13)). +C Possibly the failure is caused by redundant equations +C in the system, or by inconsistent equations. +C In that case, reformulate the system to make it +C consistent and non-redundant. +C +C IDID = -15,..,-32 --- Cannot occur with this code. +C +C *** FOLLOWING A TERMINATED TASK *** +C +C If IDID = -33, you cannot continue the solution of this problem. +C An attempt to do so will result in your run being +C terminated. +C +C --------------------------------------------------------------------- +C +C***REFERENCES +C 1. L. R. Petzold, A Description of DASSL: A Differential/Algebraic +C System Solver, in Scientific Computing, R. S. Stepleman et al. +C (Eds.), North-Holland, Amsterdam, 1983, pp. 65-68. +C 2. K. E. Brenan, S. L. Campbell, and L. R. Petzold, Numerical +C Solution of Initial-Value Problems in Differential-Algebraic +C Equations, Elsevier, New York, 1989. +C 3. P. N. Brown and A. C. Hindmarsh, Reduced Storage Matrix Methods +C in Stiff ODE Systems, J. Applied Mathematics and Computation, +C 31 (1989), pp. 40-91. +C 4. P. N. Brown, A. C. Hindmarsh, and L. R. Petzold, Using Krylov +C Methods in the Solution of Large-Scale Differential-Algebraic +C Systems, SIAM J. Sci. Comp., 15 (1994), pp. 1467-1488. +C 5. P. N. Brown, A. C. Hindmarsh, and L. R. Petzold, Consistent +C Initial Condition Calculation for Differential-Algebraic +C Systems, LLNL Report UCRL-JC-122175, August 1995; submitted to +C SIAM J. Sci. Comp. +C +C***ROUTINES CALLED +C +C The following are all the subordinate routines used by DDASPK. +C +C DDASIC computes consistent initial conditions. +C DYYPNW updates Y and YPRIME in linesearch for initial condition +C calculation. +C DDSTP carries out one step of the integration. +C DCNSTR/DCNST0 check the current solution for constraint violations. +C DDAWTS sets error weight quantities. +C DINVWT tests and inverts the error weights. +C DDATRP performs interpolation to get an output solution. +C DDWNRM computes the weighted root-mean-square norm of a vector. +C D1MACH provides the unit roundoff of the computer. +C XERRWD/XSETF/XSETUN/IXSAV is a package to handle error messages. +C DDASID nonlinear equation driver to initialize Y and YPRIME using +C direct linear system solver methods. Interfaces to Newton +C solver (direct case). +C DNSID solves the nonlinear system for unknown initial values by +C modified Newton iteration and direct linear system methods. +C DLINSD carries out linesearch algorithm for initial condition +C calculation (direct case). +C DFNRMD calculates weighted norm of preconditioned residual in +C initial condition calculation (direct case). +C DNEDD nonlinear equation driver for direct linear system solver +C methods. Interfaces to Newton solver (direct case). +C DMATD assembles the iteration matrix (direct case). +C DNSD solves the associated nonlinear system by modified +C Newton iteration and direct linear system methods. +C DSLVD interfaces to linear system solver (direct case). +C DDASIK nonlinear equation driver to initialize Y and YPRIME using +C Krylov iterative linear system methods. Interfaces to +C Newton solver (Krylov case). +C DNSIK solves the nonlinear system for unknown initial values by +C Newton iteration and Krylov iterative linear system methods. +C DLINSK carries out linesearch algorithm for initial condition +C calculation (Krylov case). +C DFNRMK calculates weighted norm of preconditioned residual in +C initial condition calculation (Krylov case). +C DNEDK nonlinear equation driver for iterative linear system solver +C methods. Interfaces to Newton solver (Krylov case). +C DNSK solves the associated nonlinear system by Inexact Newton +C iteration and (linear) Krylov iteration. +C DSLVK interfaces to linear system solver (Krylov case). +C DSPIGM solves a linear system by SPIGMR algorithm. +C DATV computes matrix-vector product in Krylov algorithm. +C DORTH performs orthogonalization of Krylov basis vectors. +C DHEQR performs QR factorization of Hessenberg matrix. +C DHELS finds least-squares solution of Hessenberg linear system. +C DGETRF, DGETRS, DGBTRF, DGBTRS are LAPACK routines for solving +C linear systems (dense or band direct methods). +C DAXPY, DCOPY, DDOT, DNRM2, DSCAL are Basic Linear Algebra (BLAS) +C routines. +C +C The routines called directly by DDASPK are: +C DCNST0, DDAWTS, DINVWT, D1MACH, DDWNRM, DDASIC, DDATRP, DDSTP, +C XERRWD +C +C***END PROLOGUE DDASPK +C +C + IMPLICIT DOUBLE PRECISION(A-H,O-Z) + LOGICAL DONE, LAVL, LCFN, LCFL, LWARN + DIMENSION Y(*),YPRIME(*) + DIMENSION INFO(20) + DIMENSION RWORK(LRW),IWORK(LIW) + DIMENSION RTOL(*),ATOL(*) + DIMENSION RPAR(*),IPAR(*) + CHARACTER MSG*80 + EXTERNAL RES, JAC, PSOL, DDASID, DDASIK, DNEDD, DNEDK +C +C Set pointers into IWORK. +C + PARAMETER (LML=1, LMU=2, LMTYPE=4, + * LIWM=1, LMXORD=3, LJCALC=5, LPHASE=6, LK=7, LKOLD=8, + * LNS=9, LNSTL=10, LNST=11, LNRE=12, LNJE=13, LETF=14, LNCFN=15, + * LNCFL=16, LNIW=17, LNRW=18, LNNI=19, LNLI=20, LNPS=21, + * LNPD=22, LMITER=23, LMAXL=24, LKMP=25, LNRMAX=26, LLNWP=27, + * LLNIWP=28, LLOCWP=29, LLCIWP=30, LKPRIN=31, + * LMXNIT=32, LMXNJ=33, LMXNH=34, LLSOFF=35, LICNS=41) +C +C Set pointers into RWORK. +C + PARAMETER (LTSTOP=1, LHMAX=2, LH=3, LTN=4, LCJ=5, LCJOLD=6, + * LHOLD=7, LS=8, LROUND=9, LEPLI=10, LSQRN=11, LRSQRN=12, + * LEPCON=13, LSTOL=14, LEPIN=15, + * LALPHA=21, LBETA=27, LGAMMA=33, LPSI=39, LSIGMA=45, LDELTA=51) +C + SAVE LID, LENID, NONNEG +C +C +C***FIRST EXECUTABLE STATEMENT DDASPK +C +C + IF(INFO(1).NE.0) GO TO 100 +C +C----------------------------------------------------------------------- +C This block is executed for the initial call only. +C It contains checking of inputs and initializations. +C----------------------------------------------------------------------- +C +C First check INFO array to make sure all elements of INFO +C Are within the proper range. (INFO(1) is checked later, because +C it must be tested on every call.) ITEMP holds the location +C within INFO which may be out of range. +C + DO 10 I=2,9 + ITEMP = I + IF (INFO(I) .NE. 0 .AND. INFO(I) .NE. 1) GO TO 701 + 10 CONTINUE + ITEMP = 10 + IF(INFO(10).LT.0 .OR. INFO(10).GT.3) GO TO 701 + ITEMP = 11 + IF(INFO(11).LT.0 .OR. INFO(11).GT.2) GO TO 701 + DO 15 I=12,17 + ITEMP = I + IF (INFO(I) .NE. 0 .AND. INFO(I) .NE. 1) GO TO 701 + 15 CONTINUE + ITEMP = 18 + IF(INFO(18).LT.0 .OR. INFO(18).GT.2) GO TO 701 + +C +C Check NEQ to see if it is positive. +C + IF (NEQ .LE. 0) GO TO 702 +C +C Check and compute maximum order. +C + MXORD=5 + IF (INFO(9) .NE. 0) THEN + MXORD=IWORK(LMXORD) + IF (MXORD .LT. 1 .OR. MXORD .GT. 5) GO TO 703 + ENDIF + IWORK(LMXORD)=MXORD +C +C Set and/or check inputs for constraint checking (INFO(10) .NE. 0). +C Set values for ICNFLG, NONNEG, and pointer LID. +C + ICNFLG = 0 + NONNEG = 0 + LID = LICNS + IF (INFO(10) .EQ. 0) GO TO 20 + IF (INFO(10) .EQ. 1) THEN + ICNFLG = 1 + NONNEG = 0 + LID = LICNS + NEQ + ELSEIF (INFO(10) .EQ. 2) THEN + ICNFLG = 0 + NONNEG = 1 + ELSE + ICNFLG = 1 + NONNEG = 1 + LID = LICNS + NEQ + ENDIF +C + 20 CONTINUE +C +C Set and/or check inputs for Krylov solver (INFO(12) .NE. 0). +C If indicated, set default values for MAXL, KMP, NRMAX, and EPLI. +C Otherwise, verify inputs required for iterative solver. +C + IF (INFO(12) .EQ. 0) GO TO 25 +C + IWORK(LMITER) = INFO(12) + IF (INFO(13) .EQ. 0) THEN + IWORK(LMAXL) = MIN(5,NEQ) + IWORK(LKMP) = IWORK(LMAXL) + IWORK(LNRMAX) = 5 + RWORK(LEPLI) = 0.05D0 + ELSE + IF(IWORK(LMAXL) .LT. 1 .OR. IWORK(LMAXL) .GT. NEQ) GO TO 720 + IF(IWORK(LKMP) .LT. 1 .OR. IWORK(LKMP) .GT. IWORK(LMAXL)) + 1 GO TO 721 + IF(IWORK(LNRMAX) .LT. 0) GO TO 722 + IF(RWORK(LEPLI).LE.0.0D0 .OR. RWORK(LEPLI).GE.1.0D0)GO TO 723 + ENDIF +C + 25 CONTINUE +C +C Set and/or check controls for the initial condition calculation +C (INFO(11) .GT. 0). If indicated, set default values. +C Otherwise, verify inputs required for iterative solver. +C + IF (INFO(11) .EQ. 0) GO TO 30 + IF (INFO(17) .EQ. 0) THEN + IWORK(LMXNIT) = 5 + IF (INFO(12) .GT. 0) IWORK(LMXNIT) = 15 + IWORK(LMXNJ) = 6 + IF (INFO(12) .GT. 0) IWORK(LMXNJ) = 2 + IWORK(LMXNH) = 5 + IWORK(LLSOFF) = 0 + RWORK(LEPIN) = 0.01D0 + ELSE + IF (IWORK(LMXNIT) .LE. 0) GO TO 725 + IF (IWORK(LMXNJ) .LE. 0) GO TO 725 + IF (IWORK(LMXNH) .LE. 0) GO TO 725 + LSOFF = IWORK(LLSOFF) + IF (LSOFF .LT. 0 .OR. LSOFF .GT. 1) GO TO 725 + IF (RWORK(LEPIN) .LE. 0.0D0) GO TO 725 + ENDIF +C + 30 CONTINUE +C +C Below is the computation and checking of the work array lengths +C LENIW and LENRW, using direct methods (INFO(12) = 0) or +C the Krylov methods (INFO(12) = 1). +C + LENIC = 0 + IF (INFO(10) .EQ. 1 .OR. INFO(10) .EQ. 3) LENIC = NEQ + LENID = 0 + IF (INFO(11) .EQ. 1 .OR. INFO(16) .EQ. 1) LENID = NEQ + IF (INFO(12) .EQ. 0) THEN +C +C Compute MTYPE, etc. Check ML and MU. +C + NCPHI = MAX(MXORD + 1, 4) + IF(INFO(6).EQ.0) THEN + LENPD = NEQ**2 + LENRW = 50 + (NCPHI+3)*NEQ + LENPD + IF(INFO(5).EQ.0) THEN + IWORK(LMTYPE)=2 + ELSE + IWORK(LMTYPE)=1 + ENDIF + ELSE + IF(IWORK(LML).LT.0.OR.IWORK(LML).GE.NEQ)GO TO 717 + IF(IWORK(LMU).LT.0.OR.IWORK(LMU).GE.NEQ)GO TO 718 + LENPD=(2*IWORK(LML)+IWORK(LMU)+1)*NEQ + IF(INFO(5).EQ.0) THEN + IWORK(LMTYPE)=5 + MBAND=IWORK(LML)+IWORK(LMU)+1 + MSAVE=(NEQ/MBAND)+1 + LENRW = 50 + (NCPHI+3)*NEQ + LENPD + 2*MSAVE + ELSE + IWORK(LMTYPE)=4 + LENRW = 50 + (NCPHI+3)*NEQ + LENPD + ENDIF + ENDIF +C +C Compute LENIW, LENWP, LENIWP. +C + LENIW = 40 + LENIC + LENID + NEQ + LENWP = 0 + LENIWP = 0 +C + ELSE IF (INFO(12) .EQ. 1) THEN + MAXL = IWORK(LMAXL) + LENWP = IWORK(LLNWP) + LENIWP = IWORK(LLNIWP) + LENPD = (MAXL+3+MIN0(1,MAXL-IWORK(LKMP)))*NEQ + 1 + (MAXL+3)*MAXL + 1 + LENWP + LENRW = 50 + (IWORK(LMXORD)+5)*NEQ + LENPD + LENIW = 40 + LENIC + LENID + LENIWP +C + ENDIF + IF(INFO(16) .NE. 0) LENRW = LENRW + NEQ +C +C Check lengths of RWORK and IWORK. +C + IWORK(LNIW)=LENIW + IWORK(LNRW)=LENRW + IWORK(LNPD)=LENPD + IWORK(LLOCWP) = LENPD-LENWP+1 + IF(LRW.LT.LENRW)GO TO 704 + IF(LIW.LT.LENIW)GO TO 705 +C +C Check ICNSTR for legality. +C + IF (LENIC .GT. 0) THEN + DO 40 I = 1,NEQ + ICI = IWORK(LICNS-1+I) + IF (ICI .LT. -2 .OR. ICI .GT. 2) GO TO 726 + 40 CONTINUE + ENDIF +C +C Check Y for consistency with constraints. +C + IF (LENIC .GT. 0) THEN + CALL DCNST0(NEQ,Y,IWORK(LICNS),IRET) + IF (IRET .NE. 0) GO TO 727 + ENDIF +C +C Check ID for legality. +C + IF (LENID .GT. 0) THEN + DO 50 I = 1,NEQ + IDI = IWORK(LID-1+I) + IF (IDI .NE. 1 .AND. IDI .NE. -1) GO TO 724 + 50 CONTINUE + ENDIF +C +C Check to see that TOUT is different from T. +C + IF(TOUT .EQ. T)GO TO 719 +C +C Check HMAX. +C + IF(INFO(7) .NE. 0) THEN + HMAX = RWORK(LHMAX) + IF (HMAX .LE. 0.0D0) GO TO 710 + ENDIF +C +C Initialize counters and other flags. +C + IWORK(LNST)=0 + IWORK(LNRE)=0 + IWORK(LNJE)=0 + IWORK(LETF)=0 + IWORK(LNCFN)=0 + IWORK(LNNI)=0 + IWORK(LNLI)=0 + IWORK(LNPS)=0 + IWORK(LNCFL)=0 + IWORK(LKPRIN)=INFO(18) + IDID=1 + GO TO 200 +C +C----------------------------------------------------------------------- +C This block is for continuation calls only. +C Here we check INFO(1), and if the last step was interrupted, +C we check whether appropriate action was taken. +C----------------------------------------------------------------------- +C +100 CONTINUE + IF(INFO(1).EQ.1)GO TO 110 + ITEMP = 1 + IF(INFO(1).NE.-1)GO TO 701 +C +C If we are here, the last step was interrupted by an error +C condition from DDSTP, and appropriate action was not taken. +C This is a fatal error. +C + MSG = 'DASPK-- THE LAST STEP TERMINATED WITH A NEGATIVE' + CALL XERRWD(MSG,49,201,0,0,0,0,0,0.0D0,0.0D0) + MSG = 'DASPK-- VALUE (=I1) OF IDID AND NO APPROPRIATE' + CALL XERRWD(MSG,47,202,0,1,IDID,0,0,0.0D0,0.0D0) + MSG = 'DASPK-- ACTION WAS TAKEN. RUN TERMINATED' + CALL XERRWD(MSG,41,203,1,0,0,0,0,0.0D0,0.0D0) + RETURN +110 CONTINUE +C +C----------------------------------------------------------------------- +C This block is executed on all calls. +C +C Counters are saved for later checks of performance. +C Then the error tolerance parameters are checked, and the +C work array pointers are set. +C----------------------------------------------------------------------- +C +200 CONTINUE +C +C Save counters for use later. +C + IWORK(LNSTL)=IWORK(LNST) + NLI0 = IWORK(LNLI) + NNI0 = IWORK(LNNI) + NCFN0 = IWORK(LNCFN) + NCFL0 = IWORK(LNCFL) + NWARN = 0 +C +C Check RTOL and ATOL. +C + NZFLG = 0 + RTOLI = RTOL(1) + ATOLI = ATOL(1) + DO 210 I=1,NEQ + IF (INFO(2) .EQ. 1) RTOLI = RTOL(I) + IF (INFO(2) .EQ. 1) ATOLI = ATOL(I) + IF (RTOLI .GT. 0.0D0 .OR. ATOLI .GT. 0.0D0) NZFLG = 1 + IF (RTOLI .LT. 0.0D0) GO TO 706 + IF (ATOLI .LT. 0.0D0) GO TO 707 +210 CONTINUE + IF (NZFLG .EQ. 0) GO TO 708 +C +C Set pointers to RWORK and IWORK segments. +C For direct methods, SAVR is not used. +C + IWORK(LLCIWP) = LID + LENID + LSAVR = LDELTA + IF (INFO(12) .NE. 0) LSAVR = LDELTA + NEQ + LE = LSAVR + NEQ + LWT = LE + NEQ + LVT = LWT + IF (INFO(16) .NE. 0) LVT = LWT + NEQ + LPHI = LVT + NEQ + LWM = LPHI + (IWORK(LMXORD)+1)*NEQ + IF (INFO(1) .EQ. 1) GO TO 400 +C +C----------------------------------------------------------------------- +C This block is executed on the initial call only. +C Set the initial step size, the error weight vector, and PHI. +C Compute unknown initial components of Y and YPRIME, if requested. +C----------------------------------------------------------------------- +C +300 CONTINUE + TN=T + IDID=1 +C +C Set error weight array WT and altered weight array VT. +C + CALL DDAWTS(NEQ,INFO(2),RTOL,ATOL,Y,RWORK(LWT),RPAR,IPAR) + CALL DINVWT(NEQ,RWORK(LWT),IER) + IF (IER .NE. 0) GO TO 713 + IF (INFO(16) .NE. 0) THEN + DO 305 I = 1, NEQ + 305 RWORK(LVT+I-1) = MAX(IWORK(LID+I-1),0)*RWORK(LWT+I-1) + ENDIF +C +C Compute unit roundoff and HMIN. +C + UROUND = D1MACH(4) + RWORK(LROUND) = UROUND + HMIN = 4.0D0*UROUND*MAX(ABS(T),ABS(TOUT)) +C +C Set/check STPTOL control for initial condition calculation. +C + IF (INFO(11) .NE. 0) THEN + IF( INFO(17) .EQ. 0) THEN + RWORK(LSTOL) = UROUND**.6667D0 + ELSE + IF (RWORK(LSTOL) .LE. 0.0D0) GO TO 725 + ENDIF + ENDIF +C +C Compute EPCON and square root of NEQ and its reciprocal, used +C inside iterative solver. +C + RWORK(LEPCON) = 0.33D0 + FLOATN = NEQ + RWORK(LSQRN) = SQRT(FLOATN) + RWORK(LRSQRN) = 1.D0/RWORK(LSQRN) +C +C Check initial interval to see that it is long enough. +C + TDIST = ABS(TOUT - T) + IF(TDIST .LT. HMIN) GO TO 714 +C +C Check H0, if this was input. +C + IF (INFO(8) .EQ. 0) GO TO 310 + H0 = RWORK(LH) + IF ((TOUT - T)*H0 .LT. 0.0D0) GO TO 711 + IF (H0 .EQ. 0.0D0) GO TO 712 + GO TO 320 +310 CONTINUE +C +C Compute initial stepsize, to be used by either +C DDSTP or DDASIC, depending on INFO(11). +C + H0 = 0.001D0*TDIST + YPNORM = DDWNRM(NEQ,YPRIME,RWORK(LVT),RPAR,IPAR) + IF (YPNORM .GT. 0.5D0/H0) H0 = 0.5D0/YPNORM + H0 = SIGN(H0,TOUT-T) +C +C Adjust H0 if necessary to meet HMAX bound. +C +320 IF (INFO(7) .EQ. 0) GO TO 330 + RH = ABS(H0)/RWORK(LHMAX) + IF (RH .GT. 1.0D0) H0 = H0/RH +C +C Check against TSTOP, if applicable. +C +330 IF (INFO(4) .EQ. 0) GO TO 340 + TSTOP = RWORK(LTSTOP) + IF ((TSTOP - T)*H0 .LT. 0.0D0) GO TO 715 + IF ((T + H0 - TSTOP)*H0 .GT. 0.0D0) H0 = TSTOP - T + IF ((TSTOP - TOUT)*H0 .LT. 0.0D0) GO TO 709 +C +340 IF (INFO(11) .EQ. 0) GO TO 370 +C +C Compute unknown components of initial Y and YPRIME, depending +C on INFO(11) and INFO(12). INFO(12) represents the nonlinear +C solver type (direct/Krylov). Pass the name of the specific +C nonlinear solver, depending on INFO(12). The location of the work +C arrays SAVR, YIC, YPIC, PWK also differ in the two cases. +C + NWT = 1 + EPCONI = RWORK(LEPIN)*RWORK(LEPCON) +350 IF (INFO(12) .EQ. 0) THEN + LYIC = LPHI + 2*NEQ + LYPIC = LYIC + NEQ + LPWK = LYPIC + CALL DDASIC(TN,Y,YPRIME,NEQ,INFO(11),IWORK(LID), + * RES,JAC,PSOL,H0,RWORK(LWT),NWT,IDID,RPAR,IPAR, + * RWORK(LPHI),RWORK(LSAVR),RWORK(LDELTA),RWORK(LE), + * RWORK(LYIC),RWORK(LYPIC),RWORK(LPWK),RWORK(LWM),IWORK(LIWM), + * HMIN,RWORK(LROUND),RWORK(LEPLI),RWORK(LSQRN),RWORK(LRSQRN), + * EPCONI,RWORK(LSTOL),INFO(15),ICNFLG,IWORK(LICNS),DDASID) + ELSE IF (INFO(12) .EQ. 1) THEN + LYIC = LWM + LYPIC = LYIC + NEQ + LPWK = LYPIC + NEQ + CALL DDASIC(TN,Y,YPRIME,NEQ,INFO(11),IWORK(LID), + * RES,JAC,PSOL,H0,RWORK(LWT),NWT,IDID,RPAR,IPAR, + * RWORK(LPHI),RWORK(LSAVR),RWORK(LDELTA),RWORK(LE), + * RWORK(LYIC),RWORK(LYPIC),RWORK(LPWK),RWORK(LWM),IWORK(LIWM), + * HMIN,RWORK(LROUND),RWORK(LEPLI),RWORK(LSQRN),RWORK(LRSQRN), + * EPCONI,RWORK(LSTOL),INFO(15),ICNFLG,IWORK(LICNS),DDASIK) + ENDIF +C + IF (IDID .LT. 0) GO TO 600 +C +C DDASIC was successful. If this was the first call to DDASIC, +C update the WT array (with the current Y) and call it again. +C + IF (NWT .EQ. 2) GO TO 355 + NWT = 2 + CALL DDAWTS(NEQ,INFO(2),RTOL,ATOL,Y,RWORK(LWT),RPAR,IPAR) + CALL DINVWT(NEQ,RWORK(LWT),IER) + IF (IER .NE. 0) GO TO 713 + GO TO 350 +C +C If INFO(14) = 1, return now with IDID = 4. +C +355 IF (INFO(14) .EQ. 1) THEN + IDID = 4 + H = H0 + IF (INFO(11) .EQ. 1) RWORK(LHOLD) = H0 + GO TO 590 + ENDIF +C +C Update the WT and VT arrays one more time, with the new Y. +C + CALL DDAWTS(NEQ,INFO(2),RTOL,ATOL,Y,RWORK(LWT),RPAR,IPAR) + CALL DINVWT(NEQ,RWORK(LWT),IER) + IF (IER .NE. 0) GO TO 713 + IF (INFO(16) .NE. 0) THEN + DO 357 I = 1, NEQ + 357 RWORK(LVT+I-1) = MAX(IWORK(LID+I-1),0)*RWORK(LWT+I-1) + ENDIF +C +C Reset the initial stepsize to be used by DDSTP. +C Use H0, if this was input. Otherwise, recompute H0, +C and adjust it if necessary to meet HMAX bound. +C + IF (INFO(8) .NE. 0) THEN + H0 = RWORK(LH) + GO TO 360 + ENDIF +C + H0 = 0.001D0*TDIST + YPNORM = DDWNRM(NEQ,YPRIME,RWORK(LVT),RPAR,IPAR) + IF (YPNORM .GT. 0.5D0/H0) H0 = 0.5D0/YPNORM + H0 = SIGN(H0,TOUT-T) +C +360 IF (INFO(7) .NE. 0) THEN + RH = ABS(H0)/RWORK(LHMAX) + IF (RH .GT. 1.0D0) H0 = H0/RH + ENDIF +C +C Check against TSTOP, if applicable. +C + IF (INFO(4) .NE. 0) THEN + TSTOP = RWORK(LTSTOP) + IF ((T + H0 - TSTOP)*H0 .GT. 0.0D0) H0 = TSTOP - T + ENDIF +C +C Load H and RWORK(LH) with H0. +C +370 H = H0 + RWORK(LH) = H +C +C Load Y and H*YPRIME into PHI(*,1) and PHI(*,2). +C + ITEMP = LPHI + NEQ + DO 380 I = 1,NEQ + RWORK(LPHI + I - 1) = Y(I) +380 RWORK(ITEMP + I - 1) = H*YPRIME(I) +C + GO TO 500 +C +C----------------------------------------------------------------------- +C This block is for continuation calls only. +C Its purpose is to check stop conditions before taking a step. +C Adjust H if necessary to meet HMAX bound. +C----------------------------------------------------------------------- +C +400 CONTINUE + UROUND=RWORK(LROUND) + DONE = .FALSE. + TN=RWORK(LTN) + H=RWORK(LH) + IF(INFO(7) .EQ. 0) GO TO 410 + RH = ABS(H)/RWORK(LHMAX) + IF(RH .GT. 1.0D0) H = H/RH +410 CONTINUE + IF(T .EQ. TOUT) GO TO 719 + IF((T - TOUT)*H .GT. 0.0D0) GO TO 711 + IF(INFO(4) .EQ. 1) GO TO 430 + IF(INFO(3) .EQ. 1) GO TO 420 + IF((TN-TOUT)*H.LT.0.0D0)GO TO 490 + CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD), + * RWORK(LPHI),RWORK(LPSI)) + T=TOUT + IDID = 3 + DONE = .TRUE. + GO TO 490 +420 IF((TN-T)*H .LE. 0.0D0) GO TO 490 + IF((TN - TOUT)*H .GT. 0.0D0) GO TO 425 + CALL DDATRP(TN,TN,Y,YPRIME,NEQ,IWORK(LKOLD), + * RWORK(LPHI),RWORK(LPSI)) + T = TN + IDID = 1 + DONE = .TRUE. + GO TO 490 +425 CONTINUE + CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD), + * RWORK(LPHI),RWORK(LPSI)) + T = TOUT + IDID = 3 + DONE = .TRUE. + GO TO 490 +430 IF(INFO(3) .EQ. 1) GO TO 440 + TSTOP=RWORK(LTSTOP) + IF((TN-TSTOP)*H.GT.0.0D0) GO TO 715 + IF((TSTOP-TOUT)*H.LT.0.0D0)GO TO 709 + IF((TN-TOUT)*H.LT.0.0D0)GO TO 450 + CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD), + * RWORK(LPHI),RWORK(LPSI)) + T=TOUT + IDID = 3 + DONE = .TRUE. + GO TO 490 +440 TSTOP = RWORK(LTSTOP) + IF((TN-TSTOP)*H .GT. 0.0D0) GO TO 715 + IF((TSTOP-TOUT)*H .LT. 0.0D0) GO TO 709 + IF((TN-T)*H .LE. 0.0D0) GO TO 450 + IF((TN - TOUT)*H .GT. 0.0D0) GO TO 445 + CALL DDATRP(TN,TN,Y,YPRIME,NEQ,IWORK(LKOLD), + * RWORK(LPHI),RWORK(LPSI)) + T = TN + IDID = 1 + DONE = .TRUE. + GO TO 490 +445 CONTINUE + CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD), + * RWORK(LPHI),RWORK(LPSI)) + T = TOUT + IDID = 3 + DONE = .TRUE. + GO TO 490 +450 CONTINUE +C +C Check whether we are within roundoff of TSTOP. +C + IF(ABS(TN-TSTOP).GT.100.0D0*UROUND* + * (ABS(TN)+ABS(H)))GO TO 460 + CALL DDATRP(TN,TSTOP,Y,YPRIME,NEQ,IWORK(LKOLD), + * RWORK(LPHI),RWORK(LPSI)) + IDID=2 + T=TSTOP + DONE = .TRUE. + GO TO 490 +460 TNEXT=TN+H + IF((TNEXT-TSTOP)*H.LE.0.0D0)GO TO 490 + H=TSTOP-TN + RWORK(LH)=H +C +490 IF (DONE) GO TO 590 +C +C----------------------------------------------------------------------- +C The next block contains the call to the one-step integrator DDSTP. +C This is a looping point for the integration steps. +C Check for too many steps. +C Check for poor Newton/Krylov performance. +C Update WT. Check for too much accuracy requested. +C Compute minimum stepsize. +C----------------------------------------------------------------------- +C +500 CONTINUE +C +C Check for too many steps. +C + IF((IWORK(LNST)-IWORK(LNSTL)).LT.500) GO TO 505 + IDID=-1 + GO TO 527 +C +C Check for poor Newton/Krylov performance. +C +505 IF (INFO(12) .EQ. 0) GO TO 510 + NSTD = IWORK(LNST) - IWORK(LNSTL) + NNID = IWORK(LNNI) - NNI0 + IF (NSTD .LT. 10 .OR. NNID .EQ. 0) GO TO 510 + AVLIN = REAL(IWORK(LNLI) - NLI0)/REAL(NNID) + RCFN = REAL(IWORK(LNCFN) - NCFN0)/REAL(NSTD) + RCFL = REAL(IWORK(LNCFL) - NCFL0)/REAL(NNID) + FMAXL = IWORK(LMAXL) + LAVL = AVLIN .GT. FMAXL + LCFN = RCFN .GT. 0.9D0 + LCFL = RCFL .GT. 0.9D0 + LWARN = LAVL .OR. LCFN .OR. LCFL + IF (.NOT.LWARN) GO TO 510 + NWARN = NWARN + 1 + IF (NWARN .GT. 10) GO TO 510 + IF (LAVL) THEN + MSG = 'DASPK-- Warning. Poor iterative algorithm performance ' + CALL XERRWD (MSG, 56, 501, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) + MSG = ' at T = R1. Average no. of linear iterations = R2 ' + CALL XERRWD (MSG, 56, 501, 0, 0, 0, 0, 2, TN, AVLIN) + ENDIF + IF (LCFN) THEN + MSG = 'DASPK-- Warning. Poor iterative algorithm performance ' + CALL XERRWD (MSG, 56, 502, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) + MSG = ' at T = R1. Nonlinear convergence failure rate = R2' + CALL XERRWD (MSG, 56, 502, 0, 0, 0, 0, 2, TN, RCFN) + ENDIF + IF (LCFL) THEN + MSG = 'DASPK-- Warning. Poor iterative algorithm performance ' + CALL XERRWD (MSG, 56, 503, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) + MSG = ' at T = R1. Linear convergence failure rate = R2 ' + CALL XERRWD (MSG, 56, 503, 0, 0, 0, 0, 2, TN, RCFL) + ENDIF +C +C Update WT and VT, if this is not the first call. +C +510 CALL DDAWTS(NEQ,INFO(2),RTOL,ATOL,RWORK(LPHI),RWORK(LWT), + * RPAR,IPAR) + CALL DINVWT(NEQ,RWORK(LWT),IER) + IF (IER .NE. 0) THEN + IDID = -3 + GO TO 527 + ENDIF + IF (INFO(16) .NE. 0) THEN + DO 515 I = 1, NEQ + 515 RWORK(LVT+I-1) = MAX(IWORK(LID+I-1),0)*RWORK(LWT+I-1) + ENDIF +C +C Test for too much accuracy requested. +C + R = DDWNRM(NEQ,RWORK(LPHI),RWORK(LWT),RPAR,IPAR)*100.0D0*UROUND + IF (R .LE. 1.0D0) GO TO 525 +C +C Multiply RTOL and ATOL by R and return. +C + IF(INFO(2).EQ.1)GO TO 523 + RTOL(1)=R*RTOL(1) + ATOL(1)=R*ATOL(1) + IDID=-2 + GO TO 527 +523 DO 524 I=1,NEQ + RTOL(I)=R*RTOL(I) +524 ATOL(I)=R*ATOL(I) + IDID=-2 + GO TO 527 +525 CONTINUE +C +C Compute minimum stepsize. +C + HMIN=4.0D0*UROUND*MAX(ABS(TN),ABS(TOUT)) +C +C Test H vs. HMAX + IF (INFO(7) .NE. 0) THEN + RH = ABS(H)/RWORK(LHMAX) + IF (RH .GT. 1.0D0) H = H/RH + ENDIF +C +C Call the one-step integrator. +C Note that INFO(12) represents the nonlinear solver type. +C Pass the required nonlinear solver, depending upon INFO(12). +C + IF (INFO(12) .EQ. 0) THEN + CALL DDSTP(TN,Y,YPRIME,NEQ, + * RES,JAC,PSOL,H,RWORK(LWT),RWORK(LVT),INFO(1),IDID,RPAR,IPAR, + * RWORK(LPHI),RWORK(LSAVR),RWORK(LDELTA),RWORK(LE), + * RWORK(LWM),IWORK(LIWM), + * RWORK(LALPHA),RWORK(LBETA),RWORK(LGAMMA), + * RWORK(LPSI),RWORK(LSIGMA), + * RWORK(LCJ),RWORK(LCJOLD),RWORK(LHOLD),RWORK(LS),HMIN, + * RWORK(LROUND), RWORK(LEPLI),RWORK(LSQRN),RWORK(LRSQRN), + * RWORK(LEPCON), IWORK(LPHASE),IWORK(LJCALC),INFO(15), + * IWORK(LK), IWORK(LKOLD),IWORK(LNS),NONNEG,INFO(12), + * DNEDD) + ELSE IF (INFO(12) .EQ. 1) THEN + CALL DDSTP(TN,Y,YPRIME,NEQ, + * RES,JAC,PSOL,H,RWORK(LWT),RWORK(LVT),INFO(1),IDID,RPAR,IPAR, + * RWORK(LPHI),RWORK(LSAVR),RWORK(LDELTA),RWORK(LE), + * RWORK(LWM),IWORK(LIWM), + * RWORK(LALPHA),RWORK(LBETA),RWORK(LGAMMA), + * RWORK(LPSI),RWORK(LSIGMA), + * RWORK(LCJ),RWORK(LCJOLD),RWORK(LHOLD),RWORK(LS),HMIN, + * RWORK(LROUND), RWORK(LEPLI),RWORK(LSQRN),RWORK(LRSQRN), + * RWORK(LEPCON), IWORK(LPHASE),IWORK(LJCALC),INFO(15), + * IWORK(LK), IWORK(LKOLD),IWORK(LNS),NONNEG,INFO(12), + * DNEDK) + ENDIF +C +527 IF(IDID.LT.0)GO TO 600 +C +C----------------------------------------------------------------------- +C This block handles the case of a successful return from DDSTP +C (IDID=1). Test for stop conditions. +C----------------------------------------------------------------------- +C + IF(INFO(4).NE.0)GO TO 540 + IF(INFO(3).NE.0)GO TO 530 + IF((TN-TOUT)*H.LT.0.0D0)GO TO 500 + CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ, + * IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) + IDID=3 + T=TOUT + GO TO 580 +530 IF((TN-TOUT)*H.GE.0.0D0)GO TO 535 + T=TN + IDID=1 + GO TO 580 +535 CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ, + * IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) + IDID=3 + T=TOUT + GO TO 580 +540 IF(INFO(3).NE.0)GO TO 550 + IF((TN-TOUT)*H.LT.0.0D0)GO TO 542 + CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ, + * IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) + T=TOUT + IDID=3 + GO TO 580 +542 IF(ABS(TN-TSTOP).LE.100.0D0*UROUND* + * (ABS(TN)+ABS(H)))GO TO 545 + TNEXT=TN+H + IF((TNEXT-TSTOP)*H.LE.0.0D0)GO TO 500 + H=TSTOP-TN + GO TO 500 +545 CALL DDATRP(TN,TSTOP,Y,YPRIME,NEQ, + * IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) + IDID=2 + T=TSTOP + GO TO 580 +550 IF((TN-TOUT)*H.GE.0.0D0)GO TO 555 + IF(ABS(TN-TSTOP).LE.100.0D0*UROUND*(ABS(TN)+ABS(H)))GO TO 552 + T=TN + IDID=1 + GO TO 580 +552 CALL DDATRP(TN,TSTOP,Y,YPRIME,NEQ, + * IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) + IDID=2 + T=TSTOP + GO TO 580 +555 CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ, + * IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) + T=TOUT + IDID=3 +580 CONTINUE +C +C----------------------------------------------------------------------- +C All successful returns from DDASPK are made from this block. +C----------------------------------------------------------------------- +C +590 CONTINUE + RWORK(LTN)=TN + RWORK(LH)=H + RETURN +C +C----------------------------------------------------------------------- +C This block handles all unsuccessful returns other than for +C illegal input. +C----------------------------------------------------------------------- +C +600 CONTINUE + ITEMP = -IDID + GO TO (610,620,630,700,655,640,650,660,670,675, + * 680,685,690,695), ITEMP +C +C The maximum number of steps was taken before +C reaching tout. +C +610 MSG = 'DASPK-- AT CURRENT T (=R1) 500 STEPS' + CALL XERRWD(MSG,38,610,0,0,0,0,1,TN,0.0D0) + MSG = 'DASPK-- TAKEN ON THIS CALL BEFORE REACHING TOUT' + CALL XERRWD(MSG,48,611,0,0,0,0,0,0.0D0,0.0D0) + GO TO 700 +C +C Too much accuracy for machine precision. +C +620 MSG = 'DASPK-- AT T (=R1) TOO MUCH ACCURACY REQUESTED' + CALL XERRWD(MSG,47,620,0,0,0,0,1,TN,0.0D0) + MSG = 'DASPK-- FOR PRECISION OF MACHINE. RTOL AND ATOL' + CALL XERRWD(MSG,48,621,0,0,0,0,0,0.0D0,0.0D0) + MSG = 'DASPK-- WERE INCREASED TO APPROPRIATE VALUES' + CALL XERRWD(MSG,45,622,0,0,0,0,0,0.0D0,0.0D0) + GO TO 700 +C +C WT(I) .LE. 0.0D0 for some I (not at start of problem). +C +630 MSG = 'DASPK-- AT T (=R1) SOME ELEMENT OF WT' + CALL XERRWD(MSG,38,630,0,0,0,0,1,TN,0.0D0) + MSG = 'DASPK-- HAS BECOME .LE. 0.0' + CALL XERRWD(MSG,28,631,0,0,0,0,0,0.0D0,0.0D0) + GO TO 700 +C +C Error test failed repeatedly or with H=HMIN. +C +640 MSG = 'DASPK-- AT T (=R1) AND STEPSIZE H (=R2) THE' + CALL XERRWD(MSG,44,640,0,0,0,0,2,TN,H) + MSG='DASPK-- ERROR TEST FAILED REPEATEDLY OR WITH ABS(H)=HMIN' + CALL XERRWD(MSG,57,641,0,0,0,0,0,0.0D0,0.0D0) + GO TO 700 +C +C Nonlinear solver failed to converge repeatedly or with H=HMIN. +C +650 MSG = 'DASPK-- AT T (=R1) AND STEPSIZE H (=R2) THE' + CALL XERRWD(MSG,44,650,0,0,0,0,2,TN,H) + MSG = 'DASPK-- NONLINEAR SOLVER FAILED TO CONVERGE' + CALL XERRWD(MSG,44,651,0,0,0,0,0,0.0D0,0.0D0) + MSG = 'DASPK-- REPEATEDLY OR WITH ABS(H)=HMIN' + CALL XERRWD(MSG,40,652,0,0,0,0,0,0.0D0,0.0D0) + GO TO 700 +C +C The preconditioner had repeated failures. +C +655 MSG = 'DASPK-- AT T (=R1) AND STEPSIZE H (=R2) THE' + CALL XERRWD(MSG,44,655,0,0,0,0,2,TN,H) + MSG = 'DASPK-- PRECONDITIONER HAD REPEATED FAILURES.' + CALL XERRWD(MSG,46,656,0,0,0,0,0,0.0D0,0.0D0) + GO TO 700 +C +C The iteration matrix is singular. +C +660 MSG = 'DASPK-- AT T (=R1) AND STEPSIZE H (=R2) THE' + CALL XERRWD(MSG,44,660,0,0,0,0,2,TN,H) + MSG = 'DASPK-- ITERATION MATRIX IS SINGULAR.' + CALL XERRWD(MSG,38,661,0,0,0,0,0,0.0D0,0.0D0) + GO TO 700 +C +C Nonlinear system failure preceded by error test failures. +C +670 MSG = 'DASPK-- AT T (=R1) AND STEPSIZE H (=R2) THE' + CALL XERRWD(MSG,44,670,0,0,0,0,2,TN,H) + MSG = 'DASPK-- NONLINEAR SOLVER COULD NOT CONVERGE.' + CALL XERRWD(MSG,45,671,0,0,0,0,0,0.0D0,0.0D0) + MSG = 'DASPK-- ALSO, THE ERROR TEST FAILED REPEATEDLY.' + CALL XERRWD(MSG,49,672,0,0,0,0,0,0.0D0,0.0D0) + GO TO 700 +C +C Nonlinear system failure because IRES = -1. +C +675 MSG = 'DASPK-- AT T (=R1) AND STEPSIZE H (=R2) THE' + CALL XERRWD(MSG,44,675,0,0,0,0,2,TN,H) + MSG = 'DASPK-- NONLINEAR SYSTEM SOLVER COULD NOT CONVERGE' + CALL XERRWD(MSG,51,676,0,0,0,0,0,0.0D0,0.0D0) + MSG = 'DASPK-- BECAUSE IRES WAS EQUAL TO MINUS ONE' + CALL XERRWD(MSG,44,677,0,0,0,0,0,0.0D0,0.0D0) + GO TO 700 +C +C Failure because IRES = -2. +C +680 MSG = 'DASPK-- AT T (=R1) AND STEPSIZE H (=R2)' + CALL XERRWD(MSG,40,680,0,0,0,0,2,TN,H) + MSG = 'DASPK-- IRES WAS EQUAL TO MINUS TWO' + CALL XERRWD(MSG,36,681,0,0,0,0,0,0.0D0,0.0D0) + GO TO 700 +C +C Failed to compute initial YPRIME. +C +685 MSG = 'DASPK-- AT T (=R1) AND STEPSIZE H (=R2) THE' + CALL XERRWD(MSG,44,685,0,0,0,0,0,0.0D0,0.0D0) + MSG = 'DASPK-- INITIAL (Y,YPRIME) COULD NOT BE COMPUTED' + CALL XERRWD(MSG,49,686,0,0,0,0,2,TN,H0) + GO TO 700 +C +C Failure because IER was negative from PSOL. +C +690 MSG = 'DASPK-- AT T (=R1) AND STEPSIZE H (=R2)' + CALL XERRWD(MSG,40,690,0,0,0,0,2,TN,H) + MSG = 'DASPK-- IER WAS NEGATIVE FROM PSOL' + CALL XERRWD(MSG,35,691,0,0,0,0,0,0.0D0,0.0D0) + GO TO 700 +C +C Failure because the linear system solver could not converge. +C +695 MSG = 'DASPK-- AT T (=R1) AND STEPSIZE H (=R2) THE' + CALL XERRWD(MSG,44,695,0,0,0,0,2,TN,H) + MSG = 'DASPK-- LINEAR SYSTEM SOLVER COULD NOT CONVERGE.' + CALL XERRWD(MSG,50,696,0,0,0,0,0,0.0D0,0.0D0) + GO TO 700 +C +C +700 CONTINUE + INFO(1)=-1 + T=TN + RWORK(LTN)=TN + RWORK(LH)=H + RETURN +C +C----------------------------------------------------------------------- +C This block handles all error returns due to illegal input, +C as detected before calling DDSTP. +C First the error message routine is called. If this happens +C twice in succession, execution is terminated. +C----------------------------------------------------------------------- +C +701 MSG = 'DASPK-- ELEMENT (=I1) OF INFO VECTOR IS NOT VALID' + CALL XERRWD(MSG,50,1,0,1,ITEMP,0,0,0.0D0,0.0D0) + GO TO 750 +702 MSG = 'DASPK-- NEQ (=I1) .LE. 0' + CALL XERRWD(MSG,25,2,0,1,NEQ,0,0,0.0D0,0.0D0) + GO TO 750 +703 MSG = 'DASPK-- MAXORD (=I1) NOT IN RANGE' + CALL XERRWD(MSG,34,3,0,1,MXORD,0,0,0.0D0,0.0D0) + GO TO 750 +704 MSG='DASPK-- RWORK LENGTH NEEDED, LENRW (=I1), EXCEEDS LRW (=I2)' + CALL XERRWD(MSG,60,4,0,2,LENRW,LRW,0,0.0D0,0.0D0) + GO TO 750 +705 MSG='DASPK-- IWORK LENGTH NEEDED, LENIW (=I1), EXCEEDS LIW (=I2)' + CALL XERRWD(MSG,60,5,0,2,LENIW,LIW,0,0.0D0,0.0D0) + GO TO 750 +706 MSG = 'DASPK-- SOME ELEMENT OF RTOL IS .LT. 0' + CALL XERRWD(MSG,39,6,0,0,0,0,0,0.0D0,0.0D0) + GO TO 750 +707 MSG = 'DASPK-- SOME ELEMENT OF ATOL IS .LT. 0' + CALL XERRWD(MSG,39,7,0,0,0,0,0,0.0D0,0.0D0) + GO TO 750 +708 MSG = 'DASPK-- ALL ELEMENTS OF RTOL AND ATOL ARE ZERO' + CALL XERRWD(MSG,47,8,0,0,0,0,0,0.0D0,0.0D0) + GO TO 750 +709 MSG='DASPK-- INFO(4) = 1 AND TSTOP (=R1) BEHIND TOUT (=R2)' + CALL XERRWD(MSG,54,9,0,0,0,0,2,TSTOP,TOUT) + GO TO 750 +710 MSG = 'DASPK-- HMAX (=R1) .LT. 0.0' + CALL XERRWD(MSG,28,10,0,0,0,0,1,HMAX,0.0D0) + GO TO 750 +711 MSG = 'DASPK-- TOUT (=R1) BEHIND T (=R2)' + CALL XERRWD(MSG,34,11,0,0,0,0,2,TOUT,T) + GO TO 750 +712 MSG = 'DASPK-- INFO(8)=1 AND H0=0.0' + CALL XERRWD(MSG,29,12,0,0,0,0,0,0.0D0,0.0D0) + GO TO 750 +713 MSG = 'DASPK-- SOME ELEMENT OF WT IS .LE. 0.0' + CALL XERRWD(MSG,39,13,0,0,0,0,0,0.0D0,0.0D0) + GO TO 750 +714 MSG='DASPK-- TOUT (=R1) TOO CLOSE TO T (=R2) TO START INTEGRATION' + CALL XERRWD(MSG,60,14,0,0,0,0,2,TOUT,T) + GO TO 750 +715 MSG = 'DASPK-- INFO(4)=1 AND TSTOP (=R1) BEHIND T (=R2)' + CALL XERRWD(MSG,49,15,0,0,0,0,2,TSTOP,T) + GO TO 750 +717 MSG = 'DASPK-- ML (=I1) ILLEGAL. EITHER .LT. 0 OR .GT. NEQ' + CALL XERRWD(MSG,52,17,0,1,IWORK(LML),0,0,0.0D0,0.0D0) + GO TO 750 +718 MSG = 'DASPK-- MU (=I1) ILLEGAL. EITHER .LT. 0 OR .GT. NEQ' + CALL XERRWD(MSG,52,18,0,1,IWORK(LMU),0,0,0.0D0,0.0D0) + GO TO 750 +719 MSG = 'DASPK-- TOUT (=R1) IS EQUAL TO T (=R2)' + CALL XERRWD(MSG,39,19,0,0,0,0,2,TOUT,T) + GO TO 750 +720 MSG = 'DASPK-- MAXL (=I1) ILLEGAL. EITHER .LT. 1 OR .GT. NEQ' + CALL XERRWD(MSG,54,20,0,1,IWORK(LMAXL),0,0,0.0D0,0.0D0) + GO TO 750 +721 MSG = 'DASPK-- KMP (=I1) ILLEGAL. EITHER .LT. 1 OR .GT. MAXL' + CALL XERRWD(MSG,54,21,0,1,IWORK(LKMP),0,0,0.0D0,0.0D0) + GO TO 750 +722 MSG = 'DASPK-- NRMAX (=I1) ILLEGAL. .LT. 0' + CALL XERRWD(MSG,36,22,0,1,IWORK(LNRMAX),0,0,0.0D0,0.0D0) + GO TO 750 +723 MSG = 'DASPK-- EPLI (=R1) ILLEGAL. EITHER .LE. 0.D0 OR .GE. 1.D0' + CALL XERRWD(MSG,58,23,0,0,0,0,1,RWORK(LEPLI),0.0D0) + GO TO 750 +724 MSG = 'DASPK-- ILLEGAL IWORK VALUE FOR INFO(11) .NE. 0' + CALL XERRWD(MSG,48,24,0,0,0,0,0,0.0D0,0.0D0) + GO TO 750 +725 MSG = 'DASPK-- ONE OF THE INPUTS FOR INFO(17) = 1 IS ILLEGAL' + CALL XERRWD(MSG,54,25,0,0,0,0,0,0.0D0,0.0D0) + GO TO 750 +726 MSG = 'DASPK-- ILLEGAL IWORK VALUE FOR INFO(10) .NE. 0' + CALL XERRWD(MSG,48,26,0,0,0,0,0,0.0D0,0.0D0) + GO TO 750 +727 MSG = 'DASPK-- Y(I) AND IWORK(40+I) (I=I1) INCONSISTENT' + CALL XERRWD(MSG,49,27,0,1,IRET,0,0,0.0D0,0.0D0) + GO TO 750 +750 IF(INFO(1).EQ.-1) GO TO 760 + INFO(1)=-1 + IDID=-33 + RETURN +760 MSG = 'DASPK-- REPEATED OCCURRENCES OF ILLEGAL INPUT' + CALL XERRWD(MSG,46,701,0,0,0,0,0,0.0D0,0.0D0) +770 MSG = 'DASPK-- RUN TERMINATED. APPARENT INFINITE LOOP' + CALL XERRWD(MSG,47,702,1,0,0,0,0,0.0D0,0.0D0) + RETURN +C +C------END OF SUBROUTINE DDASPK----------------------------------------- + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/daspk/ddstp.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,465 @@ +C Work performed under the auspices of the U.S. Department of Energy +C by Lawrence Livermore National Laboratory under contract number +C W-7405-Eng-48. +C + SUBROUTINE DDSTP(X,Y,YPRIME,NEQ,RES,JAC,PSOL,H,WT,VT, + * JSTART,IDID,RPAR,IPAR,PHI,SAVR,DELTA,E,WM,IWM, + * ALPHA,BETA,GAMMA,PSI,SIGMA,CJ,CJOLD,HOLD,S,HMIN,UROUND, + * EPLI,SQRTN,RSQRTN,EPCON,IPHASE,JCALC,JFLG,K,KOLD,NS,NONNEG, + * NTYPE,NLS) +C +C***BEGIN PROLOGUE DDSTP +C***REFER TO DDASPK +C***DATE WRITTEN 890101 (YYMMDD) +C***REVISION DATE 900926 (YYMMDD) +C***REVISION DATE 940909 (YYMMDD) (Reset PSI(1), PHI(*,2) at 690) +C +C +C----------------------------------------------------------------------- +C***DESCRIPTION +C +C DDSTP solves a system of differential/algebraic equations of +C the form G(X,Y,YPRIME) = 0, for one step (normally from X to X+H). +C +C The methods used are modified divided difference, fixed leading +C coefficient forms of backward differentiation formulas. +C The code adjusts the stepsize and order to control the local error +C per step. +C +C +C The parameters represent +C X -- Independent variable. +C Y -- Solution vector at X. +C YPRIME -- Derivative of solution vector +C after successful step. +C NEQ -- Number of equations to be integrated. +C RES -- External user-supplied subroutine +C to evaluate the residual. See RES description +C in DDASPK prologue. +C JAC -- External user-supplied routine to update +C Jacobian or preconditioner information in the +C nonlinear solver. See JAC description in DDASPK +C prologue. +C PSOL -- External user-supplied routine to solve +C a linear system using preconditioning. +C (This is optional). See PSOL in DDASPK prologue. +C H -- Appropriate step size for next step. +C Normally determined by the code. +C WT -- Vector of weights for error criterion used in Newton test. +C VT -- Masked vector of weights used in error test. +C JSTART -- Integer variable set 0 for +C first step, 1 otherwise. +C IDID -- Completion code returned from the nonlinear solver. +C See IDID description in DDASPK prologue. +C RPAR,IPAR -- Real and integer parameter arrays that +C are used for communication between the +C calling program and external user routines. +C They are not altered by DNSK +C PHI -- Array of divided differences used by +C DDSTP. The length is NEQ*(K+1), where +C K is the maximum order. +C SAVR -- Work vector for DDSTP of length NEQ. +C DELTA,E -- Work vectors for DDSTP of length NEQ. +C WM,IWM -- Real and integer arrays storing +C information required by the linear solver. +C +C The other parameters are information +C which is needed internally by DDSTP to +C continue from step to step. +C +C----------------------------------------------------------------------- +C***ROUTINES CALLED +C NLS, DDWNRM, DDATRP +C +C***END PROLOGUE DDSTP +C +C + IMPLICIT DOUBLE PRECISION(A-H,O-Z) + DIMENSION Y(*),YPRIME(*),WT(*),VT(*) + DIMENSION PHI(NEQ,*),SAVR(*),DELTA(*),E(*) + DIMENSION WM(*),IWM(*) + DIMENSION PSI(*),ALPHA(*),BETA(*),GAMMA(*),SIGMA(*) + DIMENSION RPAR(*),IPAR(*) + EXTERNAL RES, JAC, PSOL, NLS +C + PARAMETER (LMXORD=3) + PARAMETER (LNST=11, LETF=14, LCFN=15) +C +C +C----------------------------------------------------------------------- +C BLOCK 1. +C Initialize. On the first call, set +C the order to 1 and initialize +C other variables. +C----------------------------------------------------------------------- +C +C Initializations for all calls +C + XOLD=X + NCF=0 + NEF=0 + IF(JSTART .NE. 0) GO TO 120 +C +C If this is the first step, perform +C other initializations +C + K=1 + KOLD=0 + HOLD=0.0D0 + PSI(1)=H + CJ = 1.D0/H + IPHASE = 0 + NS=0 +120 CONTINUE +C +C +C +C +C +C----------------------------------------------------------------------- +C BLOCK 2 +C Compute coefficients of formulas for +C this step. +C----------------------------------------------------------------------- +200 CONTINUE + KP1=K+1 + KP2=K+2 + KM1=K-1 + IF(H.NE.HOLD.OR.K .NE. KOLD) NS = 0 + NS=MIN0(NS+1,KOLD+2) + NSP1=NS+1 + IF(KP1 .LT. NS)GO TO 230 +C + BETA(1)=1.0D0 + ALPHA(1)=1.0D0 + TEMP1=H + GAMMA(1)=0.0D0 + SIGMA(1)=1.0D0 + DO 210 I=2,KP1 + TEMP2=PSI(I-1) + PSI(I-1)=TEMP1 + BETA(I)=BETA(I-1)*PSI(I-1)/TEMP2 + TEMP1=TEMP2+H + ALPHA(I)=H/TEMP1 + SIGMA(I)=(I-1)*SIGMA(I-1)*ALPHA(I) + GAMMA(I)=GAMMA(I-1)+ALPHA(I-1)/H +210 CONTINUE + PSI(KP1)=TEMP1 +230 CONTINUE +C +C Compute ALPHAS, ALPHA0 +C + ALPHAS = 0.0D0 + ALPHA0 = 0.0D0 + DO 240 I = 1,K + ALPHAS = ALPHAS - 1.0D0/I + ALPHA0 = ALPHA0 - ALPHA(I) +240 CONTINUE +C +C Compute leading coefficient CJ +C + CJLAST = CJ + CJ = -ALPHAS/H +C +C Compute variable stepsize error coefficient CK +C + CK = ABS(ALPHA(KP1) + ALPHAS - ALPHA0) + CK = MAX(CK,ALPHA(KP1)) +C +C Change PHI to PHI STAR +C + IF(KP1 .LT. NSP1) GO TO 280 + DO 270 J=NSP1,KP1 + DO 260 I=1,NEQ +260 PHI(I,J)=BETA(J)*PHI(I,J) +270 CONTINUE +280 CONTINUE +C +C Update time +C + X=X+H +C +C Initialize IDID to 1 +C + IDID = 1 +C +C +C +C +C +C----------------------------------------------------------------------- +C BLOCK 3 +C Call the nonlinear system solver to obtain the solution and +C derivative. +C----------------------------------------------------------------------- +C + CALL NLS(X,Y,YPRIME,NEQ, + * RES,JAC,PSOL,H,WT,JSTART,IDID,RPAR,IPAR,PHI,GAMMA, + * SAVR,DELTA,E,WM,IWM,CJ,CJOLD,CJLAST,S, + * UROUND,EPLI,SQRTN,RSQRTN,EPCON,JCALC,JFLG,KP1, + * NONNEG,NTYPE,IERNLS) +C + IF(IERNLS .NE. 0)GO TO 600 +C +C +C +C +C +C----------------------------------------------------------------------- +C BLOCK 4 +C Estimate the errors at orders K,K-1,K-2 +C as if constant stepsize was used. Estimate +C the local error at order K and test +C whether the current step is successful. +C----------------------------------------------------------------------- +C +C Estimate errors at orders K,K-1,K-2 +C + ENORM = DDWNRM(NEQ,E,VT,RPAR,IPAR) + ERK = SIGMA(K+1)*ENORM + TERK = (K+1)*ERK + EST = ERK + KNEW=K + IF(K .EQ. 1)GO TO 430 + DO 405 I = 1,NEQ +405 DELTA(I) = PHI(I,KP1) + E(I) + ERKM1=SIGMA(K)*DDWNRM(NEQ,DELTA,VT,RPAR,IPAR) + TERKM1 = K*ERKM1 + IF(K .GT. 2)GO TO 410 + IF(TERKM1 .LE. 0.5*TERK)GO TO 420 + GO TO 430 +410 CONTINUE + DO 415 I = 1,NEQ +415 DELTA(I) = PHI(I,K) + DELTA(I) + ERKM2=SIGMA(K-1)*DDWNRM(NEQ,DELTA,VT,RPAR,IPAR) + TERKM2 = (K-1)*ERKM2 + IF(MAX(TERKM1,TERKM2).GT.TERK)GO TO 430 +C +C Lower the order +C +420 CONTINUE + KNEW=K-1 + EST = ERKM1 +C +C +C Calculate the local error for the current step +C to see if the step was successful +C +430 CONTINUE + ERR = CK * ENORM + IF(ERR .GT. 1.0D0)GO TO 600 +C +C +C +C +C +C----------------------------------------------------------------------- +C BLOCK 5 +C The step is successful. Determine +C the best order and stepsize for +C the next step. Update the differences +C for the next step. +C----------------------------------------------------------------------- + IDID=1 + IWM(LNST)=IWM(LNST)+1 + KDIFF=K-KOLD + KOLD=K + HOLD=H +C +C +C Estimate the error at order K+1 unless +C already decided to lower order, or +C already using maximum order, or +C stepsize not constant, or +C order raised in previous step +C + IF(KNEW.EQ.KM1.OR.K.EQ.IWM(LMXORD))IPHASE=1 + IF(IPHASE .EQ. 0)GO TO 545 + IF(KNEW.EQ.KM1)GO TO 540 + IF(K.EQ.IWM(LMXORD)) GO TO 550 + IF(KP1.GE.NS.OR.KDIFF.EQ.1)GO TO 550 + DO 510 I=1,NEQ +510 DELTA(I)=E(I)-PHI(I,KP2) + ERKP1 = (1.0D0/(K+2))*DDWNRM(NEQ,DELTA,VT,RPAR,IPAR) + TERKP1 = (K+2)*ERKP1 + IF(K.GT.1)GO TO 520 + IF(TERKP1.GE.0.5D0*TERK)GO TO 550 + GO TO 530 +520 IF(TERKM1.LE.MIN(TERK,TERKP1))GO TO 540 + IF(TERKP1.GE.TERK.OR.K.EQ.IWM(LMXORD))GO TO 550 +C +C Raise order +C +530 K=KP1 + EST = ERKP1 + GO TO 550 +C +C Lower order +C +540 K=KM1 + EST = ERKM1 + GO TO 550 +C +C If IPHASE = 0, increase order by one and multiply stepsize by +C factor two +C +545 K = KP1 + HNEW = H*2.0D0 + H = HNEW + GO TO 575 +C +C +C Determine the appropriate stepsize for +C the next step. +C +550 HNEW=H + TEMP2=K+1 + R=(2.0D0*EST+0.0001D0)**(-1.0D0/TEMP2) + IF(R .LT. 2.0D0) GO TO 555 + HNEW = 2.0D0*H + GO TO 560 +555 IF(R .GT. 1.0D0) GO TO 560 + R = MAX(0.5D0,MIN(0.9D0,R)) + HNEW = H*R +560 H=HNEW +C +C +C Update differences for next step +C +575 CONTINUE + IF(KOLD.EQ.IWM(LMXORD))GO TO 585 + DO 580 I=1,NEQ +580 PHI(I,KP2)=E(I) +585 CONTINUE + DO 590 I=1,NEQ +590 PHI(I,KP1)=PHI(I,KP1)+E(I) + DO 595 J1=2,KP1 + J=KP1-J1+1 + DO 595 I=1,NEQ +595 PHI(I,J)=PHI(I,J)+PHI(I,J+1) + JSTART = 1 + RETURN +C +C +C +C +C +C----------------------------------------------------------------------- +C BLOCK 6 +C The step is unsuccessful. Restore X,PSI,PHI +C Determine appropriate stepsize for +C continuing the integration, or exit with +C an error flag if there have been many +C failures. +C----------------------------------------------------------------------- +600 IPHASE = 1 +C +C Restore X,PHI,PSI +C + X=XOLD + IF(KP1.LT.NSP1)GO TO 630 + DO 620 J=NSP1,KP1 + TEMP1=1.0D0/BETA(J) + DO 610 I=1,NEQ +610 PHI(I,J)=TEMP1*PHI(I,J) +620 CONTINUE +630 CONTINUE + DO 640 I=2,KP1 +640 PSI(I-1)=PSI(I)-H +C +C +C Test whether failure is due to nonlinear solver +C or error test +C + IF(IERNLS .EQ. 0)GO TO 660 + IWM(LCFN)=IWM(LCFN)+1 +C +C +C The nonlinear solver failed to converge. +C Determine the cause of the failure and take appropriate action. +C If IERNLS .LT. 0, then return. Otherwise, reduce the stepsize +C and try again, unless too many failures have occurred. +C + IF (IERNLS .LT. 0) GO TO 675 + NCF = NCF + 1 + R = 0.25D0 + H = H*R + IF (NCF .LT. 10 .AND. ABS(H) .GE. HMIN) GO TO 690 + IF (IDID .EQ. 1) IDID = -7 + IF (NEF .GE. 3) IDID = -9 + GO TO 675 +C +C +C The nonlinear solver converged, and the cause +C of the failure was the error estimate +C exceeding the tolerance. +C +660 NEF=NEF+1 + IWM(LETF)=IWM(LETF)+1 + IF (NEF .GT. 1) GO TO 665 +C +C On first error test failure, keep current order or lower +C order by one. Compute new stepsize based on differences +C of the solution. +C + K = KNEW + TEMP2 = K + 1 + R = 0.90D0*(2.0D0*EST+0.0001D0)**(-1.0D0/TEMP2) + R = MAX(0.25D0,MIN(0.9D0,R)) + H = H*R + IF (ABS(H) .GE. HMIN) GO TO 690 + IDID = -6 + GO TO 675 +C +C On second error test failure, use the current order or +C decrease order by one. Reduce the stepsize by a factor of +C one quarter. +C +665 IF (NEF .GT. 2) GO TO 670 + K = KNEW + R = 0.25D0 + H = R*H + IF (ABS(H) .GE. HMIN) GO TO 690 + IDID = -6 + GO TO 675 +C +C On third and subsequent error test failures, set the order to +C one, and reduce the stepsize by a factor of one quarter. +C +670 K = 1 + R = 0.25D0 + H = R*H + IF (ABS(H) .GE. HMIN) GO TO 690 + IDID = -6 + GO TO 675 +C +C +C +C +C For all crashes, restore Y to its last value, +C interpolate to find YPRIME at last X, and return. +C +C Before returning, verify that the user has not set +C IDID to a nonnegative value. If the user has set IDID +C to a nonnegative value, then reset IDID to be -7, indicating +C a failure in the nonlinear system solver. +C +675 CONTINUE + CALL DDATRP(X,X,Y,YPRIME,NEQ,K,PHI,PSI) + JSTART = 1 + IF (IDID .GE. 0) IDID = -7 + RETURN +C +C +C Go back and try this step again. +C If this is the first step, reset PSI(1) and rescale PHI(*,2). +C +690 IF (KOLD .EQ. 0) THEN + PSI(1) = H + DO 695 I = 1,NEQ +695 PHI(I,2) = R*PHI(I,2) + ENDIF + GO TO 200 +C +C------END OF SUBROUTINE DDSTP------------------------------------------ + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/daspk/ddwnrm.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,37 @@ +C Work performed under the auspices of the U.S. Department of Energy +C by Lawrence Livermore National Laboratory under contract number +C W-7405-Eng-48. +C + DOUBLE PRECISION FUNCTION DDWNRM(NEQ,V,RWT,RPAR,IPAR) +C +C***BEGIN PROLOGUE DDWNRM +C***ROUTINES CALLED (NONE) +C***DATE WRITTEN 890101 (YYMMDD) +C***REVISION DATE 900926 (YYMMDD) +C***END PROLOGUE DDWNRM +C----------------------------------------------------------------------- +C This function routine computes the weighted +C root-mean-square norm of the vector of length +C NEQ contained in the array V, with reciprocal weights +C contained in the array RWT of length NEQ. +C DDWNRM=SQRT((1/NEQ)*SUM(V(I)*RWT(I))**2) +C----------------------------------------------------------------------- +C + IMPLICIT DOUBLE PRECISION(A-H,O-Z) + DIMENSION V(*),RWT(*) + DIMENSION RPAR(*),IPAR(*) + DDWNRM = 0.0D0 + VMAX = 0.0D0 + DO 10 I = 1,NEQ + IF(ABS(V(I)*RWT(I)) .GT. VMAX) VMAX = ABS(V(I)*RWT(I)) +10 CONTINUE + IF(VMAX .LE. 0.0D0) GO TO 30 + SUM = 0.0D0 + DO 20 I = 1,NEQ +20 SUM = SUM + ((V(I)*RWT(I))/VMAX)**2 + DDWNRM = VMAX*SQRT(SUM/NEQ) +30 CONTINUE + RETURN +C +C------END OF FUNCTION DDWNRM------------------------------------------- + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/daspk/dfnrmd.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,57 @@ +C Work performed under the auspices of the U.S. Department of Energy +C by Lawrence Livermore National Laboratory under contract number +C W-7405-Eng-48. +C + SUBROUTINE DFNRMD (NEQ, Y, T, YPRIME, R, CJ, WT, RES, IRES, + * FNORM, WM, IWM, RPAR, IPAR) +C +C***BEGIN PROLOGUE DFNRMD +C***REFER TO DLINSD +C***DATE WRITTEN 941025 (YYMMDD) +C +C +C----------------------------------------------------------------------- +C***DESCRIPTION +C +C DFNRMD calculates the scaled preconditioned norm of the nonlinear +C function used in the nonlinear iteration for obtaining consistent +C initial conditions. Specifically, DFNRMD calculates the weighted +C root-mean-square norm of the vector (J-inverse)*G(T,Y,YPRIME), +C where J is the Jacobian matrix. +C +C In addition to the parameters described in the calling program +C DLINSD, the parameters represent +C +C R -- Array of length NEQ that contains +C (J-inverse)*G(T,Y,YPRIME) on return. +C FNORM -- Scalar containing the weighted norm of R on return. +C----------------------------------------------------------------------- +C +C***ROUTINES CALLED +C RES, DSLVD, DDWNRM +C +C***END PROLOGUE DFNRMD +C +C + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + EXTERNAL RES + DIMENSION Y(*), YPRIME(*), WT(*), R(*) + DIMENSION WM(*),IWM(*), RPAR(*),IPAR(*) +C----------------------------------------------------------------------- +C Call RES routine. +C----------------------------------------------------------------------- + IRES = 0 + CALL RES(T,Y,YPRIME,CJ,R,IRES,RPAR,IPAR) + IF (IRES .LT. 0) RETURN +C----------------------------------------------------------------------- +C Apply inverse of Jacobian to vector R. +C----------------------------------------------------------------------- + CALL DSLVD(NEQ,R,WM,IWM) +C----------------------------------------------------------------------- +C Calculate norm of R. +C----------------------------------------------------------------------- + FNORM = DDWNRM(NEQ,R,WT,RPAR,IPAR) +C + RETURN +C----------------------- END OF SUBROUTINE DFNRMD ---------------------- + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/daspk/dfnrmk.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,70 @@ +C Work performed under the auspices of the U.S. Department of Energy +C by Lawrence Livermore National Laboratory under contract number +C W-7405-Eng-48. +C + SUBROUTINE DFNRMK (NEQ, Y, T, YPRIME, SAVR, R, CJ, WT, + * SQRTN, RSQRTN, RES, IRES, PSOL, IRIN, IER, + * FNORM, EPLIN, WP, IWP, PWK, RPAR, IPAR) +C +C***BEGIN PROLOGUE DFNRMK +C***REFER TO DLINSK +C***DATE WRITTEN 940830 (YYMMDD) +C***REVISION DATE 951006 (SQRTN, RSQRTN, and scaling of WT added.) +C +C +C----------------------------------------------------------------------- +C***DESCRIPTION +C +C DFNRMK calculates the scaled preconditioned norm of the nonlinear +C function used in the nonlinear iteration for obtaining consistent +C initial conditions. Specifically, DFNRMK calculates the weighted +C root-mean-square norm of the vector (P-inverse)*G(T,Y,YPRIME), +C where P is the preconditioner matrix. +C +C In addition to the parameters described in the calling program +C DLINSK, the parameters represent +C +C IRIN -- Flag showing whether the current residual vector is +C input in SAVR. 1 means it is, 0 means it is not. +C R -- Array of length NEQ that contains +C (P-inverse)*G(T,Y,YPRIME) on return. +C FNORM -- Scalar containing the weighted norm of R on return. +C----------------------------------------------------------------------- +C +C***ROUTINES CALLED +C RES, DCOPY, DSCAL, PSOL, DDWNRM +C +C***END PROLOGUE DFNRMK +C +C + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + EXTERNAL RES, PSOL + DIMENSION Y(*), YPRIME(*), WT(*), SAVR(*), R(*), PWK(*) + DIMENSION WP(*), IWP(*), RPAR(*), IPAR(*) +C----------------------------------------------------------------------- +C Call RES routine if IRIN = 0. +C----------------------------------------------------------------------- + IF (IRIN .EQ. 0) THEN + IRES = 0 + CALL RES (T, Y, YPRIME, CJ, SAVR, IRES, RPAR, IPAR) + IF (IRES .LT. 0) RETURN + ENDIF +C----------------------------------------------------------------------- +C Apply inverse of left preconditioner to vector R. +C First scale WT array by 1/sqrt(N), and undo scaling afterward. +C----------------------------------------------------------------------- + CALL DCOPY(NEQ, SAVR, 1, R, 1) + CALL DSCAL (NEQ, RSQRTN, WT, 1) + IER = 0 + CALL PSOL (NEQ, T, Y, YPRIME, SAVR, PWK, CJ, WT, WP, IWP, + * R, EPLIN, IER, RPAR, IPAR) + CALL DSCAL (NEQ, SQRTN, WT, 1) + IF (IER .NE. 0) RETURN +C----------------------------------------------------------------------- +C Calculate norm of R. +C----------------------------------------------------------------------- + FNORM = DDWNRM (NEQ, R, WT, RPAR, IPAR) +C + RETURN +C----------------------- END OF SUBROUTINE DFNRMK ---------------------- + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/daspk/dhels.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,88 @@ +C Work performed under the auspices of the U.S. Department of Energy +C by Lawrence Livermore National Laboratory under contract number +C W-7405-Eng-48. +C + SUBROUTINE DHELS (A, LDA, N, Q, B) +C +C***BEGIN PROLOGUE DHELS +C***DATE WRITTEN 890101 (YYMMDD) +C***REVISION DATE 900926 (YYMMDD) +C +C +C----------------------------------------------------------------------- +C***DESCRIPTION +C +C This is similar to the LINPACK routine DGESL except that +C A is an upper Hessenberg matrix. +C +C DHELS solves the least squares problem +C +C MIN (B-A*X,B-A*X) +C +C using the factors computed by DHEQR. +C +C On entry +C +C A DOUBLE PRECISION (LDA, N) +C The output from DHEQR which contains the upper +C triangular factor R in the QR decomposition of A. +C +C LDA INTEGER +C The leading dimension of the array A . +C +C N INTEGER +C A is originally an (N+1) by N matrix. +C +C Q DOUBLE PRECISION(2*N) +C The coefficients of the N givens rotations +C used in the QR factorization of A. +C +C B DOUBLE PRECISION(N+1) +C The right hand side vector. +C +C +C On return +C +C B The solution vector X. +C +C +C Modification of LINPACK. +C Peter Brown, Lawrence Livermore Natl. Lab. +C +C----------------------------------------------------------------------- +C***ROUTINES CALLED +C DAXPY +C +C***END PROLOGUE DHELS +C + INTEGER LDA, N + DOUBLE PRECISION A(LDA,*), B(*), Q(*) + INTEGER IQ, K, KB, KP1 + DOUBLE PRECISION C, S, T, T1, T2 +C +C Minimize (B-A*X,B-A*X). +C First form Q*B. +C + DO 20 K = 1, N + KP1 = K + 1 + IQ = 2*(K-1) + 1 + C = Q(IQ) + S = Q(IQ+1) + T1 = B(K) + T2 = B(KP1) + B(K) = C*T1 - S*T2 + B(KP1) = S*T1 + C*T2 + 20 CONTINUE +C +C Now solve R*X = Q*B. +C + DO 40 KB = 1, N + K = N + 1 - KB + B(K) = B(K)/A(K,K) + T = -B(K) + CALL DAXPY (K-1, T, A(1,K), 1, B(1), 1) + 40 CONTINUE + RETURN +C +C------END OF SUBROUTINE DHELS------------------------------------------ + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/daspk/dheqr.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,175 @@ +C Work performed under the auspices of the U.S. Department of Energy +C by Lawrence Livermore National Laboratory under contract number +C W-7405-Eng-48. +C + SUBROUTINE DHEQR (A, LDA, N, Q, INFO, IJOB) +C +C***BEGIN PROLOGUE DHEQR +C***DATE WRITTEN 890101 (YYMMDD) +C***REVISION DATE 900926 (YYMMDD) +C +C----------------------------------------------------------------------- +C***DESCRIPTION +C +C This routine performs a QR decomposition of an upper +C Hessenberg matrix A. There are two options available: +C +C (1) performing a fresh decomposition +C (2) updating the QR factors by adding a row and A +C column to the matrix A. +C +C DHEQR decomposes an upper Hessenberg matrix by using Givens +C rotations. +C +C On entry +C +C A DOUBLE PRECISION(LDA, N) +C The matrix to be decomposed. +C +C LDA INTEGER +C The leading dimension of the array A. +C +C N INTEGER +C A is an (N+1) by N Hessenberg matrix. +C +C IJOB INTEGER +C = 1 Means that a fresh decomposition of the +C matrix A is desired. +C .GE. 2 Means that the current decomposition of A +C will be updated by the addition of a row +C and a column. +C On return +C +C A The upper triangular matrix R. +C The factorization can be written Q*A = R, where +C Q is a product of Givens rotations and R is upper +C triangular. +C +C Q DOUBLE PRECISION(2*N) +C The factors C and S of each Givens rotation used +C in decomposing A. +C +C INFO INTEGER +C = 0 normal value. +C = K If A(K,K) .EQ. 0.0. This is not an error +C condition for this subroutine, but it does +C indicate that DHELS will divide by zero +C if called. +C +C Modification of LINPACK. +C Peter Brown, Lawrence Livermore Natl. Lab. +C +C----------------------------------------------------------------------- +C***ROUTINES CALLED (NONE) +C +C***END PROLOGUE DHEQR +C + INTEGER LDA, N, INFO, IJOB + DOUBLE PRECISION A(LDA,*), Q(*) + INTEGER I, IQ, J, K, KM1, KP1, NM1 + DOUBLE PRECISION C, S, T, T1, T2 +C + IF (IJOB .GT. 1) GO TO 70 +C----------------------------------------------------------------------- +C A new factorization is desired. +C----------------------------------------------------------------------- +C +C QR decomposition without pivoting. +C + INFO = 0 + DO 60 K = 1, N + KM1 = K - 1 + KP1 = K + 1 +C +C Compute Kth column of R. +C First, multiply the Kth column of A by the previous +C K-1 Givens rotations. +C + IF (KM1 .LT. 1) GO TO 20 + DO 10 J = 1, KM1 + I = 2*(J-1) + 1 + T1 = A(J,K) + T2 = A(J+1,K) + C = Q(I) + S = Q(I+1) + A(J,K) = C*T1 - S*T2 + A(J+1,K) = S*T1 + C*T2 + 10 CONTINUE +C +C Compute Givens components C and S. +C + 20 CONTINUE + IQ = 2*KM1 + 1 + T1 = A(K,K) + T2 = A(KP1,K) + IF (T2 .NE. 0.0D0) GO TO 30 + C = 1.0D0 + S = 0.0D0 + GO TO 50 + 30 CONTINUE + IF (ABS(T2) .LT. ABS(T1)) GO TO 40 + T = T1/T2 + S = -1.0D0/SQRT(1.0D0+T*T) + C = -S*T + GO TO 50 + 40 CONTINUE + T = T2/T1 + C = 1.0D0/SQRT(1.0D0+T*T) + S = -C*T + 50 CONTINUE + Q(IQ) = C + Q(IQ+1) = S + A(K,K) = C*T1 - S*T2 + IF (A(K,K) .EQ. 0.0D0) INFO = K + 60 CONTINUE + RETURN +C----------------------------------------------------------------------- +C The old factorization of A will be updated. A row and a column +C has been added to the matrix A. +C N by N-1 is now the old size of the matrix. +C----------------------------------------------------------------------- + 70 CONTINUE + NM1 = N - 1 +C----------------------------------------------------------------------- +C Multiply the new column by the N previous Givens rotations. +C----------------------------------------------------------------------- + DO 100 K = 1,NM1 + I = 2*(K-1) + 1 + T1 = A(K,N) + T2 = A(K+1,N) + C = Q(I) + S = Q(I+1) + A(K,N) = C*T1 - S*T2 + A(K+1,N) = S*T1 + C*T2 + 100 CONTINUE +C----------------------------------------------------------------------- +C Complete update of decomposition by forming last Givens rotation, +C and multiplying it times the column vector (A(N,N),A(NP1,N)). +C----------------------------------------------------------------------- + INFO = 0 + T1 = A(N,N) + T2 = A(N+1,N) + IF (T2 .NE. 0.0D0) GO TO 110 + C = 1.0D0 + S = 0.0D0 + GO TO 130 + 110 CONTINUE + IF (ABS(T2) .LT. ABS(T1)) GO TO 120 + T = T1/T2 + S = -1.0D0/SQRT(1.0D0+T*T) + C = -S*T + GO TO 130 + 120 CONTINUE + T = T2/T1 + C = 1.0D0/SQRT(1.0D0+T*T) + S = -C*T + 130 CONTINUE + IQ = 2*N - 1 + Q(IQ) = C + Q(IQ+1) = S + A(N,N) = C*T1 - S*T2 + IF (A(N,N) .EQ. 0.0D0) INFO = N + RETURN +C +C------END OF SUBROUTINE DHEQR------------------------------------------ + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/daspk/dinvwt.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,36 @@ +C Work performed under the auspices of the U.S. Department of Energy +C by Lawrence Livermore National Laboratory under contract number +C W-7405-Eng-48. +C + SUBROUTINE DINVWT(NEQ,WT,IER) +C +C***BEGIN PROLOGUE DINVWT +C***REFER TO DDASPK +C***ROUTINES CALLED (NONE) +C***DATE WRITTEN 950125 (YYMMDD) +C***END PROLOGUE DINVWT +C----------------------------------------------------------------------- +C This subroutine checks the error weight vector WT, of length NEQ, +C for components that are .le. 0, and if none are found, it +C inverts the WT(I) in place. This replaces division operations +C with multiplications in all norm evaluations. +C IER is returned as 0 if all WT(I) were found positive, +C and the first I with WT(I) .le. 0.0 otherwise. +C----------------------------------------------------------------------- +C + IMPLICIT DOUBLE PRECISION(A-H,O-Z) + DIMENSION WT(*) +C + DO 10 I = 1,NEQ + IF (WT(I) .LE. 0.0D0) GO TO 30 + 10 CONTINUE + DO 20 I = 1,NEQ + 20 WT(I) = 1.0D0/WT(I) + IER = 0 + RETURN +C + 30 IER = I + RETURN +C +C------END OF SUBROUTINE DINVWT----------------------------------------- + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/daspk/dlinsd.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,182 @@ +C Work performed under the auspices of the U.S. Department of Energy +C by Lawrence Livermore National Laboratory under contract number +C W-7405-Eng-48. +C + SUBROUTINE DLINSD (NEQ, Y, T, YPRIME, CJ, P, PNRM, WT, LSOFF, + * STPTOL, IRET, RES, IRES, WM, IWM, + * FNRM, ICOPT, ID, R, YNEW, YPNEW, ICNFLG, + * ICNSTR, RLX, RPAR, IPAR) +C +C***BEGIN PROLOGUE DLINSD +C***REFER TO DNSID +C***DATE WRITTEN 941025 (YYMMDD) +C***REVISION DATE 941215 (YYMMDD) +C***REVISION DATE 960129 Moved line RL = ONE to top block. +C +C +C----------------------------------------------------------------------- +C***DESCRIPTION +C +C DLINSD uses a linesearch algorithm to calculate a new (Y,YPRIME) +C pair (YNEW,YPNEW) such that +C +C f(YNEW,YPNEW) .le. (1 - 2*ALPHA*RL)*f(Y,YPRIME) , +C +C where 0 < RL <= 1. Here, f(y,y') is defined as +C +C f(y,y') = (1/2)*norm( (J-inverse)*G(t,y,y') )**2 , +C +C where norm() is the weighted RMS vector norm, G is the DAE +C system residual function, and J is the system iteration matrix +C (Jacobian). +C +C In addition to the parameters defined elsewhere, we have +C +C P -- Approximate Newton step used in backtracking. +C PNRM -- Weighted RMS norm of P. +C LSOFF -- Flag showing whether the linesearch algorithm is +C to be invoked. 0 means do the linesearch, and +C 1 means turn off linesearch. +C STPTOL -- Tolerance used in calculating the minimum lambda +C value allowed. +C ICNFLG -- Integer scalar. If nonzero, then constraint violations +C in the proposed new approximate solution will be +C checked for, and the maximum step length will be +C adjusted accordingly. +C ICNSTR -- Integer array of length NEQ containing flags for +C checking constraints. +C RLX -- Real scalar restricting update size in DCNSTR. +C YNEW -- Array of length NEQ used to hold the new Y in +C performing the linesearch. +C YPNEW -- Array of length NEQ used to hold the new YPRIME in +C performing the linesearch. +C Y -- Array of length NEQ containing the new Y (i.e.,=YNEW). +C YPRIME -- Array of length NEQ containing the new YPRIME +C (i.e.,=YPNEW). +C FNRM -- Real scalar containing SQRT(2*f(Y,YPRIME)) for the +C current (Y,YPRIME) on input and output. +C R -- Work array of length NEQ, containing the scaled +C residual (J-inverse)*G(t,y,y') on return. +C IRET -- Return flag. +C IRET=0 means that a satisfactory (Y,YPRIME) was found. +C IRET=1 means that the routine failed to find a new +C (Y,YPRIME) that was sufficiently distinct from +C the current (Y,YPRIME) pair. +C IRET=2 means IRES .ne. 0 from RES. +C----------------------------------------------------------------------- +C +C***ROUTINES CALLED +C DFNRMD, DYYPNW, DCOPY +C +C***END PROLOGUE DLINSD +C + IMPLICIT DOUBLE PRECISION(A-H,O-Z) + EXTERNAL RES + DIMENSION Y(*), YPRIME(*), WT(*), R(*), ID(*) + DIMENSION WM(*), IWM(*) + DIMENSION YNEW(*), YPNEW(*), P(*), ICNSTR(*) + DIMENSION RPAR(*), IPAR(*) + CHARACTER MSG*80 +C + PARAMETER (LNRE=12, LKPRIN=31) +C + SAVE ALPHA, ONE, TWO + DATA ALPHA/1.0D-4/, ONE/1.0D0/, TWO/2.0D0/ +C + KPRIN=IWM(LKPRIN) +C + F1NRM = (FNRM*FNRM)/TWO + RATIO = ONE + IF (KPRIN .GE. 2) THEN + MSG = '------ IN ROUTINE DLINSD-- PNRM = (R1) )' + CALL XERRWD(MSG, 40, 901, 0, 0, 0, 0, 1, PNRM, 0.0D0) + ENDIF + TAU = PNRM + IVIO = 0 + RL = ONE +C----------------------------------------------------------------------- +C Check for violations of the constraints, if any are imposed. +C If any violations are found, the step vector P is rescaled, and the +C constraint check is repeated, until no violations are found. +C----------------------------------------------------------------------- + IF (ICNFLG .NE. 0) THEN + 10 CONTINUE + CALL DYYPNW (NEQ,Y,YPRIME,CJ,RL,P,ICOPT,ID,YNEW,YPNEW) + CALL DCNSTR (NEQ, Y, YNEW, ICNSTR, TAU, RLX, IRET, IVAR) + IF (IRET .EQ. 1) THEN + IVIO = 1 + RATIO1 = TAU/PNRM + RATIO = RATIO*RATIO1 + DO 20 I = 1,NEQ + 20 P(I) = P(I)*RATIO1 + PNRM = TAU + IF (KPRIN .GE. 2) THEN + MSG = '------ CONSTRAINT VIOL., PNRM = (R1), INDEX = (I1)' + CALL XERRWD(MSG, 50, 902, 0, 1, IVAR, 0, 1, PNRM, 0.0D0) + ENDIF + IF (PNRM .LE. STPTOL) THEN + IRET = 1 + RETURN + ENDIF + GO TO 10 + ENDIF + ENDIF +C + SLPI = (-TWO*F1NRM)*RATIO + RLMIN = STPTOL/PNRM + IF (LSOFF .EQ. 0 .AND. KPRIN .GE. 2) THEN + MSG = '------ MIN. LAMBDA = (R1)' + CALL XERRWD(MSG, 25, 903, 0, 0, 0, 0, 1, RLMIN, 0.0D0) + ENDIF +C----------------------------------------------------------------------- +C Begin iteration to find RL value satisfying alpha-condition. +C If RL becomes less than RLMIN, then terminate with IRET = 1. +C----------------------------------------------------------------------- + 100 CONTINUE + CALL DYYPNW (NEQ,Y,YPRIME,CJ,RL,P,ICOPT,ID,YNEW,YPNEW) + CALL DFNRMD (NEQ, YNEW, T, YPNEW, R, CJ, WT, RES, IRES, + * FNRMP, WM, IWM, RPAR, IPAR) + IWM(LNRE) = IWM(LNRE) + 1 + IF (IRES .NE. 0) THEN + IRET = 2 + RETURN + ENDIF + IF (LSOFF .EQ. 1) GO TO 150 +C + F1NRMP = FNRMP*FNRMP/TWO + IF (KPRIN .GE. 2) THEN + MSG = '------ LAMBDA = (R1)' + CALL XERRWD(MSG, 20, 904, 0, 0, 0, 0, 1, RL, 0.0D0) + MSG = '------ NORM(F1) = (R1), NORM(F1NEW) = (R2)' + CALL XERRWD(MSG, 43, 905, 0, 0, 0, 0, 2, F1NRM, F1NRMP) + ENDIF + IF (F1NRMP .GT. F1NRM + ALPHA*SLPI*RL) GO TO 200 +C----------------------------------------------------------------------- +C Alpha-condition is satisfied, or linesearch is turned off. +C Copy YNEW,YPNEW to Y,YPRIME and return. +C----------------------------------------------------------------------- + 150 IRET = 0 + CALL DCOPY (NEQ, YNEW, 1, Y, 1) + CALL DCOPY (NEQ, YPNEW, 1, YPRIME, 1) + FNRM = FNRMP + IF (KPRIN .GE. 1) THEN + MSG = '------ LEAVING ROUTINE DLINSD, FNRM = (R1)' + CALL XERRWD(MSG, 42, 906, 0, 0, 0, 0, 1, FNRM, 0.0D0) + ENDIF + RETURN +C----------------------------------------------------------------------- +C Alpha-condition not satisfied. Perform backtrack to compute new RL +C value. If no satisfactory YNEW,YPNEW can be found sufficiently +C distinct from Y,YPRIME, then return IRET = 1. +C----------------------------------------------------------------------- + 200 CONTINUE + IF (RL .LT. RLMIN) THEN + IRET = 1 + RETURN + ENDIF +C + RL = RL/TWO + GO TO 100 +C +C----------------------- END OF SUBROUTINE DLINSD ---------------------- + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/daspk/dlinsk.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,189 @@ +C Work performed under the auspices of the U.S. Department of Energy +C by Lawrence Livermore National Laboratory under contract number +C W-7405-Eng-48. +C + SUBROUTINE DLINSK (NEQ, Y, T, YPRIME, SAVR, CJ, P, PNRM, WT, + * SQRTN, RSQRTN, LSOFF, STPTOL, IRET, RES, IRES, PSOL, WM, IWM, + * RHOK, FNRM, ICOPT, ID, WP, IWP, R, EPLIN, YNEW, YPNEW, PWK, + * ICNFLG, ICNSTR, RLX, RPAR, IPAR) +C +C***BEGIN PROLOGUE DLINSK +C***REFER TO DNSIK +C***DATE WRITTEN 940830 (YYMMDD) +C***REVISION DATE 951006 (Arguments SQRTN, RSQRTN added.) +C***REVISION DATE 960129 Moved line RL = ONE to top block. +C +C +C----------------------------------------------------------------------- +C***DESCRIPTION +C +C DLINSK uses a linesearch algorithm to calculate a new (Y,YPRIME) +C pair (YNEW,YPNEW) such that +C +C f(YNEW,YPNEW) .le. (1 - 2*ALPHA*RL)*f(Y,YPRIME) + +C ALPHA*RL*RHOK*RHOK , +C +C where 0 < RL <= 1, and RHOK is the scaled preconditioned norm of +C the final residual vector in the Krylov iteration. +C Here, f(y,y') is defined as +C +C f(y,y') = (1/2)*norm( (P-inverse)*G(t,y,y') )**2 , +C +C where norm() is the weighted RMS vector norm, G is the DAE +C system residual function, and P is the preconditioner used +C in the Krylov iteration. +C +C In addition to the parameters defined elsewhere, we have +C +C SAVR -- Work array of length NEQ, containing the residual +C vector G(t,y,y') on return. +C P -- Approximate Newton step used in backtracking. +C PNRM -- Weighted RMS norm of P. +C LSOFF -- Flag showing whether the linesearch algorithm is +C to be invoked. 0 means do the linesearch, +C 1 means turn off linesearch. +C STPTOL -- Tolerance used in calculating the minimum lambda +C value allowed. +C ICNFLG -- Integer scalar. If nonzero, then constraint violations +C in the proposed new approximate solution will be +C checked for, and the maximum step length will be +C adjusted accordingly. +C ICNSTR -- Integer array of length NEQ containing flags for +C checking constraints. +C RHOK -- Weighted norm of preconditioned Krylov residual. +C RLX -- Real scalar restricting update size in DCNSTR. +C YNEW -- Array of length NEQ used to hold the new Y in +C performing the linesearch. +C YPNEW -- Array of length NEQ used to hold the new YPRIME in +C performing the linesearch. +C PWK -- Work vector of length NEQ for use in PSOL. +C Y -- Array of length NEQ containing the new Y (i.e.,=YNEW). +C YPRIME -- Array of length NEQ containing the new YPRIME +C (i.e.,=YPNEW). +C FNRM -- Real scalar containing SQRT(2*f(Y,YPRIME)) for the +C current (Y,YPRIME) on input and output. +C R -- Work space length NEQ for residual vector. +C IRET -- Return flag. +C IRET=0 means that a satisfactory (Y,YPRIME) was found. +C IRET=1 means that the routine failed to find a new +C (Y,YPRIME) that was sufficiently distinct from +C the current (Y,YPRIME) pair. +C IRET=2 means a failure in RES or PSOL. +C----------------------------------------------------------------------- +C +C***ROUTINES CALLED +C DFNRMK, DYYPNW, DCOPY +C +C***END PROLOGUE DLINSK +C + IMPLICIT DOUBLE PRECISION(A-H,O-Z) + EXTERNAL RES, PSOL + DIMENSION Y(*), YPRIME(*), P(*), WT(*), SAVR(*), R(*), ID(*) + DIMENSION WM(*), IWM(*), YNEW(*), YPNEW(*), PWK(*), ICNSTR(*) + DIMENSION WP(*), IWP(*), RPAR(*), IPAR(*) + CHARACTER MSG*80 +C + PARAMETER (LNRE=12, LNPS=21, LKPRIN=31) +C + SAVE ALPHA, ONE, TWO + DATA ALPHA/1.0D-4/, ONE/1.0D0/, TWO/2.0D0/ +C + KPRIN=IWM(LKPRIN) + F1NRM = (FNRM*FNRM)/TWO + RATIO = ONE +C + IF (KPRIN .GE. 2) THEN + MSG = '------ IN ROUTINE DLINSK-- PNRM = (R1) )' + CALL XERRWD(MSG, 40, 921, 0, 0, 0, 0, 1, PNRM, 0.0D0) + ENDIF + TAU = PNRM + IVIO = 0 + RL = ONE +C----------------------------------------------------------------------- +C Check for violations of the constraints, if any are imposed. +C If any violations are found, the step vector P is rescaled, and the +C constraint check is repeated, until no violations are found. +C----------------------------------------------------------------------- + IF (ICNFLG .NE. 0) THEN + 10 CONTINUE + CALL DYYPNW (NEQ,Y,YPRIME,CJ,RL,P,ICOPT,ID,YNEW,YPNEW) + CALL DCNSTR (NEQ, Y, YNEW, ICNSTR, TAU, RLX, IRET, IVAR) + IF (IRET .EQ. 1) THEN + IVIO = 1 + RATIO1 = TAU/PNRM + RATIO = RATIO*RATIO1 + DO 20 I = 1,NEQ + 20 P(I) = P(I)*RATIO1 + PNRM = TAU + IF (KPRIN .GE. 2) THEN + MSG = '------ CONSTRAINT VIOL., PNRM = (R1), INDEX = (I1)' + CALL XERRWD(MSG, 50, 922, 0, 1, IVAR, 0, 1, PNRM, 0.0D0) + ENDIF + IF (PNRM .LE. STPTOL) THEN + IRET = 1 + RETURN + ENDIF + GO TO 10 + ENDIF + ENDIF +C + SLPI = (-TWO*F1NRM + RHOK*RHOK)*RATIO + RLMIN = STPTOL/PNRM + IF (LSOFF .EQ. 0 .AND. KPRIN .GE. 2) THEN + MSG = '------ MIN. LAMBDA = (R1)' + CALL XERRWD(MSG, 25, 923, 0, 0, 0, 0, 1, RLMIN, 0.0D0) + ENDIF +C----------------------------------------------------------------------- +C Begin iteration to find RL value satisfying alpha-condition. +C Update YNEW and YPNEW, then compute norm of new scaled residual and +C perform alpha condition test. +C----------------------------------------------------------------------- + 100 CONTINUE + CALL DYYPNW (NEQ,Y,YPRIME,CJ,RL,P,ICOPT,ID,YNEW,YPNEW) + CALL DFNRMK (NEQ, YNEW, T, YPNEW, SAVR, R, CJ, WT, SQRTN, RSQRTN, + * RES, IRES, PSOL, 0, IER, FNRMP, EPLIN, WP, IWP, PWK, RPAR, IPAR) + IWM(LNRE) = IWM(LNRE) + 1 + IF (IRES .GE. 0) IWM(LNPS) = IWM(LNPS) + 1 + IF (IRES .NE. 0 .OR. IER .NE. 0) THEN + IRET = 2 + RETURN + ENDIF + IF (LSOFF .EQ. 1) GO TO 150 +C + F1NRMP = FNRMP*FNRMP/TWO + IF (KPRIN .GE. 2) THEN + MSG = '------ LAMBDA = (R1)' + CALL XERRWD(MSG, 20, 924, 0, 0, 0, 0, 1, RL, 0.0D0) + MSG = '------ NORM(F1) = (R1), NORM(F1NEW) = (R2)' + CALL XERRWD(MSG, 43, 925, 0, 0, 0, 0, 2, F1NRM, F1NRMP) + ENDIF + IF (F1NRMP .GT. F1NRM + ALPHA*SLPI*RL) GO TO 200 +C----------------------------------------------------------------------- +C Alpha-condition is satisfied, or linesearch is turned off. +C Copy YNEW,YPNEW to Y,YPRIME and return. +C----------------------------------------------------------------------- + 150 IRET = 0 + CALL DCOPY(NEQ, YNEW, 1, Y, 1) + CALL DCOPY(NEQ, YPNEW, 1, YPRIME, 1) + FNRM = FNRMP + IF (KPRIN .GE. 1) THEN + MSG = '------ LEAVING ROUTINE DLINSK, FNRM = (R1)' + CALL XERRWD(MSG, 42, 926, 0, 0, 0, 0, 1, FNRM, 0.0D0) + ENDIF + RETURN +C----------------------------------------------------------------------- +C Alpha-condition not satisfied. Perform backtrack to compute new RL +C value. If RL is less than RLMIN, i.e. no satisfactory YNEW,YPNEW can +C be found sufficiently distinct from Y,YPRIME, then return IRET = 1. +C----------------------------------------------------------------------- + 200 CONTINUE + IF (RL .LT. RLMIN) THEN + IRET = 1 + RETURN + ENDIF +C + RL = RL/TWO + GO TO 100 +C +C----------------------- END OF SUBROUTINE DLINSK ---------------------- + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/daspk/dmatd.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,183 @@ +C Work performed under the auspices of the U.S. Department of Energy +C by Lawrence Livermore National Laboratory under contract number +C W-7405-Eng-48. +C + SUBROUTINE DMATD(NEQ,X,Y,YPRIME,DELTA,CJ,H,IER,EWT,E, + * WM,IWM,RES,IRES,UROUND,JACD,RPAR,IPAR) +C +C***BEGIN PROLOGUE DMATD +C***REFER TO DDASPK +C***DATE WRITTEN 890101 (YYMMDD) +C***REVISION DATE 900926 (YYMMDD) +C***REVISION DATE 940701 (YYMMDD) (new LIPVT) +C +C----------------------------------------------------------------------- +C***DESCRIPTION +C +C This routine computes the iteration matrix +C J = dG/dY+CJ*dG/dYPRIME (where G(X,Y,YPRIME)=0). +C Here J is computed by: +C the user-supplied routine JACD if IWM(MTYPE) is 1 or 4, or +C by numerical difference quotients if IWM(MTYPE) is 2 or 5. +C +C The parameters have the following meanings. +C X = Independent variable. +C Y = Array containing predicted values. +C YPRIME = Array containing predicted derivatives. +C DELTA = Residual evaluated at (X,Y,YPRIME). +C (Used only if IWM(MTYPE)=2 or 5). +C CJ = Scalar parameter defining iteration matrix. +C H = Current stepsize in integration. +C IER = Variable which is .NE. 0 if iteration matrix +C is singular, and 0 otherwise. +C EWT = Vector of error weights for computing norms. +C E = Work space (temporary) of length NEQ. +C WM = Real work space for matrices. On output +C it contains the LU decomposition +C of the iteration matrix. +C IWM = Integer work space containing +C matrix information. +C RES = External user-supplied subroutine +C to evaluate the residual. See RES description +C in DDASPK prologue. +C IRES = Flag which is equal to zero if no illegal values +C in RES, and less than zero otherwise. (If IRES +C is less than zero, the matrix was not completed). +C In this case (if IRES .LT. 0), then IER = 0. +C UROUND = The unit roundoff error of the machine being used. +C JACD = Name of the external user-supplied routine +C to evaluate the iteration matrix. (This routine +C is only used if IWM(MTYPE) is 1 or 4) +C See JAC description for the case INFO(12) = 0 +C in DDASPK prologue. +C RPAR,IPAR= Real and integer parameter arrays that +C are used for communication between the +C calling program and external user routines. +C They are not altered by DMATD. +C----------------------------------------------------------------------- +C***ROUTINES CALLED +C JACD, RES, DGETRF, DGBTRF +C +C***END PROLOGUE DMATD +C +C + IMPLICIT DOUBLE PRECISION(A-H,O-Z) + DIMENSION Y(*),YPRIME(*),DELTA(*),EWT(*),E(*) + DIMENSION WM(*),IWM(*), RPAR(*),IPAR(*) + EXTERNAL RES, JACD +C + PARAMETER (LML=1, LMU=2, LMTYPE=4, LNRE=12, LNPD=22, LLCIWP=30) +C + LIPVT = IWM(LLCIWP) + IER = 0 + MTYPE=IWM(LMTYPE) + GO TO (100,200,300,400,500),MTYPE +C +C +C Dense user-supplied matrix. +C +100 LENPD=IWM(LNPD) + DO 110 I=1,LENPD +110 WM(I)=0.0D0 + CALL JACD(X,Y,YPRIME,WM,CJ,RPAR,IPAR) + GO TO 230 +C +C +C Dense finite-difference-generated matrix. +C +200 IRES=0 + NROW=0 + SQUR = SQRT(UROUND) + DO 210 I=1,NEQ + DEL=SQUR*MAX(ABS(Y(I)),ABS(H*YPRIME(I)), + * ABS(1.D0/EWT(I))) + DEL=SIGN(DEL,H*YPRIME(I)) + DEL=(Y(I)+DEL)-Y(I) + YSAVE=Y(I) + YPSAVE=YPRIME(I) + Y(I)=Y(I)+DEL + YPRIME(I)=YPRIME(I)+CJ*DEL + IWM(LNRE)=IWM(LNRE)+1 + CALL RES(X,Y,YPRIME,CJ,E,IRES,RPAR,IPAR) + IF (IRES .LT. 0) RETURN + DELINV=1.0D0/DEL + DO 220 L=1,NEQ +220 WM(NROW+L)=(E(L)-DELTA(L))*DELINV + NROW=NROW+NEQ + Y(I)=YSAVE + YPRIME(I)=YPSAVE +210 CONTINUE +C +C +C Do dense-matrix LU decomposition on J. +C +230 CALL DGETRF( NEQ, NEQ, WM, NEQ, IWM(LIPVT), IER) + RETURN +C +C +C Dummy section for IWM(MTYPE)=3. +C +300 RETURN +C +C +C Banded user-supplied matrix. +C +400 LENPD=IWM(LNPD) + DO 410 I=1,LENPD +410 WM(I)=0.0D0 + CALL JACD(X,Y,YPRIME,WM,CJ,RPAR,IPAR) + MEBAND=2*IWM(LML)+IWM(LMU)+1 + GO TO 550 +C +C +C Banded finite-difference-generated matrix. +C +500 MBAND=IWM(LML)+IWM(LMU)+1 + MBA=MIN0(MBAND,NEQ) + MEBAND=MBAND+IWM(LML) + MEB1=MEBAND-1 + MSAVE=(NEQ/MBAND)+1 + ISAVE=IWM(LNPD) + IPSAVE=ISAVE+MSAVE + IRES=0 + SQUR=SQRT(UROUND) + DO 540 J=1,MBA + DO 510 N=J,NEQ,MBAND + K= (N-J)/MBAND + 1 + WM(ISAVE+K)=Y(N) + WM(IPSAVE+K)=YPRIME(N) + DEL=SQUR*MAX(ABS(Y(N)),ABS(H*YPRIME(N)), + * ABS(1.D0/EWT(N))) + DEL=SIGN(DEL,H*YPRIME(N)) + DEL=(Y(N)+DEL)-Y(N) + Y(N)=Y(N)+DEL +510 YPRIME(N)=YPRIME(N)+CJ*DEL + IWM(LNRE)=IWM(LNRE)+1 + CALL RES(X,Y,YPRIME,CJ,E,IRES,RPAR,IPAR) + IF (IRES .LT. 0) RETURN + DO 530 N=J,NEQ,MBAND + K= (N-J)/MBAND + 1 + Y(N)=WM(ISAVE+K) + YPRIME(N)=WM(IPSAVE+K) + DEL=SQUR*MAX(ABS(Y(N)),ABS(H*YPRIME(N)), + * ABS(1.D0/EWT(N))) + DEL=SIGN(DEL,H*YPRIME(N)) + DEL=(Y(N)+DEL)-Y(N) + DELINV=1.0D0/DEL + I1=MAX0(1,(N-IWM(LMU))) + I2=MIN0(NEQ,(N+IWM(LML))) + II=N*MEB1-IWM(LML) + DO 520 I=I1,I2 +520 WM(II+I)=(E(I)-DELTA(I))*DELINV +530 CONTINUE +540 CONTINUE +C +C +C Do LU decomposition of banded J. +C +550 CALL DGBTRF(NEQ, NEQ, IWM(LML), IWM(LMU), WM, MEBAND, + * IWM(LIPVT), IER) + RETURN +C +C------END OF SUBROUTINE DMATD------------------------------------------ + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/daspk/dnedd.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,270 @@ +C Work performed under the auspices of the U.S. Department of Energy +C by Lawrence Livermore National Laboratory under contract number +C W-7405-Eng-48. +C + SUBROUTINE DNEDD(X,Y,YPRIME,NEQ,RES,JACD,PDUM,H,WT, + * JSTART,IDID,RPAR,IPAR,PHI,GAMMA,DUMSVR,DELTA,E, + * WM,IWM,CJ,CJOLD,CJLAST,S,UROUND,DUME,DUMS,DUMR, + * EPCON,JCALC,JFDUM,KP1,NONNEG,NTYPE,IERNLS) +C +C***BEGIN PROLOGUE DNEDD +C***REFER TO DDASPK +C***DATE WRITTEN 891219 (YYMMDD) +C***REVISION DATE 900926 (YYMMDD) +C +C +C----------------------------------------------------------------------- +C***DESCRIPTION +C +C DNEDD solves a nonlinear system of +C algebraic equations of the form +C G(X,Y,YPRIME) = 0 for the unknown Y. +C +C The method used is a modified Newton scheme. +C +C The parameters represent +C +C X -- Independent variable. +C Y -- Solution vector. +C YPRIME -- Derivative of solution vector. +C NEQ -- Number of unknowns. +C RES -- External user-supplied subroutine +C to evaluate the residual. See RES description +C in DDASPK prologue. +C JACD -- External user-supplied routine to evaluate the +C Jacobian. See JAC description for the case +C INFO(12) = 0 in the DDASPK prologue. +C PDUM -- Dummy argument. +C H -- Appropriate step size for next step. +C WT -- Vector of weights for error criterion. +C JSTART -- Indicates first call to this routine. +C If JSTART = 0, then this is the first call, +C otherwise it is not. +C IDID -- Completion flag, output by DNEDD. +C See IDID description in DDASPK prologue. +C RPAR,IPAR -- Real and integer arrays used for communication +C between the calling program and external user +C routines. They are not altered within DASPK. +C PHI -- Array of divided differences used by +C DNEDD. The length is NEQ*(K+1),where +C K is the maximum order. +C GAMMA -- Array used to predict Y and YPRIME. The length +C is MAXORD+1 where MAXORD is the maximum order. +C DUMSVR -- Dummy argument. +C DELTA -- Work vector for NLS of length NEQ. +C E -- Error accumulation vector for NLS of length NEQ. +C WM,IWM -- Real and integer arrays storing +C matrix information such as the matrix +C of partial derivatives, permutation +C vector, and various other information. +C CJ -- Parameter always proportional to 1/H. +C CJOLD -- Saves the value of CJ as of the last call to DMATD. +C Accounts for changes in CJ needed to +C decide whether to call DMATD. +C CJLAST -- Previous value of CJ. +C S -- A scalar determined by the approximate rate +C of convergence of the Newton iteration and used +C in the convergence test for the Newton iteration. +C +C If RATE is defined to be an estimate of the +C rate of convergence of the Newton iteration, +C then S = RATE/(1.D0-RATE). +C +C The closer RATE is to 0., the faster the Newton +C iteration is converging; the closer RATE is to 1., +C the slower the Newton iteration is converging. +C +C On the first Newton iteration with an up-dated +C preconditioner S = 100.D0, Thus the initial +C RATE of convergence is approximately 1. +C +C S is preserved from call to call so that the rate +C estimate from a previous step can be applied to +C the current step. +C UROUND -- Unit roundoff. +C DUME -- Dummy argument. +C DUMS -- Dummy argument. +C DUMR -- Dummy argument. +C EPCON -- Tolerance to test for convergence of the Newton +C iteration. +C JCALC -- Flag used to determine when to update +C the Jacobian matrix. In general: +C +C JCALC = -1 ==> Call the DMATD routine to update +C the Jacobian matrix. +C JCALC = 0 ==> Jacobian matrix is up-to-date. +C JCALC = 1 ==> Jacobian matrix is out-dated, +C but DMATD will not be called unless +C JCALC is set to -1. +C JFDUM -- Dummy argument. +C KP1 -- The current order(K) + 1; updated across calls. +C NONNEG -- Flag to determine nonnegativity constraints. +C NTYPE -- Identification code for the NLS routine. +C 0 ==> modified Newton; direct solver. +C IERNLS -- Error flag for nonlinear solver. +C 0 ==> nonlinear solver converged. +C 1 ==> recoverable error inside nonlinear solver. +C -1 ==> unrecoverable error inside nonlinear solver. +C +C All variables with "DUM" in their names are dummy variables +C which are not used in this routine. +C +C Following is a list and description of local variables which +C may not have an obvious usage. They are listed in roughly the +C order they occur in this subroutine. +C +C The following group of variables are passed as arguments to +C the Newton iteration solver. They are explained in greater detail +C in DNSD: +C TOLNEW, MULDEL, MAXIT, IERNEW +C +C IERTYP -- Flag which tells whether this subroutine is correct. +C 0 ==> correct subroutine. +C 1 ==> incorrect subroutine. +C +C----------------------------------------------------------------------- +C***ROUTINES CALLED +C DDWNRM, RES, DMATD, DNSD +C +C***END PROLOGUE DNEDD +C +C + IMPLICIT DOUBLE PRECISION(A-H,O-Z) + DIMENSION Y(*),YPRIME(*),WT(*) + DIMENSION DELTA(*),E(*) + DIMENSION WM(*),IWM(*), RPAR(*),IPAR(*) + DIMENSION PHI(NEQ,*),GAMMA(*) + EXTERNAL RES, JACD +C + PARAMETER (LNRE=12, LNJE=13) +C + SAVE MULDEL, MAXIT, XRATE + DATA MULDEL/1/, MAXIT/4/, XRATE/0.25D0/ +C +C Verify that this is the correct subroutine. +C + IERTYP = 0 + IF (NTYPE .NE. 0) THEN + IERTYP = 1 + GO TO 380 + ENDIF +C +C If this is the first step, perform initializations. +C + IF (JSTART .EQ. 0) THEN + CJOLD = CJ + JCALC = -1 + ENDIF +C +C Perform all other initializations. +C + IERNLS = 0 +C +C Decide whether new Jacobian is needed. +C + TEMP1 = (1.0D0 - XRATE)/(1.0D0 + XRATE) + TEMP2 = 1.0D0/TEMP1 + IF (CJ/CJOLD .LT. TEMP1 .OR. CJ/CJOLD .GT. TEMP2) JCALC = -1 + IF (CJ .NE. CJLAST) S = 100.D0 +C +C----------------------------------------------------------------------- +C Entry point for updating the Jacobian with current +C stepsize. +C----------------------------------------------------------------------- +300 CONTINUE +C +C Initialize all error flags to zero. +C + IERJ = 0 + IRES = 0 + IERNEW = 0 +C +C Predict the solution and derivative and compute the tolerance +C for the Newton iteration. +C + DO 310 I=1,NEQ + Y(I)=PHI(I,1) +310 YPRIME(I)=0.0D0 + DO 330 J=2,KP1 + DO 320 I=1,NEQ + Y(I)=Y(I)+PHI(I,J) +320 YPRIME(I)=YPRIME(I)+GAMMA(J)*PHI(I,J) +330 CONTINUE + PNORM = DDWNRM (NEQ,Y,WT,RPAR,IPAR) + TOLNEW = 100.D0*UROUND*PNORM +C +C Call RES to initialize DELTA. +C + IWM(LNRE)=IWM(LNRE)+1 + CALL RES(X,Y,YPRIME,CJ,DELTA,IRES,RPAR,IPAR) + IF (IRES .LT. 0) GO TO 380 +C +C If indicated, reevaluate the iteration matrix +C J = dG/dY + CJ*dG/dYPRIME (where G(X,Y,YPRIME)=0). +C Set JCALC to 0 as an indicator that this has been done. +C + IF(JCALC .EQ. -1) THEN + IWM(LNJE)=IWM(LNJE)+1 + JCALC=0 + CALL DMATD(NEQ,X,Y,YPRIME,DELTA,CJ,H,IERJ,WT,E,WM,IWM, + * RES,IRES,UROUND,JACD,RPAR,IPAR) + CJOLD=CJ + S = 100.D0 + IF (IRES .LT. 0) GO TO 380 + IF(IERJ .NE. 0)GO TO 380 + ENDIF +C +C Call the nonlinear Newton solver. +C + TEMP1 = 2.0D0/(1.0D0 + CJ/CJOLD) + CALL DNSD(X,Y,YPRIME,NEQ,RES,PDUM,WT,RPAR,IPAR,DUMSVR, + * DELTA,E,WM,IWM,CJ,DUMS,DUMR,DUME,EPCON,S,TEMP1, + * TOLNEW,MULDEL,MAXIT,IRES,IDUM,IERNEW) +C + IF (IERNEW .GT. 0 .AND. JCALC .NE. 0) THEN +C +C The Newton iteration had a recoverable failure with an old +C iteration matrix. Retry the step with a new iteration matrix. +C + JCALC = -1 + GO TO 300 + ENDIF +C + IF (IERNEW .NE. 0) GO TO 380 +C +C The Newton iteration has converged. If nonnegativity of +C solution is required, set the solution nonnegative, if the +C perturbation to do it is small enough. If the change is too +C large, then consider the corrector iteration to have failed. +C +375 IF(NONNEG .EQ. 0) GO TO 390 + DO 377 I = 1,NEQ +377 DELTA(I) = MIN(Y(I),0.0D0) + DELNRM = DDWNRM(NEQ,DELTA,WT,RPAR,IPAR) + IF(DELNRM .GT. EPCON) GO TO 380 + DO 378 I = 1,NEQ +378 E(I) = E(I) - DELTA(I) + GO TO 390 +C +C +C Exits from nonlinear solver. +C No convergence with current iteration +C matrix, or singular iteration matrix. +C Compute IERNLS and IDID accordingly. +C +380 CONTINUE + IF (IRES .LE. -2 .OR. IERTYP .NE. 0) THEN + IERNLS = -1 + IF (IRES .LE. -2) IDID = -11 + IF (IERTYP .NE. 0) IDID = -15 + ELSE + IERNLS = 1 + IF (IRES .LT. 0) IDID = -10 + IF (IERJ .NE. 0) IDID = -8 + ENDIF +C +390 JCALC = 1 + RETURN +C +C------END OF SUBROUTINE DNEDD------------------------------------------ + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/daspk/dnedk.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,275 @@ +C Work performed under the auspices of the U.S. Department of Energy +C by Lawrence Livermore National Laboratory under contract number +C W-7405-Eng-48. +C + SUBROUTINE DNEDK(X,Y,YPRIME,NEQ,RES,JACK,PSOL, + * H,WT,JSTART,IDID,RPAR,IPAR,PHI,GAMMA,SAVR,DELTA,E, + * WM,IWM,CJ,CJOLD,CJLAST,S,UROUND,EPLI,SQRTN,RSQRTN, + * EPCON,JCALC,JFLG,KP1,NONNEG,NTYPE,IERNLS) +C +C***BEGIN PROLOGUE DNEDK +C***REFER TO DDASPK +C***DATE WRITTEN 891219 (YYMMDD) +C***REVISION DATE 900926 (YYMMDD) +C***REVISION DATE 940701 (YYMMDD) +C +C +C----------------------------------------------------------------------- +C***DESCRIPTION +C +C DNEDK solves a nonlinear system of +C algebraic equations of the form +C G(X,Y,YPRIME) = 0 for the unknown Y. +C +C The method used is a matrix-free Newton scheme. +C +C The parameters represent +C X -- Independent variable. +C Y -- Solution vector at x. +C YPRIME -- Derivative of solution vector +C after successful step. +C NEQ -- Number of equations to be integrated. +C RES -- External user-supplied subroutine +C to evaluate the residual. See RES description +C in DDASPK prologue. +C JACK -- External user-supplied routine to update +C the preconditioner. (This is optional). +C See JAC description for the case +C INFO(12) = 1 in the DDASPK prologue. +C PSOL -- External user-supplied routine to solve +C a linear system using preconditioning. +C (This is optional). See explanation inside DDASPK. +C H -- Appropriate step size for this step. +C WT -- Vector of weights for error criterion. +C JSTART -- Indicates first call to this routine. +C If JSTART = 0, then this is the first call, +C otherwise it is not. +C IDID -- Completion flag, output by DNEDK. +C See IDID description in DDASPK prologue. +C RPAR,IPAR -- Real and integer arrays used for communication +C between the calling program and external user +C routines. They are not altered within DASPK. +C PHI -- Array of divided differences used by +C DNEDK. The length is NEQ*(K+1), where +C K is the maximum order. +C GAMMA -- Array used to predict Y and YPRIME. The length +C is K+1, where K is the maximum order. +C SAVR -- Work vector for DNEDK of length NEQ. +C DELTA -- Work vector for DNEDK of length NEQ. +C E -- Error accumulation vector for DNEDK of length NEQ. +C WM,IWM -- Real and integer arrays storing +C matrix information for linear system +C solvers, and various other information. +C CJ -- Parameter always proportional to 1/H. +C CJOLD -- Saves the value of CJ as of the last call to DITMD. +C Accounts for changes in CJ needed to +C decide whether to call DITMD. +C CJLAST -- Previous value of CJ. +C S -- A scalar determined by the approximate rate +C of convergence of the Newton iteration and used +C in the convergence test for the Newton iteration. +C +C If RATE is defined to be an estimate of the +C rate of convergence of the Newton iteration, +C then S = RATE/(1.D0-RATE). +C +C The closer RATE is to 0., the faster the Newton +C iteration is converging; the closer RATE is to 1., +C the slower the Newton iteration is converging. +C +C On the first Newton iteration with an up-dated +C preconditioner S = 100.D0, Thus the initial +C RATE of convergence is approximately 1. +C +C S is preserved from call to call so that the rate +C estimate from a previous step can be applied to +C the current step. +C UROUND -- Unit roundoff. +C EPLI -- convergence test constant. +C See DDASPK prologue for more details. +C SQRTN -- Square root of NEQ. +C RSQRTN -- reciprical of square root of NEQ. +C EPCON -- Tolerance to test for convergence of the Newton +C iteration. +C JCALC -- Flag used to determine when to update +C the Jacobian matrix. In general: +C +C JCALC = -1 ==> Call the DITMD routine to update +C the Jacobian matrix. +C JCALC = 0 ==> Jacobian matrix is up-to-date. +C JCALC = 1 ==> Jacobian matrix is out-dated, +C but DITMD will not be called unless +C JCALC is set to -1. +C JFLG -- Flag showing whether a Jacobian routine is supplied. +C KP1 -- The current order + 1; updated across calls. +C NONNEG -- Flag to determine nonnegativity constraints. +C NTYPE -- Identification code for the DNEDK routine. +C 1 ==> modified Newton; iterative linear solver. +C 2 ==> modified Newton; user-supplied linear solver. +C IERNLS -- Error flag for nonlinear solver. +C 0 ==> nonlinear solver converged. +C 1 ==> recoverable error inside non-linear solver. +C -1 ==> unrecoverable error inside non-linear solver. +C +C The following group of variables are passed as arguments to +C the Newton iteration solver. They are explained in greater detail +C in DNSK: +C TOLNEW, MULDEL, MAXIT, IERNEW +C +C IERTYP -- Flag which tells whether this subroutine is correct. +C 0 ==> correct subroutine. +C 1 ==> incorrect subroutine. +C +C----------------------------------------------------------------------- +C***ROUTINES CALLED +C RES, JACK, DDWNRM, DNSK +C +C***END PROLOGUE DNEDK +C +C + IMPLICIT DOUBLE PRECISION(A-H,O-Z) + DIMENSION Y(*),YPRIME(*),WT(*) + DIMENSION PHI(NEQ,*),SAVR(*),DELTA(*),E(*) + DIMENSION WM(*),IWM(*) + DIMENSION GAMMA(*),RPAR(*),IPAR(*) + EXTERNAL RES, JACK, PSOL +C + PARAMETER (LNRE=12, LNJE=13, LLOCWP=29, LLCIWP=30) +C + SAVE MULDEL, MAXIT, XRATE + DATA MULDEL/0/, MAXIT/4/, XRATE/0.25D0/ +C +C Verify that this is the correct subroutine. +C + IERTYP = 0 + IF (NTYPE .NE. 1) THEN + IERTYP = 1 + GO TO 380 + ENDIF +C +C If this is the first step, perform initializations. +C + IF (JSTART .EQ. 0) THEN + CJOLD = CJ + JCALC = -1 + S = 100.D0 + ENDIF +C +C Perform all other initializations. +C + IERNLS = 0 + LWP = IWM(LLOCWP) + LIWP = IWM(LLCIWP) +C +C Decide whether to update the preconditioner. +C + IF (JFLG .NE. 0) THEN + TEMP1 = (1.0D0 - XRATE)/(1.0D0 + XRATE) + TEMP2 = 1.0D0/TEMP1 + IF (CJ/CJOLD .LT. TEMP1 .OR. CJ/CJOLD .GT. TEMP2) JCALC = -1 + IF (CJ .NE. CJLAST) S = 100.D0 + ELSE + JCALC = 0 + ENDIF +C +C Looping point for updating preconditioner with current stepsize. +C +300 CONTINUE +C +C Initialize all error flags to zero. +C + IERPJ = 0 + IRES = 0 + IERSL = 0 + IERNEW = 0 +C +C Predict the solution and derivative and compute the tolerance +C for the Newton iteration. +C + DO 310 I=1,NEQ + Y(I)=PHI(I,1) +310 YPRIME(I)=0.0D0 + DO 330 J=2,KP1 + DO 320 I=1,NEQ + Y(I)=Y(I)+PHI(I,J) +320 YPRIME(I)=YPRIME(I)+GAMMA(J)*PHI(I,J) +330 CONTINUE + EPLIN = EPLI*EPCON + TOLNEW = EPLIN +C +C Call RES to initialize DELTA. +C + IWM(LNRE)=IWM(LNRE)+1 + CALL RES(X,Y,YPRIME,CJ,DELTA,IRES,RPAR,IPAR) + IF (IRES .LT. 0) GO TO 380 +C +C +C If indicated, update the preconditioner. +C Set JCALC to 0 as an indicator that this has been done. +C + IF(JCALC .EQ. -1)THEN + IWM(LNJE) = IWM(LNJE) + 1 + JCALC=0 + CALL JACK (RES, IRES, NEQ, X, Y, YPRIME, WT, DELTA, E, H, CJ, + * WM(LWP), IWM(LIWP), IERPJ, RPAR, IPAR) + CJOLD=CJ + S = 100.D0 + IF (IRES .LT. 0) GO TO 380 + IF (IERPJ .NE. 0) GO TO 380 + ENDIF +C +C Call the nonlinear Newton solver. +C + CALL DNSK(X,Y,YPRIME,NEQ,RES,PSOL,WT,RPAR,IPAR,SAVR, + * DELTA,E,WM,IWM,CJ,SQRTN,RSQRTN,EPLIN,EPCON, + * S,TEMP1,TOLNEW,MULDEL,MAXIT,IRES,IERSL,IERNEW) +C + IF (IERNEW .GT. 0 .AND. JCALC .NE. 0) THEN +C +C The Newton iteration had a recoverable failure with an old +C preconditioner. Retry the step with a new preconditioner. +C + JCALC = -1 + GO TO 300 + ENDIF +C + IF (IERNEW .NE. 0) GO TO 380 +C +C The Newton iteration has converged. If nonnegativity of +C solution is required, set the solution nonnegative, if the +C perturbation to do it is small enough. If the change is too +C large, then consider the corrector iteration to have failed. +C + IF(NONNEG .EQ. 0) GO TO 390 + DO 360 I = 1,NEQ + 360 DELTA(I) = MIN(Y(I),0.0D0) + DELNRM = DDWNRM(NEQ,DELTA,WT,RPAR,IPAR) + IF(DELNRM .GT. EPCON) GO TO 380 + DO 370 I = 1,NEQ + 370 E(I) = E(I) - DELTA(I) + GO TO 390 +C +C +C Exits from nonlinear solver. +C No convergence with current preconditioner. +C Compute IERNLS and IDID accordingly. +C +380 CONTINUE + IF (IRES .LE. -2 .OR. IERSL .LT. 0 .OR. IERTYP .NE. 0) THEN + IERNLS = -1 + IF (IRES .LE. -2) IDID = -11 + IF (IERSL .LT. 0) IDID = -13 + IF (IERTYP .NE. 0) IDID = -15 + ELSE + IERNLS = 1 + IF (IRES .EQ. -1) IDID = -10 + IF (IERPJ .NE. 0) IDID = -5 + IF (IERSL .GT. 0) IDID = -14 + ENDIF +C +C +390 JCALC = 1 + RETURN +C +C------END OF SUBROUTINE DNEDK------------------------------------------ + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/daspk/dnsd.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,168 @@ +C Work performed under the auspices of the U.S. Department of Energy +C by Lawrence Livermore National Laboratory under contract number +C W-7405-Eng-48. +C + SUBROUTINE DNSD(X,Y,YPRIME,NEQ,RES,PDUM,WT,RPAR,IPAR, + * DUMSVR,DELTA,E,WM,IWM,CJ,DUMS,DUMR,DUME,EPCON, + * S,CONFAC,TOLNEW,MULDEL,MAXIT,IRES,IDUM,IERNEW) +C +C***BEGIN PROLOGUE DNSD +C***REFER TO DDASPK +C***DATE WRITTEN 891219 (YYMMDD) +C***REVISION DATE 900926 (YYMMDD) +C***REVISION DATE 950126 (YYMMDD) +C +C +C----------------------------------------------------------------------- +C***DESCRIPTION +C +C DNSD solves a nonlinear system of +C algebraic equations of the form +C G(X,Y,YPRIME) = 0 for the unknown Y. +C +C The method used is a modified Newton scheme. +C +C The parameters represent +C +C X -- Independent variable. +C Y -- Solution vector. +C YPRIME -- Derivative of solution vector. +C NEQ -- Number of unknowns. +C RES -- External user-supplied subroutine +C to evaluate the residual. See RES description +C in DDASPK prologue. +C PDUM -- Dummy argument. +C WT -- Vector of weights for error criterion. +C RPAR,IPAR -- Real and integer arrays used for communication +C between the calling program and external user +C routines. They are not altered within DASPK. +C DUMSVR -- Dummy argument. +C DELTA -- Work vector for DNSD of length NEQ. +C E -- Error accumulation vector for DNSD of length NEQ. +C WM,IWM -- Real and integer arrays storing +C matrix information such as the matrix +C of partial derivatives, permutation +C vector, and various other information. +C CJ -- Parameter always proportional to 1/H (step size). +C DUMS -- Dummy argument. +C DUMR -- Dummy argument. +C DUME -- Dummy argument. +C EPCON -- Tolerance to test for convergence of the Newton +C iteration. +C S -- Used for error convergence tests. +C In the Newton iteration: S = RATE/(1 - RATE), +C where RATE is the estimated rate of convergence +C of the Newton iteration. +C The calling routine passes the initial value +C of S to the Newton iteration. +C CONFAC -- A residual scale factor to improve convergence. +C TOLNEW -- Tolerance on the norm of Newton correction in +C alternative Newton convergence test. +C MULDEL -- A flag indicating whether or not to multiply +C DELTA by CONFAC. +C 0 ==> do not scale DELTA by CONFAC. +C 1 ==> scale DELTA by CONFAC. +C MAXIT -- Maximum allowed number of Newton iterations. +C IRES -- Error flag returned from RES. See RES description +C in DDASPK prologue. If IRES = -1, then IERNEW +C will be set to 1. +C If IRES < -1, then IERNEW will be set to -1. +C IDUM -- Dummy argument. +C IERNEW -- Error flag for Newton iteration. +C 0 ==> Newton iteration converged. +C 1 ==> recoverable error inside Newton iteration. +C -1 ==> unrecoverable error inside Newton iteration. +C +C All arguments with "DUM" in their names are dummy arguments +C which are not used in this routine. +C----------------------------------------------------------------------- +C +C***ROUTINES CALLED +C DSLVD, DDWNRM, RES +C +C***END PROLOGUE DNSD +C +C + IMPLICIT DOUBLE PRECISION(A-H,O-Z) + DIMENSION Y(*),YPRIME(*),WT(*),DELTA(*),E(*) + DIMENSION WM(*),IWM(*), RPAR(*),IPAR(*) + EXTERNAL RES +C + PARAMETER (LNRE=12, LNNI=19) +C +C Initialize Newton counter M and accumulation vector E. +C + M = 0 + DO 100 I=1,NEQ +100 E(I)=0.0D0 +C +C Corrector loop. +C +300 CONTINUE + IWM(LNNI) = IWM(LNNI) + 1 +C +C If necessary, multiply residual by convergence factor. +C + IF (MULDEL .EQ. 1) THEN + DO 320 I = 1,NEQ +320 DELTA(I) = DELTA(I) * CONFAC + ENDIF +C +C Compute a new iterate (back-substitution). +C Store the correction in DELTA. +C + CALL DSLVD(NEQ,DELTA,WM,IWM) +C +C Update Y, E, and YPRIME. +C + DO 340 I=1,NEQ + Y(I)=Y(I)-DELTA(I) + E(I)=E(I)-DELTA(I) +340 YPRIME(I)=YPRIME(I)-CJ*DELTA(I) +C +C Test for convergence of the iteration. +C + DELNRM=DDWNRM(NEQ,DELTA,WT,RPAR,IPAR) + IF (DELNRM .LE. TOLNEW) GO TO 370 + IF (M .EQ. 0) THEN + OLDNRM = DELNRM + ELSE + RATE = (DELNRM/OLDNRM)**(1.0D0/M) + IF (RATE .GT. 0.9D0) GO TO 380 + S = RATE/(1.0D0 - RATE) + ENDIF + IF (S*DELNRM .LE. EPCON) GO TO 370 +C +C The corrector has not yet converged. +C Update M and test whether the +C maximum number of iterations have +C been tried. +C + M=M+1 + IF(M.GE.MAXIT) GO TO 380 +C +C Evaluate the residual, +C and go back to do another iteration. +C + IWM(LNRE)=IWM(LNRE)+1 + CALL RES(X,Y,YPRIME,CJ,DELTA,IRES,RPAR,IPAR) + IF (IRES .LT. 0) GO TO 380 + GO TO 300 +C +C The iteration has converged. +C +370 RETURN +C +C The iteration has not converged. Set IERNEW appropriately. +C +380 CONTINUE + IF (IRES .LE. -2 ) THEN + IERNEW = -1 + ELSE + IERNEW = 1 + ENDIF + RETURN +C +C +C------END OF SUBROUTINE DNSD------------------------------------------- + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/daspk/dnsid.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,157 @@ +C Work performed under the auspices of the U.S. Department of Energy +C by Lawrence Livermore National Laboratory under contract number +C W-7405-Eng-48. +C + SUBROUTINE DNSID(X,Y,YPRIME,NEQ,ICOPT,ID,RES,WT,RPAR,IPAR, + * DELTA,R,YIC,YPIC,WM,IWM,CJ,EPCON,RATEMX,MAXIT,STPTOL, + * ICNFLG,ICNSTR,IERNEW) +C +C***BEGIN PROLOGUE DNSID +C***REFER TO DDASPK +C***DATE WRITTEN 940701 (YYMMDD) +C***REVISION DATE 950713 (YYMMDD) +C +C +C----------------------------------------------------------------------- +C***DESCRIPTION +C +C DNSID solves a nonlinear system of algebraic equations of the +C form G(X,Y,YPRIME) = 0 for the unknown parts of Y and YPRIME +C in the initial conditions. +C +C The method used is a modified Newton scheme. +C +C The parameters represent +C +C X -- Independent variable. +C Y -- Solution vector. +C YPRIME -- Derivative of solution vector. +C NEQ -- Number of unknowns. +C ICOPT -- Initial condition option chosen (1 or 2). +C ID -- Array of dimension NEQ, which must be initialized +C if ICOPT = 1. See DDASIC. +C RES -- External user-supplied subroutine to evaluate the +C residual. See RES description in DDASPK prologue. +C WT -- Vector of weights for error criterion. +C RPAR,IPAR -- Real and integer arrays used for communication +C between the calling program and external user +C routines. They are not altered within DASPK. +C DELTA -- Residual vector on entry, and work vector of +C length NEQ for DNSID. +C WM,IWM -- Real and integer arrays storing matrix information +C such as the matrix of partial derivatives, +C permutation vector, and various other information. +C CJ -- Matrix parameter = 1/H (ICOPT = 1) or 0 (ICOPT = 2). +C R -- Array of length NEQ used as workspace by the +C linesearch routine DLINSD. +C YIC,YPIC -- Work vectors for DLINSD, each of length NEQ. +C EPCON -- Tolerance to test for convergence of the Newton +C iteration. +C RATEMX -- Maximum convergence rate for which Newton iteration +C is considered converging. +C MAXIT -- Maximum allowed number of Newton iterations. +C STPTOL -- Tolerance used in calculating the minimum lambda +C value allowed. +C ICNFLG -- Integer scalar. If nonzero, then constraint +C violations in the proposed new approximate solution +C will be checked for, and the maximum step length +C will be adjusted accordingly. +C ICNSTR -- Integer array of length NEQ containing flags for +C checking constraints. +C IERNEW -- Error flag for Newton iteration. +C 0 ==> Newton iteration converged. +C 1 ==> failed to converge, but RATE .le. RATEMX. +C 2 ==> failed to converge, RATE .gt. RATEMX. +C 3 ==> other recoverable error (IRES = -1, or +C linesearch failed). +C -1 ==> unrecoverable error (IRES = -2). +C +C----------------------------------------------------------------------- +C +C***ROUTINES CALLED +C DSLVD, DDWNRM, DLINSD, DCOPY +C +C***END PROLOGUE DNSID +C +C + IMPLICIT DOUBLE PRECISION(A-H,O-Z) + DIMENSION Y(*),YPRIME(*),WT(*),R(*) + DIMENSION ID(*),DELTA(*), YIC(*), YPIC(*) + DIMENSION WM(*),IWM(*), RPAR(*),IPAR(*) + DIMENSION ICNSTR(*) + EXTERNAL RES +C + PARAMETER (LNNI=19, LLSOFF=35) +C +C +C Initializations. M is the Newton iteration counter. +C + LSOFF = IWM(LLSOFF) + M = 0 + RATE = 1.0D0 + RLX = 0.4D0 +C +C Compute a new step vector DELTA by back-substitution. +C + CALL DSLVD (NEQ, DELTA, WM, IWM) +C +C Get norm of DELTA. Return now if norm(DELTA) .le. EPCON. +C + DELNRM = DDWNRM(NEQ,DELTA,WT,RPAR,IPAR) + FNRM = DELNRM + IF (FNRM .LE. EPCON) RETURN +C +C Newton iteration loop. +C + 300 CONTINUE + IWM(LNNI) = IWM(LNNI) + 1 +C +C Call linesearch routine for global strategy and set RATE +C + OLDFNM = FNRM +C + CALL DLINSD (NEQ, Y, X, YPRIME, CJ, DELTA, DELNRM, WT, LSOFF, + * STPTOL, IRET, RES, IRES, WM, IWM, FNRM, ICOPT, ID, + * R, YIC, YPIC, ICNFLG, ICNSTR, RLX, RPAR, IPAR) +C + RATE = FNRM/OLDFNM +C +C Check for error condition from linesearch. + IF (IRET .NE. 0) GO TO 390 +C +C Test for convergence of the iteration, and return or loop. +C + IF (FNRM .LE. EPCON) RETURN +C +C The iteration has not yet converged. Update M. +C Test whether the maximum number of iterations have been tried. +C + M = M + 1 + IF (M .GE. MAXIT) GO TO 380 +C +C Copy the residual to DELTA and its norm to DELNRM, and loop for +C another iteration. +C + CALL DCOPY (NEQ, R, 1, DELTA, 1) + DELNRM = FNRM + GO TO 300 +C +C The maximum number of iterations was done. Set IERNEW and return. +C + 380 IF (RATE .LE. RATEMX) THEN + IERNEW = 1 + ELSE + IERNEW = 2 + ENDIF + RETURN +C + 390 IF (IRES .LE. -2) THEN + IERNEW = -1 + ELSE + IERNEW = 3 + ENDIF + RETURN +C +C +C------END OF SUBROUTINE DNSID------------------------------------------ + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/daspk/dnsik.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,189 @@ +C Work performed under the auspices of the U.S. Department of Energy +C by Lawrence Livermore National Laboratory under contract number +C W-7405-Eng-48. +C + SUBROUTINE DNSIK(X,Y,YPRIME,NEQ,ICOPT,ID,RES,PSOL,WT,RPAR,IPAR, + * SAVR,DELTA,R,YIC,YPIC,PWK,WM,IWM,CJ,SQRTN,RSQRTN,EPLIN,EPCON, + * RATEMX,MAXIT,STPTOL,ICNFLG,ICNSTR,IERNEW) +C +C***BEGIN PROLOGUE DNSIK +C***REFER TO DDASPK +C***DATE WRITTEN 940701 (YYMMDD) +C***REVISION DATE 950714 (YYMMDD) +C +C +C----------------------------------------------------------------------- +C***DESCRIPTION +C +C DNSIK solves a nonlinear system of algebraic equations of the +C form G(X,Y,YPRIME) = 0 for the unknown parts of Y and YPRIME in +C the initial conditions. +C +C The method used is a Newton scheme combined with a linesearch +C algorithm, using Krylov iterative linear system methods. +C +C The parameters represent +C +C X -- Independent variable. +C Y -- Solution vector. +C YPRIME -- Derivative of solution vector. +C NEQ -- Number of unknowns. +C ICOPT -- Initial condition option chosen (1 or 2). +C ID -- Array of dimension NEQ, which must be initialized +C if ICOPT = 1. See DDASIC. +C RES -- External user-supplied subroutine +C to evaluate the residual. See RES description +C in DDASPK prologue. +C PSOL -- External user-supplied routine to solve +C a linear system using preconditioning. +C See explanation inside DDASPK. +C WT -- Vector of weights for error criterion. +C RPAR,IPAR -- Real and integer arrays used for communication +C between the calling program and external user +C routines. They are not altered within DASPK. +C SAVR -- Work vector for DNSIK of length NEQ. +C DELTA -- Residual vector on entry, and work vector of +C length NEQ for DNSIK. +C R -- Work vector for DNSIK of length NEQ. +C YIC,YPIC -- Work vectors for DNSIK, each of length NEQ. +C PWK -- Work vector for DNSIK of length NEQ. +C WM,IWM -- Real and integer arrays storing +C matrix information such as the matrix +C of partial derivatives, permutation +C vector, and various other information. +C CJ -- Matrix parameter = 1/H (ICOPT = 1) or 0 (ICOPT = 2). +C SQRTN -- Square root of NEQ. +C RSQRTN -- reciprical of square root of NEQ. +C EPLIN -- Tolerance for linear system solver. +C EPCON -- Tolerance to test for convergence of the Newton +C iteration. +C RATEMX -- Maximum convergence rate for which Newton iteration +C is considered converging. +C MAXIT -- Maximum allowed number of Newton iterations. +C STPTOL -- Tolerance used in calculating the minimum lambda +C value allowed. +C ICNFLG -- Integer scalar. If nonzero, then constraint +C violations in the proposed new approximate solution +C will be checked for, and the maximum step length +C will be adjusted accordingly. +C ICNSTR -- Integer array of length NEQ containing flags for +C checking constraints. +C IERNEW -- Error flag for Newton iteration. +C 0 ==> Newton iteration converged. +C 1 ==> failed to converge, but RATE .lt. 1. +C 2 ==> failed to converge, RATE .gt. RATEMX. +C 3 ==> other recoverable error. +C -1 ==> unrecoverable error inside Newton iteration. +C----------------------------------------------------------------------- +C +C***ROUTINES CALLED +C DFNRMK, DSLVK, DDWNRM, DLINSK, DCOPY +C +C***END PROLOGUE DNSIK +C +C + IMPLICIT DOUBLE PRECISION(A-H,O-Z) + DIMENSION Y(*),YPRIME(*),WT(*),ID(*),DELTA(*),R(*),SAVR(*) + DIMENSION YIC(*),YPIC(*),PWK(*),WM(*),IWM(*), RPAR(*),IPAR(*) + DIMENSION ICNSTR(*) + EXTERNAL RES, PSOL +C + PARAMETER (LNNI=19, LNPS=21, LLOCWP=29, LLCIWP=30) + PARAMETER (LLSOFF=35, LSTOL=14) +C +C +C Initializations. M is the Newton iteration counter. +C + LSOFF = IWM(LLSOFF) + M = 0 + RATE = 1.0D0 + LWP = IWM(LLOCWP) + LIWP = IWM(LLCIWP) + RLX = 0.4D0 +C +C Save residual in SAVR. +C + CALL DCOPY (NEQ, DELTA, 1, SAVR, 1) +C +C Compute norm of (P-inverse)*(residual). +C + CALL DFNRMK (NEQ, Y, X, YPRIME, SAVR, R, CJ, WT, SQRTN, RSQRTN, + * RES, IRES, PSOL, 1, IER, FNRM, EPLIN, WM(LWP), IWM(LIWP), + * PWK, RPAR, IPAR) + IWM(LNPS) = IWM(LNPS) + 1 + IF (IER .NE. 0) THEN + IERNEW = 3 + RETURN + ENDIF +C +C Return now if residual norm is .le. EPCON. +C + IF (FNRM .LE. EPCON) RETURN +C +C Newton iteration loop. +C +300 CONTINUE + IWM(LNNI) = IWM(LNNI) + 1 +C +C Compute a new step vector DELTA. +C + CALL DSLVK (NEQ, Y, X, YPRIME, SAVR, DELTA, WT, WM, IWM, + * RES, IRES, PSOL, IERSL, CJ, EPLIN, SQRTN, RSQRTN, RHOK, + * RPAR, IPAR) + IF (IRES .NE. 0 .OR. IERSL .NE. 0) GO TO 390 +C +C Get norm of DELTA. Return now if DELTA is zero. +C + DELNRM = DDWNRM(NEQ,DELTA,WT,RPAR,IPAR) + IF (DELNRM .EQ. 0.0D0) RETURN +C +C Call linesearch routine for global strategy and set RATE. +C + OLDFNM = FNRM +C + CALL DLINSK (NEQ, Y, X, YPRIME, SAVR, CJ, DELTA, DELNRM, WT, + * SQRTN, RSQRTN, LSOFF, STPTOL, IRET, RES, IRES, PSOL, WM, IWM, + * RHOK, FNRM, ICOPT, ID, WM(LWP), IWM(LIWP), R, EPLIN, YIC, YPIC, + * PWK, ICNFLG, ICNSTR, RLX, RPAR, IPAR) +C + RATE = FNRM/OLDFNM +C +C Check for error condition from linesearch. + IF (IRET .NE. 0) GO TO 390 +C +C Test for convergence of the iteration, and return or loop. +C + IF (FNRM .LE. EPCON) RETURN +C +C The iteration has not yet converged. Update M. +C Test whether the maximum number of iterations have been tried. +C + M=M+1 + IF(M .GE. MAXIT) GO TO 380 +C +C Copy the residual SAVR to DELTA and loop for another iteration. +C + CALL DCOPY (NEQ, SAVR, 1, DELTA, 1) + GO TO 300 +C +C The maximum number of iterations was done. Set IERNEW and return. +C +380 IF (RATE .LE. RATEMX) THEN + IERNEW = 1 + ELSE + IERNEW = 2 + ENDIF + RETURN +C +390 IF (IRES .LE. -2 .OR. IERSL .LT. 0) THEN + IERNEW = -1 + ELSE + IERNEW = 3 + IF (IRES .EQ. 0 .AND. IERSL .EQ. 1 .AND. M .GE. 2 + 1 .AND. RATE .LT. 1.0D0) IERNEW = 1 + ENDIF + RETURN +C +C +C----------------------- END OF SUBROUTINE DNSIK------------------------ + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/daspk/dnsk.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,179 @@ +C Work performed under the auspices of the U.S. Department of Energy +C by Lawrence Livermore National Laboratory under contract number +C W-7405-Eng-48. +C + SUBROUTINE DNSK(X,Y,YPRIME,NEQ,RES,PSOL,WT,RPAR,IPAR, + * SAVR,DELTA,E,WM,IWM,CJ,SQRTN,RSQRTN,EPLIN,EPCON, + * S,CONFAC,TOLNEW,MULDEL,MAXIT,IRES,IERSL,IERNEW) +C +C***BEGIN PROLOGUE DNSK +C***REFER TO DDASPK +C***DATE WRITTEN 891219 (YYMMDD) +C***REVISION DATE 900926 (YYMMDD) +C***REVISION DATE 950126 (YYMMDD) +C +C +C----------------------------------------------------------------------- +C***DESCRIPTION +C +C DNSK solves a nonlinear system of +C algebraic equations of the form +C G(X,Y,YPRIME) = 0 for the unknown Y. +C +C The method used is a modified Newton scheme. +C +C The parameters represent +C +C X -- Independent variable. +C Y -- Solution vector. +C YPRIME -- Derivative of solution vector. +C NEQ -- Number of unknowns. +C RES -- External user-supplied subroutine +C to evaluate the residual. See RES description +C in DDASPK prologue. +C PSOL -- External user-supplied routine to solve +C a linear system using preconditioning. +C See explanation inside DDASPK. +C WT -- Vector of weights for error criterion. +C RPAR,IPAR -- Real and integer arrays used for communication +C between the calling program and external user +C routines. They are not altered within DASPK. +C SAVR -- Work vector for DNSK of length NEQ. +C DELTA -- Work vector for DNSK of length NEQ. +C E -- Error accumulation vector for DNSK of length NEQ. +C WM,IWM -- Real and integer arrays storing +C matrix information such as the matrix +C of partial derivatives, permutation +C vector, and various other information. +C CJ -- Parameter always proportional to 1/H (step size). +C SQRTN -- Square root of NEQ. +C RSQRTN -- reciprical of square root of NEQ. +C EPLIN -- Tolerance for linear system solver. +C EPCON -- Tolerance to test for convergence of the Newton +C iteration. +C S -- Used for error convergence tests. +C In the Newton iteration: S = RATE/(1.D0-RATE), +C where RATE is the estimated rate of convergence +C of the Newton iteration. +C +C The closer RATE is to 0., the faster the Newton +C iteration is converging; the closer RATE is to 1., +C the slower the Newton iteration is converging. +C +C The calling routine sends the initial value +C of S to the Newton iteration. +C CONFAC -- A residual scale factor to improve convergence. +C TOLNEW -- Tolerance on the norm of Newton correction in +C alternative Newton convergence test. +C MULDEL -- A flag indicating whether or not to multiply +C DELTA by CONFAC. +C 0 ==> do not scale DELTA by CONFAC. +C 1 ==> scale DELTA by CONFAC. +C MAXIT -- Maximum allowed number of Newton iterations. +C IRES -- Error flag returned from RES. See RES description +C in DDASPK prologue. If IRES = -1, then IERNEW +C will be set to 1. +C If IRES < -1, then IERNEW will be set to -1. +C IERSL -- Error flag for linear system solver. +C See IERSL description in subroutine DSLVK. +C If IERSL = 1, then IERNEW will be set to 1. +C If IERSL < 0, then IERNEW will be set to -1. +C IERNEW -- Error flag for Newton iteration. +C 0 ==> Newton iteration converged. +C 1 ==> recoverable error inside Newton iteration. +C -1 ==> unrecoverable error inside Newton iteration. +C----------------------------------------------------------------------- +C +C***ROUTINES CALLED +C RES, DSLVK, DDWNRM +C +C***END PROLOGUE DNSK +C +C + IMPLICIT DOUBLE PRECISION(A-H,O-Z) + DIMENSION Y(*),YPRIME(*),WT(*),DELTA(*),E(*),SAVR(*) + DIMENSION WM(*),IWM(*), RPAR(*),IPAR(*) + EXTERNAL RES, PSOL +C + PARAMETER (LNNI=19, LNRE=12) +C +C Initialize Newton counter M and accumulation vector E. +C + M = 0 + DO 100 I=1,NEQ +100 E(I) = 0.0D0 +C +C Corrector loop. +C +300 CONTINUE + IWM(LNNI) = IWM(LNNI) + 1 +C +C If necessary, multiply residual by convergence factor. +C + IF (MULDEL .EQ. 1) THEN + DO 320 I = 1,NEQ +320 DELTA(I) = DELTA(I) * CONFAC + ENDIF +C +C Save residual in SAVR. +C + DO 340 I = 1,NEQ +340 SAVR(I) = DELTA(I) +C +C Compute a new iterate. Store the correction in DELTA. +C + CALL DSLVK (NEQ, Y, X, YPRIME, SAVR, DELTA, WT, WM, IWM, + * RES, IRES, PSOL, IERSL, CJ, EPLIN, SQRTN, RSQRTN, RHOK, + * RPAR, IPAR) + IF (IRES .NE. 0 .OR. IERSL .NE. 0) GO TO 380 +C +C Update Y, E, and YPRIME. +C + DO 360 I=1,NEQ + Y(I) = Y(I) - DELTA(I) + E(I) = E(I) - DELTA(I) +360 YPRIME(I) = YPRIME(I) - CJ*DELTA(I) +C +C Test for convergence of the iteration. +C + DELNRM = DDWNRM(NEQ,DELTA,WT,RPAR,IPAR) + IF (DELNRM .LE. TOLNEW) GO TO 370 + IF (M .EQ. 0) THEN + OLDNRM = DELNRM + ELSE + RATE = (DELNRM/OLDNRM)**(1.0D0/M) + IF (RATE .GT. 0.9D0) GO TO 380 + S = RATE/(1.0D0 - RATE) + ENDIF + IF (S*DELNRM .LE. EPCON) GO TO 370 +C +C The corrector has not yet converged. Update M and test whether +C the maximum number of iterations have been tried. +C + M = M + 1 + IF (M .GE. MAXIT) GO TO 380 +C +C Evaluate the residual, and go back to do another iteration. +C + IWM(LNRE) = IWM(LNRE) + 1 + CALL RES(X,Y,YPRIME,CJ,DELTA,IRES,RPAR,IPAR) + IF (IRES .LT. 0) GO TO 380 + GO TO 300 +C +C The iteration has converged. +C +370 RETURN +C +C The iteration has not converged. Set IERNEW appropriately. +C +380 CONTINUE + IF (IRES .LE. -2 .OR. IERSL .LT. 0) THEN + IERNEW = -1 + ELSE + IERNEW = 1 + ENDIF + RETURN +C +C +C------END OF SUBROUTINE DNSK------------------------------------------- + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/daspk/dorth.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,101 @@ +C Work performed under the auspices of the U.S. Department of Energy +C by Lawrence Livermore National Laboratory under contract number +C W-7405-Eng-48. +C + SUBROUTINE DORTH (VNEW, V, HES, N, LL, LDHES, KMP, SNORMW) +C +C***BEGIN PROLOGUE DORTH +C***DATE WRITTEN 890101 (YYMMDD) +C***REVISION DATE 900926 (YYMMDD) +C +C +C----------------------------------------------------------------------- +C***DESCRIPTION +C +C This routine orthogonalizes the vector VNEW against the previous +C KMP vectors in the V array. It uses a modified Gram-Schmidt +C orthogonalization procedure with conditional reorthogonalization. +C +C On entry +C +C VNEW = The vector of length N containing a scaled product +C OF The Jacobian and the vector V(*,LL). +C +C V = The N x LL array containing the previous LL +C orthogonal vectors V(*,1) to V(*,LL). +C +C HES = An LL x LL upper Hessenberg matrix containing, +C in HES(I,K), K.LT.LL, scaled inner products of +C A*V(*,K) and V(*,I). +C +C LDHES = The leading dimension of the HES array. +C +C N = The order of the matrix A, and the length of VNEW. +C +C LL = The current order of the matrix HES. +C +C KMP = The number of previous vectors the new vector VNEW +C must be made orthogonal to (KMP .LE. MAXL). +C +C +C On return +C +C VNEW = The new vector orthogonal to V(*,I0), +C where I0 = MAX(1, LL-KMP+1). +C +C HES = Upper Hessenberg matrix with column LL filled in with +C scaled inner products of A*V(*,LL) and V(*,I). +C +C SNORMW = L-2 norm of VNEW. +C +C----------------------------------------------------------------------- +C***ROUTINES CALLED +C DDOT, DNRM2, DAXPY +C +C***END PROLOGUE DORTH +C + INTEGER N, LL, LDHES, KMP + DOUBLE PRECISION VNEW, V, HES, SNORMW + DIMENSION VNEW(*), V(N,*), HES(LDHES,*) + INTEGER I, I0 + DOUBLE PRECISION ARG, DDOT, DNRM2, SUMDSQ, TEM, VNRM +C +C----------------------------------------------------------------------- +C Get norm of unaltered VNEW for later use. +C----------------------------------------------------------------------- + VNRM = DNRM2 (N, VNEW, 1) +C----------------------------------------------------------------------- +C Do Modified Gram-Schmidt on VNEW = A*V(LL). +C Scaled inner products give new column of HES. +C Projections of earlier vectors are subtracted from VNEW. +C----------------------------------------------------------------------- + I0 = MAX0(1,LL-KMP+1) + DO 10 I = I0,LL + HES(I,LL) = DDOT (N, V(1,I), 1, VNEW, 1) + TEM = -HES(I,LL) + CALL DAXPY (N, TEM, V(1,I), 1, VNEW, 1) + 10 CONTINUE +C----------------------------------------------------------------------- +C Compute SNORMW = norm of VNEW. +C If VNEW is small compared to its input value (in norm), then +C Reorthogonalize VNEW to V(*,1) through V(*,LL). +C Correct if relative correction exceeds 1000*(unit roundoff). +C Finally, correct SNORMW using the dot products involved. +C----------------------------------------------------------------------- + SNORMW = DNRM2 (N, VNEW, 1) + IF (VNRM + 0.001D0*SNORMW .NE. VNRM) RETURN + SUMDSQ = 0.0D0 + DO 30 I = I0,LL + TEM = -DDOT (N, V(1,I), 1, VNEW, 1) + IF (HES(I,LL) + 0.001D0*TEM .EQ. HES(I,LL)) GO TO 30 + HES(I,LL) = HES(I,LL) - TEM + CALL DAXPY (N, TEM, V(1,I), 1, VNEW, 1) + SUMDSQ = SUMDSQ + TEM**2 + 30 CONTINUE + IF (SUMDSQ .EQ. 0.0D0) RETURN + ARG = MAX(0.0D0,SNORMW**2 - SUMDSQ) + SNORMW = SQRT(ARG) + RETURN +C +C------END OF SUBROUTINE DORTH------------------------------------------ + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/daspk/dslvd.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,57 @@ +C Work performed under the auspices of the U.S. Department of Energy +C by Lawrence Livermore National Laboratory under contract number +C W-7405-Eng-48. +C + SUBROUTINE DSLVD(NEQ,DELTA,WM,IWM) +C +C***BEGIN PROLOGUE DSLVD +C***REFER TO DDASPK +C***DATE WRITTEN 890101 (YYMMDD) +C***REVISION DATE 900926 (YYMMDD) +C***REVISION DATE 940701 (YYMMDD) (new LIPVT) +C +C----------------------------------------------------------------------- +C***DESCRIPTION +C +C This routine manages the solution of the linear +C system arising in the Newton iteration. +C Real matrix information and real temporary storage +C is stored in the array WM. +C Integer matrix information is stored in the array IWM. +C For a dense matrix, the LAPACK routine DGETRS is called. +C For a banded matrix, the LAPACK routine DGBTRS is called. +C----------------------------------------------------------------------- +C***ROUTINES CALLED +C DGETRS, DGBTRS +C +C***END PROLOGUE DSLVD +C +C + IMPLICIT DOUBLE PRECISION(A-H,O-Z) + DIMENSION DELTA(*),WM(*),IWM(*) +C + PARAMETER (LML=1, LMU=2, LMTYPE=4, LLCIWP=30) +C + LIPVT = IWM(LLCIWP) + MTYPE=IWM(LMTYPE) + GO TO(100,100,300,400,400),MTYPE +C +C Dense matrix. +C +100 CALL DGETRS('N', NEQ, 1, WM, NEQ, IWM(LIPVT), DELTA, NEQ, INLPCK) + RETURN +C +C Dummy section for MTYPE=3. +C +300 CONTINUE + RETURN +C +C Banded matrix. +C +400 MEBAND=2*IWM(LML)+IWM(LMU)+1 + CALL DGBTRS('N', NEQ, IWM(LML), IWM(LMU), 1, WM, MEBAND, + * IWM(LIPVT), DELTA, NEQ, INLPCK) + RETURN +C +C------END OF SUBROUTINE DSLVD------------------------------------------ + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/daspk/dslvk.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,141 @@ +C Work performed under the auspices of the U.S. Department of Energy +C by Lawrence Livermore National Laboratory under contract number +C W-7405-Eng-48. +C + SUBROUTINE DSLVK (NEQ, Y, TN, YPRIME, SAVR, X, EWT, WM, IWM, + * RES, IRES, PSOL, IERSL, CJ, EPLIN, SQRTN, RSQRTN, RHOK, + * RPAR, IPAR) +C +C***BEGIN PROLOGUE DSLVK +C***REFER TO DDASPK +C***DATE WRITTEN 890101 (YYMMDD) +C***REVISION DATE 900926 (YYMMDD) +C***REVISION DATE 940928 Removed MNEWT and added RHOK in call list. +C +C +C----------------------------------------------------------------------- +C***DESCRIPTION +C +C DSLVK uses a restart algorithm and interfaces to DSPIGM for +C the solution of the linear system arising from a Newton iteration. +C +C In addition to variables described elsewhere, +C communication with DSLVK uses the following variables.. +C WM = Real work space containing data for the algorithm +C (Krylov basis vectors, Hessenberg matrix, etc.). +C IWM = Integer work space containing data for the algorithm. +C X = The right-hand side vector on input, and the solution vector +C on output, of length NEQ. +C IRES = Error flag from RES. +C IERSL = Output flag .. +C IERSL = 0 means no trouble occurred (or user RES routine +C returned IRES < 0) +C IERSL = 1 means the iterative method failed to converge +C (DSPIGM returned IFLAG > 0.) +C IERSL = -1 means there was a nonrecoverable error in the +C iterative solver, and an error exit will occur. +C----------------------------------------------------------------------- +C***ROUTINES CALLED +C DSCAL, DCOPY, DSPIGM +C +C***END PROLOGUE DSLVK +C + INTEGER NEQ, IWM, IRES, IERSL, IPAR + DOUBLE PRECISION Y, TN, YPRIME, SAVR, X, EWT, WM, CJ, EPLIN, + 1 SQRTN, RSQRTN, RHOK, RPAR + DIMENSION Y(*), YPRIME(*), SAVR(*), X(*), EWT(*), + 1 WM(*), IWM(*), RPAR(*), IPAR(*) +C + INTEGER IFLAG, IRST, NRSTS, NRMAX, LR, LDL, LHES, LGMR, LQ, LV, + 1 LWK, LZ, MAXLP1, NPSL + INTEGER NLI, NPS, NCFL, NRE, MAXL, KMP, MITER + EXTERNAL RES, PSOL +C + PARAMETER (LNRE=12, LNCFL=16, LNLI=20, LNPS=21) + PARAMETER (LLOCWP=29, LLCIWP=30) + PARAMETER (LMITER=23, LMAXL=24, LKMP=25, LNRMAX=26) +C +C----------------------------------------------------------------------- +C IRST is set to 1, to indicate restarting is in effect. +C NRMAX is the maximum number of restarts. +C----------------------------------------------------------------------- + DATA IRST/1/ +C + LIWP = IWM(LLCIWP) + NLI = IWM(LNLI) + NPS = IWM(LNPS) + NCFL = IWM(LNCFL) + NRE = IWM(LNRE) + LWP = IWM(LLOCWP) + MAXL = IWM(LMAXL) + KMP = IWM(LKMP) + NRMAX = IWM(LNRMAX) + MITER = IWM(LMITER) + IERSL = 0 + IRES = 0 +C----------------------------------------------------------------------- +C Use a restarting strategy to solve the linear system +C P*X = -F. Parse the work vector, and perform initializations. +C Note that zero is the initial guess for X. +C----------------------------------------------------------------------- + MAXLP1 = MAXL + 1 + LV = 1 + LR = LV + NEQ*MAXL + LHES = LR + NEQ + 1 + LQ = LHES + MAXL*MAXLP1 + LWK = LQ + 2*MAXL + LDL = LWK + MIN0(1,MAXL-KMP)*NEQ + LZ = LDL + NEQ + CALL DSCAL (NEQ, RSQRTN, EWT, 1) + CALL DCOPY (NEQ, X, 1, WM(LR), 1) + DO 110 I = 1,NEQ + 110 X(I) = 0.D0 +C----------------------------------------------------------------------- +C Top of loop for the restart algorithm. Initial pass approximates +C X and sets up a transformed system to perform subsequent restarts +C to update X. NRSTS is initialized to -1, because restarting +C does not occur until after the first pass. +C Update NRSTS; conditionally copy DL to R; call the DSPIGM +C algorithm to solve A*Z = R; updated counters; update X with +C the residual solution. +C Note: if convergence is not achieved after NRMAX restarts, +C then the linear solver is considered to have failed. +C----------------------------------------------------------------------- + NRSTS = -1 + 115 CONTINUE + NRSTS = NRSTS + 1 + IF (NRSTS .GT. 0) CALL DCOPY (NEQ, WM(LDL), 1, WM(LR),1) + CALL DSPIGM (NEQ, TN, Y, YPRIME, SAVR, WM(LR), EWT, MAXL, MAXLP1, + 1 KMP, EPLIN, CJ, RES, IRES, NRES, PSOL, NPSL, WM(LZ), WM(LV), + 2 WM(LHES), WM(LQ), LGMR, WM(LWP), IWM(LIWP), WM(LWK), + 3 WM(LDL), RHOK, IFLAG, IRST, NRSTS, RPAR, IPAR) + NLI = NLI + LGMR + NPS = NPS + NPSL + NRE = NRE + NRES + DO 120 I = 1,NEQ + 120 X(I) = X(I) + WM(LZ+I-1) + IF ((IFLAG .EQ. 1) .AND. (NRSTS .LT. NRMAX) .AND. (IRES .EQ. 0)) + 1 GO TO 115 +C----------------------------------------------------------------------- +C The restart scheme is finished. Test IRES and IFLAG to see if +C convergence was not achieved, and set flags accordingly. +C----------------------------------------------------------------------- + IF (IRES .LT. 0) THEN + NCFL = NCFL + 1 + ELSE IF (IFLAG .NE. 0) THEN + NCFL = NCFL + 1 + IF (IFLAG .GT. 0) IERSL = 1 + IF (IFLAG .LT. 0) IERSL = -1 + ENDIF +C----------------------------------------------------------------------- +C Update IWM with counters, rescale EWT, and return. +C----------------------------------------------------------------------- + IWM(LNLI) = NLI + IWM(LNPS) = NPS + IWM(LNCFL) = NCFL + IWM(LNRE) = NRE + CALL DSCAL (NEQ, SQRTN, EWT, 1) + RETURN +C +C------END OF SUBROUTINE DSLVK------------------------------------------ + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/daspk/dspigm.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,319 @@ +C Work performed under the auspices of the U.S. Department of Energy +C by Lawrence Livermore National Laboratory under contract number +C W-7405-Eng-48. +C + SUBROUTINE DSPIGM (NEQ, TN, Y, YPRIME, SAVR, R, WGHT, MAXL, + * MAXLP1, KMP, EPLIN, CJ, RES, IRES, NRE, PSOL, NPSL, Z, V, + * HES, Q, LGMR, WP, IWP, WK, DL, RHOK, IFLAG, IRST, NRSTS, + * RPAR, IPAR) +C +C***BEGIN PROLOGUE DSPIGM +C***DATE WRITTEN 890101 (YYMMDD) +C***REVISION DATE 900926 (YYMMDD) +C***REVISION DATE 940927 Removed MNEWT and added RHOK in call list. +C +C +C----------------------------------------------------------------------- +C***DESCRIPTION +C +C This routine solves the linear system A * Z = R using a scaled +C preconditioned version of the generalized minimum residual method. +C An initial guess of Z = 0 is assumed. +C +C On entry +C +C NEQ = Problem size, passed to PSOL. +C +C TN = Current Value of T. +C +C Y = Array Containing current dependent variable vector. +C +C YPRIME = Array Containing current first derivative of Y. +C +C SAVR = Array containing current value of G(T,Y,YPRIME). +C +C R = The right hand side of the system A*Z = R. +C R is also used as work space when computing +C the final approximation and will therefore be +C destroyed. +C (R is the same as V(*,MAXL+1) in the call to DSPIGM.) +C +C WGHT = The vector of length NEQ containing the nonzero +C elements of the diagonal scaling matrix. +C +C MAXL = The maximum allowable order of the matrix H. +C +C MAXLP1 = MAXL + 1, used for dynamic dimensioning of HES. +C +C KMP = The number of previous vectors the new vector, VNEW, +C must be made orthogonal to. (KMP .LE. MAXL.) +C +C EPLIN = Tolerance on residuals R-A*Z in weighted rms norm. +C +C CJ = Scalar proportional to current value of +C 1/(step size H). +C +C WK = Real work array used by routine DATV and PSOL. +C +C DL = Real work array used for calculation of the residual +C norm RHO when the method is incomplete (KMP.LT.MAXL) +C and/or when using restarting. +C +C WP = Real work array used by preconditioner PSOL. +C +C IWP = Integer work array used by preconditioner PSOL. +C +C IRST = Method flag indicating if restarting is being +C performed. IRST .GT. 0 means restarting is active, +C while IRST = 0 means restarting is not being used. +C +C NRSTS = Counter for the number of restarts on the current +C call to DSPIGM. If NRSTS .GT. 0, then the residual +C R is already scaled, and so scaling of R is not +C necessary. +C +C +C On Return +C +C Z = The final computed approximation to the solution +C of the system A*Z = R. +C +C LGMR = The number of iterations performed and +C the current order of the upper Hessenberg +C matrix HES. +C +C NRE = The number of calls to RES (i.e. DATV) +C +C NPSL = The number of calls to PSOL. +C +C V = The neq by (LGMR+1) array containing the LGMR +C orthogonal vectors V(*,1) to V(*,LGMR). +C +C HES = The upper triangular factor of the QR decomposition +C of the (LGMR+1) by LGMR upper Hessenberg matrix whose +C entries are the scaled inner-products of A*V(*,I) +C and V(*,K). +C +C Q = Real array of length 2*MAXL containing the components +C of the givens rotations used in the QR decomposition +C of HES. It is loaded in DHEQR and used in DHELS. +C +C IRES = Error flag from RES. +C +C DL = Scaled preconditioned residual, +C (D-inverse)*(P-inverse)*(R-A*Z). Only loaded when +C performing restarts of the Krylov iteration. +C +C RHOK = Weighted norm of final preconditioned residual. +C +C IFLAG = Integer error flag.. +C 0 Means convergence in LGMR iterations, LGMR.LE.MAXL. +C 1 Means the convergence test did not pass in MAXL +C iterations, but the new residual norm (RHO) is +C .LT. the old residual norm (RNRM), and so Z is +C computed. +C 2 Means the convergence test did not pass in MAXL +C iterations, new residual norm (RHO) .GE. old residual +C norm (RNRM), and the initial guess, Z = 0, is +C returned. +C 3 Means there was a recoverable error in PSOL +C caused by the preconditioner being out of date. +C -1 Means there was an unrecoverable error in PSOL. +C +C----------------------------------------------------------------------- +C***ROUTINES CALLED +C PSOL, DNRM2, DSCAL, DATV, DORTH, DHEQR, DCOPY, DHELS, DAXPY +C +C***END PROLOGUE DSPIGM +C + INTEGER NEQ,MAXL,MAXLP1,KMP,IRES,NRE,NPSL,LGMR,IWP, + 1 IFLAG,IRST,NRSTS,IPAR + DOUBLE PRECISION TN,Y,YPRIME,SAVR,R,WGHT,EPLIN,CJ,Z,V,HES,Q,WP,WK, + 1 DL,RHOK,RPAR + DIMENSION Y(*), YPRIME(*), SAVR(*), R(*), WGHT(*), Z(*), + 1 V(NEQ,*), HES(MAXLP1,*), Q(*), WP(*), IWP(*), WK(*), DL(*), + 2 RPAR(*), IPAR(*) + INTEGER I, IER, INFO, IP1, I2, J, K, LL, LLP1 + DOUBLE PRECISION RNRM,C,DLNRM,PROD,RHO,S,SNORMW,DNRM2,TEM + EXTERNAL RES, PSOL +C + IER = 0 + IFLAG = 0 + LGMR = 0 + NPSL = 0 + NRE = 0 +C----------------------------------------------------------------------- +C The initial guess for Z is 0. The initial residual is therefore +C the vector R. Initialize Z to 0. +C----------------------------------------------------------------------- + DO 10 I = 1,NEQ + 10 Z(I) = 0.0D0 +C----------------------------------------------------------------------- +C Apply inverse of left preconditioner to vector R if NRSTS .EQ. 0. +C Form V(*,1), the scaled preconditioned right hand side. +C----------------------------------------------------------------------- + IF (NRSTS .EQ. 0) THEN + CALL PSOL (NEQ, TN, Y, YPRIME, SAVR, WK, CJ, WGHT, WP, IWP, + 1 R, EPLIN, IER, RPAR, IPAR) + NPSL = 1 + IF (IER .NE. 0) GO TO 300 + DO 30 I = 1,NEQ + 30 V(I,1) = R(I)*WGHT(I) + ELSE + DO 35 I = 1,NEQ + 35 V(I,1) = R(I) + ENDIF +C----------------------------------------------------------------------- +C Calculate norm of scaled vector V(*,1) and normalize it +C If, however, the norm of V(*,1) (i.e. the norm of the preconditioned +C residual) is .le. EPLIN, then return with Z=0. +C----------------------------------------------------------------------- + RNRM = DNRM2 (NEQ, V, 1) + IF (RNRM .LE. EPLIN) THEN + RHOK = RNRM + RETURN + ENDIF + TEM = 1.0D0/RNRM + CALL DSCAL (NEQ, TEM, V(1,1), 1) +C----------------------------------------------------------------------- +C Zero out the HES array. +C----------------------------------------------------------------------- + DO 65 J = 1,MAXL + DO 60 I = 1,MAXLP1 + 60 HES(I,J) = 0.0D0 + 65 CONTINUE +C----------------------------------------------------------------------- +C Main loop to compute the vectors V(*,2) to V(*,MAXL). +C The running product PROD is needed for the convergence test. +C----------------------------------------------------------------------- + PROD = 1.0D0 + DO 90 LL = 1,MAXL + LGMR = LL +C----------------------------------------------------------------------- +C Call routine DATV to compute VNEW = ABAR*V(LL), where ABAR is +C the matrix A with scaling and inverse preconditioner factors applied. +C Call routine DORTH to orthogonalize the new vector VNEW = V(*,LL+1). +C call routine DHEQR to update the factors of HES. +C----------------------------------------------------------------------- + CALL DATV (NEQ, Y, TN, YPRIME, SAVR, V(1,LL), WGHT, Z, + 1 RES, IRES, PSOL, V(1,LL+1), WK, WP, IWP, CJ, EPLIN, + 1 IER, NRE, NPSL, RPAR, IPAR) + IF (IRES .LT. 0) RETURN + IF (IER .NE. 0) GO TO 300 + CALL DORTH (V(1,LL+1), V, HES, NEQ, LL, MAXLP1, KMP, SNORMW) + HES(LL+1,LL) = SNORMW + CALL DHEQR (HES, MAXLP1, LL, Q, INFO, LL) + IF (INFO .EQ. LL) GO TO 120 +C----------------------------------------------------------------------- +C Update RHO, the estimate of the norm of the residual R - A*ZL. +C If KMP .LT. MAXL, then the vectors V(*,1),...,V(*,LL+1) are not +C necessarily orthogonal for LL .GT. KMP. The vector DL must then +C be computed, and its norm used in the calculation of RHO. +C----------------------------------------------------------------------- + PROD = PROD*Q(2*LL) + RHO = ABS(PROD*RNRM) + IF ((LL.GT.KMP) .AND. (KMP.LT.MAXL)) THEN + IF (LL .EQ. KMP+1) THEN + CALL DCOPY (NEQ, V(1,1), 1, DL, 1) + DO 75 I = 1,KMP + IP1 = I + 1 + I2 = I*2 + S = Q(I2) + C = Q(I2-1) + DO 70 K = 1,NEQ + 70 DL(K) = S*DL(K) + C*V(K,IP1) + 75 CONTINUE + ENDIF + S = Q(2*LL) + C = Q(2*LL-1)/SNORMW + LLP1 = LL + 1 + DO 80 K = 1,NEQ + 80 DL(K) = S*DL(K) + C*V(K,LLP1) + DLNRM = DNRM2 (NEQ, DL, 1) + RHO = RHO*DLNRM + ENDIF +C----------------------------------------------------------------------- +C Test for convergence. If passed, compute approximation ZL. +C If failed and LL .LT. MAXL, then continue iterating. +C----------------------------------------------------------------------- + IF (RHO .LE. EPLIN) GO TO 200 + IF (LL .EQ. MAXL) GO TO 100 +C----------------------------------------------------------------------- +C Rescale so that the norm of V(1,LL+1) is one. +C----------------------------------------------------------------------- + TEM = 1.0D0/SNORMW + CALL DSCAL (NEQ, TEM, V(1,LL+1), 1) + 90 CONTINUE + 100 CONTINUE + IF (RHO .LT. RNRM) GO TO 150 + 120 CONTINUE + IFLAG = 2 + DO 130 I = 1,NEQ + 130 Z(I) = 0.D0 + RETURN + 150 IFLAG = 1 +C----------------------------------------------------------------------- +C The tolerance was not met, but the residual norm was reduced. +C If performing restarting (IRST .gt. 0) calculate the residual vector +C RL and store it in the DL array. If the incomplete version is +C being used (KMP .lt. MAXL) then DL has already been calculated. +C----------------------------------------------------------------------- + IF (IRST .GT. 0) THEN + IF (KMP .EQ. MAXL) THEN +C +C Calculate DL from the V(I)'s. +C + CALL DCOPY (NEQ, V(1,1), 1, DL, 1) + MAXLM1 = MAXL - 1 + DO 175 I = 1,MAXLM1 + IP1 = I + 1 + I2 = I*2 + S = Q(I2) + C = Q(I2-1) + DO 170 K = 1,NEQ + 170 DL(K) = S*DL(K) + C*V(K,IP1) + 175 CONTINUE + S = Q(2*MAXL) + C = Q(2*MAXL-1)/SNORMW + DO 180 K = 1,NEQ + 180 DL(K) = S*DL(K) + C*V(K,MAXLP1) + ENDIF +C +C Scale DL by RNRM*PROD to obtain the residual RL. +C + TEM = RNRM*PROD + CALL DSCAL(NEQ, TEM, DL, 1) + ENDIF +C----------------------------------------------------------------------- +C Compute the approximation ZL to the solution. +C Since the vector Z was used as work space, and the initial guess +C of the Newton correction is zero, Z must be reset to zero. +C----------------------------------------------------------------------- + 200 CONTINUE + LL = LGMR + LLP1 = LL + 1 + DO 210 K = 1,LLP1 + 210 R(K) = 0.0D0 + R(1) = RNRM + CALL DHELS (HES, MAXLP1, LL, Q, R) + DO 220 K = 1,NEQ + 220 Z(K) = 0.0D0 + DO 230 I = 1,LL + CALL DAXPY (NEQ, R(I), V(1,I), 1, Z, 1) + 230 CONTINUE + DO 240 I = 1,NEQ + 240 Z(I) = Z(I)/WGHT(I) +C Load RHO into RHOK. + RHOK = RHO + RETURN +C----------------------------------------------------------------------- +C This block handles error returns forced by routine PSOL. +C----------------------------------------------------------------------- + 300 CONTINUE + IF (IER .LT. 0) IFLAG = -1 + IF (IER .GT. 0) IFLAG = 3 +C + RETURN +C +C------END OF SUBROUTINE DSPIGM----------------------------------------- + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/daspk/dyypnw.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,58 @@ +C Work performed under the auspices of the U.S. Department of Energy +C by Lawrence Livermore National Laboratory under contract number +C W-7405-Eng-48. +C + SUBROUTINE DYYPNW (NEQ, Y, YPRIME, CJ, RL, P, ICOPT, ID, + * YNEW, YPNEW) +C +C***BEGIN PROLOGUE DYYPNW +C***REFER TO DLINSK +C***DATE WRITTEN 940830 (YYMMDD) +C +C +C----------------------------------------------------------------------- +C***DESCRIPTION +C +C DYYPNW calculates the new (Y,YPRIME) pair needed in the +C linesearch algorithm based on the current lambda value. It is +C called by DLINSK and DLINSD. Based on the ICOPT and ID values, +C the corresponding entry in Y or YPRIME is updated. +C +C In addition to the parameters described in the calling programs, +C the parameters represent +C +C P -- Array of length NEQ that contains the current +C approximate Newton step. +C RL -- Scalar containing the current lambda value. +C YNEW -- Array of length NEQ containing the updated Y vector. +C YPNEW -- Array of length NEQ containing the updated YPRIME +C vector. +C----------------------------------------------------------------------- +C +C***ROUTINES CALLED (NONE) +C +C***END PROLOGUE DYYPNW +C +C + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + DIMENSION Y(*), YPRIME(*), YNEW(*), YPNEW(*), ID(*), P(*) +C + IF (ICOPT .EQ. 1) THEN + DO 10 I=1,NEQ + IF(ID(I) .LT. 0) THEN + YNEW(I) = Y(I) - RL*P(I) + YPNEW(I) = YPRIME(I) + ELSE + YNEW(I) = Y(I) + YPNEW(I) = YPRIME(I) - RL*CJ*P(I) + ENDIF + 10 CONTINUE + ELSE + DO 20 I = 1,NEQ + YNEW(I) = Y(I) - RL*P(I) + YPNEW(I) = YPRIME(I) + 20 CONTINUE + ENDIF + RETURN +C----------------------- END OF SUBROUTINE DYYPNW ---------------------- + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/daspk/module.mk Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,29 @@ +EXTERNAL_SOURCES += \ + liboctave/external/daspk/datv.f \ + liboctave/external/daspk/dcnst0.f \ + liboctave/external/daspk/dcnstr.f \ + liboctave/external/daspk/ddasic.f \ + liboctave/external/daspk/ddasid.f \ + liboctave/external/daspk/ddasik.f \ + liboctave/external/daspk/ddaspk.f \ + liboctave/external/daspk/ddstp.f \ + liboctave/external/daspk/ddwnrm.f \ + liboctave/external/daspk/dfnrmd.f \ + liboctave/external/daspk/dfnrmk.f \ + liboctave/external/daspk/dhels.f \ + liboctave/external/daspk/dheqr.f \ + liboctave/external/daspk/dinvwt.f \ + liboctave/external/daspk/dlinsd.f \ + liboctave/external/daspk/dlinsk.f \ + liboctave/external/daspk/dmatd.f \ + liboctave/external/daspk/dnedd.f \ + liboctave/external/daspk/dnedk.f \ + liboctave/external/daspk/dnsd.f \ + liboctave/external/daspk/dnsid.f \ + liboctave/external/daspk/dnsik.f \ + liboctave/external/daspk/dnsk.f \ + liboctave/external/daspk/dorth.f \ + liboctave/external/daspk/dslvd.f \ + liboctave/external/daspk/dslvk.f \ + liboctave/external/daspk/dspigm.f \ + liboctave/external/daspk/dyypnw.f
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/dasrt/ddasrt.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,1559 @@ + SUBROUTINE DDASRT (RES,NEQ,T,Y,YPRIME,TOUT, + * INFO,RTOL,ATOL,IDID,RWORK,LRW,IWORK,LIW,RPAR,IPAR,JAC, + * G,NG,JROOT) +C +C***BEGIN PROLOGUE DDASRT +C***DATE WRITTEN 821001 (YYMMDD) +C***REVISION DATE 910624 (YYMMDD) +C***KEYWORDS DIFFERENTIAL/ALGEBRAIC,BACKWARD DIFFERENTIATION FORMULAS +C IMPLICIT DIFFERENTIAL SYSTEMS +C***AUTHOR PETZOLD,LINDA R.,COMPUTING AND MATHEMATICS RESEARCH DIVISION +C LAWRENCE LIVERMORE NATIONAL LABORATORY +C L - 316, P.O. Box 808, +C LIVERMORE, CA. 94550 +C***PURPOSE This code solves a system of differential/algebraic +C equations of the form F(T,Y,YPRIME) = 0. +C***DESCRIPTION +C +C *Usage: +C +C IMPLICIT DOUBLE PRECISION (A-H,O-Z) +C EXTERNAL RES, JAC, G +C INTEGER NEQ, INFO(N), IDID, LRW, LIW, IWORK(LIW), IPAR, NG, +C * JROOT(NG) +C DOUBLE PRECISION T, Y(NEQ), YPRIME(NEQ), TOUT, RTOL, ATOL, +C * RWORK(LRW), RPAR +C +C CALL DDASRT (RES, NEQ, T, Y, YPRIME, TOUT, INFO, RTOL, ATOL, +C * IDID, RWORK, LRW, IWORK, LIW, RPAR, IPAR, JAC) +C +C +C +C *Arguments: +C +C RES:EXT This is a subroutine which you provide to define the +C differential/algebraic system. +C +C NEQ:IN This is the number of equations to be solved. +C +C T:INOUT This is the current value of the independent variable. +C +C Y(*):INOUT This array contains the solution components at T. +C +C YPRIME(*):INOUT This array contains the derivatives of the solution +C components at T. +C +C TOUT:IN This is a point at which a solution is desired. +C +C INFO(N):IN The basic task of the code is to solve the system from T +C to TOUT and return an answer at TOUT. INFO is an integer +C array which is used to communicate exactly how you want +C this task to be carried out. N must be greater than or +C equal to 15. +C +C RTOL,ATOL:INOUT These quantities represent absolute and relative +C error tolerances which you provide to indicate how +C accurately you wish the solution to be computed. +C You may choose them to be both scalars or else +C both vectors. +C +C IDID:OUT This scalar quantity is an indicator reporting what the +C code did. You must monitor this integer variable to decide +C what action to take next. +C +C RWORK:WORK A real work array of length LRW which provides the +C code with needed storage space. +C +C LRW:IN The length of RWORK. +C +C IWORK:WORK An integer work array of length LIW which probides the +C code with needed storage space. +C +C LIW:IN The length of IWORK. +C +C RPAR,IPAR:IN These are real and integer parameter arrays which +C you can use for communication between your calling +C program and the RES subroutine (and the JAC subroutine) +C +C JAC:EXT This is the name of a subroutine which you may choose to +C provide for defining a matrix of partial derivatives +C described below. +C +C G This is the name of the subroutine for defining +C constraint functions, G(T,Y), whose roots are desired +C during the integration. This name must be declared +C external in the calling program. +C +C NG This is the number of constraint functions G(I). +C If there are none, set NG=0, and pass a dummy name +C for G. +C +C JROOT This is an integer array of length NG for output +C of root information. +C +C +C *Description +C +C QUANTITIES WHICH MAY BE ALTERED BY THE CODE ARE +C T,Y(*),YPRIME(*),INFO(1),RTOL,ATOL, +C IDID,RWORK(*) AND IWORK(*). +C +C Subroutine DDASRT uses the backward differentiation formulas of +C orders one through five to solve a system of the above form for Y and +C YPRIME. Values for Y and YPRIME at the initial time must be given as +C input. These values must be consistent, (that is, if T,Y,YPRIME are +C the given initial values, they must satisfy F(T,Y,YPRIME) = 0.). The +C subroutine solves the system from T to TOUT. +C It is easy to continue the solution to get results at additional +C TOUT. This is the interval mode of operation. Intermediate results +C can also be obtained easily by using the intermediate-output +C capability. If DDASRT detects a sign-change in G(T,Y), then +C it will return the intermediate value of T and Y for which +C G(T,Y) = 0. +C +C ---------INPUT-WHAT TO DO ON THE FIRST CALL TO DDASRT--------------- +C +C +C The first call of the code is defined to be the start of each new +C problem. Read through the descriptions of all the following items, +C provide sufficient storage space for designated arrays, set +C appropriate variables for the initialization of the problem, and +C give information about how you want the problem to be solved. +C +C +C RES -- Provide a subroutine of the form +C SUBROUTINE RES(T,Y,YPRIME,DELTA,IRES,RPAR,IPAR) +C to define the system of differential/algebraic +C equations which is to be solved. For the given values +C of T,Y and YPRIME, the subroutine should +C return the residual of the defferential/algebraic +C system +C DELTA = F(T,Y,YPRIME) +C (DELTA(*) is a vector of length NEQ which is +C output for RES.) +C +C Subroutine RES must not alter T,Y or YPRIME. +C You must declare the name RES in an external +C statement in your program that calls DDASRT. +C You must dimension Y,YPRIME and DELTA in RES. +C +C IRES is an integer flag which is always equal to +C zero on input. Subroutine RES should alter IRES +C only if it encounters an illegal value of Y or +C a stop condition. Set IRES = -1 if an input value +C is illegal, and DDASRT will try to solve the problem +C without getting IRES = -1. If IRES = -2, DDASRT +C will return control to the calling program +C with IDID = -11. +C +C RPAR and IPAR are real and integer parameter arrays which +C you can use for communication between your calling program +C and subroutine RES. They are not altered by DDASRT. If you +C do not need RPAR or IPAR, ignore these parameters by treat- +C ing them as dummy arguments. If you do choose to use them, +C dimension them in your calling program and in RES as arrays +C of appropriate length. +C +C NEQ -- Set it to the number of differential equations. +C (NEQ .GE. 1) +C +C T -- Set it to the initial point of the integration. +C T must be defined as a variable. +C +C Y(*) -- Set this vector to the initial values of the NEQ solution +C components at the initial point. You must dimension Y of +C length at least NEQ in your calling program. +C +C YPRIME(*) -- Set this vector to the initial values of +C the NEQ first derivatives of the solution +C components at the initial point. You +C must dimension YPRIME at least NEQ +C in your calling program. If you do not +C know initial values of some of the solution +C components, see the explanation of INFO(11). +C +C TOUT - Set it to the first point at which a solution +C is desired. You can not take TOUT = T. +C integration either forward in T (TOUT .GT. T) or +C backward in T (TOUT .LT. T) is permitted. +C +C The code advances the solution from T to TOUT using +C step sizes which are automatically selected so as to +C achieve the desired accuracy. If you wish, the code will +C return with the solution and its derivative at +C intermediate steps (intermediate-output mode) so that +C you can monitor them, but you still must provide TOUT in +C accord with the basic aim of the code. +C +C the first step taken by the code is a critical one +C because it must reflect how fast the solution changes near +C the initial point. The code automatically selects an +C initial step size which is practically always suitable for +C the problem. By using the fact that the code will not step +C past TOUT in the first step, you could, if necessary, +C restrict the length of the initial step size. +C +C For some problems it may not be permissable to integrate +C past a point TSTOP because a discontinuity occurs there +C or the solution or its derivative is not defined beyond +C TSTOP. When you have declared a TSTOP point (SEE INFO(4) +C and RWORK(1)), you have told the code not to integrate +C past TSTOP. In this case any TOUT beyond TSTOP is invalid +C input. +C +C INFO(*) - Use the INFO array to give the code more details about +C how you want your problem solved. This array should be +C dimensioned of length 15, though DDASRT uses +C only the first twelve entries. You must respond to all of +C the following items which are arranged as questions. The +C simplest use of the code corresponds to answering all +C questions as yes, i.e. setting all entries of INFO to 0. +C +C INFO(1) - This parameter enables the code to initialize +C itself. You must set it to indicate the start of every +C new problem. +C +C **** Is this the first call for this problem ... +C Yes - Set INFO(1) = 0 +C No - Not applicable here. +C See below for continuation calls. **** +C +C INFO(2) - How much accuracy you want of your solution +C is specified by the error tolerances RTOL and ATOL. +C The simplest use is to take them both to be scalars. +C To obtain more flexibility, they can both be vectors. +C The code must be told your choice. +C +C **** Are both error tolerances RTOL, ATOL scalars ... +C Yes - Set INFO(2) = 0 +C and input scalars for both RTOL and ATOL +C No - Set INFO(2) = 1 +C and input arrays for both RTOL and ATOL **** +C +C INFO(3) - The code integrates from T in the direction +C of TOUT by steps. If you wish, it will return the +C computed solution and derivative at the next +C intermediate step (the intermediate-output mode) or +C TOUT, whichever comes first. This is a good way to +C proceed if you want to see the behavior of the solution. +C If you must have solutions at a great many specific +C TOUT points, this code will compute them efficiently. +C +C **** Do you want the solution only at +C TOUT (and not at the next intermediate step) ... +C Yes - Set INFO(3) = 0 +C No - Set INFO(3) = 1 **** +C +C INFO(4) - To handle solutions at a great many specific +C values TOUT efficiently, this code may integrate past +C TOUT and interpolate to obtain the result at TOUT. +C Sometimes it is not possible to integrate beyond some +C point TSTOP because the equation changes there or it is +C not defined past TSTOP. Then you must tell the code +C not to go past. +C +C **** Can the integration be carried out without any +C restrictions on the independent variable T ... +C Yes - Set INFO(4)=0 +C No - Set INFO(4)=1 +C and define the stopping point TSTOP by +C setting RWORK(1)=TSTOP **** +C +C INFO(5) - To solve differential/algebraic problems it is +C necessary to use a matrix of partial derivatives of the +C system of differential equations. If you do not +C provide a subroutine to evaluate it analytically (see +C description of the item JAC in the call list), it will +C be approximated by numerical differencing in this code. +C although it is less trouble for you to have the code +C compute partial derivatives by numerical differencing, +C the solution will be more reliable if you provide the +C derivatives via JAC. Sometimes numerical differencing +C is cheaper than evaluating derivatives in JAC and +C sometimes it is not - this depends on your problem. +C +C **** Do you want the code to evaluate the partial +C derivatives automatically by numerical differences ... +C Yes - Set INFO(5)=0 +C No - Set INFO(5)=1 +C and provide subroutine JAC for evaluating the +C matrix of partial derivatives **** +C +C INFO(6) - DDASRT will perform much better if the matrix of +C partial derivatives, DG/DY + CJ*DG/DYPRIME, +C (here CJ is a scalar determined by DDASRT) +C is banded and the code is told this. In this +C case, the storage needed will be greatly reduced, +C numerical differencing will be performed much cheaper, +C and a number of important algorithms will execute much +C faster. The differential equation is said to have +C half-bandwidths ML (lower) and MU (upper) if equation i +C involves only unknowns Y(J) with +C I-ML .LE. J .LE. I+MU +C for all I=1,2,...,NEQ. Thus, ML and MU are the widths +C of the lower and upper parts of the band, respectively, +C with the main diagonal being excluded. If you do not +C indicate that the equation has a banded matrix of partial +C derivatives, the code works with a full matrix of NEQ**2 +C elements (stored in the conventional way). Computations +C with banded matrices cost less time and storage than with +C full matrices if 2*ML+MU .LT. NEQ. If you tell the +C code that the matrix of partial derivatives has a banded +C structure and you want to provide subroutine JAC to +C compute the partial derivatives, then you must be careful +C to store the elements of the matrix in the special form +C indicated in the description of JAC. +C +C **** Do you want to solve the problem using a full +C (dense) matrix (and not a special banded +C structure) ... +C Yes - Set INFO(6)=0 +C No - Set INFO(6)=1 +C and provide the lower (ML) and upper (MU) +C bandwidths by setting +C IWORK(1)=ML +C IWORK(2)=MU **** +C +C +C INFO(7) -- You can specify a maximum (absolute value of) +C stepsize, so that the code +C will avoid passing over very +C large regions. +C +C **** Do you want the code to decide +C on its own maximum stepsize? +C Yes - Set INFO(7)=0 +C No - Set INFO(7)=1 +C and define HMAX by setting +C RWORK(2)=HMAX **** +C +C INFO(8) -- Differential/algebraic problems +C may occaisionally suffer from +C severe scaling difficulties on the +C first step. If you know a great deal +C about the scaling of your problem, you can +C help to alleviate this problem by +C specifying an initial stepsize H0. +C +C **** Do you want the code to define +C its own initial stepsize? +C Yes - Set INFO(8)=0 +C No - Set INFO(8)=1 +C and define H0 by setting +C RWORK(3)=H0 **** +C +C INFO(9) -- If storage is a severe problem, +C you can save some locations by +C restricting the maximum order MAXORD. +C the default value is 5. for each +C order decrease below 5, the code +C requires NEQ fewer locations, however +C it is likely to be slower. In any +C case, you must have 1 .LE. MAXORD .LE. 5 +C **** Do you want the maximum order to +C default to 5? +C Yes - Set INFO(9)=0 +C No - Set INFO(9)=1 +C and define MAXORD by setting +C IWORK(3)=MAXORD **** +C +C INFO(10) --If you know that the solutions to your equations +C will always be nonnegative, it may help to set this +C parameter. However, it is probably best to +C try the code without using this option first, +C and only to use this option if that doesn't +C work very well. +C **** Do you want the code to solve the problem without +C invoking any special nonnegativity constraints? +C Yes - Set INFO(10)=0 +C No - Set INFO(10)=1 +C +C INFO(11) --DDASRT normally requires the initial T, +C Y, and YPRIME to be consistent. That is, +C you must have F(T,Y,YPRIME) = 0 at the initial +C time. If you do not know the initial +C derivative precisely, you can let DDASRT try +C to compute it. +C **** Are the initial T, Y, YPRIME consistent? +C Yes - Set INFO(11) = 0 +C No - Set INFO(11) = 1, +C and set YPRIME to an initial approximation +C to YPRIME. (If you have no idea what +C YPRIME should be, set it to zero. Note +C that the initial Y should be such +C that there must exist a YPRIME so that +C F(T,Y,YPRIME) = 0.) +C +C INFO(12) --Maximum number of steps. +C **** Do you want to let DDASRT use the default limit for +C the number of steps? +C Yes - Set INFO(12) = 0 +C No - Set INFO(12) = 1, +C and define the maximum number of steps +C by setting IWORK(21)=MXSTEP +C +C RTOL, ATOL -- You must assign relative (RTOL) and absolute (ATOL +C error tolerances to tell the code how accurately you +C want the solution to be computed. They must be defined +C as variables because the code may change them. You +C have two choices -- +C Both RTOL and ATOL are scalars. (INFO(2)=0) +C Both RTOL and ATOL are vectors. (INFO(2)=1) +C in either case all components must be non-negative. +C +C The tolerances are used by the code in a local error +C test at each step which requires roughly that +C ABS(LOCAL ERROR) .LE. RTOL*ABS(Y)+ATOL +C for each vector component. +C (More specifically, a root-mean-square norm is used to +C measure the size of vectors, and the error test uses the +C magnitude of the solution at the beginning of the step.) +C +C The true (global) error is the difference between the +C true solution of the initial value problem and the +C computed approximation. Practically all present day +C codes, including this one, control the local error at +C each step and do not even attempt to control the global +C error directly. +C Usually, but not always, the true accuracy of the +C computed Y is comparable to the error tolerances. This +C code will usually, but not always, deliver a more +C accurate solution if you reduce the tolerances and +C integrate again. By comparing two such solutions you +C can get a fairly reliable idea of the true error in the +C solution at the bigger tolerances. +C +C Setting ATOL=0. results in a pure relative error test on +C that component. Setting RTOL=0. results in a pure +C absolute error test on that component. A mixed test +C with non-zero RTOL and ATOL corresponds roughly to a +C relative error test when the solution component is much +C bigger than ATOL and to an absolute error test when the +C solution component is smaller than the threshhold ATOL. +C +C The code will not attempt to compute a solution at an +C accuracy unreasonable for the machine being used. It +C will advise you if you ask for too much accuracy and +C inform you as to the maximum accuracy it believes +C possible. +C +C RWORK(*) -- Dimension this real work array of length LRW in your +C calling program. +C +C LRW -- Set it to the declared length of the RWORK array. +C You must have +C LRW .GE. 50+(MAXORD+4)*NEQ+NEQ**2+3*NG +C for the full (dense) JACOBIAN case (when INFO(6)=0), or +C LRW .GE. 50+(MAXORD+4)*NEQ+(2*ML+MU+1)*NEQ+3*NG +C for the banded user-defined JACOBIAN case +C (when INFO(5)=1 and INFO(6)=1), or +C LRW .GE. 50+(MAXORD+4)*NEQ+(2*ML+MU+1)*NEQ +C +2*(NEQ/(ML+MU+1)+1)+3*NG +C for the banded finite-difference-generated JACOBIAN case +C (when INFO(5)=0 and INFO(6)=1) +C +C IWORK(*) -- Dimension this integer work array of length LIW in +C your calling program. +C +C LIW -- Set it to the declared length of the IWORK array. +C you must have LIW .GE. 21+NEQ +C +C RPAR, IPAR -- These are parameter arrays, of real and integer +C type, respectively. You can use them for communication +C between your program that calls DDASRT and the +C RES subroutine (and the JAC subroutine). They are not +C altered by DDASRT. If you do not need RPAR or IPAR, +C ignore these parameters by treating them as dummy +C arguments. If you do choose to use them, dimension +C them in your calling program and in RES (and in JAC) +C as arrays of appropriate length. +C +C JAC -- If you have set INFO(5)=0, you can ignore this parameter +C by treating it as a dummy argument. Otherwise, you must +C provide a subroutine of the form +C JAC(T,Y,YPRIME,PD,CJ,RPAR,IPAR) +C to define the matrix of partial derivatives +C PD=DG/DY+CJ*DG/DYPRIME +C CJ is a scalar which is input to JAC. +C For the given values of T,Y,YPRIME, the +C subroutine must evaluate the non-zero partial +C derivatives for each equation and each solution +C component, and store these values in the +C matrix PD. The elements of PD are set to zero +C before each call to JAC so only non-zero elements +C need to be defined. +C +C Subroutine JAC must not alter T,Y,(*),YPRIME(*), or CJ. +C You must declare the name JAC in an +C EXTERNAL STATEMENT in your program that calls +C DDASRT. You must dimension Y, YPRIME and PD +C in JAC. +C +C The way you must store the elements into the PD matrix +C depends on the structure of the matrix which you +C indicated by INFO(6). +C *** INFO(6)=0 -- Full (dense) matrix *** +C Give PD a first dimension of NEQ. +C When you evaluate the (non-zero) partial derivative +C of equation I with respect to variable J, you must +C store it in PD according to +C PD(I,J) = * DF(I)/DY(J)+CJ*DF(I)/DYPRIME(J)* +C *** INFO(6)=1 -- Banded JACOBIAN with ML lower and MU +C upper diagonal bands (refer to INFO(6) description +C of ML and MU) *** +C Give PD a first dimension of 2*ML+MU+1. +C when you evaluate the (non-zero) partial derivative +C of equation I with respect to variable J, you must +C store it in PD according to +C IROW = I - J + ML + MU + 1 +C PD(IROW,J) = *DF(I)/DY(J)+CJ*DF(I)/DYPRIME(J)* +C RPAR and IPAR are real and integer parameter arrays +C which you can use for communication between your calling +C program and your JACOBIAN subroutine JAC. They are not +C altered by DDASRT. If you do not need RPAR or IPAR, +C ignore these parameters by treating them as dummy +C arguments. If you do choose to use them, dimension +C them in your calling program and in JAC as arrays of +C appropriate length. +C +C G -- This is the name of the subroutine for defining constraint +C functions, whose roots are desired during the +C integration. It is to have the form +C SUBROUTINE G(NEQ,T,Y,NG,GOUT,RPAR,IPAR) +C DIMENSION Y(NEQ),GOUT(NG), +C where NEQ, T, Y and NG are INPUT, and the array GOUT is +C output. NEQ, T, and Y have the same meaning as in the +C RES routine, and GOUT is an array of length NG. +C For I=1,...,NG, this routine is to load into GOUT(I) +C the value at (T,Y) of the I-th constraint function G(I). +C DDASRT will find roots of the G(I) of odd multiplicity +C (that is, sign changes) as they occur during +C the integration. G must be declared EXTERNAL in the +C calling program. +C +C CAUTION..because of numerical errors in the functions +C G(I) due to roundoff and integration error, DDASRT +C may return false roots, or return the same root at two +C or more nearly equal values of T. If such false roots +C are suspected, the user should consider smaller error +C tolerances and/or higher precision in the evaluation of +C the G(I). +C +C If a root of some G(I) defines the end of the problem, +C the input to DDASRT should nevertheless allow +C integration to a point slightly past that ROOT, so +C that DDASRT can locate the root by interpolation. +C +C NG -- The number of constraint functions G(I). If there are none, +C set NG = 0, and pass a dummy name for G. +C +C JROOT -- This is an integer array of length NG. It is used only for +C output. On a return where one or more roots have been +C found, JROOT(I)=1 If G(I) has a root at T, +C or JROOT(I)=0 if not. +C +C +C +C OPTIONALLY REPLACEABLE NORM ROUTINE: +C DDASRT uses a weighted norm DDANRM to measure the size +C of vectors such as the estimated error in each step. +C A FUNCTION subprogram +C DOUBLE PRECISION FUNCTION DDANRM(NEQ,V,WT,RPAR,IPAR) +C DIMENSION V(NEQ),WT(NEQ) +C is used to define this norm. Here, V is the vector +C whose norm is to be computed, and WT is a vector of +C weights. A DDANRM routine has been included with DDASRT +C which computes the weighted root-mean-square norm +C given by +C DDANRM=SQRT((1/NEQ)*SUM(V(I)/WT(I))**2) +C this norm is suitable for most problems. In some +C special cases, it may be more convenient and/or +C efficient to define your own norm by writing a function +C subprogram to be called instead of DDANRM. This should +C ,however, be attempted only after careful thought and +C consideration. +C +C +C------OUTPUT-AFTER ANY RETURN FROM DDASRT---- +C +C The principal aim of the code is to return a computed solution at +C TOUT, although it is also possible to obtain intermediate results +C along the way. To find out whether the code achieved its goal +C or if the integration process was interrupted before the task was +C completed, you must check the IDID parameter. +C +C +C T -- The solution was successfully advanced to the +C output value of T. +C +C Y(*) -- Contains the computed solution approximation at T. +C +C YPRIME(*) -- Contains the computed derivative +C approximation at T. +C +C IDID -- Reports what the code did. +C +C *** Task completed *** +C Reported by positive values of IDID +C +C IDID = 1 -- A step was successfully taken in the +C intermediate-output mode. The code has not +C yet reached TOUT. +C +C IDID = 2 -- The integration to TSTOP was successfully +C completed (T=TSTOP) by stepping exactly to TSTOP. +C +C IDID = 3 -- The integration to TOUT was successfully +C completed (T=TOUT) by stepping past TOUT. +C Y(*) is obtained by interpolation. +C YPRIME(*) is obtained by interpolation. +C +C IDID = 4 -- The integration was successfully completed +C by finding one or more roots of G at T. +C +C *** Task interrupted *** +C Reported by negative values of IDID +C +C IDID = -1 -- A large amount of work has been expended. +C (About INFO(12) steps) +C +C IDID = -2 -- The error tolerances are too stringent. +C +C IDID = -3 -- The local error test cannot be satisfied +C because you specified a zero component in ATOL +C and the corresponding computed solution +C component is zero. Thus, a pure relative error +C test is impossible for this component. +C +C IDID = -6 -- DDASRT had repeated error test +C failures on the last attempted step. +C +C IDID = -7 -- The corrector could not converge. +C +C IDID = -8 -- The matrix of partial derivatives +C is singular. +C +C IDID = -9 -- The corrector could not converge. +C there were repeated error test failures +C in this step. +C +C IDID =-10 -- The corrector could not converge +C because IRES was equal to minus one. +C +C IDID =-11 -- IRES equal to -2 was encountered +C and control is being returned to the +C calling program. +C +C IDID =-12 -- DDASRT failed to compute the initial +C YPRIME. +C +C +C +C IDID = -13,..,-32 -- Not applicable for this code +C +C *** Task terminated *** +C Reported by the value of IDID=-33 +C +C IDID = -33 -- The code has encountered trouble from which +C it cannot recover. A message is printed +C explaining the trouble and control is returned +C to the calling program. For example, this occurs +C when invalid input is detected. +C +C RTOL, ATOL -- These quantities remain unchanged except when +C IDID = -2. In this case, the error tolerances have been +C increased by the code to values which are estimated to +C be appropriate for continuing the integration. However, +C the reported solution at T was obtained using the input +C values of RTOL and ATOL. +C +C RWORK, IWORK -- Contain information which is usually of no +C interest to the user but necessary for subsequent calls. +C However, you may find use for +C +C RWORK(3)--Which contains the step size H to be +C attempted on the next step. +C +C RWORK(4)--Which contains the current value of the +C independent variable, i.e., the farthest point +C integration has reached. This will be different +C from T only when interpolation has been +C performed (IDID=3). +C +C RWORK(7)--Which contains the stepsize used +C on the last successful step. +C +C IWORK(7)--Which contains the order of the method to +C be attempted on the next step. +C +C IWORK(8)--Which contains the order of the method used +C on the last step. +C +C IWORK(11)--Which contains the number of steps taken so +C far. +C +C IWORK(12)--Which contains the number of calls to RES +C so far. +C +C IWORK(13)--Which contains the number of evaluations of +C the matrix of partial derivatives needed so +C far. +C +C IWORK(14)--Which contains the total number +C of error test failures so far. +C +C IWORK(15)--Which contains the total number +C of convergence test failures so far. +C (includes singular iteration matrix +C failures.) +C +C IWORK(16)--Which contains the total number of calls +C to the constraint function g so far +C +C +C +C INPUT -- What to do to continue the integration +C (calls after the first) ** +C +C This code is organized so that subsequent calls to continue the +C integration involve little (if any) additional effort on your +C part. You must monitor the IDID parameter in order to determine +C what to do next. +C +C Recalling that the principal task of the code is to integrate +C from T to TOUT (the interval mode), usually all you will need +C to do is specify a new TOUT upon reaching the current TOUT. +C +C Do not alter any quantity not specifically permitted below, +C in particular do not alter NEQ,T,Y(*),YPRIME(*),RWORK(*),IWORK(*) +C or the differential equation in subroutine RES. Any such +C alteration constitutes a new problem and must be treated as such, +C i.e., you must start afresh. +C +C You cannot change from vector to scalar error control or vice +C versa (INFO(2)), but you can change the size of the entries of +C RTOL, ATOL. Increasing a tolerance makes the equation easier +C to integrate. Decreasing a tolerance will make the equation +C harder to integrate and should generally be avoided. +C +C You can switch from the intermediate-output mode to the +C interval mode (INFO(3)) or vice versa at any time. +C +C If it has been necessary to prevent the integration from going +C past a point TSTOP (INFO(4), RWORK(1)), keep in mind that the +C code will not integrate to any TOUT beyond the currently +C specified TSTOP. Once TSTOP has been reached you must change +C the value of TSTOP or set INFO(4)=0. You may change INFO(4) +C or TSTOP at any time but you must supply the value of TSTOP in +C RWORK(1) whenever you set INFO(4)=1. +C +C Do not change INFO(5), INFO(6), IWORK(1), or IWORK(2) +C unless you are going to restart the code. +C +C *** Following a completed task *** +C If +C IDID = 1, call the code again to continue the integration +C another step in the direction of TOUT. +C +C IDID = 2 or 3, define a new TOUT and call the code again. +C TOUT must be different from T. You cannot change +C the direction of integration without restarting. +C +C IDID = 4, call the code again to continue the integration +C another step in the direction of TOUT. You may +C change the functions in G after a return with IDID=4, +C but the number of constraint functions NG must remain +C the same. If you wish to change +C the functions in RES or in G, then you +C must restart the code. +C +C *** Following an interrupted task *** +C To show the code that you realize the task was +C interrupted and that you want to continue, you +C must take appropriate action and set INFO(1) = 1 +C If +C IDID = -1, The code has reached the step iteration. +C If you want to continue, set INFO(1) = 1 and +C call the code again. See also INFO(12). +C +C IDID = -2, The error tolerances RTOL, ATOL have been +C increased to values the code estimates appropriate +C for continuing. You may want to change them +C yourself. If you are sure you want to continue +C with relaxed error tolerances, set INFO(1)=1 and +C call the code again. +C +C IDID = -3, A solution component is zero and you set the +C corresponding component of ATOL to zero. If you +C are sure you want to continue, you must first +C alter the error criterion to use positive values +C for those components of ATOL corresponding to zero +C solution components, then set INFO(1)=1 and call +C the code again. +C +C IDID = -4,-5 --- Cannot occur with this code. +C +C IDID = -6, Repeated error test failures occurred on the +C last attempted step in DDASRT. A singularity in the +C solution may be present. If you are absolutely +C certain you want to continue, you should restart +C the integration. (Provide initial values of Y and +C YPRIME which are consistent) +C +C IDID = -7, Repeated convergence test failures occurred +C on the last attempted step in DDASRT. An inaccurate +C or ill-conditioned JACOBIAN may be the problem. If +C you are absolutely certain you want to continue, you +C should restart the integration. +C +C IDID = -8, The matrix of partial derivatives is singular. +C Some of your equations may be redundant. +C DDASRT cannot solve the problem as stated. +C It is possible that the redundant equations +C could be removed, and then DDASRT could +C solve the problem. It is also possible +C that a solution to your problem either +C does not exist or is not unique. +C +C IDID = -9, DDASRT had multiple convergence test +C failures, preceeded by multiple error +C test failures, on the last attempted step. +C It is possible that your problem +C is ill-posed, and cannot be solved +C using this code. Or, there may be a +C discontinuity or a singularity in the +C solution. If you are absolutely certain +C you want to continue, you should restart +C the integration. +C +C IDID =-10, DDASRT had multiple convergence test failures +C because IRES was equal to minus one. +C If you are absolutely certain you want +C to continue, you should restart the +C integration. +C +C IDID =-11, IRES=-2 was encountered, and control is being +C returned to the calling program. +C +C IDID =-12, DDASRT failed to compute the initial YPRIME. +C This could happen because the initial +C approximation to YPRIME was not very good, or +C if a YPRIME consistent with the initial Y +C does not exist. The problem could also be caused +C by an inaccurate or singular iteration matrix. +C +C +C +C IDID = -13,..,-32 --- Cannot occur with this code. +C +C *** Following a terminated task *** +C If IDID= -33, you cannot continue the solution of this +C problem. An attempt to do so will result in your +C run being terminated. +C +C --------------------------------------------------------------------- +C +C***REFERENCE +C K. E. Brenan, S. L. Campbell, and L. R. Petzold, Numerical +C Solution of Initial-Value Problems in Differential-Algebraic +C Equations, Elsevier, New York, 1989. +C +C***ROUTINES CALLED DDASTP,DDAINI,DDANRM,DDAWTS,DDATRP,DRCHEK,DROOTS, +C XERRWD,D1MACH +C***END PROLOGUE DDASRT +C +C**End +C + IMPLICIT DOUBLE PRECISION(A-H,O-Z) + LOGICAL DONE + EXTERNAL RES, JAC, G + DIMENSION Y(*),YPRIME(*) + DIMENSION INFO(15) + DIMENSION RWORK(*),IWORK(*) + DIMENSION RTOL(*),ATOL(*) + DIMENSION RPAR(*),IPAR(*) + CHARACTER MSG*80 +C +C SET POINTERS INTO IWORK + PARAMETER (LML=1, LMU=2, LMXORD=3, LMTYPE=4, LNST=11, + * LNRE=12, LNJE=13, LETF=14, LCTF=15, LNGE=16, LNPD=17, + * LIRFND=18, LMXSTP=21, LIPVT=22, LJCALC=5, LPHASE=6, LK=7, + * LKOLD=8, LNS=9, LNSTL=10, LIWM=1) +C +C SET RELATIVE OFFSET INTO RWORK + PARAMETER (NPD=1) +C +C SET POINTERS INTO RWORK + PARAMETER (LTSTOP=1, LHMAX=2, LH=3, LTN=4, + * LCJ=5, LCJOLD=6, LHOLD=7, LS=8, LROUND=9, + * LALPHA=11, LBETA=17, LGAMMA=23, + * LPSI=29, LSIGMA=35, LT0=41, LTLAST=42, LALPHR=43, LX2=44, + * LDELTA=51) +C +C***FIRST EXECUTABLE STATEMENT DDASRT + IF(INFO(1).NE.0)GO TO 100 +C +C----------------------------------------------------------------------- +C THIS BLOCK IS EXECUTED FOR THE INITIAL CALL ONLY. +C IT CONTAINS CHECKING OF INPUTS AND INITIALIZATIONS. +C----------------------------------------------------------------------- +C +C FIRST CHECK INFO ARRAY TO MAKE SURE ALL ELEMENTS OF INFO +C ARE EITHER ZERO OR ONE. + DO 10 I=2,12 + IF(INFO(I).NE.0.AND.INFO(I).NE.1)GO TO 701 +10 CONTINUE +C + IF(NEQ.LE.0)GO TO 702 +C +C CHECK AND COMPUTE MAXIMUM ORDER + MXORD=5 + IF(INFO(9).EQ.0)GO TO 20 + MXORD=IWORK(LMXORD) + IF(MXORD.LT.1.OR.MXORD.GT.5)GO TO 703 +20 IWORK(LMXORD)=MXORD +C +C COMPUTE MTYPE,LENPD,LENRW.CHECK ML AND MU. + IF(INFO(6).NE.0)GO TO 40 + LENPD=NEQ**2 + LENRW=50+(IWORK(LMXORD)+4)*NEQ+LENPD+3*NG + IF(INFO(5).NE.0)GO TO 30 + IWORK(LMTYPE)=2 + GO TO 60 +30 IWORK(LMTYPE)=1 + GO TO 60 +40 IF(IWORK(LML).LT.0.OR.IWORK(LML).GE.NEQ)GO TO 717 + IF(IWORK(LMU).LT.0.OR.IWORK(LMU).GE.NEQ)GO TO 718 + LENPD=(2*IWORK(LML)+IWORK(LMU)+1)*NEQ + IF(INFO(5).NE.0)GO TO 50 + IWORK(LMTYPE)=5 + MBAND=IWORK(LML)+IWORK(LMU)+1 + MSAVE=(NEQ/MBAND)+1 + LENRW=50+(IWORK(LMXORD)+4)*NEQ+LENPD+2*MSAVE+3*NG + GO TO 60 +50 IWORK(LMTYPE)=4 + LENRW=50+(IWORK(LMXORD)+4)*NEQ+LENPD+3*NG +C +C CHECK LENGTHS OF RWORK AND IWORK +60 LENIW=21+NEQ + IWORK(LNPD)=LENPD + IF(LRW.LT.LENRW)GO TO 704 + IF(LIW.LT.LENIW)GO TO 705 +C +C CHECK TO SEE THAT TOUT IS DIFFERENT FROM T +C Also check to see that NG is larger than 0. + IF(TOUT .EQ. T)GO TO 719 + IF(NG .LT. 0) GO TO 730 +C +C CHECK HMAX + IF(INFO(7).EQ.0)GO TO 70 + HMAX=RWORK(LHMAX) + IF(HMAX.LE.0.0D0)GO TO 710 +70 CONTINUE +C +C CHECK AND COMPUTE MAXIMUM STEPS + MXSTP=500 + IF(INFO(12).EQ.0)GO TO 80 + MXSTP=IWORK(LMXSTP) + IF(MXSTP.LT.0)GO TO 716 +80 IWORK(LMXSTP)=MXSTP +C +C INITIALIZE COUNTERS + IWORK(LNST)=0 + IWORK(LNRE)=0 + IWORK(LNJE)=0 + IWORK(LNGE)=0 +C + IWORK(LNSTL)=0 + IDID=1 + GO TO 200 +C +C----------------------------------------------------------------------- +C THIS BLOCK IS FOR CONTINUATION CALLS +C ONLY. HERE WE CHECK INFO(1),AND IF THE +C LAST STEP WAS INTERRUPTED WE CHECK WHETHER +C APPROPRIATE ACTION WAS TAKEN. +C----------------------------------------------------------------------- +C +100 CONTINUE + IF(INFO(1).EQ.1)GO TO 110 + IF(INFO(1).NE.-1)GO TO 701 +C IF WE ARE HERE, THE LAST STEP WAS INTERRUPTED +C BY AN ERROR CONDITION FROM DDASTP,AND +C APPROPRIATE ACTION WAS NOT TAKEN. THIS +C IS A FATAL ERROR. + MSG = 'DASRT-- THE LAST STEP TERMINATED WITH A NEGATIVE' + CALL XERRWD(MSG,49,201,0,0,0,0,0,0.0D0,0.0D0) + MSG = 'DASRT-- VALUE (=I1) OF IDID AND NO APPROPRIATE' + CALL XERRWD(MSG,47,202,0,1,IDID,0,0,0.0D0,0.0D0) + MSG = 'DASRT-- ACTION WAS TAKEN. RUN TERMINATED' + CALL XERRWD(MSG,41,203,1,0,0,0,0,0.0D0,0.0D0) + RETURN +110 CONTINUE + IWORK(LNSTL)=IWORK(LNST) +C +C----------------------------------------------------------------------- +C THIS BLOCK IS EXECUTED ON ALL CALLS. +C THE ERROR TOLERANCE PARAMETERS ARE +C CHECKED, AND THE WORK ARRAY POINTERS +C ARE SET. +C----------------------------------------------------------------------- +C +200 CONTINUE +C CHECK RTOL,ATOL + NZFLG=0 + RTOLI=RTOL(1) + ATOLI=ATOL(1) + DO 210 I=1,NEQ + IF(INFO(2).EQ.1)RTOLI=RTOL(I) + IF(INFO(2).EQ.1)ATOLI=ATOL(I) + IF(RTOLI.GT.0.0D0.OR.ATOLI.GT.0.0D0)NZFLG=1 + IF(RTOLI.LT.0.0D0)GO TO 706 + IF(ATOLI.LT.0.0D0)GO TO 707 +210 CONTINUE + IF(NZFLG.EQ.0)GO TO 708 +C +C SET UP RWORK STORAGE.IWORK STORAGE IS FIXED +C IN DATA STATEMENT. + LG0=LDELTA+NEQ + LG1=LG0+NG + LGX=LG1+NG + LE=LGX+NG + LWT=LE+NEQ + LPHI=LWT+NEQ + LPD=LPHI+(IWORK(LMXORD)+1)*NEQ + LWM=LPD + NTEMP=NPD+IWORK(LNPD) + IF(INFO(1).EQ.1)GO TO 400 +C +C----------------------------------------------------------------------- +C THIS BLOCK IS EXECUTED ON THE INITIAL CALL +C ONLY. SET THE INITIAL STEP SIZE, AND +C THE ERROR WEIGHT VECTOR, AND PHI. +C COMPUTE INITIAL YPRIME, IF NECESSARY. +C----------------------------------------------------------------------- +C +300 CONTINUE + TN=T + IDID=1 +C +C SET ERROR WEIGHT VECTOR WT + CALL DDAWTS(NEQ,INFO(2),RTOL,ATOL,Y,RWORK(LWT),RPAR,IPAR) + DO 305 I = 1,NEQ + IF(RWORK(LWT+I-1).LE.0.0D0) GO TO 713 +305 CONTINUE +C +C COMPUTE UNIT ROUNDOFF AND HMIN + UROUND = D1MACH(4) + RWORK(LROUND) = UROUND + HMIN = 4.0D0*UROUND*DMAX1(DABS(T),DABS(TOUT)) +C +C CHECK INITIAL INTERVAL TO SEE THAT IT IS LONG ENOUGH + TDIST = DABS(TOUT - T) + IF(TDIST .LT. HMIN) GO TO 714 +C +C CHECK H0, IF THIS WAS INPUT + IF (INFO(8) .EQ. 0) GO TO 310 + HO = RWORK(LH) + IF ((TOUT - T)*HO .LT. 0.0D0) GO TO 711 + IF (HO .EQ. 0.0D0) GO TO 712 + GO TO 320 +310 CONTINUE +C +C COMPUTE INITIAL STEPSIZE, TO BE USED BY EITHER +C DDASTP OR DDAINI, DEPENDING ON INFO(11) + HO = 0.001D0*TDIST + YPNORM = DDANRM(NEQ,YPRIME,RWORK(LWT),RPAR,IPAR) + IF (YPNORM .GT. 0.5D0/HO) HO = 0.5D0/YPNORM + HO = DSIGN(HO,TOUT-T) +C ADJUST HO IF NECESSARY TO MEET HMAX BOUND +320 IF (INFO(7) .EQ. 0) GO TO 330 + RH = DABS(HO)/RWORK(LHMAX) + IF (RH .GT. 1.0D0) HO = HO/RH +C COMPUTE TSTOP, IF APPLICABLE +330 IF (INFO(4) .EQ. 0) GO TO 340 + TSTOP = RWORK(LTSTOP) + IF ((TSTOP - T)*HO .LT. 0.0D0) GO TO 715 + IF ((T + HO - TSTOP)*HO .GT. 0.0D0) HO = TSTOP - T + IF ((TSTOP - TOUT)*HO .LT. 0.0D0) GO TO 709 +C +C COMPUTE INITIAL DERIVATIVE, UPDATING TN AND Y, IF APPLICABLE +340 IF (INFO(11) .EQ. 0) GO TO 350 + CALL DDAINI(TN,Y,YPRIME,NEQ, + * RES,JAC,HO,RWORK(LWT),IDID,RPAR,IPAR, + * RWORK(LPHI),RWORK(LDELTA),RWORK(LE), + * RWORK(LWM),IWORK(LIWM),HMIN,RWORK(LROUND), + * INFO(10),NTEMP) + IF (IDID .LT. 0) GO TO 390 +C +C LOAD H WITH H0. STORE H IN RWORK(LH) +350 H = HO + RWORK(LH) = H +C +C LOAD Y AND H*YPRIME INTO PHI(*,1) AND PHI(*,2) +360 ITEMP = LPHI + NEQ + DO 370 I = 1,NEQ + RWORK(LPHI + I - 1) = Y(I) +370 RWORK(ITEMP + I - 1) = H*YPRIME(I) +C +C INITIALIZE T0 IN RWORK AND CHECK FOR A ZERO OF G NEAR THE +C INITIAL T. +C + RWORK(LT0) = T + IWORK(LIRFND) = 0 + RWORK(LPSI)=H + RWORK(LPSI+1)=2.0D0*H + IWORK(LKOLD)=1 + IF(NG .EQ. 0) GO TO 390 + CALL DRCHEK(1,G,NG,NEQ,T,TOUT,Y,RWORK(LE),RWORK(LPHI), + * RWORK(LPSI),IWORK(LKOLD),RWORK(LG0),RWORK(LG1), + * RWORK(LGX),JROOT,IRT,RWORK(LROUND),INFO(3), + * RWORK,IWORK,RPAR,IPAR) + IF(IRT .NE. 0) GO TO 732 +C +C Check for a root in the interval (T0,TN], unless DDASRT +C did not have to initialize YPRIME. +C + IF(NG .EQ. 0 .OR. INFO(11) .EQ. 0) GO TO 390 + CALL DRCHEK(3,G,NG,NEQ,TN,TOUT,Y,RWORK(LE),RWORK(LPHI), + * RWORK(LPSI),IWORK(LKOLD),RWORK(LG0),RWORK(LG1), + * RWORK(LGX),JROOT,IRT,RWORK(LROUND),INFO(3), + * RWORK,IWORK,RPAR,IPAR) + IF(IRT .NE. 1) GO TO 390 + IWORK(LIRFND) = 1 + IDID = 4 + T = RWORK(LT0) + GO TO 580 +C +390 GO TO 500 +C +C------------------------------------------------------- +C THIS BLOCK IS FOR CONTINUATION CALLS ONLY. ITS +C PURPOSE IS TO CHECK STOP CONDITIONS BEFORE +C TAKING A STEP. +C ADJUST H IF NECESSARY TO MEET HMAX BOUND +C------------------------------------------------------- +C +400 CONTINUE + UROUND=RWORK(LROUND) + DONE = .FALSE. + TN=RWORK(LTN) + H=RWORK(LH) + IF(NG .EQ. 0) GO TO 405 +C +C Check for a zero of G near TN. +C + CALL DRCHEK(2,G,NG,NEQ,TN,TOUT,Y,RWORK(LE),RWORK(LPHI), + * RWORK(LPSI),IWORK(LKOLD),RWORK(LG0),RWORK(LG1), + * RWORK(LGX),JROOT,IRT,RWORK(LROUND),INFO(3), + * RWORK,IWORK,RPAR,IPAR) + IF(IRT .NE. 1) GO TO 405 + IWORK(LIRFND) = 1 + IDID = 4 + T = RWORK(LT0) + DONE = .TRUE. + GO TO 490 +C +405 CONTINUE + IF(INFO(7) .EQ. 0) GO TO 410 + RH = DABS(H)/RWORK(LHMAX) + IF(RH .GT. 1.0D0) H = H/RH +410 CONTINUE + IF(T .EQ. TOUT) GO TO 719 + IF((T - TOUT)*H .GT. 0.0D0) GO TO 711 + IF(INFO(4) .EQ. 1) GO TO 430 + IF(INFO(3) .EQ. 1) GO TO 420 + IF((TN-TOUT)*H.LT.0.0D0)GO TO 490 + CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD), + * RWORK(LPHI),RWORK(LPSI)) + T=TOUT + IDID = 3 + DONE = .TRUE. + GO TO 490 +420 IF((TN-T)*H .LE. 0.0D0) GO TO 490 + IF((TN - TOUT)*H .GT. 0.0D0) GO TO 425 + CALL DDATRP(TN,TN,Y,YPRIME,NEQ,IWORK(LKOLD), + * RWORK(LPHI),RWORK(LPSI)) + T = TN + IDID = 1 + DONE = .TRUE. + GO TO 490 +425 CONTINUE + CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD), + * RWORK(LPHI),RWORK(LPSI)) + T = TOUT + IDID = 3 + DONE = .TRUE. + GO TO 490 +430 IF(INFO(3) .EQ. 1) GO TO 440 + TSTOP=RWORK(LTSTOP) + IF((TN-TSTOP)*H.GT.0.0D0) GO TO 715 + IF((TSTOP-TOUT)*H.LT.0.0D0)GO TO 709 + IF((TN-TOUT)*H.LT.0.0D0)GO TO 450 + CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD), + * RWORK(LPHI),RWORK(LPSI)) + T=TOUT + IDID = 3 + DONE = .TRUE. + GO TO 490 +440 TSTOP = RWORK(LTSTOP) + IF((TN-TSTOP)*H .GT. 0.0D0) GO TO 715 + IF((TSTOP-TOUT)*H .LT. 0.0D0) GO TO 709 + IF((TN-T)*H .LE. 0.0D0) GO TO 450 + IF((TN - TOUT)*H .GT. 0.0D0) GO TO 445 + CALL DDATRP(TN,TN,Y,YPRIME,NEQ,IWORK(LKOLD), + * RWORK(LPHI),RWORK(LPSI)) + T = TN + IDID = 1 + DONE = .TRUE. + GO TO 490 +445 CONTINUE + CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD), + * RWORK(LPHI),RWORK(LPSI)) + T = TOUT + IDID = 3 + DONE = .TRUE. + GO TO 490 +450 CONTINUE +C CHECK WHETHER WE ARE WITH IN ROUNDOFF OF TSTOP + IF(DABS(TN-TSTOP).GT.100.0D0*UROUND* + * (DABS(TN)+DABS(H)))GO TO 460 + CALL DDATRP(TN,TSTOP,Y,YPRIME,NEQ,IWORK(LKOLD), + * RWORK(LPHI),RWORK(LPSI)) + IDID=2 + T=TSTOP + DONE = .TRUE. + GO TO 490 +460 TNEXT=TN+H + IF((TNEXT-TSTOP)*H.LE.0.0D0)GO TO 490 + H=TSTOP-TN + RWORK(LH)=H +C +490 IF (DONE) GO TO 590 +C +C------------------------------------------------------- +C THE NEXT BLOCK CONTAINS THE CALL TO THE +C ONE-STEP INTEGRATOR DDASTP. +C THIS IS A LOOPING POINT FOR THE INTEGRATION STEPS. +C CHECK FOR TOO MANY STEPS. +C UPDATE WT. +C CHECK FOR TOO MUCH ACCURACY REQUESTED. +C COMPUTE MINIMUM STEPSIZE. +C------------------------------------------------------- +C +500 CONTINUE +C CHECK FOR FAILURE TO COMPUTE INITIAL YPRIME + IF (IDID .EQ. -12) GO TO 527 +C +C CHECK FOR TOO MANY STEPS + IF((IWORK(LNST)-IWORK(LNSTL)).LT.IWORK(LMXSTP)) + * GO TO 510 + IDID=-1 + GO TO 527 +C +C UPDATE WT +510 CALL DDAWTS(NEQ,INFO(2),RTOL,ATOL,RWORK(LPHI), + * RWORK(LWT),RPAR,IPAR) + DO 520 I=1,NEQ + IF(RWORK(I+LWT-1).GT.0.0D0)GO TO 520 + IDID=-3 + GO TO 527 +520 CONTINUE +C +C TEST FOR TOO MUCH ACCURACY REQUESTED. + R=DDANRM(NEQ,RWORK(LPHI),RWORK(LWT),RPAR,IPAR)* + * 100.0D0*UROUND + IF(R.LE.1.0D0)GO TO 525 +C MULTIPLY RTOL AND ATOL BY R AND RETURN + IF(INFO(2).EQ.1)GO TO 523 + RTOL(1)=R*RTOL(1) + ATOL(1)=R*ATOL(1) + IDID=-2 + GO TO 527 +523 DO 524 I=1,NEQ + RTOL(I)=R*RTOL(I) +524 ATOL(I)=R*ATOL(I) + IDID=-2 + GO TO 527 +525 CONTINUE +C +C COMPUTE MINIMUM STEPSIZE + HMIN=4.0D0*UROUND*DMAX1(DABS(TN),DABS(TOUT)) +C +C TEST H VS. HMAX + IF (INFO(7) .EQ. 0) GO TO 526 + RH = ABS(H)/RWORK(LHMAX) + IF (RH .GT. 1.0D0) H = H/RH +526 CONTINUE +C + CALL DDASTP(TN,Y,YPRIME,NEQ, + * RES,JAC,H,RWORK(LWT),INFO(1),IDID,RPAR,IPAR, + * RWORK(LPHI),RWORK(LDELTA),RWORK(LE), + * RWORK(LWM),IWORK(LIWM), + * RWORK(LALPHA),RWORK(LBETA),RWORK(LGAMMA), + * RWORK(LPSI),RWORK(LSIGMA), + * RWORK(LCJ),RWORK(LCJOLD),RWORK(LHOLD), + * RWORK(LS),HMIN,RWORK(LROUND), + * IWORK(LPHASE),IWORK(LJCALC),IWORK(LK), + * IWORK(LKOLD),IWORK(LNS),INFO(10),NTEMP) +527 IF(IDID.LT.0)GO TO 600 +C +C-------------------------------------------------------- +C THIS BLOCK HANDLES THE CASE OF A SUCCESSFUL RETURN +C FROM DDASTP (IDID=1). TEST FOR STOP CONDITIONS. +C-------------------------------------------------------- +C + IF(NG .EQ. 0) GO TO 529 +C +C Check for a zero of G near TN. +C + CALL DRCHEK(3,G,NG,NEQ,TN,TOUT,Y,RWORK(LE),RWORK(LPHI), + * RWORK(LPSI),IWORK(LKOLD),RWORK(LG0),RWORK(LG1), + * RWORK(LGX),JROOT,IRT,RWORK(LROUND),INFO(3), + * RWORK,IWORK,RPAR,IPAR) + IF(IRT .NE. 1) GO TO 529 + IWORK(LIRFND) = 1 + IDID = 4 + T = RWORK(LT0) + GO TO 580 +C +529 CONTINUE + IF(INFO(4).NE.0)GO TO 540 + IF(INFO(3).NE.0)GO TO 530 + IF((TN-TOUT)*H.LT.0.0D0)GO TO 500 + CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ, + * IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) + IDID=3 + T=TOUT + GO TO 580 +530 IF((TN-TOUT)*H.GE.0.0D0)GO TO 535 + T=TN + IDID=1 + GO TO 580 +535 CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ, + * IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) + IDID=3 + T=TOUT + GO TO 580 +540 IF(INFO(3).NE.0)GO TO 550 + IF((TN-TOUT)*H.LT.0.0D0)GO TO 542 + CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ, + * IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) + T=TOUT + IDID=3 + GO TO 580 +542 IF(DABS(TN-TSTOP).LE.100.0D0*UROUND* + * (DABS(TN)+DABS(H)))GO TO 545 + TNEXT=TN+H + IF((TNEXT-TSTOP)*H.LE.0.0D0)GO TO 500 + H=TSTOP-TN + GO TO 500 +545 CALL DDATRP(TN,TSTOP,Y,YPRIME,NEQ, + * IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) + IDID=2 + T=TSTOP + GO TO 580 +550 IF((TN-TOUT)*H.GE.0.0D0)GO TO 555 + IF(DABS(TN-TSTOP).LE.100.0D0*UROUND*(DABS(TN)+DABS(H)))GO TO 552 + T=TN + IDID=1 + GO TO 580 +552 CALL DDATRP(TN,TSTOP,Y,YPRIME,NEQ, + * IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) + IDID=2 + T=TSTOP + GO TO 580 +555 CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ, + * IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) + T=TOUT + IDID=3 +580 CONTINUE +C +C-------------------------------------------------------- +C ALL SUCCESSFUL RETURNS FROM DDASRT ARE MADE FROM +C THIS BLOCK. +C-------------------------------------------------------- +C +590 CONTINUE + RWORK(LTN)=TN + RWORK(LH)=H + RWORK(LTLAST) = T + RETURN +C +C----------------------------------------------------------------------- +C THIS BLOCK HANDLES ALL UNSUCCESSFUL +C RETURNS OTHER THAN FOR ILLEGAL INPUT. +C----------------------------------------------------------------------- +C +600 CONTINUE + ITEMP=-IDID + GO TO (610,620,630,690,690,640,650,660,670,675, + * 680,685), ITEMP +C +C THE MAXIMUM NUMBER OF STEPS WAS TAKEN BEFORE +C REACHING TOUT +610 MSG = 'DASRT-- AT CURRENT T (=R1) 500 STEPS' + CALL XERRWD(MSG,38,610,0,0,0,0,1,TN,0.0D0) + MSG = 'DASRT-- TAKEN ON THIS CALL BEFORE REACHING TOUT' + CALL XERRWD(MSG,48,611,0,0,0,0,0,0.0D0,0.0D0) + GO TO 690 +C +C TOO MUCH ACCURACY FOR MACHINE PRECISION +620 MSG = 'DASRT-- AT T (=R1) TOO MUCH ACCURACY REQUESTED' + CALL XERRWD(MSG,47,620,0,0,0,0,1,TN,0.0D0) + MSG = 'DASRT-- FOR PRECISION OF MACHINE. RTOL AND ATOL' + CALL XERRWD(MSG,48,621,0,0,0,0,0,0.0D0,0.0D0) + MSG = 'DASRT-- WERE INCREASED TO APPROPRIATE VALUES' + CALL XERRWD(MSG,45,622,0,0,0,0,0,0.0D0,0.0D0) +C + GO TO 690 +C WT(I) .LE. 0.0D0 FOR SOME I (NOT AT START OF PROBLEM) +630 MSG = 'DASRT-- AT T (=R1) SOME ELEMENT OF WT' + CALL XERRWD(MSG,38,630,0,0,0,0,1,TN,0.0D0) + MSG = 'DASRT-- HAS BECOME .LE. 0.0' + CALL XERRWD(MSG,28,631,0,0,0,0,0,0.0D0,0.0D0) + GO TO 690 +C +C ERROR TEST FAILED REPEATEDLY OR WITH H=HMIN +640 MSG = 'DASRT-- AT T (=R1) AND STEPSIZE H (=R2) THE' + CALL XERRWD(MSG,44,640,0,0,0,0,2,TN,H) + MSG='DASRT-- ERROR TEST FAILED REPEATEDLY OR WITH ABS(H)=HMIN' + CALL XERRWD(MSG,57,641,0,0,0,0,0,0.0D0,0.0D0) + GO TO 690 +C +C CORRECTOR CONVERGENCE FAILED REPEATEDLY OR WITH H=HMIN +650 MSG = 'DASRT-- AT T (=R1) AND STEPSIZE H (=R2) THE' + CALL XERRWD(MSG,44,650,0,0,0,0,2,TN,H) + MSG = 'DASRT-- CORRECTOR FAILED TO CONVERGE REPEATEDLY' + CALL XERRWD(MSG,48,651,0,0,0,0,0,0.0D0,0.0D0) + MSG = 'DASRT-- OR WITH ABS(H)=HMIN' + CALL XERRWD(MSG,28,652,0,0,0,0,0,0.0D0,0.0D0) + GO TO 690 +C +C THE ITERATION MATRIX IS SINGULAR +660 MSG = 'DASRT-- AT T (=R1) AND STEPSIZE H (=R2) THE' + CALL XERRWD(MSG,44,660,0,0,0,0,2,TN,H) + MSG = 'DASRT-- ITERATION MATRIX IS SINGULAR' + CALL XERRWD(MSG,37,661,0,0,0,0,0,0.0D0,0.0D0) + GO TO 690 +C +C CORRECTOR FAILURE PRECEEDED BY ERROR TEST FAILURES. +670 MSG = 'DASRT-- AT T (=R1) AND STEPSIZE H (=R2) THE' + CALL XERRWD(MSG,44,670,0,0,0,0,2,TN,H) + MSG = 'DASRT-- CORRECTOR COULD NOT CONVERGE. ALSO, THE' + CALL XERRWD(MSG,49,671,0,0,0,0,0,0.0D0,0.0D0) + MSG = 'DASRT-- ERROR TEST FAILED REPEATEDLY.' + CALL XERRWD(MSG,38,672,0,0,0,0,0,0.0D0,0.0D0) + GO TO 690 +C +C CORRECTOR FAILURE BECAUSE IRES = -1 +675 MSG = 'DASRT-- AT T (=R1) AND STEPSIZE H (=R2) THE' + CALL XERRWD(MSG,44,675,0,0,0,0,2,TN,H) + MSG = 'DASRT-- CORRECTOR COULD NOT CONVERGE BECAUSE' + CALL XERRWD(MSG,45,676,0,0,0,0,0,0.0D0,0.0D0) + MSG = 'DASRT-- IRES WAS EQUAL TO MINUS ONE' + CALL XERRWD(MSG,36,677,0,0,0,0,0,0.0D0,0.0D0) + GO TO 690 +C +C FAILURE BECAUSE IRES = -2 +680 MSG = 'DASRT-- AT T (=R1) AND STEPSIZE H (=R2)' + CALL XERRWD(MSG,40,680,0,0,0,0,2,TN,H) + MSG = 'DASRT-- IRES WAS EQUAL TO MINUS TWO' + CALL XERRWD(MSG,36,681,0,0,0,0,0,0.0D0,0.0D0) + GO TO 690 +C +C FAILED TO COMPUTE INITIAL YPRIME +685 MSG = 'DASRT-- AT T (=R1) AND STEPSIZE H (=R2) THE' + CALL XERRWD(MSG,44,685,0,0,0,0,2,TN,HO) + MSG = 'DASRT-- INITIAL YPRIME COULD NOT BE COMPUTED' + CALL XERRWD(MSG,45,686,0,0,0,0,0,0.0D0,0.0D0) + GO TO 690 +690 CONTINUE + INFO(1)=-1 + T=TN + RWORK(LTN)=TN + RWORK(LH)=H + RETURN +C----------------------------------------------------------------------- +C THIS BLOCK HANDLES ALL ERROR RETURNS DUE +C TO ILLEGAL INPUT, AS DETECTED BEFORE CALLING +C DDASTP. FIRST THE ERROR MESSAGE ROUTINE IS +C CALLED. IF THIS HAPPENS TWICE IN +C SUCCESSION, EXECUTION IS TERMINATED +C +C----------------------------------------------------------------------- +701 MSG = 'DASRT-- SOME ELEMENT OF INFO VECTOR IS NOT ZERO OR ONE' + CALL XERRWD(MSG,55,1,0,0,0,0,0,0.0D0,0.0D0) + GO TO 750 +702 MSG = 'DASRT-- NEQ (=I1) .LE. 0' + CALL XERRWD(MSG,25,2,0,1,NEQ,0,0,0.0D0,0.0D0) + GO TO 750 +703 MSG = 'DASRT-- MAXORD (=I1) NOT IN RANGE' + CALL XERRWD(MSG,34,3,0,1,MXORD,0,0,0.0D0,0.0D0) + GO TO 750 +704 MSG='DASRT-- RWORK LENGTH NEEDED, LENRW (=I1), EXCEEDS LRW (=I2)' + CALL XERRWD(MSG,60,4,0,2,LENRW,LRW,0,0.0D0,0.0D0) + GO TO 750 +705 MSG='DASRT-- IWORK LENGTH NEEDED, LENIW (=I1), EXCEEDS LIW (=I2)' + CALL XERRWD(MSG,60,5,0,2,LENIW,LIW,0,0.0D0,0.0D0) + GO TO 750 +706 MSG = 'DASRT-- SOME ELEMENT OF RTOL IS .LT. 0' + CALL XERRWD(MSG,39,6,0,0,0,0,0,0.0D0,0.0D0) + GO TO 750 +707 MSG = 'DASRT-- SOME ELEMENT OF ATOL IS .LT. 0' + CALL XERRWD(MSG,39,7,0,0,0,0,0,0.0D0,0.0D0) + GO TO 750 +708 MSG = 'DASRT-- ALL ELEMENTS OF RTOL AND ATOL ARE ZERO' + CALL XERRWD(MSG,47,8,0,0,0,0,0,0.0D0,0.0D0) + GO TO 750 +709 MSG='DASRT-- INFO(4) = 1 AND TSTOP (=R1) BEHIND TOUT (=R2)' + CALL XERRWD(MSG,54,9,0,0,0,0,2,TSTOP,TOUT) + GO TO 750 +710 MSG = 'DASRT-- HMAX (=R1) .LT. 0.0' + CALL XERRWD(MSG,28,10,0,0,0,0,1,HMAX,0.0D0) + GO TO 750 +711 MSG = 'DASRT-- TOUT (=R1) BEHIND T (=R2)' + CALL XERRWD(MSG,34,11,0,0,0,0,2,TOUT,T) + GO TO 750 +712 MSG = 'DASRT-- INFO(8)=1 AND H0=0.0' + CALL XERRWD(MSG,29,12,0,0,0,0,0,0.0D0,0.0D0) + GO TO 750 +713 MSG = 'DASRT-- SOME ELEMENT OF WT IS .LE. 0.0' + CALL XERRWD(MSG,39,13,0,0,0,0,0,0.0D0,0.0D0) + GO TO 750 +714 MSG='DASRT-- TOUT (=R1) TOO CLOSE TO T (=R2) TO START INTEGRATION' + CALL XERRWD(MSG,60,14,0,0,0,0,2,TOUT,T) + GO TO 750 +715 MSG = 'DASRT-- INFO(4)=1 AND TSTOP (=R1) BEHIND T (=R2)' + CALL XERRWD(MSG,49,15,0,0,0,0,2,TSTOP,T) + GO TO 750 +716 MSG = 'DASRT-- INFO(12)=1 AND MXSTP (=I1) .LT. 0' + CALL XERRWD(MSG,42,16,0,1,IWORK(LMXSTP),0,0,0.0D0,0.0D0) + GO TO 750 +717 MSG = 'DASRT-- ML (=I1) ILLEGAL. EITHER .LT. 0 OR .GT. NEQ' + CALL XERRWD(MSG,52,17,0,1,IWORK(LML),0,0,0.0D0,0.0D0) + GO TO 750 +718 MSG = 'DASRT-- MU (=I1) ILLEGAL. EITHER .LT. 0 OR .GT. NEQ' + CALL XERRWD(MSG,52,18,0,1,IWORK(LMU),0,0,0.0D0,0.0D0) + GO TO 750 +719 MSG = 'DASRT-- TOUT (=R1) IS EQUAL TO T (=R2)' + CALL XERRWD(MSG,39,19,0,0,0,0,2,TOUT,T) + GO TO 750 +730 MSG = 'DASRT-- NG (=I1) .LT. 0' + CALL XERRWD(MSG,24,30,1,1,NG,0,0,0.0D0,0.0D0) + GO TO 750 +732 MSG = 'DASRT-- ONE OR MORE COMPONENTS OF G HAS A ROOT' + CALL XERRWD(MSG,47,32,1,0,0,0,0,0.0D0,0.0D0) + MSG = ' TOO NEAR TO THE INITIAL POINT' + CALL XERRWD(MSG,38,32,1,0,0,0,0,0.0D0,0.0D0) +750 IF(INFO(1).EQ.-1) GO TO 760 + INFO(1)=-1 + IDID=-33 + RETURN +760 MSG = 'DASRT-- REPEATED OCCURRENCES OF ILLEGAL INPUT' + CALL XERRWD(MSG,46,801,0,0,0,0,0,0.0D0,0.0D0) +770 MSG = 'DASRT-- RUN TERMINATED. APPARENT INFINITE LOOP' + CALL XERRWD(MSG,47,802,1,0,0,0,0,0.0D0,0.0D0) + RETURN +C-----------END OF SUBROUTINE DDASRT------------------------------------ + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/dasrt/drchek.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,172 @@ + SUBROUTINE DRCHEK (JOB, G, NG, NEQ, TN, TOUT, Y, YP, PHI, PSI, + * KOLD, G0, G1, GX, JROOT, IRT, UROUND, INFO3, RWORK, IWORK, + * RPAR, IPAR) +C +C***BEGIN PROLOGUE DRCHEK +C***REFER TO DDASRT +C***ROUTINES CALLED DDATRP, DROOTS, DCOPY +C***DATE WRITTEN 821001 (YYMMDD) +C***REVISION DATE 900926 (YYMMDD) +C***END PROLOGUE DRCHEK +C + IMPLICIT DOUBLE PRECISION(A-H,O-Z) + PARAMETER (LNGE=16, LIRFND=18, LLAST=19, LIMAX=20, + * LT0=41, LTLAST=42, LALPHR=43, LX2=44) + EXTERNAL G + INTEGER JOB, NG, NEQ, KOLD, JROOT, IRT, INFO3, IWORK, IPAR + DOUBLE PRECISION TN, TOUT, Y, YP, PHI, PSI, G0, G1, GX, UROUND, + * RWORK, RPAR + DIMENSION Y(*), YP(*), PHI(NEQ,*), PSI(*), + 1 G0(*), G1(*), GX(*), JROOT(*), RWORK(*), IWORK(*) + INTEGER I, JFLAG + DOUBLE PRECISION H + DOUBLE PRECISION HMING, T1, TEMP1, TEMP2, X + LOGICAL ZROOT +C----------------------------------------------------------------------- +C THIS ROUTINE CHECKS FOR THE PRESENCE OF A ROOT IN THE +C VICINITY OF THE CURRENT T, IN A MANNER DEPENDING ON THE +C INPUT FLAG JOB. IT CALLS SUBROUTINE DROOTS TO LOCATE THE ROOT +C AS PRECISELY AS POSSIBLE. +C +C IN ADDITION TO VARIABLES DESCRIBED PREVIOUSLY, DRCHEK +C USES THE FOLLOWING FOR COMMUNICATION.. +C JOB = INTEGER FLAG INDICATING TYPE OF CALL.. +C JOB = 1 MEANS THE PROBLEM IS BEING INITIALIZED, AND DRCHEK +C IS TO LOOK FOR A ROOT AT OR VERY NEAR THE INITIAL T. +C JOB = 2 MEANS A CONTINUATION CALL TO THE SOLVER WAS JUST +C MADE, AND DRCHEK IS TO CHECK FOR A ROOT IN THE +C RELEVANT PART OF THE STEP LAST TAKEN. +C JOB = 3 MEANS A SUCCESSFUL STEP WAS JUST TAKEN, AND DRCHEK +C IS TO LOOK FOR A ROOT IN THE INTERVAL OF THE STEP. +C G0 = ARRAY OF LENGTH NG, CONTAINING THE VALUE OF G AT T = T0. +C G0 IS INPUT FOR JOB .GE. 2 AND ON OUTPUT IN ALL CASES. +C G1,GX = ARRAYS OF LENGTH NG FOR WORK SPACE. +C IRT = COMPLETION FLAG.. +C IRT = 0 MEANS NO ROOT WAS FOUND. +C IRT = -1 MEANS JOB = 1 AND A ROOT WAS FOUND TOO NEAR TO T. +C IRT = 1 MEANS A LEGITIMATE ROOT WAS FOUND (JOB = 2 OR 3). +C ON RETURN, T0 IS THE ROOT LOCATION, AND Y IS THE +C CORRESPONDING SOLUTION VECTOR. +C T0 = VALUE OF T AT ONE ENDPOINT OF INTERVAL OF INTEREST. ONLY +C ROOTS BEYOND T0 IN THE DIRECTION OF INTEGRATION ARE SOUGHT. +C T0 IS INPUT IF JOB .GE. 2, AND OUTPUT IN ALL CASES. +C T0 IS UPDATED BY DRCHEK, WHETHER A ROOT IS FOUND OR NOT. +C STORED IN THE GLOBAL ARRAY RWORK. +C TLAST = LAST VALUE OF T RETURNED BY THE SOLVER (INPUT ONLY). +C STORED IN THE GLOBAL ARRAY RWORK. +C TOUT = FINAL OUTPUT TIME FOR THE SOLVER. +C IRFND = INPUT FLAG SHOWING WHETHER THE LAST STEP TAKEN HAD A ROOT. +C IRFND = 1 IF IT DID, = 0 IF NOT. +C STORED IN THE GLOBAL ARRAY IWORK. +C INFO3 = COPY OF INFO(3) (INPUT ONLY). +C----------------------------------------------------------------------- +C + H = PSI(1) + IRT = 0 + DO 10 I = 1,NG + 10 JROOT(I) = 0 + HMING = (DABS(TN) + DABS(H))*UROUND*100.0D0 +C + GO TO (100, 200, 300), JOB +C +C EVALUATE G AT INITIAL T (STORED IN RWORK(LT0)), AND CHECK FOR +C ZERO VALUES.---------------------------------------------------------- + 100 CONTINUE + CALL DDATRP(TN,RWORK(LT0),Y,YP,NEQ,KOLD,PHI,PSI) + CALL G (NEQ, RWORK(LT0), Y, NG, G0, RPAR, IPAR) + IWORK(LNGE) = 1 + ZROOT = .FALSE. + DO 110 I = 1,NG + 110 IF (DABS(G0(I)) .LE. 0.0D0) ZROOT = .TRUE. + IF (.NOT. ZROOT) GO TO 190 +C G HAS A ZERO AT T. LOOK AT G AT T + (SMALL INCREMENT). -------------- + TEMP1 = DSIGN(HMING,H) + RWORK(LT0) = RWORK(LT0) + TEMP1 + TEMP2 = TEMP1/H + DO 120 I = 1,NEQ + 120 Y(I) = Y(I) + TEMP2*PHI(I,2) + CALL G (NEQ, RWORK(LT0), Y, NG, G0, RPAR, IPAR) + IWORK(LNGE) = IWORK(LNGE) + 1 + ZROOT = .FALSE. + DO 130 I = 1,NG + 130 IF (DABS(G0(I)) .LE. 0.0D0) ZROOT = .TRUE. + IF (.NOT. ZROOT) GO TO 190 +C G HAS A ZERO AT T AND ALSO CLOSE TO T. TAKE ERROR RETURN. ----------- + IRT = -1 + RETURN +C + 190 CONTINUE + RETURN +C +C + 200 CONTINUE + IF (IWORK(LIRFND) .EQ. 0) GO TO 260 +C IF A ROOT WAS FOUND ON THE PREVIOUS STEP, EVALUATE G0 = G(T0). ------- + CALL DDATRP (TN, RWORK(LT0), Y, YP, NEQ, KOLD, PHI, PSI) + CALL G (NEQ, RWORK(LT0), Y, NG, G0, RPAR, IPAR) + IWORK(LNGE) = IWORK(LNGE) + 1 + ZROOT = .FALSE. + DO 210 I = 1,NG + 210 IF (DABS(G0(I)) .LE. 0.0D0) ZROOT = .TRUE. + IF (.NOT. ZROOT) GO TO 260 +C G HAS A ZERO AT T0. LOOK AT G AT T + (SMALL INCREMENT). ------------- + TEMP1 = DSIGN(HMING,H) + RWORK(LT0) = RWORK(LT0) + TEMP1 + IF ((RWORK(LT0) - TN)*H .LT. 0.0D0) GO TO 230 + TEMP2 = TEMP1/H + DO 220 I = 1,NEQ + 220 Y(I) = Y(I) + TEMP2*PHI(I,2) + GO TO 240 + 230 CALL DDATRP (TN, RWORK(LT0), Y, YP, NEQ, KOLD, PHI, PSI) + 240 CALL G (NEQ, RWORK(LT0), Y, NG, G0, RPAR, IPAR) + IWORK(LNGE) = IWORK(LNGE) + 1 + ZROOT = .FALSE. + DO 250 I = 1,NG + IF (DABS(G0(I)) .GT. 0.0D0) GO TO 250 + JROOT(I) = 1 + ZROOT = .TRUE. + 250 CONTINUE + IF (.NOT. ZROOT) GO TO 260 +C G HAS A ZERO AT T0 AND ALSO CLOSE TO T0. RETURN ROOT. --------------- + IRT = 1 + RETURN +C HERE, G0 DOES NOT HAVE A ROOT +C G0 HAS NO ZERO COMPONENTS. PROCEED TO CHECK RELEVANT INTERVAL. ------ + 260 IF (TN .EQ. RWORK(LTLAST)) GO TO 390 +C + 300 CONTINUE +C SET T1 TO TN OR TOUT, WHICHEVER COMES FIRST, AND GET G AT T1. -------- + IF (INFO3 .EQ. 1) GO TO 310 + IF ((TOUT - TN)*H .GE. 0.0D0) GO TO 310 + T1 = TOUT + IF ((T1 - RWORK(LT0))*H .LE. 0.0D0) GO TO 390 + CALL DDATRP (TN, T1, Y, YP, NEQ, KOLD, PHI, PSI) + GO TO 330 + 310 T1 = TN + DO 320 I = 1,NEQ + 320 Y(I) = PHI(I,1) + 330 CALL G (NEQ, T1, Y, NG, G1, RPAR, IPAR) + IWORK(LNGE) = IWORK(LNGE) + 1 +C CALL DROOTS TO SEARCH FOR ROOT IN INTERVAL FROM T0 TO T1. ------------ + JFLAG = 0 + 350 CONTINUE + CALL DROOTS (NG, HMING, JFLAG, RWORK(LT0), T1, G0, G1, GX, X, + * JROOT, IWORK(LIMAX), IWORK(LLAST), RWORK(LALPHR), + * RWORK(LX2)) + IF (JFLAG .GT. 1) GO TO 360 + CALL DDATRP (TN, X, Y, YP, NEQ, KOLD, PHI, PSI) + CALL G (NEQ, X, Y, NG, GX, RPAR, IPAR) + IWORK(LNGE) = IWORK(LNGE) + 1 + GO TO 350 + 360 RWORK(LT0) = X + CALL DCOPY (NG, GX, 1, G0, 1) + IF (JFLAG .EQ. 4) GO TO 390 +C FOUND A ROOT. INTERPOLATE TO X AND RETURN. -------------------------- + CALL DDATRP (TN, X, Y, YP, NEQ, KOLD, PHI, PSI) + IRT = 1 + RETURN +C + 390 CONTINUE + RETURN +C---------------------- END OF SUBROUTINE DRCHEK ----------------------- + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/dasrt/droots.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,217 @@ + SUBROUTINE DROOTS (NG, HMIN, JFLAG, X0, X1, G0, G1, GX, X, JROOT, + * IMAX, LAST, ALPHA, X2) +C +C***BEGIN PROLOGUE DROOTS +C***REFER TO DDASRT +C***ROUTINES CALLED DCOPY +C***DATE WRITTEN 821001 (YYMMDD) +C***REVISION DATE 900926 (YYMMDD) +C***END PROLOGUE DROOTS +C + IMPLICIT DOUBLE PRECISION(A-H,O-Z) + INTEGER NG, JFLAG, JROOT, IMAX, LAST + DOUBLE PRECISION HMIN, X0, X1, G0, G1, GX, X, ALPHA, X2 + DIMENSION G0(NG), G1(NG), GX(NG), JROOT(NG) +C----------------------------------------------------------------------- +C THIS SUBROUTINE FINDS THE LEFTMOST ROOT OF A SET OF ARBITRARY +C FUNCTIONS GI(X) (I = 1,...,NG) IN AN INTERVAL (X0,X1). ONLY ROOTS +C OF ODD MULTIPLICITY (I.E. CHANGES OF SIGN OF THE GI) ARE FOUND. +C HERE THE SIGN OF X1 - X0 IS ARBITRARY, BUT IS CONSTANT FOR A GIVEN +C PROBLEM, AND -LEFTMOST- MEANS NEAREST TO X0. +C THE VALUES OF THE VECTOR-VALUED FUNCTION G(X) = (GI, I=1...NG) +C ARE COMMUNICATED THROUGH THE CALL SEQUENCE OF DROOTS. +C THE METHOD USED IS THE ILLINOIS ALGORITHM. +C +C REFERENCE.. +C KATHIE L. HIEBERT AND LAWRENCE F. SHAMPINE, IMPLICITLY DEFINED +C OUTPUT POINTS FOR SOLUTIONS OF ODE-S, SANDIA REPORT SAND80-0180, +C FEBRUARY, 1980. +C +C DESCRIPTION OF PARAMETERS. +C +C NG = NUMBER OF FUNCTIONS GI, OR THE NUMBER OF COMPONENTS OF +C THE VECTOR VALUED FUNCTION G(X). INPUT ONLY. +C +C HMIN = RESOLUTION PARAMETER IN X. INPUT ONLY. WHEN A ROOT IS +C FOUND, IT IS LOCATED ONLY TO WITHIN AN ERROR OF HMIN IN X. +C TYPICALLY, HMIN SHOULD BE SET TO SOMETHING ON THE ORDER OF +C 100 * UROUND * MAX(ABS(X0),ABS(X1)), +C WHERE UROUND IS THE UNIT ROUNDOFF OF THE MACHINE. +C +C JFLAG = INTEGER FLAG FOR INPUT AND OUTPUT COMMUNICATION. +C +C ON INPUT, SET JFLAG = 0 ON THE FIRST CALL FOR THE PROBLEM, +C AND LEAVE IT UNCHANGED UNTIL THE PROBLEM IS COMPLETED. +C (THE PROBLEM IS COMPLETED WHEN JFLAG .GE. 2 ON RETURN.) +C +C ON OUTPUT, JFLAG HAS THE FOLLOWING VALUES AND MEANINGS.. +C JFLAG = 1 MEANS DROOTS NEEDS A VALUE OF G(X). SET GX = G(X) +C AND CALL DROOTS AGAIN. +C JFLAG = 2 MEANS A ROOT HAS BEEN FOUND. THE ROOT IS +C AT X, AND GX CONTAINS G(X). (ACTUALLY, X IS THE +C RIGHTMOST APPROXIMATION TO THE ROOT ON AN INTERVAL +C (X0,X1) OF SIZE HMIN OR LESS.) +C JFLAG = 3 MEANS X = X1 IS A ROOT, WITH ONE OR MORE OF THE GI +C BEING ZERO AT X1 AND NO SIGN CHANGES IN (X0,X1). +C GX CONTAINS G(X) ON OUTPUT. +C JFLAG = 4 MEANS NO ROOTS (OF ODD MULTIPLICITY) WERE +C FOUND IN (X0,X1) (NO SIGN CHANGES). +C +C X0,X1 = ENDPOINTS OF THE INTERVAL WHERE ROOTS ARE SOUGHT. +C X1 AND X0 ARE INPUT WHEN JFLAG = 0 (FIRST CALL), AND +C MUST BE LEFT UNCHANGED BETWEEN CALLS UNTIL THE PROBLEM IS +C COMPLETED. X0 AND X1 MUST BE DISTINCT, BUT X1 - X0 MAY BE +C OF EITHER SIGN. HOWEVER, THE NOTION OF -LEFT- AND -RIGHT- +C WILL BE USED TO MEAN NEARER TO X0 OR X1, RESPECTIVELY. +C WHEN JFLAG .GE. 2 ON RETURN, X0 AND X1 ARE OUTPUT, AND +C ARE THE ENDPOINTS OF THE RELEVANT INTERVAL. +C +C G0,G1 = ARRAYS OF LENGTH NG CONTAINING THE VECTORS G(X0) AND G(X1), +C RESPECTIVELY. WHEN JFLAG = 0, G0 AND G1 ARE INPUT AND +C NONE OF THE G0(I) SHOULD BE BE ZERO. +C WHEN JFLAG .GE. 2 ON RETURN, G0 AND G1 ARE OUTPUT. +C +C GX = ARRAY OF LENGTH NG CONTAINING G(X). GX IS INPUT +C WHEN JFLAG = 1, AND OUTPUT WHEN JFLAG .GE. 2. +C +C X = INDEPENDENT VARIABLE VALUE. OUTPUT ONLY. +C WHEN JFLAG = 1 ON OUTPUT, X IS THE POINT AT WHICH G(X) +C IS TO BE EVALUATED AND LOADED INTO GX. +C WHEN JFLAG = 2 OR 3, X IS THE ROOT. +C WHEN JFLAG = 4, X IS THE RIGHT ENDPOINT OF THE INTERVAL, X1. +C +C JROOT = INTEGER ARRAY OF LENGTH NG. OUTPUT ONLY. +C WHEN JFLAG = 2 OR 3, JROOT INDICATES WHICH COMPONENTS +C OF G(X) HAVE A ROOT AT X. JROOT(I) IS 1 IF THE I-TH +C COMPONENT HAS A ROOT, AND JROOT(I) = 0 OTHERWISE. +C +C IMAX, LAST, ALPHA, X2 = +C BOOKKEEPING VARIABLES WHICH MUST BE SAVED FROM CALL +C TO CALL. THEY ARE SAVED INSIDE THE CALLING ROUTINE, +C BUT THEY ARE USED ONLY WITHIN THIS ROUTINE. +C----------------------------------------------------------------------- + INTEGER I, IMXOLD, NXLAST + DOUBLE PRECISION T2, TMAX, ZERO + LOGICAL ZROOT, SGNCHG, XROOT + DATA ZERO/0.0D0/ +C + IF (JFLAG .EQ. 1) GO TO 200 +C JFLAG .NE. 1. CHECK FOR CHANGE IN SIGN OF G OR ZERO AT X1. ---------- + IMAX = 0 + TMAX = ZERO + ZROOT = .FALSE. + DO 120 I = 1,NG + IF (DABS(G1(I)) .GT. ZERO) GO TO 110 + ZROOT = .TRUE. + GO TO 120 +C AT THIS POINT, G0(I) HAS BEEN CHECKED AND CANNOT BE ZERO. ------------ + 110 IF (DSIGN(1.0D0,G0(I)) .EQ. DSIGN(1.0D0,G1(I))) GO TO 120 + T2 = DABS(G1(I)/(G1(I)-G0(I))) + IF (T2 .LE. TMAX) GO TO 120 + TMAX = T2 + IMAX = I + 120 CONTINUE + IF (IMAX .GT. 0) GO TO 130 + SGNCHG = .FALSE. + GO TO 140 + 130 SGNCHG = .TRUE. + 140 IF (.NOT. SGNCHG) GO TO 400 +C THERE IS A SIGN CHANGE. FIND THE FIRST ROOT IN THE INTERVAL. -------- + XROOT = .FALSE. + NXLAST = 0 + LAST = 1 +C +C REPEAT UNTIL THE FIRST ROOT IN THE INTERVAL IS FOUND. LOOP POINT. --- + 150 CONTINUE + IF (XROOT) GO TO 300 + IF (NXLAST .EQ. LAST) GO TO 160 + ALPHA = 1.0D0 + GO TO 180 + 160 IF (LAST .EQ. 0) GO TO 170 + ALPHA = 0.5D0*ALPHA + GO TO 180 + 170 ALPHA = 2.0D0*ALPHA + 180 X2 = X1 - (X1-X0)*G1(IMAX)/(G1(IMAX) - ALPHA*G0(IMAX)) + IF ((DABS(X2-X0) .LT. HMIN) .AND. + 1 (DABS(X1-X0) .GT. 10.0D0*HMIN)) X2 = X0 + 0.1D0*(X1-X0) + JFLAG = 1 + X = X2 +C RETURN TO THE CALLING ROUTINE TO GET A VALUE OF GX = G(X). ----------- + RETURN +C CHECK TO SEE IN WHICH INTERVAL G CHANGES SIGN. ----------------------- + 200 IMXOLD = IMAX + IMAX = 0 + TMAX = ZERO + ZROOT = .FALSE. + DO 220 I = 1,NG + IF (DABS(GX(I)) .GT. ZERO) GO TO 210 + ZROOT = .TRUE. + GO TO 220 +C NEITHER G0(I) NOR GX(I) CAN BE ZERO AT THIS POINT. ------------------- + 210 IF (DSIGN(1.0D0,G0(I)) .EQ. DSIGN(1.0D0,GX(I))) GO TO 220 + T2 = DABS(GX(I)/(GX(I) - G0(I))) + IF (T2 .LE. TMAX) GO TO 220 + TMAX = T2 + IMAX = I + 220 CONTINUE + IF (IMAX .GT. 0) GO TO 230 + SGNCHG = .FALSE. + IMAX = IMXOLD + GO TO 240 + 230 SGNCHG = .TRUE. + 240 NXLAST = LAST + IF (.NOT. SGNCHG) GO TO 250 +C SIGN CHANGE BETWEEN X0 AND X2, SO REPLACE X1 WITH X2. ---------------- + X1 = X2 + CALL DCOPY (NG, GX, 1, G1, 1) + LAST = 1 + XROOT = .FALSE. + GO TO 270 + 250 IF (.NOT. ZROOT) GO TO 260 +C ZERO VALUE AT X2 AND NO SIGN CHANGE IN (X0,X2), SO X2 IS A ROOT. ----- + X1 = X2 + CALL DCOPY (NG, GX, 1, G1, 1) + XROOT = .TRUE. + GO TO 270 +C NO SIGN CHANGE BETWEEN X0 AND X2. REPLACE X0 WITH X2. --------------- + 260 CONTINUE + CALL DCOPY (NG, GX, 1, G0, 1) + X0 = X2 + LAST = 0 + XROOT = .FALSE. + 270 IF (DABS(X1-X0) .LE. HMIN) XROOT = .TRUE. + GO TO 150 +C +C RETURN WITH X1 AS THE ROOT. SET JROOT. SET X = X1 AND GX = G1. ----- + 300 JFLAG = 2 + X = X1 + CALL DCOPY (NG, G1, 1, GX, 1) + DO 320 I = 1,NG + JROOT(I) = 0 + IF (DABS(G1(I)) .GT. ZERO) GO TO 310 + JROOT(I) = 1 + GO TO 320 + 310 IF (DSIGN(1.0D0,G0(I)) .NE. DSIGN(1.0D0,G1(I))) JROOT(I) = 1 + 320 CONTINUE + RETURN +C +C NO SIGN CHANGE IN THE INTERVAL. CHECK FOR ZERO AT RIGHT ENDPOINT. --- + 400 IF (.NOT. ZROOT) GO TO 420 +C +C ZERO VALUE AT X1 AND NO SIGN CHANGE IN (X0,X1). RETURN JFLAG = 3. --- + X = X1 + CALL DCOPY (NG, G1, 1, GX, 1) + DO 410 I = 1,NG + JROOT(I) = 0 + IF (DABS(G1(I)) .LE. ZERO) JROOT (I) = 1 + 410 CONTINUE + JFLAG = 3 + RETURN +C +C NO SIGN CHANGES IN THIS INTERVAL. SET X = X1, RETURN JFLAG = 4. ----- + 420 CALL DCOPY (NG, G1, 1, GX, 1) + X = X1 + JFLAG = 4 + RETURN +C---------------------- END OF SUBROUTINE DROOTS ----------------------- + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/dasrt/module.mk Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,4 @@ +EXTERNAL_SOURCES += \ + liboctave/external/dasrt/ddasrt.f \ + liboctave/external/dasrt/drchek.f \ + liboctave/external/dasrt/droots.f
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/dassl/ddaini.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,257 @@ + SUBROUTINE DDAINI (X, Y, YPRIME, NEQ, RES, JAC, H, WT, IDID, RPAR, + + IPAR, PHI, DELTA, E, WM, IWM, HMIN, UROUND, NONNEG, NTEMP) +C***BEGIN PROLOGUE DDAINI +C***SUBSIDIARY +C***PURPOSE Initialization routine for DDASSL. +C***LIBRARY SLATEC (DASSL) +C***TYPE DOUBLE PRECISION (SDAINI-S, DDAINI-D) +C***AUTHOR PETZOLD, LINDA R., (LLNL) +C***DESCRIPTION +C----------------------------------------------------------------- +C DDAINI TAKES ONE STEP OF SIZE H OR SMALLER +C WITH THE BACKWARD EULER METHOD, TO +C FIND YPRIME. X AND Y ARE UPDATED TO BE CONSISTENT WITH THE +C NEW STEP. A MODIFIED DAMPED NEWTON ITERATION IS USED TO +C SOLVE THE CORRECTOR ITERATION. +C +C THE INITIAL GUESS FOR YPRIME IS USED IN THE +C PREDICTION, AND IN FORMING THE ITERATION +C MATRIX, BUT IS NOT INVOLVED IN THE +C ERROR TEST. THIS MAY HAVE TROUBLE +C CONVERGING IF THE INITIAL GUESS IS NO +C GOOD, OR IF G(X,Y,YPRIME) DEPENDS +C NONLINEARLY ON YPRIME. +C +C THE PARAMETERS REPRESENT: +C X -- INDEPENDENT VARIABLE +C Y -- SOLUTION VECTOR AT X +C YPRIME -- DERIVATIVE OF SOLUTION VECTOR +C NEQ -- NUMBER OF EQUATIONS +C H -- STEPSIZE. IMDER MAY USE A STEPSIZE +C SMALLER THAN H. +C WT -- VECTOR OF WEIGHTS FOR ERROR +C CRITERION +C IDID -- COMPLETION CODE WITH THE FOLLOWING MEANINGS +C IDID= 1 -- YPRIME WAS FOUND SUCCESSFULLY +C IDID=-12 -- DDAINI FAILED TO FIND YPRIME +C RPAR,IPAR -- REAL AND INTEGER PARAMETER ARRAYS +C THAT ARE NOT ALTERED BY DDAINI +C PHI -- WORK SPACE FOR DDAINI +C DELTA,E -- WORK SPACE FOR DDAINI +C WM,IWM -- REAL AND INTEGER ARRAYS STORING +C MATRIX INFORMATION +C +C----------------------------------------------------------------- +C***ROUTINES CALLED DDAJAC, DDANRM, DDASLV +C***REVISION HISTORY (YYMMDD) +C 830315 DATE WRITTEN +C 901009 Finished conversion to SLATEC 4.0 format (F.N.Fritsch) +C 901019 Merged changes made by C. Ulrich with SLATEC 4.0 format. +C 901026 Added explicit declarations for all variables and minor +C cosmetic changes to prologue. (FNF) +C 901030 Minor corrections to declarations. (FNF) +C***END PROLOGUE DDAINI +C + INTEGER NEQ, IDID, IPAR(*), IWM(*), NONNEG, NTEMP + DOUBLE PRECISION + * X, Y(*), YPRIME(*), H, WT(*), RPAR(*), PHI(NEQ,*), DELTA(*), + * E(*), WM(*), HMIN, UROUND + EXTERNAL RES, JAC +C + EXTERNAL DDAJAC, DDANRM, DDASLV + DOUBLE PRECISION DDANRM +C + INTEGER I, IER, IRES, JCALC, LNJE, LNRE, M, MAXIT, MJAC, NCF, + * NEF, NSF + DOUBLE PRECISION + * CJ, DAMP, DELNRM, ERR, OLDNRM, R, RATE, S, XOLD, YNORM + LOGICAL CONVGD +C + PARAMETER (LNRE=12) + PARAMETER (LNJE=13) +C + DATA MAXIT/10/,MJAC/5/ + DATA DAMP/0.75D0/ +C +C +C--------------------------------------------------- +C BLOCK 1. +C INITIALIZATIONS. +C--------------------------------------------------- +C +C***FIRST EXECUTABLE STATEMENT DDAINI + IDID=1 + NEF=0 + NCF=0 + NSF=0 + XOLD=X + YNORM=DDANRM(NEQ,Y,WT,RPAR,IPAR) +C +C SAVE Y AND YPRIME IN PHI + DO 100 I=1,NEQ + PHI(I,1)=Y(I) +100 PHI(I,2)=YPRIME(I) +C +C +C---------------------------------------------------- +C BLOCK 2. +C DO ONE BACKWARD EULER STEP. +C---------------------------------------------------- +C +C SET UP FOR START OF CORRECTOR ITERATION +200 CJ=1.0D0/H + X=X+H +C +C PREDICT SOLUTION AND DERIVATIVE + DO 250 I=1,NEQ +250 Y(I)=Y(I)+H*YPRIME(I) +C + JCALC=-1 + M=0 + CONVGD=.TRUE. +C +C +C CORRECTOR LOOP. +300 IWM(LNRE)=IWM(LNRE)+1 + IRES=0 +C + CALL RES(X,Y,YPRIME,DELTA,IRES,RPAR,IPAR) + IF (IRES.LT.0) GO TO 430 +C +C +C EVALUATE THE ITERATION MATRIX + IF (JCALC.NE.-1) GO TO 310 + IWM(LNJE)=IWM(LNJE)+1 + JCALC=0 + CALL DDAJAC(NEQ,X,Y,YPRIME,DELTA,CJ,H, + * IER,WT,E,WM,IWM,RES,IRES, + * UROUND,JAC,RPAR,IPAR,NTEMP) +C + S=1000000.D0 + IF (IRES.LT.0) GO TO 430 + IF (IER.NE.0) GO TO 430 + NSF=0 +C +C +C +C MULTIPLY RESIDUAL BY DAMPING FACTOR +310 CONTINUE + DO 320 I=1,NEQ +320 DELTA(I)=DELTA(I)*DAMP +C +C COMPUTE A NEW ITERATE (BACK SUBSTITUTION) +C STORE THE CORRECTION IN DELTA +C + CALL DDASLV(NEQ,DELTA,WM,IWM) +C +C UPDATE Y AND YPRIME + DO 330 I=1,NEQ + Y(I)=Y(I)-DELTA(I) +330 YPRIME(I)=YPRIME(I)-CJ*DELTA(I) +C +C TEST FOR CONVERGENCE OF THE ITERATION. +C + DELNRM=DDANRM(NEQ,DELTA,WT,RPAR,IPAR) + IF (DELNRM.LE.100.D0*UROUND*YNORM) + * GO TO 400 +C + IF (M.GT.0) GO TO 340 + OLDNRM=DELNRM + GO TO 350 +C +340 RATE=(DELNRM/OLDNRM)**(1.0D0/M) + IF (RATE.GT.0.90D0) GO TO 430 + S=RATE/(1.0D0-RATE) +C +350 IF (S*DELNRM .LE. 0.33D0) GO TO 400 +C +C +C THE CORRECTOR HAS NOT YET CONVERGED. UPDATE +C M AND AND TEST WHETHER THE MAXIMUM +C NUMBER OF ITERATIONS HAVE BEEN TRIED. +C EVERY MJAC ITERATIONS, GET A NEW +C ITERATION MATRIX. +C + M=M+1 + IF (M.GE.MAXIT) GO TO 430 +C + IF ((M/MJAC)*MJAC.EQ.M) JCALC=-1 + GO TO 300 +C +C +C THE ITERATION HAS CONVERGED. +C CHECK NONNEGATIVITY CONSTRAINTS +400 IF (NONNEG.EQ.0) GO TO 450 + DO 410 I=1,NEQ +410 DELTA(I)=MIN(Y(I),0.0D0) +C + DELNRM=DDANRM(NEQ,DELTA,WT,RPAR,IPAR) + IF (DELNRM.GT.0.33D0) GO TO 430 +C + DO 420 I=1,NEQ + Y(I)=Y(I)-DELTA(I) +420 YPRIME(I)=YPRIME(I)-CJ*DELTA(I) + GO TO 450 +C +C +C EXITS FROM CORRECTOR LOOP. +430 CONVGD=.FALSE. +450 IF (.NOT.CONVGD) GO TO 600 +C +C +C +C----------------------------------------------------- +C BLOCK 3. +C THE CORRECTOR ITERATION CONVERGED. +C DO ERROR TEST. +C----------------------------------------------------- +C + DO 510 I=1,NEQ +510 E(I)=Y(I)-PHI(I,1) + ERR=DDANRM(NEQ,E,WT,RPAR,IPAR) +C + IF (ERR.LE.1.0D0) RETURN +C +C +C +C-------------------------------------------------------- +C BLOCK 4. +C THE BACKWARD EULER STEP FAILED. RESTORE X, Y +C AND YPRIME TO THEIR ORIGINAL VALUES. +C REDUCE STEPSIZE AND TRY AGAIN, IF +C POSSIBLE. +C--------------------------------------------------------- +C +600 CONTINUE + X = XOLD + DO 610 I=1,NEQ + Y(I)=PHI(I,1) +610 YPRIME(I)=PHI(I,2) +C + IF (CONVGD) GO TO 640 + IF (IER.EQ.0) GO TO 620 + NSF=NSF+1 + H=H*0.25D0 + IF (NSF.LT.3.AND.ABS(H).GE.HMIN) GO TO 690 + IDID=-12 + RETURN +620 IF (IRES.GT.-2) GO TO 630 + IDID=-12 + RETURN +630 NCF=NCF+1 + H=H*0.25D0 + IF (NCF.LT.10.AND.ABS(H).GE.HMIN) GO TO 690 + IDID=-12 + RETURN +C +640 NEF=NEF+1 + R=0.90D0/(2.0D0*ERR+0.0001D0) + R=MAX(0.1D0,MIN(0.5D0,R)) + H=H*R + IF (ABS(H).GE.HMIN.AND.NEF.LT.10) GO TO 690 + IDID=-12 + RETURN +690 GO TO 200 +C +C-------------END OF SUBROUTINE DDAINI---------------------- + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/dassl/ddajac.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,178 @@ + SUBROUTINE DDAJAC (NEQ, X, Y, YPRIME, DELTA, CJ, H, + + IER, WT, E, WM, IWM, RES, IRES, UROUND, JAC, RPAR, + + IPAR, NTEMP) +C***BEGIN PROLOGUE DDAJAC +C***SUBSIDIARY +C***PURPOSE Compute the iteration matrix for DDASSL and form the +C LU-decomposition. +C***LIBRARY SLATEC (DASSL) +C***TYPE DOUBLE PRECISION (SDAJAC-S, DDAJAC-D) +C***AUTHOR PETZOLD, LINDA R., (LLNL) +C***DESCRIPTION +C----------------------------------------------------------------------- +C THIS ROUTINE COMPUTES THE ITERATION MATRIX +C PD=DG/DY+CJ*DG/DYPRIME (WHERE G(X,Y,YPRIME)=0). +C HERE PD IS COMPUTED BY THE USER-SUPPLIED +C ROUTINE JAC IF IWM(MTYPE) IS 1 OR 4, AND +C IT IS COMPUTED BY NUMERICAL FINITE DIFFERENCING +C IF IWM(MTYPE)IS 2 OR 5 +C THE PARAMETERS HAVE THE FOLLOWING MEANINGS. +C Y = ARRAY CONTAINING PREDICTED VALUES +C YPRIME = ARRAY CONTAINING PREDICTED DERIVATIVES +C DELTA = RESIDUAL EVALUATED AT (X,Y,YPRIME) +C (USED ONLY IF IWM(MTYPE)=2 OR 5) +C CJ = SCALAR PARAMETER DEFINING ITERATION MATRIX +C H = CURRENT STEPSIZE IN INTEGRATION +C IER = VARIABLE WHICH IS .NE. 0 +C IF ITERATION MATRIX IS SINGULAR, +C AND 0 OTHERWISE. +C WT = VECTOR OF WEIGHTS FOR COMPUTING NORMS +C E = WORK SPACE (TEMPORARY) OF LENGTH NEQ +C WM = REAL WORK SPACE FOR MATRICES. ON +C OUTPUT IT CONTAINS THE LU DECOMPOSITION +C OF THE ITERATION MATRIX. +C IWM = INTEGER WORK SPACE CONTAINING +C MATRIX INFORMATION +C RES = NAME OF THE EXTERNAL USER-SUPPLIED ROUTINE +C TO EVALUATE THE RESIDUAL FUNCTION G(X,Y,YPRIME) +C IRES = FLAG WHICH IS EQUAL TO ZERO IF NO ILLEGAL VALUES +C IN RES, AND LESS THAN ZERO OTHERWISE. (IF IRES +C IS LESS THAN ZERO, THE MATRIX WAS NOT COMPLETED) +C IN THIS CASE (IF IRES .LT. 0), THEN IER = 0. +C UROUND = THE UNIT ROUNDOFF ERROR OF THE MACHINE BEING USED. +C JAC = NAME OF THE EXTERNAL USER-SUPPLIED ROUTINE +C TO EVALUATE THE ITERATION MATRIX (THIS ROUTINE +C IS ONLY USED IF IWM(MTYPE) IS 1 OR 4) +C----------------------------------------------------------------------- +C***ROUTINES CALLED DGBTRF, DGETRF +C***REVISION HISTORY (YYMMDD) +C 830315 DATE WRITTEN +C 901009 Finished conversion to SLATEC 4.0 format (F.N.Fritsch) +C 901010 Modified three MAX calls to be all on one line. (FNF) +C 901019 Merged changes made by C. Ulrich with SLATEC 4.0 format. +C 901026 Added explicit declarations for all variables and minor +C cosmetic changes to prologue. (FNF) +C 901101 Corrected PURPOSE. (FNF) +C 020204 Convert to use LAPACK +C***END PROLOGUE DDAJAC +C + INTEGER NEQ, IER, IWM(*), IRES, IPAR(*), NTEMP + DOUBLE PRECISION + * X, Y(*), YPRIME(*), DELTA(*), CJ, H, WT(*), E(*), WM(*), + * UROUND, RPAR(*) + EXTERNAL RES, JAC +C + EXTERNAL DGBTRF, DGETRF +C + INTEGER I, I1, I2, II, IPSAVE, ISAVE, J, K, L, LENPD, LIPVT, + * LML, LMTYPE, LMU, MBA, MBAND, MEB1, MEBAND, MSAVE, MTYPE, N, + * NPD, NPDM1, NROW + DOUBLE PRECISION DEL, DELINV, SQUR, YPSAVE, YSAVE +C + PARAMETER (NPD=1) + PARAMETER (LML=1) + PARAMETER (LMU=2) + PARAMETER (LMTYPE=4) + PARAMETER (LIPVT=22) +C +C***FIRST EXECUTABLE STATEMENT DDAJAC + IER = 0 + NPDM1=NPD-1 + MTYPE=IWM(LMTYPE) + GO TO (100,200,300,400,500),MTYPE +C +C +C DENSE USER-SUPPLIED MATRIX +100 LENPD=NEQ*NEQ + DO 110 I=1,LENPD +110 WM(NPDM1+I)=0.0D0 + CALL JAC(X,Y,YPRIME,WM(NPD),CJ,RPAR,IPAR) + GO TO 230 +C +C +C DENSE FINITE-DIFFERENCE-GENERATED MATRIX +200 IRES=0 + NROW=NPDM1 + SQUR = SQRT(UROUND) + DO 210 I=1,NEQ + DEL=SQUR*MAX(ABS(Y(I)),ABS(H*YPRIME(I)),ABS(WT(I))) + DEL=SIGN(DEL,H*YPRIME(I)) + DEL=(Y(I)+DEL)-Y(I) + YSAVE=Y(I) + YPSAVE=YPRIME(I) + Y(I)=Y(I)+DEL + YPRIME(I)=YPRIME(I)+CJ*DEL + CALL RES(X,Y,YPRIME,E,IRES,RPAR,IPAR) + IF (IRES .LT. 0) RETURN + DELINV=1.0D0/DEL + DO 220 L=1,NEQ +220 WM(NROW+L)=(E(L)-DELTA(L))*DELINV + NROW=NROW+NEQ + Y(I)=YSAVE + YPRIME(I)=YPSAVE +210 CONTINUE +C +C +C DO DENSE-MATRIX LU DECOMPOSITION ON PD +230 CALL DGETRF( NEQ, NEQ, WM(NPD), NEQ, IWM(LIPVT), IER) + RETURN +C +C +C DUMMY SECTION FOR IWM(MTYPE)=3 +300 RETURN +C +C +C BANDED USER-SUPPLIED MATRIX +400 LENPD=(2*IWM(LML)+IWM(LMU)+1)*NEQ + DO 410 I=1,LENPD +410 WM(NPDM1+I)=0.0D0 + CALL JAC(X,Y,YPRIME,WM(NPD),CJ,RPAR,IPAR) + MEBAND=2*IWM(LML)+IWM(LMU)+1 + GO TO 550 +C +C +C BANDED FINITE-DIFFERENCE-GENERATED MATRIX +500 MBAND=IWM(LML)+IWM(LMU)+1 + MBA=MIN(MBAND,NEQ) + MEBAND=MBAND+IWM(LML) + MEB1=MEBAND-1 + MSAVE=(NEQ/MBAND)+1 + ISAVE=NTEMP-1 + IPSAVE=ISAVE+MSAVE + IRES=0 + SQUR=SQRT(UROUND) + DO 540 J=1,MBA + DO 510 N=J,NEQ,MBAND + K= (N-J)/MBAND + 1 + WM(ISAVE+K)=Y(N) + WM(IPSAVE+K)=YPRIME(N) + DEL=SQUR*MAX(ABS(Y(N)),ABS(H*YPRIME(N)),ABS(WT(N))) + DEL=SIGN(DEL,H*YPRIME(N)) + DEL=(Y(N)+DEL)-Y(N) + Y(N)=Y(N)+DEL +510 YPRIME(N)=YPRIME(N)+CJ*DEL + CALL RES(X,Y,YPRIME,E,IRES,RPAR,IPAR) + IF (IRES .LT. 0) RETURN + DO 530 N=J,NEQ,MBAND + K= (N-J)/MBAND + 1 + Y(N)=WM(ISAVE+K) + YPRIME(N)=WM(IPSAVE+K) + DEL=SQUR*MAX(ABS(Y(N)),ABS(H*YPRIME(N)),ABS(WT(N))) + DEL=SIGN(DEL,H*YPRIME(N)) + DEL=(Y(N)+DEL)-Y(N) + DELINV=1.0D0/DEL + I1=MAX(1,(N-IWM(LMU))) + I2=MIN(NEQ,(N+IWM(LML))) + II=N*MEB1-IWM(LML)+NPDM1 + DO 520 I=I1,I2 +520 WM(II+I)=(E(I)-DELTA(I))*DELINV +530 CONTINUE +540 CONTINUE +C +C +C DO LU DECOMPOSITION OF BANDED PD +550 CALL DGBTRF(NEQ, NEQ, IWM(LML), IWM(LMU), WM(NPD), MEBAND, + * IWM(LIPVT), IER) + RETURN +C------END OF SUBROUTINE DDAJAC------ + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/dassl/ddanrm.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,45 @@ + DOUBLE PRECISION FUNCTION DDANRM (NEQ, V, WT, RPAR, IPAR) +C***BEGIN PROLOGUE DDANRM +C***SUBSIDIARY +C***PURPOSE Compute vector norm for DDASSL. +C***LIBRARY SLATEC (DASSL) +C***TYPE DOUBLE PRECISION (SDANRM-S, DDANRM-D) +C***AUTHOR PETZOLD, LINDA R., (LLNL) +C***DESCRIPTION +C----------------------------------------------------------------------- +C THIS FUNCTION ROUTINE COMPUTES THE WEIGHTED +C ROOT-MEAN-SQUARE NORM OF THE VECTOR OF LENGTH +C NEQ CONTAINED IN THE ARRAY V,WITH WEIGHTS +C CONTAINED IN THE ARRAY WT OF LENGTH NEQ. +C DDANRM=SQRT((1/NEQ)*SUM(V(I)/WT(I))**2) +C----------------------------------------------------------------------- +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 830315 DATE WRITTEN +C 901009 Finished conversion to SLATEC 4.0 format (F.N.Fritsch) +C 901019 Merged changes made by C. Ulrich with SLATEC 4.0 format. +C 901026 Added explicit declarations for all variables and minor +C cosmetic changes to prologue. (FNF) +C***END PROLOGUE DDANRM +C + INTEGER NEQ, IPAR(*) + DOUBLE PRECISION V(NEQ), WT(NEQ), RPAR(*) +C + INTEGER I + DOUBLE PRECISION SUM, VMAX +C +C***FIRST EXECUTABLE STATEMENT DDANRM + DDANRM = 0.0D0 + VMAX = 0.0D0 + DO 10 I = 1,NEQ + IF(ABS(V(I)/WT(I)) .GT. VMAX) VMAX = ABS(V(I)/WT(I)) +10 CONTINUE + IF(VMAX .LE. 0.0D0) GO TO 30 + SUM = 0.0D0 + DO 20 I = 1,NEQ +20 SUM = SUM + ((V(I)/WT(I))/VMAX)**2 + DDANRM = VMAX*SQRT(SUM/NEQ) +30 CONTINUE + RETURN +C------END OF FUNCTION DDANRM------ + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/dassl/ddaslv.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,62 @@ + SUBROUTINE DDASLV (NEQ, DELTA, WM, IWM) +C***BEGIN PROLOGUE DDASLV +C***SUBSIDIARY +C***PURPOSE Linear system solver for DDASSL. +C***LIBRARY SLATEC (DASSL) +C***TYPE DOUBLE PRECISION (SDASLV-S, DDASLV-D) +C***AUTHOR PETZOLD, LINDA R., (LLNL) +C***DESCRIPTION +C----------------------------------------------------------------------- +C THIS ROUTINE MANAGES THE SOLUTION OF THE LINEAR +C SYSTEM ARISING IN THE NEWTON ITERATION. +C MATRICES AND REAL TEMPORARY STORAGE AND +C REAL INFORMATION ARE STORED IN THE ARRAY WM. +C INTEGER MATRIX INFORMATION IS STORED IN +C THE ARRAY IWM. +C FOR A DENSE MATRIX, THE LAPACK ROUTINE +C DGETRS IS CALLED. +C FOR A BANDED MATRIX,THE LAPACK ROUTINE +C DGBTRS IS CALLED. +C----------------------------------------------------------------------- +C***ROUTINES CALLED DGBTRS, DGETRF +C***REVISION HISTORY (YYMMDD) +C 830315 DATE WRITTEN +C 901009 Finished conversion to SLATEC 4.0 format (F.N.Fritsch) +C 901019 Merged changes made by C. Ulrich with SLATEC 4.0 format. +C 901026 Added explicit declarations for all variables and minor +C cosmetic changes to prologue. (FNF) +C 020204 Convert to use LAPACK +C***END PROLOGUE DDASLV +C + INTEGER NEQ, IWM(*) + DOUBLE PRECISION DELTA(*), WM(*) +C + EXTERNAL DGBTRS, DGETRS +C + INTEGER LIPVT, LML, LMU, LMTYPE, MEBAND, MTYPE, NPD, INFO + PARAMETER (NPD=1) + PARAMETER (LML=1) + PARAMETER (LMU=2) + PARAMETER (LMTYPE=4) + PARAMETER (LIPVT=22) +C +C***FIRST EXECUTABLE STATEMENT DDASLV + MTYPE=IWM(LMTYPE) + GO TO(100,100,300,400,400),MTYPE +C +C DENSE MATRIX +100 CALL DGETRS('N', NEQ, 1, WM(NPD), NEQ, IWM(LIPVT), DELTA, NEQ, + * INFO) + RETURN +C +C DUMMY SECTION FOR MTYPE=3 +300 CONTINUE + RETURN +C +C BANDED MATRIX +400 MEBAND=2*IWM(LML)+IWM(LMU)+1 + CALL DGBTRS ('N', NEQ, IWM(LML), IWM(LMU), 1, WM(NPD), MEBAND, + * IWM(LIPVT), DELTA, NEQ, INLPCK) + RETURN +C------END OF SUBROUTINE DDASLV------ + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/dassl/ddassl.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,1617 @@ + SUBROUTINE DDASSL (RES, NEQ, T, Y, YPRIME, TOUT, INFO, RTOL, ATOL, + + IDID, RWORK, LRW, IWORK, LIW, RPAR, IPAR, JAC) +C***BEGIN PROLOGUE DDASSL +C***PURPOSE This code solves a system of differential/algebraic +C equations of the form G(T,Y,YPRIME) = 0. +C***LIBRARY SLATEC (DASSL) +C***CATEGORY I1A2 +C***TYPE DOUBLE PRECISION (SDASSL-S, DDASSL-D) +C***KEYWORDS DIFFERENTIAL/ALGEBRAIC, BACKWARD DIFFERENTIATION FORMULAS, +C IMPLICIT DIFFERENTIAL SYSTEMS +C***AUTHOR PETZOLD, LINDA R., (LLNL) +C COMPUTING AND MATHEMATICS RESEARCH DIVISION +C LAWRENCE LIVERMORE NATIONAL LABORATORY +C L - 316, P.O. BOX 808, +C LIVERMORE, CA. 94550 +C***DESCRIPTION +C +C *Usage: +C +C EXTERNAL RES, JAC +C INTEGER NEQ, INFO(N), IDID, LRW, LIW, IWORK(LIW), IPAR +C DOUBLE PRECISION T, Y(NEQ), YPRIME(NEQ), TOUT, RTOL, ATOL, +C * RWORK(LRW), RPAR +C +C CALL DDASSL (RES, NEQ, T, Y, YPRIME, TOUT, INFO, RTOL, ATOL, +C * IDID, RWORK, LRW, IWORK, LIW, RPAR, IPAR, JAC) +C +C +C *Arguments: +C (In the following, all real arrays should be type DOUBLE PRECISION.) +C +C RES:EXT This is a subroutine which you provide to define the +C differential/algebraic system. +C +C NEQ:IN This is the number of equations to be solved. +C +C T:INOUT This is the current value of the independent variable. +C +C Y(*):INOUT This array contains the solution components at T. +C +C YPRIME(*):INOUT This array contains the derivatives of the solution +C components at T. +C +C TOUT:IN This is a point at which a solution is desired. +C +C INFO(N):IN The basic task of the code is to solve the system from T +C to TOUT and return an answer at TOUT. INFO is an integer +C array which is used to communicate exactly how you want +C this task to be carried out. (See below for details.) +C N must be greater than or equal to 15. +C +C RTOL,ATOL:INOUT These quantities represent relative and absolute +C error tolerances which you provide to indicate how +C accurately you wish the solution to be computed. You +C may choose them to be both scalars or else both vectors. +C Caution: In Fortran 77, a scalar is not the same as an +C array of length 1. Some compilers may object +C to using scalars for RTOL,ATOL. +C +C IDID:OUT This scalar quantity is an indicator reporting what the +C code did. You must monitor this integer variable to +C decide what action to take next. +C +C RWORK:WORK A real work array of length LRW which provides the +C code with needed storage space. +C +C LRW:IN The length of RWORK. (See below for required length.) +C +C IWORK:WORK An integer work array of length LIW which probides the +C code with needed storage space. +C +C LIW:IN The length of IWORK. (See below for required length.) +C +C RPAR,IPAR:IN These are real and integer parameter arrays which +C you can use for communication between your calling +C program and the RES subroutine (and the JAC subroutine) +C +C JAC:EXT This is the name of a subroutine which you may choose +C to provide for defining a matrix of partial derivatives +C described below. +C +C Quantities which may be altered by DDASSL are: +C T, Y(*), YPRIME(*), INFO(1), RTOL, ATOL, +C IDID, RWORK(*) AND IWORK(*) +C +C *Description +C +C Subroutine DDASSL uses the backward differentiation formulas of +C orders one through five to solve a system of the above form for Y and +C YPRIME. Values for Y and YPRIME at the initial time must be given as +C input. These values must be consistent, (that is, if T,Y,YPRIME are +C the given initial values, they must satisfy G(T,Y,YPRIME) = 0.). The +C subroutine solves the system from T to TOUT. It is easy to continue +C the solution to get results at additional TOUT. This is the interval +C mode of operation. Intermediate results can also be obtained easily +C by using the intermediate-output capability. +C +C The following detailed description is divided into subsections: +C 1. Input required for the first call to DDASSL. +C 2. Output after any return from DDASSL. +C 3. What to do to continue the integration. +C 4. Error messages. +C +C +C -------- INPUT -- WHAT TO DO ON THE FIRST CALL TO DDASSL ------------ +C +C The first call of the code is defined to be the start of each new +C problem. Read through the descriptions of all the following items, +C provide sufficient storage space for designated arrays, set +C appropriate variables for the initialization of the problem, and +C give information about how you want the problem to be solved. +C +C +C RES -- Provide a subroutine of the form +C SUBROUTINE RES(T,Y,YPRIME,DELTA,IRES,RPAR,IPAR) +C to define the system of differential/algebraic +C equations which is to be solved. For the given values +C of T,Y and YPRIME, the subroutine should +C return the residual of the defferential/algebraic +C system +C DELTA = G(T,Y,YPRIME) +C (DELTA(*) is a vector of length NEQ which is +C output for RES.) +C +C Subroutine RES must not alter T,Y or YPRIME. +C You must declare the name RES in an external +C statement in your program that calls DDASSL. +C You must dimension Y,YPRIME and DELTA in RES. +C +C IRES is an integer flag which is always equal to +C zero on input. Subroutine RES should alter IRES +C only if it encounters an illegal value of Y or +C a stop condition. Set IRES = -1 if an input value +C is illegal, and DDASSL will try to solve the problem +C without getting IRES = -1. If IRES = -2, DDASSL +C will return control to the calling program +C with IDID = -11. +C +C RPAR and IPAR are real and integer parameter arrays which +C you can use for communication between your calling program +C and subroutine RES. They are not altered by DDASSL. If you +C do not need RPAR or IPAR, ignore these parameters by treat- +C ing them as dummy arguments. If you do choose to use them, +C dimension them in your calling program and in RES as arrays +C of appropriate length. +C +C NEQ -- Set it to the number of differential equations. +C (NEQ .GE. 1) +C +C T -- Set it to the initial point of the integration. +C T must be defined as a variable. +C +C Y(*) -- Set this vector to the initial values of the NEQ solution +C components at the initial point. You must dimension Y of +C length at least NEQ in your calling program. +C +C YPRIME(*) -- Set this vector to the initial values of the NEQ +C first derivatives of the solution components at the initial +C point. You must dimension YPRIME at least NEQ in your +C calling program. If you do not know initial values of some +C of the solution components, see the explanation of INFO(11). +C +C TOUT -- Set it to the first point at which a solution +C is desired. You can not take TOUT = T. +C integration either forward in T (TOUT .GT. T) or +C backward in T (TOUT .LT. T) is permitted. +C +C The code advances the solution from T to TOUT using +C step sizes which are automatically selected so as to +C achieve the desired accuracy. If you wish, the code will +C return with the solution and its derivative at +C intermediate steps (intermediate-output mode) so that +C you can monitor them, but you still must provide TOUT in +C accord with the basic aim of the code. +C +C The first step taken by the code is a critical one +C because it must reflect how fast the solution changes near +C the initial point. The code automatically selects an +C initial step size which is practically always suitable for +C the problem. By using the fact that the code will not step +C past TOUT in the first step, you could, if necessary, +C restrict the length of the initial step size. +C +C For some problems it may not be permissible to integrate +C past a point TSTOP because a discontinuity occurs there +C or the solution or its derivative is not defined beyond +C TSTOP. When you have declared a TSTOP point (SEE INFO(4) +C and RWORK(1)), you have told the code not to integrate +C past TSTOP. In this case any TOUT beyond TSTOP is invalid +C input. +C +C INFO(*) -- Use the INFO array to give the code more details about +C how you want your problem solved. This array should be +C dimensioned of length 15, though DDASSL uses only the first +C eleven entries. You must respond to all of the following +C items, which are arranged as questions. The simplest use +C of the code corresponds to answering all questions as yes, +C i.e. setting all entries of INFO to 0. +C +C INFO(1) - This parameter enables the code to initialize +C itself. You must set it to indicate the start of every +C new problem. +C +C **** Is this the first call for this problem ... +C Yes - Set INFO(1) = 0 +C No - Not applicable here. +C See below for continuation calls. **** +C +C INFO(2) - How much accuracy you want of your solution +C is specified by the error tolerances RTOL and ATOL. +C The simplest use is to take them both to be scalars. +C To obtain more flexibility, they can both be vectors. +C The code must be told your choice. +C +C **** Are both error tolerances RTOL, ATOL scalars ... +C Yes - Set INFO(2) = 0 +C and input scalars for both RTOL and ATOL +C No - Set INFO(2) = 1 +C and input arrays for both RTOL and ATOL **** +C +C INFO(3) - The code integrates from T in the direction +C of TOUT by steps. If you wish, it will return the +C computed solution and derivative at the next +C intermediate step (the intermediate-output mode) or +C TOUT, whichever comes first. This is a good way to +C proceed if you want to see the behavior of the solution. +C If you must have solutions at a great many specific +C TOUT points, this code will compute them efficiently. +C +C **** Do you want the solution only at +C TOUT (and not at the next intermediate step) ... +C Yes - Set INFO(3) = 0 +C No - Set INFO(3) = 1 **** +C +C INFO(4) - To handle solutions at a great many specific +C values TOUT efficiently, this code may integrate past +C TOUT and interpolate to obtain the result at TOUT. +C Sometimes it is not possible to integrate beyond some +C point TSTOP because the equation changes there or it is +C not defined past TSTOP. Then you must tell the code +C not to go past. +C +C **** Can the integration be carried out without any +C restrictions on the independent variable T ... +C Yes - Set INFO(4)=0 +C No - Set INFO(4)=1 +C and define the stopping point TSTOP by +C setting RWORK(1)=TSTOP **** +C +C INFO(5) - To solve differential/algebraic problems it is +C necessary to use a matrix of partial derivatives of the +C system of differential equations. If you do not +C provide a subroutine to evaluate it analytically (see +C description of the item JAC in the call list), it will +C be approximated by numerical differencing in this code. +C although it is less trouble for you to have the code +C compute partial derivatives by numerical differencing, +C the solution will be more reliable if you provide the +C derivatives via JAC. Sometimes numerical differencing +C is cheaper than evaluating derivatives in JAC and +C sometimes it is not - this depends on your problem. +C +C **** Do you want the code to evaluate the partial +C derivatives automatically by numerical differences ... +C Yes - Set INFO(5)=0 +C No - Set INFO(5)=1 +C and provide subroutine JAC for evaluating the +C matrix of partial derivatives **** +C +C INFO(6) - DDASSL will perform much better if the matrix of +C partial derivatives, DG/DY + CJ*DG/DYPRIME, +C (here CJ is a scalar determined by DDASSL) +C is banded and the code is told this. In this +C case, the storage needed will be greatly reduced, +C numerical differencing will be performed much cheaper, +C and a number of important algorithms will execute much +C faster. The differential equation is said to have +C half-bandwidths ML (lower) and MU (upper) if equation i +C involves only unknowns Y(J) with +C I-ML .LE. J .LE. I+MU +C for all I=1,2,...,NEQ. Thus, ML and MU are the widths +C of the lower and upper parts of the band, respectively, +C with the main diagonal being excluded. If you do not +C indicate that the equation has a banded matrix of partial +C derivatives, the code works with a full matrix of NEQ**2 +C elements (stored in the conventional way). Computations +C with banded matrices cost less time and storage than with +C full matrices if 2*ML+MU .LT. NEQ. If you tell the +C code that the matrix of partial derivatives has a banded +C structure and you want to provide subroutine JAC to +C compute the partial derivatives, then you must be careful +C to store the elements of the matrix in the special form +C indicated in the description of JAC. +C +C **** Do you want to solve the problem using a full +C (dense) matrix (and not a special banded +C structure) ... +C Yes - Set INFO(6)=0 +C No - Set INFO(6)=1 +C and provide the lower (ML) and upper (MU) +C bandwidths by setting +C IWORK(1)=ML +C IWORK(2)=MU **** +C +C +C INFO(7) -- You can specify a maximum (absolute value of) +C stepsize, so that the code +C will avoid passing over very +C large regions. +C +C **** Do you want the code to decide +C on its own maximum stepsize? +C Yes - Set INFO(7)=0 +C No - Set INFO(7)=1 +C and define HMAX by setting +C RWORK(2)=HMAX **** +C +C INFO(8) -- Differential/algebraic problems +C may occaisionally suffer from +C severe scaling difficulties on the +C first step. If you know a great deal +C about the scaling of your problem, you can +C help to alleviate this problem by +C specifying an initial stepsize HO. +C +C **** Do you want the code to define +C its own initial stepsize? +C Yes - Set INFO(8)=0 +C No - Set INFO(8)=1 +C and define HO by setting +C RWORK(3)=HO **** +C +C INFO(9) -- If storage is a severe problem, +C you can save some locations by +C restricting the maximum order MAXORD. +C the default value is 5. for each +C order decrease below 5, the code +C requires NEQ fewer locations, however +C it is likely to be slower. In any +C case, you must have 1 .LE. MAXORD .LE. 5 +C **** Do you want the maximum order to +C default to 5? +C Yes - Set INFO(9)=0 +C No - Set INFO(9)=1 +C and define MAXORD by setting +C IWORK(3)=MAXORD **** +C +C INFO(10) --If you know that the solutions to your equations +C will always be nonnegative, it may help to set this +C parameter. However, it is probably best to +C try the code without using this option first, +C and only to use this option if that doesn't +C work very well. +C **** Do you want the code to solve the problem without +C invoking any special nonnegativity constraints? +C Yes - Set INFO(10)=0 +C No - Set INFO(10)=1 +C +C INFO(11) --DDASSL normally requires the initial T, +C Y, and YPRIME to be consistent. That is, +C you must have G(T,Y,YPRIME) = 0 at the initial +C time. If you do not know the initial +C derivative precisely, you can let DDASSL try +C to compute it. +C **** Are the initialHE INITIAL T, Y, YPRIME consistent? +C Yes - Set INFO(11) = 0 +C No - Set INFO(11) = 1, +C and set YPRIME to an initial approximation +C to YPRIME. (If you have no idea what +C YPRIME should be, set it to zero. Note +C that the initial Y should be such +C that there must exist a YPRIME so that +C G(T,Y,YPRIME) = 0.) +C +C RTOL, ATOL -- You must assign relative (RTOL) and absolute (ATOL +C error tolerances to tell the code how accurately you +C want the solution to be computed. They must be defined +C as variables because the code may change them. You +C have two choices -- +C Both RTOL and ATOL are scalars. (INFO(2)=0) +C Both RTOL and ATOL are vectors. (INFO(2)=1) +C in either case all components must be non-negative. +C +C The tolerances are used by the code in a local error +C test at each step which requires roughly that +C ABS(LOCAL ERROR) .LE. RTOL*ABS(Y)+ATOL +C for each vector component. +C (More specifically, a root-mean-square norm is used to +C measure the size of vectors, and the error test uses the +C magnitude of the solution at the beginning of the step.) +C +C The true (global) error is the difference between the +C true solution of the initial value problem and the +C computed approximation. Practically all present day +C codes, including this one, control the local error at +C each step and do not even attempt to control the global +C error directly. +C Usually, but not always, the true accuracy of the +C computed Y is comparable to the error tolerances. This +C code will usually, but not always, deliver a more +C accurate solution if you reduce the tolerances and +C integrate again. By comparing two such solutions you +C can get a fairly reliable idea of the true error in the +C solution at the bigger tolerances. +C +C Setting ATOL=0. results in a pure relative error test on +C that component. Setting RTOL=0. results in a pure +C absolute error test on that component. A mixed test +C with non-zero RTOL and ATOL corresponds roughly to a +C relative error test when the solution component is much +C bigger than ATOL and to an absolute error test when the +C solution component is smaller than the threshhold ATOL. +C +C The code will not attempt to compute a solution at an +C accuracy unreasonable for the machine being used. It will +C advise you if you ask for too much accuracy and inform +C you as to the maximum accuracy it believes possible. +C +C RWORK(*) -- Dimension this real work array of length LRW in your +C calling program. +C +C LRW -- Set it to the declared length of the RWORK array. +C You must have +C LRW .GE. 40+(MAXORD+4)*NEQ+NEQ**2 +C for the full (dense) JACOBIAN case (when INFO(6)=0), or +C LRW .GE. 40+(MAXORD+4)*NEQ+(2*ML+MU+1)*NEQ +C for the banded user-defined JACOBIAN case +C (when INFO(5)=1 and INFO(6)=1), or +C LRW .GE. 40+(MAXORD+4)*NEQ+(2*ML+MU+1)*NEQ +C +2*(NEQ/(ML+MU+1)+1) +C for the banded finite-difference-generated JACOBIAN case +C (when INFO(5)=0 and INFO(6)=1) +C +C IWORK(*) -- Dimension this integer work array of length LIW in +C your calling program. +C +C LIW -- Set it to the declared length of the IWORK array. +C You must have LIW .GE. 21+NEQ +C +C RPAR, IPAR -- These are parameter arrays, of real and integer +C type, respectively. You can use them for communication +C between your program that calls DDASSL and the +C RES subroutine (and the JAC subroutine). They are not +C altered by DDASSL. If you do not need RPAR or IPAR, +C ignore these parameters by treating them as dummy +C arguments. If you do choose to use them, dimension +C them in your calling program and in RES (and in JAC) +C as arrays of appropriate length. +C +C JAC -- If you have set INFO(5)=0, you can ignore this parameter +C by treating it as a dummy argument. Otherwise, you must +C provide a subroutine of the form +C SUBROUTINE JAC(T,Y,YPRIME,PD,CJ,RPAR,IPAR) +C to define the matrix of partial derivatives +C PD=DG/DY+CJ*DG/DYPRIME +C CJ is a scalar which is input to JAC. +C For the given values of T,Y,YPRIME, the +C subroutine must evaluate the non-zero partial +C derivatives for each equation and each solution +C component, and store these values in the +C matrix PD. The elements of PD are set to zero +C before each call to JAC so only non-zero elements +C need to be defined. +C +C Subroutine JAC must not alter T,Y,(*),YPRIME(*), or CJ. +C You must declare the name JAC in an EXTERNAL statement in +C your program that calls DDASSL. You must dimension Y, +C YPRIME and PD in JAC. +C +C The way you must store the elements into the PD matrix +C depends on the structure of the matrix which you +C indicated by INFO(6). +C *** INFO(6)=0 -- Full (dense) matrix *** +C Give PD a first dimension of NEQ. +C When you evaluate the (non-zero) partial derivative +C of equation I with respect to variable J, you must +C store it in PD according to +C PD(I,J) = "DG(I)/DY(J)+CJ*DG(I)/DYPRIME(J)" +C *** INFO(6)=1 -- Banded JACOBIAN with ML lower and MU +C upper diagonal bands (refer to INFO(6) description +C of ML and MU) *** +C Give PD a first dimension of 2*ML+MU+1. +C when you evaluate the (non-zero) partial derivative +C of equation I with respect to variable J, you must +C store it in PD according to +C IROW = I - J + ML + MU + 1 +C PD(IROW,J) = "DG(I)/DY(J)+CJ*DG(I)/DYPRIME(J)" +C +C RPAR and IPAR are real and integer parameter arrays +C which you can use for communication between your calling +C program and your JACOBIAN subroutine JAC. They are not +C altered by DDASSL. If you do not need RPAR or IPAR, +C ignore these parameters by treating them as dummy +C arguments. If you do choose to use them, dimension +C them in your calling program and in JAC as arrays of +C appropriate length. +C +C +C OPTIONALLY REPLACEABLE NORM ROUTINE: +C +C DDASSL uses a weighted norm DDANRM to measure the size +C of vectors such as the estimated error in each step. +C A FUNCTION subprogram +C DOUBLE PRECISION FUNCTION DDANRM(NEQ,V,WT,RPAR,IPAR) +C DIMENSION V(NEQ),WT(NEQ) +C is used to define this norm. Here, V is the vector +C whose norm is to be computed, and WT is a vector of +C weights. A DDANRM routine has been included with DDASSL +C which computes the weighted root-mean-square norm +C given by +C DDANRM=SQRT((1/NEQ)*SUM(V(I)/WT(I))**2) +C this norm is suitable for most problems. In some +C special cases, it may be more convenient and/or +C efficient to define your own norm by writing a function +C subprogram to be called instead of DDANRM. This should, +C however, be attempted only after careful thought and +C consideration. +C +C +C -------- OUTPUT -- AFTER ANY RETURN FROM DDASSL --------------------- +C +C The principal aim of the code is to return a computed solution at +C TOUT, although it is also possible to obtain intermediate results +C along the way. To find out whether the code achieved its goal +C or if the integration process was interrupted before the task was +C completed, you must check the IDID parameter. +C +C +C T -- The solution was successfully advanced to the +C output value of T. +C +C Y(*) -- Contains the computed solution approximation at T. +C +C YPRIME(*) -- Contains the computed derivative +C approximation at T. +C +C IDID -- Reports what the code did. +C +C *** Task completed *** +C Reported by positive values of IDID +C +C IDID = 1 -- A step was successfully taken in the +C intermediate-output mode. The code has not +C yet reached TOUT. +C +C IDID = 2 -- The integration to TSTOP was successfully +C completed (T=TSTOP) by stepping exactly to TSTOP. +C +C IDID = 3 -- The integration to TOUT was successfully +C completed (T=TOUT) by stepping past TOUT. +C Y(*) is obtained by interpolation. +C YPRIME(*) is obtained by interpolation. +C +C *** Task interrupted *** +C Reported by negative values of IDID +C +C IDID = -1 -- A large amount of work has been expended. +C (About 500 steps) +C +C IDID = -2 -- The error tolerances are too stringent. +C +C IDID = -3 -- The local error test cannot be satisfied +C because you specified a zero component in ATOL +C and the corresponding computed solution +C component is zero. Thus, a pure relative error +C test is impossible for this component. +C +C IDID = -6 -- DDASSL had repeated error test +C failures on the last attempted step. +C +C IDID = -7 -- The corrector could not converge. +C +C IDID = -8 -- The matrix of partial derivatives +C is singular. +C +C IDID = -9 -- The corrector could not converge. +C there were repeated error test failures +C in this step. +C +C IDID =-10 -- The corrector could not converge +C because IRES was equal to minus one. +C +C IDID =-11 -- IRES equal to -2 was encountered +C and control is being returned to the +C calling program. +C +C IDID =-12 -- DDASSL failed to compute the initial +C YPRIME. +C +C +C +C IDID = -13,..,-32 -- Not applicable for this code +C +C *** Task terminated *** +C Reported by the value of IDID=-33 +C +C IDID = -33 -- The code has encountered trouble from which +C it cannot recover. A message is printed +C explaining the trouble and control is returned +C to the calling program. For example, this occurs +C when invalid input is detected. +C +C RTOL, ATOL -- These quantities remain unchanged except when +C IDID = -2. In this case, the error tolerances have been +C increased by the code to values which are estimated to +C be appropriate for continuing the integration. However, +C the reported solution at T was obtained using the input +C values of RTOL and ATOL. +C +C RWORK, IWORK -- Contain information which is usually of no +C interest to the user but necessary for subsequent calls. +C However, you may find use for +C +C RWORK(3)--Which contains the step size H to be +C attempted on the next step. +C +C RWORK(4)--Which contains the current value of the +C independent variable, i.e., the farthest point +C integration has reached. This will be different +C from T only when interpolation has been +C performed (IDID=3). +C +C RWORK(7)--Which contains the stepsize used +C on the last successful step. +C +C IWORK(7)--Which contains the order of the method to +C be attempted on the next step. +C +C IWORK(8)--Which contains the order of the method used +C on the last step. +C +C IWORK(11)--Which contains the number of steps taken so +C far. +C +C IWORK(12)--Which contains the number of calls to RES +C so far. +C +C IWORK(13)--Which contains the number of evaluations of +C the matrix of partial derivatives needed so +C far. +C +C IWORK(14)--Which contains the total number +C of error test failures so far. +C +C IWORK(15)--Which contains the total number +C of convergence test failures so far. +C (includes singular iteration matrix +C failures.) +C +C +C -------- INPUT -- WHAT TO DO TO CONTINUE THE INTEGRATION ------------ +C (CALLS AFTER THE FIRST) +C +C This code is organized so that subsequent calls to continue the +C integration involve little (if any) additional effort on your +C part. You must monitor the IDID parameter in order to determine +C what to do next. +C +C Recalling that the principal task of the code is to integrate +C from T to TOUT (the interval mode), usually all you will need +C to do is specify a new TOUT upon reaching the current TOUT. +C +C Do not alter any quantity not specifically permitted below, +C in particular do not alter NEQ,T,Y(*),YPRIME(*),RWORK(*),IWORK(*) +C or the differential equation in subroutine RES. Any such +C alteration constitutes a new problem and must be treated as such, +C i.e., you must start afresh. +C +C You cannot change from vector to scalar error control or vice +C versa (INFO(2)), but you can change the size of the entries of +C RTOL, ATOL. Increasing a tolerance makes the equation easier +C to integrate. Decreasing a tolerance will make the equation +C harder to integrate and should generally be avoided. +C +C You can switch from the intermediate-output mode to the +C interval mode (INFO(3)) or vice versa at any time. +C +C If it has been necessary to prevent the integration from going +C past a point TSTOP (INFO(4), RWORK(1)), keep in mind that the +C code will not integrate to any TOUT beyond the currently +C specified TSTOP. Once TSTOP has been reached you must change +C the value of TSTOP or set INFO(4)=0. You may change INFO(4) +C or TSTOP at any time but you must supply the value of TSTOP in +C RWORK(1) whenever you set INFO(4)=1. +C +C Do not change INFO(5), INFO(6), IWORK(1), or IWORK(2) +C unless you are going to restart the code. +C +C *** Following a completed task *** +C If +C IDID = 1, call the code again to continue the integration +C another step in the direction of TOUT. +C +C IDID = 2 or 3, define a new TOUT and call the code again. +C TOUT must be different from T. You cannot change +C the direction of integration without restarting. +C +C *** Following an interrupted task *** +C To show the code that you realize the task was +C interrupted and that you want to continue, you +C must take appropriate action and set INFO(1) = 1 +C If +C IDID = -1, The code has taken about 500 steps. +C If you want to continue, set INFO(1) = 1 and +C call the code again. An additional 500 steps +C will be allowed. +C +C IDID = -2, The error tolerances RTOL, ATOL have been +C increased to values the code estimates appropriate +C for continuing. You may want to change them +C yourself. If you are sure you want to continue +C with relaxed error tolerances, set INFO(1)=1 and +C call the code again. +C +C IDID = -3, A solution component is zero and you set the +C corresponding component of ATOL to zero. If you +C are sure you want to continue, you must first +C alter the error criterion to use positive values +C for those components of ATOL corresponding to zero +C solution components, then set INFO(1)=1 and call +C the code again. +C +C IDID = -4,-5 --- Cannot occur with this code. +C +C IDID = -6, Repeated error test failures occurred on the +C last attempted step in DDASSL. A singularity in the +C solution may be present. If you are absolutely +C certain you want to continue, you should restart +C the integration. (Provide initial values of Y and +C YPRIME which are consistent) +C +C IDID = -7, Repeated convergence test failures occurred +C on the last attempted step in DDASSL. An inaccurate +C or ill-conditioned JACOBIAN may be the problem. If +C you are absolutely certain you want to continue, you +C should restart the integration. +C +C IDID = -8, The matrix of partial derivatives is singular. +C Some of your equations may be redundant. +C DDASSL cannot solve the problem as stated. +C It is possible that the redundant equations +C could be removed, and then DDASSL could +C solve the problem. It is also possible +C that a solution to your problem either +C does not exist or is not unique. +C +C IDID = -9, DDASSL had multiple convergence test +C failures, preceeded by multiple error +C test failures, on the last attempted step. +C It is possible that your problem +C is ill-posed, and cannot be solved +C using this code. Or, there may be a +C discontinuity or a singularity in the +C solution. If you are absolutely certain +C you want to continue, you should restart +C the integration. +C +C IDID =-10, DDASSL had multiple convergence test failures +C because IRES was equal to minus one. +C If you are absolutely certain you want +C to continue, you should restart the +C integration. +C +C IDID =-11, IRES=-2 was encountered, and control is being +C returned to the calling program. +C +C IDID =-12, DDASSL failed to compute the initial YPRIME. +C This could happen because the initial +C approximation to YPRIME was not very good, or +C if a YPRIME consistent with the initial Y +C does not exist. The problem could also be caused +C by an inaccurate or singular iteration matrix. +C +C IDID = -13,..,-32 --- Cannot occur with this code. +C +C +C *** Following a terminated task *** +C +C If IDID= -33, you cannot continue the solution of this problem. +C An attempt to do so will result in your +C run being terminated. +C +C +C -------- ERROR MESSAGES --------------------------------------------- +C +C The SLATEC error print routine XERMSG is called in the event of +C unsuccessful completion of a task. Most of these are treated as +C "recoverable errors", which means that (unless the user has directed +C otherwise) control will be returned to the calling program for +C possible action after the message has been printed. +C +C In the event of a negative value of IDID other than -33, an appro- +C priate message is printed and the "error number" printed by XERMSG +C is the value of IDID. There are quite a number of illegal input +C errors that can lead to a returned value IDID=-33. The conditions +C and their printed "error numbers" are as follows: +C +C Error number Condition +C +C 1 Some element of INFO vector is not zero or one. +C 2 NEQ .le. 0 +C 3 MAXORD not in range. +C 4 LRW is less than the required length for RWORK. +C 5 LIW is less than the required length for IWORK. +C 6 Some element of RTOL is .lt. 0 +C 7 Some element of ATOL is .lt. 0 +C 8 All elements of RTOL and ATOL are zero. +C 9 INFO(4)=1 and TSTOP is behind TOUT. +C 10 HMAX .lt. 0.0 +C 11 TOUT is behind T. +C 12 INFO(8)=1 and H0=0.0 +C 13 Some element of WT is .le. 0.0 +C 14 TOUT is too close to T to start integration. +C 15 INFO(4)=1 and TSTOP is behind T. +C 16 --( Not used in this version )-- +C 17 ML illegal. Either .lt. 0 or .gt. NEQ +C 18 MU illegal. Either .lt. 0 or .gt. NEQ +C 19 TOUT = T. +C +C If DDASSL is called again without any action taken to remove the +C cause of an unsuccessful return, XERMSG will be called with a fatal +C error flag, which will cause unconditional termination of the +C program. There are two such fatal errors: +C +C Error number -998: The last step was terminated with a negative +C value of IDID other than -33, and no appropriate action was +C taken. +C +C Error number -999: The previous call was terminated because of +C illegal input (IDID=-33) and there is illegal input in the +C present call, as well. (Suspect infinite loop.) +C +C --------------------------------------------------------------------- +C +C***REFERENCES A DESCRIPTION OF DASSL: A DIFFERENTIAL/ALGEBRAIC +C SYSTEM SOLVER, L. R. PETZOLD, SAND82-8637, +C SANDIA NATIONAL LABORATORIES, SEPTEMBER 1982. +C***ROUTINES CALLED D1MACH, DDAINI, DDANRM, DDASTP, DDATRP, DDAWTS, +C XERMSG +C***REVISION HISTORY (YYMMDD) +C 830315 DATE WRITTEN +C 880387 Code changes made. All common statements have been +C replaced by a DATA statement, which defines pointers into +C RWORK, and PARAMETER statements which define pointers +C into IWORK. As well the documentation has gone through +C grammatical changes. +C 881005 The prologue has been changed to mixed case. +C The subordinate routines had revision dates changed to +C this date, although the documentation for these routines +C is all upper case. No code changes. +C 890511 Code changes made. The DATA statement in the declaration +C section of DDASSL was replaced with a PARAMETER +C statement. Also the statement S = 100.D0 was removed +C from the top of the Newton iteration in DDASTP. +C The subordinate routines had revision dates changed to +C this date. +C 890517 The revision date syntax was replaced with the revision +C history syntax. Also the "DECK" comment was added to +C the top of all subroutines. These changes are consistent +C with new SLATEC guidelines. +C The subordinate routines had revision dates changed to +C this date. No code changes. +C 891013 Code changes made. +C Removed all occurrances of FLOAT or DBLE. All operations +C are now performed with "mixed-mode" arithmetic. +C Also, specific function names were replaced with generic +C function names to be consistent with new SLATEC guidelines. +C In particular: +C Replaced DSQRT with SQRT everywhere. +C Replaced DABS with ABS everywhere. +C Replaced DMIN1 with MIN everywhere. +C Replaced MIN0 with MIN everywhere. +C Replaced DMAX1 with MAX everywhere. +C Replaced MAX0 with MAX everywhere. +C Replaced DSIGN with SIGN everywhere. +C Also replaced REVISION DATE with REVISION HISTORY in all +C subordinate routines. +C 901004 Miscellaneous changes to prologue to complete conversion +C to SLATEC 4.0 format. No code changes. (F.N.Fritsch) +C 901009 Corrected GAMS classification code and converted subsidiary +C routines to 4.0 format. No code changes. (F.N.Fritsch) +C 901010 Converted XERRWV calls to XERMSG calls. (R.Clemens,AFWL) +C 901019 Code changes made. +C Merged SLATEC 4.0 changes with previous changes made +C by C. Ulrich. Below is a history of the changes made by +C C. Ulrich. (Changes in subsidiary routines are implied +C by this history) +C 891228 Bug was found and repaired inside the DDASSL +C and DDAINI routines. DDAINI was incorrectly +C returning the initial T with Y and YPRIME +C computed at T+H. The routine now returns T+H +C rather than the initial T. +C Cosmetic changes made to DDASTP. +C 900904 Three modifications were made to fix a bug (inside +C DDASSL) re interpolation for continuation calls and +C cases where TN is very close to TSTOP: +C +C 1) In testing for whether H is too large, just +C compare H to (TSTOP - TN), rather than +C (TSTOP - TN) * (1-4*UROUND), and set H to +C TSTOP - TN. This will force DDASTP to step +C exactly to TSTOP under certain situations +C (i.e. when H returned from DDASTP would otherwise +C take TN beyond TSTOP). +C +C 2) Inside the DDASTP loop, interpolate exactly to +C TSTOP if TN is very close to TSTOP (rather than +C interpolating to within roundoff of TSTOP). +C +C 3) Modified IDID description for IDID = 2 to say that +C the solution is returned by stepping exactly to +C TSTOP, rather than TOUT. (In some cases the +C solution is actually obtained by extrapolating +C over a distance near unit roundoff to TSTOP, +C but this small distance is deemed acceptable in +C these circumstances.) +C 901026 Added explicit declarations for all variables and minor +C cosmetic changes to prologue, removed unreferenced labels, +C and improved XERMSG calls. (FNF) +C 901030 Added ERROR MESSAGES section and reworked other sections to +C be of more uniform format. (FNF) +C 910624 Fixed minor bug related to HMAX (five lines ending in +C statement 526 in DDASSL). (LRP) +C +C***END PROLOGUE DDASSL +C +C**End +C +C Declare arguments. +C + INTEGER NEQ, INFO(15), IDID, LRW, IWORK(*), LIW, IPAR(*) + DOUBLE PRECISION + * T, Y(*), YPRIME(*), TOUT, RTOL(*), ATOL(*), RWORK(*), + * RPAR(*) + EXTERNAL RES, JAC +C +C Declare externals. +C + EXTERNAL D1MACH, DDAINI, DDANRM, DDASTP, DDATRP, DDAWTS, XERMSG + DOUBLE PRECISION D1MACH, DDANRM +C +C Declare local variables. +C + INTEGER I, ITEMP, LALPHA, LBETA, LCJ, LCJOLD, LCTF, LDELTA, + * LENIW, LENPD, LENRW, LE, LETF, LGAMMA, LH, LHMAX, LHOLD, + * LMXSTP, LIPVT, + * LJCALC, LK, LKOLD, LIWM, LML, LMTYPE, LMU, LMXORD, LNJE, LNPD, + * LNRE, LNS, LNST, LNSTL, LPD, LPHASE, LPHI, LPSI, LROUND, LS, + * LSIGMA, LTN, LTSTOP, LWM, LWT, MBAND, MSAVE, MXORD, NPD, NTEMP, + * NZFLG + DOUBLE PRECISION + * ATOLI, H, HMAX, HMIN, HO, R, RH, RTOLI, TDIST, TN, TNEXT, + * TSTOP, UROUND, YPNORM + LOGICAL DONE +C Auxiliary variables for conversion of values to be included in +C error messages. + CHARACTER*8 XERN1, XERN2 + CHARACTER*16 XERN3, XERN4 +C +C SET POINTERS INTO IWORK + PARAMETER (LML=1, LMU=2, LMXORD=3, LMTYPE=4, LNST=11, + * LNRE=12, LNJE=13, LETF=14, LCTF=15, LNPD=16, LMXSTP=21, + * LIPVT=22, LJCALC=5, LPHASE=6, LK=7, LKOLD=8, + * LNS=9, LNSTL=10, LIWM=1) +C +C SET RELATIVE OFFSET INTO RWORK + PARAMETER (NPD=1) +C +C SET POINTERS INTO RWORK + PARAMETER (LTSTOP=1, LHMAX=2, LH=3, LTN=4, + * LCJ=5, LCJOLD=6, LHOLD=7, LS=8, LROUND=9, + * LALPHA=11, LBETA=17, LGAMMA=23, + * LPSI=29, LSIGMA=35, LDELTA=41) +C +C***FIRST EXECUTABLE STATEMENT DDASSL + IF(INFO(1).NE.0)GO TO 100 +C +C----------------------------------------------------------------------- +C THIS BLOCK IS EXECUTED FOR THE INITIAL CALL ONLY. +C IT CONTAINS CHECKING OF INPUTS AND INITIALIZATIONS. +C----------------------------------------------------------------------- +C +C FIRST CHECK INFO ARRAY TO MAKE SURE ALL ELEMENTS OF INFO +C ARE EITHER ZERO OR ONE. + DO 10 I=2,11 + IF(INFO(I).NE.0.AND.INFO(I).NE.1)GO TO 701 +10 CONTINUE +C + IF(NEQ.LE.0)GO TO 702 +C +C CHECK AND COMPUTE MAXIMUM ORDER + MXORD=5 + IF(INFO(9).EQ.0)GO TO 20 + MXORD=IWORK(LMXORD) + IF(MXORD.LT.1.OR.MXORD.GT.5)GO TO 703 +20 IWORK(LMXORD)=MXORD +C +C COMPUTE MTYPE,LENPD,LENRW.CHECK ML AND MU. + IF(INFO(6).NE.0)GO TO 40 + LENPD=NEQ**2 + LENRW=40+(IWORK(LMXORD)+4)*NEQ+LENPD + IF(INFO(5).NE.0)GO TO 30 + IWORK(LMTYPE)=2 + GO TO 60 +30 IWORK(LMTYPE)=1 + GO TO 60 +40 IF(IWORK(LML).LT.0.OR.IWORK(LML).GE.NEQ)GO TO 717 + IF(IWORK(LMU).LT.0.OR.IWORK(LMU).GE.NEQ)GO TO 718 + LENPD=(2*IWORK(LML)+IWORK(LMU)+1)*NEQ + IF(INFO(5).NE.0)GO TO 50 + IWORK(LMTYPE)=5 + MBAND=IWORK(LML)+IWORK(LMU)+1 + MSAVE=(NEQ/MBAND)+1 + LENRW=40+(IWORK(LMXORD)+4)*NEQ+LENPD+2*MSAVE + GO TO 60 +50 IWORK(LMTYPE)=4 + LENRW=40+(IWORK(LMXORD)+4)*NEQ+LENPD +C +C CHECK LENGTHS OF RWORK AND IWORK +60 LENIW=21+NEQ + IWORK(LNPD)=LENPD + IF(LRW.LT.LENRW)GO TO 704 + IF(LIW.LT.LENIW)GO TO 705 +C +C CHECK TO SEE THAT TOUT IS DIFFERENT FROM T + IF(TOUT .EQ. T)GO TO 719 +C +C CHECK HMAX + IF(INFO(7).EQ.0)GO TO 70 + HMAX=RWORK(LHMAX) + IF(HMAX.LE.0.0D0)GO TO 710 +70 CONTINUE +C +C CHECK AND COMPUTE MAXIMUM STEPS + MXSTP=500 + IF(INFO(12).EQ.0)GO TO 80 + MXSTP=IWORK(LMXSTP) + IF(MXSTP.LT.0)GO TO 716 +80 IWORK(LMXSTP)=MXSTP +C +C INITIALIZE COUNTERS + IWORK(LNST)=0 + IWORK(LNRE)=0 + IWORK(LNJE)=0 +C + IWORK(LNSTL)=0 + IDID=1 + GO TO 200 +C +C----------------------------------------------------------------------- +C THIS BLOCK IS FOR CONTINUATION CALLS +C ONLY. HERE WE CHECK INFO(1),AND IF THE +C LAST STEP WAS INTERRUPTED WE CHECK WHETHER +C APPROPRIATE ACTION WAS TAKEN. +C----------------------------------------------------------------------- +C +100 CONTINUE + IF(INFO(1).EQ.1)GO TO 110 + IF(INFO(1).NE.-1)GO TO 701 +C +C IF WE ARE HERE, THE LAST STEP WAS INTERRUPTED +C BY AN ERROR CONDITION FROM DDASTP,AND +C APPROPRIATE ACTION WAS NOT TAKEN. THIS +C IS A FATAL ERROR. + WRITE (XERN1, '(I8)') IDID + CALL XERMSG ('SLATEC', 'DDASSL', + * 'THE LAST STEP TERMINATED WITH A NEGATIVE VALUE OF IDID = ' // + * XERN1 // ' AND NO APPROPRIATE ACTION WAS TAKEN. ' // + * 'RUN TERMINATED', -998, 2) + RETURN +110 CONTINUE + IWORK(LNSTL)=IWORK(LNST) +C +C----------------------------------------------------------------------- +C THIS BLOCK IS EXECUTED ON ALL CALLS. +C THE ERROR TOLERANCE PARAMETERS ARE +C CHECKED, AND THE WORK ARRAY POINTERS +C ARE SET. +C----------------------------------------------------------------------- +C +200 CONTINUE +C CHECK RTOL,ATOL + NZFLG=0 + RTOLI=RTOL(1) + ATOLI=ATOL(1) + DO 210 I=1,NEQ + IF(INFO(2).EQ.1)RTOLI=RTOL(I) + IF(INFO(2).EQ.1)ATOLI=ATOL(I) + IF(RTOLI.GT.0.0D0.OR.ATOLI.GT.0.0D0)NZFLG=1 + IF(RTOLI.LT.0.0D0)GO TO 706 + IF(ATOLI.LT.0.0D0)GO TO 707 +210 CONTINUE + IF(NZFLG.EQ.0)GO TO 708 +C +C SET UP RWORK STORAGE.IWORK STORAGE IS FIXED +C IN DATA STATEMENT. + LE=LDELTA+NEQ + LWT=LE+NEQ + LPHI=LWT+NEQ + LPD=LPHI+(IWORK(LMXORD)+1)*NEQ + LWM=LPD + NTEMP=NPD+IWORK(LNPD) + IF(INFO(1).EQ.1)GO TO 400 +C +C----------------------------------------------------------------------- +C THIS BLOCK IS EXECUTED ON THE INITIAL CALL +C ONLY. SET THE INITIAL STEP SIZE, AND +C THE ERROR WEIGHT VECTOR, AND PHI. +C COMPUTE INITIAL YPRIME, IF NECESSARY. +C----------------------------------------------------------------------- +C + TN=T + IDID=1 +C +C SET ERROR WEIGHT VECTOR WT + CALL DDAWTS(NEQ,INFO(2),RTOL,ATOL,Y,RWORK(LWT),RPAR,IPAR) + DO 305 I = 1,NEQ + IF(RWORK(LWT+I-1).LE.0.0D0) GO TO 713 +305 CONTINUE +C +C COMPUTE UNIT ROUNDOFF AND HMIN + UROUND = D1MACH(4) + RWORK(LROUND) = UROUND + HMIN = 4.0D0*UROUND*MAX(ABS(T),ABS(TOUT)) +C +C CHECK INITIAL INTERVAL TO SEE THAT IT IS LONG ENOUGH + TDIST = ABS(TOUT - T) + IF(TDIST .LT. HMIN) GO TO 714 +C +C CHECK HO, IF THIS WAS INPUT + IF (INFO(8) .EQ. 0) GO TO 310 + HO = RWORK(LH) + IF ((TOUT - T)*HO .LT. 0.0D0) GO TO 711 + IF (HO .EQ. 0.0D0) GO TO 712 + GO TO 320 +310 CONTINUE +C +C COMPUTE INITIAL STEPSIZE, TO BE USED BY EITHER +C DDASTP OR DDAINI, DEPENDING ON INFO(11) + HO = 0.001D0*TDIST + YPNORM = DDANRM(NEQ,YPRIME,RWORK(LWT),RPAR,IPAR) + IF (YPNORM .GT. 0.5D0/HO) HO = 0.5D0/YPNORM + HO = SIGN(HO,TOUT-T) +C ADJUST HO IF NECESSARY TO MEET HMAX BOUND +320 IF (INFO(7) .EQ. 0) GO TO 330 + RH = ABS(HO)/RWORK(LHMAX) + IF (RH .GT. 1.0D0) HO = HO/RH +C COMPUTE TSTOP, IF APPLICABLE +330 IF (INFO(4) .EQ. 0) GO TO 340 + TSTOP = RWORK(LTSTOP) + IF ((TSTOP - T)*HO .LT. 0.0D0) GO TO 715 + IF ((T + HO - TSTOP)*HO .GT. 0.0D0) HO = TSTOP - T + IF ((TSTOP - TOUT)*HO .LT. 0.0D0) GO TO 709 +C +C COMPUTE INITIAL DERIVATIVE, UPDATING TN AND Y, IF APPLICABLE +340 IF (INFO(11) .EQ. 0) GO TO 350 + CALL DDAINI(TN,Y,YPRIME,NEQ, + * RES,JAC,HO,RWORK(LWT),IDID,RPAR,IPAR, + * RWORK(LPHI),RWORK(LDELTA),RWORK(LE), + * RWORK(LWM),IWORK(LIWM),HMIN,RWORK(LROUND), + * INFO(10),NTEMP) + IF (IDID .LT. 0) GO TO 390 +C +C LOAD H WITH HO. STORE H IN RWORK(LH) +350 H = HO + RWORK(LH) = H +C +C LOAD Y AND H*YPRIME INTO PHI(*,1) AND PHI(*,2) + ITEMP = LPHI + NEQ + DO 370 I = 1,NEQ + RWORK(LPHI + I - 1) = Y(I) +370 RWORK(ITEMP + I - 1) = H*YPRIME(I) +C +390 GO TO 500 +C +C------------------------------------------------------- +C THIS BLOCK IS FOR CONTINUATION CALLS ONLY. ITS +C PURPOSE IS TO CHECK STOP CONDITIONS BEFORE +C TAKING A STEP. +C ADJUST H IF NECESSARY TO MEET HMAX BOUND +C------------------------------------------------------- +C +400 CONTINUE + UROUND=RWORK(LROUND) + DONE = .FALSE. + TN=RWORK(LTN) + H=RWORK(LH) + IF(INFO(7) .EQ. 0) GO TO 410 + RH = ABS(H)/RWORK(LHMAX) + IF(RH .GT. 1.0D0) H = H/RH +410 CONTINUE + IF(T .EQ. TOUT) GO TO 719 + IF((T - TOUT)*H .GT. 0.0D0) GO TO 711 + IF(INFO(4) .EQ. 1) GO TO 430 + IF(INFO(3) .EQ. 1) GO TO 420 + IF((TN-TOUT)*H.LT.0.0D0)GO TO 490 + CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD), + * RWORK(LPHI),RWORK(LPSI)) + T=TOUT + IDID = 3 + DONE = .TRUE. + GO TO 490 +420 IF((TN-T)*H .LE. 0.0D0) GO TO 490 + IF((TN - TOUT)*H .GT. 0.0D0) GO TO 425 + CALL DDATRP(TN,TN,Y,YPRIME,NEQ,IWORK(LKOLD), + * RWORK(LPHI),RWORK(LPSI)) + T = TN + IDID = 1 + DONE = .TRUE. + GO TO 490 +425 CONTINUE + CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD), + * RWORK(LPHI),RWORK(LPSI)) + T = TOUT + IDID = 3 + DONE = .TRUE. + GO TO 490 +430 IF(INFO(3) .EQ. 1) GO TO 440 + TSTOP=RWORK(LTSTOP) + IF((TN-TSTOP)*H.GT.0.0D0) GO TO 715 + IF((TSTOP-TOUT)*H.LT.0.0D0)GO TO 709 + IF((TN-TOUT)*H.LT.0.0D0)GO TO 450 + CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD), + * RWORK(LPHI),RWORK(LPSI)) + T=TOUT + IDID = 3 + DONE = .TRUE. + GO TO 490 +440 TSTOP = RWORK(LTSTOP) + IF((TN-TSTOP)*H .GT. 0.0D0) GO TO 715 + IF((TSTOP-TOUT)*H .LT. 0.0D0) GO TO 709 + IF((TN-T)*H .LE. 0.0D0) GO TO 450 + IF((TN - TOUT)*H .GT. 0.0D0) GO TO 445 + CALL DDATRP(TN,TN,Y,YPRIME,NEQ,IWORK(LKOLD), + * RWORK(LPHI),RWORK(LPSI)) + T = TN + IDID = 1 + DONE = .TRUE. + GO TO 490 +445 CONTINUE + CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD), + * RWORK(LPHI),RWORK(LPSI)) + T = TOUT + IDID = 3 + DONE = .TRUE. + GO TO 490 +450 CONTINUE +C CHECK WHETHER WE ARE WITHIN ROUNDOFF OF TSTOP + IF(ABS(TN-TSTOP).GT.100.0D0*UROUND* + * (ABS(TN)+ABS(H)))GO TO 460 + CALL DDATRP(TN,TSTOP,Y,YPRIME,NEQ,IWORK(LKOLD), + * RWORK(LPHI),RWORK(LPSI)) + IDID=2 + T=TSTOP + DONE = .TRUE. + GO TO 490 +460 TNEXT=TN+H + IF((TNEXT-TSTOP)*H.LE.0.0D0)GO TO 490 + H=TSTOP-TN + RWORK(LH)=H +C +490 IF (DONE) GO TO 580 +C +C------------------------------------------------------- +C THE NEXT BLOCK CONTAINS THE CALL TO THE +C ONE-STEP INTEGRATOR DDASTP. +C THIS IS A LOOPING POINT FOR THE INTEGRATION STEPS. +C CHECK FOR TOO MANY STEPS. +C UPDATE WT. +C CHECK FOR TOO MUCH ACCURACY REQUESTED. +C COMPUTE MINIMUM STEPSIZE. +C------------------------------------------------------- +C +500 CONTINUE +C CHECK FOR FAILURE TO COMPUTE INITIAL YPRIME + IF (IDID .EQ. -12) GO TO 527 +C +C CHECK FOR TOO MANY STEPS + IF((IWORK(LNST)-IWORK(LNSTL)).LT.IWORK(LMXSTP)) + * GO TO 510 + IDID=-1 + GO TO 527 +C +C UPDATE WT +510 CALL DDAWTS(NEQ,INFO(2),RTOL,ATOL,RWORK(LPHI), + * RWORK(LWT),RPAR,IPAR) + DO 520 I=1,NEQ + IF(RWORK(I+LWT-1).GT.0.0D0)GO TO 520 + IDID=-3 + GO TO 527 +520 CONTINUE +C +C TEST FOR TOO MUCH ACCURACY REQUESTED. + R=DDANRM(NEQ,RWORK(LPHI),RWORK(LWT),RPAR,IPAR)* + * 100.0D0*UROUND + IF(R.LE.1.0D0)GO TO 525 +C MULTIPLY RTOL AND ATOL BY R AND RETURN + IF(INFO(2).EQ.1)GO TO 523 + RTOL(1)=R*RTOL(1) + ATOL(1)=R*ATOL(1) + IDID=-2 + GO TO 527 +523 DO 524 I=1,NEQ + RTOL(I)=R*RTOL(I) +524 ATOL(I)=R*ATOL(I) + IDID=-2 + GO TO 527 +525 CONTINUE +C +C COMPUTE MINIMUM STEPSIZE + HMIN=4.0D0*UROUND*MAX(ABS(TN),ABS(TOUT)) +C +C TEST H VS. HMAX + IF (INFO(7) .EQ. 0) GO TO 526 + RH = ABS(H)/RWORK(LHMAX) + IF (RH .GT. 1.0D0) H = H/RH +526 CONTINUE +C + CALL DDASTP(TN,Y,YPRIME,NEQ, + * RES,JAC,H,RWORK(LWT),INFO(1),IDID,RPAR,IPAR, + * RWORK(LPHI),RWORK(LDELTA),RWORK(LE), + * RWORK(LWM),IWORK(LIWM), + * RWORK(LALPHA),RWORK(LBETA),RWORK(LGAMMA), + * RWORK(LPSI),RWORK(LSIGMA), + * RWORK(LCJ),RWORK(LCJOLD),RWORK(LHOLD), + * RWORK(LS),HMIN,RWORK(LROUND), + * IWORK(LPHASE),IWORK(LJCALC),IWORK(LK), + * IWORK(LKOLD),IWORK(LNS),INFO(10),NTEMP) +527 IF(IDID.LT.0)GO TO 600 +C +C-------------------------------------------------------- +C THIS BLOCK HANDLES THE CASE OF A SUCCESSFUL RETURN +C FROM DDASTP (IDID=1). TEST FOR STOP CONDITIONS. +C-------------------------------------------------------- +C + IF(INFO(4).NE.0)GO TO 540 + IF(INFO(3).NE.0)GO TO 530 + IF((TN-TOUT)*H.LT.0.0D0)GO TO 500 + CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ, + * IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) + IDID=3 + T=TOUT + GO TO 580 +530 IF((TN-TOUT)*H.GE.0.0D0)GO TO 535 + T=TN + IDID=1 + GO TO 580 +535 CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ, + * IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) + IDID=3 + T=TOUT + GO TO 580 +540 IF(INFO(3).NE.0)GO TO 550 + IF((TN-TOUT)*H.LT.0.0D0)GO TO 542 + CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ, + * IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) + T=TOUT + IDID=3 + GO TO 580 +542 IF(ABS(TN-TSTOP).LE.100.0D0*UROUND* + * (ABS(TN)+ABS(H)))GO TO 545 + TNEXT=TN+H + IF((TNEXT-TSTOP)*H.LE.0.0D0)GO TO 500 + H=TSTOP-TN + GO TO 500 +545 CALL DDATRP(TN,TSTOP,Y,YPRIME,NEQ, + * IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) + IDID=2 + T=TSTOP + GO TO 580 +550 IF((TN-TOUT)*H.GE.0.0D0)GO TO 555 + IF(ABS(TN-TSTOP).LE.100.0D0*UROUND*(ABS(TN)+ABS(H)))GO TO 552 + T=TN + IDID=1 + GO TO 580 +552 CALL DDATRP(TN,TSTOP,Y,YPRIME,NEQ, + * IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) + IDID=2 + T=TSTOP + GO TO 580 +555 CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ, + * IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) + T=TOUT + IDID=3 + GO TO 580 +C +C-------------------------------------------------------- +C ALL SUCCESSFUL RETURNS FROM DDASSL ARE MADE FROM +C THIS BLOCK. +C-------------------------------------------------------- +C +580 CONTINUE + RWORK(LTN)=TN + RWORK(LH)=H + RETURN +C +C----------------------------------------------------------------------- +C THIS BLOCK HANDLES ALL UNSUCCESSFUL +C RETURNS OTHER THAN FOR ILLEGAL INPUT. +C----------------------------------------------------------------------- +C +600 CONTINUE + ITEMP=-IDID + GO TO (610,620,630,690,690,640,650,660,670,675, + * 680,685), ITEMP +C +C THE MAXIMUM NUMBER OF STEPS WAS TAKEN BEFORE +C REACHING TOUT +610 WRITE (XERN3, '(1P,D15.6)') TN + CALL XERMSG ('SLATEC', 'DDASSL', + * 'AT CURRENT T = ' // XERN3 // ' 500 STEPS TAKEN ON THIS ' // + * 'CALL BEFORE REACHING TOUT', IDID, 1) + GO TO 690 +C +C TOO MUCH ACCURACY FOR MACHINE PRECISION +620 WRITE (XERN3, '(1P,D15.6)') TN + CALL XERMSG ('SLATEC', 'DDASSL', + * 'AT T = ' // XERN3 // ' TOO MUCH ACCURACY REQUESTED FOR ' // + * 'PRECISION OF MACHINE. RTOL AND ATOL WERE INCREASED TO ' // + * 'APPROPRIATE VALUES', IDID, 1) + GO TO 690 +C +C WT(I) .LE. 0.0 FOR SOME I (NOT AT START OF PROBLEM) +630 WRITE (XERN3, '(1P,D15.6)') TN + CALL XERMSG ('SLATEC', 'DDASSL', + * 'AT T = ' // XERN3 // ' SOME ELEMENT OF WT HAS BECOME .LE. ' // + * '0.0', IDID, 1) + GO TO 690 +C +C ERROR TEST FAILED REPEATEDLY OR WITH H=HMIN +640 WRITE (XERN3, '(1P,D15.6)') TN + WRITE (XERN4, '(1P,D15.6)') H + CALL XERMSG ('SLATEC', 'DDASSL', + * 'AT T = ' // XERN3 // ' AND STEPSIZE H = ' // XERN4 // + * ' THE ERROR TEST FAILED REPEATEDLY OR WITH ABS(H)=HMIN', + * IDID, 1) + GO TO 690 +C +C CORRECTOR CONVERGENCE FAILED REPEATEDLY OR WITH H=HMIN +650 WRITE (XERN3, '(1P,D15.6)') TN + WRITE (XERN4, '(1P,D15.6)') H + CALL XERMSG ('SLATEC', 'DDASSL', + * 'AT T = ' // XERN3 // ' AND STEPSIZE H = ' // XERN4 // + * ' THE CORRECTOR FAILED TO CONVERGE REPEATEDLY OR WITH ' // + * 'ABS(H)=HMIN', IDID, 1) + GO TO 690 +C +C THE ITERATION MATRIX IS SINGULAR +660 WRITE (XERN3, '(1P,D15.6)') TN + WRITE (XERN4, '(1P,D15.6)') H + CALL XERMSG ('SLATEC', 'DDASSL', + * 'AT T = ' // XERN3 // ' AND STEPSIZE H = ' // XERN4 // + * ' THE ITERATION MATRIX IS SINGULAR', IDID, 1) + GO TO 690 +C +C CORRECTOR FAILURE PRECEEDED BY ERROR TEST FAILURES. +670 WRITE (XERN3, '(1P,D15.6)') TN + WRITE (XERN4, '(1P,D15.6)') H + CALL XERMSG ('SLATEC', 'DDASSL', + * 'AT T = ' // XERN3 // ' AND STEPSIZE H = ' // XERN4 // + * ' THE CORRECTOR COULD NOT CONVERGE. ALSO, THE ERROR TEST ' // + * 'FAILED REPEATEDLY.', IDID, 1) + GO TO 690 +C +C CORRECTOR FAILURE BECAUSE IRES = -1 +675 WRITE (XERN3, '(1P,D15.6)') TN + WRITE (XERN4, '(1P,D15.6)') H + CALL XERMSG ('SLATEC', 'DDASSL', + * 'AT T = ' // XERN3 // ' AND STEPSIZE H = ' // XERN4 // + * ' THE CORRECTOR COULD NOT CONVERGE BECAUSE IRES WAS EQUAL ' // + * 'TO MINUS ONE', IDID, 1) + GO TO 690 +C +C FAILURE BECAUSE IRES = -2 +680 WRITE (XERN3, '(1P,D15.6)') TN + WRITE (XERN4, '(1P,D15.6)') H + CALL XERMSG ('SLATEC', 'DDASSL', + * 'AT T = ' // XERN3 // ' AND STEPSIZE H = ' // XERN4 // + * ' IRES WAS EQUAL TO MINUS TWO', IDID, 1) + GO TO 690 +C +C FAILED TO COMPUTE INITIAL YPRIME +685 WRITE (XERN3, '(1P,D15.6)') TN + WRITE (XERN4, '(1P,D15.6)') HO + CALL XERMSG ('SLATEC', 'DDASSL', + * 'AT T = ' // XERN3 // ' AND STEPSIZE H = ' // XERN4 // + * ' THE INITIAL YPRIME COULD NOT BE COMPUTED', IDID, 1) + GO TO 690 +C +690 CONTINUE + INFO(1)=-1 + T=TN + RWORK(LTN)=TN + RWORK(LH)=H + RETURN +C +C----------------------------------------------------------------------- +C THIS BLOCK HANDLES ALL ERROR RETURNS DUE +C TO ILLEGAL INPUT, AS DETECTED BEFORE CALLING +C DDASTP. FIRST THE ERROR MESSAGE ROUTINE IS +C CALLED. IF THIS HAPPENS TWICE IN +C SUCCESSION, EXECUTION IS TERMINATED +C +C----------------------------------------------------------------------- +701 CALL XERMSG ('SLATEC', 'DDASSL', + * 'SOME ELEMENT OF INFO VECTOR IS NOT ZERO OR ONE', 1, 1) + GO TO 750 +C +702 WRITE (XERN1, '(I8)') NEQ + CALL XERMSG ('SLATEC', 'DDASSL', + * 'NEQ = ' // XERN1 // ' .LE. 0', 2, 1) + GO TO 750 +C +703 WRITE (XERN1, '(I8)') MXORD + CALL XERMSG ('SLATEC', 'DDASSL', + * 'MAXORD = ' // XERN1 // ' NOT IN RANGE', 3, 1) + GO TO 750 +C +704 WRITE (XERN1, '(I8)') LENRW + WRITE (XERN2, '(I8)') LRW + CALL XERMSG ('SLATEC', 'DDASSL', + * 'RWORK LENGTH NEEDED, LENRW = ' // XERN1 // + * ', EXCEEDS LRW = ' // XERN2, 4, 1) + GO TO 750 +C +705 WRITE (XERN1, '(I8)') LENIW + WRITE (XERN2, '(I8)') LIW + CALL XERMSG ('SLATEC', 'DDASSL', + * 'IWORK LENGTH NEEDED, LENIW = ' // XERN1 // + * ', EXCEEDS LIW = ' // XERN2, 5, 1) + GO TO 750 +C +706 CALL XERMSG ('SLATEC', 'DDASSL', + * 'SOME ELEMENT OF RTOL IS .LT. 0', 6, 1) + GO TO 750 +C +707 CALL XERMSG ('SLATEC', 'DDASSL', + * 'SOME ELEMENT OF ATOL IS .LT. 0', 7, 1) + GO TO 750 +C +708 CALL XERMSG ('SLATEC', 'DDASSL', + * 'ALL ELEMENTS OF RTOL AND ATOL ARE ZERO', 8, 1) + GO TO 750 +C +709 WRITE (XERN3, '(1P,D15.6)') TSTOP + WRITE (XERN4, '(1P,D15.6)') TOUT + CALL XERMSG ('SLATEC', 'DDASSL', + * 'INFO(4) = 1 AND TSTOP = ' // XERN3 // ' BEHIND TOUT = ' // + * XERN4, 9, 1) + GO TO 750 +C +710 WRITE (XERN3, '(1P,D15.6)') HMAX + CALL XERMSG ('SLATEC', 'DDASSL', + * 'HMAX = ' // XERN3 // ' .LT. 0.0', 10, 1) + GO TO 750 +C +711 WRITE (XERN3, '(1P,D15.6)') TOUT + WRITE (XERN4, '(1P,D15.6)') T + CALL XERMSG ('SLATEC', 'DDASSL', + * 'TOUT = ' // XERN3 // ' BEHIND T = ' // XERN4, 11, 1) + GO TO 750 +C +712 CALL XERMSG ('SLATEC', 'DDASSL', + * 'INFO(8)=1 AND H0=0.0', 12, 1) + GO TO 750 +C +713 CALL XERMSG ('SLATEC', 'DDASSL', + * 'SOME ELEMENT OF WT IS .LE. 0.0', 13, 1) + GO TO 750 +C +714 WRITE (XERN3, '(1P,D15.6)') TOUT + WRITE (XERN4, '(1P,D15.6)') T + CALL XERMSG ('SLATEC', 'DDASSL', + * 'TOUT = ' // XERN3 // ' TOO CLOSE TO T = ' // XERN4 // + * ' TO START INTEGRATION', 14, 1) + GO TO 750 +C +715 WRITE (XERN3, '(1P,D15.6)') TSTOP + WRITE (XERN4, '(1P,D15.6)') T + CALL XERMSG ('SLATEC', 'DDASSL', + * 'INFO(4)=1 AND TSTOP = ' // XERN3 // ' BEHIND T = ' // XERN4, + * 15, 1) + GO TO 750 +C +716 WRITE (XERN1, '(I8)') MXSTP + CALL XERMSG ('SLATEC', 'DDASSL', + * 'INFO(12)=1 AND MXSTP = ' // XERN1 // ' ILLEGAL.', 3, 1) + GO TO 750 +C +717 WRITE (XERN1, '(I8)') IWORK(LML) + CALL XERMSG ('SLATEC', 'DDASSL', + * 'ML = ' // XERN1 // ' ILLEGAL. EITHER .LT. 0 OR .GT. NEQ', + * 17, 1) + GO TO 750 +C +718 WRITE (XERN1, '(I8)') IWORK(LMU) + CALL XERMSG ('SLATEC', 'DDASSL', + * 'MU = ' // XERN1 // ' ILLEGAL. EITHER .LT. 0 OR .GT. NEQ', + * 18, 1) + GO TO 750 +C +719 WRITE (XERN3, '(1P,D15.6)') TOUT + CALL XERMSG ('SLATEC', 'DDASSL', + * 'TOUT = T = ' // XERN3, 19, 1) + GO TO 750 +C +750 IDID=-33 + IF(INFO(1).EQ.-1) THEN + CALL XERMSG ('SLATEC', 'DDASSL', + * 'REPEATED OCCURRENCES OF ILLEGAL INPUT$$' // + * 'RUN TERMINATED. APPARENT INFINITE LOOP', -999, 2) + ENDIF +C + INFO(1)=-1 + RETURN +C-----------END OF SUBROUTINE DDASSL------------------------------------ + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/dassl/ddastp.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,612 @@ + SUBROUTINE DDASTP (X, Y, YPRIME, NEQ, RES, JAC, H, WT, JSTART, + + IDID, RPAR, IPAR, PHI, DELTA, E, WM, IWM, ALPHA, BETA, GAMMA, + + PSI, SIGMA, CJ, CJOLD, HOLD, S, HMIN, UROUND, IPHASE, JCALC, + + K, KOLD, NS, NONNEG, NTEMP) +C***BEGIN PROLOGUE DDASTP +C***SUBSIDIARY +C***PURPOSE Perform one step of the DDASSL integration. +C***LIBRARY SLATEC (DASSL) +C***TYPE DOUBLE PRECISION (SDASTP-S, DDASTP-D) +C***AUTHOR PETZOLD, LINDA R., (LLNL) +C***DESCRIPTION +C----------------------------------------------------------------------- +C DDASTP SOLVES A SYSTEM OF DIFFERENTIAL/ +C ALGEBRAIC EQUATIONS OF THE FORM +C G(X,Y,YPRIME) = 0, FOR ONE STEP (NORMALLY +C FROM X TO X+H). +C +C THE METHODS USED ARE MODIFIED DIVIDED +C DIFFERENCE,FIXED LEADING COEFFICIENT +C FORMS OF BACKWARD DIFFERENTIATION +C FORMULAS. THE CODE ADJUSTS THE STEPSIZE +C AND ORDER TO CONTROL THE LOCAL ERROR PER +C STEP. +C +C +C THE PARAMETERS REPRESENT +C X -- INDEPENDENT VARIABLE +C Y -- SOLUTION VECTOR AT X +C YPRIME -- DERIVATIVE OF SOLUTION VECTOR +C AFTER SUCCESSFUL STEP +C NEQ -- NUMBER OF EQUATIONS TO BE INTEGRATED +C RES -- EXTERNAL USER-SUPPLIED SUBROUTINE +C TO EVALUATE THE RESIDUAL. THE CALL IS +C CALL RES(X,Y,YPRIME,DELTA,IRES,RPAR,IPAR) +C X,Y,YPRIME ARE INPUT. DELTA IS OUTPUT. +C ON INPUT, IRES=0. RES SHOULD ALTER IRES ONLY +C IF IT ENCOUNTERS AN ILLEGAL VALUE OF Y OR A +C STOP CONDITION. SET IRES=-1 IF AN INPUT VALUE +C OF Y IS ILLEGAL, AND DDASTP WILL TRY TO SOLVE +C THE PROBLEM WITHOUT GETTING IRES = -1. IF +C IRES=-2, DDASTP RETURNS CONTROL TO THE CALLING +C PROGRAM WITH IDID = -11. +C JAC -- EXTERNAL USER-SUPPLIED ROUTINE TO EVALUATE +C THE ITERATION MATRIX (THIS IS OPTIONAL) +C THE CALL IS OF THE FORM +C CALL JAC(X,Y,YPRIME,PD,CJ,RPAR,IPAR) +C PD IS THE MATRIX OF PARTIAL DERIVATIVES, +C PD=DG/DY+CJ*DG/DYPRIME +C H -- APPROPRIATE STEP SIZE FOR NEXT STEP. +C NORMALLY DETERMINED BY THE CODE +C WT -- VECTOR OF WEIGHTS FOR ERROR CRITERION. +C JSTART -- INTEGER VARIABLE SET 0 FOR +C FIRST STEP, 1 OTHERWISE. +C IDID -- COMPLETION CODE WITH THE FOLLOWING MEANINGS: +C IDID= 1 -- THE STEP WAS COMPLETED SUCCESSFULLY +C IDID=-6 -- THE ERROR TEST FAILED REPEATEDLY +C IDID=-7 -- THE CORRECTOR COULD NOT CONVERGE +C IDID=-8 -- THE ITERATION MATRIX IS SINGULAR +C IDID=-9 -- THE CORRECTOR COULD NOT CONVERGE. +C THERE WERE REPEATED ERROR TEST +C FAILURES ON THIS STEP. +C IDID=-10-- THE CORRECTOR COULD NOT CONVERGE +C BECAUSE IRES WAS EQUAL TO MINUS ONE +C IDID=-11-- IRES EQUAL TO -2 WAS ENCOUNTERED, +C AND CONTROL IS BEING RETURNED TO +C THE CALLING PROGRAM +C RPAR,IPAR -- REAL AND INTEGER PARAMETER ARRAYS THAT +C ARE USED FOR COMMUNICATION BETWEEN THE +C CALLING PROGRAM AND EXTERNAL USER ROUTINES +C THEY ARE NOT ALTERED BY DDASTP +C PHI -- ARRAY OF DIVIDED DIFFERENCES USED BY +C DDASTP. THE LENGTH IS NEQ*(K+1),WHERE +C K IS THE MAXIMUM ORDER +C DELTA,E -- WORK VECTORS FOR DDASTP OF LENGTH NEQ +C WM,IWM -- REAL AND INTEGER ARRAYS STORING +C MATRIX INFORMATION SUCH AS THE MATRIX +C OF PARTIAL DERIVATIVES,PERMUTATION +C VECTOR,AND VARIOUS OTHER INFORMATION. +C +C THE OTHER PARAMETERS ARE INFORMATION +C WHICH IS NEEDED INTERNALLY BY DDASTP TO +C CONTINUE FROM STEP TO STEP. +C +C----------------------------------------------------------------------- +C***ROUTINES CALLED DDAJAC, DDANRM, DDASLV, DDATRP +C***REVISION HISTORY (YYMMDD) +C 830315 DATE WRITTEN +C 901009 Finished conversion to SLATEC 4.0 format (F.N.Fritsch) +C 901019 Merged changes made by C. Ulrich with SLATEC 4.0 format. +C 901026 Added explicit declarations for all variables and minor +C cosmetic changes to prologue. (FNF) +C***END PROLOGUE DDASTP +C + INTEGER NEQ, JSTART, IDID, IPAR(*), IWM(*), IPHASE, JCALC, K, + * KOLD, NS, NONNEG, NTEMP + DOUBLE PRECISION + * X, Y(*), YPRIME(*), H, WT(*), RPAR(*), PHI(NEQ,*), DELTA(*), + * E(*), WM(*), ALPHA(*), BETA(*), GAMMA(*), PSI(*), SIGMA(*), CJ, + * CJOLD, HOLD, S, HMIN, UROUND + EXTERNAL RES, JAC +C + EXTERNAL DDAJAC, DDANRM, DDASLV, DDATRP + DOUBLE PRECISION DDANRM +C + INTEGER I, IER, IRES, J, J1, KDIFF, KM1, KNEW, KP1, KP2, LCTF, + * LETF, LMXORD, LNJE, LNRE, LNST, M, MAXIT, NCF, NEF, NSF, NSP1 + DOUBLE PRECISION + * ALPHA0, ALPHAS, CJLAST, CK, DELNRM, ENORM, ERK, ERKM1, + * ERKM2, ERKP1, ERR, EST, HNEW, OLDNRM, PNORM, R, RATE, TEMP1, + * TEMP2, TERK, TERKM1, TERKM2, TERKP1, XOLD, XRATE + LOGICAL CONVGD +C + PARAMETER (LMXORD=3) + PARAMETER (LNST=11) + PARAMETER (LNRE=12) + PARAMETER (LNJE=13) + PARAMETER (LETF=14) + PARAMETER (LCTF=15) +C + DATA MAXIT/4/ + DATA XRATE/0.25D0/ +C +C +C +C +C +C----------------------------------------------------------------------- +C BLOCK 1. +C INITIALIZE. ON THE FIRST CALL,SET +C THE ORDER TO 1 AND INITIALIZE +C OTHER VARIABLES. +C----------------------------------------------------------------------- +C +C INITIALIZATIONS FOR ALL CALLS +C***FIRST EXECUTABLE STATEMENT DDASTP + IDID=1 + XOLD=X + NCF=0 + NSF=0 + NEF=0 + IF(JSTART .NE. 0) GO TO 120 +C +C IF THIS IS THE FIRST STEP,PERFORM +C OTHER INITIALIZATIONS + IWM(LETF) = 0 + IWM(LCTF) = 0 + K=1 + KOLD=0 + HOLD=0.0D0 + JSTART=1 + PSI(1)=H + CJOLD = 1.0D0/H + CJ = CJOLD + S = 100.D0 + JCALC = -1 + DELNRM=1.0D0 + IPHASE = 0 + NS=0 +120 CONTINUE +C +C +C +C +C +C----------------------------------------------------------------------- +C BLOCK 2 +C COMPUTE COEFFICIENTS OF FORMULAS FOR +C THIS STEP. +C----------------------------------------------------------------------- +200 CONTINUE + KP1=K+1 + KP2=K+2 + KM1=K-1 + XOLD=X + IF(H.NE.HOLD.OR.K .NE. KOLD) NS = 0 + NS=MIN(NS+1,KOLD+2) + NSP1=NS+1 + IF(KP1 .LT. NS)GO TO 230 +C + BETA(1)=1.0D0 + ALPHA(1)=1.0D0 + TEMP1=H + GAMMA(1)=0.0D0 + SIGMA(1)=1.0D0 + DO 210 I=2,KP1 + TEMP2=PSI(I-1) + PSI(I-1)=TEMP1 + BETA(I)=BETA(I-1)*PSI(I-1)/TEMP2 + TEMP1=TEMP2+H + ALPHA(I)=H/TEMP1 + SIGMA(I)=(I-1)*SIGMA(I-1)*ALPHA(I) + GAMMA(I)=GAMMA(I-1)+ALPHA(I-1)/H +210 CONTINUE + PSI(KP1)=TEMP1 +230 CONTINUE +C +C COMPUTE ALPHAS, ALPHA0 + ALPHAS = 0.0D0 + ALPHA0 = 0.0D0 + DO 240 I = 1,K + ALPHAS = ALPHAS - 1.0D0/I + ALPHA0 = ALPHA0 - ALPHA(I) +240 CONTINUE +C +C COMPUTE LEADING COEFFICIENT CJ + CJLAST = CJ + CJ = -ALPHAS/H +C +C COMPUTE VARIABLE STEPSIZE ERROR COEFFICIENT CK + CK = ABS(ALPHA(KP1) + ALPHAS - ALPHA0) + CK = MAX(CK,ALPHA(KP1)) +C +C DECIDE WHETHER NEW JACOBIAN IS NEEDED + TEMP1 = (1.0D0 - XRATE)/(1.0D0 + XRATE) + TEMP2 = 1.0D0/TEMP1 + IF (CJ/CJOLD .LT. TEMP1 .OR. CJ/CJOLD .GT. TEMP2) JCALC = -1 + IF (CJ .NE. CJLAST) S = 100.D0 +C +C CHANGE PHI TO PHI STAR + IF(KP1 .LT. NSP1) GO TO 280 + DO 270 J=NSP1,KP1 + DO 260 I=1,NEQ +260 PHI(I,J)=BETA(J)*PHI(I,J) +270 CONTINUE +280 CONTINUE +C +C UPDATE TIME + X=X+H +C +C +C +C +C +C----------------------------------------------------------------------- +C BLOCK 3 +C PREDICT THE SOLUTION AND DERIVATIVE, +C AND SOLVE THE CORRECTOR EQUATION +C----------------------------------------------------------------------- +C +C FIRST,PREDICT THE SOLUTION AND DERIVATIVE +300 CONTINUE + DO 310 I=1,NEQ + Y(I)=PHI(I,1) +310 YPRIME(I)=0.0D0 + DO 330 J=2,KP1 + DO 320 I=1,NEQ + Y(I)=Y(I)+PHI(I,J) +320 YPRIME(I)=YPRIME(I)+GAMMA(J)*PHI(I,J) +330 CONTINUE + PNORM = DDANRM (NEQ,Y,WT,RPAR,IPAR) +C +C +C +C SOLVE THE CORRECTOR EQUATION USING A +C MODIFIED NEWTON SCHEME. + CONVGD= .TRUE. + M=0 + IWM(LNRE)=IWM(LNRE)+1 + IRES = 0 + CALL RES(X,Y,YPRIME,DELTA,IRES,RPAR,IPAR) + IF (IRES .LT. 0) GO TO 380 +C +C +C IF INDICATED,REEVALUATE THE +C ITERATION MATRIX PD = DG/DY + CJ*DG/DYPRIME +C (WHERE G(X,Y,YPRIME)=0). SET +C JCALC TO 0 AS AN INDICATOR THAT +C THIS HAS BEEN DONE. + IF(JCALC .NE. -1)GO TO 340 + IWM(LNJE)=IWM(LNJE)+1 + JCALC=0 + CALL DDAJAC(NEQ,X,Y,YPRIME,DELTA,CJ,H, + * IER,WT,E,WM,IWM,RES,IRES,UROUND,JAC,RPAR, + * IPAR,NTEMP) + CJOLD=CJ + S = 100.D0 + IF (IRES .LT. 0) GO TO 380 + IF(IER .NE. 0)GO TO 380 + NSF=0 +C +C +C INITIALIZE THE ERROR ACCUMULATION VECTOR E. +340 CONTINUE + DO 345 I=1,NEQ +345 E(I)=0.0D0 +C +C +C CORRECTOR LOOP. +350 CONTINUE +C +C MULTIPLY RESIDUAL BY TEMP1 TO ACCELERATE CONVERGENCE + TEMP1 = 2.0D0/(1.0D0 + CJ/CJOLD) + DO 355 I = 1,NEQ +355 DELTA(I) = DELTA(I) * TEMP1 +C +C COMPUTE A NEW ITERATE (BACK-SUBSTITUTION). +C STORE THE CORRECTION IN DELTA. + CALL DDASLV(NEQ,DELTA,WM,IWM) +C +C UPDATE Y,E,AND YPRIME + DO 360 I=1,NEQ + Y(I)=Y(I)-DELTA(I) + E(I)=E(I)-DELTA(I) +360 YPRIME(I)=YPRIME(I)-CJ*DELTA(I) +C +C TEST FOR CONVERGENCE OF THE ITERATION + DELNRM=DDANRM(NEQ,DELTA,WT,RPAR,IPAR) + IF (DELNRM .LE. 100.D0*UROUND*PNORM) GO TO 375 + IF (M .GT. 0) GO TO 365 + OLDNRM = DELNRM + GO TO 367 +365 RATE = (DELNRM/OLDNRM)**(1.0D0/M) + IF (RATE .GT. 0.90D0) GO TO 370 + S = RATE/(1.0D0 - RATE) +367 IF (S*DELNRM .LE. 0.33D0) GO TO 375 +C +C THE CORRECTOR HAS NOT YET CONVERGED. +C UPDATE M AND TEST WHETHER THE +C MAXIMUM NUMBER OF ITERATIONS HAVE +C BEEN TRIED. + M=M+1 + IF(M.GE.MAXIT)GO TO 370 +C +C EVALUATE THE RESIDUAL +C AND GO BACK TO DO ANOTHER ITERATION + IWM(LNRE)=IWM(LNRE)+1 + IRES = 0 + CALL RES(X,Y,YPRIME,DELTA,IRES, + * RPAR,IPAR) + IF (IRES .LT. 0) GO TO 380 + GO TO 350 +C +C +C THE CORRECTOR FAILED TO CONVERGE IN MAXIT +C ITERATIONS. IF THE ITERATION MATRIX +C IS NOT CURRENT,RE-DO THE STEP WITH +C A NEW ITERATION MATRIX. +370 CONTINUE + IF(JCALC.EQ.0)GO TO 380 + JCALC=-1 + GO TO 300 +C +C +C THE ITERATION HAS CONVERGED. IF NONNEGATIVITY OF SOLUTION IS +C REQUIRED, SET THE SOLUTION NONNEGATIVE, IF THE PERTURBATION +C TO DO IT IS SMALL ENOUGH. IF THE CHANGE IS TOO LARGE, THEN +C CONSIDER THE CORRECTOR ITERATION TO HAVE FAILED. +375 IF(NONNEG .EQ. 0) GO TO 390 + DO 377 I = 1,NEQ +377 DELTA(I) = MIN(Y(I),0.0D0) + DELNRM = DDANRM(NEQ,DELTA,WT,RPAR,IPAR) + IF(DELNRM .GT. 0.33D0) GO TO 380 + DO 378 I = 1,NEQ +378 E(I) = E(I) - DELTA(I) + GO TO 390 +C +C +C EXITS FROM BLOCK 3 +C NO CONVERGENCE WITH CURRENT ITERATION +C MATRIX,OR SINGULAR ITERATION MATRIX +380 CONVGD= .FALSE. +390 JCALC = 1 + IF(.NOT.CONVGD)GO TO 600 +C +C +C +C +C +C----------------------------------------------------------------------- +C BLOCK 4 +C ESTIMATE THE ERRORS AT ORDERS K,K-1,K-2 +C AS IF CONSTANT STEPSIZE WAS USED. ESTIMATE +C THE LOCAL ERROR AT ORDER K AND TEST +C WHETHER THE CURRENT STEP IS SUCCESSFUL. +C----------------------------------------------------------------------- +C +C ESTIMATE ERRORS AT ORDERS K,K-1,K-2 + ENORM = DDANRM(NEQ,E,WT,RPAR,IPAR) + ERK = SIGMA(K+1)*ENORM + TERK = (K+1)*ERK + EST = ERK + KNEW=K + IF(K .EQ. 1)GO TO 430 + DO 405 I = 1,NEQ +405 DELTA(I) = PHI(I,KP1) + E(I) + ERKM1=SIGMA(K)*DDANRM(NEQ,DELTA,WT,RPAR,IPAR) + TERKM1 = K*ERKM1 + IF(K .GT. 2)GO TO 410 + IF(TERKM1 .LE. 0.5D0*TERK)GO TO 420 + GO TO 430 +410 CONTINUE + DO 415 I = 1,NEQ +415 DELTA(I) = PHI(I,K) + DELTA(I) + ERKM2=SIGMA(K-1)*DDANRM(NEQ,DELTA,WT,RPAR,IPAR) + TERKM2 = (K-1)*ERKM2 + IF(MAX(TERKM1,TERKM2).GT.TERK)GO TO 430 +C LOWER THE ORDER +420 CONTINUE + KNEW=K-1 + EST = ERKM1 +C +C +C CALCULATE THE LOCAL ERROR FOR THE CURRENT STEP +C TO SEE IF THE STEP WAS SUCCESSFUL +430 CONTINUE + ERR = CK * ENORM + IF(ERR .GT. 1.0D0)GO TO 600 +C +C +C +C +C +C----------------------------------------------------------------------- +C BLOCK 5 +C THE STEP IS SUCCESSFUL. DETERMINE +C THE BEST ORDER AND STEPSIZE FOR +C THE NEXT STEP. UPDATE THE DIFFERENCES +C FOR THE NEXT STEP. +C----------------------------------------------------------------------- + IDID=1 + IWM(LNST)=IWM(LNST)+1 + KDIFF=K-KOLD + KOLD=K + HOLD=H +C +C +C ESTIMATE THE ERROR AT ORDER K+1 UNLESS: +C ALREADY DECIDED TO LOWER ORDER, OR +C ALREADY USING MAXIMUM ORDER, OR +C STEPSIZE NOT CONSTANT, OR +C ORDER RAISED IN PREVIOUS STEP + IF(KNEW.EQ.KM1.OR.K.EQ.IWM(LMXORD))IPHASE=1 + IF(IPHASE .EQ. 0)GO TO 545 + IF(KNEW.EQ.KM1)GO TO 540 + IF(K.EQ.IWM(LMXORD)) GO TO 550 + IF(KP1.GE.NS.OR.KDIFF.EQ.1)GO TO 550 + DO 510 I=1,NEQ +510 DELTA(I)=E(I)-PHI(I,KP2) + ERKP1 = (1.0D0/(K+2))*DDANRM(NEQ,DELTA,WT,RPAR,IPAR) + TERKP1 = (K+2)*ERKP1 + IF(K.GT.1)GO TO 520 + IF(TERKP1.GE.0.5D0*TERK)GO TO 550 + GO TO 530 +520 IF(TERKM1.LE.MIN(TERK,TERKP1))GO TO 540 + IF(TERKP1.GE.TERK.OR.K.EQ.IWM(LMXORD))GO TO 550 +C +C RAISE ORDER +530 K=KP1 + EST = ERKP1 + GO TO 550 +C +C LOWER ORDER +540 K=KM1 + EST = ERKM1 + GO TO 550 +C +C IF IPHASE = 0, INCREASE ORDER BY ONE AND MULTIPLY STEPSIZE BY +C FACTOR TWO +545 K = KP1 + HNEW = H*2.0D0 + H = HNEW + GO TO 575 +C +C +C DETERMINE THE APPROPRIATE STEPSIZE FOR +C THE NEXT STEP. +550 HNEW=H + TEMP2=K+1 + R=(2.0D0*EST+0.0001D0)**(-1.0D0/TEMP2) + IF(R .LT. 2.0D0) GO TO 555 + HNEW = 2.0D0*H + GO TO 560 +555 IF(R .GT. 1.0D0) GO TO 560 + R = MAX(0.5D0,MIN(0.9D0,R)) + HNEW = H*R +560 H=HNEW +C +C +C UPDATE DIFFERENCES FOR NEXT STEP +575 CONTINUE + IF(KOLD.EQ.IWM(LMXORD))GO TO 585 + DO 580 I=1,NEQ +580 PHI(I,KP2)=E(I) +585 CONTINUE + DO 590 I=1,NEQ +590 PHI(I,KP1)=PHI(I,KP1)+E(I) + DO 595 J1=2,KP1 + J=KP1-J1+1 + DO 595 I=1,NEQ +595 PHI(I,J)=PHI(I,J)+PHI(I,J+1) + RETURN +C +C +C +C +C +C----------------------------------------------------------------------- +C BLOCK 6 +C THE STEP IS UNSUCCESSFUL. RESTORE X,PSI,PHI +C DETERMINE APPROPRIATE STEPSIZE FOR +C CONTINUING THE INTEGRATION, OR EXIT WITH +C AN ERROR FLAG IF THERE HAVE BEEN MANY +C FAILURES. +C----------------------------------------------------------------------- +600 IPHASE = 1 +C +C RESTORE X,PHI,PSI + X=XOLD + IF(KP1.LT.NSP1)GO TO 630 + DO 620 J=NSP1,KP1 + TEMP1=1.0D0/BETA(J) + DO 610 I=1,NEQ +610 PHI(I,J)=TEMP1*PHI(I,J) +620 CONTINUE +630 CONTINUE + DO 640 I=2,KP1 +640 PSI(I-1)=PSI(I)-H +C +C +C TEST WHETHER FAILURE IS DUE TO CORRECTOR ITERATION +C OR ERROR TEST + IF(CONVGD)GO TO 660 + IWM(LCTF)=IWM(LCTF)+1 +C +C +C THE NEWTON ITERATION FAILED TO CONVERGE WITH +C A CURRENT ITERATION MATRIX. DETERMINE THE CAUSE +C OF THE FAILURE AND TAKE APPROPRIATE ACTION. + IF(IER.EQ.0)GO TO 650 +C +C THE ITERATION MATRIX IS SINGULAR. REDUCE +C THE STEPSIZE BY A FACTOR OF 4. IF +C THIS HAPPENS THREE TIMES IN A ROW ON +C THE SAME STEP, RETURN WITH AN ERROR FLAG + NSF=NSF+1 + R = 0.25D0 + H=H*R + IF (NSF .LT. 3 .AND. ABS(H) .GE. HMIN) GO TO 690 + IDID=-8 + GO TO 675 +C +C +C THE NEWTON ITERATION FAILED TO CONVERGE FOR A REASON +C OTHER THAN A SINGULAR ITERATION MATRIX. IF IRES = -2, THEN +C RETURN. OTHERWISE, REDUCE THE STEPSIZE AND TRY AGAIN, UNLESS +C TOO MANY FAILURES HAVE OCCURRED. +650 CONTINUE + IF (IRES .GT. -2) GO TO 655 + IDID = -11 + GO TO 675 +655 NCF = NCF + 1 + R = 0.25D0 + H = H*R + IF (NCF .LT. 10 .AND. ABS(H) .GE. HMIN) GO TO 690 + IDID = -7 + IF (IRES .LT. 0) IDID = -10 + IF (NEF .GE. 3) IDID = -9 + GO TO 675 +C +C +C THE NEWTON SCHEME CONVERGED,AND THE CAUSE +C OF THE FAILURE WAS THE ERROR ESTIMATE +C EXCEEDING THE TOLERANCE. +660 NEF=NEF+1 + IWM(LETF)=IWM(LETF)+1 + IF (NEF .GT. 1) GO TO 665 +C +C ON FIRST ERROR TEST FAILURE, KEEP CURRENT ORDER OR LOWER +C ORDER BY ONE. COMPUTE NEW STEPSIZE BASED ON DIFFERENCES +C OF THE SOLUTION. + K = KNEW + TEMP2 = K + 1 + R = 0.90D0*(2.0D0*EST+0.0001D0)**(-1.0D0/TEMP2) + R = MAX(0.25D0,MIN(0.9D0,R)) + H = H*R + IF (ABS(H) .GE. HMIN) GO TO 690 + IDID = -6 + GO TO 675 +C +C ON SECOND ERROR TEST FAILURE, USE THE CURRENT ORDER OR +C DECREASE ORDER BY ONE. REDUCE THE STEPSIZE BY A FACTOR OF +C FOUR. +665 IF (NEF .GT. 2) GO TO 670 + K = KNEW + H = 0.25D0*H + IF (ABS(H) .GE. HMIN) GO TO 690 + IDID = -6 + GO TO 675 +C +C ON THIRD AND SUBSEQUENT ERROR TEST FAILURES, SET THE ORDER TO +C ONE AND REDUCE THE STEPSIZE BY A FACTOR OF FOUR. +670 K = 1 + H = 0.25D0*H + IF (ABS(H) .GE. HMIN) GO TO 690 + IDID = -6 + GO TO 675 +C +C +C +C +C FOR ALL CRASHES, RESTORE Y TO ITS LAST VALUE, +C INTERPOLATE TO FIND YPRIME AT LAST X, AND RETURN +675 CONTINUE + CALL DDATRP(X,X,Y,YPRIME,NEQ,K,PHI,PSI) + RETURN +C +C +C GO BACK AND TRY THIS STEP AGAIN +690 GO TO 200 +C +C------END OF SUBROUTINE DDASTP------ + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/dassl/ddatrp.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,64 @@ + SUBROUTINE DDATRP (X, XOUT, YOUT, YPOUT, NEQ, KOLD, PHI, PSI) +C***BEGIN PROLOGUE DDATRP +C***SUBSIDIARY +C***PURPOSE Interpolation routine for DDASSL. +C***LIBRARY SLATEC (DASSL) +C***TYPE DOUBLE PRECISION (SDATRP-S, DDATRP-D) +C***AUTHOR PETZOLD, LINDA R., (LLNL) +C***DESCRIPTION +C----------------------------------------------------------------------- +C THE METHODS IN SUBROUTINE DDASTP USE POLYNOMIALS +C TO APPROXIMATE THE SOLUTION. DDATRP APPROXIMATES THE +C SOLUTION AND ITS DERIVATIVE AT TIME XOUT BY EVALUATING +C ONE OF THESE POLYNOMIALS,AND ITS DERIVATIVE,THERE. +C INFORMATION DEFINING THIS POLYNOMIAL IS PASSED FROM +C DDASTP, SO DDATRP CANNOT BE USED ALONE. +C +C THE PARAMETERS ARE: +C X THE CURRENT TIME IN THE INTEGRATION. +C XOUT THE TIME AT WHICH THE SOLUTION IS DESIRED +C YOUT THE INTERPOLATED APPROXIMATION TO Y AT XOUT +C (THIS IS OUTPUT) +C YPOUT THE INTERPOLATED APPROXIMATION TO YPRIME AT XOUT +C (THIS IS OUTPUT) +C NEQ NUMBER OF EQUATIONS +C KOLD ORDER USED ON LAST SUCCESSFUL STEP +C PHI ARRAY OF SCALED DIVIDED DIFFERENCES OF Y +C PSI ARRAY OF PAST STEPSIZE HISTORY +C----------------------------------------------------------------------- +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 830315 DATE WRITTEN +C 901009 Finished conversion to SLATEC 4.0 format (F.N.Fritsch) +C 901019 Merged changes made by C. Ulrich with SLATEC 4.0 format. +C 901026 Added explicit declarations for all variables and minor +C cosmetic changes to prologue. (FNF) +C***END PROLOGUE DDATRP +C + INTEGER NEQ, KOLD + DOUBLE PRECISION X, XOUT, YOUT(*), YPOUT(*), PHI(NEQ,*), PSI(*) +C + INTEGER I, J, KOLDP1 + DOUBLE PRECISION C, D, GAMMA, TEMP1 +C +C***FIRST EXECUTABLE STATEMENT DDATRP + KOLDP1=KOLD+1 + TEMP1=XOUT-X + DO 10 I=1,NEQ + YOUT(I)=PHI(I,1) +10 YPOUT(I)=0.0D0 + C=1.0D0 + D=0.0D0 + GAMMA=TEMP1/PSI(1) + DO 30 J=2,KOLDP1 + D=D*GAMMA+C/PSI(J-1) + C=C*GAMMA + GAMMA=(TEMP1+PSI(J-1))/PSI(J) + DO 20 I=1,NEQ + YOUT(I)=YOUT(I)+C*PHI(I,J) +20 YPOUT(I)=YPOUT(I)+D*PHI(I,J) +30 CONTINUE + RETURN +C +C------END OF SUBROUTINE DDATRP------ + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/dassl/ddawts.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,42 @@ + SUBROUTINE DDAWTS (NEQ, IWT, RTOL, ATOL, Y, WT, RPAR, IPAR) +C***BEGIN PROLOGUE DDAWTS +C***SUBSIDIARY +C***PURPOSE Set error weight vector for DDASSL. +C***LIBRARY SLATEC (DASSL) +C***TYPE DOUBLE PRECISION (SDAWTS-S, DDAWTS-D) +C***AUTHOR PETZOLD, LINDA R., (LLNL) +C***DESCRIPTION +C----------------------------------------------------------------------- +C THIS SUBROUTINE SETS THE ERROR WEIGHT VECTOR +C WT ACCORDING TO WT(I)=RTOL(I)*ABS(Y(I))+ATOL(I), +C I=1,-,N. +C RTOL AND ATOL ARE SCALARS IF IWT = 0, +C AND VECTORS IF IWT = 1. +C----------------------------------------------------------------------- +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 830315 DATE WRITTEN +C 901009 Finished conversion to SLATEC 4.0 format (F.N.Fritsch) +C 901019 Merged changes made by C. Ulrich with SLATEC 4.0 format. +C 901026 Added explicit declarations for all variables and minor +C cosmetic changes to prologue. (FNF) +C***END PROLOGUE DDAWTS +C + INTEGER NEQ, IWT, IPAR(*) + DOUBLE PRECISION RTOL(*), ATOL(*), Y(*), WT(*), RPAR(*) +C + INTEGER I + DOUBLE PRECISION ATOLI, RTOLI +C +C***FIRST EXECUTABLE STATEMENT DDAWTS + RTOLI=RTOL(1) + ATOLI=ATOL(1) + DO 20 I=1,NEQ + IF (IWT .EQ.0) GO TO 10 + RTOLI=RTOL(I) + ATOLI=ATOL(I) +10 WT(I)=RTOLI*ABS(Y(I))+ATOLI +20 CONTINUE + RETURN +C-----------END OF SUBROUTINE DDAWTS------------------------------------ + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/dassl/module.mk Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,9 @@ +EXTERNAL_SOURCES += \ + liboctave/external/dassl/ddaini.f \ + liboctave/external/dassl/ddajac.f \ + liboctave/external/dassl/ddanrm.f \ + liboctave/external/dassl/ddaslv.f \ + liboctave/external/dassl/ddassl.f \ + liboctave/external/dassl/ddastp.f \ + liboctave/external/dassl/ddatrp.f \ + liboctave/external/dassl/ddawts.f
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/fftpack/cfftb.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,8 @@ + subroutine cfftb (n,c,wsave) + dimension c(*) ,wsave(*) + if (n .eq. 1) return + iw1 = n+n+1 + iw2 = iw1+n+n + call cfftb1 (n,c,wsave,wsave(iw1),wsave(iw2)) + return + end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/fftpack/cfftb1.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,61 @@ + subroutine cfftb1 (n,c,ch,wa,ifac) + dimension ch(*) ,c(*) ,wa(*) ,ifac(*) + nf = ifac(2) + na = 0 + l1 = 1 + iw = 1 + do 116 k1=1,nf + ip = ifac(k1+2) + l2 = ip*l1 + ido = n/l2 + idot = ido+ido + idl1 = idot*l1 + if (ip .ne. 4) go to 103 + ix2 = iw+idot + ix3 = ix2+idot + if (na .ne. 0) go to 101 + call passb4 (idot,l1,c,ch,wa(iw),wa(ix2),wa(ix3)) + go to 102 + 101 call passb4 (idot,l1,ch,c,wa(iw),wa(ix2),wa(ix3)) + 102 na = 1-na + go to 115 + 103 if (ip .ne. 2) go to 106 + if (na .ne. 0) go to 104 + call passb2 (idot,l1,c,ch,wa(iw)) + go to 105 + 104 call passb2 (idot,l1,ch,c,wa(iw)) + 105 na = 1-na + go to 115 + 106 if (ip .ne. 3) go to 109 + ix2 = iw+idot + if (na .ne. 0) go to 107 + call passb3 (idot,l1,c,ch,wa(iw),wa(ix2)) + go to 108 + 107 call passb3 (idot,l1,ch,c,wa(iw),wa(ix2)) + 108 na = 1-na + go to 115 + 109 if (ip .ne. 5) go to 112 + ix2 = iw+idot + ix3 = ix2+idot + ix4 = ix3+idot + if (na .ne. 0) go to 110 + call passb5 (idot,l1,c,ch,wa(iw),wa(ix2),wa(ix3),wa(ix4)) + go to 111 + 110 call passb5 (idot,l1,ch,c,wa(iw),wa(ix2),wa(ix3),wa(ix4)) + 111 na = 1-na + go to 115 + 112 if (na .ne. 0) go to 113 + call passb (nac,idot,ip,l1,idl1,c,c,c,ch,ch,wa(iw)) + go to 114 + 113 call passb (nac,idot,ip,l1,idl1,ch,ch,ch,c,c,wa(iw)) + 114 if (nac .ne. 0) na = 1-na + 115 l1 = l2 + iw = iw+(ip-1)*idot + 116 continue + if (na .eq. 0) return + n2 = n+n + do 117 i=1,n2 + c(i) = ch(i) + 117 continue + return + end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/fftpack/cfftf.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,8 @@ + subroutine cfftf (n,c,wsave) + dimension c(*) ,wsave(*) + if (n .eq. 1) return + iw1 = n+n+1 + iw2 = iw1+n+n + call cfftf1 (n,c,wsave,wsave(iw1),wsave(iw2)) + return + end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/fftpack/cfftf1.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,61 @@ + subroutine cfftf1 (n,c,ch,wa,ifac) + dimension ch(*) ,c(*) ,wa(*) ,ifac(*) + nf = ifac(2) + na = 0 + l1 = 1 + iw = 1 + do 116 k1=1,nf + ip = ifac(k1+2) + l2 = ip*l1 + ido = n/l2 + idot = ido+ido + idl1 = idot*l1 + if (ip .ne. 4) go to 103 + ix2 = iw+idot + ix3 = ix2+idot + if (na .ne. 0) go to 101 + call passf4 (idot,l1,c,ch,wa(iw),wa(ix2),wa(ix3)) + go to 102 + 101 call passf4 (idot,l1,ch,c,wa(iw),wa(ix2),wa(ix3)) + 102 na = 1-na + go to 115 + 103 if (ip .ne. 2) go to 106 + if (na .ne. 0) go to 104 + call passf2 (idot,l1,c,ch,wa(iw)) + go to 105 + 104 call passf2 (idot,l1,ch,c,wa(iw)) + 105 na = 1-na + go to 115 + 106 if (ip .ne. 3) go to 109 + ix2 = iw+idot + if (na .ne. 0) go to 107 + call passf3 (idot,l1,c,ch,wa(iw),wa(ix2)) + go to 108 + 107 call passf3 (idot,l1,ch,c,wa(iw),wa(ix2)) + 108 na = 1-na + go to 115 + 109 if (ip .ne. 5) go to 112 + ix2 = iw+idot + ix3 = ix2+idot + ix4 = ix3+idot + if (na .ne. 0) go to 110 + call passf5 (idot,l1,c,ch,wa(iw),wa(ix2),wa(ix3),wa(ix4)) + go to 111 + 110 call passf5 (idot,l1,ch,c,wa(iw),wa(ix2),wa(ix3),wa(ix4)) + 111 na = 1-na + go to 115 + 112 if (na .ne. 0) go to 113 + call passf (nac,idot,ip,l1,idl1,c,c,c,ch,ch,wa(iw)) + go to 114 + 113 call passf (nac,idot,ip,l1,idl1,ch,ch,ch,c,c,wa(iw)) + 114 if (nac .ne. 0) na = 1-na + 115 l1 = l2 + iw = iw+(ip-1)*idot + 116 continue + if (na .eq. 0) return + n2 = n+n + do 117 i=1,n2 + c(i) = ch(i) + 117 continue + return + end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/fftpack/cffti.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,8 @@ + subroutine cffti (n,wsave) + dimension wsave(*) + if (n .eq. 1) return + iw1 = n+n+1 + iw2 = iw1+n+n + call cffti1 (n,wsave(iw1),wsave(iw2)) + return + end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/fftpack/cffti1.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,60 @@ + subroutine cffti1 (n,wa,ifac) + dimension wa(*) ,ifac(*) ,ntryh(4) + data ntryh(1),ntryh(2),ntryh(3),ntryh(4)/3,4,2,5/ + nl = n + nf = 0 + j = 0 + 101 j = j+1 + if (j-4) 102,102,103 + 102 ntry = ntryh(j) + go to 104 + 103 ntry = ntry+2 + 104 nq = nl/ntry + nr = nl-ntry*nq + if (nr) 101,105,101 + 105 nf = nf+1 + ifac(nf+2) = ntry + nl = nq + if (ntry .ne. 2) go to 107 + if (nf .eq. 1) go to 107 + do 106 i=2,nf + ib = nf-i+2 + ifac(ib+2) = ifac(ib+1) + 106 continue + ifac(3) = 2 + 107 if (nl .ne. 1) go to 104 + ifac(1) = n + ifac(2) = nf + tpi = 6.28318530717959 + argh = tpi/dble(n) + i = 2 + l1 = 1 + do 110 k1=1,nf + ip = ifac(k1+2) + ld = 0 + l2 = l1*ip + ido = n/l2 + idot = ido+ido+2 + ipm = ip-1 + do 109 j=1,ipm + i1 = i + wa(i-1) = 1. + wa(i) = 0. + ld = ld+l1 + fi = 0. + argld = dble(ld)*argh + do 108 ii=4,idot,2 + i = i+2 + fi = fi+1. + arg = fi*argld + wa(i-1) = cos(arg) + wa(i) = sin(arg) + 108 continue + if (ip .le. 5) go to 109 + wa(i1-1) = wa(i-1) + wa(i1) = wa(i) + 109 continue + l1 = l2 + 110 continue + return + end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/fftpack/fftpack.doc Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,865 @@ + + FFTPACK + +* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + + version 4 april 1985 + + a package of fortran subprograms for the fast fourier + transform of periodic and other symmetric sequences + + by + + paul n swarztrauber + + national center for atmospheric research boulder,colorado 80307 + + which is sponsored by the national science foundation + +* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + + +this package consists of programs which perform fast fourier +transforms for both complex and real periodic sequences and +certain other symmetric sequences that are listed below. + +1. rffti initialize rfftf and rfftb +2. rfftf forward transform of a real periodic sequence +3. rfftb backward transform of a real coefficient array + +4. ezffti initialize ezfftf and ezfftb +5. ezfftf a simplified real periodic forward transform +6. ezfftb a simplified real periodic backward transform + +7. sinti initialize sint +8. sint sine transform of a real odd sequence + +9. costi initialize cost +10. cost cosine transform of a real even sequence + +11. sinqi initialize sinqf and sinqb +12. sinqf forward sine transform with odd wave numbers +13. sinqb unnormalized inverse of sinqf + +14. cosqi initialize cosqf and cosqb +15. cosqf forward cosine transform with odd wave numbers +16. cosqb unnormalized inverse of cosqf + +17. cffti initialize cfftf and cfftb +18. cfftf forward transform of a complex periodic sequence +19. cfftb unnormalized inverse of cfftf + + +****************************************************************** + +subroutine rffti(n,wsave) + + **************************************************************** + +subroutine rffti initializes the array wsave which is used in +both rfftf and rfftb. the prime factorization of n together with +a tabulation of the trigonometric functions are computed and +stored in wsave. + +input parameter + +n the length of the sequence to be transformed. + +output parameter + +wsave a work array which must be dimensioned at least 2*n+15. + the same work array can be used for both rfftf and rfftb + as long as n remains unchanged. different wsave arrays + are required for different values of n. the contents of + wsave must not be changed between calls of rfftf or rfftb. + +****************************************************************** + +subroutine rfftf(n,r,wsave) + +****************************************************************** + +subroutine rfftf computes the fourier coefficients of a real +perodic sequence (fourier analysis). the transform is defined +below at output parameter r. + +input parameters + +n the length of the array r to be transformed. the method + is most efficient when n is a product of small primes. + n may change so long as different work arrays are provided + +r a real array of length n which contains the sequence + to be transformed + +wsave a work array which must be dimensioned at least 2*n+15. + in the program that calls rfftf. the wsave array must be + initialized by calling subroutine rffti(n,wsave) and a + different wsave array must be used for each different + value of n. this initialization does not have to be + repeated so long as n remains unchanged thus subsequent + transforms can be obtained faster than the first. + the same wsave array can be used by rfftf and rfftb. + + +output parameters + +r r(1) = the sum from i=1 to i=n of r(i) + + if n is even set l =n/2 , if n is odd set l = (n+1)/2 + + then for k = 2,...,l + + r(2*k-2) = the sum from i = 1 to i = n of + + r(i)*cos((k-1)*(i-1)*2*pi/n) + + r(2*k-1) = the sum from i = 1 to i = n of + + -r(i)*sin((k-1)*(i-1)*2*pi/n) + + if n is even + + r(n) = the sum from i = 1 to i = n of + + (-1)**(i-1)*r(i) + + ***** note + this transform is unnormalized since a call of rfftf + followed by a call of rfftb will multiply the input + sequence by n. + +wsave contains results which must not be destroyed between + calls of rfftf or rfftb. + + +****************************************************************** + +subroutine rfftb(n,r,wsave) + +****************************************************************** + +subroutine rfftb computes the real perodic sequence from its +fourier coefficients (fourier synthesis). the transform is defined +below at output parameter r. + +input parameters + +n the length of the array r to be transformed. the method + is most efficient when n is a product of small primes. + n may change so long as different work arrays are provided + +r a real array of length n which contains the sequence + to be transformed + +wsave a work array which must be dimensioned at least 2*n+15. + in the program that calls rfftb. the wsave array must be + initialized by calling subroutine rffti(n,wsave) and a + different wsave array must be used for each different + value of n. this initialization does not have to be + repeated so long as n remains unchanged thus subsequent + transforms can be obtained faster than the first. + the same wsave array can be used by rfftf and rfftb. + + +output parameters + +r for n even and for i = 1,...,n + + r(i) = r(1)+(-1)**(i-1)*r(n) + + plus the sum from k=2 to k=n/2 of + + 2.*r(2*k-2)*cos((k-1)*(i-1)*2*pi/n) + + -2.*r(2*k-1)*sin((k-1)*(i-1)*2*pi/n) + + for n odd and for i = 1,...,n + + r(i) = r(1) plus the sum from k=2 to k=(n+1)/2 of + + 2.*r(2*k-2)*cos((k-1)*(i-1)*2*pi/n) + + -2.*r(2*k-1)*sin((k-1)*(i-1)*2*pi/n) + + ***** note + this transform is unnormalized since a call of rfftf + followed by a call of rfftb will multiply the input + sequence by n. + +wsave contains results which must not be destroyed between + calls of rfftb or rfftf. + + +****************************************************************** + +subroutine ezffti(n,wsave) + +****************************************************************** + +subroutine ezffti initializes the array wsave which is used in +both ezfftf and ezfftb. the prime factorization of n together with +a tabulation of the trigonometric functions are computed and +stored in wsave. + +input parameter + +n the length of the sequence to be transformed. + +output parameter + +wsave a work array which must be dimensioned at least 3*n+15. + the same work array can be used for both ezfftf and ezfftb + as long as n remains unchanged. different wsave arrays + are required for different values of n. + + +****************************************************************** + +subroutine ezfftf(n,r,azero,a,b,wsave) + +****************************************************************** + +subroutine ezfftf computes the fourier coefficients of a real +perodic sequence (fourier analysis). the transform is defined +below at output parameters azero,a and b. ezfftf is a simplified +but slower version of rfftf. + +input parameters + +n the length of the array r to be transformed. the method + is must efficient when n is the product of small primes. + +r a real array of length n which contains the sequence + to be transformed. r is not destroyed. + + +wsave a work array which must be dimensioned at least 3*n+15. + in the program that calls ezfftf. the wsave array must be + initialized by calling subroutine ezffti(n,wsave) and a + different wsave array must be used for each different + value of n. this initialization does not have to be + repeated so long as n remains unchanged thus subsequent + transforms can be obtained faster than the first. + the same wsave array can be used by ezfftf and ezfftb. + +output parameters + +azero the sum from i=1 to i=n of r(i)/n + +a,b for n even b(n/2)=0. and a(n/2) is the sum from i=1 to + i=n of (-1)**(i-1)*r(i)/n + + for n even define kmax=n/2-1 + for n odd define kmax=(n-1)/2 + + then for k=1,...,kmax + + a(k) equals the sum from i=1 to i=n of + + 2./n*r(i)*cos(k*(i-1)*2*pi/n) + + b(k) equals the sum from i=1 to i=n of + + 2./n*r(i)*sin(k*(i-1)*2*pi/n) + + +****************************************************************** + +subroutine ezfftb(n,r,azero,a,b,wsave) + +****************************************************************** + +subroutine ezfftb computes a real perodic sequence from its +fourier coefficients (fourier synthesis). the transform is +defined below at output parameter r. ezfftb is a simplified +but slower version of rfftb. + +input parameters + +n the length of the output array r. the method is most + efficient when n is the product of small primes. + +azero the constant fourier coefficient + +a,b arrays which contain the remaining fourier coefficients + these arrays are not destroyed. + + the length of these arrays depends on whether n is even or + odd. + + if n is even n/2 locations are required + if n is odd (n-1)/2 locations are required + +wsave a work array which must be dimensioned at least 3*n+15. + in the program that calls ezfftb. the wsave array must be + initialized by calling subroutine ezffti(n,wsave) and a + different wsave array must be used for each different + value of n. this initialization does not have to be + repeated so long as n remains unchanged thus subsequent + transforms can be obtained faster than the first. + the same wsave array can be used by ezfftf and ezfftb. + + +output parameters + +r if n is even define kmax=n/2 + if n is odd define kmax=(n-1)/2 + + then for i=1,...,n + + r(i)=azero plus the sum from k=1 to k=kmax of + + a(k)*cos(k*(i-1)*2*pi/n)+b(k)*sin(k*(i-1)*2*pi/n) + +********************* complex notation ************************** + + for j=1,...,n + + r(j) equals the sum from k=-kmax to k=kmax of + + c(k)*exp(i*k*(j-1)*2*pi/n) + + where + + c(k) = .5*cmplx(a(k),-b(k)) for k=1,...,kmax + + c(-k) = conjg(c(k)) + + c(0) = azero + + and i=sqrt(-1) + +*************** amplitude - phase notation *********************** + + for i=1,...,n + + r(i) equals azero plus the sum from k=1 to k=kmax of + + alpha(k)*cos(k*(i-1)*2*pi/n+beta(k)) + + where + + alpha(k) = sqrt(a(k)*a(k)+b(k)*b(k)) + + cos(beta(k))=a(k)/alpha(k) + + sin(beta(k))=-b(k)/alpha(k) + +****************************************************************** + +subroutine sinti(n,wsave) + +****************************************************************** + +subroutine sinti initializes the array wsave which is used in +subroutine sint. the prime factorization of n together with +a tabulation of the trigonometric functions are computed and +stored in wsave. + +input parameter + +n the length of the sequence to be transformed. the method + is most efficient when n+1 is a product of small primes. + +output parameter + +wsave a work array with at least int(2.5*n+15) locations. + different wsave arrays are required for different values + of n. the contents of wsave must not be changed between + calls of sint. + +****************************************************************** + +subroutine sint(n,x,wsave) + +****************************************************************** + +subroutine sint computes the discrete fourier sine transform +of an odd sequence x(i). the transform is defined below at +output parameter x. + +sint is the unnormalized inverse of itself since a call of sint +followed by another call of sint will multiply the input sequence +x by 2*(n+1). + +the array wsave which is used by subroutine sint must be +initialized by calling subroutine sinti(n,wsave). + +input parameters + +n the length of the sequence to be transformed. the method + is most efficient when n+1 is the product of small primes. + +x an array which contains the sequence to be transformed + + +wsave a work array with dimension at least int(2.5*n+15) + in the program that calls sint. the wsave array must be + initialized by calling subroutine sinti(n,wsave) and a + different wsave array must be used for each different + value of n. this initialization does not have to be + repeated so long as n remains unchanged thus subsequent + transforms can be obtained faster than the first. + +output parameters + +x for i=1,...,n + + x(i)= the sum from k=1 to k=n + + 2*x(k)*sin(k*i*pi/(n+1)) + + a call of sint followed by another call of + sint will multiply the sequence x by 2*(n+1). + hence sint is the unnormalized inverse + of itself. + +wsave contains initialization calculations which must not be + destroyed between calls of sint. + +****************************************************************** + +subroutine costi(n,wsave) + +****************************************************************** + +subroutine costi initializes the array wsave which is used in +subroutine cost. the prime factorization of n together with +a tabulation of the trigonometric functions are computed and +stored in wsave. + +input parameter + +n the length of the sequence to be transformed. the method + is most efficient when n-1 is a product of small primes. + +output parameter + +wsave a work array which must be dimensioned at least 3*n+15. + different wsave arrays are required for different values + of n. the contents of wsave must not be changed between + calls of cost. + +****************************************************************** + +subroutine cost(n,x,wsave) + +****************************************************************** + +subroutine cost computes the discrete fourier cosine transform +of an even sequence x(i). the transform is defined below at output +parameter x. + +cost is the unnormalized inverse of itself since a call of cost +followed by another call of cost will multiply the input sequence +x by 2*(n-1). the transform is defined below at output parameter x + +the array wsave which is used by subroutine cost must be +initialized by calling subroutine costi(n,wsave). + +input parameters + +n the length of the sequence x. n must be greater than 1. + the method is most efficient when n-1 is a product of + small primes. + +x an array which contains the sequence to be transformed + +wsave a work array which must be dimensioned at least 3*n+15 + in the program that calls cost. the wsave array must be + initialized by calling subroutine costi(n,wsave) and a + different wsave array must be used for each different + value of n. this initialization does not have to be + repeated so long as n remains unchanged thus subsequent + transforms can be obtained faster than the first. + +output parameters + +x for i=1,...,n + + x(i) = x(1)+(-1)**(i-1)*x(n) + + + the sum from k=2 to k=n-1 + + 2*x(k)*cos((k-1)*(i-1)*pi/(n-1)) + + a call of cost followed by another call of + cost will multiply the sequence x by 2*(n-1) + hence cost is the unnormalized inverse + of itself. + +wsave contains initialization calculations which must not be + destroyed between calls of cost. + +****************************************************************** + +subroutine sinqi(n,wsave) + +****************************************************************** + +subroutine sinqi initializes the array wsave which is used in +both sinqf and sinqb. the prime factorization of n together with +a tabulation of the trigonometric functions are computed and +stored in wsave. + +input parameter + +n the length of the sequence to be transformed. the method + is most efficient when n is a product of small primes. + +output parameter + +wsave a work array which must be dimensioned at least 3*n+15. + the same work array can be used for both sinqf and sinqb + as long as n remains unchanged. different wsave arrays + are required for different values of n. the contents of + wsave must not be changed between calls of sinqf or sinqb. + +****************************************************************** + +subroutine sinqf(n,x,wsave) + +****************************************************************** + +subroutine sinqf computes the fast fourier transform of quarter +wave data. that is , sinqf computes the coefficients in a sine +series representation with only odd wave numbers. the transform +is defined below at output parameter x. + +sinqb is the unnormalized inverse of sinqf since a call of sinqf +followed by a call of sinqb will multiply the input sequence x +by 4*n. + +the array wsave which is used by subroutine sinqf must be +initialized by calling subroutine sinqi(n,wsave). + + +input parameters + +n the length of the array x to be transformed. the method + is most efficient when n is a product of small primes. + +x an array which contains the sequence to be transformed + +wsave a work array which must be dimensioned at least 3*n+15. + in the program that calls sinqf. the wsave array must be + initialized by calling subroutine sinqi(n,wsave) and a + different wsave array must be used for each different + value of n. this initialization does not have to be + repeated so long as n remains unchanged thus subsequent + transforms can be obtained faster than the first. + +output parameters + +x for i=1,...,n + + x(i) = (-1)**(i-1)*x(n) + + + the sum from k=1 to k=n-1 of + + 2*x(k)*sin((2*i-1)*k*pi/(2*n)) + + a call of sinqf followed by a call of + sinqb will multiply the sequence x by 4*n. + therefore sinqb is the unnormalized inverse + of sinqf. + +wsave contains initialization calculations which must not + be destroyed between calls of sinqf or sinqb. + +****************************************************************** + +subroutine sinqb(n,x,wsave) + +****************************************************************** + +subroutine sinqb computes the fast fourier transform of quarter +wave data. that is , sinqb computes a sequence from its +representation in terms of a sine series with odd wave numbers. +the transform is defined below at output parameter x. + +sinqf is the unnormalized inverse of sinqb since a call of sinqb +followed by a call of sinqf will multiply the input sequence x +by 4*n. + +the array wsave which is used by subroutine sinqb must be +initialized by calling subroutine sinqi(n,wsave). + + +input parameters + +n the length of the array x to be transformed. the method + is most efficient when n is a product of small primes. + +x an array which contains the sequence to be transformed + +wsave a work array which must be dimensioned at least 3*n+15. + in the program that calls sinqb. the wsave array must be + initialized by calling subroutine sinqi(n,wsave) and a + different wsave array must be used for each different + value of n. this initialization does not have to be + repeated so long as n remains unchanged thus subsequent + transforms can be obtained faster than the first. + +output parameters + +x for i=1,...,n + + x(i)= the sum from k=1 to k=n of + + 4*x(k)*sin((2k-1)*i*pi/(2*n)) + + a call of sinqb followed by a call of + sinqf will multiply the sequence x by 4*n. + therefore sinqf is the unnormalized inverse + of sinqb. + +wsave contains initialization calculations which must not + be destroyed between calls of sinqb or sinqf. + +****************************************************************** + +subroutine cosqi(n,wsave) + +****************************************************************** + +subroutine cosqi initializes the array wsave which is used in +both cosqf and cosqb. the prime factorization of n together with +a tabulation of the trigonometric functions are computed and +stored in wsave. + +input parameter + +n the length of the array to be transformed. the method + is most efficient when n is a product of small primes. + +output parameter + +wsave a work array which must be dimensioned at least 3*n+15. + the same work array can be used for both cosqf and cosqb + as long as n remains unchanged. different wsave arrays + are required for different values of n. the contents of + wsave must not be changed between calls of cosqf or cosqb. + +****************************************************************** + +subroutine cosqf(n,x,wsave) + +****************************************************************** + +subroutine cosqf computes the fast fourier transform of quarter +wave data. that is , cosqf computes the coefficients in a cosine +series representation with only odd wave numbers. the transform +is defined below at output parameter x + +cosqf is the unnormalized inverse of cosqb since a call of cosqf +followed by a call of cosqb will multiply the input sequence x +by 4*n. + +the array wsave which is used by subroutine cosqf must be +initialized by calling subroutine cosqi(n,wsave). + + +input parameters + +n the length of the array x to be transformed. the method + is most efficient when n is a product of small primes. + +x an array which contains the sequence to be transformed + +wsave a work array which must be dimensioned at least 3*n+15 + in the program that calls cosqf. the wsave array must be + initialized by calling subroutine cosqi(n,wsave) and a + different wsave array must be used for each different + value of n. this initialization does not have to be + repeated so long as n remains unchanged thus subsequent + transforms can be obtained faster than the first. + +output parameters + +x for i=1,...,n + + x(i) = x(1) plus the sum from k=2 to k=n of + + 2*x(k)*cos((2*i-1)*(k-1)*pi/(2*n)) + + a call of cosqf followed by a call of + cosqb will multiply the sequence x by 4*n. + therefore cosqb is the unnormalized inverse + of cosqf. + +wsave contains initialization calculations which must not + be destroyed between calls of cosqf or cosqb. + +****************************************************************** + +subroutine cosqb(n,x,wsave) + +****************************************************************** + +subroutine cosqb computes the fast fourier transform of quarter +wave data. that is , cosqb computes a sequence from its +representation in terms of a cosine series with odd wave numbers. +the transform is defined below at output parameter x. + +cosqb is the unnormalized inverse of cosqf since a call of cosqb +followed by a call of cosqf will multiply the input sequence x +by 4*n. + +the array wsave which is used by subroutine cosqb must be +initialized by calling subroutine cosqi(n,wsave). + + +input parameters + +n the length of the array x to be transformed. the method + is most efficient when n is a product of small primes. + +x an array which contains the sequence to be transformed + +wsave a work array that must be dimensioned at least 3*n+15 + in the program that calls cosqb. the wsave array must be + initialized by calling subroutine cosqi(n,wsave) and a + different wsave array must be used for each different + value of n. this initialization does not have to be + repeated so long as n remains unchanged thus subsequent + transforms can be obtained faster than the first. + +output parameters + +x for i=1,...,n + + x(i)= the sum from k=1 to k=n of + + 4*x(k)*cos((2*k-1)*(i-1)*pi/(2*n)) + + a call of cosqb followed by a call of + cosqf will multiply the sequence x by 4*n. + therefore cosqf is the unnormalized inverse + of cosqb. + +wsave contains initialization calculations which must not + be destroyed between calls of cosqb or cosqf. + +****************************************************************** + +subroutine cffti(n,wsave) + +****************************************************************** + +subroutine cffti initializes the array wsave which is used in +both cfftf and cfftb. the prime factorization of n together with +a tabulation of the trigonometric functions are computed and +stored in wsave. + +input parameter + +n the length of the sequence to be transformed + +output parameter + +wsave a work array which must be dimensioned at least 4*n+15 + the same work array can be used for both cfftf and cfftb + as long as n remains unchanged. different wsave arrays + are required for different values of n. the contents of + wsave must not be changed between calls of cfftf or cfftb. + +****************************************************************** + +subroutine cfftf(n,c,wsave) + +****************************************************************** + +subroutine cfftf computes the forward complex discrete fourier +transform (the fourier analysis). equivalently , cfftf computes +the fourier coefficients of a complex periodic sequence. +the transform is defined below at output parameter c. + +the transform is not normalized. to obtain a normalized transform +the output must be divided by n. otherwise a call of cfftf +followed by a call of cfftb will multiply the sequence by n. + +the array wsave which is used by subroutine cfftf must be +initialized by calling subroutine cffti(n,wsave). + +input parameters + + +n the length of the complex sequence c. the method is + more efficient when n is the product of small primes. n + +c a complex array of length n which contains the sequence + +wsave a real work array which must be dimensioned at least 4n+15 + in the program that calls cfftf. the wsave array must be + initialized by calling subroutine cffti(n,wsave) and a + different wsave array must be used for each different + value of n. this initialization does not have to be + repeated so long as n remains unchanged thus subsequent + transforms can be obtained faster than the first. + the same wsave array can be used by cfftf and cfftb. + +output parameters + +c for j=1,...,n + + c(j)=the sum from k=1,...,n of + + c(k)*exp(-i*(j-1)*(k-1)*2*pi/n) + + where i=sqrt(-1) + +wsave contains initialization calculations which must not be + destroyed between calls of subroutine cfftf or cfftb + +****************************************************************** + +subroutine cfftb(n,c,wsave) + +****************************************************************** + +subroutine cfftb computes the backward complex discrete fourier +transform (the fourier synthesis). equivalently , cfftb computes +a complex periodic sequence from its fourier coefficients. +the transform is defined below at output parameter c. + +a call of cfftf followed by a call of cfftb will multiply the +sequence by n. + +the array wsave which is used by subroutine cfftb must be +initialized by calling subroutine cffti(n,wsave). + +input parameters + + +n the length of the complex sequence c. the method is + more efficient when n is the product of small primes. + +c a complex array of length n which contains the sequence + +wsave a real work array which must be dimensioned at least 4n+15 + in the program that calls cfftb. the wsave array must be + initialized by calling subroutine cffti(n,wsave) and a + different wsave array must be used for each different + value of n. this initialization does not have to be + repeated so long as n remains unchanged thus subsequent + transforms can be obtained faster than the first. + the same wsave array can be used by cfftf and cfftb. + +output parameters + +c for j=1,...,n + + c(j)=the sum from k=1,...,n of + + c(k)*exp(i*(j-1)*(k-1)*2*pi/n) + + where i=sqrt(-1) + +wsave contains initialization calculations which must not be + destroyed between calls of subroutine cfftf or cfftb + + + +["send index for vfftpk" describes a vectorized version of fftpack]
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/fftpack/module.mk Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,42 @@ +FFTPACK_SRC = \ + liboctave/external/fftpack/cfftb.f \ + liboctave/external/fftpack/cfftb1.f \ + liboctave/external/fftpack/cfftf.f \ + liboctave/external/fftpack/cfftf1.f \ + liboctave/external/fftpack/cffti.f \ + liboctave/external/fftpack/cffti1.f \ + liboctave/external/fftpack/passb.f \ + liboctave/external/fftpack/passb2.f \ + liboctave/external/fftpack/passb3.f \ + liboctave/external/fftpack/passb4.f \ + liboctave/external/fftpack/passb5.f \ + liboctave/external/fftpack/passf.f \ + liboctave/external/fftpack/passf2.f \ + liboctave/external/fftpack/passf3.f \ + liboctave/external/fftpack/passf4.f \ + liboctave/external/fftpack/passf5.f \ + liboctave/external/fftpack/zfftb.f \ + liboctave/external/fftpack/zfftb1.f \ + liboctave/external/fftpack/zfftf.f \ + liboctave/external/fftpack/zfftf1.f \ + liboctave/external/fftpack/zffti.f \ + liboctave/external/fftpack/zffti1.f \ + liboctave/external/fftpack/zpassb.f \ + liboctave/external/fftpack/zpassb2.f \ + liboctave/external/fftpack/zpassb3.f \ + liboctave/external/fftpack/zpassb4.f \ + liboctave/external/fftpack/zpassb5.f \ + liboctave/external/fftpack/zpassf.f \ + liboctave/external/fftpack/zpassf2.f \ + liboctave/external/fftpack/zpassf3.f \ + liboctave/external/fftpack/zpassf4.f \ + liboctave/external/fftpack/zpassf5.f + +if AMCOND_HAVE_FFTW + liboctave_EXTRA_DIST += $(FFTPACK_SRC) +else + EXTERNAL_SOURCES += $(FFTPACK_SRC) +endif + +liboctave_EXTRA_DIST += \ + liboctave/external/fftpack/fftpack.doc
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/fftpack/passb.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,116 @@ + subroutine passb (nac,ido,ip,l1,idl1,cc,c1,c2,ch,ch2,wa) + dimension ch(ido,l1,ip) ,cc(ido,ip,l1) , + 1 c1(ido,l1,ip) ,wa(1) ,c2(idl1,ip), + 2 ch2(idl1,ip) + idot = ido/2 + nt = ip*idl1 + ipp2 = ip+2 + ipph = (ip+1)/2 + idp = ip*ido +c + if (ido .lt. l1) go to 106 + do 103 j=2,ipph + jc = ipp2-j + do 102 k=1,l1 + do 101 i=1,ido + ch(i,k,j) = cc(i,j,k)+cc(i,jc,k) + ch(i,k,jc) = cc(i,j,k)-cc(i,jc,k) + 101 continue + 102 continue + 103 continue + do 105 k=1,l1 + do 104 i=1,ido + ch(i,k,1) = cc(i,1,k) + 104 continue + 105 continue + go to 112 + 106 do 109 j=2,ipph + jc = ipp2-j + do 108 i=1,ido + do 107 k=1,l1 + ch(i,k,j) = cc(i,j,k)+cc(i,jc,k) + ch(i,k,jc) = cc(i,j,k)-cc(i,jc,k) + 107 continue + 108 continue + 109 continue + do 111 i=1,ido + do 110 k=1,l1 + ch(i,k,1) = cc(i,1,k) + 110 continue + 111 continue + 112 idl = 2-ido + inc = 0 + do 116 l=2,ipph + lc = ipp2-l + idl = idl+ido + do 113 ik=1,idl1 + c2(ik,l) = ch2(ik,1)+wa(idl-1)*ch2(ik,2) + c2(ik,lc) = wa(idl)*ch2(ik,ip) + 113 continue + idlj = idl + inc = inc+ido + do 115 j=3,ipph + jc = ipp2-j + idlj = idlj+inc + if (idlj .gt. idp) idlj = idlj-idp + war = wa(idlj-1) + wai = wa(idlj) + do 114 ik=1,idl1 + c2(ik,l) = c2(ik,l)+war*ch2(ik,j) + c2(ik,lc) = c2(ik,lc)+wai*ch2(ik,jc) + 114 continue + 115 continue + 116 continue + do 118 j=2,ipph + do 117 ik=1,idl1 + ch2(ik,1) = ch2(ik,1)+ch2(ik,j) + 117 continue + 118 continue + do 120 j=2,ipph + jc = ipp2-j + do 119 ik=2,idl1,2 + ch2(ik-1,j) = c2(ik-1,j)-c2(ik,jc) + ch2(ik-1,jc) = c2(ik-1,j)+c2(ik,jc) + ch2(ik,j) = c2(ik,j)+c2(ik-1,jc) + ch2(ik,jc) = c2(ik,j)-c2(ik-1,jc) + 119 continue + 120 continue + nac = 1 + if (ido .eq. 2) return + nac = 0 + do 121 ik=1,idl1 + c2(ik,1) = ch2(ik,1) + 121 continue + do 123 j=2,ip + do 122 k=1,l1 + c1(1,k,j) = ch(1,k,j) + c1(2,k,j) = ch(2,k,j) + 122 continue + 123 continue + if (idot .gt. l1) go to 127 + idij = 0 + do 126 j=2,ip + idij = idij+2 + do 125 i=4,ido,2 + idij = idij+2 + do 124 k=1,l1 + c1(i-1,k,j) = wa(idij-1)*ch(i-1,k,j)-wa(idij)*ch(i,k,j) + c1(i,k,j) = wa(idij-1)*ch(i,k,j)+wa(idij)*ch(i-1,k,j) + 124 continue + 125 continue + 126 continue + return + 127 idj = 2-ido + do 130 j=2,ip + idj = idj+ido + do 129 k=1,l1 + idij = idj + do 128 i=4,ido,2 + idij = idij+2 + c1(i-1,k,j) = wa(idij-1)*ch(i-1,k,j)-wa(idij)*ch(i,k,j) + c1(i,k,j) = wa(idij-1)*ch(i,k,j)+wa(idij)*ch(i-1,k,j) + 128 continue + 129 continue + 130 continue + return + end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/fftpack/passb2.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,23 @@ + subroutine passb2 (ido,l1,cc,ch,wa1) + dimension cc(ido,2,l1) ,ch(ido,l1,2) , + 1 wa1(1) + if (ido .gt. 2) go to 102 + do 101 k=1,l1 + ch(1,k,1) = cc(1,1,k)+cc(1,2,k) + ch(1,k,2) = cc(1,1,k)-cc(1,2,k) + ch(2,k,1) = cc(2,1,k)+cc(2,2,k) + ch(2,k,2) = cc(2,1,k)-cc(2,2,k) + 101 continue + return + 102 do 104 k=1,l1 + do 103 i=2,ido,2 + ch(i-1,k,1) = cc(i-1,1,k)+cc(i-1,2,k) + tr2 = cc(i-1,1,k)-cc(i-1,2,k) + ch(i,k,1) = cc(i,1,k)+cc(i,2,k) + ti2 = cc(i,1,k)-cc(i,2,k) + ch(i,k,2) = wa1(i-1)*ti2+wa1(i)*tr2 + ch(i-1,k,2) = wa1(i-1)*tr2-wa1(i)*ti2 + 103 continue + 104 continue + return + end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/fftpack/passb3.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,42 @@ + subroutine passb3 (ido,l1,cc,ch,wa1,wa2) + dimension cc(ido,3,l1) ,ch(ido,l1,3) , + 1 wa1(1) ,wa2(1) + data taur,taui /-.5,.866025403784439/ + if (ido .ne. 2) go to 102 + do 101 k=1,l1 + tr2 = cc(1,2,k)+cc(1,3,k) + cr2 = cc(1,1,k)+taur*tr2 + ch(1,k,1) = cc(1,1,k)+tr2 + ti2 = cc(2,2,k)+cc(2,3,k) + ci2 = cc(2,1,k)+taur*ti2 + ch(2,k,1) = cc(2,1,k)+ti2 + cr3 = taui*(cc(1,2,k)-cc(1,3,k)) + ci3 = taui*(cc(2,2,k)-cc(2,3,k)) + ch(1,k,2) = cr2-ci3 + ch(1,k,3) = cr2+ci3 + ch(2,k,2) = ci2+cr3 + ch(2,k,3) = ci2-cr3 + 101 continue + return + 102 do 104 k=1,l1 + do 103 i=2,ido,2 + tr2 = cc(i-1,2,k)+cc(i-1,3,k) + cr2 = cc(i-1,1,k)+taur*tr2 + ch(i-1,k,1) = cc(i-1,1,k)+tr2 + ti2 = cc(i,2,k)+cc(i,3,k) + ci2 = cc(i,1,k)+taur*ti2 + ch(i,k,1) = cc(i,1,k)+ti2 + cr3 = taui*(cc(i-1,2,k)-cc(i-1,3,k)) + ci3 = taui*(cc(i,2,k)-cc(i,3,k)) + dr2 = cr2-ci3 + dr3 = cr2+ci3 + di2 = ci2+cr3 + di3 = ci2-cr3 + ch(i,k,2) = wa1(i-1)*di2+wa1(i)*dr2 + ch(i-1,k,2) = wa1(i-1)*dr2-wa1(i)*di2 + ch(i,k,3) = wa2(i-1)*di3+wa2(i)*dr3 + ch(i-1,k,3) = wa2(i-1)*dr3-wa2(i)*di3 + 103 continue + 104 continue + return + end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/fftpack/passb4.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,51 @@ + subroutine passb4 (ido,l1,cc,ch,wa1,wa2,wa3) + dimension cc(ido,4,l1) ,ch(ido,l1,4) , + 1 wa1(1) ,wa2(1) ,wa3(1) + if (ido .ne. 2) go to 102 + do 101 k=1,l1 + ti1 = cc(2,1,k)-cc(2,3,k) + ti2 = cc(2,1,k)+cc(2,3,k) + tr4 = cc(2,4,k)-cc(2,2,k) + ti3 = cc(2,2,k)+cc(2,4,k) + tr1 = cc(1,1,k)-cc(1,3,k) + tr2 = cc(1,1,k)+cc(1,3,k) + ti4 = cc(1,2,k)-cc(1,4,k) + tr3 = cc(1,2,k)+cc(1,4,k) + ch(1,k,1) = tr2+tr3 + ch(1,k,3) = tr2-tr3 + ch(2,k,1) = ti2+ti3 + ch(2,k,3) = ti2-ti3 + ch(1,k,2) = tr1+tr4 + ch(1,k,4) = tr1-tr4 + ch(2,k,2) = ti1+ti4 + ch(2,k,4) = ti1-ti4 + 101 continue + return + 102 do 104 k=1,l1 + do 103 i=2,ido,2 + ti1 = cc(i,1,k)-cc(i,3,k) + ti2 = cc(i,1,k)+cc(i,3,k) + ti3 = cc(i,2,k)+cc(i,4,k) + tr4 = cc(i,4,k)-cc(i,2,k) + tr1 = cc(i-1,1,k)-cc(i-1,3,k) + tr2 = cc(i-1,1,k)+cc(i-1,3,k) + ti4 = cc(i-1,2,k)-cc(i-1,4,k) + tr3 = cc(i-1,2,k)+cc(i-1,4,k) + ch(i-1,k,1) = tr2+tr3 + cr3 = tr2-tr3 + ch(i,k,1) = ti2+ti3 + ci3 = ti2-ti3 + cr2 = tr1+tr4 + cr4 = tr1-tr4 + ci2 = ti1+ti4 + ci4 = ti1-ti4 + ch(i-1,k,2) = wa1(i-1)*cr2-wa1(i)*ci2 + ch(i,k,2) = wa1(i-1)*ci2+wa1(i)*cr2 + ch(i-1,k,3) = wa2(i-1)*cr3-wa2(i)*ci3 + ch(i,k,3) = wa2(i-1)*ci3+wa2(i)*cr3 + ch(i-1,k,4) = wa3(i-1)*cr4-wa3(i)*ci4 + ch(i,k,4) = wa3(i-1)*ci4+wa3(i)*cr4 + 103 continue + 104 continue + return + end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/fftpack/passb5.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,75 @@ + subroutine passb5 (ido,l1,cc,ch,wa1,wa2,wa3,wa4) + dimension cc(ido,5,l1) ,ch(ido,l1,5) , + 1 wa1(1) ,wa2(1) ,wa3(1) ,wa4(1) + data tr11,ti11,tr12,ti12 /.309016994374947,.951056516295154, + 1-.809016994374947,.587785252292473/ + if (ido .ne. 2) go to 102 + do 101 k=1,l1 + ti5 = cc(2,2,k)-cc(2,5,k) + ti2 = cc(2,2,k)+cc(2,5,k) + ti4 = cc(2,3,k)-cc(2,4,k) + ti3 = cc(2,3,k)+cc(2,4,k) + tr5 = cc(1,2,k)-cc(1,5,k) + tr2 = cc(1,2,k)+cc(1,5,k) + tr4 = cc(1,3,k)-cc(1,4,k) + tr3 = cc(1,3,k)+cc(1,4,k) + ch(1,k,1) = cc(1,1,k)+tr2+tr3 + ch(2,k,1) = cc(2,1,k)+ti2+ti3 + cr2 = cc(1,1,k)+tr11*tr2+tr12*tr3 + ci2 = cc(2,1,k)+tr11*ti2+tr12*ti3 + cr3 = cc(1,1,k)+tr12*tr2+tr11*tr3 + ci3 = cc(2,1,k)+tr12*ti2+tr11*ti3 + cr5 = ti11*tr5+ti12*tr4 + ci5 = ti11*ti5+ti12*ti4 + cr4 = ti12*tr5-ti11*tr4 + ci4 = ti12*ti5-ti11*ti4 + ch(1,k,2) = cr2-ci5 + ch(1,k,5) = cr2+ci5 + ch(2,k,2) = ci2+cr5 + ch(2,k,3) = ci3+cr4 + ch(1,k,3) = cr3-ci4 + ch(1,k,4) = cr3+ci4 + ch(2,k,4) = ci3-cr4 + ch(2,k,5) = ci2-cr5 + 101 continue + return + 102 do 104 k=1,l1 + do 103 i=2,ido,2 + ti5 = cc(i,2,k)-cc(i,5,k) + ti2 = cc(i,2,k)+cc(i,5,k) + ti4 = cc(i,3,k)-cc(i,4,k) + ti3 = cc(i,3,k)+cc(i,4,k) + tr5 = cc(i-1,2,k)-cc(i-1,5,k) + tr2 = cc(i-1,2,k)+cc(i-1,5,k) + tr4 = cc(i-1,3,k)-cc(i-1,4,k) + tr3 = cc(i-1,3,k)+cc(i-1,4,k) + ch(i-1,k,1) = cc(i-1,1,k)+tr2+tr3 + ch(i,k,1) = cc(i,1,k)+ti2+ti3 + cr2 = cc(i-1,1,k)+tr11*tr2+tr12*tr3 + ci2 = cc(i,1,k)+tr11*ti2+tr12*ti3 + cr3 = cc(i-1,1,k)+tr12*tr2+tr11*tr3 + ci3 = cc(i,1,k)+tr12*ti2+tr11*ti3 + cr5 = ti11*tr5+ti12*tr4 + ci5 = ti11*ti5+ti12*ti4 + cr4 = ti12*tr5-ti11*tr4 + ci4 = ti12*ti5-ti11*ti4 + dr3 = cr3-ci4 + dr4 = cr3+ci4 + di3 = ci3+cr4 + di4 = ci3-cr4 + dr5 = cr2+ci5 + dr2 = cr2-ci5 + di5 = ci2-cr5 + di2 = ci2+cr5 + ch(i-1,k,2) = wa1(i-1)*dr2-wa1(i)*di2 + ch(i,k,2) = wa1(i-1)*di2+wa1(i)*dr2 + ch(i-1,k,3) = wa2(i-1)*dr3-wa2(i)*di3 + ch(i,k,3) = wa2(i-1)*di3+wa2(i)*dr3 + ch(i-1,k,4) = wa3(i-1)*dr4-wa3(i)*di4 + ch(i,k,4) = wa3(i-1)*di4+wa3(i)*dr4 + ch(i-1,k,5) = wa4(i-1)*dr5-wa4(i)*di5 + ch(i,k,5) = wa4(i-1)*di5+wa4(i)*dr5 + 103 continue + 104 continue + return + end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/fftpack/passf.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,116 @@ + subroutine passf (nac,ido,ip,l1,idl1,cc,c1,c2,ch,ch2,wa) + dimension ch(ido,l1,ip) ,cc(ido,ip,l1) , + 1 c1(ido,l1,ip) ,wa(1) ,c2(idl1,ip), + 2 ch2(idl1,ip) + idot = ido/2 + nt = ip*idl1 + ipp2 = ip+2 + ipph = (ip+1)/2 + idp = ip*ido +c + if (ido .lt. l1) go to 106 + do 103 j=2,ipph + jc = ipp2-j + do 102 k=1,l1 + do 101 i=1,ido + ch(i,k,j) = cc(i,j,k)+cc(i,jc,k) + ch(i,k,jc) = cc(i,j,k)-cc(i,jc,k) + 101 continue + 102 continue + 103 continue + do 105 k=1,l1 + do 104 i=1,ido + ch(i,k,1) = cc(i,1,k) + 104 continue + 105 continue + go to 112 + 106 do 109 j=2,ipph + jc = ipp2-j + do 108 i=1,ido + do 107 k=1,l1 + ch(i,k,j) = cc(i,j,k)+cc(i,jc,k) + ch(i,k,jc) = cc(i,j,k)-cc(i,jc,k) + 107 continue + 108 continue + 109 continue + do 111 i=1,ido + do 110 k=1,l1 + ch(i,k,1) = cc(i,1,k) + 110 continue + 111 continue + 112 idl = 2-ido + inc = 0 + do 116 l=2,ipph + lc = ipp2-l + idl = idl+ido + do 113 ik=1,idl1 + c2(ik,l) = ch2(ik,1)+wa(idl-1)*ch2(ik,2) + c2(ik,lc) = -wa(idl)*ch2(ik,ip) + 113 continue + idlj = idl + inc = inc+ido + do 115 j=3,ipph + jc = ipp2-j + idlj = idlj+inc + if (idlj .gt. idp) idlj = idlj-idp + war = wa(idlj-1) + wai = wa(idlj) + do 114 ik=1,idl1 + c2(ik,l) = c2(ik,l)+war*ch2(ik,j) + c2(ik,lc) = c2(ik,lc)-wai*ch2(ik,jc) + 114 continue + 115 continue + 116 continue + do 118 j=2,ipph + do 117 ik=1,idl1 + ch2(ik,1) = ch2(ik,1)+ch2(ik,j) + 117 continue + 118 continue + do 120 j=2,ipph + jc = ipp2-j + do 119 ik=2,idl1,2 + ch2(ik-1,j) = c2(ik-1,j)-c2(ik,jc) + ch2(ik-1,jc) = c2(ik-1,j)+c2(ik,jc) + ch2(ik,j) = c2(ik,j)+c2(ik-1,jc) + ch2(ik,jc) = c2(ik,j)-c2(ik-1,jc) + 119 continue + 120 continue + nac = 1 + if (ido .eq. 2) return + nac = 0 + do 121 ik=1,idl1 + c2(ik,1) = ch2(ik,1) + 121 continue + do 123 j=2,ip + do 122 k=1,l1 + c1(1,k,j) = ch(1,k,j) + c1(2,k,j) = ch(2,k,j) + 122 continue + 123 continue + if (idot .gt. l1) go to 127 + idij = 0 + do 126 j=2,ip + idij = idij+2 + do 125 i=4,ido,2 + idij = idij+2 + do 124 k=1,l1 + c1(i-1,k,j) = wa(idij-1)*ch(i-1,k,j)+wa(idij)*ch(i,k,j) + c1(i,k,j) = wa(idij-1)*ch(i,k,j)-wa(idij)*ch(i-1,k,j) + 124 continue + 125 continue + 126 continue + return + 127 idj = 2-ido + do 130 j=2,ip + idj = idj+ido + do 129 k=1,l1 + idij = idj + do 128 i=4,ido,2 + idij = idij+2 + c1(i-1,k,j) = wa(idij-1)*ch(i-1,k,j)+wa(idij)*ch(i,k,j) + c1(i,k,j) = wa(idij-1)*ch(i,k,j)-wa(idij)*ch(i-1,k,j) + 128 continue + 129 continue + 130 continue + return + end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/fftpack/passf2.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,23 @@ + subroutine passf2 (ido,l1,cc,ch,wa1) + dimension cc(ido,2,l1) ,ch(ido,l1,2) , + 1 wa1(1) + if (ido .gt. 2) go to 102 + do 101 k=1,l1 + ch(1,k,1) = cc(1,1,k)+cc(1,2,k) + ch(1,k,2) = cc(1,1,k)-cc(1,2,k) + ch(2,k,1) = cc(2,1,k)+cc(2,2,k) + ch(2,k,2) = cc(2,1,k)-cc(2,2,k) + 101 continue + return + 102 do 104 k=1,l1 + do 103 i=2,ido,2 + ch(i-1,k,1) = cc(i-1,1,k)+cc(i-1,2,k) + tr2 = cc(i-1,1,k)-cc(i-1,2,k) + ch(i,k,1) = cc(i,1,k)+cc(i,2,k) + ti2 = cc(i,1,k)-cc(i,2,k) + ch(i,k,2) = wa1(i-1)*ti2-wa1(i)*tr2 + ch(i-1,k,2) = wa1(i-1)*tr2+wa1(i)*ti2 + 103 continue + 104 continue + return + end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/fftpack/passf3.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,42 @@ + subroutine passf3 (ido,l1,cc,ch,wa1,wa2) + dimension cc(ido,3,l1) ,ch(ido,l1,3) , + 1 wa1(1) ,wa2(1) + data taur,taui /-.5,-.866025403784439/ + if (ido .ne. 2) go to 102 + do 101 k=1,l1 + tr2 = cc(1,2,k)+cc(1,3,k) + cr2 = cc(1,1,k)+taur*tr2 + ch(1,k,1) = cc(1,1,k)+tr2 + ti2 = cc(2,2,k)+cc(2,3,k) + ci2 = cc(2,1,k)+taur*ti2 + ch(2,k,1) = cc(2,1,k)+ti2 + cr3 = taui*(cc(1,2,k)-cc(1,3,k)) + ci3 = taui*(cc(2,2,k)-cc(2,3,k)) + ch(1,k,2) = cr2-ci3 + ch(1,k,3) = cr2+ci3 + ch(2,k,2) = ci2+cr3 + ch(2,k,3) = ci2-cr3 + 101 continue + return + 102 do 104 k=1,l1 + do 103 i=2,ido,2 + tr2 = cc(i-1,2,k)+cc(i-1,3,k) + cr2 = cc(i-1,1,k)+taur*tr2 + ch(i-1,k,1) = cc(i-1,1,k)+tr2 + ti2 = cc(i,2,k)+cc(i,3,k) + ci2 = cc(i,1,k)+taur*ti2 + ch(i,k,1) = cc(i,1,k)+ti2 + cr3 = taui*(cc(i-1,2,k)-cc(i-1,3,k)) + ci3 = taui*(cc(i,2,k)-cc(i,3,k)) + dr2 = cr2-ci3 + dr3 = cr2+ci3 + di2 = ci2+cr3 + di3 = ci2-cr3 + ch(i,k,2) = wa1(i-1)*di2-wa1(i)*dr2 + ch(i-1,k,2) = wa1(i-1)*dr2+wa1(i)*di2 + ch(i,k,3) = wa2(i-1)*di3-wa2(i)*dr3 + ch(i-1,k,3) = wa2(i-1)*dr3+wa2(i)*di3 + 103 continue + 104 continue + return + end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/fftpack/passf4.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,51 @@ + subroutine passf4 (ido,l1,cc,ch,wa1,wa2,wa3) + dimension cc(ido,4,l1) ,ch(ido,l1,4) , + 1 wa1(1) ,wa2(1) ,wa3(1) + if (ido .ne. 2) go to 102 + do 101 k=1,l1 + ti1 = cc(2,1,k)-cc(2,3,k) + ti2 = cc(2,1,k)+cc(2,3,k) + tr4 = cc(2,2,k)-cc(2,4,k) + ti3 = cc(2,2,k)+cc(2,4,k) + tr1 = cc(1,1,k)-cc(1,3,k) + tr2 = cc(1,1,k)+cc(1,3,k) + ti4 = cc(1,4,k)-cc(1,2,k) + tr3 = cc(1,2,k)+cc(1,4,k) + ch(1,k,1) = tr2+tr3 + ch(1,k,3) = tr2-tr3 + ch(2,k,1) = ti2+ti3 + ch(2,k,3) = ti2-ti3 + ch(1,k,2) = tr1+tr4 + ch(1,k,4) = tr1-tr4 + ch(2,k,2) = ti1+ti4 + ch(2,k,4) = ti1-ti4 + 101 continue + return + 102 do 104 k=1,l1 + do 103 i=2,ido,2 + ti1 = cc(i,1,k)-cc(i,3,k) + ti2 = cc(i,1,k)+cc(i,3,k) + ti3 = cc(i,2,k)+cc(i,4,k) + tr4 = cc(i,2,k)-cc(i,4,k) + tr1 = cc(i-1,1,k)-cc(i-1,3,k) + tr2 = cc(i-1,1,k)+cc(i-1,3,k) + ti4 = cc(i-1,4,k)-cc(i-1,2,k) + tr3 = cc(i-1,2,k)+cc(i-1,4,k) + ch(i-1,k,1) = tr2+tr3 + cr3 = tr2-tr3 + ch(i,k,1) = ti2+ti3 + ci3 = ti2-ti3 + cr2 = tr1+tr4 + cr4 = tr1-tr4 + ci2 = ti1+ti4 + ci4 = ti1-ti4 + ch(i-1,k,2) = wa1(i-1)*cr2+wa1(i)*ci2 + ch(i,k,2) = wa1(i-1)*ci2-wa1(i)*cr2 + ch(i-1,k,3) = wa2(i-1)*cr3+wa2(i)*ci3 + ch(i,k,3) = wa2(i-1)*ci3-wa2(i)*cr3 + ch(i-1,k,4) = wa3(i-1)*cr4+wa3(i)*ci4 + ch(i,k,4) = wa3(i-1)*ci4-wa3(i)*cr4 + 103 continue + 104 continue + return + end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/fftpack/passf5.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,75 @@ + subroutine passf5 (ido,l1,cc,ch,wa1,wa2,wa3,wa4) + dimension cc(ido,5,l1) ,ch(ido,l1,5) , + 1 wa1(1) ,wa2(1) ,wa3(1) ,wa4(1) + data tr11,ti11,tr12,ti12 /.309016994374947,-.951056516295154, + 1-.809016994374947,-.587785252292473/ + if (ido .ne. 2) go to 102 + do 101 k=1,l1 + ti5 = cc(2,2,k)-cc(2,5,k) + ti2 = cc(2,2,k)+cc(2,5,k) + ti4 = cc(2,3,k)-cc(2,4,k) + ti3 = cc(2,3,k)+cc(2,4,k) + tr5 = cc(1,2,k)-cc(1,5,k) + tr2 = cc(1,2,k)+cc(1,5,k) + tr4 = cc(1,3,k)-cc(1,4,k) + tr3 = cc(1,3,k)+cc(1,4,k) + ch(1,k,1) = cc(1,1,k)+tr2+tr3 + ch(2,k,1) = cc(2,1,k)+ti2+ti3 + cr2 = cc(1,1,k)+tr11*tr2+tr12*tr3 + ci2 = cc(2,1,k)+tr11*ti2+tr12*ti3 + cr3 = cc(1,1,k)+tr12*tr2+tr11*tr3 + ci3 = cc(2,1,k)+tr12*ti2+tr11*ti3 + cr5 = ti11*tr5+ti12*tr4 + ci5 = ti11*ti5+ti12*ti4 + cr4 = ti12*tr5-ti11*tr4 + ci4 = ti12*ti5-ti11*ti4 + ch(1,k,2) = cr2-ci5 + ch(1,k,5) = cr2+ci5 + ch(2,k,2) = ci2+cr5 + ch(2,k,3) = ci3+cr4 + ch(1,k,3) = cr3-ci4 + ch(1,k,4) = cr3+ci4 + ch(2,k,4) = ci3-cr4 + ch(2,k,5) = ci2-cr5 + 101 continue + return + 102 do 104 k=1,l1 + do 103 i=2,ido,2 + ti5 = cc(i,2,k)-cc(i,5,k) + ti2 = cc(i,2,k)+cc(i,5,k) + ti4 = cc(i,3,k)-cc(i,4,k) + ti3 = cc(i,3,k)+cc(i,4,k) + tr5 = cc(i-1,2,k)-cc(i-1,5,k) + tr2 = cc(i-1,2,k)+cc(i-1,5,k) + tr4 = cc(i-1,3,k)-cc(i-1,4,k) + tr3 = cc(i-1,3,k)+cc(i-1,4,k) + ch(i-1,k,1) = cc(i-1,1,k)+tr2+tr3 + ch(i,k,1) = cc(i,1,k)+ti2+ti3 + cr2 = cc(i-1,1,k)+tr11*tr2+tr12*tr3 + ci2 = cc(i,1,k)+tr11*ti2+tr12*ti3 + cr3 = cc(i-1,1,k)+tr12*tr2+tr11*tr3 + ci3 = cc(i,1,k)+tr12*ti2+tr11*ti3 + cr5 = ti11*tr5+ti12*tr4 + ci5 = ti11*ti5+ti12*ti4 + cr4 = ti12*tr5-ti11*tr4 + ci4 = ti12*ti5-ti11*ti4 + dr3 = cr3-ci4 + dr4 = cr3+ci4 + di3 = ci3+cr4 + di4 = ci3-cr4 + dr5 = cr2+ci5 + dr2 = cr2-ci5 + di5 = ci2-cr5 + di2 = ci2+cr5 + ch(i-1,k,2) = wa1(i-1)*dr2+wa1(i)*di2 + ch(i,k,2) = wa1(i-1)*di2-wa1(i)*dr2 + ch(i-1,k,3) = wa2(i-1)*dr3+wa2(i)*di3 + ch(i,k,3) = wa2(i-1)*di3-wa2(i)*dr3 + ch(i-1,k,4) = wa3(i-1)*dr4+wa3(i)*di4 + ch(i,k,4) = wa3(i-1)*di4-wa3(i)*dr4 + ch(i-1,k,5) = wa4(i-1)*dr5+wa4(i)*di5 + ch(i,k,5) = wa4(i-1)*di5-wa4(i)*dr5 + 103 continue + 104 continue + return + end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/fftpack/zfftb.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,9 @@ + subroutine zfftb (n,c,wsave) + implicit double precision (a-h,o-z) + dimension c(*) ,wsave(*) + if (n .eq. 1) return + iw1 = n+n+1 + iw2 = iw1+n+n + call zfftb1 (n,c,wsave,wsave(iw1),wsave(iw2)) + return + end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/fftpack/zfftb1.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,62 @@ + subroutine zfftb1 (n,c,ch,wa,ifac) + implicit double precision (a-h,o-z) + dimension ch(*) ,c(*) ,wa(*) ,ifac(*) + nf = ifac(2) + na = 0 + l1 = 1 + iw = 1 + do 116 k1=1,nf + ip = ifac(k1+2) + l2 = ip*l1 + ido = n/l2 + idot = ido+ido + idl1 = idot*l1 + if (ip .ne. 4) go to 103 + ix2 = iw+idot + ix3 = ix2+idot + if (na .ne. 0) go to 101 + call zpassb4 (idot,l1,c,ch,wa(iw),wa(ix2),wa(ix3)) + go to 102 + 101 call zpassb4 (idot,l1,ch,c,wa(iw),wa(ix2),wa(ix3)) + 102 na = 1-na + go to 115 + 103 if (ip .ne. 2) go to 106 + if (na .ne. 0) go to 104 + call zpassb2 (idot,l1,c,ch,wa(iw)) + go to 105 + 104 call zpassb2 (idot,l1,ch,c,wa(iw)) + 105 na = 1-na + go to 115 + 106 if (ip .ne. 3) go to 109 + ix2 = iw+idot + if (na .ne. 0) go to 107 + call zpassb3 (idot,l1,c,ch,wa(iw),wa(ix2)) + go to 108 + 107 call zpassb3 (idot,l1,ch,c,wa(iw),wa(ix2)) + 108 na = 1-na + go to 115 + 109 if (ip .ne. 5) go to 112 + ix2 = iw+idot + ix3 = ix2+idot + ix4 = ix3+idot + if (na .ne. 0) go to 110 + call zpassb5 (idot,l1,c,ch,wa(iw),wa(ix2),wa(ix3),wa(ix4)) + go to 111 + 110 call zpassb5 (idot,l1,ch,c,wa(iw),wa(ix2),wa(ix3),wa(ix4)) + 111 na = 1-na + go to 115 + 112 if (na .ne. 0) go to 113 + call zpassb (nac,idot,ip,l1,idl1,c,c,c,ch,ch,wa(iw)) + go to 114 + 113 call zpassb (nac,idot,ip,l1,idl1,ch,ch,ch,c,c,wa(iw)) + 114 if (nac .ne. 0) na = 1-na + 115 l1 = l2 + iw = iw+(ip-1)*idot + 116 continue + if (na .eq. 0) return + n2 = n+n + do 117 i=1,n2 + c(i) = ch(i) + 117 continue + return + end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/fftpack/zfftf.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,9 @@ + subroutine zfftf (n,c,wsave) + implicit double precision (a-h,o-z) + dimension c(*) ,wsave(*) + if (n .eq. 1) return + iw1 = n+n+1 + iw2 = iw1+n+n + call zfftf1 (n,c,wsave,wsave(iw1),wsave(iw2)) + return + end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/fftpack/zfftf1.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,62 @@ + subroutine zfftf1 (n,c,ch,wa,ifac) + implicit double precision (a-h,o-z) + dimension ch(*) ,c(*) ,wa(*) ,ifac(*) + nf = ifac(2) + na = 0 + l1 = 1 + iw = 1 + do 116 k1=1,nf + ip = ifac(k1+2) + l2 = ip*l1 + ido = n/l2 + idot = ido+ido + idl1 = idot*l1 + if (ip .ne. 4) go to 103 + ix2 = iw+idot + ix3 = ix2+idot + if (na .ne. 0) go to 101 + call zpassf4 (idot,l1,c,ch,wa(iw),wa(ix2),wa(ix3)) + go to 102 + 101 call zpassf4 (idot,l1,ch,c,wa(iw),wa(ix2),wa(ix3)) + 102 na = 1-na + go to 115 + 103 if (ip .ne. 2) go to 106 + if (na .ne. 0) go to 104 + call zpassf2 (idot,l1,c,ch,wa(iw)) + go to 105 + 104 call zpassf2 (idot,l1,ch,c,wa(iw)) + 105 na = 1-na + go to 115 + 106 if (ip .ne. 3) go to 109 + ix2 = iw+idot + if (na .ne. 0) go to 107 + call zpassf3 (idot,l1,c,ch,wa(iw),wa(ix2)) + go to 108 + 107 call zpassf3 (idot,l1,ch,c,wa(iw),wa(ix2)) + 108 na = 1-na + go to 115 + 109 if (ip .ne. 5) go to 112 + ix2 = iw+idot + ix3 = ix2+idot + ix4 = ix3+idot + if (na .ne. 0) go to 110 + call zpassf5 (idot,l1,c,ch,wa(iw),wa(ix2),wa(ix3),wa(ix4)) + go to 111 + 110 call zpassf5 (idot,l1,ch,c,wa(iw),wa(ix2),wa(ix3),wa(ix4)) + 111 na = 1-na + go to 115 + 112 if (na .ne. 0) go to 113 + call zpassf (nac,idot,ip,l1,idl1,c,c,c,ch,ch,wa(iw)) + go to 114 + 113 call zpassf (nac,idot,ip,l1,idl1,ch,ch,ch,c,c,wa(iw)) + 114 if (nac .ne. 0) na = 1-na + 115 l1 = l2 + iw = iw+(ip-1)*idot + 116 continue + if (na .eq. 0) return + n2 = n+n + do 117 i=1,n2 + c(i) = ch(i) + 117 continue + return + end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/fftpack/zffti.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,9 @@ + subroutine zffti (n,wsave) + implicit double precision (a-h,o-z) + dimension wsave(*) + if (n .eq. 1) return + iw1 = n+n+1 + iw2 = iw1+n+n + call zffti1 (n,wsave(iw1),wsave(iw2)) + return + end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/fftpack/zffti1.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,61 @@ + subroutine zffti1 (n,wa,ifac) + implicit double precision (a-h,o-z) + dimension wa(*) ,ifac(*) ,ntryh(4) + data ntryh(1),ntryh(2),ntryh(3),ntryh(4)/3,4,2,5/ + nl = n + nf = 0 + j = 0 + 101 j = j+1 + if (j-4) 102,102,103 + 102 ntry = ntryh(j) + go to 104 + 103 ntry = ntry+2 + 104 nq = nl/ntry + nr = nl-ntry*nq + if (nr) 101,105,101 + 105 nf = nf+1 + ifac(nf+2) = ntry + nl = nq + if (ntry .ne. 2) go to 107 + if (nf .eq. 1) go to 107 + do 106 i=2,nf + ib = nf-i+2 + ifac(ib+2) = ifac(ib+1) + 106 continue + ifac(3) = 2 + 107 if (nl .ne. 1) go to 104 + ifac(1) = n + ifac(2) = nf + tpi = 6.28318530717959d0 + argh = tpi/dble(n) + i = 2 + l1 = 1 + do 110 k1=1,nf + ip = ifac(k1+2) + ld = 0 + l2 = l1*ip + ido = n/l2 + idot = ido+ido+2 + ipm = ip-1 + do 109 j=1,ipm + i1 = i + wa(i-1) = 1. + wa(i) = 0. + ld = ld+l1 + fi = 0. + argld = dble(ld)*argh + do 108 ii=4,idot,2 + i = i+2 + fi = fi+1. + arg = fi*argld + wa(i-1) = cos(arg) + wa(i) = sin(arg) + 108 continue + if (ip .le. 5) go to 109 + wa(i1-1) = wa(i-1) + wa(i1) = wa(i) + 109 continue + l1 = l2 + 110 continue + return + end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/fftpack/zpassb.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,117 @@ + subroutine zpassb (nac,ido,ip,l1,idl1,cc,c1,c2,ch,ch2,wa) + implicit double precision (a-h,o-z) + dimension ch(ido,l1,ip) ,cc(ido,ip,l1) , + 1 c1(ido,l1,ip) ,wa(1) ,c2(idl1,ip), + 2 ch2(idl1,ip) + idot = ido/2 + nt = ip*idl1 + ipp2 = ip+2 + ipph = (ip+1)/2 + idp = ip*ido +c + if (ido .lt. l1) go to 106 + do 103 j=2,ipph + jc = ipp2-j + do 102 k=1,l1 + do 101 i=1,ido + ch(i,k,j) = cc(i,j,k)+cc(i,jc,k) + ch(i,k,jc) = cc(i,j,k)-cc(i,jc,k) + 101 continue + 102 continue + 103 continue + do 105 k=1,l1 + do 104 i=1,ido + ch(i,k,1) = cc(i,1,k) + 104 continue + 105 continue + go to 112 + 106 do 109 j=2,ipph + jc = ipp2-j + do 108 i=1,ido + do 107 k=1,l1 + ch(i,k,j) = cc(i,j,k)+cc(i,jc,k) + ch(i,k,jc) = cc(i,j,k)-cc(i,jc,k) + 107 continue + 108 continue + 109 continue + do 111 i=1,ido + do 110 k=1,l1 + ch(i,k,1) = cc(i,1,k) + 110 continue + 111 continue + 112 idl = 2-ido + inc = 0 + do 116 l=2,ipph + lc = ipp2-l + idl = idl+ido + do 113 ik=1,idl1 + c2(ik,l) = ch2(ik,1)+wa(idl-1)*ch2(ik,2) + c2(ik,lc) = wa(idl)*ch2(ik,ip) + 113 continue + idlj = idl + inc = inc+ido + do 115 j=3,ipph + jc = ipp2-j + idlj = idlj+inc + if (idlj .gt. idp) idlj = idlj-idp + war = wa(idlj-1) + wai = wa(idlj) + do 114 ik=1,idl1 + c2(ik,l) = c2(ik,l)+war*ch2(ik,j) + c2(ik,lc) = c2(ik,lc)+wai*ch2(ik,jc) + 114 continue + 115 continue + 116 continue + do 118 j=2,ipph + do 117 ik=1,idl1 + ch2(ik,1) = ch2(ik,1)+ch2(ik,j) + 117 continue + 118 continue + do 120 j=2,ipph + jc = ipp2-j + do 119 ik=2,idl1,2 + ch2(ik-1,j) = c2(ik-1,j)-c2(ik,jc) + ch2(ik-1,jc) = c2(ik-1,j)+c2(ik,jc) + ch2(ik,j) = c2(ik,j)+c2(ik-1,jc) + ch2(ik,jc) = c2(ik,j)-c2(ik-1,jc) + 119 continue + 120 continue + nac = 1 + if (ido .eq. 2) return + nac = 0 + do 121 ik=1,idl1 + c2(ik,1) = ch2(ik,1) + 121 continue + do 123 j=2,ip + do 122 k=1,l1 + c1(1,k,j) = ch(1,k,j) + c1(2,k,j) = ch(2,k,j) + 122 continue + 123 continue + if (idot .gt. l1) go to 127 + idij = 0 + do 126 j=2,ip + idij = idij+2 + do 125 i=4,ido,2 + idij = idij+2 + do 124 k=1,l1 + c1(i-1,k,j) = wa(idij-1)*ch(i-1,k,j)-wa(idij)*ch(i,k,j) + c1(i,k,j) = wa(idij-1)*ch(i,k,j)+wa(idij)*ch(i-1,k,j) + 124 continue + 125 continue + 126 continue + return + 127 idj = 2-ido + do 130 j=2,ip + idj = idj+ido + do 129 k=1,l1 + idij = idj + do 128 i=4,ido,2 + idij = idij+2 + c1(i-1,k,j) = wa(idij-1)*ch(i-1,k,j)-wa(idij)*ch(i,k,j) + c1(i,k,j) = wa(idij-1)*ch(i,k,j)+wa(idij)*ch(i-1,k,j) + 128 continue + 129 continue + 130 continue + return + end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/fftpack/zpassb2.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,24 @@ + subroutine zpassb2 (ido,l1,cc,ch,wa1) + implicit double precision (a-h,o-z) + dimension cc(ido,2,l1) ,ch(ido,l1,2) , + 1 wa1(1) + if (ido .gt. 2) go to 102 + do 101 k=1,l1 + ch(1,k,1) = cc(1,1,k)+cc(1,2,k) + ch(1,k,2) = cc(1,1,k)-cc(1,2,k) + ch(2,k,1) = cc(2,1,k)+cc(2,2,k) + ch(2,k,2) = cc(2,1,k)-cc(2,2,k) + 101 continue + return + 102 do 104 k=1,l1 + do 103 i=2,ido,2 + ch(i-1,k,1) = cc(i-1,1,k)+cc(i-1,2,k) + tr2 = cc(i-1,1,k)-cc(i-1,2,k) + ch(i,k,1) = cc(i,1,k)+cc(i,2,k) + ti2 = cc(i,1,k)-cc(i,2,k) + ch(i,k,2) = wa1(i-1)*ti2+wa1(i)*tr2 + ch(i-1,k,2) = wa1(i-1)*tr2-wa1(i)*ti2 + 103 continue + 104 continue + return + end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/fftpack/zpassb3.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,43 @@ + subroutine zpassb3 (ido,l1,cc,ch,wa1,wa2) + implicit double precision (a-h,o-z) + dimension cc(ido,3,l1) ,ch(ido,l1,3) , + 1 wa1(1) ,wa2(1) + data taur,taui /-.5,.866025403784439d0/ + if (ido .ne. 2) go to 102 + do 101 k=1,l1 + tr2 = cc(1,2,k)+cc(1,3,k) + cr2 = cc(1,1,k)+taur*tr2 + ch(1,k,1) = cc(1,1,k)+tr2 + ti2 = cc(2,2,k)+cc(2,3,k) + ci2 = cc(2,1,k)+taur*ti2 + ch(2,k,1) = cc(2,1,k)+ti2 + cr3 = taui*(cc(1,2,k)-cc(1,3,k)) + ci3 = taui*(cc(2,2,k)-cc(2,3,k)) + ch(1,k,2) = cr2-ci3 + ch(1,k,3) = cr2+ci3 + ch(2,k,2) = ci2+cr3 + ch(2,k,3) = ci2-cr3 + 101 continue + return + 102 do 104 k=1,l1 + do 103 i=2,ido,2 + tr2 = cc(i-1,2,k)+cc(i-1,3,k) + cr2 = cc(i-1,1,k)+taur*tr2 + ch(i-1,k,1) = cc(i-1,1,k)+tr2 + ti2 = cc(i,2,k)+cc(i,3,k) + ci2 = cc(i,1,k)+taur*ti2 + ch(i,k,1) = cc(i,1,k)+ti2 + cr3 = taui*(cc(i-1,2,k)-cc(i-1,3,k)) + ci3 = taui*(cc(i,2,k)-cc(i,3,k)) + dr2 = cr2-ci3 + dr3 = cr2+ci3 + di2 = ci2+cr3 + di3 = ci2-cr3 + ch(i,k,2) = wa1(i-1)*di2+wa1(i)*dr2 + ch(i-1,k,2) = wa1(i-1)*dr2-wa1(i)*di2 + ch(i,k,3) = wa2(i-1)*di3+wa2(i)*dr3 + ch(i-1,k,3) = wa2(i-1)*dr3-wa2(i)*di3 + 103 continue + 104 continue + return + end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/fftpack/zpassb4.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,52 @@ + subroutine zpassb4 (ido,l1,cc,ch,wa1,wa2,wa3) + implicit double precision (a-h,o-z) + dimension cc(ido,4,l1) ,ch(ido,l1,4) , + 1 wa1(1) ,wa2(1) ,wa3(1) + if (ido .ne. 2) go to 102 + do 101 k=1,l1 + ti1 = cc(2,1,k)-cc(2,3,k) + ti2 = cc(2,1,k)+cc(2,3,k) + tr4 = cc(2,4,k)-cc(2,2,k) + ti3 = cc(2,2,k)+cc(2,4,k) + tr1 = cc(1,1,k)-cc(1,3,k) + tr2 = cc(1,1,k)+cc(1,3,k) + ti4 = cc(1,2,k)-cc(1,4,k) + tr3 = cc(1,2,k)+cc(1,4,k) + ch(1,k,1) = tr2+tr3 + ch(1,k,3) = tr2-tr3 + ch(2,k,1) = ti2+ti3 + ch(2,k,3) = ti2-ti3 + ch(1,k,2) = tr1+tr4 + ch(1,k,4) = tr1-tr4 + ch(2,k,2) = ti1+ti4 + ch(2,k,4) = ti1-ti4 + 101 continue + return + 102 do 104 k=1,l1 + do 103 i=2,ido,2 + ti1 = cc(i,1,k)-cc(i,3,k) + ti2 = cc(i,1,k)+cc(i,3,k) + ti3 = cc(i,2,k)+cc(i,4,k) + tr4 = cc(i,4,k)-cc(i,2,k) + tr1 = cc(i-1,1,k)-cc(i-1,3,k) + tr2 = cc(i-1,1,k)+cc(i-1,3,k) + ti4 = cc(i-1,2,k)-cc(i-1,4,k) + tr3 = cc(i-1,2,k)+cc(i-1,4,k) + ch(i-1,k,1) = tr2+tr3 + cr3 = tr2-tr3 + ch(i,k,1) = ti2+ti3 + ci3 = ti2-ti3 + cr2 = tr1+tr4 + cr4 = tr1-tr4 + ci2 = ti1+ti4 + ci4 = ti1-ti4 + ch(i-1,k,2) = wa1(i-1)*cr2-wa1(i)*ci2 + ch(i,k,2) = wa1(i-1)*ci2+wa1(i)*cr2 + ch(i-1,k,3) = wa2(i-1)*cr3-wa2(i)*ci3 + ch(i,k,3) = wa2(i-1)*ci3+wa2(i)*cr3 + ch(i-1,k,4) = wa3(i-1)*cr4-wa3(i)*ci4 + ch(i,k,4) = wa3(i-1)*ci4+wa3(i)*cr4 + 103 continue + 104 continue + return + end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/fftpack/zpassb5.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,76 @@ + subroutine zpassb5 (ido,l1,cc,ch,wa1,wa2,wa3,wa4) + implicit double precision (a-h,o-z) + dimension cc(ido,5,l1) ,ch(ido,l1,5) , + 1 wa1(1) ,wa2(1) ,wa3(1) ,wa4(1) + data tr11,ti11,tr12,ti12 /.309016994374947d0,.951056516295154d0, + 1-.809016994374947d0,.587785252292473d0/ + if (ido .ne. 2) go to 102 + do 101 k=1,l1 + ti5 = cc(2,2,k)-cc(2,5,k) + ti2 = cc(2,2,k)+cc(2,5,k) + ti4 = cc(2,3,k)-cc(2,4,k) + ti3 = cc(2,3,k)+cc(2,4,k) + tr5 = cc(1,2,k)-cc(1,5,k) + tr2 = cc(1,2,k)+cc(1,5,k) + tr4 = cc(1,3,k)-cc(1,4,k) + tr3 = cc(1,3,k)+cc(1,4,k) + ch(1,k,1) = cc(1,1,k)+tr2+tr3 + ch(2,k,1) = cc(2,1,k)+ti2+ti3 + cr2 = cc(1,1,k)+tr11*tr2+tr12*tr3 + ci2 = cc(2,1,k)+tr11*ti2+tr12*ti3 + cr3 = cc(1,1,k)+tr12*tr2+tr11*tr3 + ci3 = cc(2,1,k)+tr12*ti2+tr11*ti3 + cr5 = ti11*tr5+ti12*tr4 + ci5 = ti11*ti5+ti12*ti4 + cr4 = ti12*tr5-ti11*tr4 + ci4 = ti12*ti5-ti11*ti4 + ch(1,k,2) = cr2-ci5 + ch(1,k,5) = cr2+ci5 + ch(2,k,2) = ci2+cr5 + ch(2,k,3) = ci3+cr4 + ch(1,k,3) = cr3-ci4 + ch(1,k,4) = cr3+ci4 + ch(2,k,4) = ci3-cr4 + ch(2,k,5) = ci2-cr5 + 101 continue + return + 102 do 104 k=1,l1 + do 103 i=2,ido,2 + ti5 = cc(i,2,k)-cc(i,5,k) + ti2 = cc(i,2,k)+cc(i,5,k) + ti4 = cc(i,3,k)-cc(i,4,k) + ti3 = cc(i,3,k)+cc(i,4,k) + tr5 = cc(i-1,2,k)-cc(i-1,5,k) + tr2 = cc(i-1,2,k)+cc(i-1,5,k) + tr4 = cc(i-1,3,k)-cc(i-1,4,k) + tr3 = cc(i-1,3,k)+cc(i-1,4,k) + ch(i-1,k,1) = cc(i-1,1,k)+tr2+tr3 + ch(i,k,1) = cc(i,1,k)+ti2+ti3 + cr2 = cc(i-1,1,k)+tr11*tr2+tr12*tr3 + ci2 = cc(i,1,k)+tr11*ti2+tr12*ti3 + cr3 = cc(i-1,1,k)+tr12*tr2+tr11*tr3 + ci3 = cc(i,1,k)+tr12*ti2+tr11*ti3 + cr5 = ti11*tr5+ti12*tr4 + ci5 = ti11*ti5+ti12*ti4 + cr4 = ti12*tr5-ti11*tr4 + ci4 = ti12*ti5-ti11*ti4 + dr3 = cr3-ci4 + dr4 = cr3+ci4 + di3 = ci3+cr4 + di4 = ci3-cr4 + dr5 = cr2+ci5 + dr2 = cr2-ci5 + di5 = ci2-cr5 + di2 = ci2+cr5 + ch(i-1,k,2) = wa1(i-1)*dr2-wa1(i)*di2 + ch(i,k,2) = wa1(i-1)*di2+wa1(i)*dr2 + ch(i-1,k,3) = wa2(i-1)*dr3-wa2(i)*di3 + ch(i,k,3) = wa2(i-1)*di3+wa2(i)*dr3 + ch(i-1,k,4) = wa3(i-1)*dr4-wa3(i)*di4 + ch(i,k,4) = wa3(i-1)*di4+wa3(i)*dr4 + ch(i-1,k,5) = wa4(i-1)*dr5-wa4(i)*di5 + ch(i,k,5) = wa4(i-1)*di5+wa4(i)*dr5 + 103 continue + 104 continue + return + end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/fftpack/zpassf.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,117 @@ + subroutine zpassf (nac,ido,ip,l1,idl1,cc,c1,c2,ch,ch2,wa) + implicit double precision (a-h,o-z) + dimension ch(ido,l1,ip) ,cc(ido,ip,l1) , + 1 c1(ido,l1,ip) ,wa(1) ,c2(idl1,ip), + 2 ch2(idl1,ip) + idot = ido/2 + nt = ip*idl1 + ipp2 = ip+2 + ipph = (ip+1)/2 + idp = ip*ido +c + if (ido .lt. l1) go to 106 + do 103 j=2,ipph + jc = ipp2-j + do 102 k=1,l1 + do 101 i=1,ido + ch(i,k,j) = cc(i,j,k)+cc(i,jc,k) + ch(i,k,jc) = cc(i,j,k)-cc(i,jc,k) + 101 continue + 102 continue + 103 continue + do 105 k=1,l1 + do 104 i=1,ido + ch(i,k,1) = cc(i,1,k) + 104 continue + 105 continue + go to 112 + 106 do 109 j=2,ipph + jc = ipp2-j + do 108 i=1,ido + do 107 k=1,l1 + ch(i,k,j) = cc(i,j,k)+cc(i,jc,k) + ch(i,k,jc) = cc(i,j,k)-cc(i,jc,k) + 107 continue + 108 continue + 109 continue + do 111 i=1,ido + do 110 k=1,l1 + ch(i,k,1) = cc(i,1,k) + 110 continue + 111 continue + 112 idl = 2-ido + inc = 0 + do 116 l=2,ipph + lc = ipp2-l + idl = idl+ido + do 113 ik=1,idl1 + c2(ik,l) = ch2(ik,1)+wa(idl-1)*ch2(ik,2) + c2(ik,lc) = -wa(idl)*ch2(ik,ip) + 113 continue + idlj = idl + inc = inc+ido + do 115 j=3,ipph + jc = ipp2-j + idlj = idlj+inc + if (idlj .gt. idp) idlj = idlj-idp + war = wa(idlj-1) + wai = wa(idlj) + do 114 ik=1,idl1 + c2(ik,l) = c2(ik,l)+war*ch2(ik,j) + c2(ik,lc) = c2(ik,lc)-wai*ch2(ik,jc) + 114 continue + 115 continue + 116 continue + do 118 j=2,ipph + do 117 ik=1,idl1 + ch2(ik,1) = ch2(ik,1)+ch2(ik,j) + 117 continue + 118 continue + do 120 j=2,ipph + jc = ipp2-j + do 119 ik=2,idl1,2 + ch2(ik-1,j) = c2(ik-1,j)-c2(ik,jc) + ch2(ik-1,jc) = c2(ik-1,j)+c2(ik,jc) + ch2(ik,j) = c2(ik,j)+c2(ik-1,jc) + ch2(ik,jc) = c2(ik,j)-c2(ik-1,jc) + 119 continue + 120 continue + nac = 1 + if (ido .eq. 2) return + nac = 0 + do 121 ik=1,idl1 + c2(ik,1) = ch2(ik,1) + 121 continue + do 123 j=2,ip + do 122 k=1,l1 + c1(1,k,j) = ch(1,k,j) + c1(2,k,j) = ch(2,k,j) + 122 continue + 123 continue + if (idot .gt. l1) go to 127 + idij = 0 + do 126 j=2,ip + idij = idij+2 + do 125 i=4,ido,2 + idij = idij+2 + do 124 k=1,l1 + c1(i-1,k,j) = wa(idij-1)*ch(i-1,k,j)+wa(idij)*ch(i,k,j) + c1(i,k,j) = wa(idij-1)*ch(i,k,j)-wa(idij)*ch(i-1,k,j) + 124 continue + 125 continue + 126 continue + return + 127 idj = 2-ido + do 130 j=2,ip + idj = idj+ido + do 129 k=1,l1 + idij = idj + do 128 i=4,ido,2 + idij = idij+2 + c1(i-1,k,j) = wa(idij-1)*ch(i-1,k,j)+wa(idij)*ch(i,k,j) + c1(i,k,j) = wa(idij-1)*ch(i,k,j)-wa(idij)*ch(i-1,k,j) + 128 continue + 129 continue + 130 continue + return + end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/fftpack/zpassf2.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,24 @@ + subroutine zpassf2 (ido,l1,cc,ch,wa1) + implicit double precision (a-h,o-z) + dimension cc(ido,2,l1) ,ch(ido,l1,2) , + 1 wa1(1) + if (ido .gt. 2) go to 102 + do 101 k=1,l1 + ch(1,k,1) = cc(1,1,k)+cc(1,2,k) + ch(1,k,2) = cc(1,1,k)-cc(1,2,k) + ch(2,k,1) = cc(2,1,k)+cc(2,2,k) + ch(2,k,2) = cc(2,1,k)-cc(2,2,k) + 101 continue + return + 102 do 104 k=1,l1 + do 103 i=2,ido,2 + ch(i-1,k,1) = cc(i-1,1,k)+cc(i-1,2,k) + tr2 = cc(i-1,1,k)-cc(i-1,2,k) + ch(i,k,1) = cc(i,1,k)+cc(i,2,k) + ti2 = cc(i,1,k)-cc(i,2,k) + ch(i,k,2) = wa1(i-1)*ti2-wa1(i)*tr2 + ch(i-1,k,2) = wa1(i-1)*tr2+wa1(i)*ti2 + 103 continue + 104 continue + return + end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/fftpack/zpassf3.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,43 @@ + subroutine zpassf3 (ido,l1,cc,ch,wa1,wa2) + implicit double precision (a-h,o-z) + dimension cc(ido,3,l1) ,ch(ido,l1,3) , + 1 wa1(1) ,wa2(1) + data taur,taui /-.5d0,-.866025403784439d0/ + if (ido .ne. 2) go to 102 + do 101 k=1,l1 + tr2 = cc(1,2,k)+cc(1,3,k) + cr2 = cc(1,1,k)+taur*tr2 + ch(1,k,1) = cc(1,1,k)+tr2 + ti2 = cc(2,2,k)+cc(2,3,k) + ci2 = cc(2,1,k)+taur*ti2 + ch(2,k,1) = cc(2,1,k)+ti2 + cr3 = taui*(cc(1,2,k)-cc(1,3,k)) + ci3 = taui*(cc(2,2,k)-cc(2,3,k)) + ch(1,k,2) = cr2-ci3 + ch(1,k,3) = cr2+ci3 + ch(2,k,2) = ci2+cr3 + ch(2,k,3) = ci2-cr3 + 101 continue + return + 102 do 104 k=1,l1 + do 103 i=2,ido,2 + tr2 = cc(i-1,2,k)+cc(i-1,3,k) + cr2 = cc(i-1,1,k)+taur*tr2 + ch(i-1,k,1) = cc(i-1,1,k)+tr2 + ti2 = cc(i,2,k)+cc(i,3,k) + ci2 = cc(i,1,k)+taur*ti2 + ch(i,k,1) = cc(i,1,k)+ti2 + cr3 = taui*(cc(i-1,2,k)-cc(i-1,3,k)) + ci3 = taui*(cc(i,2,k)-cc(i,3,k)) + dr2 = cr2-ci3 + dr3 = cr2+ci3 + di2 = ci2+cr3 + di3 = ci2-cr3 + ch(i,k,2) = wa1(i-1)*di2-wa1(i)*dr2 + ch(i-1,k,2) = wa1(i-1)*dr2+wa1(i)*di2 + ch(i,k,3) = wa2(i-1)*di3-wa2(i)*dr3 + ch(i-1,k,3) = wa2(i-1)*dr3+wa2(i)*di3 + 103 continue + 104 continue + return + end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/fftpack/zpassf4.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,52 @@ + subroutine zpassf4 (ido,l1,cc,ch,wa1,wa2,wa3) + implicit double precision (a-h,o-z) + dimension cc(ido,4,l1) ,ch(ido,l1,4) , + 1 wa1(1) ,wa2(1) ,wa3(1) + if (ido .ne. 2) go to 102 + do 101 k=1,l1 + ti1 = cc(2,1,k)-cc(2,3,k) + ti2 = cc(2,1,k)+cc(2,3,k) + tr4 = cc(2,2,k)-cc(2,4,k) + ti3 = cc(2,2,k)+cc(2,4,k) + tr1 = cc(1,1,k)-cc(1,3,k) + tr2 = cc(1,1,k)+cc(1,3,k) + ti4 = cc(1,4,k)-cc(1,2,k) + tr3 = cc(1,2,k)+cc(1,4,k) + ch(1,k,1) = tr2+tr3 + ch(1,k,3) = tr2-tr3 + ch(2,k,1) = ti2+ti3 + ch(2,k,3) = ti2-ti3 + ch(1,k,2) = tr1+tr4 + ch(1,k,4) = tr1-tr4 + ch(2,k,2) = ti1+ti4 + ch(2,k,4) = ti1-ti4 + 101 continue + return + 102 do 104 k=1,l1 + do 103 i=2,ido,2 + ti1 = cc(i,1,k)-cc(i,3,k) + ti2 = cc(i,1,k)+cc(i,3,k) + ti3 = cc(i,2,k)+cc(i,4,k) + tr4 = cc(i,2,k)-cc(i,4,k) + tr1 = cc(i-1,1,k)-cc(i-1,3,k) + tr2 = cc(i-1,1,k)+cc(i-1,3,k) + ti4 = cc(i-1,4,k)-cc(i-1,2,k) + tr3 = cc(i-1,2,k)+cc(i-1,4,k) + ch(i-1,k,1) = tr2+tr3 + cr3 = tr2-tr3 + ch(i,k,1) = ti2+ti3 + ci3 = ti2-ti3 + cr2 = tr1+tr4 + cr4 = tr1-tr4 + ci2 = ti1+ti4 + ci4 = ti1-ti4 + ch(i-1,k,2) = wa1(i-1)*cr2+wa1(i)*ci2 + ch(i,k,2) = wa1(i-1)*ci2-wa1(i)*cr2 + ch(i-1,k,3) = wa2(i-1)*cr3+wa2(i)*ci3 + ch(i,k,3) = wa2(i-1)*ci3-wa2(i)*cr3 + ch(i-1,k,4) = wa3(i-1)*cr4+wa3(i)*ci4 + ch(i,k,4) = wa3(i-1)*ci4-wa3(i)*cr4 + 103 continue + 104 continue + return + end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/fftpack/zpassf5.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,76 @@ + subroutine zpassf5 (ido,l1,cc,ch,wa1,wa2,wa3,wa4) + implicit double precision (a-h,o-z) + dimension cc(ido,5,l1) ,ch(ido,l1,5) , + 1 wa1(1) ,wa2(1) ,wa3(1) ,wa4(1) + data tr11,ti11,tr12,ti12 /.309016994374947d0,-.951056516295154d0, + 1-.809016994374947d0,-.587785252292473d0/ + if (ido .ne. 2) go to 102 + do 101 k=1,l1 + ti5 = cc(2,2,k)-cc(2,5,k) + ti2 = cc(2,2,k)+cc(2,5,k) + ti4 = cc(2,3,k)-cc(2,4,k) + ti3 = cc(2,3,k)+cc(2,4,k) + tr5 = cc(1,2,k)-cc(1,5,k) + tr2 = cc(1,2,k)+cc(1,5,k) + tr4 = cc(1,3,k)-cc(1,4,k) + tr3 = cc(1,3,k)+cc(1,4,k) + ch(1,k,1) = cc(1,1,k)+tr2+tr3 + ch(2,k,1) = cc(2,1,k)+ti2+ti3 + cr2 = cc(1,1,k)+tr11*tr2+tr12*tr3 + ci2 = cc(2,1,k)+tr11*ti2+tr12*ti3 + cr3 = cc(1,1,k)+tr12*tr2+tr11*tr3 + ci3 = cc(2,1,k)+tr12*ti2+tr11*ti3 + cr5 = ti11*tr5+ti12*tr4 + ci5 = ti11*ti5+ti12*ti4 + cr4 = ti12*tr5-ti11*tr4 + ci4 = ti12*ti5-ti11*ti4 + ch(1,k,2) = cr2-ci5 + ch(1,k,5) = cr2+ci5 + ch(2,k,2) = ci2+cr5 + ch(2,k,3) = ci3+cr4 + ch(1,k,3) = cr3-ci4 + ch(1,k,4) = cr3+ci4 + ch(2,k,4) = ci3-cr4 + ch(2,k,5) = ci2-cr5 + 101 continue + return + 102 do 104 k=1,l1 + do 103 i=2,ido,2 + ti5 = cc(i,2,k)-cc(i,5,k) + ti2 = cc(i,2,k)+cc(i,5,k) + ti4 = cc(i,3,k)-cc(i,4,k) + ti3 = cc(i,3,k)+cc(i,4,k) + tr5 = cc(i-1,2,k)-cc(i-1,5,k) + tr2 = cc(i-1,2,k)+cc(i-1,5,k) + tr4 = cc(i-1,3,k)-cc(i-1,4,k) + tr3 = cc(i-1,3,k)+cc(i-1,4,k) + ch(i-1,k,1) = cc(i-1,1,k)+tr2+tr3 + ch(i,k,1) = cc(i,1,k)+ti2+ti3 + cr2 = cc(i-1,1,k)+tr11*tr2+tr12*tr3 + ci2 = cc(i,1,k)+tr11*ti2+tr12*ti3 + cr3 = cc(i-1,1,k)+tr12*tr2+tr11*tr3 + ci3 = cc(i,1,k)+tr12*ti2+tr11*ti3 + cr5 = ti11*tr5+ti12*tr4 + ci5 = ti11*ti5+ti12*ti4 + cr4 = ti12*tr5-ti11*tr4 + ci4 = ti12*ti5-ti11*ti4 + dr3 = cr3-ci4 + dr4 = cr3+ci4 + di3 = ci3+cr4 + di4 = ci3-cr4 + dr5 = cr2+ci5 + dr2 = cr2-ci5 + di5 = ci2-cr5 + di2 = ci2+cr5 + ch(i-1,k,2) = wa1(i-1)*dr2+wa1(i)*di2 + ch(i,k,2) = wa1(i-1)*di2-wa1(i)*dr2 + ch(i-1,k,3) = wa2(i-1)*dr3+wa2(i)*di3 + ch(i,k,3) = wa2(i-1)*di3-wa2(i)*dr3 + ch(i-1,k,4) = wa3(i-1)*dr4+wa3(i)*di4 + ch(i,k,4) = wa3(i-1)*di4-wa3(i)*dr4 + ch(i-1,k,5) = wa4(i-1)*dr5+wa4(i)*di5 + ch(i,k,5) = wa4(i-1)*di5-wa4(i)*dr5 + 103 continue + 104 continue + return + end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/lapack-xtra/crsf2csf.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,96 @@ +c Copyright (C) 2010-2017 VZLU Prague, a.s., Czech Republic +c +c Author: Jaroslav Hajek <highegg@gmail.com> +c +c This file is part of Octave. +c +c Octave is free software; you can redistribute it and/or modify it +c under the terms of the GNU General Public License as published by +c the Free Software Foundation; either version 3 of the License, or +c (at your option) any later version. +c +c Octave is distributed in the hope that it will be useful, but +c WITHOUT ANY WARRANTY; without even the implied warranty of +c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +c GNU General Public License for more details. +c +c You should have received a copy of the GNU General Public License +c along with Octave; see the file COPYING. If not, see +c <http://www.gnu.org/licenses/>. +c + + subroutine crsf2csf(n,t,u,c,s) + integer n + complex t(n,n),u(n,n) + real c(n-1),s(n-1) + real x,y,z + integer j + do j = 1,n-1 + c(j) = 1 + end do + j = 1 + do while (j < n) +c apply previous rotations to rows + call crcrot1(j,t(1,j),c,s) + + y = t(j+1,j) + if (y /= 0) then +c 2x2 block, form Givens rotation [c, i*s; i*s, c] + z = t(j,j+1) + c(j) = sqrt(z/(z-y)) + s(j) = sqrt(y/(y-z)) +c apply new rotation to t(j:j+1,j) + call crcrot1(2,t(j,j),c(j),s(j)) +c apply all rotations to t(1:j+1,j+1) + call crcrot1(j+1,t(1,j+1),c,s) +c apply new rotation to columns j,j+1 + call crcrot2(j+1,t(1,j),t(1,j+1),c(j),s(j)) +c zero subdiagonal entry, skip next row + t(j+1,j) = 0 + j = j + 2 + else + j = j + 1 + end if + end do + +c apply rotations to last column if needed + if (j == n) then + call crcrot1(j,t(1,j),c,s) + end if + +c apply stored rotations to all columns of u + do j = 1,n-1 + if (c(j) /= 1) then + call crcrot2(n,u(1,j),u(1,j+1),c(j),s(j)) + end if + end do + + end subroutine + + subroutine crcrot1(n,x,c,s) +c apply rotations to a column from the left + integer n + complex x(n), t + real c(n-1),s(n-1) + integer i + do i = 1,n-1 + if (c(i) /= 1) then + t = x(i)*c(i) - x(i+1)*cmplx(0,s(i)) + x(i+1) = x(i+1)*c(i) - x(i)*cmplx(0,s(i)) + x(i) = t + endif + end do + end subroutine + + subroutine crcrot2(n,x,y,c,s) +c apply a single rotation from the right to a pair of columns + integer n + complex x(n),y(n),t + real c, s + integer i + do i = 1,n + t = x(i)*c + y(i)*cmplx(0,s) + y(i) = y(i)*c + x(i)*cmplx(0,s) + x(i) = t + end do + end subroutine
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/lapack-xtra/module.mk Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,10 @@ +EXTERNAL_SOURCES += \ + liboctave/external/lapack-xtra/xclange.f \ + liboctave/external/lapack-xtra/xdlamch.f \ + liboctave/external/lapack-xtra/xdlange.f \ + liboctave/external/lapack-xtra/xilaenv.f \ + liboctave/external/lapack-xtra/xslamch.f \ + liboctave/external/lapack-xtra/xslange.f \ + liboctave/external/lapack-xtra/xzlange.f \ + liboctave/external/lapack-xtra/zrsf2csf.f \ + liboctave/external/lapack-xtra/crsf2csf.f
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/lapack-xtra/xclange.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,155 @@ +*** This subroutine includes all of the CLANGE function instead of +*** simply wrapping it in a subroutine to avoid possible differences in +*** the way complex values are returned by various Fortran compilers. +*** For example, if we simply wrap the function and compile this file +*** with gfortran and the library that provides CLANGE is compiled with +*** a compiler that uses the g77 (f2c-compatible) calling convention for +*** complex-valued functions, all hell will break loose. + + SUBROUTINE XCLANGE ( NORM, M, N, A, LDA, WORK, VALUE ) + +*** DOUBLE PRECISION FUNCTION CLANGE( NORM, M, N, A, LDA, WORK ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER NORM + INTEGER LDA, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION WORK( * ) + COMPLEX*16 A( LDA, * ) +* .. +* +* Purpose +* ======= +* +* CLANGE returns the value of the one norm, or the Frobenius norm, or +* the infinity norm, or the element of largest absolute value of a +* complex matrix A. +* +* Description +* =========== +* +* CLANGE returns the value +* +* CLANGE = ( max(abs(A(i,j))), NORM = 'M' or 'm' +* ( +* ( norm1(A), NORM = '1', 'O' or 'o' +* ( +* ( normI(A), NORM = 'I' or 'i' +* ( +* ( normF(A), NORM = 'F', 'f', 'E' or 'e' +* +* where norm1 denotes the one norm of a matrix (maximum column sum), +* normI denotes the infinity norm of a matrix (maximum row sum) and +* normF denotes the Frobenius norm of a matrix (square root of sum of +* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. +* +* Arguments +* ========= +* +* NORM (input) CHARACTER*1 +* Specifies the value to be returned in CLANGE as described +* above. +* +* M (input) INTEGER +* The number of rows of the matrix A. M >= 0. When M = 0, +* CLANGE is set to zero. +* +* N (input) INTEGER +* The number of columns of the matrix A. N >= 0. When N = 0, +* CLANGE is set to zero. +* +* A (input) COMPLEX*16 array, dimension (LDA,N) +* The m by n matrix A. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(M,1). +* +* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)), +* where LWORK >= M when NORM = 'I'; otherwise, WORK is not +* referenced. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, J + DOUBLE PRECISION SCALE, SUM, VALUE +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL CLASSQ +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, SQRT +* .. +* .. Executable Statements .. +* + IF( MIN( M, N ).EQ.0 ) THEN + VALUE = ZERO + ELSE IF( LSAME( NORM, 'M' ) ) THEN +* +* Find max(abs(A(i,j))). +* + VALUE = ZERO + DO 20 J = 1, N + DO 10 I = 1, M + VALUE = MAX( VALUE, ABS( A( I, J ) ) ) + 10 CONTINUE + 20 CONTINUE + ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN +* +* Find norm1(A). +* + VALUE = ZERO + DO 40 J = 1, N + SUM = ZERO + DO 30 I = 1, M + SUM = SUM + ABS( A( I, J ) ) + 30 CONTINUE + VALUE = MAX( VALUE, SUM ) + 40 CONTINUE + ELSE IF( LSAME( NORM, 'I' ) ) THEN +* +* Find normI(A). +* + DO 50 I = 1, M + WORK( I ) = ZERO + 50 CONTINUE + DO 70 J = 1, N + DO 60 I = 1, M + WORK( I ) = WORK( I ) + ABS( A( I, J ) ) + 60 CONTINUE + 70 CONTINUE + VALUE = ZERO + DO 80 I = 1, M + VALUE = MAX( VALUE, WORK( I ) ) + 80 CONTINUE + ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN +* +* Find normF(A). +* + SCALE = ZERO + SUM = ONE + DO 90 J = 1, N + CALL CLASSQ( M, A( 1, J ), 1, SCALE, SUM ) + 90 CONTINUE + VALUE = SCALE*SQRT( SUM ) + END IF +* +*** CLANGE = VALUE + RETURN +* +* End of CLANGE +* + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/lapack-xtra/xdlamch.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,6 @@ + subroutine xdlamch (cmach, retval) + character cmach + double precision retval, dlamch + retval = dlamch (cmach) + return + end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/lapack-xtra/xdlange.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,7 @@ + subroutine xdlange (norm, m, n, a, lda, work, retval) + character norm + integer lda, m, n + double precision a (lda, *), work (*), dlange, retval + retval = dlange (norm, m, n, a, lda, work) + return + end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/lapack-xtra/xilaenv.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,6 @@ + subroutine xilaenv (ispec, name, opts, n1, n2, n3, n4, retval) + character*(*) name, opts + integer ilaenv, ispec, n1, n2, n3, n4, retval + retval = ilaenv (ispec, name, opts, n1, n2, n3, n4) + return + end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/lapack-xtra/xslamch.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,6 @@ + subroutine xslamch (cmach, retval) + character cmach + real retval, slamch + retval = slamch (cmach) + return + end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/lapack-xtra/xslange.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,7 @@ + subroutine xslange (norm, m, n, a, lda, work, retval) + character norm + integer lda, m, n + real a (lda, *), work (*), slange, retval + retval = slange (norm, m, n, a, lda, work) + return + end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/lapack-xtra/xzlange.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,155 @@ +*** This subroutine includes all of the ZLANGE function instead of +*** simply wrapping it in a subroutine to avoid possible differences in +*** the way complex values are returned by various Fortran compilers. +*** For example, if we simply wrap the function and compile this file +*** with gfortran and the library that provides ZLANGE is compiled with +*** a compiler that uses the g77 (f2c-compatible) calling convention for +*** complex-valued functions, all hell will break loose. + + SUBROUTINE XZLANGE ( NORM, M, N, A, LDA, WORK, VALUE ) + +*** DOUBLE PRECISION FUNCTION ZLANGE( NORM, M, N, A, LDA, WORK ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER NORM + INTEGER LDA, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION WORK( * ) + COMPLEX*16 A( LDA, * ) +* .. +* +* Purpose +* ======= +* +* ZLANGE returns the value of the one norm, or the Frobenius norm, or +* the infinity norm, or the element of largest absolute value of a +* complex matrix A. +* +* Description +* =========== +* +* ZLANGE returns the value +* +* ZLANGE = ( max(abs(A(i,j))), NORM = 'M' or 'm' +* ( +* ( norm1(A), NORM = '1', 'O' or 'o' +* ( +* ( normI(A), NORM = 'I' or 'i' +* ( +* ( normF(A), NORM = 'F', 'f', 'E' or 'e' +* +* where norm1 denotes the one norm of a matrix (maximum column sum), +* normI denotes the infinity norm of a matrix (maximum row sum) and +* normF denotes the Frobenius norm of a matrix (square root of sum of +* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. +* +* Arguments +* ========= +* +* NORM (input) CHARACTER*1 +* Specifies the value to be returned in ZLANGE as described +* above. +* +* M (input) INTEGER +* The number of rows of the matrix A. M >= 0. When M = 0, +* ZLANGE is set to zero. +* +* N (input) INTEGER +* The number of columns of the matrix A. N >= 0. When N = 0, +* ZLANGE is set to zero. +* +* A (input) COMPLEX*16 array, dimension (LDA,N) +* The m by n matrix A. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(M,1). +* +* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)), +* where LWORK >= M when NORM = 'I'; otherwise, WORK is not +* referenced. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, J + DOUBLE PRECISION SCALE, SUM, VALUE +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL ZLASSQ +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, SQRT +* .. +* .. Executable Statements .. +* + IF( MIN( M, N ).EQ.0 ) THEN + VALUE = ZERO + ELSE IF( LSAME( NORM, 'M' ) ) THEN +* +* Find max(abs(A(i,j))). +* + VALUE = ZERO + DO 20 J = 1, N + DO 10 I = 1, M + VALUE = MAX( VALUE, ABS( A( I, J ) ) ) + 10 CONTINUE + 20 CONTINUE + ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN +* +* Find norm1(A). +* + VALUE = ZERO + DO 40 J = 1, N + SUM = ZERO + DO 30 I = 1, M + SUM = SUM + ABS( A( I, J ) ) + 30 CONTINUE + VALUE = MAX( VALUE, SUM ) + 40 CONTINUE + ELSE IF( LSAME( NORM, 'I' ) ) THEN +* +* Find normI(A). +* + DO 50 I = 1, M + WORK( I ) = ZERO + 50 CONTINUE + DO 70 J = 1, N + DO 60 I = 1, M + WORK( I ) = WORK( I ) + ABS( A( I, J ) ) + 60 CONTINUE + 70 CONTINUE + VALUE = ZERO + DO 80 I = 1, M + VALUE = MAX( VALUE, WORK( I ) ) + 80 CONTINUE + ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN +* +* Find normF(A). +* + SCALE = ZERO + SUM = ONE + DO 90 J = 1, N + CALL ZLASSQ( M, A( 1, J ), 1, SCALE, SUM ) + 90 CONTINUE + VALUE = SCALE*SQRT( SUM ) + END IF +* +*** ZLANGE = VALUE + RETURN +* +* End of ZLANGE +* + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/lapack-xtra/zrsf2csf.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,96 @@ +c Copyright (C) 2010-2017 VZLU Prague, a.s., Czech Republic +c +c Author: Jaroslav Hajek <highegg@gmail.com> +c +c This file is part of Octave. +c +c Octave is free software; you can redistribute it and/or modify it +c under the terms of the GNU General Public License as published by +c the Free Software Foundation; either version 3 of the License, or +c (at your option) any later version. +c +c Octave is distributed in the hope that it will be useful, but +c WITHOUT ANY WARRANTY; without even the implied warranty of +c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +c GNU General Public License for more details. +c +c You should have received a copy of the GNU General Public License +c along with Octave; see the file COPYING. If not, see +c <http://www.gnu.org/licenses/>. +c + + subroutine zrsf2csf(n,t,u,c,s) + integer n + double complex t(n,n),u(n,n) + double precision c(n-1),s(n-1) + double precision x,y,z + integer j + do j = 1,n-1 + c(j) = 1 + end do + j = 1 + do while (j < n) +c apply previous rotations to rows + call zrcrot1(j,t(1,j),c,s) + + y = t(j+1,j) + if (y /= 0) then +c 2x2 block, form Givens rotation [c, i*s; i*s, c] + z = t(j,j+1) + c(j) = sqrt(z/(z-y)) + s(j) = sqrt(y/(y-z)) +c apply new rotation to t(j:j+1,j) + call zrcrot1(2,t(j,j),c(j),s(j)) +c apply all rotations to t(1:j+1,j+1) + call zrcrot1(j+1,t(1,j+1),c,s) +c apply new rotation to columns j,j+1 + call zrcrot2(j+1,t(1,j),t(1,j+1),c(j),s(j)) +c zero subdiagonal entry, skip next row + t(j+1,j) = 0 + j = j + 2 + else + j = j + 1 + end if + end do + +c apply rotations to last column if needed + if (j == n) then + call zrcrot1(j,t(1,j),c,s) + end if + +c apply stored rotations to all columns of u + do j = 1,n-1 + if (c(j) /= 1) then + call zrcrot2(n,u(1,j),u(1,j+1),c(j),s(j)) + end if + end do + + end subroutine + + subroutine zrcrot1(n,x,c,s) +c apply rotations to a column from the left + integer n + double complex x(n), t + double precision c(n-1),s(n-1) + integer i + do i = 1,n-1 + if (c(i) /= 1) then + t = x(i)*c(i) - x(i+1)*dcmplx(0,s(i)) + x(i+1) = x(i+1)*c(i) - x(i)*dcmplx(0,s(i)) + x(i) = t + endif + end do + end subroutine + + subroutine zrcrot2(n,x,y,c,s) +c apply a single rotation from the right to a pair of columns + integer n + double complex x(n),y(n),t + double precision c, s + integer i + do i = 1,n + t = x(i)*c + y(i)*dcmplx(0,s) + y(i) = y(i)*c + x(i)*dcmplx(0,s) + x(i) = t + end do + end subroutine
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/module.mk Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,46 @@ +nodist_liboctave_external_libexternal_la_SOURCES = + +liboctave_external_libexternal_la_FFLAGS = $(F77_INTEGER_8_FLAG) + +liboctave_external_libexternal_la_DEPENDENCIES = liboctave/external/external.def + +EXTERNAL_INC = + +EXTERNAL_SOURCES = + +include liboctave/external/amos/module.mk +include liboctave/external/blas-xtra/module.mk +include liboctave/external/daspk/module.mk +include liboctave/external/dasrt/module.mk +include liboctave/external/dassl/module.mk +include liboctave/external/Faddeeva/module.mk +include liboctave/external/fftpack/module.mk +include liboctave/external/lapack-xtra/module.mk +include liboctave/external/odepack/module.mk +include liboctave/external/ordered-qz/module.mk +include liboctave/external/quadpack/module.mk +include liboctave/external/ranlib/module.mk +include liboctave/external/slatec-err/module.mk +include liboctave/external/slatec-fn/module.mk + +liboctave/external/external.def: $(liboctave_external_libexternal_la_SOURCES) build-aux/mk-f77-def.sh + $(AM_V_GEN)rm -f $@-t $@ && \ + $(SHELL) build-aux/mk-f77-def.sh $(srcdir) $(liboctave_external_libexternal_la_SOURCES) > $@-t && \ + mv $@-t $@ + +liboctave_CLEANFILES += \ + liboctave/external/external.def \ + liboctave/external/ranlib/ranlib.def \ + $(nodist_liboctave_external_libexternal_la_SOURCES) + +noinst_LTLIBRARIES += liboctave/external/libexternal.la + +liboctave_external_libexternal_la_SOURCES = $(EXTERNAL_SOURCES) + +liboctave_external_libexternal_la_CPPFLAGS = $(liboctave_liboctave_la_CPPFLAGS) + +liboctave_external_libexternal_la_CFLAGS = $(liboctave_liboctave_la_CFLAGS) + +liboctave_external_libexternal_la_CXXFLAGS = $(liboctave_liboctave_la_CXXFLAGS) + +liboctave_liboctave_la_LIBADD += liboctave/external/libexternal.la
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/odepack/cfode.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,112 @@ + SUBROUTINE CFODE (METH, ELCO, TESCO) +CLLL. OPTIMIZE + INTEGER METH + INTEGER I, IB, NQ, NQM1, NQP1 + DOUBLE PRECISION ELCO, TESCO + DOUBLE PRECISION AGAMQ, FNQ, FNQM1, PC, PINT, RAGQ, + 1 RQFAC, RQ1FAC, TSIGN, XPIN + DIMENSION ELCO(13,12), TESCO(3,12) +C----------------------------------------------------------------------- +C CFODE IS CALLED BY THE INTEGRATOR ROUTINE TO SET COEFFICIENTS +C NEEDED THERE. THE COEFFICIENTS FOR THE CURRENT METHOD, AS +C GIVEN BY THE VALUE OF METH, ARE SET FOR ALL ORDERS AND SAVED. +C THE MAXIMUM ORDER ASSUMED HERE IS 12 IF METH = 1 AND 5 IF METH = 2. +C (A SMALLER VALUE OF THE MAXIMUM ORDER IS ALSO ALLOWED.) +C CFODE IS CALLED ONCE AT THE BEGINNING OF THE PROBLEM, +C AND IS NOT CALLED AGAIN UNLESS AND UNTIL METH IS CHANGED. +C +C THE ELCO ARRAY CONTAINS THE BASIC METHOD COEFFICIENTS. +C THE COEFFICIENTS EL(I), 1 .LE. I .LE. NQ+1, FOR THE METHOD OF +C ORDER NQ ARE STORED IN ELCO(I,NQ). THEY ARE GIVEN BY A GENETRATING +C POLYNOMIAL, I.E., +C L(X) = EL(1) + EL(2)*X + ... + EL(NQ+1)*X**NQ. +C FOR THE IMPLICIT ADAMS METHODS, L(X) IS GIVEN BY +C DL/DX = (X+1)*(X+2)*...*(X+NQ-1)/FACTORIAL(NQ-1), L(-1) = 0. +C FOR THE BDF METHODS, L(X) IS GIVEN BY +C L(X) = (X+1)*(X+2)* ... *(X+NQ)/K, +C WHERE K = FACTORIAL(NQ)*(1 + 1/2 + ... + 1/NQ). +C +C THE TESCO ARRAY CONTAINS TEST CONSTANTS USED FOR THE +C LOCAL ERROR TEST AND THE SELECTION OF STEP SIZE AND/OR ORDER. +C AT ORDER NQ, TESCO(K,NQ) IS USED FOR THE SELECTION OF STEP +C SIZE AT ORDER NQ - 1 IF K = 1, AT ORDER NQ IF K = 2, AND AT ORDER +C NQ + 1 IF K = 3. +C----------------------------------------------------------------------- + DIMENSION PC(12) +C + GO TO (100, 200), METH +C + 100 ELCO(1,1) = 1.0D0 + ELCO(2,1) = 1.0D0 + TESCO(1,1) = 0.0D0 + TESCO(2,1) = 2.0D0 + TESCO(1,2) = 1.0D0 + TESCO(3,12) = 0.0D0 + PC(1) = 1.0D0 + RQFAC = 1.0D0 + DO 140 NQ = 2,12 +C----------------------------------------------------------------------- +C THE PC ARRAY WILL CONTAIN THE COEFFICIENTS OF THE POLYNOMIAL +C P(X) = (X+1)*(X+2)*...*(X+NQ-1). +C INITIALLY, P(X) = 1. +C----------------------------------------------------------------------- + RQ1FAC = RQFAC + RQFAC = RQFAC/DBLE(NQ) + NQM1 = NQ - 1 + FNQM1 = DBLE(NQM1) + NQP1 = NQ + 1 +C FORM COEFFICIENTS OF P(X)*(X+NQ-1). ---------------------------------- + PC(NQ) = 0.0D0 + DO 110 IB = 1,NQM1 + I = NQP1 - IB + 110 PC(I) = PC(I-1) + FNQM1*PC(I) + PC(1) = FNQM1*PC(1) +C COMPUTE INTEGRAL, -1 TO 0, OF P(X) AND X*P(X). ----------------------- + PINT = PC(1) + XPIN = PC(1)/2.0D0 + TSIGN = 1.0D0 + DO 120 I = 2,NQ + TSIGN = -TSIGN + PINT = PINT + TSIGN*PC(I)/DBLE(I) + 120 XPIN = XPIN + TSIGN*PC(I)/DBLE(I+1) +C STORE COEFFICIENTS IN ELCO AND TESCO. -------------------------------- + ELCO(1,NQ) = PINT*RQ1FAC + ELCO(2,NQ) = 1.0D0 + DO 130 I = 2,NQ + 130 ELCO(I+1,NQ) = RQ1FAC*PC(I)/DBLE(I) + AGAMQ = RQFAC*XPIN + RAGQ = 1.0D0/AGAMQ + TESCO(2,NQ) = RAGQ + IF (NQ .LT. 12) TESCO(1,NQP1) = RAGQ*RQFAC/DBLE(NQP1) + TESCO(3,NQM1) = RAGQ + 140 CONTINUE + RETURN +C + 200 PC(1) = 1.0D0 + RQ1FAC = 1.0D0 + DO 230 NQ = 1,5 +C----------------------------------------------------------------------- +C THE PC ARRAY WILL CONTAIN THE COEFFICIENTS OF THE POLYNOMIAL +C P(X) = (X+1)*(X+2)*...*(X+NQ). +C INITIALLY, P(X) = 1. +C----------------------------------------------------------------------- + FNQ = DBLE(NQ) + NQP1 = NQ + 1 +C FORM COEFFICIENTS OF P(X)*(X+NQ). ------------------------------------ + PC(NQP1) = 0.0D0 + DO 210 IB = 1,NQ + I = NQ + 2 - IB + 210 PC(I) = PC(I-1) + FNQ*PC(I) + PC(1) = FNQ*PC(1) +C STORE COEFFICIENTS IN ELCO AND TESCO. -------------------------------- + DO 220 I = 1,NQP1 + 220 ELCO(I,NQ) = PC(I)/PC(2) + ELCO(2,NQ) = 1.0D0 + TESCO(1,NQ) = RQ1FAC + TESCO(2,NQ) = DBLE(NQP1)/ELCO(1,NQ) + TESCO(3,NQ) = DBLE(NQ+2)/ELCO(1,NQ) + RQ1FAC = RQ1FAC/FNQ + 230 CONTINUE + RETURN +C----------------------- END OF SUBROUTINE CFODE ----------------------- + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/odepack/dlsode.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,1525 @@ + SUBROUTINE DLSODE (F, NEQ, Y, T, TOUT, ITOL, RTOL, ATOL, ITASK, + 1 ISTATE, IOPT, RWORK, LRW, IWORK, LIW, JAC, MF) + EXTERNAL F, JAC + INTEGER NEQ, ITOL, ITASK, ISTATE, IOPT, LRW, IWORK, LIW, MF + DOUBLE PRECISION Y, T, TOUT, RTOL, ATOL, RWORK + DIMENSION NEQ(*), Y(*), RTOL(*), ATOL(*), RWORK(LRW), IWORK(LIW) +C----------------------------------------------------------------------- +C THIS IS THE MARCH 30, 1987 VERSION OF +C LSODE.. LIVERMORE SOLVER FOR ORDINARY DIFFERENTIAL EQUATIONS. +C THIS VERSION IS IN DOUBLE PRECISION. +C +C LSODE SOLVES THE INITIAL VALUE PROBLEM FOR STIFF OR NONSTIFF +C SYSTEMS OF FIRST ORDER ODE-S, +C DY/DT = F(T,Y) , OR, IN COMPONENT FORM, +C DY(I)/DT = F(I) = F(I,T,Y(1),Y(2),...,Y(NEQ)) (I = 1,...,NEQ). +C LSODE IS A PACKAGE BASED ON THE GEAR AND GEARB PACKAGES, AND ON THE +C OCTOBER 23, 1978 VERSION OF THE TENTATIVE ODEPACK USER INTERFACE +C STANDARD, WITH MINOR MODIFICATIONS. +C----------------------------------------------------------------------- +C REFERENCE.. +C ALAN C. HINDMARSH, ODEPACK, A SYSTEMATIZED COLLECTION OF ODE +C SOLVERS, IN SCIENTIFIC COMPUTING, R. S. STEPLEMAN ET AL. (EDS.), +C NORTH-HOLLAND, AMSTERDAM, 1983, PP. 55-64. +C----------------------------------------------------------------------- +C AUTHOR AND CONTACT.. ALAN C. HINDMARSH, +C COMPUTING AND MATHEMATICS RESEARCH DIV., L-316 +C LAWRENCE LIVERMORE NATIONAL LABORATORY +C LIVERMORE, CA 94550. +C----------------------------------------------------------------------- +C SUMMARY OF USAGE. +C +C COMMUNICATION BETWEEN THE USER AND THE LSODE PACKAGE, FOR NORMAL +C SITUATIONS, IS SUMMARIZED HERE. THIS SUMMARY DESCRIBES ONLY A SUBSET +C OF THE FULL SET OF OPTIONS AVAILABLE. SEE THE FULL DESCRIPTION FOR +C DETAILS, INCLUDING OPTIONAL COMMUNICATION, NONSTANDARD OPTIONS, +C AND INSTRUCTIONS FOR SPECIAL SITUATIONS. SEE ALSO THE EXAMPLE +C PROBLEM (WITH PROGRAM AND OUTPUT) FOLLOWING THIS SUMMARY. +C +C A. FIRST PROVIDE A SUBROUTINE OF THE FORM.. +C SUBROUTINE F (NEQ, T, Y, YDOT, IERR) +C DIMENSION Y(NEQ), YDOT(NEQ) +C WHICH SUPPLIES THE VECTOR FUNCTION F BY LOADING YDOT(I) WITH F(I). +C +C B. NEXT DETERMINE (OR GUESS) WHETHER OR NOT THE PROBLEM IS STIFF. +C STIFFNESS OCCURS WHEN THE JACOBIAN MATRIX DF/DY HAS AN EIGENVALUE +C WHOSE REAL PART IS NEGATIVE AND LARGE IN MAGNITUDE, COMPARED TO THE +C RECIPROCAL OF THE T SPAN OF INTEREST. IF THE PROBLEM IS NONSTIFF, +C USE A METHOD FLAG MF = 10. IF IT IS STIFF, THERE ARE FOUR STANDARD +C CHOICES FOR MF, AND LSODE REQUIRES THE JACOBIAN MATRIX IN SOME FORM. +C THIS MATRIX IS REGARDED EITHER AS FULL (MF = 21 OR 22), +C OR BANDED (MF = 24 OR 25). IN THE BANDED CASE, LSODE REQUIRES TWO +C HALF-BANDWIDTH PARAMETERS ML AND MU. THESE ARE, RESPECTIVELY, THE +C WIDTHS OF THE LOWER AND UPPER PARTS OF THE BAND, EXCLUDING THE MAIN +C DIAGONAL. THUS THE BAND CONSISTS OF THE LOCATIONS (I,J) WITH +C I-ML .LE. J .LE. I+MU, AND THE FULL BANDWIDTH IS ML+MU+1. +C +C C. IF THE PROBLEM IS STIFF, YOU ARE ENCOURAGED TO SUPPLY THE JACOBIAN +C DIRECTLY (MF = 21 OR 24), BUT IF THIS IS NOT FEASIBLE, LSODE WILL +C COMPUTE IT INTERNALLY BY DIFFERENCE QUOTIENTS (MF = 22 OR 25). +C IF YOU ARE SUPPLYING THE JACOBIAN, PROVIDE A SUBROUTINE OF THE FORM.. +C SUBROUTINE JAC (NEQ, T, Y, ML, MU, PD, NROWPD) +C DIMENSION Y(NEQ), PD(NROWPD,NEQ) +C WHICH SUPPLIES DF/DY BY LOADING PD AS FOLLOWS.. +C FOR A FULL JACOBIAN (MF = 21), LOAD PD(I,J) WITH DF(I)/DY(J), +C THE PARTIAL DERIVATIVE OF F(I) WITH RESPECT TO Y(J). (IGNORE THE +C ML AND MU ARGUMENTS IN THIS CASE.) +C FOR A BANDED JACOBIAN (MF = 24), LOAD PD(I-J+MU+1,J) WITH +C DF(I)/DY(J), I.E. LOAD THE DIAGONAL LINES OF DF/DY INTO THE ROWS OF +C PD FROM THE TOP DOWN. +C IN EITHER CASE, ONLY NONZERO ELEMENTS NEED BE LOADED. +C +C D. WRITE A MAIN PROGRAM WHICH CALLS SUBROUTINE LSODE ONCE FOR +C EACH POINT AT WHICH ANSWERS ARE DESIRED. THIS SHOULD ALSO PROVIDE +C FOR POSSIBLE USE OF LOGICAL UNIT 6 FOR OUTPUT OF ERROR MESSAGES +C BY LSODE. ON THE FIRST CALL TO LSODE, SUPPLY ARGUMENTS AS FOLLOWS.. +C F = NAME OF SUBROUTINE FOR RIGHT-HAND SIDE VECTOR F. +C THIS NAME MUST BE DECLARED EXTERNAL IN CALLING PROGRAM. +C NEQ = NUMBER OF FIRST ORDER ODE-S. +C Y = ARRAY OF INITIAL VALUES, OF LENGTH NEQ. +C T = THE INITIAL VALUE OF THE INDEPENDENT VARIABLE. +C TOUT = FIRST POINT WHERE OUTPUT IS DESIRED (.NE. T). +C ITOL = 1 OR 2 ACCORDING AS ATOL (BELOW) IS A SCALAR OR ARRAY. +C RTOL = RELATIVE TOLERANCE PARAMETER (SCALAR). +C ATOL = ABSOLUTE TOLERANCE PARAMETER (SCALAR OR ARRAY). +C THE ESTIMATED LOCAL ERROR IN Y(I) WILL BE CONTROLLED SO AS +C TO BE ROUGHLY LESS (IN MAGNITUDE) THAN +C EWT(I) = RTOL*ABS(Y(I)) + ATOL IF ITOL = 1, OR +C EWT(I) = RTOL*ABS(Y(I)) + ATOL(I) IF ITOL = 2. +C THUS THE LOCAL ERROR TEST PASSES IF, IN EACH COMPONENT, +C EITHER THE ABSOLUTE ERROR IS LESS THAN ATOL (OR ATOL(I)), +C OR THE RELATIVE ERROR IS LESS THAN RTOL. +C USE RTOL = 0.0 FOR PURE ABSOLUTE ERROR CONTROL, AND +C USE ATOL = 0.0 (OR ATOL(I) = 0.0) FOR PURE RELATIVE ERROR +C CONTROL. CAUTION.. ACTUAL (GLOBAL) ERRORS MAY EXCEED THESE +C LOCAL TOLERANCES, SO CHOOSE THEM CONSERVATIVELY. +C ITASK = 1 FOR NORMAL COMPUTATION OF OUTPUT VALUES OF Y AT T = TOUT. +C ISTATE = INTEGER FLAG (INPUT AND OUTPUT). SET ISTATE = 1. +C IOPT = 0 TO INDICATE NO OPTIONAL INPUTS USED. +C RWORK = REAL WORK ARRAY OF LENGTH AT LEAST.. +C 20 + 16*NEQ FOR MF = 10, +C 22 + 9*NEQ + NEQ**2 FOR MF = 21 OR 22, +C 22 + 10*NEQ + (2*ML + MU)*NEQ FOR MF = 24 OR 25. +C LRW = DECLARED LENGTH OF RWORK (IN USER-S DIMENSION). +C IWORK = INTEGER WORK ARRAY OF LENGTH AT LEAST.. +C 20 FOR MF = 10, +C 20 + NEQ FOR MF = 21, 22, 24, OR 25. +C IF MF = 24 OR 25, INPUT IN IWORK(1),IWORK(2) THE LOWER +C AND UPPER HALF-BANDWIDTHS ML,MU. +C LIW = DECLARED LENGTH OF IWORK (IN USER-S DIMENSION). +C JAC = NAME OF SUBROUTINE FOR JACOBIAN MATRIX (MF = 21 OR 24). +C IF USED, THIS NAME MUST BE DECLARED EXTERNAL IN CALLING +C PROGRAM. IF NOT USED, PASS A DUMMY NAME. +C MF = METHOD FLAG. STANDARD VALUES ARE.. +C 10 FOR NONSTIFF (ADAMS) METHOD, NO JACOBIAN USED. +C 21 FOR STIFF (BDF) METHOD, USER-SUPPLIED FULL JACOBIAN. +C 22 FOR STIFF METHOD, INTERNALLY GENERATED FULL JACOBIAN. +C 24 FOR STIFF METHOD, USER-SUPPLIED BANDED JACOBIAN. +C 25 FOR STIFF METHOD, INTERNALLY GENERATED BANDED JACOBIAN. +C NOTE THAT THE MAIN PROGRAM MUST DECLARE ARRAYS Y, RWORK, IWORK, +C AND POSSIBLY ATOL. +C +C E. THE OUTPUT FROM THE FIRST CALL (OR ANY CALL) IS.. +C Y = ARRAY OF COMPUTED VALUES OF Y(T) VECTOR. +C T = CORRESPONDING VALUE OF INDEPENDENT VARIABLE (NORMALLY TOUT). +C ISTATE = 2 IF LSODE WAS SUCCESSFUL, NEGATIVE OTHERWISE. +C -1 MEANS EXCESS WORK DONE ON THIS CALL (PERHAPS WRONG MF). +C -2 MEANS EXCESS ACCURACY REQUESTED (TOLERANCES TOO SMALL). +C -3 MEANS ILLEGAL INPUT DETECTED (SEE PRINTED MESSAGE). +C -4 MEANS REPEATED ERROR TEST FAILURES (CHECK ALL INPUTS). +C -5 MEANS REPEATED CONVERGENCE FAILURES (PERHAPS BAD JACOBIAN +C SUPPLIED OR WRONG CHOICE OF MF OR TOLERANCES). +C -6 MEANS ERROR WEIGHT BECAME ZERO DURING PROBLEM. (SOLUTION +C COMPONENT I VANISHED, AND ATOL OR ATOL(I) = 0.) +C -13 MEANS EXIT REQUESTED IN USER-SUPPLIED FUNCTION. +C +C F. TO CONTINUE THE INTEGRATION AFTER A SUCCESSFUL RETURN, SIMPLY +C RESET TOUT AND CALL LSODE AGAIN. NO OTHER PARAMETERS NEED BE RESET. +C +C----------------------------------------------------------------------- +C EXAMPLE PROBLEM. +C +C THE FOLLOWING IS A SIMPLE EXAMPLE PROBLEM, WITH THE CODING +C NEEDED FOR ITS SOLUTION BY LSODE. THE PROBLEM IS FROM CHEMICAL +C KINETICS, AND CONSISTS OF THE FOLLOWING THREE RATE EQUATIONS.. +C DY1/DT = -.04*Y1 + 1.E4*Y2*Y3 +C DY2/DT = .04*Y1 - 1.E4*Y2*Y3 - 3.E7*Y2**2 +C DY3/DT = 3.E7*Y2**2 +C ON THE INTERVAL FROM T = 0.0 TO T = 4.E10, WITH INITIAL CONDITIONS +C Y1 = 1.0, Y2 = Y3 = 0. THE PROBLEM IS STIFF. +C +C THE FOLLOWING CODING SOLVES THIS PROBLEM WITH LSODE, USING MF = 21 +C AND PRINTING RESULTS AT T = .4, 4., ..., 4.E10. IT USES +C ITOL = 2 AND ATOL MUCH SMALLER FOR Y2 THAN Y1 OR Y3 BECAUSE +C Y2 HAS MUCH SMALLER VALUES. +C AT THE END OF THE RUN, STATISTICAL QUANTITIES OF INTEREST ARE +C PRINTED (SEE OPTIONAL OUTPUTS IN THE FULL DESCRIPTION BELOW). +C +C EXTERNAL FEX, JEX +C DOUBLE PRECISION ATOL, RTOL, RWORK, T, TOUT, Y +C DIMENSION Y(3), ATOL(3), RWORK(58), IWORK(23) +C NEQ = 3 +C Y(1) = 1.D0 +C Y(2) = 0.D0 +C Y(3) = 0.D0 +C T = 0.D0 +C TOUT = .4D0 +C ITOL = 2 +C RTOL = 1.D-4 +C ATOL(1) = 1.D-6 +C ATOL(2) = 1.D-10 +C ATOL(3) = 1.D-6 +C ITASK = 1 +C ISTATE = 1 +C IOPT = 0 +C LRW = 58 +C LIW = 23 +C MF = 21 +C DO 40 IOUT = 1,12 +C CALL LSODE(FEX,NEQ,Y,T,TOUT,ITOL,RTOL,ATOL,ITASK,ISTATE, +C 1 IOPT,RWORK,LRW,IWORK,LIW,JEX,MF) +C WRITE(6,20)T,Y(1),Y(2),Y(3) +C 20 FORMAT(7H AT T =,E12.4,6H Y =,3E14.6) +C IF (ISTATE .LT. 0) GO TO 80 +C 40 TOUT = TOUT*10.D0 +C WRITE(6,60)IWORK(11),IWORK(12),IWORK(13) +C 60 FORMAT(/12H NO. STEPS =,I4,11H NO. F-S =,I4,11H NO. J-S =,I4) +C STOP +C 80 WRITE(6,90)ISTATE +C 90 FORMAT(///22H ERROR HALT.. ISTATE =,I3) +C STOP +C END +C +C SUBROUTINE FEX (NEQ, T, Y, YDOT) +C DOUBLE PRECISION T, Y, YDOT +C DIMENSION Y(3), YDOT(3) +C YDOT(1) = -.04D0*Y(1) + 1.D4*Y(2)*Y(3) +C YDOT(3) = 3.D7*Y(2)*Y(2) +C YDOT(2) = -YDOT(1) - YDOT(3) +C RETURN +C END +C +C SUBROUTINE JEX (NEQ, T, Y, ML, MU, PD, NRPD) +C DOUBLE PRECISION PD, T, Y +C DIMENSION Y(3), PD(NRPD,3) +C PD(1,1) = -.04D0 +C PD(1,2) = 1.D4*Y(3) +C PD(1,3) = 1.D4*Y(2) +C PD(2,1) = .04D0 +C PD(2,3) = -PD(1,3) +C PD(3,2) = 6.D7*Y(2) +C PD(2,2) = -PD(1,2) - PD(3,2) +C RETURN +C END +C +C THE OUTPUT OF THIS PROGRAM (ON A CDC-7600 IN SINGLE PRECISION) +C IS AS FOLLOWS.. +C +C AT T = 4.0000E-01 Y = 9.851726E-01 3.386406E-05 1.479357E-02 +C AT T = 4.0000E+00 Y = 9.055142E-01 2.240418E-05 9.446344E-02 +C AT T = 4.0000E+01 Y = 7.158050E-01 9.184616E-06 2.841858E-01 +C AT T = 4.0000E+02 Y = 4.504846E-01 3.222434E-06 5.495122E-01 +C AT T = 4.0000E+03 Y = 1.831701E-01 8.940379E-07 8.168290E-01 +C AT T = 4.0000E+04 Y = 3.897016E-02 1.621193E-07 9.610297E-01 +C AT T = 4.0000E+05 Y = 4.935213E-03 1.983756E-08 9.950648E-01 +C AT T = 4.0000E+06 Y = 5.159269E-04 2.064759E-09 9.994841E-01 +C AT T = 4.0000E+07 Y = 5.306413E-05 2.122677E-10 9.999469E-01 +C AT T = 4.0000E+08 Y = 5.494529E-06 2.197824E-11 9.999945E-01 +C AT T = 4.0000E+09 Y = 5.129458E-07 2.051784E-12 9.999995E-01 +C AT T = 4.0000E+10 Y = -7.170586E-08 -2.868234E-13 1.000000E+00 +C +C NO. STEPS = 330 NO. F-S = 405 NO. J-S = 69 +C----------------------------------------------------------------------- +C FULL DESCRIPTION OF USER INTERFACE TO LSODE. +C +C THE USER INTERFACE TO LSODE CONSISTS OF THE FOLLOWING PARTS. +C +C I. THE CALL SEQUENCE TO SUBROUTINE LSODE, WHICH IS A DRIVER +C ROUTINE FOR THE SOLVER. THIS INCLUDES DESCRIPTIONS OF BOTH +C THE CALL SEQUENCE ARGUMENTS AND OF USER-SUPPLIED ROUTINES. +C FOLLOWING THESE DESCRIPTIONS IS A DESCRIPTION OF +C OPTIONAL INPUTS AVAILABLE THROUGH THE CALL SEQUENCE, AND THEN +C A DESCRIPTION OF OPTIONAL OUTPUTS (IN THE WORK ARRAYS). +C +C II. DESCRIPTIONS OF OTHER ROUTINES IN THE LSODE PACKAGE THAT MAY BE +C (OPTIONALLY) CALLED BY THE USER. THESE PROVIDE THE ABILITY TO +C ALTER ERROR MESSAGE HANDLING, SAVE AND RESTORE THE INTERNAL +C COMMON, AND OBTAIN SPECIFIED DERIVATIVES OF THE SOLUTION Y(T). +C +C III. DESCRIPTIONS OF COMMON BLOCKS TO BE DECLARED IN OVERLAY +C OR SIMILAR ENVIRONMENTS, OR TO BE SAVED WHEN DOING AN INTERRUPT +C OF THE PROBLEM AND CONTINUED SOLUTION LATER. +C +C IV. DESCRIPTION OF TWO ROUTINES IN THE LSODE PACKAGE, EITHER OF +C WHICH THE USER MAY REPLACE WITH HIS OWN VERSION, IF DESIRED. +C THESE RELATE TO THE MEASUREMENT OF ERRORS. +C +C----------------------------------------------------------------------- +C PART I. CALL SEQUENCE. +C +C THE CALL SEQUENCE PARAMETERS USED FOR INPUT ONLY ARE +C F, NEQ, TOUT, ITOL, RTOL, ATOL, ITASK, IOPT, LRW, LIW, JAC, MF, +C AND THOSE USED FOR BOTH INPUT AND OUTPUT ARE +C Y, T, ISTATE. +C THE WORK ARRAYS RWORK AND IWORK ARE ALSO USED FOR CONDITIONAL AND +C OPTIONAL INPUTS AND OPTIONAL OUTPUTS. (THE TERM OUTPUT HERE REFERS +C TO THE RETURN FROM SUBROUTINE LSODE TO THE USER-S CALLING PROGRAM.) +C +C THE LEGALITY OF INPUT PARAMETERS WILL BE THOROUGHLY CHECKED ON THE +C INITIAL CALL FOR THE PROBLEM, BUT NOT CHECKED THEREAFTER UNLESS A +C CHANGE IN INPUT PARAMETERS IS FLAGGED BY ISTATE = 3 ON INPUT. +C +C THE DESCRIPTIONS OF THE CALL ARGUMENTS ARE AS FOLLOWS. +C +C F = THE NAME OF THE USER-SUPPLIED SUBROUTINE DEFINING THE +C ODE SYSTEM. THE SYSTEM MUST BE PUT IN THE FIRST-ORDER +C FORM DY/DT = F(T,Y), WHERE F IS A VECTOR-VALUED FUNCTION +C OF THE SCALAR T AND THE VECTOR Y. SUBROUTINE F IS TO +C COMPUTE THE FUNCTION F. IT IS TO HAVE THE FORM +C SUBROUTINE F (NEQ, T, Y, YDOT) +C DIMENSION Y(1), YDOT(1) +C WHERE NEQ, T, AND Y ARE INPUT, AND THE ARRAY YDOT = F(T,Y) +C IS OUTPUT. Y AND YDOT ARE ARRAYS OF LENGTH NEQ. +C (IN THE DIMENSION STATEMENT ABOVE, 1 IS A DUMMY +C DIMENSION.. IT CAN BE REPLACED BY ANY VALUE.) +C SUBROUTINE F SHOULD NOT ALTER Y(1),...,Y(NEQ). +C F MUST BE DECLARED EXTERNAL IN THE CALLING PROGRAM. +C +C SUBROUTINE F MAY ACCESS USER-DEFINED QUANTITIES IN +C NEQ(2),... AND/OR IN Y(NEQ(1)+1),... IF NEQ IS AN ARRAY +C (DIMENSIONED IN F) AND/OR Y HAS LENGTH EXCEEDING NEQ(1). +C SEE THE DESCRIPTIONS OF NEQ AND Y BELOW. +C +C IF QUANTITIES COMPUTED IN THE F ROUTINE ARE NEEDED +C EXTERNALLY TO LSODE, AN EXTRA CALL TO F SHOULD BE MADE +C FOR THIS PURPOSE, FOR CONSISTENT AND ACCURATE RESULTS. +C IF ONLY THE DERIVATIVE DY/DT IS NEEDED, USE INTDY INSTEAD. +C +C NEQ = THE SIZE OF THE ODE SYSTEM (NUMBER OF FIRST ORDER +C ORDINARY DIFFERENTIAL EQUATIONS). USED ONLY FOR INPUT. +C NEQ MAY BE DECREASED, BUT NOT INCREASED, DURING THE PROBLEM. +C IF NEQ IS DECREASED (WITH ISTATE = 3 ON INPUT), THE +C REMAINING COMPONENTS OF Y SHOULD BE LEFT UNDISTURBED, IF +C THESE ARE TO BE ACCESSED IN F AND/OR JAC. +C +C NORMALLY, NEQ IS A SCALAR, AND IT IS GENERALLY REFERRED TO +C AS A SCALAR IN THIS USER INTERFACE DESCRIPTION. HOWEVER, +C NEQ MAY BE AN ARRAY, WITH NEQ(1) SET TO THE SYSTEM SIZE. +C (THE LSODE PACKAGE ACCESSES ONLY NEQ(1).) IN EITHER CASE, +C THIS PARAMETER IS PASSED AS THE NEQ ARGUMENT IN ALL CALLS +C TO F AND JAC. HENCE, IF IT IS AN ARRAY, LOCATIONS +C NEQ(2),... MAY BE USED TO STORE OTHER INTEGER DATA AND PASS +C IT TO F AND/OR JAC. SUBROUTINES F AND/OR JAC MUST INCLUDE +C NEQ IN A DIMENSION STATEMENT IN THAT CASE. +C +C Y = A REAL ARRAY FOR THE VECTOR OF DEPENDENT VARIABLES, OF +C LENGTH NEQ OR MORE. USED FOR BOTH INPUT AND OUTPUT ON THE +C FIRST CALL (ISTATE = 1), AND ONLY FOR OUTPUT ON OTHER CALLS. +C ON THE FIRST CALL, Y MUST CONTAIN THE VECTOR OF INITIAL +C VALUES. ON OUTPUT, Y CONTAINS THE COMPUTED SOLUTION VECTOR, +C EVALUATED AT T. IF DESIRED, THE Y ARRAY MAY BE USED +C FOR OTHER PURPOSES BETWEEN CALLS TO THE SOLVER. +C +C THIS ARRAY IS PASSED AS THE Y ARGUMENT IN ALL CALLS TO +C F AND JAC. HENCE ITS LENGTH MAY EXCEED NEQ, AND LOCATIONS +C Y(NEQ+1),... MAY BE USED TO STORE OTHER REAL DATA AND +C PASS IT TO F AND/OR JAC. (THE LSODE PACKAGE ACCESSES ONLY +C Y(1),...,Y(NEQ).) +C +C T = THE INDEPENDENT VARIABLE. ON INPUT, T IS USED ONLY ON THE +C FIRST CALL, AS THE INITIAL POINT OF THE INTEGRATION. +C ON OUTPUT, AFTER EACH CALL, T IS THE VALUE AT WHICH A +C COMPUTED SOLUTION Y IS EVALUATED (USUALLY THE SAME AS TOUT). +C ON AN ERROR RETURN, T IS THE FARTHEST POINT REACHED. +C +C TOUT = THE NEXT VALUE OF T AT WHICH A COMPUTED SOLUTION IS DESIRED. +C USED ONLY FOR INPUT. +C +C WHEN STARTING THE PROBLEM (ISTATE = 1), TOUT MAY BE EQUAL +C TO T FOR ONE CALL, THEN SHOULD .NE. T FOR THE NEXT CALL. +C FOR THE INITIAL T, AN INPUT VALUE OF TOUT .NE. T IS USED +C IN ORDER TO DETERMINE THE DIRECTION OF THE INTEGRATION +C (I.E. THE ALGEBRAIC SIGN OF THE STEP SIZES) AND THE ROUGH +C SCALE OF THE PROBLEM. INTEGRATION IN EITHER DIRECTION +C (FORWARD OR BACKWARD IN T) IS PERMITTED. +C +C IF ITASK = 2 OR 5 (ONE-STEP MODES), TOUT IS IGNORED AFTER +C THE FIRST CALL (I.E. THE FIRST CALL WITH TOUT .NE. T). +C OTHERWISE, TOUT IS REQUIRED ON EVERY CALL. +C +C IF ITASK = 1, 3, OR 4, THE VALUES OF TOUT NEED NOT BE +C MONOTONE, BUT A VALUE OF TOUT WHICH BACKS UP IS LIMITED +C TO THE CURRENT INTERNAL T INTERVAL, WHOSE ENDPOINTS ARE +C TCUR - HU AND TCUR (SEE OPTIONAL OUTPUTS, BELOW, FOR +C TCUR AND HU). +C +C ITOL = AN INDICATOR FOR THE TYPE OF ERROR CONTROL. SEE +C DESCRIPTION BELOW UNDER ATOL. USED ONLY FOR INPUT. +C +C RTOL = A RELATIVE ERROR TOLERANCE PARAMETER, EITHER A SCALAR OR +C AN ARRAY OF LENGTH NEQ. SEE DESCRIPTION BELOW UNDER ATOL. +C INPUT ONLY. +C +C ATOL = AN ABSOLUTE ERROR TOLERANCE PARAMETER, EITHER A SCALAR OR +C AN ARRAY OF LENGTH NEQ. INPUT ONLY. +C +C THE INPUT PARAMETERS ITOL, RTOL, AND ATOL DETERMINE +C THE ERROR CONTROL PERFORMED BY THE SOLVER. THE SOLVER WILL +C CONTROL THE VECTOR E = (E(I)) OF ESTIMATED LOCAL ERRORS +C IN Y, ACCORDING TO AN INEQUALITY OF THE FORM +C RMS-NORM OF ( E(I)/EWT(I) ) .LE. 1, +C WHERE EWT(I) = RTOL(I)*ABS(Y(I)) + ATOL(I), +C AND THE RMS-NORM (ROOT-MEAN-SQUARE NORM) HERE IS +C RMS-NORM(V) = SQRT(SUM V(I)**2 / NEQ). HERE EWT = (EWT(I)) +C IS A VECTOR OF WEIGHTS WHICH MUST ALWAYS BE POSITIVE, AND +C THE VALUES OF RTOL AND ATOL SHOULD ALL BE NON-NEGATIVE. +C THE FOLLOWING TABLE GIVES THE TYPES (SCALAR/ARRAY) OF +C RTOL AND ATOL, AND THE CORRESPONDING FORM OF EWT(I). +C +C ITOL RTOL ATOL EWT(I) +C 1 SCALAR SCALAR RTOL*ABS(Y(I)) + ATOL +C 2 SCALAR ARRAY RTOL*ABS(Y(I)) + ATOL(I) +C 3 ARRAY SCALAR RTOL(I)*ABS(Y(I)) + ATOL +C 4 ARRAY ARRAY RTOL(I)*ABS(Y(I)) + ATOL(I) +C +C WHEN EITHER OF THESE PARAMETERS IS A SCALAR, IT NEED NOT +C BE DIMENSIONED IN THE USER-S CALLING PROGRAM. +C +C IF NONE OF THE ABOVE CHOICES (WITH ITOL, RTOL, AND ATOL +C FIXED THROUGHOUT THE PROBLEM) IS SUITABLE, MORE GENERAL +C ERROR CONTROLS CAN BE OBTAINED BY SUBSTITUTING +C USER-SUPPLIED ROUTINES FOR THE SETTING OF EWT AND/OR FOR +C THE NORM CALCULATION. SEE PART IV BELOW. +C +C IF GLOBAL ERRORS ARE TO BE ESTIMATED BY MAKING A REPEATED +C RUN ON THE SAME PROBLEM WITH SMALLER TOLERANCES, THEN ALL +C COMPONENTS OF RTOL AND ATOL (I.E. OF EWT) SHOULD BE SCALED +C DOWN UNIFORMLY. +C +C ITASK = AN INDEX SPECIFYING THE TASK TO BE PERFORMED. +C INPUT ONLY. ITASK HAS THE FOLLOWING VALUES AND MEANINGS. +C 1 MEANS NORMAL COMPUTATION OF OUTPUT VALUES OF Y(T) AT +C T = TOUT (BY OVERSHOOTING AND INTERPOLATING). +C 2 MEANS TAKE ONE STEP ONLY AND RETURN. +C 3 MEANS STOP AT THE FIRST INTERNAL MESH POINT AT OR +C BEYOND T = TOUT AND RETURN. +C 4 MEANS NORMAL COMPUTATION OF OUTPUT VALUES OF Y(T) AT +C T = TOUT BUT WITHOUT OVERSHOOTING T = TCRIT. +C TCRIT MUST BE INPUT AS RWORK(1). TCRIT MAY BE EQUAL TO +C OR BEYOND TOUT, BUT NOT BEHIND IT IN THE DIRECTION OF +C INTEGRATION. THIS OPTION IS USEFUL IF THE PROBLEM +C HAS A SINGULARITY AT OR BEYOND T = TCRIT. +C 5 MEANS TAKE ONE STEP, WITHOUT PASSING TCRIT, AND RETURN. +C TCRIT MUST BE INPUT AS RWORK(1). +C +C NOTE.. IF ITASK = 4 OR 5 AND THE SOLVER REACHES TCRIT +C (WITHIN ROUNDOFF), IT WILL RETURN T = TCRIT (EXACTLY) TO +C INDICATE THIS (UNLESS ITASK = 4 AND TOUT COMES BEFORE TCRIT, +C IN WHICH CASE ANSWERS AT T = TOUT ARE RETURNED FIRST). +C +C ISTATE = AN INDEX USED FOR INPUT AND OUTPUT TO SPECIFY THE +C THE STATE OF THE CALCULATION. +C +C ON INPUT, THE VALUES OF ISTATE ARE AS FOLLOWS. +C 1 MEANS THIS IS THE FIRST CALL FOR THE PROBLEM +C (INITIALIZATIONS WILL BE DONE). SEE NOTE BELOW. +C 2 MEANS THIS IS NOT THE FIRST CALL, AND THE CALCULATION +C IS TO CONTINUE NORMALLY, WITH NO CHANGE IN ANY INPUT +C PARAMETERS EXCEPT POSSIBLY TOUT AND ITASK. +C (IF ITOL, RTOL, AND/OR ATOL ARE CHANGED BETWEEN CALLS +C WITH ISTATE = 2, THE NEW VALUES WILL BE USED BUT NOT +C TESTED FOR LEGALITY.) +C 3 MEANS THIS IS NOT THE FIRST CALL, AND THE +C CALCULATION IS TO CONTINUE NORMALLY, BUT WITH +C A CHANGE IN INPUT PARAMETERS OTHER THAN +C TOUT AND ITASK. CHANGES ARE ALLOWED IN +C NEQ, ITOL, RTOL, ATOL, IOPT, LRW, LIW, MF, ML, MU, +C AND ANY OF THE OPTIONAL INPUTS EXCEPT H0. +C (SEE IWORK DESCRIPTION FOR ML AND MU.) +C NOTE.. A PRELIMINARY CALL WITH TOUT = T IS NOT COUNTED +C AS A FIRST CALL HERE, AS NO INITIALIZATION OR CHECKING OF +C INPUT IS DONE. (SUCH A CALL IS SOMETIMES USEFUL FOR THE +C PURPOSE OF OUTPUTTING THE INITIAL CONDITIONS.) +C THUS THE FIRST CALL FOR WHICH TOUT .NE. T REQUIRES +C ISTATE = 1 ON INPUT. +C +C ON OUTPUT, ISTATE HAS THE FOLLOWING VALUES AND MEANINGS. +C 1 MEANS NOTHING WAS DONE, AS TOUT WAS EQUAL TO T WITH +C ISTATE = 1 ON INPUT. (HOWEVER, AN INTERNAL COUNTER WAS +C SET TO DETECT AND PREVENT REPEATED CALLS OF THIS TYPE.) +C 2 MEANS THE INTEGRATION WAS PERFORMED SUCCESSFULLY. +C -1 MEANS AN EXCESSIVE AMOUNT OF WORK (MORE THAN MXSTEP +C STEPS) WAS DONE ON THIS CALL, BEFORE COMPLETING THE +C REQUESTED TASK, BUT THE INTEGRATION WAS OTHERWISE +C SUCCESSFUL AS FAR AS T. (MXSTEP IS AN OPTIONAL INPUT +C AND IS NORMALLY 500.) TO CONTINUE, THE USER MAY +C SIMPLY RESET ISTATE TO A VALUE .GT. 1 AND CALL AGAIN +C (THE EXCESS WORK STEP COUNTER WILL BE RESET TO 0). +C IN ADDITION, THE USER MAY INCREASE MXSTEP TO AVOID +C THIS ERROR RETURN (SEE BELOW ON OPTIONAL INPUTS). +C -2 MEANS TOO MUCH ACCURACY WAS REQUESTED FOR THE PRECISION +C OF THE MACHINE BEING USED. THIS WAS DETECTED BEFORE +C COMPLETING THE REQUESTED TASK, BUT THE INTEGRATION +C WAS SUCCESSFUL AS FAR AS T. TO CONTINUE, THE TOLERANCE +C PARAMETERS MUST BE RESET, AND ISTATE MUST BE SET +C TO 3. THE OPTIONAL OUTPUT TOLSF MAY BE USED FOR THIS +C PURPOSE. (NOTE.. IF THIS CONDITION IS DETECTED BEFORE +C TAKING ANY STEPS, THEN AN ILLEGAL INPUT RETURN +C (ISTATE = -3) OCCURS INSTEAD.) +C -3 MEANS ILLEGAL INPUT WAS DETECTED, BEFORE TAKING ANY +C INTEGRATION STEPS. SEE WRITTEN MESSAGE FOR DETAILS. +C NOTE.. IF THE SOLVER DETECTS AN INFINITE LOOP OF CALLS +C TO THE SOLVER WITH ILLEGAL INPUT, IT WILL CAUSE +C THE RUN TO STOP. +C -4 MEANS THERE WERE REPEATED ERROR TEST FAILURES ON +C ONE ATTEMPTED STEP, BEFORE COMPLETING THE REQUESTED +C TASK, BUT THE INTEGRATION WAS SUCCESSFUL AS FAR AS T. +C THE PROBLEM MAY HAVE A SINGULARITY, OR THE INPUT +C MAY BE INAPPROPRIATE. +C -5 MEANS THERE WERE REPEATED CONVERGENCE TEST FAILURES ON +C ONE ATTEMPTED STEP, BEFORE COMPLETING THE REQUESTED +C TASK, BUT THE INTEGRATION WAS SUCCESSFUL AS FAR AS T. +C THIS MAY BE CAUSED BY AN INACCURATE JACOBIAN MATRIX, +C IF ONE IS BEING USED. +C -6 MEANS EWT(I) BECAME ZERO FOR SOME I DURING THE +C INTEGRATION. PURE RELATIVE ERROR CONTROL (ATOL(I)=0.0) +C WAS REQUESTED ON A VARIABLE WHICH HAS NOW VANISHED. +C THE INTEGRATION WAS SUCCESSFUL AS FAR AS T. +C +C NOTE.. SINCE THE NORMAL OUTPUT VALUE OF ISTATE IS 2, +C IT DOES NOT NEED TO BE RESET FOR NORMAL CONTINUATION. +C ALSO, SINCE A NEGATIVE INPUT VALUE OF ISTATE WILL BE +C REGARDED AS ILLEGAL, A NEGATIVE OUTPUT VALUE REQUIRES THE +C USER TO CHANGE IT, AND POSSIBLY OTHER INPUTS, BEFORE +C CALLING THE SOLVER AGAIN. +C +C IOPT = AN INTEGER FLAG TO SPECIFY WHETHER OR NOT ANY OPTIONAL +C INPUTS ARE BEING USED ON THIS CALL. INPUT ONLY. +C THE OPTIONAL INPUTS ARE LISTED SEPARATELY BELOW. +C IOPT = 0 MEANS NO OPTIONAL INPUTS ARE BEING USED. +C DEFAULT VALUES WILL BE USED IN ALL CASES. +C IOPT = 1 MEANS ONE OR MORE OPTIONAL INPUTS ARE BEING USED. +C +C RWORK = A REAL WORKING ARRAY (DOUBLE PRECISION). +C THE LENGTH OF RWORK MUST BE AT LEAST +C 20 + NYH*(MAXORD + 1) + 3*NEQ + LWM WHERE +C NYH = THE INITIAL VALUE OF NEQ, +C MAXORD = 12 (IF METH = 1) OR 5 (IF METH = 2) (UNLESS A +C SMALLER VALUE IS GIVEN AS AN OPTIONAL INPUT), +C LWM = 0 IF MITER = 0, +C LWM = NEQ**2 + 2 IF MITER IS 1 OR 2, +C LWM = NEQ + 2 IF MITER = 3, AND +C LWM = (2*ML+MU+1)*NEQ + 2 IF MITER IS 4 OR 5. +C (SEE THE MF DESCRIPTION FOR METH AND MITER.) +C THUS IF MAXORD HAS ITS DEFAULT VALUE AND NEQ IS CONSTANT, +C THIS LENGTH IS.. +C 20 + 16*NEQ FOR MF = 10, +C 22 + 16*NEQ + NEQ**2 FOR MF = 11 OR 12, +C 22 + 17*NEQ FOR MF = 13, +C 22 + 17*NEQ + (2*ML+MU)*NEQ FOR MF = 14 OR 15, +C 20 + 9*NEQ FOR MF = 20, +C 22 + 9*NEQ + NEQ**2 FOR MF = 21 OR 22, +C 22 + 10*NEQ FOR MF = 23, +C 22 + 10*NEQ + (2*ML+MU)*NEQ FOR MF = 24 OR 25. +C THE FIRST 20 WORDS OF RWORK ARE RESERVED FOR CONDITIONAL +C AND OPTIONAL INPUTS AND OPTIONAL OUTPUTS. +C +C THE FOLLOWING WORD IN RWORK IS A CONDITIONAL INPUT.. +C RWORK(1) = TCRIT = CRITICAL VALUE OF T WHICH THE SOLVER +C IS NOT TO OVERSHOOT. REQUIRED IF ITASK IS +C 4 OR 5, AND IGNORED OTHERWISE. (SEE ITASK.) +C +C LRW = THE LENGTH OF THE ARRAY RWORK, AS DECLARED BY THE USER. +C (THIS WILL BE CHECKED BY THE SOLVER.) +C +C IWORK = AN INTEGER WORK ARRAY. THE LENGTH OF IWORK MUST BE AT LEAST +C 20 IF MITER = 0 OR 3 (MF = 10, 13, 20, 23), OR +C 20 + NEQ OTHERWISE (MF = 11, 12, 14, 15, 21, 22, 24, 25). +C THE FIRST FEW WORDS OF IWORK ARE USED FOR CONDITIONAL AND +C OPTIONAL INPUTS AND OPTIONAL OUTPUTS. +C +C THE FOLLOWING 2 WORDS IN IWORK ARE CONDITIONAL INPUTS.. +C IWORK(1) = ML THESE ARE THE LOWER AND UPPER +C IWORK(2) = MU HALF-BANDWIDTHS, RESPECTIVELY, OF THE +C BANDED JACOBIAN, EXCLUDING THE MAIN DIAGONAL. +C THE BAND IS DEFINED BY THE MATRIX LOCATIONS +C (I,J) WITH I-ML .LE. J .LE. I+MU. ML AND MU +C MUST SATISFY 0 .LE. ML,MU .LE. NEQ-1. +C THESE ARE REQUIRED IF MITER IS 4 OR 5, AND +C IGNORED OTHERWISE. ML AND MU MAY IN FACT BE +C THE BAND PARAMETERS FOR A MATRIX TO WHICH +C DF/DY IS ONLY APPROXIMATELY EQUAL. +C +C LIW = THE LENGTH OF THE ARRAY IWORK, AS DECLARED BY THE USER. +C (THIS WILL BE CHECKED BY THE SOLVER.) +C +C NOTE.. THE WORK ARRAYS MUST NOT BE ALTERED BETWEEN CALLS TO LSODE +C FOR THE SAME PROBLEM, EXCEPT POSSIBLY FOR THE CONDITIONAL AND +C OPTIONAL INPUTS, AND EXCEPT FOR THE LAST 3*NEQ WORDS OF RWORK. +C THE LATTER SPACE IS USED FOR INTERNAL SCRATCH SPACE, AND SO IS +C AVAILABLE FOR USE BY THE USER OUTSIDE LSODE BETWEEN CALLS, IF +C DESIRED (BUT NOT FOR USE BY F OR JAC). +C +C JAC = THE NAME OF THE USER-SUPPLIED ROUTINE (MITER = 1 OR 4) TO +C COMPUTE THE JACOBIAN MATRIX, DF/DY, AS A FUNCTION OF +C THE SCALAR T AND THE VECTOR Y. IT IS TO HAVE THE FORM +C SUBROUTINE JAC (NEQ, T, Y, ML, MU, PD, NROWPD) +C DIMENSION Y(1), PD(NROWPD,1) +C WHERE NEQ, T, Y, ML, MU, AND NROWPD ARE INPUT AND THE ARRAY +C PD IS TO BE LOADED WITH PARTIAL DERIVATIVES (ELEMENTS OF +C THE JACOBIAN MATRIX) ON OUTPUT. PD MUST BE GIVEN A FIRST +C DIMENSION OF NROWPD. T AND Y HAVE THE SAME MEANING AS IN +C SUBROUTINE F. (IN THE DIMENSION STATEMENT ABOVE, 1 IS A +C DUMMY DIMENSION.. IT CAN BE REPLACED BY ANY VALUE.) +C IN THE FULL MATRIX CASE (MITER = 1), ML AND MU ARE +C IGNORED, AND THE JACOBIAN IS TO BE LOADED INTO PD IN +C COLUMNWISE MANNER, WITH DF(I)/DY(J) LOADED INTO PD(I,J). +C IN THE BAND MATRIX CASE (MITER = 4), THE ELEMENTS +C WITHIN THE BAND ARE TO BE LOADED INTO PD IN COLUMNWISE +C MANNER, WITH DIAGONAL LINES OF DF/DY LOADED INTO THE ROWS +C OF PD. THUS DF(I)/DY(J) IS TO BE LOADED INTO PD(I-J+MU+1,J). +C ML AND MU ARE THE HALF-BANDWIDTH PARAMETERS (SEE IWORK). +C THE LOCATIONS IN PD IN THE TWO TRIANGULAR AREAS WHICH +C CORRESPOND TO NONEXISTENT MATRIX ELEMENTS CAN BE IGNORED +C OR LOADED ARBITRARILY, AS THEY ARE OVERWRITTEN BY LSODE. +C JAC NEED NOT PROVIDE DF/DY EXACTLY. A CRUDE +C APPROXIMATION (POSSIBLY WITH A SMALLER BANDWIDTH) WILL DO. +C IN EITHER CASE, PD IS PRESET TO ZERO BY THE SOLVER, +C SO THAT ONLY THE NONZERO ELEMENTS NEED BE LOADED BY JAC. +C EACH CALL TO JAC IS PRECEDED BY A CALL TO F WITH THE SAME +C ARGUMENTS NEQ, T, AND Y. THUS TO GAIN SOME EFFICIENCY, +C INTERMEDIATE QUANTITIES SHARED BY BOTH CALCULATIONS MAY BE +C SAVED IN A USER COMMON BLOCK BY F AND NOT RECOMPUTED BY JAC, +C IF DESIRED. ALSO, JAC MAY ALTER THE Y ARRAY, IF DESIRED. +C JAC MUST BE DECLARED EXTERNAL IN THE CALLING PROGRAM. +C SUBROUTINE JAC MAY ACCESS USER-DEFINED QUANTITIES IN +C NEQ(2),... AND/OR IN Y(NEQ(1)+1),... IF NEQ IS AN ARRAY +C (DIMENSIONED IN JAC) AND/OR Y HAS LENGTH EXCEEDING NEQ(1). +C SEE THE DESCRIPTIONS OF NEQ AND Y ABOVE. +C +C MF = THE METHOD FLAG. USED ONLY FOR INPUT. THE LEGAL VALUES OF +C MF ARE 10, 11, 12, 13, 14, 15, 20, 21, 22, 23, 24, AND 25. +C MF HAS DECIMAL DIGITS METH AND MITER.. MF = 10*METH + MITER. +C METH INDICATES THE BASIC LINEAR MULTISTEP METHOD.. +C METH = 1 MEANS THE IMPLICIT ADAMS METHOD. +C METH = 2 MEANS THE METHOD BASED ON BACKWARD +C DIFFERENTIATION FORMULAS (BDF-S). +C MITER INDICATES THE CORRECTOR ITERATION METHOD.. +C MITER = 0 MEANS FUNCTIONAL ITERATION (NO JACOBIAN MATRIX +C IS INVOLVED). +C MITER = 1 MEANS CHORD ITERATION WITH A USER-SUPPLIED +C FULL (NEQ BY NEQ) JACOBIAN. +C MITER = 2 MEANS CHORD ITERATION WITH AN INTERNALLY +C GENERATED (DIFFERENCE QUOTIENT) FULL JACOBIAN +C (USING NEQ EXTRA CALLS TO F PER DF/DY VALUE). +C MITER = 3 MEANS CHORD ITERATION WITH AN INTERNALLY +C GENERATED DIAGONAL JACOBIAN APPROXIMATION. +C (USING 1 EXTRA CALL TO F PER DF/DY EVALUATION). +C MITER = 4 MEANS CHORD ITERATION WITH A USER-SUPPLIED +C BANDED JACOBIAN. +C MITER = 5 MEANS CHORD ITERATION WITH AN INTERNALLY +C GENERATED BANDED JACOBIAN (USING ML+MU+1 EXTRA +C CALLS TO F PER DF/DY EVALUATION). +C IF MITER = 1 OR 4, THE USER MUST SUPPLY A SUBROUTINE JAC +C (THE NAME IS ARBITRARY) AS DESCRIBED ABOVE UNDER JAC. +C FOR OTHER VALUES OF MITER, A DUMMY ARGUMENT CAN BE USED. +C----------------------------------------------------------------------- +C OPTIONAL INPUTS. +C +C THE FOLLOWING IS A LIST OF THE OPTIONAL INPUTS PROVIDED FOR IN THE +C CALL SEQUENCE. (SEE ALSO PART II.) FOR EACH SUCH INPUT VARIABLE, +C THIS TABLE LISTS ITS NAME AS USED IN THIS DOCUMENTATION, ITS +C LOCATION IN THE CALL SEQUENCE, ITS MEANING, AND THE DEFAULT VALUE. +C THE USE OF ANY OF THESE INPUTS REQUIRES IOPT = 1, AND IN THAT +C CASE ALL OF THESE INPUTS ARE EXAMINED. A VALUE OF ZERO FOR ANY +C OF THESE OPTIONAL INPUTS WILL CAUSE THE DEFAULT VALUE TO BE USED. +C THUS TO USE A SUBSET OF THE OPTIONAL INPUTS, SIMPLY PRELOAD +C LOCATIONS 5 TO 10 IN RWORK AND IWORK TO 0.0 AND 0 RESPECTIVELY, AND +C THEN SET THOSE OF INTEREST TO NONZERO VALUES. +C +C NAME LOCATION MEANING AND DEFAULT VALUE +C +C H0 RWORK(5) THE STEP SIZE TO BE ATTEMPTED ON THE FIRST STEP. +C THE DEFAULT VALUE IS DETERMINED BY THE SOLVER. +C +C HMAX RWORK(6) THE MAXIMUM ABSOLUTE STEP SIZE ALLOWED. +C THE DEFAULT VALUE IS INFINITE. +C +C HMIN RWORK(7) THE MINIMUM ABSOLUTE STEP SIZE ALLOWED. +C THE DEFAULT VALUE IS 0. (THIS LOWER BOUND IS NOT +C ENFORCED ON THE FINAL STEP BEFORE REACHING TCRIT +C WHEN ITASK = 4 OR 5.) +C +C MAXORD IWORK(5) THE MAXIMUM ORDER TO BE ALLOWED. THE DEFAULT +C VALUE IS 12 IF METH = 1, AND 5 IF METH = 2. +C IF MAXORD EXCEEDS THE DEFAULT VALUE, IT WILL +C BE REDUCED TO THE DEFAULT VALUE. +C IF MAXORD IS CHANGED DURING THE PROBLEM, IT MAY +C CAUSE THE CURRENT ORDER TO BE REDUCED. +C +C MXSTEP IWORK(6) MAXIMUM NUMBER OF (INTERNALLY DEFINED) STEPS +C ALLOWED DURING ONE CALL TO THE SOLVER. +C THE DEFAULT VALUE IS 500. +C +C MXHNIL IWORK(7) MAXIMUM NUMBER OF MESSAGES PRINTED (PER PROBLEM) +C WARNING THAT T + H = T ON A STEP (H = STEP SIZE). +C THIS MUST BE POSITIVE TO RESULT IN A NON-DEFAULT +C VALUE. THE DEFAULT VALUE IS 10. +C----------------------------------------------------------------------- +C OPTIONAL OUTPUTS. +C +C AS OPTIONAL ADDITIONAL OUTPUT FROM LSODE, THE VARIABLES LISTED +C BELOW ARE QUANTITIES RELATED TO THE PERFORMANCE OF LSODE +C WHICH ARE AVAILABLE TO THE USER. THESE ARE COMMUNICATED BY WAY OF +C THE WORK ARRAYS, BUT ALSO HAVE INTERNAL MNEMONIC NAMES AS SHOWN. +C EXCEPT WHERE STATED OTHERWISE, ALL OF THESE OUTPUTS ARE DEFINED +C ON ANY SUCCESSFUL RETURN FROM LSODE, AND ON ANY RETURN WITH +C ISTATE = -1, -2, -4, -5, OR -6. ON AN ILLEGAL INPUT RETURN +C (ISTATE = -3), THEY WILL BE UNCHANGED FROM THEIR EXISTING VALUES +C (IF ANY), EXCEPT POSSIBLY FOR TOLSF, LENRW, AND LENIW. +C ON ANY ERROR RETURN, OUTPUTS RELEVANT TO THE ERROR WILL BE DEFINED, +C AS NOTED BELOW. +C +C NAME LOCATION MEANING +C +C HU RWORK(11) THE STEP SIZE IN T LAST USED (SUCCESSFULLY). +C +C HCUR RWORK(12) THE STEP SIZE TO BE ATTEMPTED ON THE NEXT STEP. +C +C TCUR RWORK(13) THE CURRENT VALUE OF THE INDEPENDENT VARIABLE +C WHICH THE SOLVER HAS ACTUALLY REACHED, I.E. THE +C CURRENT INTERNAL MESH POINT IN T. ON OUTPUT, TCUR +C WILL ALWAYS BE AT LEAST AS FAR AS THE ARGUMENT +C T, BUT MAY BE FARTHER (IF INTERPOLATION WAS DONE). +C +C TOLSF RWORK(14) A TOLERANCE SCALE FACTOR, GREATER THAN 1.0, +C COMPUTED WHEN A REQUEST FOR TOO MUCH ACCURACY WAS +C DETECTED (ISTATE = -3 IF DETECTED AT THE START OF +C THE PROBLEM, ISTATE = -2 OTHERWISE). IF ITOL IS +C LEFT UNALTERED BUT RTOL AND ATOL ARE UNIFORMLY +C SCALED UP BY A FACTOR OF TOLSF FOR THE NEXT CALL, +C THEN THE SOLVER IS DEEMED LIKELY TO SUCCEED. +C (THE USER MAY ALSO IGNORE TOLSF AND ALTER THE +C TOLERANCE PARAMETERS IN ANY OTHER WAY APPROPRIATE.) +C +C NST IWORK(11) THE NUMBER OF STEPS TAKEN FOR THE PROBLEM SO FAR. +C +C NFE IWORK(12) THE NUMBER OF F EVALUATIONS FOR THE PROBLEM SO FAR. +C +C NJE IWORK(13) THE NUMBER OF JACOBIAN EVALUATIONS (AND OF MATRIX +C LU DECOMPOSITIONS) FOR THE PROBLEM SO FAR. +C +C NQU IWORK(14) THE METHOD ORDER LAST USED (SUCCESSFULLY). +C +C NQCUR IWORK(15) THE ORDER TO BE ATTEMPTED ON THE NEXT STEP. +C +C IMXER IWORK(16) THE INDEX OF THE COMPONENT OF LARGEST MAGNITUDE IN +C THE WEIGHTED LOCAL ERROR VECTOR ( E(I)/EWT(I) ), +C ON AN ERROR RETURN WITH ISTATE = -4 OR -5. +C +C LENRW IWORK(17) THE LENGTH OF RWORK ACTUALLY REQUIRED. +C THIS IS DEFINED ON NORMAL RETURNS AND ON AN ILLEGAL +C INPUT RETURN FOR INSUFFICIENT STORAGE. +C +C LENIW IWORK(18) THE LENGTH OF IWORK ACTUALLY REQUIRED. +C THIS IS DEFINED ON NORMAL RETURNS AND ON AN ILLEGAL +C INPUT RETURN FOR INSUFFICIENT STORAGE. +C +C THE FOLLOWING TWO ARRAYS ARE SEGMENTS OF THE RWORK ARRAY WHICH +C MAY ALSO BE OF INTEREST TO THE USER AS OPTIONAL OUTPUTS. +C FOR EACH ARRAY, THE TABLE BELOW GIVES ITS INTERNAL NAME, +C ITS BASE ADDRESS IN RWORK, AND ITS DESCRIPTION. +C +C NAME BASE ADDRESS DESCRIPTION +C +C YH 21 THE NORDSIECK HISTORY ARRAY, OF SIZE NYH BY +C (NQCUR + 1), WHERE NYH IS THE INITIAL VALUE +C OF NEQ. FOR J = 0,1,...,NQCUR, COLUMN J+1 +C OF YH CONTAINS HCUR**J/FACTORIAL(J) TIMES +C THE J-TH DERIVATIVE OF THE INTERPOLATING +C POLYNOMIAL CURRENTLY REPRESENTING THE SOLUTION, +C EVALUATED AT T = TCUR. +C +C ACOR LENRW-NEQ+1 ARRAY OF SIZE NEQ USED FOR THE ACCUMULATED +C CORRECTIONS ON EACH STEP, SCALED ON OUTPUT +C TO REPRESENT THE ESTIMATED LOCAL ERROR IN Y +C ON THE LAST STEP. THIS IS THE VECTOR E IN +C THE DESCRIPTION OF THE ERROR CONTROL. IT IS +C DEFINED ONLY ON A SUCCESSFUL RETURN FROM LSODE. +C +C----------------------------------------------------------------------- +C PART II. OTHER ROUTINES CALLABLE. +C +C THE FOLLOWING ARE OPTIONAL CALLS WHICH THE USER MAY MAKE TO +C GAIN ADDITIONAL CAPABILITIES IN CONJUNCTION WITH LSODE. +C (THE ROUTINES XSETUN AND XSETF ARE DESIGNED TO CONFORM TO THE +C SLATEC ERROR HANDLING PACKAGE.) +C +C FORM OF CALL FUNCTION +C CALL XSETUN(LUN) SET THE LOGICAL UNIT NUMBER, LUN, FOR +C OUTPUT OF MESSAGES FROM LSODE, IF +C THE DEFAULT IS NOT DESIRED. +C THE DEFAULT VALUE OF LUN IS 6. +C +C CALL XSETF(MFLAG) SET A FLAG TO CONTROL THE PRINTING OF +C MESSAGES BY LSODE. +C MFLAG = 0 MEANS DO NOT PRINT. (DANGER.. +C THIS RISKS LOSING VALUABLE INFORMATION.) +C MFLAG = 1 MEANS PRINT (THE DEFAULT). +C +C EITHER OF THE ABOVE CALLS MAY BE MADE AT +C ANY TIME AND WILL TAKE EFFECT IMMEDIATELY. +C +C CALL SRCOM(RSAV,ISAV,JOB) SAVES AND RESTORES THE CONTENTS OF +C THE INTERNAL COMMON BLOCKS USED BY +C LSODE (SEE PART III BELOW). +C RSAV MUST BE A REAL ARRAY OF LENGTH 218 +C OR MORE, AND ISAV MUST BE AN INTEGER +C ARRAY OF LENGTH 41 OR MORE. +C JOB=1 MEANS SAVE COMMON INTO RSAV/ISAV. +C JOB=2 MEANS RESTORE COMMON FROM RSAV/ISAV. +C SRCOM IS USEFUL IF ONE IS +C INTERRUPTING A RUN AND RESTARTING +C LATER, OR ALTERNATING BETWEEN TWO OR +C MORE PROBLEMS SOLVED WITH LSODE. +C +C CALL INTDY(,,,,,) PROVIDE DERIVATIVES OF Y, OF VARIOUS +C (SEE BELOW) ORDERS, AT A SPECIFIED POINT T, IF +C DESIRED. IT MAY BE CALLED ONLY AFTER +C A SUCCESSFUL RETURN FROM LSODE. +C +C THE DETAILED INSTRUCTIONS FOR USING INTDY ARE AS FOLLOWS. +C THE FORM OF THE CALL IS.. +C +C CALL INTDY (T, K, RWORK(21), NYH, DKY, IFLAG) +C +C THE INPUT PARAMETERS ARE.. +C +C T = VALUE OF INDEPENDENT VARIABLE WHERE ANSWERS ARE DESIRED +C (NORMALLY THE SAME AS THE T LAST RETURNED BY LSODE). +C FOR VALID RESULTS, T MUST LIE BETWEEN TCUR - HU AND TCUR. +C (SEE OPTIONAL OUTPUTS FOR TCUR AND HU.) +C K = INTEGER ORDER OF THE DERIVATIVE DESIRED. K MUST SATISFY +C 0 .LE. K .LE. NQCUR, WHERE NQCUR IS THE CURRENT ORDER +C (SEE OPTIONAL OUTPUTS). THE CAPABILITY CORRESPONDING +C TO K = 0, I.E. COMPUTING Y(T), IS ALREADY PROVIDED +C BY LSODE DIRECTLY. SINCE NQCUR .GE. 1, THE FIRST +C DERIVATIVE DY/DT IS ALWAYS AVAILABLE WITH INTDY. +C RWORK(21) = THE BASE ADDRESS OF THE HISTORY ARRAY YH. +C NYH = COLUMN LENGTH OF YH, EQUAL TO THE INITIAL VALUE OF NEQ. +C +C THE OUTPUT PARAMETERS ARE.. +C +C DKY = A REAL ARRAY OF LENGTH NEQ CONTAINING THE COMPUTED VALUE +C OF THE K-TH DERIVATIVE OF Y(T). +C IFLAG = INTEGER FLAG, RETURNED AS 0 IF K AND T WERE LEGAL, +C -1 IF K WAS ILLEGAL, AND -2 IF T WAS ILLEGAL. +C ON AN ERROR RETURN, A MESSAGE IS ALSO WRITTEN. +C----------------------------------------------------------------------- +C PART III. COMMON BLOCKS. +C +C IF LSODE IS TO BE USED IN AN OVERLAY SITUATION, THE USER +C MUST DECLARE, IN THE PRIMARY OVERLAY, THE VARIABLES IN.. +C (1) THE CALL SEQUENCE TO LSODE, +C (2) THE INTERNAL COMMON BLOCK +C /LS0001/ OF LENGTH 257 (218 DOUBLE PRECISION WORDS +C FOLLOWED BY 39 INTEGER WORDS), +C +C IF LSODE IS USED ON A SYSTEM IN WHICH THE CONTENTS OF INTERNAL +C COMMON BLOCKS ARE NOT PRESERVED BETWEEN CALLS, THE USER SHOULD +C DECLARE THE ABOVE TWO COMMON BLOCKS IN HIS MAIN PROGRAM TO INSURE +C THAT THEIR CONTENTS ARE PRESERVED. +C +C IF THE SOLUTION OF A GIVEN PROBLEM BY LSODE IS TO BE INTERRUPTED +C AND THEN LATER CONTINUED, SUCH AS WHEN RESTARTING AN INTERRUPTED RUN +C OR ALTERNATING BETWEEN TWO OR MORE PROBLEMS, THE USER SHOULD SAVE, +C FOLLOWING THE RETURN FROM THE LAST LSODE CALL PRIOR TO THE +C INTERRUPTION, THE CONTENTS OF THE CALL SEQUENCE VARIABLES AND THE +C INTERNAL COMMON BLOCKS, AND LATER RESTORE THESE VALUES BEFORE THE +C NEXT LSODE CALL FOR THAT PROBLEM. TO SAVE AND RESTORE THE COMMON +C BLOCKS, USE SUBROUTINE SRCOM (SEE PART II ABOVE). +C +C----------------------------------------------------------------------- +C PART IV. OPTIONALLY REPLACEABLE SOLVER ROUTINES. +C +C BELOW ARE DESCRIPTIONS OF TWO ROUTINES IN THE LSODE PACKAGE WHICH +C RELATE TO THE MEASUREMENT OF ERRORS. EITHER ROUTINE CAN BE +C REPLACED BY A USER-SUPPLIED VERSION, IF DESIRED. HOWEVER, SINCE SUCH +C A REPLACEMENT MAY HAVE A MAJOR IMPACT ON PERFORMANCE, IT SHOULD BE +C DONE ONLY WHEN ABSOLUTELY NECESSARY, AND ONLY WITH GREAT CAUTION. +C (NOTE.. THE MEANS BY WHICH THE PACKAGE VERSION OF A ROUTINE IS +C SUPERSEDED BY THE USER-S VERSION MAY BE SYSTEM-DEPENDENT.) +C +C (A) EWSET. +C THE FOLLOWING SUBROUTINE IS CALLED JUST BEFORE EACH INTERNAL +C INTEGRATION STEP, AND SETS THE ARRAY OF ERROR WEIGHTS, EWT, AS +C DESCRIBED UNDER ITOL/RTOL/ATOL ABOVE.. +C SUBROUTINE EWSET (NEQ, ITOL, RTOL, ATOL, YCUR, EWT) +C WHERE NEQ, ITOL, RTOL, AND ATOL ARE AS IN THE LSODE CALL SEQUENCE, +C YCUR CONTAINS THE CURRENT DEPENDENT VARIABLE VECTOR, AND +C EWT IS THE ARRAY OF WEIGHTS SET BY EWSET. +C +C IF THE USER SUPPLIES THIS SUBROUTINE, IT MUST RETURN IN EWT(I) +C (I = 1,...,NEQ) A POSITIVE QUANTITY SUITABLE FOR COMPARING ERRORS +C IN Y(I) TO. THE EWT ARRAY RETURNED BY EWSET IS PASSED TO THE +C VNORM ROUTINE (SEE BELOW), AND ALSO USED BY LSODE IN THE COMPUTATION +C OF THE OPTIONAL OUTPUT IMXER, THE DIAGONAL JACOBIAN APPROXIMATION, +C AND THE INCREMENTS FOR DIFFERENCE QUOTIENT JACOBIANS. +C +C IN THE USER-SUPPLIED VERSION OF EWSET, IT MAY BE DESIRABLE TO USE +C THE CURRENT VALUES OF DERIVATIVES OF Y. DERIVATIVES UP TO ORDER NQ +C ARE AVAILABLE FROM THE HISTORY ARRAY YH, DESCRIBED ABOVE UNDER +C OPTIONAL OUTPUTS. IN EWSET, YH IS IDENTICAL TO THE YCUR ARRAY, +C EXTENDED TO NQ + 1 COLUMNS WITH A COLUMN LENGTH OF NYH AND SCALE +C FACTORS OF H**J/FACTORIAL(J). ON THE FIRST CALL FOR THE PROBLEM, +C GIVEN BY NST = 0, NQ IS 1 AND H IS TEMPORARILY SET TO 1.0. +C THE QUANTITIES NQ, NYH, H, AND NST CAN BE OBTAINED BY INCLUDING +C IN EWSET THE STATEMENTS.. +C DOUBLE PRECISION H, RLS +C COMMON /LS0001/ RLS(218),ILS(39) +C NQ = ILS(35) +C NYH = ILS(14) +C NST = ILS(36) +C H = RLS(212) +C THUS, FOR EXAMPLE, THE CURRENT VALUE OF DY/DT CAN BE OBTAINED AS +C YCUR(NYH+I)/H (I=1,...,NEQ) (AND THE DIVISION BY H IS +C UNNECESSARY WHEN NST = 0). +C +C (B) VNORM. +C THE FOLLOWING IS A REAL FUNCTION ROUTINE WHICH COMPUTES THE WEIGHTED +C ROOT-MEAN-SQUARE NORM OF A VECTOR V.. +C D = VNORM (N, V, W) +C WHERE.. +C N = THE LENGTH OF THE VECTOR, +C V = REAL ARRAY OF LENGTH N CONTAINING THE VECTOR, +C W = REAL ARRAY OF LENGTH N CONTAINING WEIGHTS, +C D = SQRT( (1/N) * SUM(V(I)*W(I))**2 ). +C VNORM IS CALLED WITH N = NEQ AND WITH W(I) = 1.0/EWT(I), WHERE +C EWT IS AS SET BY SUBROUTINE EWSET. +C +C IF THE USER SUPPLIES THIS FUNCTION, IT SHOULD RETURN A NON-NEGATIVE +C VALUE OF VNORM SUITABLE FOR USE IN THE ERROR CONTROL IN LSODE. +C NONE OF THE ARGUMENTS SHOULD BE ALTERED BY VNORM. +C FOR EXAMPLE, A USER-SUPPLIED VNORM ROUTINE MIGHT.. +C -SUBSTITUTE A MAX-NORM OF (V(I)*W(I)) FOR THE RMS-NORM, OR +C -IGNORE SOME COMPONENTS OF V IN THE NORM, WITH THE EFFECT OF +C SUPPRESSING THE ERROR CONTROL ON THOSE COMPONENTS OF Y. +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- +C OTHER ROUTINES IN THE LSODE PACKAGE. +C +C IN ADDITION TO SUBROUTINE LSODE, THE LSODE PACKAGE INCLUDES THE +C FOLLOWING SUBROUTINES AND FUNCTION ROUTINES.. +C INTDY COMPUTES AN INTERPOLATED VALUE OF THE Y VECTOR AT T = TOUT. +C STODE IS THE CORE INTEGRATOR, WHICH DOES ONE STEP OF THE +C INTEGRATION AND THE ASSOCIATED ERROR CONTROL. +C CFODE SETS ALL METHOD COEFFICIENTS AND TEST CONSTANTS. +C PREPJ COMPUTES AND PREPROCESSES THE JACOBIAN MATRIX J = DF/DY +C AND THE NEWTON ITERATION MATRIX P = I - H*L0*J. +C SOLSY MANAGES SOLUTION OF LINEAR SYSTEM IN CHORD ITERATION. +C EWSET SETS THE ERROR WEIGHT VECTOR EWT BEFORE EACH STEP. +C VNORM COMPUTES THE WEIGHTED R.M.S. NORM OF A VECTOR. +C SRCOM IS A USER-CALLABLE ROUTINE TO SAVE AND RESTORE +C THE CONTENTS OF THE INTERNAL COMMON BLOCKS. +C DGETRF AND DGETRS ARE ROUTINES FROM LAPACK FOR SOLVING FULL +C SYSTEMS OF LINEAR ALGEBRAIC EQUATIONS. +C DGBTRF AND DGBTRS ARE ROUTINES FROM LAPACK FOR SOLVING BANDED +C LINEAR SYSTEMS. +C DAXPY, DSCAL, IDAMAX, AND DDOT ARE BASIC LINEAR ALGEBRA MODULES +C (BLAS) USED BY THE ABOVE LINPACK ROUTINES. +C D1MACH COMPUTES THE UNIT ROUNDOFF IN A MACHINE-INDEPENDENT MANNER. +C XERRWD, XSETUN, AND XSETF HANDLE THE PRINTING OF ALL ERROR +C MESSAGES AND WARNINGS. XERRWD IS MACHINE-DEPENDENT. +C NOTE.. VNORM, IDAMAX, DDOT, AND D1MACH ARE FUNCTION ROUTINES. +C ALL THE OTHERS ARE SUBROUTINES. +C +C THE INTRINSIC AND EXTERNAL ROUTINES USED BY LSODE ARE.. +C DABS, DMAX1, DMIN1, DBLE, MAX0, MIN0, MOD, DSIGN, DSQRT, AND WRITE. +C +C A BLOCK DATA SUBPROGRAM IS ALSO INCLUDED WITH THE PACKAGE, +C FOR LOADING SOME OF THE VARIABLES IN INTERNAL COMMON. +C +C----------------------------------------------------------------------- +C THE FOLLOWING CARD IS FOR OPTIMIZED COMPILATION ON LLNL COMPILERS. +CLLL. OPTIMIZE +C----------------------------------------------------------------------- + EXTERNAL PREPJ, SOLSY + INTEGER ILLIN, INIT, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, + 1 MXSTEP, MXHNIL, NHNIL, NTREP, NSLAST, NYH, + 2 IALTH, IPUP, LMAX, MEO, NQNYH, NSLP + INTEGER ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, METH, MITER, + 1 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU + INTEGER I, I1, I2, IFLAG, IMXER, KGO, LF0, + 1 LENIW, LENRW, LENWM, ML, MORD, MU, MXHNL0, MXSTP0 + DOUBLE PRECISION CONIT, CRATE, EL, ELCO, HOLD, RMAX, TESCO, + 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND + DOUBLE PRECISION ATOLI, AYI, BIG, EWTI, H0, HMAX, HMX, RH, RTOLI, + 1 TCRIT, TDIST, TNEXT, TOL, TOLSF, TP, SIZE, SUM, W0, + 2 D1MACH, VNORM + DIMENSION MORD(2) + LOGICAL IHIT +C----------------------------------------------------------------------- +C THE FOLLOWING INTERNAL COMMON BLOCK CONTAINS +C (A) VARIABLES WHICH ARE LOCAL TO ANY SUBROUTINE BUT WHOSE VALUES MUST +C BE PRESERVED BETWEEN CALLS TO THE ROUTINE (OWN VARIABLES), AND +C (B) VARIABLES WHICH ARE COMMUNICATED BETWEEN SUBROUTINES. +C THE STRUCTURE OF THE BLOCK IS AS FOLLOWS.. ALL REAL VARIABLES ARE +C LISTED FIRST, FOLLOWED BY ALL INTEGERS. WITHIN EACH TYPE, THE +C VARIABLES ARE GROUPED WITH THOSE LOCAL TO SUBROUTINE LSODE FIRST, +C THEN THOSE LOCAL TO SUBROUTINE STODE, AND FINALLY THOSE USED +C FOR COMMUNICATION. THE BLOCK IS DECLARED IN SUBROUTINES +C LSODE, INTDY, STODE, PREPJ, AND SOLSY. GROUPS OF VARIABLES ARE +C REPLACED BY DUMMY ARRAYS IN THE COMMON DECLARATIONS IN ROUTINES +C WHERE THOSE VARIABLES ARE NOT USED. +C----------------------------------------------------------------------- + COMMON /LS0001/ CONIT, CRATE, EL(13), ELCO(13,12), + 1 HOLD, RMAX, TESCO(3,12), + 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, + 2 ILLIN, INIT, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, + 3 MXSTEP, MXHNIL, NHNIL, NTREP, NSLAST, NYH, + 3 IALTH, IPUP, LMAX, MEO, NQNYH, NSLP, + 4 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, METH, MITER, + 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU +C + DATA MORD(1),MORD(2)/12,5/, MXSTP0/500/, MXHNL0/10/ +C----------------------------------------------------------------------- +C BLOCK A. +C THIS CODE BLOCK IS EXECUTED ON EVERY CALL. +C IT TESTS ISTATE AND ITASK FOR LEGALITY AND BRANCHES APPROPRIATELY. +C IF ISTATE .GT. 1 BUT THE FLAG INIT SHOWS THAT INITIALIZATION HAS +C NOT YET BEEN DONE, AN ERROR RETURN OCCURS. +C IF ISTATE = 1 AND TOUT = T, JUMP TO BLOCK G AND RETURN IMMEDIATELY. +C----------------------------------------------------------------------- + IF (ISTATE .LT. 1 .OR. ISTATE .GT. 3) GO TO 601 + IF (ITASK .LT. 1 .OR. ITASK .GT. 5) GO TO 602 + IF (ISTATE .EQ. 1) GO TO 10 + IF (INIT .EQ. 0) GO TO 603 + IF (ISTATE .EQ. 2) GO TO 200 + GO TO 20 + 10 INIT = 0 + IF (TOUT .EQ. T) GO TO 430 + 20 NTREP = 0 +C----------------------------------------------------------------------- +C BLOCK B. +C THE NEXT CODE BLOCK IS EXECUTED FOR THE INITIAL CALL (ISTATE = 1), +C OR FOR A CONTINUATION CALL WITH PARAMETER CHANGES (ISTATE = 3). +C IT CONTAINS CHECKING OF ALL INPUTS AND VARIOUS INITIALIZATIONS. +C +C FIRST CHECK LEGALITY OF THE NON-OPTIONAL INPUTS NEQ, ITOL, IOPT, +C MF, ML, AND MU. +C----------------------------------------------------------------------- + IF (NEQ(1) .LE. 0) GO TO 604 + IF (ISTATE .EQ. 1) GO TO 25 + IF (NEQ(1) .GT. N) GO TO 605 + 25 N = NEQ(1) + IF (ITOL .LT. 1 .OR. ITOL .GT. 4) GO TO 606 + IF (IOPT .LT. 0 .OR. IOPT .GT. 1) GO TO 607 + METH = MF/10 + MITER = MF - 10*METH + IF (METH .LT. 1 .OR. METH .GT. 2) GO TO 608 + IF (MITER .LT. 0 .OR. MITER .GT. 5) GO TO 608 + IF (MITER .LE. 3) GO TO 30 + ML = IWORK(1) + MU = IWORK(2) + IF (ML .LT. 0 .OR. ML .GE. N) GO TO 609 + IF (MU .LT. 0 .OR. MU .GE. N) GO TO 610 + 30 CONTINUE +C NEXT PROCESS AND CHECK THE OPTIONAL INPUTS. -------------------------- + IF (IOPT .EQ. 1) GO TO 40 + MAXORD = MORD(METH) + MXSTEP = MXSTP0 + MXHNIL = MXHNL0 + IF (ISTATE .EQ. 1) H0 = 0.0D0 + HMXI = 0.0D0 + HMIN = 0.0D0 + GO TO 60 + 40 MAXORD = IWORK(5) + IF (MAXORD .LT. 0) GO TO 611 + IF (MAXORD .EQ. 0) MAXORD = 100 + MAXORD = MIN0(MAXORD,MORD(METH)) + MXSTEP = IWORK(6) + IF (MXSTEP .LT. 0) GO TO 612 + IF (MXSTEP .EQ. 0) MXSTEP = MXSTP0 + MXHNIL = IWORK(7) + IF (MXHNIL .LT. 0) GO TO 613 + IF (MXHNIL .EQ. 0) MXHNIL = MXHNL0 + IF (ISTATE .NE. 1) GO TO 50 + H0 = RWORK(5) + IF ((TOUT - T)*H0 .LT. 0.0D0) GO TO 614 + 50 HMAX = RWORK(6) + IF (HMAX .LT. 0.0D0) GO TO 615 + HMXI = 0.0D0 + IF (HMAX .GT. 0.0D0) HMXI = 1.0D0/HMAX + HMIN = RWORK(7) + IF (HMIN .LT. 0.0D0) GO TO 616 +C----------------------------------------------------------------------- +C SET WORK ARRAY POINTERS AND CHECK LENGTHS LRW AND LIW. +C POINTERS TO SEGMENTS OF RWORK AND IWORK ARE NAMED BY PREFIXING L TO +C THE NAME OF THE SEGMENT. E.G., THE SEGMENT YH STARTS AT RWORK(LYH). +C SEGMENTS OF RWORK (IN ORDER) ARE DENOTED YH, WM, EWT, SAVF, ACOR. +C----------------------------------------------------------------------- + 60 LYH = 21 + IF (ISTATE .EQ. 1) NYH = N + LWM = LYH + (MAXORD + 1)*NYH + IF (MITER .EQ. 0) LENWM = 0 + IF (MITER .EQ. 1 .OR. MITER .EQ. 2) LENWM = N*N + 2 + IF (MITER .EQ. 3) LENWM = N + 2 + IF (MITER .GE. 4) LENWM = (2*ML + MU + 1)*N + 2 + LEWT = LWM + LENWM + LSAVF = LEWT + N + LACOR = LSAVF + N + LENRW = LACOR + N - 1 + IWORK(17) = LENRW + LIWM = 1 + LENIW = 20 + N + IF (MITER .EQ. 0 .OR. MITER .EQ. 3) LENIW = 20 + IWORK(18) = LENIW + IF (LENRW .GT. LRW) GO TO 617 + IF (LENIW .GT. LIW) GO TO 618 +C CHECK RTOL AND ATOL FOR LEGALITY. ------------------------------------ + RTOLI = RTOL(1) + ATOLI = ATOL(1) + DO 70 I = 1,N + IF (ITOL .GE. 3) RTOLI = RTOL(I) + IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) ATOLI = ATOL(I) + IF (RTOLI .LT. 0.0D0) GO TO 619 + IF (ATOLI .LT. 0.0D0) GO TO 620 + 70 CONTINUE + IF (ISTATE .EQ. 1) GO TO 100 +C IF ISTATE = 3, SET FLAG TO SIGNAL PARAMETER CHANGES TO STODE. -------- + JSTART = -1 + IF (NQ .LE. MAXORD) GO TO 90 +C MAXORD WAS REDUCED BELOW NQ. COPY YH(*,MAXORD+2) INTO SAVF. --------- + DO 80 I = 1,N + 80 RWORK(I+LSAVF-1) = RWORK(I+LWM-1) +C RELOAD WM(1) = RWORK(LWM), SINCE LWM MAY HAVE CHANGED. --------------- + 90 IF (MITER .GT. 0) RWORK(LWM) = DSQRT(UROUND) + IF (N .EQ. NYH) GO TO 200 +C NEQ WAS REDUCED. ZERO PART OF YH TO AVOID UNDEFINED REFERENCES. ----- + I1 = LYH + L*NYH + I2 = LYH + (MAXORD + 1)*NYH - 1 + IF (I1 .GT. I2) GO TO 200 + DO 95 I = I1,I2 + 95 RWORK(I) = 0.0D0 + GO TO 200 +C----------------------------------------------------------------------- +C BLOCK C. +C THE NEXT BLOCK IS FOR THE INITIAL CALL ONLY (ISTATE = 1). +C IT CONTAINS ALL REMAINING INITIALIZATIONS, THE INITIAL CALL TO F, +C AND THE CALCULATION OF THE INITIAL STEP SIZE. +C THE ERROR WEIGHTS IN EWT ARE INVERTED AFTER BEING LOADED. +C----------------------------------------------------------------------- + 100 UROUND = D1MACH(4) + TN = T + IF (ITASK .NE. 4 .AND. ITASK .NE. 5) GO TO 110 + TCRIT = RWORK(1) + IF ((TCRIT - TOUT)*(TOUT - T) .LT. 0.0D0) GO TO 625 + IF (H0 .NE. 0.0D0 .AND. (T + H0 - TCRIT)*H0 .GT. 0.0D0) + 1 H0 = TCRIT - T + 110 JSTART = 0 + IF (MITER .GT. 0) RWORK(LWM) = DSQRT(UROUND) + NHNIL = 0 + NST = 0 + NJE = 0 + NSLAST = 0 + HU = 0.0D0 + NQU = 0 + CCMAX = 0.3D0 + MAXCOR = 3 + MSBP = 20 + MXNCF = 10 +C INITIAL CALL TO F. (LF0 POINTS TO YH(*,2).) ------------------------- + LF0 = LYH + NYH + IERR = 0 + CALL F (NEQ, T, Y, RWORK(LF0), IERR) + IF (IERR .LT. 0) THEN + ISTATE = -13 + RETURN + ENDIF + NFE = 1 +C LOAD THE INITIAL VALUE VECTOR IN YH. --------------------------------- + DO 115 I = 1,N + 115 RWORK(I+LYH-1) = Y(I) +C LOAD AND INVERT THE EWT ARRAY. (H IS TEMPORARILY SET TO 1.0.) ------- + NQ = 1 + H = 1.0D0 + CALL EWSET (N, ITOL, RTOL, ATOL, RWORK(LYH), RWORK(LEWT)) + DO 120 I = 1,N + IF (RWORK(I+LEWT-1) .LE. 0.0D0) GO TO 621 + 120 RWORK(I+LEWT-1) = 1.0D0/RWORK(I+LEWT-1) +C----------------------------------------------------------------------- +C THE CODING BELOW COMPUTES THE STEP SIZE, H0, TO BE ATTEMPTED ON THE +C FIRST STEP, UNLESS THE USER HAS SUPPLIED A VALUE FOR THIS. +C FIRST CHECK THAT TOUT - T DIFFERS SIGNIFICANTLY FROM ZERO. +C A SCALAR TOLERANCE QUANTITY TOL IS COMPUTED, AS MAX(RTOL(I)) +C IF THIS IS POSITIVE, OR MAX(ATOL(I)/ABS(Y(I))) OTHERWISE, ADJUSTED +C SO AS TO BE BETWEEN 100*UROUND AND 1.0E-3. +C THEN THE COMPUTED VALUE H0 IS GIVEN BY.. +C NEQ +C H0**2 = TOL / ( W0**-2 + (1/NEQ) * SUM ( F(I)/YWT(I) )**2 ) +C 1 +C WHERE W0 = MAX ( ABS(T), ABS(TOUT) ), +C F(I) = I-TH COMPONENT OF INITIAL VALUE OF F, +C YWT(I) = EWT(I)/TOL (A WEIGHT FOR Y(I)). +C THE SIGN OF H0 IS INFERRED FROM THE INITIAL VALUES OF TOUT AND T. +C----------------------------------------------------------------------- + IF (H0 .NE. 0.0D0) GO TO 180 + TDIST = DABS(TOUT - T) + W0 = DMAX1(DABS(T),DABS(TOUT)) + IF (TDIST .LT. 2.0D0*UROUND*W0) GO TO 622 + TOL = RTOL(1) + IF (ITOL .LE. 2) GO TO 140 + DO 130 I = 1,N + 130 TOL = DMAX1(TOL,RTOL(I)) + 140 IF (TOL .GT. 0.0D0) GO TO 160 + ATOLI = ATOL(1) + DO 150 I = 1,N + IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) ATOLI = ATOL(I) + AYI = DABS(Y(I)) + IF (AYI .NE. 0.0D0) TOL = DMAX1(TOL,ATOLI/AYI) + 150 CONTINUE + 160 TOL = DMAX1(TOL,100.0D0*UROUND) + TOL = DMIN1(TOL,0.001D0) + SUM = VNORM (N, RWORK(LF0), RWORK(LEWT)) + SUM = 1.0D0/(TOL*W0*W0) + TOL*SUM**2 + H0 = 1.0D0/DSQRT(SUM) + H0 = DMIN1(H0,TDIST) + H0 = DSIGN(H0,TOUT-T) +C ADJUST H0 IF NECESSARY TO MEET HMAX BOUND. --------------------------- + 180 RH = DABS(H0)*HMXI + IF (RH .GT. 1.0D0) H0 = H0/RH +C LOAD H WITH H0 AND SCALE YH(*,2) BY H0. ------------------------------ + H = H0 + DO 190 I = 1,N + 190 RWORK(I+LF0-1) = H0*RWORK(I+LF0-1) + GO TO 270 +C----------------------------------------------------------------------- +C BLOCK D. +C THE NEXT CODE BLOCK IS FOR CONTINUATION CALLS ONLY (ISTATE = 2 OR 3) +C AND IS TO CHECK STOP CONDITIONS BEFORE TAKING A STEP. +C----------------------------------------------------------------------- + 200 NSLAST = NST + GO TO (210, 250, 220, 230, 240), ITASK + 210 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 250 + CALL INTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) + IF (IFLAG .NE. 0) GO TO 627 + T = TOUT + GO TO 420 + 220 TP = TN - HU*(1.0D0 + 100.0D0*UROUND) + IF ((TP - TOUT)*H .GT. 0.0D0) GO TO 623 + IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 250 + GO TO 400 + 230 TCRIT = RWORK(1) + IF ((TN - TCRIT)*H .GT. 0.0D0) GO TO 624 + IF ((TCRIT - TOUT)*H .LT. 0.0D0) GO TO 625 + IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 245 + CALL INTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) + IF (IFLAG .NE. 0) GO TO 627 + T = TOUT + GO TO 420 + 240 TCRIT = RWORK(1) + IF ((TN - TCRIT)*H .GT. 0.0D0) GO TO 624 + 245 HMX = DABS(TN) + DABS(H) + IHIT = DABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX + IF (IHIT) GO TO 400 + TNEXT = TN + H*(1.0D0 + 4.0D0*UROUND) + IF ((TNEXT - TCRIT)*H .LE. 0.0D0) GO TO 250 + H = (TCRIT - TN)*(1.0D0 - 4.0D0*UROUND) + IF (ISTATE .EQ. 2) JSTART = -2 +C----------------------------------------------------------------------- +C BLOCK E. +C THE NEXT BLOCK IS NORMALLY EXECUTED FOR ALL CALLS AND CONTAINS +C THE CALL TO THE ONE-STEP CORE INTEGRATOR STODE. +C +C THIS IS A LOOPING POINT FOR THE INTEGRATION STEPS. +C +C FIRST CHECK FOR TOO MANY STEPS BEING TAKEN, UPDATE EWT (IF NOT AT +C START OF PROBLEM), CHECK FOR TOO MUCH ACCURACY BEING REQUESTED, AND +C CHECK FOR H BELOW THE ROUNDOFF LEVEL IN T. +C----------------------------------------------------------------------- + 250 CONTINUE + IF ((NST-NSLAST) .GE. MXSTEP) GO TO 500 + CALL EWSET (N, ITOL, RTOL, ATOL, RWORK(LYH), RWORK(LEWT)) + DO 260 I = 1,N + IF (RWORK(I+LEWT-1) .LE. 0.0D0) GO TO 510 + 260 RWORK(I+LEWT-1) = 1.0D0/RWORK(I+LEWT-1) + 270 TOLSF = UROUND*VNORM (N, RWORK(LYH), RWORK(LEWT)) + IF (TOLSF .LE. 1.0D0) GO TO 280 + TOLSF = TOLSF*2.0D0 + IF (NST .EQ. 0) GO TO 626 + GO TO 520 + 280 IF ((TN + H) .NE. TN) GO TO 290 + NHNIL = NHNIL + 1 + IF (NHNIL .GT. MXHNIL) GO TO 290 + CALL XERRWD('LSODE-- WARNING..INTERNAL T (=R1) AND H (=R2) ARE', + 1 50, 101, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) + CALL XERRWD( + 1 ' SUCH THAT IN THE MACHINE, T + H = T ON THE NEXT STEP ', + 1 60, 101, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) + CALL XERRWD(' (H = STEP SIZE). SOLVER WILL CONTINUE ANYWAY', + 1 50, 101, 0, 0, 0, 0, 2, TN, H) + IF (NHNIL .LT. MXHNIL) GO TO 290 + CALL XERRWD('LSODE-- ABOVE WARNING HAS BEEN ISSUED I1 TIMES. ', + 1 50, 102, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) + CALL XERRWD(' IT WILL NOT BE ISSUED AGAIN FOR THIS PROBLEM', + 1 50, 102, 0, 1, MXHNIL, 0, 0, 0.0D0, 0.0D0) + 290 CONTINUE +C----------------------------------------------------------------------- +C CALL STODE(NEQ,Y,YH,NYH,YH,EWT,SAVF,ACOR,WM,IWM,F,JAC,PREPJ,SOLSY) +C----------------------------------------------------------------------- + IERR = 0 + CALL STODE (NEQ, Y, RWORK(LYH), NYH, RWORK(LYH), RWORK(LEWT), + 1 RWORK(LSAVF), RWORK(LACOR), RWORK(LWM), IWORK(LIWM), + 2 F, JAC, PREPJ, SOLSY, IERR) + IF (IERR .LT. 0) THEN + ISTATE = -13 + RETURN + ENDIF + KGO = 1 - KFLAG + GO TO (300, 530, 540), KGO +C----------------------------------------------------------------------- +C BLOCK F. +C THE FOLLOWING BLOCK HANDLES THE CASE OF A SUCCESSFUL RETURN FROM THE +C CORE INTEGRATOR (KFLAG = 0). TEST FOR STOP CONDITIONS. +C----------------------------------------------------------------------- + 300 INIT = 1 + GO TO (310, 400, 330, 340, 350), ITASK +C ITASK = 1. IF TOUT HAS BEEN REACHED, INTERPOLATE. ------------------- + 310 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 250 + CALL INTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) + T = TOUT + GO TO 420 +C ITASK = 3. JUMP TO EXIT IF TOUT WAS REACHED. ------------------------ + 330 IF ((TN - TOUT)*H .GE. 0.0D0) GO TO 400 + GO TO 250 +C ITASK = 4. SEE IF TOUT OR TCRIT WAS REACHED. ADJUST H IF NECESSARY. + 340 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 345 + CALL INTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) + T = TOUT + GO TO 420 + 345 HMX = DABS(TN) + DABS(H) + IHIT = DABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX + IF (IHIT) GO TO 400 + TNEXT = TN + H*(1.0D0 + 4.0D0*UROUND) + IF ((TNEXT - TCRIT)*H .LE. 0.0D0) GO TO 250 + H = (TCRIT - TN)*(1.0D0 - 4.0D0*UROUND) + JSTART = -2 + GO TO 250 +C ITASK = 5. SEE IF TCRIT WAS REACHED AND JUMP TO EXIT. --------------- + 350 HMX = DABS(TN) + DABS(H) + IHIT = DABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX +C----------------------------------------------------------------------- +C BLOCK G. +C THE FOLLOWING BLOCK HANDLES ALL SUCCESSFUL RETURNS FROM LSODE. +C IF ITASK .NE. 1, Y IS LOADED FROM YH AND T IS SET ACCORDINGLY. +C ISTATE IS SET TO 2, THE ILLEGAL INPUT COUNTER IS ZEROED, AND THE +C OPTIONAL OUTPUTS ARE LOADED INTO THE WORK ARRAYS BEFORE RETURNING. +C IF ISTATE = 1 AND TOUT = T, THERE IS A RETURN WITH NO ACTION TAKEN, +C EXCEPT THAT IF THIS HAS HAPPENED REPEATEDLY, THE RUN IS TERMINATED. +C----------------------------------------------------------------------- + 400 DO 410 I = 1,N + 410 Y(I) = RWORK(I+LYH-1) + T = TN + IF (ITASK .NE. 4 .AND. ITASK .NE. 5) GO TO 420 + IF (IHIT) T = TCRIT + 420 ISTATE = 2 + ILLIN = 0 + RWORK(11) = HU + RWORK(12) = H + RWORK(13) = TN + IWORK(11) = NST + IWORK(12) = NFE + IWORK(13) = NJE + IWORK(14) = NQU + IWORK(15) = NQ + RETURN +C + 430 NTREP = NTREP + 1 + IF (NTREP .LT. 5) RETURN + CALL XERRWD( + 1 'LSODE-- REPEATED CALLS WITH ISTATE = 1 AND TOUT = T (=R1) ', + 1 60, 301, 0, 0, 0, 0, 1, T, 0.0D0) + GO TO 800 +C----------------------------------------------------------------------- +C BLOCK H. +C THE FOLLOWING BLOCK HANDLES ALL UNSUCCESSFUL RETURNS OTHER THAN +C THOSE FOR ILLEGAL INPUT. FIRST THE ERROR MESSAGE ROUTINE IS CALLED. +C IF THERE WAS AN ERROR TEST OR CONVERGENCE TEST FAILURE, IMXER IS SET. +C THEN Y IS LOADED FROM YH, T IS SET TO TN, AND THE ILLEGAL INPUT +C COUNTER ILLIN IS SET TO 0. THE OPTIONAL OUTPUTS ARE LOADED INTO +C THE WORK ARRAYS BEFORE RETURNING. +C----------------------------------------------------------------------- +C THE MAXIMUM NUMBER OF STEPS WAS TAKEN BEFORE REACHING TOUT. ---------- + 500 CALL XERRWD('LSODE-- AT CURRENT T (=R1), MXSTEP (=I1) STEPS ', + 1 50, 201, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) + CALL XERRWD(' TAKEN ON THIS CALL BEFORE REACHING TOUT ', + 1 50, 201, 0, 1, MXSTEP, 0, 1, TN, 0.0D0) + ISTATE = -1 + GO TO 580 +C EWT(I) .LE. 0.0 FOR SOME I (NOT AT START OF PROBLEM). ---------------- + 510 EWTI = RWORK(LEWT+I-1) + CALL XERRWD('LSODE-- AT T (=R1), EWT(I1) HAS BECOME R2 .LE. 0.', + 1 50, 202, 0, 1, I, 0, 2, TN, EWTI) + ISTATE = -6 + GO TO 580 +C TOO MUCH ACCURACY REQUESTED FOR MACHINE PRECISION. ------------------- + 520 CALL XERRWD('LSODE-- AT T (=R1), TOO MUCH ACCURACY REQUESTED ', + 1 50, 203, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) + CALL XERRWD(' FOR PRECISION OF MACHINE.. SEE TOLSF (=R2) ', + 1 50, 203, 0, 0, 0, 0, 2, TN, TOLSF) + RWORK(14) = TOLSF + ISTATE = -2 + GO TO 580 +C KFLAG = -1. ERROR TEST FAILED REPEATEDLY OR WITH ABS(H) = HMIN. ----- + 530 CALL XERRWD('LSODE-- AT T(=R1) AND STEP SIZE H(=R2), THE ERROR', + 1 50, 204, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) + CALL XERRWD(' TEST FAILED REPEATEDLY OR WITH ABS(H) = HMIN', + 1 50, 204, 0, 0, 0, 0, 2, TN, H) + ISTATE = -4 + GO TO 560 +C KFLAG = -2. CONVERGENCE FAILED REPEATEDLY OR WITH ABS(H) = HMIN. ---- + 540 CALL XERRWD('LSODE-- AT T (=R1) AND STEP SIZE H (=R2), THE ', + 1 50, 205, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) + CALL XERRWD(' CORRECTOR CONVERGENCE FAILED REPEATEDLY ', + 1 50, 205, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) + CALL XERRWD(' OR WITH ABS(H) = HMIN ', + 1 30, 205, 0, 0, 0, 0, 2, TN, H) + ISTATE = -5 +C COMPUTE IMXER IF RELEVANT. ------------------------------------------- + 560 BIG = 0.0D0 + IMXER = 1 + DO 570 I = 1,N + SIZE = DABS(RWORK(I+LACOR-1)*RWORK(I+LEWT-1)) + IF (BIG .GE. SIZE) GO TO 570 + BIG = SIZE + IMXER = I + 570 CONTINUE + IWORK(16) = IMXER +C SET Y VECTOR, T, ILLIN, AND OPTIONAL OUTPUTS. ------------------------ + 580 DO 590 I = 1,N + 590 Y(I) = RWORK(I+LYH-1) + T = TN + ILLIN = 0 + RWORK(11) = HU + RWORK(12) = H + RWORK(13) = TN + IWORK(11) = NST + IWORK(12) = NFE + IWORK(13) = NJE + IWORK(14) = NQU + IWORK(15) = NQ + RETURN +C----------------------------------------------------------------------- +C BLOCK I. +C THE FOLLOWING BLOCK HANDLES ALL ERROR RETURNS DUE TO ILLEGAL INPUT +C (ISTATE = -3), AS DETECTED BEFORE CALLING THE CORE INTEGRATOR. +C FIRST THE ERROR MESSAGE ROUTINE IS CALLED. THEN IF THERE HAVE BEEN +C 5 CONSECUTIVE SUCH RETURNS JUST BEFORE THIS CALL TO THE SOLVER, +C THE RUN IS HALTED. +C----------------------------------------------------------------------- + 601 CALL XERRWD('LSODE-- ISTATE (=I1) ILLEGAL ', + 1 30, 1, 0, 1, ISTATE, 0, 0, 0.0D0, 0.0D0) + GO TO 700 + 602 CALL XERRWD('LSODE-- ITASK (=I1) ILLEGAL ', + 1 30, 2, 0, 1, ITASK, 0, 0, 0.0D0, 0.0D0) + GO TO 700 + 603 CALL XERRWD('LSODE-- ISTATE .GT. 1 BUT LSODE NOT INITIALIZED ', + 1 50, 3, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) + GO TO 700 + 604 CALL XERRWD('LSODE-- NEQ (=I1) .LT. 1 ', + 1 30, 4, 0, 1, NEQ(1), 0, 0, 0.0D0, 0.0D0) + GO TO 700 + 605 CALL XERRWD('LSODE-- ISTATE = 3 AND NEQ INCREASED (I1 TO I2) ', + 1 50, 5, 0, 2, N, NEQ(1), 0, 0.0D0, 0.0D0) + GO TO 700 + 606 CALL XERRWD('LSODE-- ITOL (=I1) ILLEGAL ', + 1 30, 6, 0, 1, ITOL, 0, 0, 0.0D0, 0.0D0) + GO TO 700 + 607 CALL XERRWD('LSODE-- IOPT (=I1) ILLEGAL ', + 1 30, 7, 0, 1, IOPT, 0, 0, 0.0D0, 0.0D0) + GO TO 700 + 608 CALL XERRWD('LSODE-- MF (=I1) ILLEGAL ', + 1 30, 8, 0, 1, MF, 0, 0, 0.0D0, 0.0D0) + GO TO 700 + 609 CALL XERRWD('LSODE-- ML (=I1) ILLEGAL.. .LT.0 OR .GE.NEQ (=I2)', + 1 50, 9, 0, 2, ML, NEQ(1), 0, 0.0D0, 0.0D0) + GO TO 700 + 610 CALL XERRWD('LSODE-- MU (=I1) ILLEGAL.. .LT.0 OR .GE.NEQ (=I2)', + 1 50, 10, 0, 2, MU, NEQ(1), 0, 0.0D0, 0.0D0) + GO TO 700 + 611 CALL XERRWD('LSODE-- MAXORD (=I1) .LT. 0 ', + 1 30, 11, 0, 1, MAXORD, 0, 0, 0.0D0, 0.0D0) + GO TO 700 + 612 CALL XERRWD('LSODE-- MXSTEP (=I1) .LT. 0 ', + 1 30, 12, 0, 1, MXSTEP, 0, 0, 0.0D0, 0.0D0) + GO TO 700 + 613 CALL XERRWD('LSODE-- MXHNIL (=I1) .LT. 0 ', + 1 30, 13, 0, 1, MXHNIL, 0, 0, 0.0D0, 0.0D0) + GO TO 700 + 614 CALL XERRWD('LSODE-- TOUT (=R1) BEHIND T (=R2) ', + 1 40, 14, 0, 0, 0, 0, 2, TOUT, T) + CALL XERRWD(' INTEGRATION DIRECTION IS GIVEN BY H0 (=R1) ', + 1 50, 14, 0, 0, 0, 0, 1, H0, 0.0D0) + GO TO 700 + 615 CALL XERRWD('LSODE-- HMAX (=R1) .LT. 0.0 ', + 1 30, 15, 0, 0, 0, 0, 1, HMAX, 0.0D0) + GO TO 700 + 616 CALL XERRWD('LSODE-- HMIN (=R1) .LT. 0.0 ', + 1 30, 16, 0, 0, 0, 0, 1, HMIN, 0.0D0) + GO TO 700 + 617 CALL XERRWD( + 1 'LSODE-- RWORK LENGTH NEEDED, LENRW (=I1), EXCEEDS LRW (=I2)', + 1 60, 17, 0, 2, LENRW, LRW, 0, 0.0D0, 0.0D0) + GO TO 700 + 618 CALL XERRWD( + 1 'LSODE-- IWORK LENGTH NEEDED, LENIW (=I1), EXCEEDS LIW (=I2)', + 1 60, 18, 0, 2, LENIW, LIW, 0, 0.0D0, 0.0D0) + GO TO 700 + 619 CALL XERRWD('LSODE-- RTOL(I1) IS R1 .LT. 0.0 ', + 1 40, 19, 0, 1, I, 0, 1, RTOLI, 0.0D0) + GO TO 700 + 620 CALL XERRWD('LSODE-- ATOL(I1) IS R1 .LT. 0.0 ', + 1 40, 20, 0, 1, I, 0, 1, ATOLI, 0.0D0) + GO TO 700 + 621 EWTI = RWORK(LEWT+I-1) + CALL XERRWD('LSODE-- EWT(I1) IS R1 .LE. 0.0 ', + 1 40, 21, 0, 1, I, 0, 1, EWTI, 0.0D0) + GO TO 700 + 622 CALL XERRWD( + 1 'LSODE-- TOUT (=R1) TOO CLOSE TO T(=R2) TO START INTEGRATION', + 1 60, 22, 0, 0, 0, 0, 2, TOUT, T) + GO TO 700 + 623 CALL XERRWD( + 1 'LSODE-- ITASK = I1 AND TOUT (=R1) BEHIND TCUR - HU (= R2) ', + 1 60, 23, 0, 1, ITASK, 0, 2, TOUT, TP) + GO TO 700 + 624 CALL XERRWD( + 1 'LSODE-- ITASK = 4 OR 5 AND TCRIT (=R1) BEHIND TCUR (=R2) ', + 1 60, 24, 0, 0, 0, 0, 2, TCRIT, TN) + GO TO 700 + 625 CALL XERRWD( + 1 'LSODE-- ITASK = 4 OR 5 AND TCRIT (=R1) BEHIND TOUT (=R2) ', + 1 60, 25, 0, 0, 0, 0, 2, TCRIT, TOUT) + GO TO 700 + 626 CALL XERRWD('LSODE-- AT START OF PROBLEM, TOO MUCH ACCURACY ', + 1 50, 26, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) + CALL XERRWD( + 1 ' REQUESTED FOR PRECISION OF MACHINE.. SEE TOLSF (=R1) ', + 1 60, 26, 0, 0, 0, 0, 1, TOLSF, 0.0D0) + RWORK(14) = TOLSF + GO TO 700 + 627 CALL XERRWD('LSODE-- TROUBLE FROM INTDY. ITASK = I1, TOUT = R1', + 1 50, 27, 0, 1, ITASK, 0, 1, TOUT, 0.0D0) +C + 700 IF (ILLIN .EQ. 5) GO TO 710 + ILLIN = ILLIN + 1 + ISTATE = -3 + RETURN + 710 CALL XERRWD('LSODE-- REPEATED OCCURRENCES OF ILLEGAL INPUT ', + 1 50, 302, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) +C + 800 CALL XERRWD('LSODE-- RUN ABORTED.. APPARENT INFINITE LOOP ', + 1 50, 303, 2, 0, 0, 0, 0, 0.0D0, 0.0D0) + RETURN +C----------------------- END OF SUBROUTINE LSODE ----------------------- + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/odepack/ewset.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,32 @@ + SUBROUTINE EWSET (N, ITOL, RTOL, ATOL, YCUR, EWT) +CLLL. OPTIMIZE +C----------------------------------------------------------------------- +C THIS SUBROUTINE SETS THE ERROR WEIGHT VECTOR EWT ACCORDING TO +C EWT(I) = RTOL(I)*ABS(YCUR(I)) + ATOL(I), I = 1,...,N, +C WITH THE SUBSCRIPT ON RTOL AND/OR ATOL POSSIBLY REPLACED BY 1 ABOVE, +C DEPENDING ON THE VALUE OF ITOL. +C----------------------------------------------------------------------- + INTEGER N, ITOL + INTEGER I + DOUBLE PRECISION RTOL, ATOL, YCUR, EWT + DIMENSION RTOL(*), ATOL(*), YCUR(N), EWT(N) +C + GO TO (10, 20, 30, 40), ITOL + 10 CONTINUE + DO 15 I = 1,N + 15 EWT(I) = RTOL(1)*DABS(YCUR(I)) + ATOL(1) + RETURN + 20 CONTINUE + DO 25 I = 1,N + 25 EWT(I) = RTOL(1)*DABS(YCUR(I)) + ATOL(I) + RETURN + 30 CONTINUE + DO 35 I = 1,N + 35 EWT(I) = RTOL(I)*DABS(YCUR(I)) + ATOL(1) + RETURN + 40 CONTINUE + DO 45 I = 1,N + 45 EWT(I) = RTOL(I)*DABS(YCUR(I)) + ATOL(I) + RETURN +C----------------------- END OF SUBROUTINE EWSET ----------------------- + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/odepack/intdy.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,89 @@ + SUBROUTINE INTDY (T, K, YH, NYH, DKY, IFLAG) +CLLL. OPTIMIZE + INTEGER K, NYH, IFLAG + INTEGER ILLIN, INIT, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, + 1 MXSTEP, MXHNIL, NHNIL, NTREP, NSLAST, CNYH, + 2 IALTH, IPUP, LMAX, MEO, NQNYH, NSLP + INTEGER ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, METH, MITER, + 2 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU + INTEGER I, IC, J, JB, JB2, JJ, JJ1, JP1 + DOUBLE PRECISION T, YH, DKY + DOUBLE PRECISION CONIT, CRATE, EL, ELCO, HOLD, RMAX, TESCO, + 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND + DOUBLE PRECISION C, R, S, TP + DIMENSION YH(NYH,*), DKY(*) + COMMON /LS0001/ CONIT, CRATE, EL(13), ELCO(13,12), + 1 HOLD, RMAX, TESCO(3,12), + 2 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, + 2 ILLIN, INIT, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, + 3 MXSTEP, MXHNIL, NHNIL, NTREP, NSLAST, CNYH, + 3 IALTH, IPUP, LMAX, MEO, NQNYH, NSLP, + 4 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, METH, MITER, + 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU +C----------------------------------------------------------------------- +C INTDY COMPUTES INTERPOLATED VALUES OF THE K-TH DERIVATIVE OF THE +C DEPENDENT VARIABLE VECTOR Y, AND STORES IT IN DKY. THIS ROUTINE +C IS CALLED WITHIN THE PACKAGE WITH K = 0 AND T = TOUT, BUT MAY +C ALSO BE CALLED BY THE USER FOR ANY K UP TO THE CURRENT ORDER. +C (SEE DETAILED INSTRUCTIONS IN THE USAGE DOCUMENTATION.) +C----------------------------------------------------------------------- +C THE COMPUTED VALUES IN DKY ARE GOTTEN BY INTERPOLATION USING THE +C NORDSIECK HISTORY ARRAY YH. THIS ARRAY CORRESPONDS UNIQUELY TO A +C VECTOR-VALUED POLYNOMIAL OF DEGREE NQCUR OR LESS, AND DKY IS SET +C TO THE K-TH DERIVATIVE OF THIS POLYNOMIAL AT T. +C THE FORMULA FOR DKY IS.. +C Q +C DKY(I) = SUM C(J,K) * (T - TN)**(J-K) * H**(-J) * YH(I,J+1) +C J=K +C WHERE C(J,K) = J*(J-1)*...*(J-K+1), Q = NQCUR, TN = TCUR, H = HCUR. +C THE QUANTITIES NQ = NQCUR, L = NQ+1, N = NEQ, TN, AND H ARE +C COMMUNICATED BY COMMON. THE ABOVE SUM IS DONE IN REVERSE ORDER. +C IFLAG IS RETURNED NEGATIVE IF EITHER K OR T IS OUT OF BOUNDS. +C----------------------------------------------------------------------- + IFLAG = 0 + IF (K .LT. 0 .OR. K .GT. NQ) GO TO 80 + TP = TN - HU - 100.0D0*UROUND*(TN + HU) + IF ((T-TP)*(T-TN) .GT. 0.0D0) GO TO 90 +C + S = (T - TN)/H + IC = 1 + IF (K .EQ. 0) GO TO 15 + JJ1 = L - K + DO 10 JJ = JJ1,NQ + 10 IC = IC*JJ + 15 C = DBLE(IC) + DO 20 I = 1,N + 20 DKY(I) = C*YH(I,L) + IF (K .EQ. NQ) GO TO 55 + JB2 = NQ - K + DO 50 JB = 1,JB2 + J = NQ - JB + JP1 = J + 1 + IC = 1 + IF (K .EQ. 0) GO TO 35 + JJ1 = JP1 - K + DO 30 JJ = JJ1,J + 30 IC = IC*JJ + 35 C = DBLE(IC) + DO 40 I = 1,N + 40 DKY(I) = C*YH(I,JP1) + S*DKY(I) + 50 CONTINUE + IF (K .EQ. 0) RETURN + 55 R = H**(-K) + DO 60 I = 1,N + 60 DKY(I) = R*DKY(I) + RETURN +C + 80 CALL XERRWD('INTDY-- K (=I1) ILLEGAL ', + 1 30, 51, 0, 1, K, 0, 0, 0.0D0, 0.0D0) + IFLAG = -1 + RETURN + 90 CALL XERRWD('INTDY-- T (=R1) ILLEGAL ', + 1 30, 52, 0, 0, 0, 0, 1, T, 0.0D0) + CALL XERRWD( + 1 ' T NOT IN INTERVAL TCUR - HU (= R1) TO TCUR (=R2) ', + 1 60, 52, 0, 0, 0, 0, 2, TP, TN) + IFLAG = -2 + RETURN +C----------------------- END OF SUBROUTINE INTDY ----------------------- + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/odepack/module.mk Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,17 @@ +EXTERNAL_SOURCES += \ + liboctave/external/odepack/cfode.f \ + liboctave/external/odepack/dlsode.f \ + liboctave/external/odepack/ewset.f \ + liboctave/external/odepack/intdy.f \ + liboctave/external/odepack/prepj.f \ + liboctave/external/odepack/solsy.f \ + liboctave/external/odepack/stode.f \ + liboctave/external/odepack/vnorm.f \ + liboctave/external/odepack/scfode.f \ + liboctave/external/odepack/sewset.f \ + liboctave/external/odepack/sintdy.f \ + liboctave/external/odepack/slsode.f \ + liboctave/external/odepack/sprepj.f \ + liboctave/external/odepack/ssolsy.f \ + liboctave/external/odepack/sstode.f \ + liboctave/external/odepack/svnorm.f
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/odepack/prepj.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,182 @@ + SUBROUTINE PREPJ (NEQ, Y, YH, NYH, EWT, FTEM, SAVF, WM, IWM, + 1 F, JAC, IERR) +CLLL. OPTIMIZE + EXTERNAL F, JAC + INTEGER NEQ, NYH, IWM + INTEGER ILLIN, INIT, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, + 1 MXSTEP, MXHNIL, NHNIL, NTREP, NSLAST, CNYH, + 2 IALTH, IPUP, LMAX, MEO, NQNYH, NSLP + INTEGER ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, METH, MITER, + 2 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU + INTEGER I, I1, I2, IER, II, J, J1, JJ, LENP, + 1 MBA, MBAND, MEB1, MEBAND, ML, ML3, MU, NP1 + DOUBLE PRECISION Y, YH, EWT, FTEM, SAVF, WM + DOUBLE PRECISION CONIT, CRATE, EL, ELCO, HOLD, RMAX, TESCO, + 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND + DOUBLE PRECISION CON, DI, FAC, HL0, R, R0, SRUR, YI, YJ, YJJ, + 1 VNORM + DIMENSION NEQ(*), Y(*), YH(NYH,*), EWT(*), FTEM(*), SAVF(*), + 1 WM(*), IWM(*) + COMMON /LS0001/ CONIT, CRATE, EL(13), ELCO(13,12), + 1 HOLD, RMAX, TESCO(3,12), + 2 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, + 2 ILLIN, INIT, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, + 3 MXSTEP, MXHNIL, NHNIL, NTREP, NSLAST, CNYH, + 3 IALTH, IPUP, LMAX, MEO, NQNYH, NSLP, + 4 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, METH, MITER, + 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU +C----------------------------------------------------------------------- +C PREPJ IS CALLED BY STODE TO COMPUTE AND PROCESS THE MATRIX +C P = I - H*EL(1)*J , WHERE J IS AN APPROXIMATION TO THE JACOBIAN. +C HERE J IS COMPUTED BY THE USER-SUPPLIED ROUTINE JAC IF +C MITER = 1 OR 4, OR BY FINITE DIFFERENCING IF MITER = 2, 3, OR 5. +C IF MITER = 3, A DIAGONAL APPROXIMATION TO J IS USED. +C J IS STORED IN WM AND REPLACED BY P. IF MITER .NE. 3, P IS THEN +C SUBJECTED TO LU DECOMPOSITION IN PREPARATION FOR LATER SOLUTION +C OF LINEAR SYSTEMS WITH P AS COEFFICIENT MATRIX. THIS IS DONE +C BY DGETRF IF MITER = 1 OR 2, AND BY DGBTRF IF MITER = 4 OR 5. +C +C IN ADDITION TO VARIABLES DESCRIBED PREVIOUSLY, COMMUNICATION +C WITH PREPJ USES THE FOLLOWING.. +C Y = ARRAY CONTAINING PREDICTED VALUES ON ENTRY. +C FTEM = WORK ARRAY OF LENGTH N (ACOR IN STODE). +C SAVF = ARRAY CONTAINING F EVALUATED AT PREDICTED Y. +C WM = REAL WORK SPACE FOR MATRICES. ON OUTPUT IT CONTAINS THE +C INVERSE DIAGONAL MATRIX IF MITER = 3 AND THE LU DECOMPOSITION +C OF P IF MITER IS 1, 2 , 4, OR 5. +C STORAGE OF MATRIX ELEMENTS STARTS AT WM(3). +C WM ALSO CONTAINS THE FOLLOWING MATRIX-RELATED DATA.. +C WM(1) = SQRT(UROUND), USED IN NUMERICAL JACOBIAN INCREMENTS. +C WM(2) = H*EL0, SAVED FOR LATER USE IF MITER = 3. +C IWM = INTEGER WORK SPACE CONTAINING PIVOT INFORMATION, STARTING AT +C IWM(21), IF MITER IS 1, 2, 4, OR 5. IWM ALSO CONTAINS BAND +C PARAMETERS ML = IWM(1) AND MU = IWM(2) IF MITER IS 4 OR 5. +C EL0 = EL(1) (INPUT). +C IERPJ = OUTPUT ERROR FLAG, = 0 IF NO TROUBLE, .GT. 0 IF +C P MATRIX FOUND TO BE SINGULAR. +C JCUR = OUTPUT FLAG = 1 TO INDICATE THAT THE JACOBIAN MATRIX +C (OR APPROXIMATION) IS NOW CURRENT. +C THIS ROUTINE ALSO USES THE COMMON VARIABLES EL0, H, TN, UROUND, +C MITER, N, NFE, AND NJE. +C----------------------------------------------------------------------- + NJE = NJE + 1 + IERPJ = 0 + JCUR = 1 + HL0 = H*EL0 + GO TO (100, 200, 300, 400, 500), MITER +C IF MITER = 1, CALL JAC AND MULTIPLY BY SCALAR. ----------------------- + 100 LENP = N*N + DO 110 I = 1,LENP + 110 WM(I+2) = 0.0D0 + CALL JAC (NEQ, TN, Y, 0, 0, WM(3), N) + CON = -HL0 + DO 120 I = 1,LENP + 120 WM(I+2) = WM(I+2)*CON + GO TO 240 +C IF MITER = 2, MAKE N CALLS TO F TO APPROXIMATE J. -------------------- + 200 FAC = VNORM (N, SAVF, EWT) + R0 = 1000.0D0*DABS(H)*UROUND*DBLE(N)*FAC + IF (R0 .EQ. 0.0D0) R0 = 1.0D0 + SRUR = WM(1) + J1 = 2 + DO 230 J = 1,N + YJ = Y(J) + R = DMAX1(SRUR*DABS(YJ),R0/EWT(J)) + Y(J) = Y(J) + R + FAC = -HL0/R + IERR = 0 + CALL F (NEQ, TN, Y, FTEM, IERR) + IF (IERR .LT. 0) RETURN + DO 220 I = 1,N + 220 WM(I+J1) = (FTEM(I) - SAVF(I))*FAC + Y(J) = YJ + J1 = J1 + N + 230 CONTINUE + NFE = NFE + N +C ADD IDENTITY MATRIX. ------------------------------------------------- + 240 J = 3 + NP1 = N + 1 + DO 250 I = 1,N + WM(J) = WM(J) + 1.0D0 + 250 J = J + NP1 +C DO LU DECOMPOSITION ON P. -------------------------------------------- + CALL DGETRF ( N, N, WM(3), N, IWM(21), IER) + IF (IER .NE. 0) IERPJ = 1 + RETURN +C IF MITER = 3, CONSTRUCT A DIAGONAL APPROXIMATION TO J AND P. --------- + 300 WM(2) = HL0 + R = EL0*0.1D0 + DO 310 I = 1,N + 310 Y(I) = Y(I) + R*(H*SAVF(I) - YH(I,2)) + IERR = 0 + CALL F (NEQ, TN, Y, WM(3), IERR) + IF (IERR .LT. 0) RETURN + NFE = NFE + 1 + DO 320 I = 1,N + R0 = H*SAVF(I) - YH(I,2) + DI = 0.1D0*R0 - H*(WM(I+2) - SAVF(I)) + WM(I+2) = 1.0D0 + IF (DABS(R0) .LT. UROUND/EWT(I)) GO TO 320 + IF (DABS(DI) .EQ. 0.0D0) GO TO 330 + WM(I+2) = 0.1D0*R0/DI + 320 CONTINUE + RETURN + 330 IERPJ = 1 + RETURN +C IF MITER = 4, CALL JAC AND MULTIPLY BY SCALAR. ----------------------- + 400 ML = IWM(1) + MU = IWM(2) + ML3 = ML + 3 + MBAND = ML + MU + 1 + MEBAND = MBAND + ML + LENP = MEBAND*N + DO 410 I = 1,LENP + 410 WM(I+2) = 0.0D0 + CALL JAC (NEQ, TN, Y, ML, MU, WM(ML3), MEBAND) + CON = -HL0 + DO 420 I = 1,LENP + 420 WM(I+2) = WM(I+2)*CON + GO TO 570 +C IF MITER = 5, MAKE MBAND CALLS TO F TO APPROXIMATE J. ---------------- + 500 ML = IWM(1) + MU = IWM(2) + MBAND = ML + MU + 1 + MBA = MIN0(MBAND,N) + MEBAND = MBAND + ML + MEB1 = MEBAND - 1 + SRUR = WM(1) + FAC = VNORM (N, SAVF, EWT) + R0 = 1000.0D0*DABS(H)*UROUND*DBLE(N)*FAC + IF (R0 .EQ. 0.0D0) R0 = 1.0D0 + DO 560 J = 1,MBA + DO 530 I = J,N,MBAND + YI = Y(I) + R = DMAX1(SRUR*DABS(YI),R0/EWT(I)) + 530 Y(I) = Y(I) + R + IERR = 0 + CALL F (NEQ, TN, Y, FTEM, IERR) + IF (IERR .LT. 0) RETURN + DO 550 JJ = J,N,MBAND + Y(JJ) = YH(JJ,1) + YJJ = Y(JJ) + R = DMAX1(SRUR*DABS(YJJ),R0/EWT(JJ)) + FAC = -HL0/R + I1 = MAX0(JJ-MU,1) + I2 = MIN0(JJ+ML,N) + II = JJ*MEB1 - ML + 2 + DO 540 I = I1,I2 + 540 WM(II+I) = (FTEM(I) - SAVF(I))*FAC + 550 CONTINUE + 560 CONTINUE + NFE = NFE + MBA +C ADD IDENTITY MATRIX. ------------------------------------------------- + 570 II = MBAND + 2 + DO 580 I = 1,N + WM(II) = WM(II) + 1.0D0 + 580 II = II + MEBAND +C DO LU DECOMPOSITION OF P. -------------------------------------------- + CALL DGBTRF ( N, N, ML, MU, WM(3), MEBAND, IWM(21), IER) + IF (IER .NE. 0) IERPJ = 1 + RETURN +C----------------------- END OF SUBROUTINE PREPJ ----------------------- + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/odepack/scfode.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,127 @@ + SUBROUTINE SCFODE (METH, ELCO, TESCO) +C***BEGIN PROLOGUE SCFODE +C***SUBSIDIARY +C***PURPOSE Set ODE integrator coefficients. +C***TYPE SINGLE PRECISION (SCFODE-S, DCFODE-D) +C***AUTHOR Hindmarsh, Alan C., (LLNL) +C***DESCRIPTION +C +C SCFODE is called by the integrator routine to set coefficients +C needed there. The coefficients for the current method, as +C given by the value of METH, are set for all orders and saved. +C The maximum order assumed here is 12 if METH = 1 and 5 if METH = 2. +C (A smaller value of the maximum order is also allowed.) +C SCFODE is called once at the beginning of the problem, +C and is not called again unless and until METH is changed. +C +C The ELCO array contains the basic method coefficients. +C The coefficients el(i), 1 .le. i .le. nq+1, for the method of +C order nq are stored in ELCO(i,nq). They are given by a genetrating +C polynomial, i.e., +C l(x) = el(1) + el(2)*x + ... + el(nq+1)*x**nq. +C For the implicit Adams methods, l(x) is given by +C dl/dx = (x+1)*(x+2)*...*(x+nq-1)/factorial(nq-1), l(-1) = 0. +C For the BDF methods, l(x) is given by +C l(x) = (x+1)*(x+2)* ... *(x+nq)/K, +C where K = factorial(nq)*(1 + 1/2 + ... + 1/nq). +C +C The TESCO array contains test constants used for the +C local error test and the selection of step size and/or order. +C At order nq, TESCO(k,nq) is used for the selection of step +C size at order nq - 1 if k = 1, at order nq if k = 2, and at order +C nq + 1 if k = 3. +C +C***SEE ALSO SLSODE +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 791129 DATE WRITTEN +C 890501 Modified prologue to SLATEC/LDOC format. (FNF) +C 890503 Minor cosmetic changes. (FNF) +C 930809 Renamed to allow single/double precision versions. (ACH) +C***END PROLOGUE SCFODE +C**End + INTEGER METH + INTEGER I, IB, NQ, NQM1, NQP1 + REAL ELCO, TESCO + REAL AGAMQ, FNQ, FNQM1, PC, PINT, RAGQ, + 1 RQFAC, RQ1FAC, TSIGN, XPIN + DIMENSION ELCO(13,12), TESCO(3,12) + DIMENSION PC(12) +C +C***FIRST EXECUTABLE STATEMENT SCFODE + GO TO (100, 200), METH +C + 100 ELCO(1,1) = 1.0E0 + ELCO(2,1) = 1.0E0 + TESCO(1,1) = 0.0E0 + TESCO(2,1) = 2.0E0 + TESCO(1,2) = 1.0E0 + TESCO(3,12) = 0.0E0 + PC(1) = 1.0E0 + RQFAC = 1.0E0 + DO 140 NQ = 2,12 +C----------------------------------------------------------------------- +C The PC array will contain the coefficients of the polynomial +C p(x) = (x+1)*(x+2)*...*(x+nq-1). +C Initially, p(x) = 1. +C----------------------------------------------------------------------- + RQ1FAC = RQFAC + RQFAC = RQFAC/NQ + NQM1 = NQ - 1 + FNQM1 = NQM1 + NQP1 = NQ + 1 +C Form coefficients of p(x)*(x+nq-1). ---------------------------------- + PC(NQ) = 0.0E0 + DO 110 IB = 1,NQM1 + I = NQP1 - IB + 110 PC(I) = PC(I-1) + FNQM1*PC(I) + PC(1) = FNQM1*PC(1) +C Compute integral, -1 to 0, of p(x) and x*p(x). ----------------------- + PINT = PC(1) + XPIN = PC(1)/2.0E0 + TSIGN = 1.0E0 + DO 120 I = 2,NQ + TSIGN = -TSIGN + PINT = PINT + TSIGN*PC(I)/I + 120 XPIN = XPIN + TSIGN*PC(I)/(I+1) +C Store coefficients in ELCO and TESCO. -------------------------------- + ELCO(1,NQ) = PINT*RQ1FAC + ELCO(2,NQ) = 1.0E0 + DO 130 I = 2,NQ + 130 ELCO(I+1,NQ) = RQ1FAC*PC(I)/I + AGAMQ = RQFAC*XPIN + RAGQ = 1.0E0/AGAMQ + TESCO(2,NQ) = RAGQ + IF (NQ .LT. 12) TESCO(1,NQP1) = RAGQ*RQFAC/NQP1 + TESCO(3,NQM1) = RAGQ + 140 CONTINUE + RETURN +C + 200 PC(1) = 1.0E0 + RQ1FAC = 1.0E0 + DO 230 NQ = 1,5 +C----------------------------------------------------------------------- +C The PC array will contain the coefficients of the polynomial +C p(x) = (x+1)*(x+2)*...*(x+nq). +C Initially, p(x) = 1. +C----------------------------------------------------------------------- + FNQ = NQ + NQP1 = NQ + 1 +C Form coefficients of p(x)*(x+nq). ------------------------------------ + PC(NQP1) = 0.0E0 + DO 210 IB = 1,NQ + I = NQ + 2 - IB + 210 PC(I) = PC(I-1) + FNQ*PC(I) + PC(1) = FNQ*PC(1) +C Store coefficients in ELCO and TESCO. -------------------------------- + DO 220 I = 1,NQP1 + 220 ELCO(I,NQ) = PC(I)/PC(2) + ELCO(2,NQ) = 1.0E0 + TESCO(1,NQ) = RQ1FAC + TESCO(2,NQ) = NQP1/ELCO(1,NQ) + TESCO(3,NQ) = (NQ+2)/ELCO(1,NQ) + RQ1FAC = RQ1FAC/FNQ + 230 CONTINUE + RETURN +C----------------------- END OF SUBROUTINE SCFODE ---------------------- + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/odepack/sewset.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,47 @@ + SUBROUTINE SEWSET (N, ITOL, RTOL, ATOL, YCUR, EWT) +C***BEGIN PROLOGUE SEWSET +C***SUBSIDIARY +C***PURPOSE Set error weight vector. +C***TYPE SINGLE PRECISION (SEWSET-S, DEWSET-D) +C***AUTHOR Hindmarsh, Alan C., (LLNL) +C***DESCRIPTION +C +C This subroutine sets the error weight vector EWT according to +C EWT(i) = RTOL(i)*ABS(YCUR(i)) + ATOL(i), i = 1,...,N, +C with the subscript on RTOL and/or ATOL possibly replaced by 1 above, +C depending on the value of ITOL. +C +C***SEE ALSO SLSODE +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 791129 DATE WRITTEN +C 890501 Modified prologue to SLATEC/LDOC format. (FNF) +C 890503 Minor cosmetic changes. (FNF) +C 930809 Renamed to allow single/double precision versions. (ACH) +C***END PROLOGUE SEWSET +C**End + INTEGER N, ITOL + INTEGER I + REAL RTOL, ATOL, YCUR, EWT + DIMENSION RTOL(*), ATOL(*), YCUR(N), EWT(N) +C +C***FIRST EXECUTABLE STATEMENT SEWSET + GO TO (10, 20, 30, 40), ITOL + 10 CONTINUE + DO 15 I = 1,N + 15 EWT(I) = RTOL(1)*ABS(YCUR(I)) + ATOL(1) + RETURN + 20 CONTINUE + DO 25 I = 1,N + 25 EWT(I) = RTOL(1)*ABS(YCUR(I)) + ATOL(I) + RETURN + 30 CONTINUE + DO 35 I = 1,N + 35 EWT(I) = RTOL(I)*ABS(YCUR(I)) + ATOL(1) + RETURN + 40 CONTINUE + DO 45 I = 1,N + 45 EWT(I) = RTOL(I)*ABS(YCUR(I)) + ATOL(I) + RETURN +C----------------------- END OF SUBROUTINE SEWSET ---------------------- + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/odepack/sintdy.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,111 @@ + SUBROUTINE SINTDY (T, K, YH, NYH, DKY, IFLAG) +C***BEGIN PROLOGUE SINTDY +C***SUBSIDIARY +C***PURPOSE Interpolate solution derivatives. +C***TYPE SINGLE PRECISION (SINTDY-S, DINTDY-D) +C***AUTHOR Hindmarsh, Alan C., (LLNL) +C***DESCRIPTION +C +C SINTDY computes interpolated values of the K-th derivative of the +C dependent variable vector y, and stores it in DKY. This routine +C is called within the package with K = 0 and T = TOUT, but may +C also be called by the user for any K up to the current order. +C (See detailed instructions in the usage documentation.) +C +C The computed values in DKY are gotten by interpolation using the +C Nordsieck history array YH. This array corresponds uniquely to a +C vector-valued polynomial of degree NQCUR or less, and DKY is set +C to the K-th derivative of this polynomial at T. +C The formula for DKY is: +C q +C DKY(i) = sum c(j,K) * (T - tn)**(j-K) * h**(-j) * YH(i,j+1) +C j=K +C where c(j,K) = j*(j-1)*...*(j-K+1), q = NQCUR, tn = TCUR, h = HCUR. +C The quantities nq = NQCUR, l = nq+1, N = NEQ, tn, and h are +C communicated by COMMON. The above sum is done in reverse order. +C IFLAG is returned negative if either K or T is out of bounds. +C +C***SEE ALSO SLSODE +C***ROUTINES CALLED XERRWV +C***COMMON BLOCKS SLS001 +C***REVISION HISTORY (YYMMDD) +C 791129 DATE WRITTEN +C 890501 Modified prologue to SLATEC/LDOC format. (FNF) +C 890503 Minor cosmetic changes. (FNF) +C 930809 Renamed to allow single/double precision versions. (ACH) +C 010412 Reduced size of Common block /SLS001/. (ACH) +C 031105 Restored 'own' variables to Common block /SLS001/, to +C enable interrupt/restart feature. (ACH) +C 050427 Corrected roundoff decrement in TP. (ACH) +C***END PROLOGUE SINTDY +C**End + INTEGER K, NYH, IFLAG + REAL T, YH, DKY + DIMENSION YH(NYH,*), DKY(*) + INTEGER INIT, MXSTEP, MXHNIL, NHNIL, NSLAST, CNYH, + 1 IALTH, IPUP, LMAX, MEO, NQNYH, NSLP, + 1 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, + 2 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, + 3 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU + REAL CONIT, CRATE, EL, ELCO, HOLD, RMAX, TESCO, + 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND + COMMON /SLS001/ CONIT, CRATE, EL(13), ELCO(13,12), + 1 HOLD, RMAX, TESCO(3,12), + 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, + 2 INIT, MXSTEP, MXHNIL, NHNIL, NSLAST, CNYH, + 3 IALTH, IPUP, LMAX, MEO, NQNYH, NSLP, + 3 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, + 4 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, + 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU + INTEGER I, IC, J, JB, JB2, JJ, JJ1, JP1 + REAL C, R, S, TP + CHARACTER*80 MSG +C +C***FIRST EXECUTABLE STATEMENT SINTDY + IFLAG = 0 + IF (K .LT. 0 .OR. K .GT. NQ) GO TO 80 + TP = TN - HU - 100.0E0*UROUND*SIGN(ABS(TN) + ABS(HU), HU) + IF ((T-TP)*(T-TN) .GT. 0.0E0) GO TO 90 +C + S = (T - TN)/H + IC = 1 + IF (K .EQ. 0) GO TO 15 + JJ1 = L - K + DO 10 JJ = JJ1,NQ + 10 IC = IC*JJ + 15 C = IC + DO 20 I = 1,N + 20 DKY(I) = C*YH(I,L) + IF (K .EQ. NQ) GO TO 55 + JB2 = NQ - K + DO 50 JB = 1,JB2 + J = NQ - JB + JP1 = J + 1 + IC = 1 + IF (K .EQ. 0) GO TO 35 + JJ1 = JP1 - K + DO 30 JJ = JJ1,J + 30 IC = IC*JJ + 35 C = IC + DO 40 I = 1,N + 40 DKY(I) = C*YH(I,JP1) + S*DKY(I) + 50 CONTINUE + IF (K .EQ. 0) RETURN + 55 R = H**(-K) + DO 60 I = 1,N + 60 DKY(I) = R*DKY(I) + RETURN +C + 80 CALL XERRWD('SINTDY- K (=I1) illegal ', + 1 30, 51, 0, 1, K, 0, 0, 0.0E0, 0.0E0) + IFLAG = -1 + RETURN + 90 CALL XERRWD('SINTDY- T (=R1) illegal ', + 1 30, 52, 0, 0, 0, 0, 1, T, 0.0E0) + CALL XERRWD( + 1 ' T not in interval TCUR - HU (= R1) to TCUR (=R2) ', + 1 60, 52, 0, 0, 0, 0, 2, TP, TN) + IFLAG = -2 + RETURN +C----------------------- END OF SUBROUTINE SINTDY ---------------------- + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/odepack/slsode.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,1760 @@ +*DECK SLSODE + SUBROUTINE SLSODE (F, NEQ, Y, T, TOUT, ITOL, RTOL, ATOL, ITASK, + 1 ISTATE, IOPT, RWORK, LRW, IWORK, LIW, JAC, MF) + EXTERNAL F, JAC + INTEGER NEQ, ITOL, ITASK, ISTATE, IOPT, LRW, IWORK, LIW, MF + REAL Y, T, TOUT, RTOL, ATOL, RWORK + DIMENSION NEQ(*), Y(*), RTOL(*), ATOL(*), RWORK(LRW), IWORK(LIW) +C***BEGIN PROLOGUE SLSODE +C***PURPOSE Livermore Solver for Ordinary Differential Equations. +C SLSODE solves the initial-value problem for stiff or +C nonstiff systems of first-order ODE's, +C dy/dt = f(t,y), or, in component form, +C dy(i)/dt = f(i) = f(i,t,y(1),y(2),...,y(N)), i=1,...,N. +C***CATEGORY I1A +C***TYPE SINGLE PRECISION (SLSODE-S, DLSODE-D) +C***KEYWORDS ORDINARY DIFFERENTIAL EQUATIONS, INITIAL VALUE PROBLEM, +C STIFF, NONSTIFF +C***AUTHOR Hindmarsh, Alan C., (LLNL) +C Center for Applied Scientific Computing, L-561 +C Lawrence Livermore National Laboratory +C Livermore, CA 94551. +C***DESCRIPTION +C +C NOTE: The "Usage" and "Arguments" sections treat only a subset of +C available options, in condensed fashion. The options +C covered and the information supplied will support most +C standard uses of SLSODE. +C +C For more sophisticated uses, full details on all options are +C given in the concluding section, headed "Long Description." +C A synopsis of the SLSODE Long Description is provided at the +C beginning of that section; general topics covered are: +C - Elements of the call sequence; optional input and output +C - Optional supplemental routines in the SLSODE package +C - internal COMMON block +C +C *Usage: +C Communication between the user and the SLSODE package, for normal +C situations, is summarized here. This summary describes a subset +C of the available options. See "Long Description" for complete +C details, including optional communication, nonstandard options, +C and instructions for special situations. +C +C A sample program is given in the "Examples" section. +C +C Refer to the argument descriptions for the definitions of the +C quantities that appear in the following sample declarations. +C +C For MF = 10, +C PARAMETER (LRW = 20 + 16*NEQ, LIW = 20) +C For MF = 21 or 22, +C PARAMETER (LRW = 22 + 9*NEQ + NEQ**2, LIW = 20 + NEQ) +C For MF = 24 or 25, +C PARAMETER (LRW = 22 + 10*NEQ + (2*ML+MU)*NEQ, +C * LIW = 20 + NEQ) +C +C EXTERNAL F, JAC +C INTEGER NEQ, ITOL, ITASK, ISTATE, IOPT, LRW, IWORK(LIW), +C * LIW, MF +C REAL Y(NEQ), T, TOUT, RTOL, ATOL(ntol), RWORK(LRW) +C +C CALL SLSODE (F, NEQ, Y, T, TOUT, ITOL, RTOL, ATOL, ITASK, +C * ISTATE, IOPT, RWORK, LRW, IWORK, LIW, JAC, MF) +C +C *Arguments: +C F :EXT Name of subroutine for right-hand-side vector f. +C This name must be declared EXTERNAL in calling +C program. The form of F must be: +C +C SUBROUTINE F (NEQ, T, Y, YDOT) +C INTEGER NEQ +C REAL T, Y(*), YDOT(*) +C +C The inputs are NEQ, T, Y. F is to set +C +C YDOT(i) = f(i,T,Y(1),Y(2),...,Y(NEQ)), +C i = 1, ..., NEQ . +C +C NEQ :IN Number of first-order ODE's. +C +C Y :INOUT Array of values of the y(t) vector, of length NEQ. +C Input: For the first call, Y should contain the +C values of y(t) at t = T. (Y is an input +C variable only if ISTATE = 1.) +C Output: On return, Y will contain the values at the +C new t-value. +C +C T :INOUT Value of the independent variable. On return it +C will be the current value of t (normally TOUT). +C +C TOUT :IN Next point where output is desired (.NE. T). +C +C ITOL :IN 1 or 2 according as ATOL (below) is a scalar or +C an array. +C +C RTOL :IN Relative tolerance parameter (scalar). +C +C ATOL :IN Absolute tolerance parameter (scalar or array). +C If ITOL = 1, ATOL need not be dimensioned. +C If ITOL = 2, ATOL must be dimensioned at least NEQ. +C +C The estimated local error in Y(i) will be controlled +C so as to be roughly less (in magnitude) than +C +C EWT(i) = RTOL*ABS(Y(i)) + ATOL if ITOL = 1, or +C EWT(i) = RTOL*ABS(Y(i)) + ATOL(i) if ITOL = 2. +C +C Thus the local error test passes if, in each +C component, either the absolute error is less than +C ATOL (or ATOL(i)), or the relative error is less +C than RTOL. +C +C Use RTOL = 0.0 for pure absolute error control, and +C use ATOL = 0.0 (or ATOL(i) = 0.0) for pure relative +C error control. Caution: Actual (global) errors may +C exceed these local tolerances, so choose them +C conservatively. +C +C ITASK :IN Flag indicating the task SLSODE is to perform. +C Use ITASK = 1 for normal computation of output +C values of y at t = TOUT. +C +C ISTATE:INOUT Index used for input and output to specify the state +C of the calculation. +C Input: +C 1 This is the first call for a problem. +C 2 This is a subsequent call. +C Output: +C 1 Nothing was done, as TOUT was equal to T. +C 2 SLSODE was successful (otherwise, negative). +C Note that ISTATE need not be modified after a +C successful return. +C -1 Excess work done on this call (perhaps wrong +C MF). +C -2 Excess accuracy requested (tolerances too +C small). +C -3 Illegal input detected (see printed message). +C -4 Repeated error test failures (check all +C inputs). +C -5 Repeated convergence failures (perhaps bad +C Jacobian supplied or wrong choice of MF or +C tolerances). +C -6 Error weight became zero during problem +C (solution component i vanished, and ATOL or +C ATOL(i) = 0.). +C +C IOPT :IN Flag indicating whether optional inputs are used: +C 0 No. +C 1 Yes. (See "Optional inputs" under "Long +C Description," Part 1.) +C +C RWORK :WORK Real work array of length at least: +C 20 + 16*NEQ for MF = 10, +C 22 + 9*NEQ + NEQ**2 for MF = 21 or 22, +C 22 + 10*NEQ + (2*ML + MU)*NEQ for MF = 24 or 25. +C +C LRW :IN Declared length of RWORK (in user's DIMENSION +C statement). +C +C IWORK :WORK Integer work array of length at least: +C 20 for MF = 10, +C 20 + NEQ for MF = 21, 22, 24, or 25. +C +C If MF = 24 or 25, input in IWORK(1),IWORK(2) the +C lower and upper Jacobian half-bandwidths ML,MU. +C +C On return, IWORK contains information that may be +C of interest to the user: +C +C Name Location Meaning +C ----- --------- ----------------------------------------- +C NST IWORK(11) Number of steps taken for the problem so +C far. +C NFE IWORK(12) Number of f evaluations for the problem +C so far. +C NJE IWORK(13) Number of Jacobian evaluations (and of +C matrix LU decompositions) for the problem +C so far. +C NQU IWORK(14) Method order last used (successfully). +C LENRW IWORK(17) Length of RWORK actually required. This +C is defined on normal returns and on an +C illegal input return for insufficient +C storage. +C LENIW IWORK(18) Length of IWORK actually required. This +C is defined on normal returns and on an +C illegal input return for insufficient +C storage. +C +C LIW :IN Declared length of IWORK (in user's DIMENSION +C statement). +C +C JAC :EXT Name of subroutine for Jacobian matrix (MF = +C 21 or 24). If used, this name must be declared +C EXTERNAL in calling program. If not used, pass a +C dummy name. The form of JAC must be: +C +C SUBROUTINE JAC (NEQ, T, Y, ML, MU, PD, NROWPD) +C INTEGER NEQ, ML, MU, NROWPD +C REAL T, Y(*), PD(NROWPD,*) +C +C See item c, under "Description" below for more +C information about JAC. +C +C MF :IN Method flag. Standard values are: +C 10 Nonstiff (Adams) method, no Jacobian used. +C 21 Stiff (BDF) method, user-supplied full Jacobian. +C 22 Stiff method, internally generated full +C Jacobian. +C 24 Stiff method, user-supplied banded Jacobian. +C 25 Stiff method, internally generated banded +C Jacobian. +C +C *Description: +C SLSODE solves the initial value problem for stiff or nonstiff +C systems of first-order ODE's, +C +C dy/dt = f(t,y) , +C +C or, in component form, +C +C dy(i)/dt = f(i) = f(i,t,y(1),y(2),...,y(NEQ)) +C (i = 1, ..., NEQ) . +C +C SLSODE is a package based on the GEAR and GEARB packages, and on +C the October 23, 1978, version of the tentative ODEPACK user +C interface standard, with minor modifications. +C +C The steps in solving such a problem are as follows. +C +C a. First write a subroutine of the form +C +C SUBROUTINE F (NEQ, T, Y, YDOT) +C INTEGER NEQ +C REAL T, Y(*), YDOT(*) +C +C which supplies the vector function f by loading YDOT(i) with +C f(i). +C +C b. Next determine (or guess) whether or not the problem is stiff. +C Stiffness occurs when the Jacobian matrix df/dy has an +C eigenvalue whose real part is negative and large in magnitude +C compared to the reciprocal of the t span of interest. If the +C problem is nonstiff, use method flag MF = 10. If it is stiff, +C there are four standard choices for MF, and SLSODE requires the +C Jacobian matrix in some form. This matrix is regarded either +C as full (MF = 21 or 22), or banded (MF = 24 or 25). In the +C banded case, SLSODE requires two half-bandwidth parameters ML +C and MU. These are, respectively, the widths of the lower and +C upper parts of the band, excluding the main diagonal. Thus the +C band consists of the locations (i,j) with +C +C i - ML <= j <= i + MU , +C +C and the full bandwidth is ML + MU + 1 . +C +C c. If the problem is stiff, you are encouraged to supply the +C Jacobian directly (MF = 21 or 24), but if this is not feasible, +C SLSODE will compute it internally by difference quotients (MF = +C 22 or 25). If you are supplying the Jacobian, write a +C subroutine of the form +C +C SUBROUTINE JAC (NEQ, T, Y, ML, MU, PD, NROWPD) +C INTEGER NEQ, ML, MU, NRWOPD +C REAL T, Y(*), PD(NROWPD,*) +C +C which provides df/dy by loading PD as follows: +C - For a full Jacobian (MF = 21), load PD(i,j) with df(i)/dy(j), +C the partial derivative of f(i) with respect to y(j). (Ignore +C the ML and MU arguments in this case.) +C - For a banded Jacobian (MF = 24), load PD(i-j+MU+1,j) with +C df(i)/dy(j); i.e., load the diagonal lines of df/dy into the +C rows of PD from the top down. +C - In either case, only nonzero elements need be loaded. +C +C d. Write a main program that calls subroutine SLSODE once for each +C point at which answers are desired. This should also provide +C for possible use of logical unit 6 for output of error messages +C by SLSODE. +C +C Before the first call to SLSODE, set ISTATE = 1, set Y and T to +C the initial values, and set TOUT to the first output point. To +C continue the integration after a successful return, simply +C reset TOUT and call SLSODE again. No other parameters need be +C reset. +C +C *Examples: +C The following is a simple example problem, with the coding needed +C for its solution by SLSODE. The problem is from chemical kinetics, +C and consists of the following three rate equations: +C +C dy1/dt = -.04*y1 + 1.E4*y2*y3 +C dy2/dt = .04*y1 - 1.E4*y2*y3 - 3.E7*y2**2 +C dy3/dt = 3.E7*y2**2 +C +C on the interval from t = 0.0 to t = 4.E10, with initial conditions +C y1 = 1.0, y2 = y3 = 0. The problem is stiff. +C +C The following coding solves this problem with SLSODE, using +C MF = 21 and printing results at t = .4, 4., ..., 4.E10. It uses +C ITOL = 2 and ATOL much smaller for y2 than for y1 or y3 because y2 +C has much smaller values. At the end of the run, statistical +C quantities of interest are printed. +C +C EXTERNAL FEX, JEX +C INTEGER IOPT, IOUT, ISTATE, ITASK, ITOL, IWORK(23), LIW, LRW, +C * MF, NEQ +C REAL ATOL(3), RTOL, RWORK(58), T, TOUT, Y(3) +C NEQ = 3 +C Y(1) = 1. +C Y(2) = 0. +C Y(3) = 0. +C T = 0. +C TOUT = .4 +C ITOL = 2 +C RTOL = 1.E-4 +C ATOL(1) = 1.E-6 +C ATOL(2) = 1.E-10 +C ATOL(3) = 1.E-6 +C ITASK = 1 +C ISTATE = 1 +C IOPT = 0 +C LRW = 58 +C LIW = 23 +C MF = 21 +C DO 40 IOUT = 1,12 +C CALL SLSODE (FEX, NEQ, Y, T, TOUT, ITOL, RTOL, ATOL, ITASK, +C * ISTATE, IOPT, RWORK, LRW, IWORK, LIW, JEX, MF) +C WRITE(6,20) T, Y(1), Y(2), Y(3) +C 20 FORMAT(' At t =',E12.4,' y =',3E14.6) +C IF (ISTATE .LT. 0) GO TO 80 +C 40 TOUT = TOUT*10. +C WRITE(6,60) IWORK(11), IWORK(12), IWORK(13) +C 60 FORMAT(/' No. steps =',i4,', No. f-s =',i4,', No. J-s =',i4) +C STOP +C 80 WRITE(6,90) ISTATE +C 90 FORMAT(///' Error halt.. ISTATE =',I3) +C STOP +C END +C +C SUBROUTINE FEX (NEQ, T, Y, YDOT) +C INTEGER NEQ +C REAL T, Y(3), YDOT(3) +C YDOT(1) = -.04*Y(1) + 1.E4*Y(2)*Y(3) +C YDOT(3) = 3.E7*Y(2)*Y(2) +C YDOT(2) = -YDOT(1) - YDOT(3) +C RETURN +C END +C +C SUBROUTINE JEX (NEQ, T, Y, ML, MU, PD, NRPD) +C INTEGER NEQ, ML, MU, NRPD +C REAL T, Y(3), PD(NRPD,3) +C PD(1,1) = -.04 +C PD(1,2) = 1.E4*Y(3) +C PD(1,3) = 1.E4*Y(2) +C PD(2,1) = .04 +C PD(2,3) = -PD(1,3) +C PD(3,2) = 6.E7*Y(2) +C PD(2,2) = -PD(1,2) - PD(3,2) +C RETURN +C END +C +C The output from this program (on a Cray-1 in single precision) +C is as follows. +C +C At t = 4.0000e-01 y = 9.851726e-01 3.386406e-05 1.479357e-02 +C At t = 4.0000e+00 y = 9.055142e-01 2.240418e-05 9.446344e-02 +C At t = 4.0000e+01 y = 7.158050e-01 9.184616e-06 2.841858e-01 +C At t = 4.0000e+02 y = 4.504846e-01 3.222434e-06 5.495122e-01 +C At t = 4.0000e+03 y = 1.831701e-01 8.940379e-07 8.168290e-01 +C At t = 4.0000e+04 y = 3.897016e-02 1.621193e-07 9.610297e-01 +C At t = 4.0000e+05 y = 4.935213e-03 1.983756e-08 9.950648e-01 +C At t = 4.0000e+06 y = 5.159269e-04 2.064759e-09 9.994841e-01 +C At t = 4.0000e+07 y = 5.306413e-05 2.122677e-10 9.999469e-01 +C At t = 4.0000e+08 y = 5.494530e-06 2.197825e-11 9.999945e-01 +C At t = 4.0000e+09 y = 5.129458e-07 2.051784e-12 9.999995e-01 +C At t = 4.0000e+10 y = -7.170603e-08 -2.868241e-13 1.000000e+00 +C +C No. steps = 330, No. f-s = 405, No. J-s = 69 +C +C *Accuracy: +C The accuracy of the solution depends on the choice of tolerances +C RTOL and ATOL. Actual (global) errors may exceed these local +C tolerances, so choose them conservatively. +C +C *Cautions: +C The work arrays should not be altered between calls to SLSODE for +C the same problem, except possibly for the conditional and optional +C inputs. +C +C *Portability: +C Since NEQ is dimensioned inside SLSODE, some compilers may object +C to a call to SLSODE with NEQ a scalar variable. In this event, +C use DIMENSION NEQ(1). Similar remarks apply to RTOL and ATOL. +C +C Note to Cray users: +C For maximum efficiency, use the CFT77 compiler. Appropriate +C compiler optimization directives have been inserted for CFT77. +C +C *Reference: +C Alan C. Hindmarsh, "ODEPACK, A Systematized Collection of ODE +C Solvers," in Scientific Computing, R. S. Stepleman, et al., Eds. +C (North-Holland, Amsterdam, 1983), pp. 55-64. +C +C *Long Description: +C The following complete description of the user interface to +C SLSODE consists of four parts: +C +C 1. The call sequence to subroutine SLSODE, which is a driver +C routine for the solver. This includes descriptions of both +C the call sequence arguments and user-supplied routines. +C Following these descriptions is a description of optional +C inputs available through the call sequence, and then a +C description of optional outputs in the work arrays. +C +C 2. Descriptions of other routines in the SLSODE package that may +C be (optionally) called by the user. These provide the ability +C to alter error message handling, save and restore the internal +C COMMON, and obtain specified derivatives of the solution y(t). +C +C 3. Descriptions of COMMON block to be declared in overlay or +C similar environments, or to be saved when doing an interrupt +C of the problem and continued solution later. +C +C 4. Description of two routines in the SLSODE package, either of +C which the user may replace with his own version, if desired. +C These relate to the measurement of errors. +C +C +C Part 1. Call Sequence +C ---------------------- +C +C Arguments +C --------- +C The call sequence parameters used for input only are +C +C F, NEQ, TOUT, ITOL, RTOL, ATOL, ITASK, IOPT, LRW, LIW, JAC, MF, +C +C and those used for both input and output are +C +C Y, T, ISTATE. +C +C The work arrays RWORK and IWORK are also used for conditional and +C optional inputs and optional outputs. (The term output here +C refers to the return from subroutine SLSODE to the user's calling +C program.) +C +C The legality of input parameters will be thoroughly checked on the +C initial call for the problem, but not checked thereafter unless a +C change in input parameters is flagged by ISTATE = 3 on input. +C +C The descriptions of the call arguments are as follows. +C +C F The name of the user-supplied subroutine defining the ODE +C system. The system must be put in the first-order form +C dy/dt = f(t,y), where f is a vector-valued function of +C the scalar t and the vector y. Subroutine F is to compute +C the function f. It is to have the form +C +C SUBROUTINE F (NEQ, T, Y, YDOT) +C REAL T, Y(*), YDOT(*) +C +C where NEQ, T, and Y are input, and the array YDOT = +C f(T,Y) is output. Y and YDOT are arrays of length NEQ. +C Subroutine F should not alter Y(1),...,Y(NEQ). F must be +C declared EXTERNAL in the calling program. +C +C Subroutine F may access user-defined quantities in +C NEQ(2),... and/or in Y(NEQ(1)+1),..., if NEQ is an array +C (dimensioned in F) and/or Y has length exceeding NEQ(1). +C See the descriptions of NEQ and Y below. +C +C If quantities computed in the F routine are needed +C externally to SLSODE, an extra call to F should be made +C for this purpose, for consistent and accurate results. +C If only the derivative dy/dt is needed, use SINTDY +C instead. +C +C NEQ The size of the ODE system (number of first-order +C ordinary differential equations). Used only for input. +C NEQ may be decreased, but not increased, during the +C problem. If NEQ is decreased (with ISTATE = 3 on input), +C the remaining components of Y should be left undisturbed, +C if these are to be accessed in F and/or JAC. +C +C Normally, NEQ is a scalar, and it is generally referred +C to as a scalar in this user interface description. +C However, NEQ may be an array, with NEQ(1) set to the +C system size. (The SLSODE package accesses only NEQ(1).) +C In either case, this parameter is passed as the NEQ +C argument in all calls to F and JAC. Hence, if it is an +C array, locations NEQ(2),... may be used to store other +C integer data and pass it to F and/or JAC. Subroutines +C F and/or JAC must include NEQ in a DIMENSION statement +C in that case. +C +C Y A real array for the vector of dependent variables, of +C length NEQ or more. Used for both input and output on +C the first call (ISTATE = 1), and only for output on +C other calls. On the first call, Y must contain the +C vector of initial values. On output, Y contains the +C computed solution vector, evaluated at T. If desired, +C the Y array may be used for other purposes between +C calls to the solver. +C +C This array is passed as the Y argument in all calls to F +C and JAC. Hence its length may exceed NEQ, and locations +C Y(NEQ+1),... may be used to store other real data and +C pass it to F and/or JAC. (The SLSODE package accesses +C only Y(1),...,Y(NEQ).) +C +C T The independent variable. On input, T is used only on +C the first call, as the initial point of the integration. +C On output, after each call, T is the value at which a +C computed solution Y is evaluated (usually the same as +C TOUT). On an error return, T is the farthest point +C reached. +C +C TOUT The next value of T at which a computed solution is +C desired. Used only for input. +C +C When starting the problem (ISTATE = 1), TOUT may be equal +C to T for one call, then should not equal T for the next +C call. For the initial T, an input value of TOUT .NE. T +C is used in order to determine the direction of the +C integration (i.e., the algebraic sign of the step sizes) +C and the rough scale of the problem. Integration in +C either direction (forward or backward in T) is permitted. +C +C If ITASK = 2 or 5 (one-step modes), TOUT is ignored +C after the first call (i.e., the first call with +C TOUT .NE. T). Otherwise, TOUT is required on every call. +C +C If ITASK = 1, 3, or 4, the values of TOUT need not be +C monotone, but a value of TOUT which backs up is limited +C to the current internal T interval, whose endpoints are +C TCUR - HU and TCUR. (See "Optional Outputs" below for +C TCUR and HU.) +C +C +C ITOL An indicator for the type of error control. See +C description below under ATOL. Used only for input. +C +C RTOL A relative error tolerance parameter, either a scalar or +C an array of length NEQ. See description below under +C ATOL. Input only. +C +C ATOL An absolute error tolerance parameter, either a scalar or +C an array of length NEQ. Input only. +C +C The input parameters ITOL, RTOL, and ATOL determine the +C error control performed by the solver. The solver will +C control the vector e = (e(i)) of estimated local errors +C in Y, according to an inequality of the form +C +C rms-norm of ( e(i)/EWT(i) ) <= 1, +C +C where +C +C EWT(i) = RTOL(i)*ABS(Y(i)) + ATOL(i), +C +C and the rms-norm (root-mean-square norm) here is +C +C rms-norm(v) = SQRT(sum v(i)**2 / NEQ). +C +C Here EWT = (EWT(i)) is a vector of weights which must +C always be positive, and the values of RTOL and ATOL +C should all be nonnegative. The following table gives the +C types (scalar/array) of RTOL and ATOL, and the +C corresponding form of EWT(i). +C +C ITOL RTOL ATOL EWT(i) +C ---- ------ ------ ----------------------------- +C 1 scalar scalar RTOL*ABS(Y(i)) + ATOL +C 2 scalar array RTOL*ABS(Y(i)) + ATOL(i) +C 3 array scalar RTOL(i)*ABS(Y(i)) + ATOL +C 4 array array RTOL(i)*ABS(Y(i)) + ATOL(i) +C +C When either of these parameters is a scalar, it need not +C be dimensioned in the user's calling program. +C +C If none of the above choices (with ITOL, RTOL, and ATOL +C fixed throughout the problem) is suitable, more general +C error controls can be obtained by substituting +C user-supplied routines for the setting of EWT and/or for +C the norm calculation. See Part 4 below. +C +C If global errors are to be estimated by making a repeated +C run on the same problem with smaller tolerances, then all +C components of RTOL and ATOL (i.e., of EWT) should be +C scaled down uniformly. +C +C ITASK An index specifying the task to be performed. Input +C only. ITASK has the following values and meanings: +C 1 Normal computation of output values of y(t) at +C t = TOUT (by overshooting and interpolating). +C 2 Take one step only and return. +C 3 Stop at the first internal mesh point at or beyond +C t = TOUT and return. +C 4 Normal computation of output values of y(t) at +C t = TOUT but without overshooting t = TCRIT. TCRIT +C must be input as RWORK(1). TCRIT may be equal to or +C beyond TOUT, but not behind it in the direction of +C integration. This option is useful if the problem +C has a singularity at or beyond t = TCRIT. +C 5 Take one step, without passing TCRIT, and return. +C TCRIT must be input as RWORK(1). +C +C Note: If ITASK = 4 or 5 and the solver reaches TCRIT +C (within roundoff), it will return T = TCRIT (exactly) to +C indicate this (unless ITASK = 4 and TOUT comes before +C TCRIT, in which case answers at T = TOUT are returned +C first). +C +C ISTATE An index used for input and output to specify the state +C of the calculation. +C +C On input, the values of ISTATE are as follows: +C 1 This is the first call for the problem +C (initializations will be done). See "Note" below. +C 2 This is not the first call, and the calculation is to +C continue normally, with no change in any input +C parameters except possibly TOUT and ITASK. (If ITOL, +C RTOL, and/or ATOL are changed between calls with +C ISTATE = 2, the new values will be used but not +C tested for legality.) +C 3 This is not the first call, and the calculation is to +C continue normally, but with a change in input +C parameters other than TOUT and ITASK. Changes are +C allowed in NEQ, ITOL, RTOL, ATOL, IOPT, LRW, LIW, MF, +C ML, MU, and any of the optional inputs except H0. +C (See IWORK description for ML and MU.) +C +C Note: A preliminary call with TOUT = T is not counted as +C a first call here, as no initialization or checking of +C input is done. (Such a call is sometimes useful for the +C purpose of outputting the initial conditions.) Thus the +C first call for which TOUT .NE. T requires ISTATE = 1 on +C input. +C +C On output, ISTATE has the following values and meanings: +C 1 Nothing was done, as TOUT was equal to T with +C ISTATE = 1 on input. +C 2 The integration was performed successfully. +C -1 An excessive amount of work (more than MXSTEP steps) +C was done on this call, before completing the +C requested task, but the integration was otherwise +C successful as far as T. (MXSTEP is an optional input +C and is normally 500.) To continue, the user may +C simply reset ISTATE to a value >1 and call again (the +C excess work step counter will be reset to 0). In +C addition, the user may increase MXSTEP to avoid this +C error return; see "Optional Inputs" below. +C -2 Too much accuracy was requested for the precision of +C the machine being used. This was detected before +C completing the requested task, but the integration +C was successful as far as T. To continue, the +C tolerance parameters must be reset, and ISTATE must +C be set to 3. The optional output TOLSF may be used +C for this purpose. (Note: If this condition is +C detected before taking any steps, then an illegal +C input return (ISTATE = -3) occurs instead.) +C -3 Illegal input was detected, before taking any +C integration steps. See written message for details. +C (Note: If the solver detects an infinite loop of +C calls to the solver with illegal input, it will cause +C the run to stop.) +C -4 There were repeated error-test failures on one +C attempted step, before completing the requested task, +C but the integration was successful as far as T. The +C problem may have a singularity, or the input may be +C inappropriate. +C -5 There were repeated convergence-test failures on one +C attempted step, before completing the requested task, +C but the integration was successful as far as T. This +C may be caused by an inaccurate Jacobian matrix, if +C one is being used. +C -6 EWT(i) became zero for some i during the integration. +C Pure relative error control (ATOL(i)=0.0) was +C requested on a variable which has now vanished. The +C integration was successful as far as T. +C +C Note: Since the normal output value of ISTATE is 2, it +C does not need to be reset for normal continuation. Also, +C since a negative input value of ISTATE will be regarded +C as illegal, a negative output value requires the user to +C change it, and possibly other inputs, before calling the +C solver again. +C +C IOPT An integer flag to specify whether any optional inputs +C are being used on this call. Input only. The optional +C inputs are listed under a separate heading below. +C 0 No optional inputs are being used. Default values +C will be used in all cases. +C 1 One or more optional inputs are being used. +C +C RWORK A real working array (single precision). The length of +C RWORK must be at least +C +C 20 + NYH*(MAXORD + 1) + 3*NEQ + LWM +C +C where +C NYH = the initial value of NEQ, +C MAXORD = 12 (if METH = 1) or 5 (if METH = 2) (unless a +C smaller value is given as an optional input), +C LWM = 0 if MITER = 0, +C LWM = NEQ**2 + 2 if MITER = 1 or 2, +C LWM = NEQ + 2 if MITER = 3, and +C LWM = (2*ML + MU + 1)*NEQ + 2 +C if MITER = 4 or 5. +C (See the MF description below for METH and MITER.) +C +C Thus if MAXORD has its default value and NEQ is constant, +C this length is: +C 20 + 16*NEQ for MF = 10, +C 22 + 16*NEQ + NEQ**2 for MF = 11 or 12, +C 22 + 17*NEQ for MF = 13, +C 22 + 17*NEQ + (2*ML + MU)*NEQ for MF = 14 or 15, +C 20 + 9*NEQ for MF = 20, +C 22 + 9*NEQ + NEQ**2 for MF = 21 or 22, +C 22 + 10*NEQ for MF = 23, +C 22 + 10*NEQ + (2*ML + MU)*NEQ for MF = 24 or 25. +C +C The first 20 words of RWORK are reserved for conditional +C and optional inputs and optional outputs. +C +C The following word in RWORK is a conditional input: +C RWORK(1) = TCRIT, the critical value of t which the +C solver is not to overshoot. Required if ITASK +C is 4 or 5, and ignored otherwise. See ITASK. +C +C LRW The length of the array RWORK, as declared by the user. +C (This will be checked by the solver.) +C +C IWORK An integer work array. Its length must be at least +C 20 if MITER = 0 or 3 (MF = 10, 13, 20, 23), or +C 20 + NEQ otherwise (MF = 11, 12, 14, 15, 21, 22, 24, 25). +C (See the MF description below for MITER.) The first few +C words of IWORK are used for conditional and optional +C inputs and optional outputs. +C +C The following two words in IWORK are conditional inputs: +C IWORK(1) = ML These are the lower and upper half- +C IWORK(2) = MU bandwidths, respectively, of the banded +C Jacobian, excluding the main diagonal. +C The band is defined by the matrix locations +C (i,j) with i - ML <= j <= i + MU. ML and MU +C must satisfy 0 <= ML,MU <= NEQ - 1. These are +C required if MITER is 4 or 5, and ignored +C otherwise. ML and MU may in fact be the band +C parameters for a matrix to which df/dy is only +C approximately equal. +C +C LIW The length of the array IWORK, as declared by the user. +C (This will be checked by the solver.) +C +C Note: The work arrays must not be altered between calls to SLSODE +C for the same problem, except possibly for the conditional and +C optional inputs, and except for the last 3*NEQ words of RWORK. +C The latter space is used for internal scratch space, and so is +C available for use by the user outside SLSODE between calls, if +C desired (but not for use by F or JAC). +C +C JAC The name of the user-supplied routine (MITER = 1 or 4) to +C compute the Jacobian matrix, df/dy, as a function of the +C scalar t and the vector y. (See the MF description below +C for MITER.) It is to have the form +C +C SUBROUTINE JAC (NEQ, T, Y, ML, MU, PD, NROWPD) +C REAL T, Y(*), PD(NROWPD,*) +C +C where NEQ, T, Y, ML, MU, and NROWPD are input and the +C array PD is to be loaded with partial derivatives +C (elements of the Jacobian matrix) on output. PD must be +C given a first dimension of NROWPD. T and Y have the same +C meaning as in subroutine F. +C +C In the full matrix case (MITER = 1), ML and MU are +C ignored, and the Jacobian is to be loaded into PD in +C columnwise manner, with df(i)/dy(j) loaded into PD(i,j). +C +C In the band matrix case (MITER = 4), the elements within +C the band are to be loaded into PD in columnwise manner, +C with diagonal lines of df/dy loaded into the rows of PD. +C Thus df(i)/dy(j) is to be loaded into PD(i-j+MU+1,j). ML +C and MU are the half-bandwidth parameters (see IWORK). +C The locations in PD in the two triangular areas which +C correspond to nonexistent matrix elements can be ignored +C or loaded arbitrarily, as they are overwritten by SLSODE. +C +C JAC need not provide df/dy exactly. A crude approximation +C (possibly with a smaller bandwidth) will do. +C +C In either case, PD is preset to zero by the solver, so +C that only the nonzero elements need be loaded by JAC. +C Each call to JAC is preceded by a call to F with the same +C arguments NEQ, T, and Y. Thus to gain some efficiency, +C intermediate quantities shared by both calculations may +C be saved in a user COMMON block by F and not recomputed +C by JAC, if desired. Also, JAC may alter the Y array, if +C desired. JAC must be declared EXTERNAL in the calling +C program. +C +C Subroutine JAC may access user-defined quantities in +C NEQ(2),... and/or in Y(NEQ(1)+1),... if NEQ is an array +C (dimensioned in JAC) and/or Y has length exceeding +C NEQ(1). See the descriptions of NEQ and Y above. +C +C MF The method flag. Used only for input. The legal values +C of MF are 10, 11, 12, 13, 14, 15, 20, 21, 22, 23, 24, +C and 25. MF has decimal digits METH and MITER: +C MF = 10*METH + MITER . +C +C METH indicates the basic linear multistep method: +C 1 Implicit Adams method. +C 2 Method based on backward differentiation formulas +C (BDF's). +C +C MITER indicates the corrector iteration method: +C 0 Functional iteration (no Jacobian matrix is +C involved). +C 1 Chord iteration with a user-supplied full (NEQ by +C NEQ) Jacobian. +C 2 Chord iteration with an internally generated +C (difference quotient) full Jacobian (using NEQ +C extra calls to F per df/dy value). +C 3 Chord iteration with an internally generated +C diagonal Jacobian approximation (using one extra call +C to F per df/dy evaluation). +C 4 Chord iteration with a user-supplied banded Jacobian. +C 5 Chord iteration with an internally generated banded +C Jacobian (using ML + MU + 1 extra calls to F per +C df/dy evaluation). +C +C If MITER = 1 or 4, the user must supply a subroutine JAC +C (the name is arbitrary) as described above under JAC. +C For other values of MITER, a dummy argument can be used. +C +C Optional Inputs +C --------------- +C The following is a list of the optional inputs provided for in the +C call sequence. (See also Part 2.) For each such input variable, +C this table lists its name as used in this documentation, its +C location in the call sequence, its meaning, and the default value. +C The use of any of these inputs requires IOPT = 1, and in that case +C all of these inputs are examined. A value of zero for any of +C these optional inputs will cause the default value to be used. +C Thus to use a subset of the optional inputs, simply preload +C locations 5 to 10 in RWORK and IWORK to 0.0 and 0 respectively, +C and then set those of interest to nonzero values. +C +C Name Location Meaning and default value +C ------ --------- ----------------------------------------------- +C H0 RWORK(5) Step size to be attempted on the first step. +C The default value is determined by the solver. +C HMAX RWORK(6) Maximum absolute step size allowed. The +C default value is infinite. +C HMIN RWORK(7) Minimum absolute step size allowed. The +C default value is 0. (This lower bound is not +C enforced on the final step before reaching +C TCRIT when ITASK = 4 or 5.) +C MAXORD IWORK(5) Maximum order to be allowed. The default value +C is 12 if METH = 1, and 5 if METH = 2. (See the +C MF description above for METH.) If MAXORD +C exceeds the default value, it will be reduced +C to the default value. If MAXORD is changed +C during the problem, it may cause the current +C order to be reduced. +C MXSTEP IWORK(6) Maximum number of (internally defined) steps +C allowed during one call to the solver. The +C default value is 500. +C MXHNIL IWORK(7) Maximum number of messages printed (per +C problem) warning that T + H = T on a step +C (H = step size). This must be positive to +C result in a nondefault value. The default +C value is 10. +C +C Optional Outputs +C ---------------- +C As optional additional output from SLSODE, the variables listed +C below are quantities related to the performance of SLSODE which +C are available to the user. These are communicated by way of the +C work arrays, but also have internal mnemonic names as shown. +C Except where stated otherwise, all of these outputs are defined on +C any successful return from SLSODE, and on any return with ISTATE = +C -1, -2, -4, -5, or -6. On an illegal input return (ISTATE = -3), +C they will be unchanged from their existing values (if any), except +C possibly for TOLSF, LENRW, and LENIW. On any error return, +C outputs relevant to the error will be defined, as noted below. +C +C Name Location Meaning +C ----- --------- ------------------------------------------------ +C HU RWORK(11) Step size in t last used (successfully). +C HCUR RWORK(12) Step size to be attempted on the next step. +C TCUR RWORK(13) Current value of the independent variable which +C the solver has actually reached, i.e., the +C current internal mesh point in t. On output, +C TCUR will always be at least as far as the +C argument T, but may be farther (if interpolation +C was done). +C TOLSF RWORK(14) Tolerance scale factor, greater than 1.0, +C computed when a request for too much accuracy +C was detected (ISTATE = -3 if detected at the +C start of the problem, ISTATE = -2 otherwise). +C If ITOL is left unaltered but RTOL and ATOL are +C uniformly scaled up by a factor of TOLSF for the +C next call, then the solver is deemed likely to +C succeed. (The user may also ignore TOLSF and +C alter the tolerance parameters in any other way +C appropriate.) +C NST IWORK(11) Number of steps taken for the problem so far. +C NFE IWORK(12) Number of F evaluations for the problem so far. +C NJE IWORK(13) Number of Jacobian evaluations (and of matrix LU +C decompositions) for the problem so far. +C NQU IWORK(14) Method order last used (successfully). +C NQCUR IWORK(15) Order to be attempted on the next step. +C IMXER IWORK(16) Index of the component of largest magnitude in +C the weighted local error vector ( e(i)/EWT(i) ), +C on an error return with ISTATE = -4 or -5. +C LENRW IWORK(17) Length of RWORK actually required. This is +C defined on normal returns and on an illegal +C input return for insufficient storage. +C LENIW IWORK(18) Length of IWORK actually required. This is +C defined on normal returns and on an illegal +C input return for insufficient storage. +C +C The following two arrays are segments of the RWORK array which may +C also be of interest to the user as optional outputs. For each +C array, the table below gives its internal name, its base address +C in RWORK, and its description. +C +C Name Base address Description +C ---- ------------ ---------------------------------------------- +C YH 21 The Nordsieck history array, of size NYH by +C (NQCUR + 1), where NYH is the initial value of +C NEQ. For j = 0,1,...,NQCUR, column j + 1 of +C YH contains HCUR**j/factorial(j) times the jth +C derivative of the interpolating polynomial +C currently representing the solution, evaluated +C at t = TCUR. +C ACOR LENRW-NEQ+1 Array of size NEQ used for the accumulated +C corrections on each step, scaled on output to +C represent the estimated local error in Y on +C the last step. This is the vector e in the +C description of the error control. It is +C defined only on successful return from SLSODE. +C +C +C Part 2. Other Callable Routines +C -------------------------------- +C +C The following are optional calls which the user may make to gain +C additional capabilities in conjunction with SLSODE. +C +C Form of call Function +C ------------------------ ---------------------------------------- +C CALL XSETUN(LUN) Set the logical unit number, LUN, for +C output of messages from SLSODE, if the +C default is not desired. The default +C value of LUN is 6. This call may be made +C at any time and will take effect +C immediately. +C CALL XSETF(MFLAG) Set a flag to control the printing of +C messages by SLSODE. MFLAG = 0 means do +C not print. (Danger: this risks losing +C valuable information.) MFLAG = 1 means +C print (the default). This call may be +C made at any time and will take effect +C immediately. +C CALL SSRCOM(RSAV,ISAV,JOB) Saves and restores the contents of the +C internal COMMON blocks used by SLSODE +C (see Part 3 below). RSAV must be a +C real array of length 218 or more, and +C ISAV must be an integer array of length +C 37 or more. JOB = 1 means save COMMON +C into RSAV/ISAV. JOB = 2 means restore +C COMMON from same. SSRCOM is useful if +C one is interrupting a run and restarting +C later, or alternating between two or +C more problems solved with SLSODE. +C CALL SINTDY(,,,,,) Provide derivatives of y, of various +C (see below) orders, at a specified point t, if +C desired. It may be called only after a +C successful return from SLSODE. Detailed +C instructions follow. +C +C Detailed instructions for using SINTDY +C -------------------------------------- +C The form of the CALL is: +C +C CALL SINTDY (T, K, RWORK(21), NYH, DKY, IFLAG) +C +C The input parameters are: +C +C T Value of independent variable where answers are +C desired (normally the same as the T last returned by +C SLSODE). For valid results, T must lie between +C TCUR - HU and TCUR. (See "Optional Outputs" above +C for TCUR and HU.) +C K Integer order of the derivative desired. K must +C satisfy 0 <= K <= NQCUR, where NQCUR is the current +C order (see "Optional Outputs"). The capability +C corresponding to K = 0, i.e., computing y(t), is +C already provided by SLSODE directly. Since +C NQCUR >= 1, the first derivative dy/dt is always +C available with SINTDY. +C RWORK(21) The base address of the history array YH. +C NYH Column length of YH, equal to the initial value of NEQ. +C +C The output parameters are: +C +C DKY Real array of length NEQ containing the computed value +C of the Kth derivative of y(t). +C IFLAG Integer flag, returned as 0 if K and T were legal, +C -1 if K was illegal, and -2 if T was illegal. +C On an error return, a message is also written. +C +C +C Part 3. Common Blocks +C ---------------------- +C +C If SLSODE is to be used in an overlay situation, the user must +C declare, in the primary overlay, the variables in: +C (1) the call sequence to SLSODE, +C (2) the internal COMMON block /SLS001/, of length 255 +C (218 single precision words followed by 37 integer words). +C +C If SLSODE is used on a system in which the contents of internal +C COMMON blocks are not preserved between calls, the user should +C declare the above COMMON block in his main program to insure that +C its contents are preserved. +C +C If the solution of a given problem by SLSODE is to be interrupted +C and then later continued, as when restarting an interrupted run or +C alternating between two or more problems, the user should save, +C following the return from the last SLSODE call prior to the +C interruption, the contents of the call sequence variables and the +C internal COMMON block, and later restore these values before the +C next SLSODE call for that problem. In addition, if XSETUN and/or +C XSETF was called for non-default handling of error messages, then +C these calls must be repeated. To save and restore the COMMON +C block, use subroutine SSRCOM (see Part 2 above). +C +C +C Part 4. Optionally Replaceable Solver Routines +C ----------------------------------------------- +C +C Below are descriptions of two routines in the SLSODE package which +C relate to the measurement of errors. Either routine can be +C replaced by a user-supplied version, if desired. However, since +C such a replacement may have a major impact on performance, it +C should be done only when absolutely necessary, and only with great +C caution. (Note: The means by which the package version of a +C routine is superseded by the user's version may be system- +C dependent.) +C +C SEWSET +C ------ +C The following subroutine is called just before each internal +C integration step, and sets the array of error weights, EWT, as +C described under ITOL/RTOL/ATOL above: +C +C SUBROUTINE SEWSET (NEQ, ITOL, RTOL, ATOL, YCUR, EWT) +C +C where NEQ, ITOL, RTOL, and ATOL are as in the SLSODE call +C sequence, YCUR contains the current dependent variable vector, +C and EWT is the array of weights set by SEWSET. +C +C If the user supplies this subroutine, it must return in EWT(i) +C (i = 1,...,NEQ) a positive quantity suitable for comparing errors +C in Y(i) to. The EWT array returned by SEWSET is passed to the +C SVNORM routine (see below), and also used by SLSODE in the +C computation of the optional output IMXER, the diagonal Jacobian +C approximation, and the increments for difference quotient +C Jacobians. +C +C In the user-supplied version of SEWSET, it may be desirable to use +C the current values of derivatives of y. Derivatives up to order NQ +C are available from the history array YH, described above under +C optional outputs. In SEWSET, YH is identical to the YCUR array, +C extended to NQ + 1 columns with a column length of NYH and scale +C factors of H**j/factorial(j). On the first call for the problem, +C given by NST = 0, NQ is 1 and H is temporarily set to 1.0. +C NYH is the initial value of NEQ. The quantities NQ, H, and NST +C can be obtained by including in SEWSET the statements: +C REAL RLS +C COMMON /SLS001/ RLS(218),ILS(37) +C NQ = ILS(33) +C NST = ILS(34) +C H = RLS(212) +C Thus, for example, the current value of dy/dt can be obtained as +C YCUR(NYH+i)/H (i=1,...,NEQ) (and the division by H is unnecessary +C when NST = 0). +C +C SVNORM +C ------ +C SVNORM is a real function routine which computes the weighted +C root-mean-square norm of a vector v: +C +C d = SVNORM (n, v, w) +C +C where: +C n = the length of the vector, +C v = real array of length n containing the vector, +C w = real array of length n containing weights, +C d = SQRT( (1/n) * sum(v(i)*w(i))**2 ). +C +C SVNORM is called with n = NEQ and with w(i) = 1.0/EWT(i), where +C EWT is as set by subroutine SEWSET. +C +C If the user supplies this function, it should return a nonnegative +C value of SVNORM suitable for use in the error control in SLSODE. +C None of the arguments should be altered by SVNORM. For example, a +C user-supplied SVNORM routine might: +C - Substitute a max-norm of (v(i)*w(i)) for the rms-norm, or +C - Ignore some components of v in the norm, with the effect of +C suppressing the error control on those components of Y. +C --------------------------------------------------------------------- +C***ROUTINES CALLED SEWSET, SINTDY, R1MACH, SSTODE, SVNORM, XERRWD +C***COMMON BLOCKS SLS001 +C***REVISION HISTORY (YYYYMMDD) +C 19791129 DATE WRITTEN +C 19791213 Minor changes to declarations; DELP init. in STODE. +C 19800118 Treat NEQ as array; integer declarations added throughout; +C minor changes to prologue. +C 19800306 Corrected TESCO(1,NQP1) setting in CFODE. +C 19800519 Corrected access of YH on forced order reduction; +C numerous corrections to prologues and other comments. +C 19800617 In main driver, added loading of SQRT(UROUND) in RWORK; +C minor corrections to main prologue. +C 19800923 Added zero initialization of HU and NQU. +C 19801218 Revised XERRWV routine; minor corrections to main prologue. +C 19810401 Minor changes to comments and an error message. +C 19810814 Numerous revisions: replaced EWT by 1/EWT; used flags +C JCUR, ICF, IERPJ, IERSL between STODE and subordinates; +C added tuning parameters CCMAX, MAXCOR, MSBP, MXNCF; +C reorganized returns from STODE; reorganized type decls.; +C fixed message length in XERRWV; changed default LUNIT to 6; +C changed Common lengths; changed comments throughout. +C 19870330 Major update by ACH: corrected comments throughout; +C removed TRET from Common; rewrote EWSET with 4 loops; +C fixed t test in INTDY; added Cray directives in STODE; +C in STODE, fixed DELP init. and logic around PJAC call; +C combined routines to save/restore Common; +C passed LEVEL = 0 in error message calls (except run abort). +C 19890426 Modified prologue to SLATEC/LDOC format. (FNF) +C 19890501 Many improvements to prologue. (FNF) +C 19890503 A few final corrections to prologue. (FNF) +C 19890504 Minor cosmetic changes. (FNF) +C 19890510 Corrected description of Y in Arguments section. (FNF) +C 19890517 Minor corrections to prologue. (FNF) +C 19920514 Updated with prologue edited 891025 by G. Shaw for manual. +C 19920515 Converted source lines to upper case. (FNF) +C 19920603 Revised XERRWV calls using mixed upper-lower case. (ACH) +C 19920616 Revised prologue comment regarding CFT. (ACH) +C 19921116 Revised prologue comments regarding Common. (ACH). +C 19930326 Added comment about non-reentrancy. (FNF) +C 19930723 Changed R1MACH to RUMACH. (FNF) +C 19930801 Removed ILLIN and NTREP from Common (affects driver logic); +C minor changes to prologue and internal comments; +C changed Hollerith strings to quoted strings; +C changed internal comments to mixed case; +C replaced XERRWV with new version using character type; +C changed dummy dimensions from 1 to *. (ACH) +C 19930809 Changed to generic intrinsic names; changed names of +C subprograms and Common blocks to SLSODE etc. (ACH) +C 19930929 Eliminated use of REAL intrinsic; other minor changes. (ACH) +C 20010412 Removed all 'own' variables from Common block /SLS001/ +C (affects declarations in 6 routines). (ACH) +C 20010509 Minor corrections to prologue. (ACH) +C 20031105 Restored 'own' variables to Common block /SLS001/, to +C enable interrupt/restart feature. (ACH) +C 20031112 Added SAVE statements for data-loaded constants. +C +C*** END PROLOGUE SLSODE +C +C*Internal Notes: +C +C Other Routines in the SLSODE Package. +C +C In addition to Subroutine SLSODE, the SLSODE package includes the +C following subroutines and function routines: +C SINTDY computes an interpolated value of the y vector at t = TOUT. +C SSTODE is the core integrator, which does one step of the +C integration and the associated error control. +C SCFODE sets all method coefficients and test constants. +C SPREPJ computes and preprocesses the Jacobian matrix J = df/dy +C and the Newton iteration matrix P = I - h*l0*J. +C SSOLSY manages solution of linear system in chord iteration. +C SEWSET sets the error weight vector EWT before each step. +C SVNORM computes the weighted R.M.S. norm of a vector. +C SSRCOM is a user-callable routine to save and restore +C the contents of the internal Common block. +C DGETRF AND DGETRS ARE ROUTINES FROM LAPACK FOR SOLVING FULL +C SYSTEMS OF LINEAR ALGEBRAIC EQUATIONS. +C DGBTRF AND DGBTRS ARE ROUTINES FROM LAPACK FOR SOLVING BANDED +C LINEAR SYSTEMS. +C R1MACH computes the unit roundoff in a machine-independent manner. +C XERRWD, XSETUN, XSETF, IXSAV, IUMACH handle the printing of all +C error messages and warnings. XERRWD is machine-dependent. +C Note: SVNORM, R1MACH, IXSAV, and IUMACH are function routines. +C All the others are subroutines. +C +C**End +C +C Declare externals. + EXTERNAL SPREPJ, SSOLSY + REAL R1MACH, SVNORM +C +C Declare all other variables. + INTEGER INIT, MXSTEP, MXHNIL, NHNIL, NSLAST, NYH, + 1 IALTH, IPUP, LMAX, MEO, NQNYH, NSLP, + 1 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, + 2 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, + 3 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU + INTEGER I, I1, I2, IFLAG, IMXER, KGO, LF0, + 1 LENIW, LENRW, LENWM, ML, MORD, MU, MXHNL0, MXSTP0 + REAL CONIT, CRATE, EL, ELCO, HOLD, RMAX, TESCO, + 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND + REAL ATOLI, AYI, BIG, EWTI, H0, HMAX, HMX, RH, RTOLI, + 1 TCRIT, TDIST, TNEXT, TOL, TOLSF, TP, SIZE, SUM, W0 + DIMENSION MORD(2) + LOGICAL IHIT + CHARACTER*80 MSG + SAVE MORD, MXSTP0, MXHNL0 +C----------------------------------------------------------------------- +C The following internal Common block contains +C (a) variables which are local to any subroutine but whose values must +C be preserved between calls to the routine ("own" variables), and +C (b) variables which are communicated between subroutines. +C The block SLS001 is declared in subroutines SLSODE, SINTDY, SSTODE, +C SPREPJ, and SSOLSY. +C Groups of variables are replaced by dummy arrays in the Common +C declarations in routines where those variables are not used. +C----------------------------------------------------------------------- + COMMON /SLS001/ CONIT, CRATE, EL(13), ELCO(13,12), + 1 HOLD, RMAX, TESCO(3,12), + 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, + 2 INIT, MXSTEP, MXHNIL, NHNIL, NSLAST, NYH, + 3 IALTH, IPUP, LMAX, MEO, NQNYH, NSLP, + 3 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, + 4 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, + 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU +C + DATA MORD(1),MORD(2)/12,5/, MXSTP0/500/, MXHNL0/10/ +C----------------------------------------------------------------------- +C Block A. +C This code block is executed on every call. +C It tests ISTATE and ITASK for legality and branches appropriately. +C If ISTATE .GT. 1 but the flag INIT shows that initialization has +C not yet been done, an error return occurs. +C If ISTATE = 1 and TOUT = T, return immediately. +C----------------------------------------------------------------------- +C +C***FIRST EXECUTABLE STATEMENT SLSODE + IF (ISTATE .LT. 1 .OR. ISTATE .GT. 3) GO TO 601 + IF (ITASK .LT. 1 .OR. ITASK .GT. 5) GO TO 602 + IF (ISTATE .EQ. 1) GO TO 10 + IF (INIT .EQ. 0) GO TO 603 + IF (ISTATE .EQ. 2) GO TO 200 + GO TO 20 + 10 INIT = 0 + IF (TOUT .EQ. T) RETURN +C----------------------------------------------------------------------- +C Block B. +C The next code block is executed for the initial call (ISTATE = 1), +C or for a continuation call with parameter changes (ISTATE = 3). +C It contains checking of all inputs and various initializations. +C +C First check legality of the non-optional inputs NEQ, ITOL, IOPT, +C MF, ML, and MU. +C----------------------------------------------------------------------- + 20 IF (NEQ(1) .LE. 0) GO TO 604 + IF (ISTATE .EQ. 1) GO TO 25 + IF (NEQ(1) .GT. N) GO TO 605 + 25 N = NEQ(1) + IF (ITOL .LT. 1 .OR. ITOL .GT. 4) GO TO 606 + IF (IOPT .LT. 0 .OR. IOPT .GT. 1) GO TO 607 + METH = MF/10 + MITER = MF - 10*METH + IF (METH .LT. 1 .OR. METH .GT. 2) GO TO 608 + IF (MITER .LT. 0 .OR. MITER .GT. 5) GO TO 608 + IF (MITER .LE. 3) GO TO 30 + ML = IWORK(1) + MU = IWORK(2) + IF (ML .LT. 0 .OR. ML .GE. N) GO TO 609 + IF (MU .LT. 0 .OR. MU .GE. N) GO TO 610 + 30 CONTINUE +C Next process and check the optional inputs. -------------------------- + IF (IOPT .EQ. 1) GO TO 40 + MAXORD = MORD(METH) + MXSTEP = MXSTP0 + MXHNIL = MXHNL0 + IF (ISTATE .EQ. 1) H0 = 0.0E0 + HMXI = 0.0E0 + HMIN = 0.0E0 + GO TO 60 + 40 MAXORD = IWORK(5) + IF (MAXORD .LT. 0) GO TO 611 + IF (MAXORD .EQ. 0) MAXORD = 100 + MAXORD = MIN(MAXORD,MORD(METH)) + MXSTEP = IWORK(6) + IF (MXSTEP .LT. 0) GO TO 612 + IF (MXSTEP .EQ. 0) MXSTEP = MXSTP0 + MXHNIL = IWORK(7) + IF (MXHNIL .LT. 0) GO TO 613 + IF (MXHNIL .EQ. 0) MXHNIL = MXHNL0 + IF (ISTATE .NE. 1) GO TO 50 + H0 = RWORK(5) + IF ((TOUT - T)*H0 .LT. 0.0E0) GO TO 614 + 50 HMAX = RWORK(6) + IF (HMAX .LT. 0.0E0) GO TO 615 + HMXI = 0.0E0 + IF (HMAX .GT. 0.0E0) HMXI = 1.0E0/HMAX + HMIN = RWORK(7) + IF (HMIN .LT. 0.0E0) GO TO 616 +C----------------------------------------------------------------------- +C Set work array pointers and check lengths LRW and LIW. +C Pointers to segments of RWORK and IWORK are named by prefixing L to +C the name of the segment. E.g., the segment YH starts at RWORK(LYH). +C Segments of RWORK (in order) are denoted YH, WM, EWT, SAVF, ACOR. +C----------------------------------------------------------------------- + 60 LYH = 21 + IF (ISTATE .EQ. 1) NYH = N + LWM = LYH + (MAXORD + 1)*NYH + IF (MITER .EQ. 0) LENWM = 0 + IF (MITER .EQ. 1 .OR. MITER .EQ. 2) LENWM = N*N + 2 + IF (MITER .EQ. 3) LENWM = N + 2 + IF (MITER .GE. 4) LENWM = (2*ML + MU + 1)*N + 2 + LEWT = LWM + LENWM + LSAVF = LEWT + N + LACOR = LSAVF + N + LENRW = LACOR + N - 1 + IWORK(17) = LENRW + LIWM = 1 + LENIW = 20 + N + IF (MITER .EQ. 0 .OR. MITER .EQ. 3) LENIW = 20 + IWORK(18) = LENIW + IF (LENRW .GT. LRW) GO TO 617 + IF (LENIW .GT. LIW) GO TO 618 +C Check RTOL and ATOL for legality. ------------------------------------ + RTOLI = RTOL(1) + ATOLI = ATOL(1) + DO 70 I = 1,N + IF (ITOL .GE. 3) RTOLI = RTOL(I) + IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) ATOLI = ATOL(I) + IF (RTOLI .LT. 0.0E0) GO TO 619 + IF (ATOLI .LT. 0.0E0) GO TO 620 + 70 CONTINUE + IF (ISTATE .EQ. 1) GO TO 100 +C If ISTATE = 3, set flag to signal parameter changes to SSTODE. ------- + JSTART = -1 + IF (NQ .LE. MAXORD) GO TO 90 +C MAXORD was reduced below NQ. Copy YH(*,MAXORD+2) into SAVF. --------- + DO 80 I = 1,N + 80 RWORK(I+LSAVF-1) = RWORK(I+LWM-1) +C Reload WM(1) = RWORK(LWM), since LWM may have changed. --------------- + 90 IF (MITER .GT. 0) RWORK(LWM) = SQRT(UROUND) + IF (N .EQ. NYH) GO TO 200 +C NEQ was reduced. Zero part of YH to avoid undefined references. ----- + I1 = LYH + L*NYH + I2 = LYH + (MAXORD + 1)*NYH - 1 + IF (I1 .GT. I2) GO TO 200 + DO 95 I = I1,I2 + 95 RWORK(I) = 0.0E0 + GO TO 200 +C----------------------------------------------------------------------- +C Block C. +C The next block is for the initial call only (ISTATE = 1). +C It contains all remaining initializations, the initial call to F, +C and the calculation of the initial step size. +C The error weights in EWT are inverted after being loaded. +C----------------------------------------------------------------------- + 100 UROUND = R1MACH(4) + TN = T + IF (ITASK .NE. 4 .AND. ITASK .NE. 5) GO TO 110 + TCRIT = RWORK(1) + IF ((TCRIT - TOUT)*(TOUT - T) .LT. 0.0E0) GO TO 625 + IF (H0 .NE. 0.0E0 .AND. (T + H0 - TCRIT)*H0 .GT. 0.0E0) + 1 H0 = TCRIT - T + 110 JSTART = 0 + IF (MITER .GT. 0) RWORK(LWM) = SQRT(UROUND) + NHNIL = 0 + NST = 0 + NJE = 0 + NSLAST = 0 + HU = 0.0E0 + NQU = 0 + CCMAX = 0.3E0 + MAXCOR = 3 + MSBP = 20 + MXNCF = 10 +C Initial call to F. (LF0 points to YH(*,2).) ------------------------- + LF0 = LYH + NYH + CALL F (NEQ, T, Y, RWORK(LF0)) + NFE = 1 +C Load the initial value vector in YH. --------------------------------- + DO 115 I = 1,N + 115 RWORK(I+LYH-1) = Y(I) +C Load and invert the EWT array. (H is temporarily set to 1.0.) ------- + NQ = 1 + H = 1.0E0 + CALL SEWSET (N, ITOL, RTOL, ATOL, RWORK(LYH), RWORK(LEWT)) + DO 120 I = 1,N + IF (RWORK(I+LEWT-1) .LE. 0.0E0) GO TO 621 + 120 RWORK(I+LEWT-1) = 1.0E0/RWORK(I+LEWT-1) +C----------------------------------------------------------------------- +C The coding below computes the step size, H0, to be attempted on the +C first step, unless the user has supplied a value for this. +C First check that TOUT - T differs significantly from zero. +C A scalar tolerance quantity TOL is computed, as MAX(RTOL(I)) +C if this is positive, or MAX(ATOL(I)/ABS(Y(I))) otherwise, adjusted +C so as to be between 100*UROUND and 1.0E-3. +C Then the computed value H0 is given by.. +C NEQ +C H0**2 = TOL / ( w0**-2 + (1/NEQ) * SUM ( f(i)/ywt(i) )**2 ) +C 1 +C where w0 = MAX ( ABS(T), ABS(TOUT) ), +C f(i) = i-th component of initial value of f, +C ywt(i) = EWT(i)/TOL (a weight for y(i)). +C The sign of H0 is inferred from the initial values of TOUT and T. +C----------------------------------------------------------------------- + IF (H0 .NE. 0.0E0) GO TO 180 + TDIST = ABS(TOUT - T) + W0 = MAX(ABS(T),ABS(TOUT)) + IF (TDIST .LT. 2.0E0*UROUND*W0) GO TO 622 + TOL = RTOL(1) + IF (ITOL .LE. 2) GO TO 140 + DO 130 I = 1,N + 130 TOL = MAX(TOL,RTOL(I)) + 140 IF (TOL .GT. 0.0E0) GO TO 160 + ATOLI = ATOL(1) + DO 150 I = 1,N + IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) ATOLI = ATOL(I) + AYI = ABS(Y(I)) + IF (AYI .NE. 0.0E0) TOL = MAX(TOL,ATOLI/AYI) + 150 CONTINUE + 160 TOL = MAX(TOL,100.0E0*UROUND) + TOL = MIN(TOL,0.001E0) + SUM = SVNORM (N, RWORK(LF0), RWORK(LEWT)) + SUM = 1.0E0/(TOL*W0*W0) + TOL*SUM**2 + H0 = 1.0E0/SQRT(SUM) + H0 = MIN(H0,TDIST) + H0 = SIGN(H0,TOUT-T) +C Adjust H0 if necessary to meet HMAX bound. --------------------------- + 180 RH = ABS(H0)*HMXI + IF (RH .GT. 1.0E0) H0 = H0/RH +C Load H with H0 and scale YH(*,2) by H0. ------------------------------ + H = H0 + DO 190 I = 1,N + 190 RWORK(I+LF0-1) = H0*RWORK(I+LF0-1) + GO TO 270 +C----------------------------------------------------------------------- +C Block D. +C The next code block is for continuation calls only (ISTATE = 2 or 3) +C and is to check stop conditions before taking a step. +C----------------------------------------------------------------------- + 200 NSLAST = NST + GO TO (210, 250, 220, 230, 240), ITASK + 210 IF ((TN - TOUT)*H .LT. 0.0E0) GO TO 250 + CALL SINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) + IF (IFLAG .NE. 0) GO TO 627 + T = TOUT + GO TO 420 + 220 TP = TN - HU*(1.0E0 + 100.0E0*UROUND) + IF ((TP - TOUT)*H .GT. 0.0E0) GO TO 623 + IF ((TN - TOUT)*H .LT. 0.0E0) GO TO 250 + GO TO 400 + 230 TCRIT = RWORK(1) + IF ((TN - TCRIT)*H .GT. 0.0E0) GO TO 624 + IF ((TCRIT - TOUT)*H .LT. 0.0E0) GO TO 625 + IF ((TN - TOUT)*H .LT. 0.0E0) GO TO 245 + CALL SINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) + IF (IFLAG .NE. 0) GO TO 627 + T = TOUT + GO TO 420 + 240 TCRIT = RWORK(1) + IF ((TN - TCRIT)*H .GT. 0.0E0) GO TO 624 + 245 HMX = ABS(TN) + ABS(H) + IHIT = ABS(TN - TCRIT) .LE. 100.0E0*UROUND*HMX + IF (IHIT) GO TO 400 + TNEXT = TN + H*(1.0E0 + 4.0E0*UROUND) + IF ((TNEXT - TCRIT)*H .LE. 0.0E0) GO TO 250 + H = (TCRIT - TN)*(1.0E0 - 4.0E0*UROUND) + IF (ISTATE .EQ. 2) JSTART = -2 +C----------------------------------------------------------------------- +C Block E. +C The next block is normally executed for all calls and contains +C the call to the one-step core integrator SSTODE. +C +C This is a looping point for the integration steps. +C +C First check for too many steps being taken, update EWT (if not at +C start of problem), check for too much accuracy being requested, and +C check for H below the roundoff level in T. +C----------------------------------------------------------------------- + 250 CONTINUE + IF ((NST-NSLAST) .GE. MXSTEP) GO TO 500 + CALL SEWSET (N, ITOL, RTOL, ATOL, RWORK(LYH), RWORK(LEWT)) + DO 260 I = 1,N + IF (RWORK(I+LEWT-1) .LE. 0.0E0) GO TO 510 + 260 RWORK(I+LEWT-1) = 1.0E0/RWORK(I+LEWT-1) + 270 TOLSF = UROUND*SVNORM (N, RWORK(LYH), RWORK(LEWT)) + IF (TOLSF .LE. 1.0E0) GO TO 280 + TOLSF = TOLSF*2.0E0 + IF (NST .EQ. 0) GO TO 626 + GO TO 520 + 280 IF ((TN + H) .NE. TN) GO TO 290 + NHNIL = NHNIL + 1 + IF (NHNIL .GT. MXHNIL) GO TO 290 + CALL XERRWD('SLSODE- Warning..internal T (=R1) and H (=R2) are', + 1 50, 101, 0, 0, 0, 0, 0, 0.0E0, 0.0E0) + CALL XERRWD( + 1 ' such that in the machine, T + H = T on the next step ', + 1 60, 101, 0, 0, 0, 0, 0, 0.0E0, 0.0E0) + CALL XERRWD(' (H = step size). Solver will continue anyway', + 1 50, 101, 0, 0, 0, 0, 2, TN, H) + IF (NHNIL .LT. MXHNIL) GO TO 290 + CALL XERRWD('SLSODE- Above warning has been issued I1 times. ', + 1 50, 102, 0, 0, 0, 0, 0, 0.0E0, 0.0E0) + CALL XERRWD(' It will not be issued again for this problem', + 1 50, 102, 0, 1, MXHNIL, 0, 0, 0.0E0, 0.0E0) + 290 CONTINUE +C----------------------------------------------------------------------- +C CALL SSTODE(NEQ,Y,YH,NYH,YH,EWT,SAVF,ACOR,WM,IWM,F,JAC,SPREPJ,SSOLSY) +C----------------------------------------------------------------------- + CALL SSTODE (NEQ, Y, RWORK(LYH), NYH, RWORK(LYH), RWORK(LEWT), + 1 RWORK(LSAVF), RWORK(LACOR), RWORK(LWM), IWORK(LIWM), + 2 F, JAC, SPREPJ, SSOLSY) + KGO = 1 - KFLAG + GO TO (300, 530, 540), KGO +C----------------------------------------------------------------------- +C Block F. +C The following block handles the case of a successful return from the +C core integrator (KFLAG = 0). Test for stop conditions. +C----------------------------------------------------------------------- + 300 INIT = 1 + GO TO (310, 400, 330, 340, 350), ITASK +C ITASK = 1. If TOUT has been reached, interpolate. ------------------- + 310 IF ((TN - TOUT)*H .LT. 0.0E0) GO TO 250 + CALL SINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) + T = TOUT + GO TO 420 +C ITASK = 3. Jump to exit if TOUT was reached. ------------------------ + 330 IF ((TN - TOUT)*H .GE. 0.0E0) GO TO 400 + GO TO 250 +C ITASK = 4. See if TOUT or TCRIT was reached. Adjust H if necessary. + 340 IF ((TN - TOUT)*H .LT. 0.0E0) GO TO 345 + CALL SINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) + T = TOUT + GO TO 420 + 345 HMX = ABS(TN) + ABS(H) + IHIT = ABS(TN - TCRIT) .LE. 100.0E0*UROUND*HMX + IF (IHIT) GO TO 400 + TNEXT = TN + H*(1.0E0 + 4.0E0*UROUND) + IF ((TNEXT - TCRIT)*H .LE. 0.0E0) GO TO 250 + H = (TCRIT - TN)*(1.0E0 - 4.0E0*UROUND) + JSTART = -2 + GO TO 250 +C ITASK = 5. See if TCRIT was reached and jump to exit. --------------- + 350 HMX = ABS(TN) + ABS(H) + IHIT = ABS(TN - TCRIT) .LE. 100.0E0*UROUND*HMX +C----------------------------------------------------------------------- +C Block G. +C The following block handles all successful returns from SLSODE. +C If ITASK .NE. 1, Y is loaded from YH and T is set accordingly. +C ISTATE is set to 2, and the optional outputs are loaded into the +C work arrays before returning. +C----------------------------------------------------------------------- + 400 DO 410 I = 1,N + 410 Y(I) = RWORK(I+LYH-1) + T = TN + IF (ITASK .NE. 4 .AND. ITASK .NE. 5) GO TO 420 + IF (IHIT) T = TCRIT + 420 ISTATE = 2 + RWORK(11) = HU + RWORK(12) = H + RWORK(13) = TN + IWORK(11) = NST + IWORK(12) = NFE + IWORK(13) = NJE + IWORK(14) = NQU + IWORK(15) = NQ + RETURN +C----------------------------------------------------------------------- +C Block H. +C The following block handles all unsuccessful returns other than +C those for illegal input. First the error message routine is called. +C If there was an error test or convergence test failure, IMXER is set. +C Then Y is loaded from YH and T is set to TN. The optional outputs +C are loaded into the work arrays before returning. +C----------------------------------------------------------------------- +C The maximum number of steps was taken before reaching TOUT. ---------- + 500 CALL XERRWD('SLSODE- At current T (=R1), MXSTEP (=I1) steps ', + 1 50, 201, 0, 0, 0, 0, 0, 0.0E0, 0.0E0) + CALL XERRWD(' taken on this call before reaching TOUT ', + 1 50, 201, 0, 1, MXSTEP, 0, 1, TN, 0.0E0) + ISTATE = -1 + GO TO 580 +C EWT(I) .LE. 0.0 for some I (not at start of problem). ---------------- + 510 EWTI = RWORK(LEWT+I-1) + CALL XERRWD('SLSODE- At T (=R1), EWT(I1) has become R2 .LE. 0.', + 1 50, 202, 0, 1, I, 0, 2, TN, EWTI) + ISTATE = -6 + GO TO 580 +C Too much accuracy requested for machine precision. ------------------- + 520 CALL XERRWD('SLSODE- At T (=R1), too much accuracy requested ', + 1 50, 203, 0, 0, 0, 0, 0, 0.0E0, 0.0E0) + CALL XERRWD(' for precision of machine.. see TOLSF (=R2) ', + 1 50, 203, 0, 0, 0, 0, 2, TN, TOLSF) + RWORK(14) = TOLSF + ISTATE = -2 + GO TO 580 +C KFLAG = -1. Error test failed repeatedly or with ABS(H) = HMIN. ----- + 530 CALL XERRWD('SLSODE- At T(=R1) and step size H(=R2), the error', + 1 50, 204, 0, 0, 0, 0, 0, 0.0E0, 0.0E0) + CALL XERRWD(' test failed repeatedly or with ABS(H) = HMIN', + 1 50, 204, 0, 0, 0, 0, 2, TN, H) + ISTATE = -4 + GO TO 560 +C KFLAG = -2. Convergence failed repeatedly or with ABS(H) = HMIN. ---- + 540 CALL XERRWD('SLSODE- At T (=R1) and step size H (=R2), the ', + 1 50, 205, 0, 0, 0, 0, 0, 0.0E0, 0.0E0) + CALL XERRWD(' corrector convergence failed repeatedly ', + 1 50, 205, 0, 0, 0, 0, 0, 0.0E0, 0.0E0) + CALL XERRWD(' or with ABS(H) = HMIN ', + 1 30, 205, 0, 0, 0, 0, 2, TN, H) + ISTATE = -5 +C Compute IMXER if relevant. ------------------------------------------- + 560 BIG = 0.0E0 + IMXER = 1 + DO 570 I = 1,N + SIZE = ABS(RWORK(I+LACOR-1)*RWORK(I+LEWT-1)) + IF (BIG .GE. SIZE) GO TO 570 + BIG = SIZE + IMXER = I + 570 CONTINUE + IWORK(16) = IMXER +C Set Y vector, T, and optional outputs. ------------------------------- + 580 DO 590 I = 1,N + 590 Y(I) = RWORK(I+LYH-1) + T = TN + RWORK(11) = HU + RWORK(12) = H + RWORK(13) = TN + IWORK(11) = NST + IWORK(12) = NFE + IWORK(13) = NJE + IWORK(14) = NQU + IWORK(15) = NQ + RETURN +C----------------------------------------------------------------------- +C Block I. +C The following block handles all error returns due to illegal input +C (ISTATE = -3), as detected before calling the core integrator. +C First the error message routine is called. If the illegal input +C is a negative ISTATE, the run is aborted (apparent infinite loop). +C----------------------------------------------------------------------- + 601 CALL XERRWD('SLSODE- ISTATE (=I1) illegal ', + 1 30, 1, 0, 1, ISTATE, 0, 0, 0.0E0, 0.0E0) + IF (ISTATE .LT. 0) GO TO 800 + GO TO 700 + 602 CALL XERRWD('SLSODE- ITASK (=I1) illegal ', + 1 30, 2, 0, 1, ITASK, 0, 0, 0.0E0, 0.0E0) + GO TO 700 + 603 CALL XERRWD('SLSODE- ISTATE .GT. 1 but SLSODE not initialized ', + 1 50, 3, 0, 0, 0, 0, 0, 0.0E0, 0.0E0) + GO TO 700 + 604 CALL XERRWD('SLSODE- NEQ (=I1) .LT. 1 ', + 1 30, 4, 0, 1, NEQ(1), 0, 0, 0.0E0, 0.0E0) + GO TO 700 + 605 CALL XERRWD('SLSODE- ISTATE = 3 and NEQ increased (I1 to I2) ', + 1 50, 5, 0, 2, N, NEQ(1), 0, 0.0E0, 0.0E0) + GO TO 700 + 606 CALL XERRWD('SLSODE- ITOL (=I1) illegal ', + 1 30, 6, 0, 1, ITOL, 0, 0, 0.0E0, 0.0E0) + GO TO 700 + 607 CALL XERRWD('SLSODE- IOPT (=I1) illegal ', + 1 30, 7, 0, 1, IOPT, 0, 0, 0.0E0, 0.0E0) + GO TO 700 + 608 CALL XERRWD('SLSODE- MF (=I1) illegal ', + 1 30, 8, 0, 1, MF, 0, 0, 0.0E0, 0.0E0) + GO TO 700 + 609 CALL XERRWD('SLSODE- ML (=I1) illegal.. .LT.0 or .GE.NEQ (=I2)', + 1 50, 9, 0, 2, ML, NEQ(1), 0, 0.0E0, 0.0E0) + GO TO 700 + 610 CALL XERRWD('SLSODE- MU (=I1) illegal.. .LT.0 or .GE.NEQ (=I2)', + 1 50, 10, 0, 2, MU, NEQ(1), 0, 0.0E0, 0.0E0) + GO TO 700 + 611 CALL XERRWD('SLSODE- MAXORD (=I1) .LT. 0 ', + 1 30, 11, 0, 1, MAXORD, 0, 0, 0.0E0, 0.0E0) + GO TO 700 + 612 CALL XERRWD('SLSODE- MXSTEP (=I1) .LT. 0 ', + 1 30, 12, 0, 1, MXSTEP, 0, 0, 0.0E0, 0.0E0) + GO TO 700 + 613 CALL XERRWD('SLSODE- MXHNIL (=I1) .LT. 0 ', + 1 30, 13, 0, 1, MXHNIL, 0, 0, 0.0E0, 0.0E0) + GO TO 700 + 614 CALL XERRWD('SLSODE- TOUT (=R1) behind T (=R2) ', + 1 40, 14, 0, 0, 0, 0, 2, TOUT, T) + CALL XERRWD(' Integration direction is given by H0 (=R1) ', + 1 50, 14, 0, 0, 0, 0, 1, H0, 0.0E0) + GO TO 700 + 615 CALL XERRWD('SLSODE- HMAX (=R1) .LT. 0.0 ', + 1 30, 15, 0, 0, 0, 0, 1, HMAX, 0.0E0) + GO TO 700 + 616 CALL XERRWD('SLSODE- HMIN (=R1) .LT. 0.0 ', + 1 30, 16, 0, 0, 0, 0, 1, HMIN, 0.0E0) + GO TO 700 + 617 CALL XERRWD( + 1 'SLSODE- RWORK length needed, LENRW (=I1), exceeds LRW (=I2)', + 1 60, 17, 0, 2, LENRW, LRW, 0, 0.0E0, 0.0E0) + GO TO 700 + 618 CALL XERRWD( + 1 'SLSODE- IWORK length needed, LENIW (=I1), exceeds LIW (=I2)', + 1 60, 18, 0, 2, LENIW, LIW, 0, 0.0E0, 0.0E0) + GO TO 700 + 619 CALL XERRWD('SLSODE- RTOL(I1) is R1 .LT. 0.0 ', + 1 40, 19, 0, 1, I, 0, 1, RTOLI, 0.0E0) + GO TO 700 + 620 CALL XERRWD('SLSODE- ATOL(I1) is R1 .LT. 0.0 ', + 1 40, 20, 0, 1, I, 0, 1, ATOLI, 0.0E0) + GO TO 700 + 621 EWTI = RWORK(LEWT+I-1) + CALL XERRWD('SLSODE- EWT(I1) is R1 .LE. 0.0 ', + 1 40, 21, 0, 1, I, 0, 1, EWTI, 0.0E0) + GO TO 700 + 622 CALL XERRWD( + 1 'SLSODE- TOUT (=R1) too close to T(=R2) to start integration', + 1 60, 22, 0, 0, 0, 0, 2, TOUT, T) + GO TO 700 + 623 CALL XERRWD( + 1 'SLSODE- ITASK = I1 and TOUT (=R1) behind TCUR - HU (= R2) ', + 1 60, 23, 0, 1, ITASK, 0, 2, TOUT, TP) + GO TO 700 + 624 CALL XERRWD( + 1 'SLSODE- ITASK = 4 OR 5 and TCRIT (=R1) behind TCUR (=R2) ', + 1 60, 24, 0, 0, 0, 0, 2, TCRIT, TN) + GO TO 700 + 625 CALL XERRWD( + 1 'SLSODE- ITASK = 4 or 5 and TCRIT (=R1) behind TOUT (=R2) ', + 1 60, 25, 0, 0, 0, 0, 2, TCRIT, TOUT) + GO TO 700 + 626 CALL XERRWD('SLSODE- At start of problem, too much accuracy ', + 1 50, 26, 0, 0, 0, 0, 0, 0.0E0, 0.0E0) + CALL XERRWD( + 1 ' requested for precision of machine.. See TOLSF (=R1) ', + 1 60, 26, 0, 0, 0, 0, 1, TOLSF, 0.0E0) + RWORK(14) = TOLSF + GO TO 700 + 627 CALL XERRWD('SLSODE- Trouble in SINTDY. ITASK = I1, TOUT = R1', + 1 50, 27, 0, 1, ITASK, 0, 1, TOUT, 0.0E0) +C + 700 ISTATE = -3 + RETURN +C + 800 CALL XERRWD('SLSODE- Run aborted.. apparent infinite loop ', + 1 50, 303, 2, 0, 0, 0, 0, 0.0E0, 0.0E0) + RETURN +C----------------------- END OF SUBROUTINE SLSODE ---------------------- + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/odepack/solsy.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,74 @@ + SUBROUTINE SOLSY (WM, IWM, X, TEM) +CLLL. OPTIMIZE + INTEGER IWM + INTEGER ILLIN, INIT, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, + 1 MXSTEP, MXHNIL, NHNIL, NTREP, NSLAST, NYH, + 2 IALTH, IPUP, LMAX, MEO, NQNYH, NSLP + INTEGER ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, METH, MITER, + 2 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU + INTEGER I, MEBAND, ML, MU + DOUBLE PRECISION WM, X, TEM + DOUBLE PRECISION CONIT, CRATE, EL, ELCO, HOLD, RMAX, TESCO, + 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND + DOUBLE PRECISION DI, HL0, PHL0, R + DIMENSION WM(*), IWM(*), X(*), TEM(*) + COMMON /LS0001/ CONIT, CRATE, EL(13), ELCO(13,12), + 1 HOLD, RMAX, TESCO(3,12), + 2 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, + 2 ILLIN, INIT, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, + 3 MXSTEP, MXHNIL, NHNIL, NTREP, NSLAST, NYH, + 3 IALTH, IPUP, LMAX, MEO, NQNYH, NSLP, + 4 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, METH, MITER, + 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU +C----------------------------------------------------------------------- +C THIS ROUTINE MANAGES THE SOLUTION OF THE LINEAR SYSTEM ARISING FROM +C A CHORD ITERATION. IT IS CALLED IF MITER .NE. 0. +C IF MITER IS 1 OR 2, IT CALLS DGETRS TO ACCOMPLISH THIS. +C IF MITER = 3 IT UPDATES THE COEFFICIENT H*EL0 IN THE DIAGONAL +C MATRIX, AND THEN COMPUTES THE SOLUTION. +C IF MITER IS 4 OR 5, IT CALLS DGBTRS. +C COMMUNICATION WITH SOLSY USES THE FOLLOWING VARIABLES.. +C WM = REAL WORK SPACE CONTAINING THE INVERSE DIAGONAL MATRIX IF +C MITER = 3 AND THE LU DECOMPOSITION OF THE MATRIX OTHERWISE. +C STORAGE OF MATRIX ELEMENTS STARTS AT WM(3). +C WM ALSO CONTAINS THE FOLLOWING MATRIX-RELATED DATA.. +C WM(1) = SQRT(UROUND) (NOT USED HERE), +C WM(2) = HL0, THE PREVIOUS VALUE OF H*EL0, USED IF MITER = 3. +C IWM = INTEGER WORK SPACE CONTAINING PIVOT INFORMATION, STARTING AT +C IWM(21), IF MITER IS 1, 2, 4, OR 5. IWM ALSO CONTAINS BAND +C PARAMETERS ML = IWM(1) AND MU = IWM(2) IF MITER IS 4 OR 5. +C X = THE RIGHT-HAND SIDE VECTOR ON INPUT, AND THE SOLUTION VECTOR +C ON OUTPUT, OF LENGTH N. +C TEM = VECTOR OF WORK SPACE OF LENGTH N, NOT USED IN THIS VERSION. +C IERSL = OUTPUT FLAG (IN COMMON). IERSL = 0 IF NO TROUBLE OCCURRED. +C IERSL = 1 IF A SINGULAR MATRIX AROSE WITH MITER = 3. +C THIS ROUTINE ALSO USES THE COMMON VARIABLES EL0, H, MITER, AND N. +C----------------------------------------------------------------------- + IERSL = 0 + GO TO (100, 100, 300, 400, 400), MITER + 100 CALL DGETRS ( 'N', N, 1, WM(3), N, IWM(21), X, N, INLPCK) + RETURN +C + 300 PHL0 = WM(2) + HL0 = H*EL0 + WM(2) = HL0 + IF (HL0 .EQ. PHL0) GO TO 330 + R = HL0/PHL0 + DO 320 I = 1,N + DI = 1.0D0 - R*(1.0D0 - 1.0D0/WM(I+2)) + IF (DABS(DI) .EQ. 0.0D0) GO TO 390 + 320 WM(I+2) = 1.0D0/DI + 330 DO 340 I = 1,N + 340 X(I) = WM(I+2)*X(I) + RETURN + 390 IERSL = 1 + RETURN +C + 400 ML = IWM(1) + MU = IWM(2) + MEBAND = 2*ML + MU + 1 + CALL DGBTRS ( 'N', N, ML, MU, 1, WM(3), MEBAND, IWM(21), X, N, + * INLPCK) + RETURN +C----------------------- END OF SUBROUTINE SOLSY ----------------------- + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/odepack/sprepj.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,196 @@ + SUBROUTINE SPREPJ (NEQ, Y, YH, NYH, EWT, FTEM, SAVF, WM, IWM, + 1 F, JAC) +C***BEGIN PROLOGUE SPREPJ +C***SUBSIDIARY +C***PURPOSE Compute and process Newton iteration matrix. +C***TYPE SINGLE PRECISION (SPREPJ-S, DPREPJ-D) +C***AUTHOR Hindmarsh, Alan C., (LLNL) +C***DESCRIPTION +C +C SPREPJ is called by SSTODE to compute and process the matrix +C P = I - h*el(1)*J , where J is an approximation to the Jacobian. +C Here J is computed by the user-supplied routine JAC if +C MITER = 1 or 4, or by finite differencing if MITER = 2, 3, or 5. +C If MITER = 3, a diagonal approximation to J is used. +C J is stored in WM and replaced by P. If MITER .ne. 3, P is then +C subjected to LU decomposition in preparation for later solution +C of linear systems with P as coefficient matrix. This is done +C by SGETRF if MITER = 1 or 2, and by SGBTRF if MITER = 4 or 5. +C +C In addition to variables described in SSTODE and SLSODE prologues, +C communication with SPREPJ uses the following: +C Y = array containing predicted values on entry. +C FTEM = work array of length N (ACOR in SSTODE). +C SAVF = array containing f evaluated at predicted y. +C WM = real work space for matrices. On output it contains the +C inverse diagonal matrix if MITER = 3 and the LU decomposition +C of P if MITER is 1, 2 , 4, or 5. +C Storage of matrix elements starts at WM(3). +C WM also contains the following matrix-related data: +C WM(1) = SQRT(UROUND), used in numerical Jacobian increments. +C WM(2) = H*EL0, saved for later use if MITER = 3. +C IWM = integer work space containing pivot information, starting at +C IWM(21), if MITER is 1, 2, 4, or 5. IWM also contains band +C parameters ML = IWM(1) and MU = IWM(2) if MITER is 4 or 5. +C EL0 = EL(1) (input). +C IERPJ = output error flag, = 0 if no trouble, .gt. 0 if +C P matrix found to be singular. +C JCUR = output flag = 1 to indicate that the Jacobian matrix +C (or approximation) is now current. +C This routine also uses the COMMON variables EL0, H, TN, UROUND, +C MITER, N, NFE, and NJE. +C +C***SEE ALSO SLSODE +C***ROUTINES CALLED SGBTRF, SGETRF, SVNORM +C***COMMON BLOCKS SLS001 +C***REVISION HISTORY (YYMMDD) +C 791129 DATE WRITTEN +C 890501 Modified prologue to SLATEC/LDOC format. (FNF) +C 890504 Minor cosmetic changes. (FNF) +C 930809 Renamed to allow single/double precision versions. (ACH) +C 010412 Reduced size of Common block /SLS001/. (ACH) +C 031105 Restored 'own' variables to Common block /SLS001/, to +C enable interrupt/restart feature. (ACH) +C***END PROLOGUE SPREPJ +C**End + EXTERNAL F, JAC + INTEGER NEQ, NYH, IWM + REAL Y, YH, EWT, FTEM, SAVF, WM + DIMENSION NEQ(*), Y(*), YH(NYH,*), EWT(*), FTEM(*), SAVF(*), + 1 WM(*), IWM(*) + INTEGER INIT, MXSTEP, MXHNIL, NHNIL, NSLAST, CNYH, + 1 IALTH, IPUP, LMAX, MEO, NQNYH, NSLP, + 1 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, + 2 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, + 3 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU + REAL CONIT, CRATE, EL, ELCO, HOLD, RMAX, TESCO, + 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND + COMMON /SLS001/ CONIT, CRATE, EL(13), ELCO(13,12), + 1 HOLD, RMAX, TESCO(3,12), + 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, + 2 INIT, MXSTEP, MXHNIL, NHNIL, NSLAST, CNYH, + 3 IALTH, IPUP, LMAX, MEO, NQNYH, NSLP, + 3 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, + 4 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, + 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU + INTEGER I, I1, I2, IER, II, J, J1, JJ, LENP, + 1 MBA, MBAND, MEB1, MEBAND, ML, ML3, MU, NP1 + REAL CON, DI, FAC, HL0, R, R0, SRUR, YI, YJ, YJJ, + 1 SVNORM +C +C***FIRST EXECUTABLE STATEMENT SPREPJ + NJE = NJE + 1 + IERPJ = 0 + JCUR = 1 + HL0 = H*EL0 + GO TO (100, 200, 300, 400, 500), MITER +C If MITER = 1, call JAC and multiply by scalar. ----------------------- + 100 LENP = N*N + DO 110 I = 1,LENP + 110 WM(I+2) = 0.0E0 + CALL JAC (NEQ, TN, Y, 0, 0, WM(3), N) + CON = -HL0 + DO 120 I = 1,LENP + 120 WM(I+2) = WM(I+2)*CON + GO TO 240 +C If MITER = 2, make N calls to F to approximate J. -------------------- + 200 FAC = SVNORM (N, SAVF, EWT) + R0 = 1000.0E0*ABS(H)*UROUND*N*FAC + IF (R0 .EQ. 0.0E0) R0 = 1.0E0 + SRUR = WM(1) + J1 = 2 + DO 230 J = 1,N + YJ = Y(J) + R = MAX(SRUR*ABS(YJ),R0/EWT(J)) + Y(J) = Y(J) + R + FAC = -HL0/R + CALL F (NEQ, TN, Y, FTEM) + DO 220 I = 1,N + 220 WM(I+J1) = (FTEM(I) - SAVF(I))*FAC + Y(J) = YJ + J1 = J1 + N + 230 CONTINUE + NFE = NFE + N +C Add identity matrix. ------------------------------------------------- + 240 J = 3 + NP1 = N + 1 + DO 250 I = 1,N + WM(J) = WM(J) + 1.0E0 + 250 J = J + NP1 +C Do LU decomposition on P. -------------------------------------------- + CALL SGETRF (N, N, WM(3), N, IWM(21), IER) + IF (IER .NE. 0) IERPJ = 1 + RETURN +C If MITER = 3, construct a diagonal approximation to J and P. --------- + 300 WM(2) = HL0 + R = EL0*0.1E0 + DO 310 I = 1,N + 310 Y(I) = Y(I) + R*(H*SAVF(I) - YH(I,2)) + CALL F (NEQ, TN, Y, WM(3)) + NFE = NFE + 1 + DO 320 I = 1,N + R0 = H*SAVF(I) - YH(I,2) + DI = 0.1E0*R0 - H*(WM(I+2) - SAVF(I)) + WM(I+2) = 1.0E0 + IF (ABS(R0) .LT. UROUND/EWT(I)) GO TO 320 + IF (ABS(DI) .EQ. 0.0E0) GO TO 330 + WM(I+2) = 0.1E0*R0/DI + 320 CONTINUE + RETURN + 330 IERPJ = 1 + RETURN +C If MITER = 4, call JAC and multiply by scalar. ----------------------- + 400 ML = IWM(1) + MU = IWM(2) + ML3 = ML + 3 + MBAND = ML + MU + 1 + MEBAND = MBAND + ML + LENP = MEBAND*N + DO 410 I = 1,LENP + 410 WM(I+2) = 0.0E0 + CALL JAC (NEQ, TN, Y, ML, MU, WM(ML3), MEBAND) + CON = -HL0 + DO 420 I = 1,LENP + 420 WM(I+2) = WM(I+2)*CON + GO TO 570 +C If MITER = 5, make MBAND calls to F to approximate J. ---------------- + 500 ML = IWM(1) + MU = IWM(2) + MBAND = ML + MU + 1 + MBA = MIN(MBAND,N) + MEBAND = MBAND + ML + MEB1 = MEBAND - 1 + SRUR = WM(1) + FAC = SVNORM (N, SAVF, EWT) + R0 = 1000.0E0*ABS(H)*UROUND*N*FAC + IF (R0 .EQ. 0.0E0) R0 = 1.0E0 + DO 560 J = 1,MBA + DO 530 I = J,N,MBAND + YI = Y(I) + R = MAX(SRUR*ABS(YI),R0/EWT(I)) + 530 Y(I) = Y(I) + R + CALL F (NEQ, TN, Y, FTEM) + DO 550 JJ = J,N,MBAND + Y(JJ) = YH(JJ,1) + YJJ = Y(JJ) + R = MAX(SRUR*ABS(YJJ),R0/EWT(JJ)) + FAC = -HL0/R + I1 = MAX(JJ-MU,1) + I2 = MIN(JJ+ML,N) + II = JJ*MEB1 - ML + 2 + DO 540 I = I1,I2 + 540 WM(II+I) = (FTEM(I) - SAVF(I))*FAC + 550 CONTINUE + 560 CONTINUE + NFE = NFE + MBA +C Add identity matrix. ------------------------------------------------- + 570 II = MBAND + 2 + DO 580 I = 1,N + WM(II) = WM(II) + 1.0E0 + 580 II = II + MEBAND +C Do LU decomposition of P. -------------------------------------------- + CALL SGBTRF ( N, N, ML, MU, WM(3), MEBAND, IWM(21), IER) + IF (IER .NE. 0) IERPJ = 1 + RETURN +C----------------------- END OF SUBROUTINE SPREPJ ---------------------- + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/odepack/ssolsy.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,94 @@ + SUBROUTINE SSOLSY (WM, IWM, X, TEM) +C***BEGIN PROLOGUE SSOLSY +C***SUBSIDIARY +C***PURPOSE ODEPACK linear system solver. +C***TYPE SINGLE PRECISION (SSOLSY-S, DSOLSY-D) +C***AUTHOR Hindmarsh, Alan C., (LLNL) +C***DESCRIPTION +C +C This routine manages the solution of the linear system arising from +C a chord iteration. It is called if MITER .ne. 0. +C If MITER is 1 or 2, it calls SGETRF to accomplish this. +C If MITER = 3 it updates the coefficient h*EL0 in the diagonal +C matrix, and then computes the solution. +C If MITER is 4 or 5, it calls SGBTRS. +C Communication with SSOLSY uses the following variables: +C WM = real work space containing the inverse diagonal matrix if +C MITER = 3 and the LU decomposition of the matrix otherwise. +C Storage of matrix elements starts at WM(3). +C WM also contains the following matrix-related data: +C WM(1) = SQRT(UROUND) (not used here), +C WM(2) = HL0, the previous value of h*EL0, used if MITER = 3. +C IWM = integer work space containing pivot information, starting at +C IWM(21), if MITER is 1, 2, 4, or 5. IWM also contains band +C parameters ML = IWM(1) and MU = IWM(2) if MITER is 4 or 5. +C X = the right-hand side vector on input, and the solution vector +C on output, of length N. +C TEM = vector of work space of length N, not used in this version. +C IERSL = output flag (in COMMON). IERSL = 0 if no trouble occurred. +C IERSL = 1 if a singular matrix arose with MITER = 3. +C This routine also uses the COMMON variables EL0, H, MITER, and N. +C +C***SEE ALSO SLSODE +C***ROUTINES CALLED SGBTRS, SGETRS +C***COMMON BLOCKS SLS001 +C***REVISION HISTORY (YYMMDD) +C 791129 DATE WRITTEN +C 890501 Modified prologue to SLATEC/LDOC format. (FNF) +C 890503 Minor cosmetic changes. (FNF) +C 930809 Renamed to allow single/double precision versions. (ACH) +C 010412 Reduced size of Common block /SLS001/. (ACH) +C 031105 Restored 'own' variables to Common block /SLS001/, to +C enable interrupt/restart feature. (ACH) +C***END PROLOGUE SSOLSY +C**End + INTEGER IWM + REAL WM, X, TEM + DIMENSION WM(*), IWM(*), X(*), TEM(*) + INTEGER INIT, MXSTEP, MXHNIL, NHNIL, NSLAST, NYH, + 1 IALTH, IPUP, LMAX, MEO, NQNYH, NSLP, + 1 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, + 2 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, + 3 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU + REAL CONIT, CRATE, EL, ELCO, HOLD, RMAX, TESCO, + 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND + COMMON /SLS001/ CONIT, CRATE, EL(13), ELCO(13,12), + 1 HOLD, RMAX, TESCO(3,12), + 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, + 2 INIT, MXSTEP, MXHNIL, NHNIL, NSLAST, NYH, + 3 IALTH, IPUP, LMAX, MEO, NQNYH, NSLP, + 3 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, + 4 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, + 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU + INTEGER I, MEBAND, ML, MU + REAL DI, HL0, PHL0, R +C +C***FIRST EXECUTABLE STATEMENT SSOLSY + IERSL = 0 + GO TO (100, 100, 300, 400, 400), MITER + 100 CALL SGETRS ( 'N', N, 1, WM(3), N, IWM(21), X, N, INLPCK) + RETURN +C + 300 PHL0 = WM(2) + HL0 = H*EL0 + WM(2) = HL0 + IF (HL0 .EQ. PHL0) GO TO 330 + R = HL0/PHL0 + DO 320 I = 1,N + DI = 1.0E0 - R*(1.0E0 - 1.0E0/WM(I+2)) + IF (ABS(DI) .EQ. 0.0E0) GO TO 390 + 320 WM(I+2) = 1.0E0/DI + 330 DO 340 I = 1,N + 340 X(I) = WM(I+2)*X(I) + RETURN + 390 IERSL = 1 + RETURN +C + 400 ML = IWM(1) + MU = IWM(2) + MEBAND = 2*ML + MU + 1 + CALL SGBTRS ( 'N', N, ML, MU, 1, WM(3), MEBAND, IWM(21), X, N, + * INLPCK) + RETURN +C----------------------- END OF SUBROUTINE SSOLSY ---------------------- + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/odepack/sstode.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,499 @@ + SUBROUTINE SSTODE (NEQ, Y, YH, NYH, YH1, EWT, SAVF, ACOR, + 1 WM, IWM, F, JAC, PJAC, SLVS) +C***BEGIN PROLOGUE SSTODE +C***SUBSIDIARY +C***PURPOSE Performs one step of an ODEPACK integration. +C***TYPE SINGLE PRECISION (SSTODE-S, DSTODE-D) +C***AUTHOR Hindmarsh, Alan C., (LLNL) +C***DESCRIPTION +C +C SSTODE performs one step of the integration of an initial value +C problem for a system of ordinary differential equations. +C Note: SSTODE is independent of the value of the iteration method +C indicator MITER, when this is .ne. 0, and hence is independent +C of the type of chord method used, or the Jacobian structure. +C Communication with SSTODE is done with the following variables: +C +C NEQ = integer array containing problem size in NEQ(1), and +C passed as the NEQ argument in all calls to F and JAC. +C Y = an array of length .ge. N used as the Y argument in +C all calls to F and JAC. +C YH = an NYH by LMAX array containing the dependent variables +C and their approximate scaled derivatives, where +C LMAX = MAXORD + 1. YH(i,j+1) contains the approximate +C j-th derivative of y(i), scaled by h**j/factorial(j) +C (j = 0,1,...,NQ). on entry for the first step, the first +C two columns of YH must be set from the initial values. +C NYH = a constant integer .ge. N, the first dimension of YH. +C YH1 = a one-dimensional array occupying the same space as YH. +C EWT = an array of length N containing multiplicative weights +C for local error measurements. Local errors in Y(i) are +C compared to 1.0/EWT(i) in various error tests. +C SAVF = an array of working storage, of length N. +C Also used for input of YH(*,MAXORD+2) when JSTART = -1 +C and MAXORD .lt. the current order NQ. +C ACOR = a work array of length N, used for the accumulated +C corrections. On a successful return, ACOR(i) contains +C the estimated one-step local error in Y(i). +C WM,IWM = real and integer work arrays associated with matrix +C operations in chord iteration (MITER .ne. 0). +C PJAC = name of routine to evaluate and preprocess Jacobian matrix +C and P = I - h*el0*JAC, if a chord method is being used. +C SLVS = name of routine to solve linear system in chord iteration. +C CCMAX = maximum relative change in h*el0 before PJAC is called. +C H = the step size to be attempted on the next step. +C H is altered by the error control algorithm during the +C problem. H can be either positive or negative, but its +C sign must remain constant throughout the problem. +C HMIN = the minimum absolute value of the step size h to be used. +C HMXI = inverse of the maximum absolute value of h to be used. +C HMXI = 0.0 is allowed and corresponds to an infinite hmax. +C HMIN and HMXI may be changed at any time, but will not +C take effect until the next change of h is considered. +C TN = the independent variable. TN is updated on each step taken. +C JSTART = an integer used for input only, with the following +C values and meanings: +C 0 perform the first step. +C .gt.0 take a new step continuing from the last. +C -1 take the next step with a new value of H, MAXORD, +C N, METH, MITER, and/or matrix parameters. +C -2 take the next step with a new value of H, +C but with other inputs unchanged. +C On return, JSTART is set to 1 to facilitate continuation. +C KFLAG = a completion code with the following meanings: +C 0 the step was succesful. +C -1 the requested error could not be achieved. +C -2 corrector convergence could not be achieved. +C -3 fatal error in PJAC or SLVS. +C A return with KFLAG = -1 or -2 means either +C abs(H) = HMIN or 10 consecutive failures occurred. +C On a return with KFLAG negative, the values of TN and +C the YH array are as of the beginning of the last +C step, and H is the last step size attempted. +C MAXORD = the maximum order of integration method to be allowed. +C MAXCOR = the maximum number of corrector iterations allowed. +C MSBP = maximum number of steps between PJAC calls (MITER .gt. 0). +C MXNCF = maximum number of convergence failures allowed. +C METH/MITER = the method flags. See description in driver. +C N = the number of first-order differential equations. +C The values of CCMAX, H, HMIN, HMXI, TN, JSTART, KFLAG, MAXORD, +C MAXCOR, MSBP, MXNCF, METH, MITER, and N are communicated via COMMON. +C +C***SEE ALSO SLSODE +C***ROUTINES CALLED SCFODE, SVNORM +C***COMMON BLOCKS SLS001 +C***REVISION HISTORY (YYMMDD) +C 791129 DATE WRITTEN +C 890501 Modified prologue to SLATEC/LDOC format. (FNF) +C 890503 Minor cosmetic changes. (FNF) +C 930809 Renamed to allow single/double precision versions. (ACH) +C 010413 Reduced size of Common block /SLS001/. (ACH) +C 031105 Restored 'own' variables to Common block /SLS001/, to +C enable interrupt/restart feature. (ACH) +C***END PROLOGUE SSTODE +C**End + EXTERNAL F, JAC, PJAC, SLVS + INTEGER NEQ, NYH, IWM + REAL Y, YH, YH1, EWT, SAVF, ACOR, WM + DIMENSION NEQ(*), Y(*), YH(NYH,*), YH1(*), EWT(*), SAVF(*), + 1 ACOR(*), WM(*), IWM(*) + INTEGER INIT, MXSTEP, MXHNIL, NHNIL, NSLAST, CNYH, + 1 IALTH, IPUP, LMAX, MEO, NQNYH, NSLP, + 1 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, + 2 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, + 3 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU + INTEGER I, I1, IREDO, IRET, J, JB, M, NCF, NEWQ + REAL CONIT, CRATE, EL, ELCO, HOLD, RMAX, TESCO, + 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND + REAL DCON, DDN, DEL, DELP, DSM, DUP, EXDN, EXSM, EXUP, + 1 R, RH, RHDN, RHSM, RHUP, TOLD, SVNORM + COMMON /SLS001/ CONIT, CRATE, EL(13), ELCO(13,12), + 1 HOLD, RMAX, TESCO(3,12), + 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, + 2 INIT, MXSTEP, MXHNIL, NHNIL, NSLAST, CNYH, + 3 IALTH, IPUP, LMAX, MEO, NQNYH, NSLP, + 3 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, + 4 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, + 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU +C +C***FIRST EXECUTABLE STATEMENT SSTODE + KFLAG = 0 + TOLD = TN + NCF = 0 + IERPJ = 0 + IERSL = 0 + JCUR = 0 + ICF = 0 + DELP = 0.0E0 + IF (JSTART .GT. 0) GO TO 200 + IF (JSTART .EQ. -1) GO TO 100 + IF (JSTART .EQ. -2) GO TO 160 +C----------------------------------------------------------------------- +C On the first call, the order is set to 1, and other variables are +C initialized. RMAX is the maximum ratio by which H can be increased +C in a single step. It is initially 1.E4 to compensate for the small +C initial H, but then is normally equal to 10. If a failure +C occurs (in corrector convergence or error test), RMAX is set to 2 +C for the next increase. +C----------------------------------------------------------------------- + LMAX = MAXORD + 1 + NQ = 1 + L = 2 + IALTH = 2 + RMAX = 10000.0E0 + RC = 0.0E0 + EL0 = 1.0E0 + CRATE = 0.7E0 + HOLD = H + MEO = METH + NSLP = 0 + IPUP = MITER + IRET = 3 + GO TO 140 +C----------------------------------------------------------------------- +C The following block handles preliminaries needed when JSTART = -1. +C IPUP is set to MITER to force a matrix update. +C If an order increase is about to be considered (IALTH = 1), +C IALTH is reset to 2 to postpone consideration one more step. +C If the caller has changed METH, SCFODE is called to reset +C the coefficients of the method. +C If the caller has changed MAXORD to a value less than the current +C order NQ, NQ is reduced to MAXORD, and a new H chosen accordingly. +C If H is to be changed, YH must be rescaled. +C If H or METH is being changed, IALTH is reset to L = NQ + 1 +C to prevent further changes in H for that many steps. +C----------------------------------------------------------------------- + 100 IPUP = MITER + LMAX = MAXORD + 1 + IF (IALTH .EQ. 1) IALTH = 2 + IF (METH .EQ. MEO) GO TO 110 + CALL SCFODE (METH, ELCO, TESCO) + MEO = METH + IF (NQ .GT. MAXORD) GO TO 120 + IALTH = L + IRET = 1 + GO TO 150 + 110 IF (NQ .LE. MAXORD) GO TO 160 + 120 NQ = MAXORD + L = LMAX + DO 125 I = 1,L + 125 EL(I) = ELCO(I,NQ) + NQNYH = NQ*NYH + RC = RC*EL(1)/EL0 + EL0 = EL(1) + CONIT = 0.5E0/(NQ+2) + DDN = SVNORM (N, SAVF, EWT)/TESCO(1,L) + EXDN = 1.0E0/L + RHDN = 1.0E0/(1.3E0*DDN**EXDN + 0.0000013E0) + RH = MIN(RHDN,1.0E0) + IREDO = 3 + IF (H .EQ. HOLD) GO TO 170 + RH = MIN(RH,ABS(H/HOLD)) + H = HOLD + GO TO 175 +C----------------------------------------------------------------------- +C SCFODE is called to get all the integration coefficients for the +C current METH. Then the EL vector and related constants are reset +C whenever the order NQ is changed, or at the start of the problem. +C----------------------------------------------------------------------- + 140 CALL SCFODE (METH, ELCO, TESCO) + 150 DO 155 I = 1,L + 155 EL(I) = ELCO(I,NQ) + NQNYH = NQ*NYH + RC = RC*EL(1)/EL0 + EL0 = EL(1) + CONIT = 0.5E0/(NQ+2) + GO TO (160, 170, 200), IRET +C----------------------------------------------------------------------- +C If H is being changed, the H ratio RH is checked against +C RMAX, HMIN, and HMXI, and the YH array rescaled. IALTH is set to +C L = NQ + 1 to prevent a change of H for that many steps, unless +C forced by a convergence or error test failure. +C----------------------------------------------------------------------- + 160 IF (H .EQ. HOLD) GO TO 200 + RH = H/HOLD + H = HOLD + IREDO = 3 + GO TO 175 + 170 RH = MAX(RH,HMIN/ABS(H)) + 175 RH = MIN(RH,RMAX) + RH = RH/MAX(1.0E0,ABS(H)*HMXI*RH) + R = 1.0E0 + DO 180 J = 2,L + R = R*RH + DO 180 I = 1,N + 180 YH(I,J) = YH(I,J)*R + H = H*RH + RC = RC*RH + IALTH = L + IF (IREDO .EQ. 0) GO TO 690 +C----------------------------------------------------------------------- +C This section computes the predicted values by effectively +C multiplying the YH array by the Pascal Triangle matrix. +C RC is the ratio of new to old values of the coefficient H*EL(1). +C When RC differs from 1 by more than CCMAX, IPUP is set to MITER +C to force PJAC to be called, if a Jacobian is involved. +C In any case, PJAC is called at least every MSBP steps. +C----------------------------------------------------------------------- + 200 IF (ABS(RC-1.0E0) .GT. CCMAX) IPUP = MITER + IF (NST .GE. NSLP+MSBP) IPUP = MITER + TN = TN + H + I1 = NQNYH + 1 + DO 215 JB = 1,NQ + I1 = I1 - NYH +Cdir$ ivdep + DO 210 I = I1,NQNYH + 210 YH1(I) = YH1(I) + YH1(I+NYH) + 215 CONTINUE +C----------------------------------------------------------------------- +C Up to MAXCOR corrector iterations are taken. A convergence test is +C made on the R.M.S. norm of each correction, weighted by the error +C weight vector EWT. The sum of the corrections is accumulated in the +C vector ACOR(i). The YH array is not altered in the corrector loop. +C----------------------------------------------------------------------- + 220 M = 0 + DO 230 I = 1,N + 230 Y(I) = YH(I,1) + CALL F (NEQ, TN, Y, SAVF) + NFE = NFE + 1 + IF (IPUP .LE. 0) GO TO 250 +C----------------------------------------------------------------------- +C If indicated, the matrix P = I - h*el(1)*J is reevaluated and +C preprocessed before starting the corrector iteration. IPUP is set +C to 0 as an indicator that this has been done. +C----------------------------------------------------------------------- + CALL PJAC (NEQ, Y, YH, NYH, EWT, ACOR, SAVF, WM, IWM, F, JAC) + IPUP = 0 + RC = 1.0E0 + NSLP = NST + CRATE = 0.7E0 + IF (IERPJ .NE. 0) GO TO 430 + 250 DO 260 I = 1,N + 260 ACOR(I) = 0.0E0 + 270 IF (MITER .NE. 0) GO TO 350 +C----------------------------------------------------------------------- +C In the case of functional iteration, update Y directly from +C the result of the last function evaluation. +C----------------------------------------------------------------------- + DO 290 I = 1,N + SAVF(I) = H*SAVF(I) - YH(I,2) + 290 Y(I) = SAVF(I) - ACOR(I) + DEL = SVNORM (N, Y, EWT) + DO 300 I = 1,N + Y(I) = YH(I,1) + EL(1)*SAVF(I) + 300 ACOR(I) = SAVF(I) + GO TO 400 +C----------------------------------------------------------------------- +C In the case of the chord method, compute the corrector error, +C and solve the linear system with that as right-hand side and +C P as coefficient matrix. +C----------------------------------------------------------------------- + 350 DO 360 I = 1,N + 360 Y(I) = H*SAVF(I) - (YH(I,2) + ACOR(I)) + CALL SLVS (WM, IWM, Y, SAVF) + IF (IERSL .LT. 0) GO TO 430 + IF (IERSL .GT. 0) GO TO 410 + DEL = SVNORM (N, Y, EWT) + DO 380 I = 1,N + ACOR(I) = ACOR(I) + Y(I) + 380 Y(I) = YH(I,1) + EL(1)*ACOR(I) +C----------------------------------------------------------------------- +C Test for convergence. If M.gt.0, an estimate of the convergence +C rate constant is stored in CRATE, and this is used in the test. +C----------------------------------------------------------------------- + 400 IF (M .NE. 0) CRATE = MAX(0.2E0*CRATE,DEL/DELP) + DCON = DEL*MIN(1.0E0,1.5E0*CRATE)/(TESCO(2,NQ)*CONIT) + IF (DCON .LE. 1.0E0) GO TO 450 + M = M + 1 + IF (M .EQ. MAXCOR) GO TO 410 + IF (M .GE. 2 .AND. DEL .GT. 2.0E0*DELP) GO TO 410 + DELP = DEL + CALL F (NEQ, TN, Y, SAVF) + NFE = NFE + 1 + GO TO 270 +C----------------------------------------------------------------------- +C The corrector iteration failed to converge. +C If MITER .ne. 0 and the Jacobian is out of date, PJAC is called for +C the next try. Otherwise the YH array is retracted to its values +C before prediction, and H is reduced, if possible. If H cannot be +C reduced or MXNCF failures have occurred, exit with KFLAG = -2. +C----------------------------------------------------------------------- + 410 IF (MITER .EQ. 0 .OR. JCUR .EQ. 1) GO TO 430 + ICF = 1 + IPUP = MITER + GO TO 220 + 430 ICF = 2 + NCF = NCF + 1 + RMAX = 2.0E0 + TN = TOLD + I1 = NQNYH + 1 + DO 445 JB = 1,NQ + I1 = I1 - NYH +Cdir$ ivdep + DO 440 I = I1,NQNYH + 440 YH1(I) = YH1(I) - YH1(I+NYH) + 445 CONTINUE + IF (IERPJ .LT. 0 .OR. IERSL .LT. 0) GO TO 680 + IF (ABS(H) .LE. HMIN*1.00001E0) GO TO 670 + IF (NCF .EQ. MXNCF) GO TO 670 + RH = 0.25E0 + IPUP = MITER + IREDO = 1 + GO TO 170 +C----------------------------------------------------------------------- +C The corrector has converged. JCUR is set to 0 +C to signal that the Jacobian involved may need updating later. +C The local error test is made and control passes to statement 500 +C if it fails. +C----------------------------------------------------------------------- + 450 JCUR = 0 + IF (M .EQ. 0) DSM = DEL/TESCO(2,NQ) + IF (M .GT. 0) DSM = SVNORM (N, ACOR, EWT)/TESCO(2,NQ) + IF (DSM .GT. 1.0E0) GO TO 500 +C----------------------------------------------------------------------- +C After a successful step, update the YH array. +C Consider changing H if IALTH = 1. Otherwise decrease IALTH by 1. +C If IALTH is then 1 and NQ .lt. MAXORD, then ACOR is saved for +C use in a possible order increase on the next step. +C If a change in H is considered, an increase or decrease in order +C by one is considered also. A change in H is made only if it is by a +C factor of at least 1.1. If not, IALTH is set to 3 to prevent +C testing for that many steps. +C----------------------------------------------------------------------- + KFLAG = 0 + IREDO = 0 + NST = NST + 1 + HU = H + NQU = NQ + DO 470 J = 1,L + DO 470 I = 1,N + 470 YH(I,J) = YH(I,J) + EL(J)*ACOR(I) + IALTH = IALTH - 1 + IF (IALTH .EQ. 0) GO TO 520 + IF (IALTH .GT. 1) GO TO 700 + IF (L .EQ. LMAX) GO TO 700 + DO 490 I = 1,N + 490 YH(I,LMAX) = ACOR(I) + GO TO 700 +C----------------------------------------------------------------------- +C The error test failed. KFLAG keeps track of multiple failures. +C Restore TN and the YH array to their previous values, and prepare +C to try the step again. Compute the optimum step size for this or +C one lower order. After 2 or more failures, H is forced to decrease +C by a factor of 0.2 or less. +C----------------------------------------------------------------------- + 500 KFLAG = KFLAG - 1 + TN = TOLD + I1 = NQNYH + 1 + DO 515 JB = 1,NQ + I1 = I1 - NYH +Cdir$ ivdep + DO 510 I = I1,NQNYH + 510 YH1(I) = YH1(I) - YH1(I+NYH) + 515 CONTINUE + RMAX = 2.0E0 + IF (ABS(H) .LE. HMIN*1.00001E0) GO TO 660 + IF (KFLAG .LE. -3) GO TO 640 + IREDO = 2 + RHUP = 0.0E0 + GO TO 540 +C----------------------------------------------------------------------- +C Regardless of the success or failure of the step, factors +C RHDN, RHSM, and RHUP are computed, by which H could be multiplied +C at order NQ - 1, order NQ, or order NQ + 1, respectively. +C In the case of failure, RHUP = 0.0 to avoid an order increase. +C The largest of these is determined and the new order chosen +C accordingly. If the order is to be increased, we compute one +C additional scaled derivative. +C----------------------------------------------------------------------- + 520 RHUP = 0.0E0 + IF (L .EQ. LMAX) GO TO 540 + DO 530 I = 1,N + 530 SAVF(I) = ACOR(I) - YH(I,LMAX) + DUP = SVNORM (N, SAVF, EWT)/TESCO(3,NQ) + EXUP = 1.0E0/(L+1) + RHUP = 1.0E0/(1.4E0*DUP**EXUP + 0.0000014E0) + 540 EXSM = 1.0E0/L + RHSM = 1.0E0/(1.2E0*DSM**EXSM + 0.0000012E0) + RHDN = 0.0E0 + IF (NQ .EQ. 1) GO TO 560 + DDN = SVNORM (N, YH(1,L), EWT)/TESCO(1,NQ) + EXDN = 1.0E0/NQ + RHDN = 1.0E0/(1.3E0*DDN**EXDN + 0.0000013E0) + 560 IF (RHSM .GE. RHUP) GO TO 570 + IF (RHUP .GT. RHDN) GO TO 590 + GO TO 580 + 570 IF (RHSM .LT. RHDN) GO TO 580 + NEWQ = NQ + RH = RHSM + GO TO 620 + 580 NEWQ = NQ - 1 + RH = RHDN + IF (KFLAG .LT. 0 .AND. RH .GT. 1.0E0) RH = 1.0E0 + GO TO 620 + 590 NEWQ = L + RH = RHUP + IF (RH .LT. 1.1E0) GO TO 610 + R = EL(L)/L + DO 600 I = 1,N + 600 YH(I,NEWQ+1) = ACOR(I)*R + GO TO 630 + 610 IALTH = 3 + GO TO 700 + 620 IF ((KFLAG .EQ. 0) .AND. (RH .LT. 1.1E0)) GO TO 610 + IF (KFLAG .LE. -2) RH = MIN(RH,0.2E0) +C----------------------------------------------------------------------- +C If there is a change of order, reset NQ, l, and the coefficients. +C In any case H is reset according to RH and the YH array is rescaled. +C Then exit from 690 if the step was OK, or redo the step otherwise. +C----------------------------------------------------------------------- + IF (NEWQ .EQ. NQ) GO TO 170 + 630 NQ = NEWQ + L = NQ + 1 + IRET = 2 + GO TO 150 +C----------------------------------------------------------------------- +C Control reaches this section if 3 or more failures have occurred. +C If 10 failures have occurred, exit with KFLAG = -1. +C It is assumed that the derivatives that have accumulated in the +C YH array have errors of the wrong order. Hence the first +C derivative is recomputed, and the order is set to 1. Then +C H is reduced by a factor of 10, and the step is retried, +C until it succeeds or H reaches HMIN. +C----------------------------------------------------------------------- + 640 IF (KFLAG .EQ. -10) GO TO 660 + RH = 0.1E0 + RH = MAX(HMIN/ABS(H),RH) + H = H*RH + DO 645 I = 1,N + 645 Y(I) = YH(I,1) + CALL F (NEQ, TN, Y, SAVF) + NFE = NFE + 1 + DO 650 I = 1,N + 650 YH(I,2) = H*SAVF(I) + IPUP = MITER + IALTH = 5 + IF (NQ .EQ. 1) GO TO 200 + NQ = 1 + L = 2 + IRET = 3 + GO TO 150 +C----------------------------------------------------------------------- +C All returns are made through this section. H is saved in HOLD +C to allow the caller to change H on the next step. +C----------------------------------------------------------------------- + 660 KFLAG = -1 + GO TO 720 + 670 KFLAG = -2 + GO TO 720 + 680 KFLAG = -3 + GO TO 720 + 690 RMAX = 10.0E0 + 700 R = 1.0E0/TESCO(2,NQU) + DO 710 I = 1,N + 710 ACOR(I) = ACOR(I)*R + 720 HOLD = H + JSTART = 1 + RETURN +C----------------------- END OF SUBROUTINE SSTODE ---------------------- + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/odepack/stode.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,487 @@ + SUBROUTINE STODE (NEQ, Y, YH, NYH, YH1, EWT, SAVF, ACOR, + 1 WM, IWM, F, JAC, PJAC, SLVS, IERR) +CLLL. OPTIMIZE + EXTERNAL F, JAC, PJAC, SLVS + INTEGER NEQ, NYH, IWM + INTEGER ILLIN, INIT, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, + 1 MXSTEP, MXHNIL, NHNIL, NTREP, NSLAST, CNYH, + 2 IALTH, IPUP, LMAX, MEO, NQNYH, NSLP + INTEGER ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, METH, MITER, + 1 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU + INTEGER I, I1, IREDO, IRET, J, JB, M, NCF, NEWQ + DOUBLE PRECISION Y, YH, YH1, EWT, SAVF, ACOR, WM + DOUBLE PRECISION CONIT, CRATE, EL, ELCO, HOLD, RMAX, TESCO, + 2 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND + DOUBLE PRECISION DCON, DDN, DEL, DELP, DSM, DUP, EXDN, EXSM, EXUP, + 1 R, RH, RHDN, RHSM, RHUP, TOLD, VNORM + DIMENSION NEQ(*), Y(*), YH(NYH,*), YH1(*), EWT(*), SAVF(*), + 1 ACOR(*), WM(*), IWM(*) + COMMON /LS0001/ CONIT, CRATE, EL(13), ELCO(13,12), + 1 HOLD, RMAX, TESCO(3,12), + 2 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, + 2 ILLIN, INIT, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, + 3 MXSTEP, MXHNIL, NHNIL, NTREP, NSLAST, CNYH, + 3 IALTH, IPUP, LMAX, MEO, NQNYH, NSLP, + 4 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, METH, MITER, + 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU +C----------------------------------------------------------------------- +C STODE PERFORMS ONE STEP OF THE INTEGRATION OF AN INITIAL VALUE +C PROBLEM FOR A SYSTEM OF ORDINARY DIFFERENTIAL EQUATIONS. +C NOTE.. STODE IS INDEPENDENT OF THE VALUE OF THE ITERATION METHOD +C INDICATOR MITER, WHEN THIS IS .NE. 0, AND HENCE IS INDEPENDENT +C OF THE TYPE OF CHORD METHOD USED, OR THE JACOBIAN STRUCTURE. +C COMMUNICATION WITH STODE IS DONE WITH THE FOLLOWING VARIABLES.. +C +C NEQ = INTEGER ARRAY CONTAINING PROBLEM SIZE IN NEQ(1), AND +C PASSED AS THE NEQ ARGUMENT IN ALL CALLS TO F AND JAC. +C Y = AN ARRAY OF LENGTH .GE. N USED AS THE Y ARGUMENT IN +C ALL CALLS TO F AND JAC. +C YH = AN NYH BY LMAX ARRAY CONTAINING THE DEPENDENT VARIABLES +C AND THEIR APPROXIMATE SCALED DERIVATIVES, WHERE +C LMAX = MAXORD + 1. YH(I,J+1) CONTAINS THE APPROXIMATE +C J-TH DERIVATIVE OF Y(I), SCALED BY H**J/FACTORIAL(J) +C (J = 0,1,...,NQ). ON ENTRY FOR THE FIRST STEP, THE FIRST +C TWO COLUMNS OF YH MUST BE SET FROM THE INITIAL VALUES. +C NYH = A CONSTANT INTEGER .GE. N, THE FIRST DIMENSION OF YH. +C YH1 = A ONE-DIMENSIONAL ARRAY OCCUPYING THE SAME SPACE AS YH. +C EWT = AN ARRAY OF LENGTH N CONTAINING MULTIPLICATIVE WEIGHTS +C FOR LOCAL ERROR MEASUREMENTS. LOCAL ERRORS IN Y(I) ARE +C COMPARED TO 1.0/EWT(I) IN VARIOUS ERROR TESTS. +C SAVF = AN ARRAY OF WORKING STORAGE, OF LENGTH N. +C ALSO USED FOR INPUT OF YH(*,MAXORD+2) WHEN JSTART = -1 +C AND MAXORD .LT. THE CURRENT ORDER NQ. +C ACOR = A WORK ARRAY OF LENGTH N, USED FOR THE ACCUMULATED +C CORRECTIONS. ON A SUCCESSFUL RETURN, ACOR(I) CONTAINS +C THE ESTIMATED ONE-STEP LOCAL ERROR IN Y(I). +C WM,IWM = REAL AND INTEGER WORK ARRAYS ASSOCIATED WITH MATRIX +C OPERATIONS IN CHORD ITERATION (MITER .NE. 0). +C PJAC = NAME OF ROUTINE TO EVALUATE AND PREPROCESS JACOBIAN MATRIX +C AND P = I - H*EL0*JAC, IF A CHORD METHOD IS BEING USED. +C SLVS = NAME OF ROUTINE TO SOLVE LINEAR SYSTEM IN CHORD ITERATION. +C CCMAX = MAXIMUM RELATIVE CHANGE IN H*EL0 BEFORE PJAC IS CALLED. +C H = THE STEP SIZE TO BE ATTEMPTED ON THE NEXT STEP. +C H IS ALTERED BY THE ERROR CONTROL ALGORITHM DURING THE +C PROBLEM. H CAN BE EITHER POSITIVE OR NEGATIVE, BUT ITS +C SIGN MUST REMAIN CONSTANT THROUGHOUT THE PROBLEM. +C HMIN = THE MINIMUM ABSOLUTE VALUE OF THE STEP SIZE H TO BE USED. +C HMXI = INVERSE OF THE MAXIMUM ABSOLUTE VALUE OF H TO BE USED. +C HMXI = 0.0 IS ALLOWED AND CORRESPONDS TO AN INFINITE HMAX. +C HMIN AND HMXI MAY BE CHANGED AT ANY TIME, BUT WILL NOT +C TAKE EFFECT UNTIL THE NEXT CHANGE OF H IS CONSIDERED. +C TN = THE INDEPENDENT VARIABLE. TN IS UPDATED ON EACH STEP TAKEN. +C JSTART = AN INTEGER USED FOR INPUT ONLY, WITH THE FOLLOWING +C VALUES AND MEANINGS.. +C 0 PERFORM THE FIRST STEP. +C .GT.0 TAKE A NEW STEP CONTINUING FROM THE LAST. +C -1 TAKE THE NEXT STEP WITH A NEW VALUE OF H, MAXORD, +C N, METH, MITER, AND/OR MATRIX PARAMETERS. +C -2 TAKE THE NEXT STEP WITH A NEW VALUE OF H, +C BUT WITH OTHER INPUTS UNCHANGED. +C ON RETURN, JSTART IS SET TO 1 TO FACILITATE CONTINUATION. +C KFLAG = A COMPLETION CODE WITH THE FOLLOWING MEANINGS.. +C 0 THE STEP WAS SUCCESFUL. +C -1 THE REQUESTED ERROR COULD NOT BE ACHIEVED. +C -2 CORRECTOR CONVERGENCE COULD NOT BE ACHIEVED. +C -3 FATAL ERROR IN PJAC OR SLVS. +C A RETURN WITH KFLAG = -1 OR -2 MEANS EITHER +C ABS(H) = HMIN OR 10 CONSECUTIVE FAILURES OCCURRED. +C ON A RETURN WITH KFLAG NEGATIVE, THE VALUES OF TN AND +C THE YH ARRAY ARE AS OF THE BEGINNING OF THE LAST +C STEP, AND H IS THE LAST STEP SIZE ATTEMPTED. +C MAXORD = THE MAXIMUM ORDER OF INTEGRATION METHOD TO BE ALLOWED. +C MAXCOR = THE MAXIMUM NUMBER OF CORRECTOR ITERATIONS ALLOWED. +C MSBP = MAXIMUM NUMBER OF STEPS BETWEEN PJAC CALLS (MITER .GT. 0). +C MXNCF = MAXIMUM NUMBER OF CONVERGENCE FAILURES ALLOWED. +C METH/MITER = THE METHOD FLAGS. SEE DESCRIPTION IN DRIVER. +C N = THE NUMBER OF FIRST-ORDER DIFFERENTIAL EQUATIONS. +C IERR = ERROR FLAG FROM USER-SUPPLIED FUNCTION +C----------------------------------------------------------------------- + KFLAG = 0 + TOLD = TN + NCF = 0 + IERPJ = 0 + IERSL = 0 + JCUR = 0 + ICF = 0 + DELP = 0.0D0 + IF (JSTART .GT. 0) GO TO 200 + IF (JSTART .EQ. -1) GO TO 100 + IF (JSTART .EQ. -2) GO TO 160 +C----------------------------------------------------------------------- +C ON THE FIRST CALL, THE ORDER IS SET TO 1, AND OTHER VARIABLES ARE +C INITIALIZED. RMAX IS THE MAXIMUM RATIO BY WHICH H CAN BE INCREASED +C IN A SINGLE STEP. IT IS INITIALLY 1.E4 TO COMPENSATE FOR THE SMALL +C INITIAL H, BUT THEN IS NORMALLY EQUAL TO 10. IF A FAILURE +C OCCURS (IN CORRECTOR CONVERGENCE OR ERROR TEST), RMAX IS SET AT 2 +C FOR THE NEXT INCREASE. +C----------------------------------------------------------------------- + LMAX = MAXORD + 1 + NQ = 1 + L = 2 + IALTH = 2 + RMAX = 10000.0D0 + RC = 0.0D0 + EL0 = 1.0D0 + CRATE = 0.7D0 + HOLD = H + MEO = METH + NSLP = 0 + IPUP = MITER + IRET = 3 + GO TO 140 +C----------------------------------------------------------------------- +C THE FOLLOWING BLOCK HANDLES PRELIMINARIES NEEDED WHEN JSTART = -1. +C IPUP IS SET TO MITER TO FORCE A MATRIX UPDATE. +C IF AN ORDER INCREASE IS ABOUT TO BE CONSIDERED (IALTH = 1), +C IALTH IS RESET TO 2 TO POSTPONE CONSIDERATION ONE MORE STEP. +C IF THE CALLER HAS CHANGED METH, CFODE IS CALLED TO RESET +C THE COEFFICIENTS OF THE METHOD. +C IF THE CALLER HAS CHANGED MAXORD TO A VALUE LESS THAN THE CURRENT +C ORDER NQ, NQ IS REDUCED TO MAXORD, AND A NEW H CHOSEN ACCORDINGLY. +C IF H IS TO BE CHANGED, YH MUST BE RESCALED. +C IF H OR METH IS BEING CHANGED, IALTH IS RESET TO L = NQ + 1 +C TO PREVENT FURTHER CHANGES IN H FOR THAT MANY STEPS. +C----------------------------------------------------------------------- + 100 IPUP = MITER + LMAX = MAXORD + 1 + IF (IALTH .EQ. 1) IALTH = 2 + IF (METH .EQ. MEO) GO TO 110 + CALL CFODE (METH, ELCO, TESCO) + MEO = METH + IF (NQ .GT. MAXORD) GO TO 120 + IALTH = L + IRET = 1 + GO TO 150 + 110 IF (NQ .LE. MAXORD) GO TO 160 + 120 NQ = MAXORD + L = LMAX + DO 125 I = 1,L + 125 EL(I) = ELCO(I,NQ) + NQNYH = NQ*NYH + RC = RC*EL(1)/EL0 + EL0 = EL(1) + CONIT = 0.5D0/DBLE(NQ+2) + DDN = VNORM (N, SAVF, EWT)/TESCO(1,L) + EXDN = 1.0D0/DBLE(L) + RHDN = 1.0D0/(1.3D0*DDN**EXDN + 0.0000013D0) + RH = DMIN1(RHDN,1.0D0) + IREDO = 3 + IF (H .EQ. HOLD) GO TO 170 + RH = DMIN1(RH,DABS(H/HOLD)) + H = HOLD + GO TO 175 +C----------------------------------------------------------------------- +C CFODE IS CALLED TO GET ALL THE INTEGRATION COEFFICIENTS FOR THE +C CURRENT METH. THEN THE EL VECTOR AND RELATED CONSTANTS ARE RESET +C WHENEVER THE ORDER NQ IS CHANGED, OR AT THE START OF THE PROBLEM. +C----------------------------------------------------------------------- + 140 CALL CFODE (METH, ELCO, TESCO) + 150 DO 155 I = 1,L + 155 EL(I) = ELCO(I,NQ) + NQNYH = NQ*NYH + RC = RC*EL(1)/EL0 + EL0 = EL(1) + CONIT = 0.5D0/DBLE(NQ+2) + GO TO (160, 170, 200), IRET +C----------------------------------------------------------------------- +C IF H IS BEING CHANGED, THE H RATIO RH IS CHECKED AGAINST +C RMAX, HMIN, AND HMXI, AND THE YH ARRAY RESCALED. IALTH IS SET TO +C L = NQ + 1 TO PREVENT A CHANGE OF H FOR THAT MANY STEPS, UNLESS +C FORCED BY A CONVERGENCE OR ERROR TEST FAILURE. +C----------------------------------------------------------------------- + 160 IF (H .EQ. HOLD) GO TO 200 + RH = H/HOLD + H = HOLD + IREDO = 3 + GO TO 175 + 170 RH = DMAX1(RH,HMIN/DABS(H)) + 175 RH = DMIN1(RH,RMAX) + RH = RH/DMAX1(1.0D0,DABS(H)*HMXI*RH) + R = 1.0D0 + DO 180 J = 2,L + R = R*RH + DO 180 I = 1,N + 180 YH(I,J) = YH(I,J)*R + H = H*RH + RC = RC*RH + IALTH = L + IF (IREDO .EQ. 0) GO TO 690 +C----------------------------------------------------------------------- +C THIS SECTION COMPUTES THE PREDICTED VALUES BY EFFECTIVELY +C MULTIPLYING THE YH ARRAY BY THE PASCAL TRIANGLE MATRIX. +C RC IS THE RATIO OF NEW TO OLD VALUES OF THE COEFFICIENT H*EL(1). +C WHEN RC DIFFERS FROM 1 BY MORE THAN CCMAX, IPUP IS SET TO MITER +C TO FORCE PJAC TO BE CALLED, IF A JACOBIAN IS INVOLVED. +C IN ANY CASE, PJAC IS CALLED AT LEAST EVERY MSBP STEPS. +C----------------------------------------------------------------------- + 200 IF (DABS(RC-1.0D0) .GT. CCMAX) IPUP = MITER + IF (NST .GE. NSLP+MSBP) IPUP = MITER + TN = TN + H + I1 = NQNYH + 1 + DO 215 JB = 1,NQ + I1 = I1 - NYH +CDIR$ IVDEP + DO 210 I = I1,NQNYH + 210 YH1(I) = YH1(I) + YH1(I+NYH) + 215 CONTINUE +C----------------------------------------------------------------------- +C UP TO MAXCOR CORRECTOR ITERATIONS ARE TAKEN. A CONVERGENCE TEST IS +C MADE ON THE R.M.S. NORM OF EACH CORRECTION, WEIGHTED BY THE ERROR +C WEIGHT VECTOR EWT. THE SUM OF THE CORRECTIONS IS ACCUMULATED IN THE +C VECTOR ACOR(I). THE YH ARRAY IS NOT ALTERED IN THE CORRECTOR LOOP. +C----------------------------------------------------------------------- + 220 M = 0 + DO 230 I = 1,N + 230 Y(I) = YH(I,1) + IERR = 0 + CALL F (NEQ, TN, Y, SAVF, IERR) + IF (IERR .LT. 0) RETURN + NFE = NFE + 1 + IF (IPUP .LE. 0) GO TO 250 +C----------------------------------------------------------------------- +C IF INDICATED, THE MATRIX P = I - H*EL(1)*J IS REEVALUATED AND +C PREPROCESSED BEFORE STARTING THE CORRECTOR ITERATION. IPUP IS SET +C TO 0 AS AN INDICATOR THAT THIS HAS BEEN DONE. +C----------------------------------------------------------------------- + IERR = 0 + CALL PJAC (NEQ, Y, YH, NYH, EWT, ACOR, SAVF, WM, IWM, F, JAC, + 1 IERR) + IF (IERR .LT. 0) RETURN + IPUP = 0 + RC = 1.0D0 + NSLP = NST + CRATE = 0.7D0 + IF (IERPJ .NE. 0) GO TO 430 + 250 DO 260 I = 1,N + 260 ACOR(I) = 0.0D0 + 270 IF (MITER .NE. 0) GO TO 350 +C----------------------------------------------------------------------- +C IN THE CASE OF FUNCTIONAL ITERATION, UPDATE Y DIRECTLY FROM +C THE RESULT OF THE LAST FUNCTION EVALUATION. +C----------------------------------------------------------------------- + DO 290 I = 1,N + SAVF(I) = H*SAVF(I) - YH(I,2) + 290 Y(I) = SAVF(I) - ACOR(I) + DEL = VNORM (N, Y, EWT) + DO 300 I = 1,N + Y(I) = YH(I,1) + EL(1)*SAVF(I) + 300 ACOR(I) = SAVF(I) + GO TO 400 +C----------------------------------------------------------------------- +C IN THE CASE OF THE CHORD METHOD, COMPUTE THE CORRECTOR ERROR, +C AND SOLVE THE LINEAR SYSTEM WITH THAT AS RIGHT-HAND SIDE AND +C P AS COEFFICIENT MATRIX. +C----------------------------------------------------------------------- + 350 DO 360 I = 1,N + 360 Y(I) = H*SAVF(I) - (YH(I,2) + ACOR(I)) + CALL SLVS (WM, IWM, Y, SAVF) + IF (IERSL .LT. 0) GO TO 430 + IF (IERSL .GT. 0) GO TO 410 + DEL = VNORM (N, Y, EWT) + DO 380 I = 1,N + ACOR(I) = ACOR(I) + Y(I) + 380 Y(I) = YH(I,1) + EL(1)*ACOR(I) +C----------------------------------------------------------------------- +C TEST FOR CONVERGENCE. IF M.GT.0, AN ESTIMATE OF THE CONVERGENCE +C RATE CONSTANT IS STORED IN CRATE, AND THIS IS USED IN THE TEST. +C----------------------------------------------------------------------- + 400 IF (M .NE. 0) CRATE = DMAX1(0.2D0*CRATE,DEL/DELP) + DCON = DEL*DMIN1(1.0D0,1.5D0*CRATE)/(TESCO(2,NQ)*CONIT) + IF (DCON .LE. 1.0D0) GO TO 450 + M = M + 1 + IF (M .EQ. MAXCOR) GO TO 410 + IF (M .GE. 2 .AND. DEL .GT. 2.0D0*DELP) GO TO 410 + DELP = DEL + IERR = 0 + CALL F (NEQ, TN, Y, SAVF, IERR) + IF (IERR .LT. 0) RETURN + NFE = NFE + 1 + GO TO 270 +C----------------------------------------------------------------------- +C THE CORRECTOR ITERATION FAILED TO CONVERGE. +C IF MITER .NE. 0 AND THE JACOBIAN IS OUT OF DATE, PJAC IS CALLED FOR +C THE NEXT TRY. OTHERWISE THE YH ARRAY IS RETRACTED TO ITS VALUES +C BEFORE PREDICTION, AND H IS REDUCED, IF POSSIBLE. IF H CANNOT BE +C REDUCED OR MXNCF FAILURES HAVE OCCURRED, EXIT WITH KFLAG = -2. +C----------------------------------------------------------------------- + 410 IF (MITER .EQ. 0 .OR. JCUR .EQ. 1) GO TO 430 + ICF = 1 + IPUP = MITER + GO TO 220 + 430 ICF = 2 + NCF = NCF + 1 + RMAX = 2.0D0 + TN = TOLD + I1 = NQNYH + 1 + DO 445 JB = 1,NQ + I1 = I1 - NYH +CDIR$ IVDEP + DO 440 I = I1,NQNYH + 440 YH1(I) = YH1(I) - YH1(I+NYH) + 445 CONTINUE + IF (IERPJ .LT. 0 .OR. IERSL .LT. 0) GO TO 680 + IF (DABS(H) .LE. HMIN*1.00001D0) GO TO 670 + IF (NCF .EQ. MXNCF) GO TO 670 + RH = 0.25D0 + IPUP = MITER + IREDO = 1 + GO TO 170 +C----------------------------------------------------------------------- +C THE CORRECTOR HAS CONVERGED. JCUR IS SET TO 0 +C TO SIGNAL THAT THE JACOBIAN INVOLVED MAY NEED UPDATING LATER. +C THE LOCAL ERROR TEST IS MADE AND CONTROL PASSES TO STATEMENT 500 +C IF IT FAILS. +C----------------------------------------------------------------------- + 450 JCUR = 0 + IF (M .EQ. 0) DSM = DEL/TESCO(2,NQ) + IF (M .GT. 0) DSM = VNORM (N, ACOR, EWT)/TESCO(2,NQ) + IF (DSM .GT. 1.0D0) GO TO 500 +C----------------------------------------------------------------------- +C AFTER A SUCCESSFUL STEP, UPDATE THE YH ARRAY. +C CONSIDER CHANGING H IF IALTH = 1. OTHERWISE DECREASE IALTH BY 1. +C IF IALTH IS THEN 1 AND NQ .LT. MAXORD, THEN ACOR IS SAVED FOR +C USE IN A POSSIBLE ORDER INCREASE ON THE NEXT STEP. +C IF A CHANGE IN H IS CONSIDERED, AN INCREASE OR DECREASE IN ORDER +C BY ONE IS CONSIDERED ALSO. A CHANGE IN H IS MADE ONLY IF IT IS BY A +C FACTOR OF AT LEAST 1.1. IF NOT, IALTH IS SET TO 3 TO PREVENT +C TESTING FOR THAT MANY STEPS. +C----------------------------------------------------------------------- + KFLAG = 0 + IREDO = 0 + NST = NST + 1 + HU = H + NQU = NQ + DO 470 J = 1,L + DO 470 I = 1,N + 470 YH(I,J) = YH(I,J) + EL(J)*ACOR(I) + IALTH = IALTH - 1 + IF (IALTH .EQ. 0) GO TO 520 + IF (IALTH .GT. 1) GO TO 700 + IF (L .EQ. LMAX) GO TO 700 + DO 490 I = 1,N + 490 YH(I,LMAX) = ACOR(I) + GO TO 700 +C----------------------------------------------------------------------- +C THE ERROR TEST FAILED. KFLAG KEEPS TRACK OF MULTIPLE FAILURES. +C RESTORE TN AND THE YH ARRAY TO THEIR PREVIOUS VALUES, AND PREPARE +C TO TRY THE STEP AGAIN. COMPUTE THE OPTIMUM STEP SIZE FOR THIS OR +C ONE LOWER ORDER. AFTER 2 OR MORE FAILURES, H IS FORCED TO DECREASE +C BY A FACTOR OF 0.2 OR LESS. +C----------------------------------------------------------------------- + 500 KFLAG = KFLAG - 1 + TN = TOLD + I1 = NQNYH + 1 + DO 515 JB = 1,NQ + I1 = I1 - NYH +CDIR$ IVDEP + DO 510 I = I1,NQNYH + 510 YH1(I) = YH1(I) - YH1(I+NYH) + 515 CONTINUE + RMAX = 2.0D0 + IF (DABS(H) .LE. HMIN*1.00001D0) GO TO 660 + IF (KFLAG .LE. -3) GO TO 640 + IREDO = 2 + RHUP = 0.0D0 + GO TO 540 +C----------------------------------------------------------------------- +C REGARDLESS OF THE SUCCESS OR FAILURE OF THE STEP, FACTORS +C RHDN, RHSM, AND RHUP ARE COMPUTED, BY WHICH H COULD BE MULTIPLIED +C AT ORDER NQ - 1, ORDER NQ, OR ORDER NQ + 1, RESPECTIVELY. +C IN THE CASE OF FAILURE, RHUP = 0.0 TO AVOID AN ORDER INCREASE. +C THE LARGEST OF THESE IS DETERMINED AND THE NEW ORDER CHOSEN +C ACCORDINGLY. IF THE ORDER IS TO BE INCREASED, WE COMPUTE ONE +C ADDITIONAL SCALED DERIVATIVE. +C----------------------------------------------------------------------- + 520 RHUP = 0.0D0 + IF (L .EQ. LMAX) GO TO 540 + DO 530 I = 1,N + 530 SAVF(I) = ACOR(I) - YH(I,LMAX) + DUP = VNORM (N, SAVF, EWT)/TESCO(3,NQ) + EXUP = 1.0D0/DBLE(L+1) + RHUP = 1.0D0/(1.4D0*DUP**EXUP + 0.0000014D0) + 540 EXSM = 1.0D0/DBLE(L) + RHSM = 1.0D0/(1.2D0*DSM**EXSM + 0.0000012D0) + RHDN = 0.0D0 + IF (NQ .EQ. 1) GO TO 560 + DDN = VNORM (N, YH(1,L), EWT)/TESCO(1,NQ) + EXDN = 1.0D0/DBLE(NQ) + RHDN = 1.0D0/(1.3D0*DDN**EXDN + 0.0000013D0) + 560 IF (RHSM .GE. RHUP) GO TO 570 + IF (RHUP .GT. RHDN) GO TO 590 + GO TO 580 + 570 IF (RHSM .LT. RHDN) GO TO 580 + NEWQ = NQ + RH = RHSM + GO TO 620 + 580 NEWQ = NQ - 1 + RH = RHDN + IF (KFLAG .LT. 0 .AND. RH .GT. 1.0D0) RH = 1.0D0 + GO TO 620 + 590 NEWQ = L + RH = RHUP + IF (RH .LT. 1.1D0) GO TO 610 + R = EL(L)/DBLE(L) + DO 600 I = 1,N + 600 YH(I,NEWQ+1) = ACOR(I)*R + GO TO 630 + 610 IALTH = 3 + GO TO 700 + 620 IF ((KFLAG .EQ. 0) .AND. (RH .LT. 1.1D0)) GO TO 610 + IF (KFLAG .LE. -2) RH = DMIN1(RH,0.2D0) +C----------------------------------------------------------------------- +C IF THERE IS A CHANGE OF ORDER, RESET NQ, L, AND THE COEFFICIENTS. +C IN ANY CASE H IS RESET ACCORDING TO RH AND THE YH ARRAY IS RESCALED. +C THEN EXIT FROM 690 IF THE STEP WAS OK, OR REDO THE STEP OTHERWISE. +C----------------------------------------------------------------------- + IF (NEWQ .EQ. NQ) GO TO 170 + 630 NQ = NEWQ + L = NQ + 1 + IRET = 2 + GO TO 150 +C----------------------------------------------------------------------- +C CONTROL REACHES THIS SECTION IF 3 OR MORE FAILURES HAVE OCCURRED. +C IF 10 FAILURES HAVE OCCURRED, EXIT WITH KFLAG = -1. +C IT IS ASSUMED THAT THE DERIVATIVES THAT HAVE ACCUMULATED IN THE +C YH ARRAY HAVE ERRORS OF THE WRONG ORDER. HENCE THE FIRST +C DERIVATIVE IS RECOMPUTED, AND THE ORDER IS SET TO 1. THEN +C H IS REDUCED BY A FACTOR OF 10, AND THE STEP IS RETRIED, +C UNTIL IT SUCCEEDS OR H REACHES HMIN. +C----------------------------------------------------------------------- + 640 IF (KFLAG .EQ. -10) GO TO 660 + RH = 0.1D0 + RH = DMAX1(HMIN/DABS(H),RH) + H = H*RH + DO 645 I = 1,N + 645 Y(I) = YH(I,1) + IERR = 0 + CALL F (NEQ, TN, Y, SAVF, IERR) + IF (IERR .LT. 0) RETURN + NFE = NFE + 1 + DO 650 I = 1,N + 650 YH(I,2) = H*SAVF(I) + IPUP = MITER + IALTH = 5 + IF (NQ .EQ. 1) GO TO 200 + NQ = 1 + L = 2 + IRET = 3 + GO TO 150 +C----------------------------------------------------------------------- +C ALL RETURNS ARE MADE THROUGH THIS SECTION. H IS SAVED IN HOLD +C TO ALLOW THE CALLER TO CHANGE H ON THE NEXT STEP. +C----------------------------------------------------------------------- + 660 KFLAG = -1 + GO TO 720 + 670 KFLAG = -2 + GO TO 720 + 680 KFLAG = -3 + GO TO 720 + 690 RMAX = 10.0D0 + 700 R = 1.0D0/TESCO(2,NQU) + DO 710 I = 1,N + 710 ACOR(I) = ACOR(I)*R + 720 HOLD = H + JSTART = 1 + RETURN +C----------------------- END OF SUBROUTINE STODE ----------------------- + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/odepack/svnorm.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,34 @@ + REAL FUNCTION SVNORM (N, V, W) +C***BEGIN PROLOGUE SVNORM +C***SUBSIDIARY +C***PURPOSE Weighted root-mean-square vector norm. +C***TYPE SINGLE PRECISION (SVNORM-S, DVNORM-D) +C***AUTHOR Hindmarsh, Alan C., (LLNL) +C***DESCRIPTION +C +C This function routine computes the weighted root-mean-square norm +C of the vector of length N contained in the array V, with weights +C contained in the array W of length N: +C SVNORM = SQRT( (1/N) * SUM( V(i)*W(i) )**2 ) +C +C***SEE ALSO SLSODE +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 791129 DATE WRITTEN +C 890501 Modified prologue to SLATEC/LDOC format. (FNF) +C 890503 Minor cosmetic changes. (FNF) +C 930809 Renamed to allow single/double precision versions. (ACH) +C***END PROLOGUE SVNORM +C**End + INTEGER N, I + REAL V, W, SUM + DIMENSION V(N), W(N) +C +C***FIRST EXECUTABLE STATEMENT SVNORM + SUM = 0.0E0 + DO 10 I = 1,N + 10 SUM = SUM + (V(I)*W(I))**2 + SVNORM = SQRT(SUM/N) + RETURN +C----------------------- END OF FUNCTION SVNORM ------------------------ + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/odepack/vnorm.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,18 @@ + DOUBLE PRECISION FUNCTION VNORM (N, V, W) +CLLL. OPTIMIZE +C----------------------------------------------------------------------- +C THIS FUNCTION ROUTINE COMPUTES THE WEIGHTED ROOT-MEAN-SQUARE NORM +C OF THE VECTOR OF LENGTH N CONTAINED IN THE ARRAY V, WITH WEIGHTS +C CONTAINED IN THE ARRAY W OF LENGTH N.. +C VNORM = SQRT( (1/N) * SUM( V(I)*W(I) )**2 ) +C----------------------------------------------------------------------- + INTEGER N, I + DOUBLE PRECISION V, W, SUM + DIMENSION V(N), W(N) + SUM = 0.0D0 + DO 10 I = 1,N + 10 SUM = SUM + (V(I)*W(I))**2 + VNORM = DSQRT(SUM/DBLE(N)) + RETURN +C----------------------- END OF FUNCTION VNORM ------------------------- + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/ordered-qz/README Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,2 @@ +Code in this directory is adapted from Paul Van Dooren's toms/590 +code. Modifications are listed in the comment header sections.
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/ordered-qz/dsubsp.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,104 @@ + SUBROUTINE DSUBSP(NMAX, N, A, B, Z, FTEST, EPS, NDIM, FAIL, IND) + INTEGER NMAX, N, FTEST, NDIM, IND(N) + LOGICAL FAIL + DOUBLE PRECISION A(NMAX,N), B(NMAX,N), Z(NMAX,N), EPS +C* +C* GIVEN THE UPPER TRIANGULAR MATRIX B AND UPPER HESSENBERG MATRIX A +C* WITH 1X1 OR 2X2 DIAGONAL BLOCKS, THIS ROUTINE REORDERS THE DIAGONAL +C* BLOCKS ALONG WITH THEIR GENERALIZED EIGENVALUES BY CONSTRUCTING EQUI- +C* VALENCE TRANSFORMATIONS QT AND ZT. THE ROW TRANSFORMATION ZT IS ALSO +C* PERFORMED ON THE GIVEN (INITIAL) TRANSFORMATION Z (RESULTING FROM A +C* POSSIBLE PREVIOUS STEP OR INITIALIZED WITH THE IDENTITY MATRIX). +C* AFTER REORDERING, THE EIGENVALUES INSIDE THE REGION SPECIFIED BY THE +C* FUNCTION FTEST APPEAR AT THE TOP. IF NDIM IS THEIR NUMBER THEN THE +C* NDIM FIRST COLUMNS OF Z SPAN THE REQUESTED SUBSPACE. DSUBSP REQUIRES +C* THE SUBROUTINE EXCHQZ AND THE INTEGER FUNCTION FTEST WHICH HAS TO BE +C* PROVIDED BY THE USER. THE PARAMETERS IN THE CALLING SEQUENCE ARE : +C* (STARRED PARAMETERS ARE ALTERED BY THE SUBROUTINE) +C* +C* NMAX THE FIRST DIMENSION OF A, B AND Z +C* N THE ORDER OF A, B AND Z +C* *A,*B THE MATRIX PAIR WHOSE BLOCKS ARE TO BE REORDERED. +C* *Z UPON RETURN THIS ARRAY IS MULTIPLIED BY THE COLUMN +C* TRANSFORMATION ZT. +C* FTEST(LS,ALPHA,BETA,S,P) AN INTEGER FUNCTION DESCRIBING THE +C* SPECTRUM OF THE DEFLATING SUBSPACE TO BE COMPUTED: +C* WHEN LS=1 FTEST CHECKS IF ALPHA/BETA IS IN THAT SPECTRUM +C* WHEN LS=2 FTEST CHECKS IF THE TWO COMPLEX CONJUGATE +C* ROOTS WITH SUM S AND PRODUCT P ARE IN THAT SPECTRUM +C* IF THE ANSWER IS POSITIVE, FTEST=1, OTHERWISE FTEST=-1 +C* EPS THE REQUIRED ABSOLUTE ACCURACY OF THE RESULT +C* *NDIM AN INTEGER GIVING THE DIMENSION OF THE COMPUTED +C* DEFLATING SUBSPACE +C* *FAIL A LOGICAL VARIABLE WHICH IS FALSE ON A NORMAL RETURN, +C* TRUE OTHERWISE (WHEN EXCHQZ FAILS) +C* *IND AN INTEGER WORKING ARRAY OF DIMENSION AT LEAST N +C* + INTEGER L, LS, LS1, LS2, L1, LL, NUM, IS, L2I, L2K, I, K, II, + * ISTEP, IFIRST + DOUBLE PRECISION S, P, D, ALPHA, BETA + FAIL = .TRUE. + NDIM = 0 + NUM = 0 + L = 0 + LS = 1 +C*** CONSTRUCT ARRAY IND(I) WHERE : +C*** IABS(IND(I)) IS THE SIZE OF THE BLOCK I +C*** SIGN(IND(I)) INDICATES THE LOCATION OF ITS EIGENVALUES +C*** (AS DETERMINED BY FTEST). +C*** NUM IS THE NUMBER OF ELEMENTS IN THIS ARRAY + DO 30 LL=1,N + L = L + LS + IF (L.GT.N) GO TO 40 + L1 = L + 1 + IF (L1.GT.N) GO TO 10 + IF (A(L1,L).EQ.0.) GO TO 10 +C* HERE A 2X2 BLOCK IS CHECKED * + LS = 2 + D = B(L,L)*B(L1,L1) + S = (A(L,L)*B(L1,L1)+A(L1,L1)*B(L,L)-A(L1,L)*B(L,L1))/D + P = (A(L,L)*A(L1,L1)-A(L,L1)*A(L1,L))/D + IS = FTEST(LS,ALPHA,BETA,S,P) + GO TO 20 +C* HERE A 1X1 BLOCK IS CHECKED * + 10 LS = 1 + IS = FTEST(LS,A(L,L),B(L,L),S,P) + 20 NUM = NUM + 1 + IF (IS.EQ.1) NDIM = NDIM + LS + IND(NUM) = LS*IS + 30 CONTINUE +C*** REORDER BLOCKS SUCH THAT THOSE WITH POSITIVE VALUE +C*** OF IND(.) APPEAR FIRST. + 40 L2I = 1 + DO 100 I=1,NUM + IF (IND(I).GT.0) GO TO 90 +C* IF A NEGATIVE IND(I) IS ENCOUNTERED, THEN SEARCH FOR THE FIRST +C* POSITIVE IND(K) FOLLOWING ON IT + L2K = L2I + DO 60 K=I,NUM + IF (IND(K).LT.0) GO TO 50 + GO TO 70 + 50 L2K = L2K - IND(K) + 60 CONTINUE +C* IF THERE ARE NO POSITIVE INDICES FOLLOWING ON A NEGATIVE ONE +C* THEN STOP + GO TO 110 +C* IF A POSITIVE IND(K) FOLLOWS ON A NEGATIVE IND(I) THEN +C* INTERCHANGE BLOCK K BEFORE BLOCK I BY PERFORMING K-I SWAPS + 70 ISTEP = K - I + LS2 = IND(K) + L = L2K + DO 80 II=1,ISTEP + IFIRST = K - II + LS1 = -IND(IFIRST) + L = L - LS1 + CALL EXCHQZ(NMAX, N, A, B, Z, L, LS1, LS2, EPS, FAIL) + IF (FAIL) RETURN + IND(IFIRST+1) = IND(IFIRST) + 80 CONTINUE + IND(I) = LS2 + 90 L2I = L2I + IND(I) + 100 CONTINUE + 110 FAIL = .FALSE. + RETURN + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/ordered-qz/exchqz.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,263 @@ + SUBROUTINE EXCHQZ(NMAX, N, A, B, Z, L, LS1, LS2, EPS, FAIL) + INTEGER NMAX, N, L, LS1, LS2 + DOUBLE PRECISION A(NMAX,N), B(NMAX,N), Z(NMAX,N), EPS + LOGICAL FAIL +c modified july 9, 1998 a.s.hodel@eng.auburn.edu: +c REAL changed to DOUBLE PRECISION +c calls to AMAX1 changed to call MAX instead. +c calls to SROT changed to DROT (both in BLAS) +c calls to giv changed to dlartg (LAPACK); required new variable tempr +C* +C* GIVEN THE UPPER TRIANGULAR MATRIX B AND UPPER HESSENBERG MATRIX A +C* WITH CONSECUTIVE LS1XLS1 AND LS2XLS2 DIAGONAL BLOCKS (LS1,LS2.LE.2) +C* STARTING AT ROW/COLUMN L, EXCHQZ PRODUCES EQUIVALENCE TRANSFORMA- +C* TIONS QT AND ZT THAT EXCHANGE THE BLOCKS ALONG WITH THEIR GENERALIZED +C* EIGENVALUES. EXCHQZ REQUIRES THE SUBROUTINES DROT (BLAS) AND GIV. +C* THE PARAMETERS IN THE CALLING SEQUENCE ARE (STARRED PARAMETERS ARE +C* ALTERED BY THE SUBROUTINE): +C* +C* NMAX THE FIRST DIMENSION OF A, B AND Z +C* N THE ORDER OF A, B AND Z +C* *A,*B THE MATRIX PAIR WHOSE BLOCKS ARE TO BE INTERCHANGED +C* *Z UPON RETURN THIS ARRAY IS MULTIPLIED BY THE COLUMN +C* TRANSFORMATION ZT. +C* L THE POSITION OF THE BLOCKS +C* LS1 THE SIZE OF THE FIRST BLOCK +C* LS2 THE SIZE OF THE SECOND BLOCK +C* EPS THE REQUIRED ABSOLUTE ACCURACY OF THE RESULT +C* *FAIL A LOGICAL VARIABLE WHICH IS FALSE ON A NORMAL RETURN, +C* TRUE OTHERWISE. +C* + INTEGER I, J, L1, L2, L3, LI, LJ, LL, IT1, IT2 + DOUBLE PRECISION U(3,3), D, E, F, G, SA, SB, A11B11, A21B11, + * A12B22, B12B22, + * A22B22, AMMBMM, ANMBMM, AMNBNN, BMNBNN, ANNBNN, TEMPR + LOGICAL ALTB + FAIL = .FALSE. + L1 = L + 1 + LL = LS1 + LS2 + IF (LL.GT.2) GO TO 10 +C*** INTERCHANGE 1X1 AND 1X1 BLOCKS VIA AN EQUIVALENCE +C*** TRANSFORMATION A:=Q*A*Z , B:=Q*B*Z +C*** WHERE Q AND Z ARE GIVENS ROTATIONS + F = MAX(ABS(A(L1,L1)),ABS(B(L1,L1))) + ALTB = .TRUE. + IF (ABS(A(L1,L1)).GE.F) ALTB = .FALSE. + SA = A(L1,L1)/F + SB = B(L1,L1)/F + F = SA*B(L,L) - SB*A(L,L) +C* CONSTRUCT THE COLUMN TRANSFORMATION Z + G = SA*B(L,L1) - SB*A(L,L1) + CALL DLARTG(F, G, D, E,TEMPR) + CALL DROT(L1, A(1,L), 1, A(1,L1), 1, E, -D) + CALL DROT(L1, B(1,L), 1, B(1,L1), 1, E, -D) + CALL DROT(N, Z(1,L), 1, Z(1,L1), 1, E, -D) +C* CONSTRUCT THE ROW TRANSFORMATION Q + IF (ALTB) CALL DLARTG(B(L,L), B(L1,L), D, E,TEMPR) + IF (.NOT.ALTB) CALL DLARTG(A(L,L), A(L1,L), D, E,TEMPR) + CALL DROT(N-L+1, A(L,L), NMAX, A(L1,L), NMAX, D, E) + CALL DROT(N-L+1, B(L,L), NMAX, B(L1,L), NMAX, D, E) + A(L1,L) = 0. + B(L1,L) = 0. + RETURN +C*** INTERCHANGE 1X1 AND 2X2 BLOCKS VIA AN EQUIVALENCE +C*** TRANSFORMATION A:=Q2*Q1*A*Z1*Z2 , B:=Q2*Q1*B*Z1*Z2 +C*** WHERE EACH QI AND ZI IS A GIVENS ROTATION + 10 L2 = L + 2 + IF (LS1.EQ.2) GO TO 60 + G = MAX(ABS(A(L,L)),ABS(B(L,L))) + ALTB = .TRUE. + IF (ABS(A(L,L)).LT.G) GO TO 20 + ALTB = .FALSE. + CALL DLARTG(A(L1,L1), A(L2,L1), D, E,TEMPR) + CALL DROT(N-L, A(L1,L1), NMAX, A(L2,L1), NMAX, D, E) + CALL DROT(N-L, B(L1,L1), NMAX, B(L2,L1), NMAX, D, E) +C** EVALUATE THE PENCIL AT THE EIGENVALUE CORRESPONDING +C** TO THE 1X1 BLOCK + 20 SA = A(L,L)/G + SB = B(L,L)/G + DO 40 J=1,2 + LJ = L + J + DO 30 I=1,3 + LI = L + I - 1 + U(I,J) = SA*B(LI,LJ) - SB*A(LI,LJ) + 30 CONTINUE + 40 CONTINUE + CALL DLARTG(U(3,1), U(3,2), D, E,TEMPR) + CALL DROT(3, U(1,1), 1, U(1,2), 1, E, -D) +C* PERFORM THE ROW TRANSFORMATION Q1 + CALL DLARTG(U(1,1), U(2,1), D, E,TEMPR) + U(2,2) = -U(1,2)*E + U(2,2)*D + CALL DROT(N-L+1, A(L,L), NMAX, A(L1,L), NMAX, D, E) + CALL DROT(N-L+1, B(L,L), NMAX, B(L1,L), NMAX, D, E) +C* PERFORM THE COLUMN TRANSFORMATION Z1 + IF (ALTB) CALL DLARTG(B(L1,L), B(L1,L1), D, E,TEMPR) + IF (.NOT.ALTB) CALL DLARTG(A(L1,L), A(L1,L1), D, E,TEMPR) + CALL DROT(L2, A(1,L), 1, A(1,L1), 1, E, -D) + CALL DROT(L2, B(1,L), 1, B(1,L1), 1, E, -D) + CALL DROT(N, Z(1,L), 1, Z(1,L1), 1, E, -D) +C* PERFORM THE ROW TRANSFORMATION Q2 + CALL DLARTG(U(2,2), U(3,2), D, E,TEMPR) + CALL DROT(N-L+1, A(L1,L), NMAX, A(L2,L), NMAX, D, E) + CALL DROT(N-L+1, B(L1,L), NMAX, B(L2,L), NMAX, D, E) +C* PERFORM THE COLUMN TRANSFORMATION Z2 + IF (ALTB) CALL DLARTG(B(L2,L1), B(L2,L2), D, E,TEMPR) + IF (.NOT.ALTB) CALL DLARTG(A(L2,L1), A(L2,L2), D, E,TEMPR) + CALL DROT(L2, A(1,L1), 1, A(1,L2), 1, E, -D) + CALL DROT(L2, B(1,L1), 1, B(1,L2), 1, E, -D) + CALL DROT(N, Z(1,L1), 1, Z(1,L2), 1, E, -D) + IF (ALTB) GO TO 50 + CALL DLARTG(B(L,L), B(L1,L), D, E,TEMPR) + CALL DROT(N-L+1, A(L,L), NMAX, A(L1,L), NMAX, D, E) + CALL DROT(N-L+1, B(L,L), NMAX, B(L1,L), NMAX, D, E) +C* PUT THE NEGLECTABLE ELEMENTS EQUAL TO ZERO + 50 A(L2,L) = 0. + A(L2,L1) = 0. + B(L1,L) = 0. + B(L2,L) = 0. + B(L2,L1) = 0. + RETURN +C*** INTERCHANGE 2X2 AND 1X1 BLOCKS VIA AN EQUIVALENCE +C*** TRANSFORMATION A:=Q2*Q1*A*Z1*Z2 , B:=Q2*Q1*B*Z1*Z2 +C*** WHERE EACH QI AND ZI IS A GIVENS ROTATION + 60 IF (LS2.EQ.2) GO TO 110 + G = MAX(ABS(A(L2,L2)),ABS(B(L2,L2))) + ALTB = .TRUE. + IF (ABS(A(L2,L2)).LT.G) GO TO 70 + ALTB = .FALSE. + CALL DLARTG(A(L,L), A(L1,L), D, E,TEMPR) + CALL DROT(N-L+1, A(L,L), NMAX, A(L1,L), NMAX, D, E) + CALL DROT(N-L+1, B(L,L), NMAX, B(L1,L), NMAX, D, E) +C** EVALUATE THE PENCIL AT THE EIGENVALUE CORRESPONDING +C** TO THE 1X1 BLOCK + 70 SA = A(L2,L2)/G + SB = B(L2,L2)/G + DO 90 I=1,2 + LI = L + I - 1 + DO 80 J=1,3 + LJ = L + J - 1 + U(I,J) = SA*B(LI,LJ) - SB*A(LI,LJ) + 80 CONTINUE + 90 CONTINUE + CALL DLARTG(U(1,1), U(2,1), D, E,TEMPR) + CALL DROT(3, U(1,1), 3, U(2,1), 3, D, E) +C* PERFORM THE COLUMN TRANSFORMATION Z1 + CALL DLARTG(U(2,2), U(2,3), D, E,TEMPR) + U(1,2) = U(1,2)*E - U(1,3)*D + CALL DROT(L2, A(1,L1), 1, A(1,L2), 1, E, -D) + CALL DROT(L2, B(1,L1), 1, B(1,L2), 1, E, -D) + CALL DROT(N, Z(1,L1), 1, Z(1,L2), 1, E, -D) +C* PERFORM THE ROW TRANSFORMATION Q1 + IF (ALTB) CALL DLARTG(B(L1,L1), B(L2,L1), D, E,TEMPR) + IF (.NOT.ALTB) CALL DLARTG(A(L1,L1), A(L2,L1), D, E,TEMPR) + CALL DROT(N-L+1, A(L1,L), NMAX, A(L2,L), NMAX, D, E) + CALL DROT(N-L+1, B(L1,L), NMAX, B(L2,L), NMAX, D, E) +C* PERFORM THE COLUMN TRANSFORMATION Z2 + CALL DLARTG(U(1,1), U(1,2), D, E,TEMPR) + CALL DROT(L2, A(1,L), 1, A(1,L1), 1, E, -D) + CALL DROT(L2, B(1,L), 1, B(1,L1), 1, E, -D) + CALL DROT(N, Z(1,L), 1, Z(1,L1), 1, E, -D) +C* PERFORM THE ROW TRANSFORMATION Q2 + IF (ALTB) CALL DLARTG(B(L,L), B(L1,L), D, E,TEMPR) + IF (.NOT.ALTB) CALL DLARTG(A(L,L), A(L1,L), D, E,TEMPR) + CALL DROT(N-L+1, A(L,L), NMAX, A(L1,L), NMAX, D, E) + CALL DROT(N-L+1, B(L,L), NMAX, B(L1,L), NMAX, D, E) + IF (ALTB) GO TO 100 + CALL DLARTG(B(L1,L1), B(L2,L1), D, E,TEMPR) + CALL DROT(N-L, A(L1,L1), NMAX, A(L2,L1), NMAX, D, E) + CALL DROT(N-L, B(L1,L1), NMAX, B(L2,L1), NMAX, D, E) +C* PUT THE NEGLECTABLE ELEMENTS EQUAL TO ZERO + 100 A(L1,L) = 0. + A(L2,L) = 0. + B(L1,L) = 0. + B(L2,1) = 0. + B(L2,L1) = 0. + RETURN +C*** INTERCHANGE 2X2 AND 2X2 BLOCKS VIA A SEQUENCE OF +C*** QZ-STEPS REALIZED BY THE EQUIVALENCE TRANSFORMATIONS +C*** A:=Q5*Q4*Q3*Q2*Q1*A*Z1*Z2*Z3*Z4*Z5 +C*** B:=Q5*Q4*Q3*Q2*Q1*B*Z1*Z2*Z3*Z4*Z5 +C*** WHERE EACH QI AND ZI IS A GIVENS ROTATION + 110 L3 = L + 3 +C* COMPUTE IMPLICIT SHIFT + AMMBMM = A(L,L)/B(L,L) + ANMBMM = A(L1,L)/B(L,L) + AMNBNN = A(L,L1)/B(L1,L1) + ANNBNN = A(L1,L1)/B(L1,L1) + BMNBNN = B(L,L1)/B(L1,L1) + DO 130 IT1=1,3 + U(1,1) = 1. + U(2,1) = 1. + U(3,1) = 1. + DO 120 IT2=1,10 +C* PERFORM ROW TRANSFORMATIONS Q1 AND Q2 + CALL DLARTG(U(2,1), U(3,1), D, E,TEMPR) + CALL DROT(N-L+1, A(L1,L), NMAX, A(L2,L), NMAX, D, E) + CALL DROT(N-L, B(L1,L1), NMAX, B(L2,L1), NMAX, D, E) + U(2,1) = D*U(2,1) + E*U(3,1) + CALL DLARTG(U(1,1), U(2,1), D, E,TEMPR) + CALL DROT(N-L+1, A(L,L), NMAX, A(L1,L), NMAX, D, E) + CALL DROT(N-L+1, B(L,L), NMAX, B(L1,L), NMAX, D, E) +C* PERFORM COLUMN TRANSFORMATIONS Z1 AND Z2 + CALL DLARTG(B(L2,L1), B(L2,L2), D, E,TEMPR) + CALL DROT(L3, A(1,L1), 1, A(1,L2), 1, E, -D) + CALL DROT(L2, B(1,L1), 1, B(1,L2), 1, E, -D) + CALL DROT(N, Z(1,L1), 1, Z(1,L2), 1, E, -D) + CALL DLARTG(B(L1,L), B(L1,L1), D, E,TEMPR) + CALL DROT(L3, A(1,L), 1, A(1,L1), 1, E, -D) + CALL DROT(L1, B(1,L), 1, B(1,L1), 1, E, -D) + CALL DROT(N, Z(1,L), 1, Z(1,L1), 1, E, -D) +C* PERFORM TRANSFORMATIONS Q3,Z3,Q4,Z4,Q5 AND Z5 IN +C* ORDER TO REDUCE THE PENCIL TO HESSENBERG FORM + CALL DLARTG(A(L2,L), A(L3,L), D, E,TEMPR) + CALL DROT(N-L+1, A(L2,L), NMAX, A(L3,L), NMAX, D, E) + CALL DROT(N-L1, B(L2,L2), NMAX, B(L3,L2), NMAX, D, E) + CALL DLARTG(B(L3,L2), B(L3,L3), D, E,TEMPR) + CALL DROT(L3, A(1,L2), 1, A(1,L3), 1, E, -D) + CALL DROT(L3, B(1,L2), 1, B(1,L3), 1, E, -D) + CALL DROT(N, Z(1,L2), 1, Z(1,L3), 1, E, -D) + CALL DLARTG(A(L1,L), A(L2,L), D, E,TEMPR) + CALL DROT(N-L+1, A(L1,L), NMAX, A(L2,L), NMAX, D, E) + CALL DROT(N-L, B(L1,L1), NMAX, B(L2,L1), NMAX, D, E) + CALL DLARTG(B(L2,L1), B(L2,L2), D, E,TEMPR) + CALL DROT(L3, A(1,L1), 1, A(1,L2), 1, E, -D) + CALL DROT(L2, B(1,L1), 1, B(1,L2), 1, E, -D) + CALL DROT(N, Z(1,L1), 1, Z(1,L2), 1, E, -D) + CALL DLARTG(A(L2,L1), A(L3,L1), D, E,TEMPR) + CALL DROT(N-L, A(L2,L1), NMAX, A(L3,L1), NMAX, D, E) + CALL DROT(N-L1, B(L2,L2), NMAX, B(L3,L2), NMAX, D, E) + CALL DLARTG(B(L3,L2), B(L3,L3), D, E,TEMPR) + CALL DROT(L3, A(1,L2), 1, A(1,L3), 1, E, -D) + CALL DROT(L3, B(1,L2), 1, B(1,L3), 1, E, -D) + CALL DROT(N, Z(1,L2), 1, Z(1,L3), 1, E, -D) +C* TEST OF CONVERGENCE ON THE ELEMENT SEPARATING THE BLOCKS + IF (ABS(A(L2,L1)).LE.EPS) GO TO 140 +C* COMPUTE A NEW SHIFT IN CASE OF NO CONVERGENCE + A11B11 = A(L,L)/B(L,L) + A12B22 = A(L,L1)/B(L1,L1) + A21B11 = A(L1,L)/B(L,L) + A22B22 = A(L1,L1)/B(L1,L1) + B12B22 = B(L,L1)/B(L1,L1) + U(1,1) = ((AMMBMM-A11B11)*(ANNBNN-A11B11)-AMNBNN* + * ANMBMM+ANMBMM*BMNBNN*A11B11)/A21B11 + A12B22 - A11B11*B12B22 + U(2,1) = (A22B22-A11B11) - A21B11*B12B22 - (AMMBMM-A11B11) - + * (ANNBNN-A11B11) + ANMBMM*BMNBNN + U(3,1) = A(L2,L1)/B(L1,L1) + 120 CONTINUE + 130 CONTINUE + FAIL = .TRUE. + RETURN +C* PUT THE NEGLECTABLE ELEMENTS EQUAL TO ZERO IN +C* CASE OF CONVERGENCE + 140 A(L2,L) = 0. + A(L2,L1) = 0. + A(L3,L) = 0. + A(L3,L1) = 0. + B(L1,L) = 0. + B(L2,L) = 0. + B(L2,L1) = 0. + B(L3,L) = 0. + B(L3,L1) = 0. + B(L3,L2) = 0. + RETURN + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/ordered-qz/module.mk Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,8 @@ +EXTERNAL_SOURCES += \ + liboctave/external/ordered-qz/dsubsp.f \ + liboctave/external/ordered-qz/exchqz.f \ + liboctave/external/ordered-qz/ssubsp.f \ + liboctave/external/ordered-qz/sexchqz.f + +liboctave_EXTRA_DIST += \ + liboctave/external/ordered-qz/README
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/ordered-qz/sexchqz.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,261 @@ + SUBROUTINE SEXCHQZ(NMAX, N, A, B, Z, L, LS1, LS2, EPS, FAIL) + INTEGER NMAX, N, L, LS1, LS2 + REAL A(NMAX,N), B(NMAX,N), Z(NMAX,N), EPS + LOGICAL FAIL +c modified july 9, 1998 a.s.hodel@eng.auburn.edu: +c calls to AMAX1 changed to call MAX instead. +c calls to giv changed to slartg (LAPACK); required new variable tempr +C* +C* GIVEN THE UPPER TRIANGULAR MATRIX B AND UPPER HESSENBERG MATRIX A +C* WITH CONSECUTIVE LS1XLS1 AND LS2XLS2 DIAGONAL BLOCKS (LS1,LS2.LE.2) +C* STARTING AT ROW/COLUMN L, EXCHQZ PRODUCES EQUIVALENCE TRANSFORMA- +C* TIONS QT AND ZT THAT EXCHANGE THE BLOCKS ALONG WITH THEIR GENERALIZED +C* EIGENVALUES. EXCHQZ REQUIRES THE SUBROUTINES SROT (BLAS) AND GIV. +C* THE PARAMETERS IN THE CALLING SEQUENCE ARE (STARRED PARAMETERS ARE +C* ALTERED BY THE SUBROUTINE): +C* +C* NMAX THE FIRST DIMENSION OF A, B AND Z +C* N THE ORDER OF A, B AND Z +C* *A,*B THE MATRIX PAIR WHOSE BLOCKS ARE TO BE INTERCHANGED +C* *Z UPON RETURN THIS ARRAY IS MULTIPLIED BY THE COLUMN +C* TRANSFORMATION ZT. +C* L THE POSITION OF THE BLOCKS +C* LS1 THE SIZE OF THE FIRST BLOCK +C* LS2 THE SIZE OF THE SECOND BLOCK +C* EPS THE REQUIRED ABSOLUTE ACCURACY OF THE RESULT +C* *FAIL A LOGICAL VARIABLE WHICH IS FALSE ON A NORMAL RETURN, +C* TRUE OTHERWISE. +C* + INTEGER I, J, L1, L2, L3, LI, LJ, LL, IT1, IT2 + REAL U(3,3), D, E, F, G, SA, SB, A11B11, A21B11, + * A12B22, B12B22, + * A22B22, AMMBMM, ANMBMM, AMNBNN, BMNBNN, ANNBNN, TEMPR + LOGICAL ALTB + FAIL = .FALSE. + L1 = L + 1 + LL = LS1 + LS2 + IF (LL.GT.2) GO TO 10 +C*** INTERCHANGE 1X1 AND 1X1 BLOCKS VIA AN EQUIVALENCE +C*** TRANSFORMATION A:=Q*A*Z , B:=Q*B*Z +C*** WHERE Q AND Z ARE GIVENS ROTATIONS + F = MAX(ABS(A(L1,L1)),ABS(B(L1,L1))) + ALTB = .TRUE. + IF (ABS(A(L1,L1)).GE.F) ALTB = .FALSE. + SA = A(L1,L1)/F + SB = B(L1,L1)/F + F = SA*B(L,L) - SB*A(L,L) +C* CONSTRUCT THE COLUMN TRANSFORMATION Z + G = SA*B(L,L1) - SB*A(L,L1) + CALL SLARTG(F, G, D, E,TEMPR) + CALL SROT(L1, A(1,L), 1, A(1,L1), 1, E, -D) + CALL SROT(L1, B(1,L), 1, B(1,L1), 1, E, -D) + CALL SROT(N, Z(1,L), 1, Z(1,L1), 1, E, -D) +C* CONSTRUCT THE ROW TRANSFORMATION Q + IF (ALTB) CALL SLARTG(B(L,L), B(L1,L), D, E,TEMPR) + IF (.NOT.ALTB) CALL SLARTG(A(L,L), A(L1,L), D, E,TEMPR) + CALL SROT(N-L+1, A(L,L), NMAX, A(L1,L), NMAX, D, E) + CALL SROT(N-L+1, B(L,L), NMAX, B(L1,L), NMAX, D, E) + A(L1,L) = 0. + B(L1,L) = 0. + RETURN +C*** INTERCHANGE 1X1 AND 2X2 BLOCKS VIA AN EQUIVALENCE +C*** TRANSFORMATION A:=Q2*Q1*A*Z1*Z2 , B:=Q2*Q1*B*Z1*Z2 +C*** WHERE EACH QI AND ZI IS A GIVENS ROTATION + 10 L2 = L + 2 + IF (LS1.EQ.2) GO TO 60 + G = MAX(ABS(A(L,L)),ABS(B(L,L))) + ALTB = .TRUE. + IF (ABS(A(L,L)).LT.G) GO TO 20 + ALTB = .FALSE. + CALL SLARTG(A(L1,L1), A(L2,L1), D, E,TEMPR) + CALL SROT(N-L, A(L1,L1), NMAX, A(L2,L1), NMAX, D, E) + CALL SROT(N-L, B(L1,L1), NMAX, B(L2,L1), NMAX, D, E) +C** EVALUATE THE PENCIL AT THE EIGENVALUE CORRESPONDING +C** TO THE 1X1 BLOCK + 20 SA = A(L,L)/G + SB = B(L,L)/G + DO 40 J=1,2 + LJ = L + J + DO 30 I=1,3 + LI = L + I - 1 + U(I,J) = SA*B(LI,LJ) - SB*A(LI,LJ) + 30 CONTINUE + 40 CONTINUE + CALL SLARTG(U(3,1), U(3,2), D, E,TEMPR) + CALL SROT(3, U(1,1), 1, U(1,2), 1, E, -D) +C* PERFORM THE ROW TRANSFORMATION Q1 + CALL SLARTG(U(1,1), U(2,1), D, E,TEMPR) + U(2,2) = -U(1,2)*E + U(2,2)*D + CALL SROT(N-L+1, A(L,L), NMAX, A(L1,L), NMAX, D, E) + CALL SROT(N-L+1, B(L,L), NMAX, B(L1,L), NMAX, D, E) +C* PERFORM THE COLUMN TRANSFORMATION Z1 + IF (ALTB) CALL SLARTG(B(L1,L), B(L1,L1), D, E,TEMPR) + IF (.NOT.ALTB) CALL SLARTG(A(L1,L), A(L1,L1), D, E,TEMPR) + CALL SROT(L2, A(1,L), 1, A(1,L1), 1, E, -D) + CALL SROT(L2, B(1,L), 1, B(1,L1), 1, E, -D) + CALL SROT(N, Z(1,L), 1, Z(1,L1), 1, E, -D) +C* PERFORM THE ROW TRANSFORMATION Q2 + CALL SLARTG(U(2,2), U(3,2), D, E,TEMPR) + CALL SROT(N-L+1, A(L1,L), NMAX, A(L2,L), NMAX, D, E) + CALL SROT(N-L+1, B(L1,L), NMAX, B(L2,L), NMAX, D, E) +C* PERFORM THE COLUMN TRANSFORMATION Z2 + IF (ALTB) CALL SLARTG(B(L2,L1), B(L2,L2), D, E,TEMPR) + IF (.NOT.ALTB) CALL SLARTG(A(L2,L1), A(L2,L2), D, E,TEMPR) + CALL SROT(L2, A(1,L1), 1, A(1,L2), 1, E, -D) + CALL SROT(L2, B(1,L1), 1, B(1,L2), 1, E, -D) + CALL SROT(N, Z(1,L1), 1, Z(1,L2), 1, E, -D) + IF (ALTB) GO TO 50 + CALL SLARTG(B(L,L), B(L1,L), D, E,TEMPR) + CALL SROT(N-L+1, A(L,L), NMAX, A(L1,L), NMAX, D, E) + CALL SROT(N-L+1, B(L,L), NMAX, B(L1,L), NMAX, D, E) +C* PUT THE NEGLECTABLE ELEMENTS EQUAL TO ZERO + 50 A(L2,L) = 0. + A(L2,L1) = 0. + B(L1,L) = 0. + B(L2,L) = 0. + B(L2,L1) = 0. + RETURN +C*** INTERCHANGE 2X2 AND 1X1 BLOCKS VIA AN EQUIVALENCE +C*** TRANSFORMATION A:=Q2*Q1*A*Z1*Z2 , B:=Q2*Q1*B*Z1*Z2 +C*** WHERE EACH QI AND ZI IS A GIVENS ROTATION + 60 IF (LS2.EQ.2) GO TO 110 + G = MAX(ABS(A(L2,L2)),ABS(B(L2,L2))) + ALTB = .TRUE. + IF (ABS(A(L2,L2)).LT.G) GO TO 70 + ALTB = .FALSE. + CALL SLARTG(A(L,L), A(L1,L), D, E,TEMPR) + CALL SROT(N-L+1, A(L,L), NMAX, A(L1,L), NMAX, D, E) + CALL SROT(N-L+1, B(L,L), NMAX, B(L1,L), NMAX, D, E) +C** EVALUATE THE PENCIL AT THE EIGENVALUE CORRESPONDING +C** TO THE 1X1 BLOCK + 70 SA = A(L2,L2)/G + SB = B(L2,L2)/G + DO 90 I=1,2 + LI = L + I - 1 + DO 80 J=1,3 + LJ = L + J - 1 + U(I,J) = SA*B(LI,LJ) - SB*A(LI,LJ) + 80 CONTINUE + 90 CONTINUE + CALL SLARTG(U(1,1), U(2,1), D, E,TEMPR) + CALL SROT(3, U(1,1), 3, U(2,1), 3, D, E) +C* PERFORM THE COLUMN TRANSFORMATION Z1 + CALL SLARTG(U(2,2), U(2,3), D, E,TEMPR) + U(1,2) = U(1,2)*E - U(1,3)*D + CALL SROT(L2, A(1,L1), 1, A(1,L2), 1, E, -D) + CALL SROT(L2, B(1,L1), 1, B(1,L2), 1, E, -D) + CALL SROT(N, Z(1,L1), 1, Z(1,L2), 1, E, -D) +C* PERFORM THE ROW TRANSFORMATION Q1 + IF (ALTB) CALL SLARTG(B(L1,L1), B(L2,L1), D, E,TEMPR) + IF (.NOT.ALTB) CALL SLARTG(A(L1,L1), A(L2,L1), D, E,TEMPR) + CALL SROT(N-L+1, A(L1,L), NMAX, A(L2,L), NMAX, D, E) + CALL SROT(N-L+1, B(L1,L), NMAX, B(L2,L), NMAX, D, E) +C* PERFORM THE COLUMN TRANSFORMATION Z2 + CALL SLARTG(U(1,1), U(1,2), D, E,TEMPR) + CALL SROT(L2, A(1,L), 1, A(1,L1), 1, E, -D) + CALL SROT(L2, B(1,L), 1, B(1,L1), 1, E, -D) + CALL SROT(N, Z(1,L), 1, Z(1,L1), 1, E, -D) +C* PERFORM THE ROW TRANSFORMATION Q2 + IF (ALTB) CALL SLARTG(B(L,L), B(L1,L), D, E,TEMPR) + IF (.NOT.ALTB) CALL SLARTG(A(L,L), A(L1,L), D, E,TEMPR) + CALL SROT(N-L+1, A(L,L), NMAX, A(L1,L), NMAX, D, E) + CALL SROT(N-L+1, B(L,L), NMAX, B(L1,L), NMAX, D, E) + IF (ALTB) GO TO 100 + CALL SLARTG(B(L1,L1), B(L2,L1), D, E,TEMPR) + CALL SROT(N-L, A(L1,L1), NMAX, A(L2,L1), NMAX, D, E) + CALL SROT(N-L, B(L1,L1), NMAX, B(L2,L1), NMAX, D, E) +C* PUT THE NEGLECTABLE ELEMENTS EQUAL TO ZERO + 100 A(L1,L) = 0. + A(L2,L) = 0. + B(L1,L) = 0. + B(L2,1) = 0. + B(L2,L1) = 0. + RETURN +C*** INTERCHANGE 2X2 AND 2X2 BLOCKS VIA A SEQUENCE OF +C*** QZ-STEPS REALIZED BY THE EQUIVALENCE TRANSFORMATIONS +C*** A:=Q5*Q4*Q3*Q2*Q1*A*Z1*Z2*Z3*Z4*Z5 +C*** B:=Q5*Q4*Q3*Q2*Q1*B*Z1*Z2*Z3*Z4*Z5 +C*** WHERE EACH QI AND ZI IS A GIVENS ROTATION + 110 L3 = L + 3 +C* COMPUTE IMPLICIT SHIFT + AMMBMM = A(L,L)/B(L,L) + ANMBMM = A(L1,L)/B(L,L) + AMNBNN = A(L,L1)/B(L1,L1) + ANNBNN = A(L1,L1)/B(L1,L1) + BMNBNN = B(L,L1)/B(L1,L1) + DO 130 IT1=1,3 + U(1,1) = 1. + U(2,1) = 1. + U(3,1) = 1. + DO 120 IT2=1,10 +C* PERFORM ROW TRANSFORMATIONS Q1 AND Q2 + CALL SLARTG(U(2,1), U(3,1), D, E,TEMPR) + CALL SROT(N-L+1, A(L1,L), NMAX, A(L2,L), NMAX, D, E) + CALL SROT(N-L, B(L1,L1), NMAX, B(L2,L1), NMAX, D, E) + U(2,1) = D*U(2,1) + E*U(3,1) + CALL SLARTG(U(1,1), U(2,1), D, E,TEMPR) + CALL SROT(N-L+1, A(L,L), NMAX, A(L1,L), NMAX, D, E) + CALL SROT(N-L+1, B(L,L), NMAX, B(L1,L), NMAX, D, E) +C* PERFORM COLUMN TRANSFORMATIONS Z1 AND Z2 + CALL SLARTG(B(L2,L1), B(L2,L2), D, E,TEMPR) + CALL SROT(L3, A(1,L1), 1, A(1,L2), 1, E, -D) + CALL SROT(L2, B(1,L1), 1, B(1,L2), 1, E, -D) + CALL SROT(N, Z(1,L1), 1, Z(1,L2), 1, E, -D) + CALL SLARTG(B(L1,L), B(L1,L1), D, E,TEMPR) + CALL SROT(L3, A(1,L), 1, A(1,L1), 1, E, -D) + CALL SROT(L1, B(1,L), 1, B(1,L1), 1, E, -D) + CALL SROT(N, Z(1,L), 1, Z(1,L1), 1, E, -D) +C* PERFORM TRANSFORMATIONS Q3,Z3,Q4,Z4,Q5 AND Z5 IN +C* ORDER TO REDUCE THE PENCIL TO HESSENBERG FORM + CALL SLARTG(A(L2,L), A(L3,L), D, E,TEMPR) + CALL SROT(N-L+1, A(L2,L), NMAX, A(L3,L), NMAX, D, E) + CALL SROT(N-L1, B(L2,L2), NMAX, B(L3,L2), NMAX, D, E) + CALL SLARTG(B(L3,L2), B(L3,L3), D, E,TEMPR) + CALL SROT(L3, A(1,L2), 1, A(1,L3), 1, E, -D) + CALL SROT(L3, B(1,L2), 1, B(1,L3), 1, E, -D) + CALL SROT(N, Z(1,L2), 1, Z(1,L3), 1, E, -D) + CALL SLARTG(A(L1,L), A(L2,L), D, E,TEMPR) + CALL SROT(N-L+1, A(L1,L), NMAX, A(L2,L), NMAX, D, E) + CALL SROT(N-L, B(L1,L1), NMAX, B(L2,L1), NMAX, D, E) + CALL SLARTG(B(L2,L1), B(L2,L2), D, E,TEMPR) + CALL SROT(L3, A(1,L1), 1, A(1,L2), 1, E, -D) + CALL SROT(L2, B(1,L1), 1, B(1,L2), 1, E, -D) + CALL SROT(N, Z(1,L1), 1, Z(1,L2), 1, E, -D) + CALL SLARTG(A(L2,L1), A(L3,L1), D, E,TEMPR) + CALL SROT(N-L, A(L2,L1), NMAX, A(L3,L1), NMAX, D, E) + CALL SROT(N-L1, B(L2,L2), NMAX, B(L3,L2), NMAX, D, E) + CALL SLARTG(B(L3,L2), B(L3,L3), D, E,TEMPR) + CALL SROT(L3, A(1,L2), 1, A(1,L3), 1, E, -D) + CALL SROT(L3, B(1,L2), 1, B(1,L3), 1, E, -D) + CALL SROT(N, Z(1,L2), 1, Z(1,L3), 1, E, -D) +C* TEST OF CONVERGENCE ON THE ELEMENT SEPARATING THE BLOCKS + IF (ABS(A(L2,L1)).LE.EPS) GO TO 140 +C* COMPUTE A NEW SHIFT IN CASE OF NO CONVERGENCE + A11B11 = A(L,L)/B(L,L) + A12B22 = A(L,L1)/B(L1,L1) + A21B11 = A(L1,L)/B(L,L) + A22B22 = A(L1,L1)/B(L1,L1) + B12B22 = B(L,L1)/B(L1,L1) + U(1,1) = ((AMMBMM-A11B11)*(ANNBNN-A11B11)-AMNBNN* + * ANMBMM+ANMBMM*BMNBNN*A11B11)/A21B11 + A12B22 - A11B11*B12B22 + U(2,1) = (A22B22-A11B11) - A21B11*B12B22 - (AMMBMM-A11B11) - + * (ANNBNN-A11B11) + ANMBMM*BMNBNN + U(3,1) = A(L2,L1)/B(L1,L1) + 120 CONTINUE + 130 CONTINUE + FAIL = .TRUE. + RETURN +C* PUT THE NEGLECTABLE ELEMENTS EQUAL TO ZERO IN +C* CASE OF CONVERGENCE + 140 A(L2,L) = 0. + A(L2,L1) = 0. + A(L3,L) = 0. + A(L3,L1) = 0. + B(L1,L) = 0. + B(L2,L) = 0. + B(L2,L1) = 0. + B(L3,L) = 0. + B(L3,L1) = 0. + B(L3,L2) = 0. + RETURN + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/ordered-qz/ssubsp.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,104 @@ + SUBROUTINE SSUBSP(NMAX, N, A, B, Z, FTEST, EPS, NDIM, FAIL, IND) + INTEGER NMAX, N, FTEST, NDIM, IND(N) + LOGICAL FAIL + REAL A(NMAX,N), B(NMAX,N), Z(NMAX,N), EPS +C* +C* GIVEN THE UPPER TRIANGULAR MATRIX B AND UPPER HESSENBERG MATRIX A +C* WITH 1X1 OR 2X2 DIAGONAL BLOCKS, THIS ROUTINE REORDERS THE DIAGONAL +C* BLOCKS ALONG WITH THEIR GENERALIZED EIGENVALUES BY CONSTRUCTING EQUI- +C* VALENCE TRANSFORMATIONS QT AND ZT. THE ROW TRANSFORMATION ZT IS ALSO +C* PERFORMED ON THE GIVEN (INITIAL) TRANSFORMATION Z (RESULTING FROM A +C* POSSIBLE PREVIOUS STEP OR INITIALIZED WITH THE IDENTITY MATRIX). +C* AFTER REORDERING, THE EIGENVALUES INSIDE THE REGION SPECIFIED BY THE +C* FUNCTION FTEST APPEAR AT THE TOP. IF NDIM IS THEIR NUMBER THEN THE +C* NDIM FIRST COLUMNS OF Z SPAN THE REQUESTED SUBSPACE. DSUBSP REQUIRES +C* THE SUBROUTINE EXCHQZ AND THE INTEGER FUNCTION FTEST WHICH HAS TO BE +C* PROVIDED BY THE USER. THE PARAMETERS IN THE CALLING SEQUENCE ARE : +C* (STARRED PARAMETERS ARE ALTERED BY THE SUBROUTINE) +C* +C* NMAX THE FIRST DIMENSION OF A, B AND Z +C* N THE ORDER OF A, B AND Z +C* *A,*B THE MATRIX PAIR WHOSE BLOCKS ARE TO BE REORDERED. +C* *Z UPON RETURN THIS ARRAY IS MULTIPLIED BY THE COLUMN +C* TRANSFORMATION ZT. +C* FTEST(LS,ALPHA,BETA,S,P) AN INTEGER FUNCTION DESCRIBING THE +C* SPECTRUM OF THE DEFLATING SUBSPACE TO BE COMPUTED: +C* WHEN LS=1 FTEST CHECKS IF ALPHA/BETA IS IN THAT SPECTRUM +C* WHEN LS=2 FTEST CHECKS IF THE TWO COMPLEX CONJUGATE +C* ROOTS WITH SUM S AND PRODUCT P ARE IN THAT SPECTRUM +C* IF THE ANSWER IS POSITIVE, FTEST=1, OTHERWISE FTEST=-1 +C* EPS THE REQUIRED ABSOLUTE ACCURACY OF THE RESULT +C* *NDIM AN INTEGER GIVING THE DIMENSION OF THE COMPUTED +C* DEFLATING SUBSPACE +C* *FAIL A LOGICAL VARIABLE WHICH IS FALSE ON A NORMAL RETURN, +C* TRUE OTHERWISE (WHEN SEXCHQZ FAILS) +C* *IND AN INTEGER WORKING ARRAY OF DIMENSION AT LEAST N +C* + INTEGER L, LS, LS1, LS2, L1, LL, NUM, IS, L2I, L2K, I, K, II, + * ISTEP, IFIRST + REAL S, P, D, ALPHA, BETA + FAIL = .TRUE. + NDIM = 0 + NUM = 0 + L = 0 + LS = 1 +C*** CONSTRUCT ARRAY IND(I) WHERE : +C*** IABS(IND(I)) IS THE SIZE OF THE BLOCK I +C*** SIGN(IND(I)) INDICATES THE LOCATION OF ITS EIGENVALUES +C*** (AS DETERMINED BY FTEST). +C*** NUM IS THE NUMBER OF ELEMENTS IN THIS ARRAY + DO 30 LL=1,N + L = L + LS + IF (L.GT.N) GO TO 40 + L1 = L + 1 + IF (L1.GT.N) GO TO 10 + IF (A(L1,L).EQ.0.) GO TO 10 +C* HERE A 2X2 BLOCK IS CHECKED * + LS = 2 + D = B(L,L)*B(L1,L1) + S = (A(L,L)*B(L1,L1)+A(L1,L1)*B(L,L)-A(L1,L)*B(L,L1))/D + P = (A(L,L)*A(L1,L1)-A(L,L1)*A(L1,L))/D + IS = FTEST(LS,ALPHA,BETA,S,P) + GO TO 20 +C* HERE A 1X1 BLOCK IS CHECKED * + 10 LS = 1 + IS = FTEST(LS,A(L,L),B(L,L),S,P) + 20 NUM = NUM + 1 + IF (IS.EQ.1) NDIM = NDIM + LS + IND(NUM) = LS*IS + 30 CONTINUE +C*** REORDER BLOCKS SUCH THAT THOSE WITH POSITIVE VALUE +C*** OF IND(.) APPEAR FIRST. + 40 L2I = 1 + DO 100 I=1,NUM + IF (IND(I).GT.0) GO TO 90 +C* IF A NEGATIVE IND(I) IS ENCOUNTERED, THEN SEARCH FOR THE FIRST +C* POSITIVE IND(K) FOLLOWING ON IT + L2K = L2I + DO 60 K=I,NUM + IF (IND(K).LT.0) GO TO 50 + GO TO 70 + 50 L2K = L2K - IND(K) + 60 CONTINUE +C* IF THERE ARE NO POSITIVE INDICES FOLLOWING ON A NEGATIVE ONE +C* THEN STOP + GO TO 110 +C* IF A POSITIVE IND(K) FOLLOWS ON A NEGATIVE IND(I) THEN +C* INTERCHANGE BLOCK K BEFORE BLOCK I BY PERFORMING K-I SWAPS + 70 ISTEP = K - I + LS2 = IND(K) + L = L2K + DO 80 II=1,ISTEP + IFIRST = K - II + LS1 = -IND(IFIRST) + L = L - LS1 + CALL SEXCHQZ(NMAX, N, A, B, Z, L, LS1, LS2, EPS, FAIL) + IF (FAIL) RETURN + IND(IFIRST+1) = IND(IFIRST) + 80 CONTINUE + IND(I) = LS2 + 90 L2I = L2I + IND(I) + 100 CONTINUE + 110 FAIL = .FALSE. + RETURN + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/quadpack/dqagi.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,190 @@ + SUBROUTINE DQAGI(F,BOUND,INF,EPSABS,EPSREL,RESULT,ABSERR,NEVAL, + * IER,LIMIT,LENW,LAST,IWORK,WORK) +C***BEGIN PROLOGUE DQAGI +C***DATE WRITTEN 800101 (YYMMDD) +C***REVISION DATE 830518 (YYMMDD) +C***CATEGORY NO. H2A3A1,H2A4A1 +C***KEYWORDS AUTOMATIC INTEGRATOR, INFINITE INTERVALS, +C GENERAL-PURPOSE, TRANSFORMATION, EXTRAPOLATION, +C GLOBALLY ADAPTIVE +C***AUTHOR PIESSENS,ROBERT,APPL. MATH. & PROGR. DIV. - K.U.LEUVEN +C DE DONCKER,ELISE,APPL. MATH. & PROGR. DIV. -K.U.LEUVEN +C***PURPOSE THE ROUTINE CALCULATES AN APPROXIMATION RESULT TO A GIVEN +C INTEGRAL I = INTEGRAL OF F OVER (BOUND,+INFINITY) +C OR I = INTEGRAL OF F OVER (-INFINITY,BOUND) +C OR I = INTEGRAL OF F OVER (-INFINITY,+INFINITY) +C HOPEFULLY SATISFYING FOLLOWING CLAIM FOR ACCURACY +C ABS(I-RESULT).LE.MAX(EPSABS,EPSREL*ABS(I)). +C***DESCRIPTION +C +C INTEGRATION OVER INFINITE INTERVALS +C STANDARD FORTRAN SUBROUTINE +C +C PARAMETERS +C ON ENTRY +C F - SUBROUTINE F(X,RESULT) DEFINING THE INTEGRAND +C FUNCTION F(X). THE ACTUAL NAME FOR F NEEDS TO BE +C DECLARED E X T E R N A L IN THE DRIVER PROGRAM. +C +C BOUND - DOUBLE PRECISION +C FINITE BOUND OF INTEGRATION RANGE +C (HAS NO MEANING IF INTERVAL IS DOUBLY-INFINITE) +C +C INF - INTEGER +C INDICATING THE KIND OF INTEGRATION RANGE INVOLVED +C INF = 1 CORRESPONDS TO (BOUND,+INFINITY), +C INF = -1 TO (-INFINITY,BOUND), +C INF = 2 TO (-INFINITY,+INFINITY). +C +C EPSABS - DOUBLE PRECISION +C ABSOLUTE ACCURACY REQUESTED +C EPSREL - DOUBLE PRECISION +C RELATIVE ACCURACY REQUESTED +C IF EPSABS.LE.0 +C AND EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28), +C THE ROUTINE WILL END WITH IER = 6. +C +C +C ON RETURN +C RESULT - DOUBLE PRECISION +C APPROXIMATION TO THE INTEGRAL +C +C ABSERR - DOUBLE PRECISION +C ESTIMATE OF THE MODULUS OF THE ABSOLUTE ERROR, +C WHICH SHOULD EQUAL OR EXCEED ABS(I-RESULT) +C +C NEVAL - INTEGER +C NUMBER OF INTEGRAND EVALUATIONS +C +C IER - INTEGER +C IER = 0 NORMAL AND RELIABLE TERMINATION OF THE +C ROUTINE. IT IS ASSUMED THAT THE REQUESTED +C ACCURACY HAS BEEN ACHIEVED. +C - IER.GT.0 ABNORMAL TERMINATION OF THE ROUTINE. THE +C ESTIMATES FOR RESULT AND ERROR ARE LESS +C RELIABLE. IT IS ASSUMED THAT THE REQUESTED +C ACCURACY HAS NOT BEEN ACHIEVED. +C ERROR MESSAGES +C IER = 1 MAXIMUM NUMBER OF SUBDIVISIONS ALLOWED +C HAS BEEN ACHIEVED. ONE CAN ALLOW MORE +C SUBDIVISIONS BY INCREASING THE VALUE OF +C LIMIT (AND TAKING THE ACCORDING DIMENSION +C ADJUSTMENTS INTO ACCOUNT). HOWEVER, IF +C THIS YIELDS NO IMPROVEMENT IT IS ADVISED +C TO ANALYZE THE INTEGRAND IN ORDER TO +C DETERMINE THE INTEGRATION DIFFICULTIES. IF +C THE POSITION OF A LOCAL DIFFICULTY CAN BE +C DETERMINED (E.G. SINGULARITY, +C DISCONTINUITY WITHIN THE INTERVAL) ONE +C WILL PROBABLY GAIN FROM SPLITTING UP THE +C INTERVAL AT THIS POINT AND CALLING THE +C INTEGRATOR ON THE SUBRANGES. IF POSSIBLE, +C AN APPROPRIATE SPECIAL-PURPOSE INTEGRATOR +C SHOULD BE USED, WHICH IS DESIGNED FOR +C HANDLING THE TYPE OF DIFFICULTY INVOLVED. +C = 2 THE OCCURRENCE OF ROUNDOFF ERROR IS +C DETECTED, WHICH PREVENTS THE REQUESTED +C TOLERANCE FROM BEING ACHIEVED. +C THE ERROR MAY BE UNDER-ESTIMATED. +C = 3 EXTREMELY BAD INTEGRAND BEHAVIOUR OCCURS +C AT SOME POINTS OF THE INTEGRATION +C INTERVAL. +C = 4 THE ALGORITHM DOES NOT CONVERGE. +C ROUNDOFF ERROR IS DETECTED IN THE +C EXTRAPOLATION TABLE. +C IT IS ASSUMED THAT THE REQUESTED TOLERANCE +C CANNOT BE ACHIEVED, AND THAT THE RETURNED +C RESULT IS THE BEST WHICH CAN BE OBTAINED. +C = 5 THE INTEGRAL IS PROBABLY DIVERGENT, OR +C SLOWLY CONVERGENT. IT MUST BE NOTED THAT +C DIVERGENCE CAN OCCUR WITH ANY OTHER VALUE +C OF IER. +C = 6 THE INPUT IS INVALID, BECAUSE +C (EPSABS.LE.0 AND +C EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28)) +C OR LIMIT.LT.1 OR LENIW.LT.LIMIT*4. +C RESULT, ABSERR, NEVAL, LAST ARE SET TO +C ZERO. EXEPT WHEN LIMIT OR LENIW IS +C INVALID, IWORK(1), WORK(LIMIT*2+1) AND +C WORK(LIMIT*3+1) ARE SET TO ZERO, WORK(1) +C IS SET TO A AND WORK(LIMIT+1) TO B. +C +C DIMENSIONING PARAMETERS +C LIMIT - INTEGER +C DIMENSIONING PARAMETER FOR IWORK +C LIMIT DETERMINES THE MAXIMUM NUMBER OF SUBINTERVALS +C IN THE PARTITION OF THE GIVEN INTEGRATION INTERVAL +C (A,B), LIMIT.GE.1. +C IF LIMIT.LT.1, THE ROUTINE WILL END WITH IER = 6. +C +C LENW - INTEGER +C DIMENSIONING PARAMETER FOR WORK +C LENW MUST BE AT LEAST LIMIT*4. +C IF LENW.LT.LIMIT*4, THE ROUTINE WILL END +C WITH IER = 6. +C +C LAST - INTEGER +C ON RETURN, LAST EQUALS THE NUMBER OF SUBINTERVALS +C PRODUCED IN THE SUBDIVISION PROCESS, WHICH +C DETERMINES THE NUMBER OF SIGNIFICANT ELEMENTS +C ACTUALLY IN THE WORK ARRAYS. +C +C WORK ARRAYS +C IWORK - INTEGER +C VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST +C K ELEMENTS OF WHICH CONTAIN POINTERS +C TO THE ERROR ESTIMATES OVER THE SUBINTERVALS, +C SUCH THAT WORK(LIMIT*3+IWORK(1)),... , +C WORK(LIMIT*3+IWORK(K)) FORM A DECREASING +C SEQUENCE, WITH K = LAST IF LAST.LE.(LIMIT/2+2), AND +C K = LIMIT+1-LAST OTHERWISE +C +C WORK - DOUBLE PRECISION +C VECTOR OF DIMENSION AT LEAST LENW +C ON RETURN +C WORK(1), ..., WORK(LAST) CONTAIN THE LEFT +C END POINTS OF THE SUBINTERVALS IN THE +C PARTITION OF (A,B), +C WORK(LIMIT+1), ..., WORK(LIMIT+LAST) CONTAIN +C THE RIGHT END POINTS, +C WORK(LIMIT*2+1), ...,WORK(LIMIT*2+LAST) CONTAIN THE +C INTEGRAL APPROXIMATIONS OVER THE SUBINTERVALS, +C WORK(LIMIT*3+1), ..., WORK(LIMIT*3) +C CONTAIN THE ERROR ESTIMATES. +C***REFERENCES (NONE) +C***ROUTINES CALLED DQAGIE,XERROR +C***END PROLOGUE DQAGI +C + DOUBLE PRECISION ABSERR,BOUND,EPSABS,EPSREL,RESULT,WORK + INTEGER IER,INF,IWORK,LAST,LENW,LIMIT,LVL,L1,L2,L3,NEVAL +C + DIMENSION IWORK(LIMIT),WORK(LENW) +C + EXTERNAL F +C +C CHECK VALIDITY OF LIMIT AND LENW. +C +C***FIRST EXECUTABLE STATEMENT DQAGI + IER = 6 + NEVAL = 0 + LAST = 0 + RESULT = 0.0D+00 + ABSERR = 0.0D+00 + IF(LIMIT.LT.1.OR.LENW.LT.LIMIT*4) GO TO 10 +C +C PREPARE CALL FOR DQAGIE. +C + L1 = LIMIT+1 + L2 = LIMIT+L1 + L3 = LIMIT+L2 +C + CALL DQAGIE(F,BOUND,INF,EPSABS,EPSREL,LIMIT,RESULT,ABSERR, + * NEVAL,IER,WORK(1),WORK(L1),WORK(L2),WORK(L3),IWORK,LAST) +C +C CALL ERROR HANDLER IF NECESSARY. +C + LVL = 0 +10 IF(IER.EQ.6) LVL = 1 + IF(IER.GT.0) CALL XERROR('ABNORMAL RETURN FROM DQAGI',26,IER,LVL) + RETURN + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/quadpack/dqagie.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,457 @@ + SUBROUTINE DQAGIE(F,BOUND,INF,EPSABS,EPSREL,LIMIT,RESULT,ABSERR, + * NEVAL,IER,ALIST,BLIST,RLIST,ELIST,IORD,LAST) +C***BEGIN PROLOGUE DQAGIE +C***DATE WRITTEN 800101 (YYMMDD) +C***REVISION DATE 830518 (YYMMDD) +C***CATEGORY NO. H2A3A1,H2A4A1 +C***KEYWORDS AUTOMATIC INTEGRATOR, INFINITE INTERVALS, +C GENERAL-PURPOSE, TRANSFORMATION, EXTRAPOLATION, +C GLOBALLY ADAPTIVE +C***AUTHOR PIESSENS,ROBERT,APPL. MATH & PROGR. DIV - K.U.LEUVEN +C DE DONCKER,ELISE,APPL. MATH & PROGR. DIV - K.U.LEUVEN +C***PURPOSE THE ROUTINE CALCULATES AN APPROXIMATION RESULT TO A GIVEN +C INTEGRAL I = INTEGRAL OF F OVER (BOUND,+INFINITY) +C OR I = INTEGRAL OF F OVER (-INFINITY,BOUND) +C OR I = INTEGRAL OF F OVER (-INFINITY,+INFINITY), +C HOPEFULLY SATISFYING FOLLOWING CLAIM FOR ACCURACY +C ABS(I-RESULT).LE.MAX(EPSABS,EPSREL*ABS(I)) +C***DESCRIPTION +C +C INTEGRATION OVER INFINITE INTERVALS +C STANDARD FORTRAN SUBROUTINE +C +C F - SUBROUTINE F(X,IERR,RESULT) DEFINING THE INTEGRAND +C FUNCTION F(X). THE ACTUAL NAME FOR F NEEDS TO BE +C DECLARED E X T E R N A L IN THE DRIVER PROGRAM. +C +C BOUND - DOUBLE PRECISION +C FINITE BOUND OF INTEGRATION RANGE +C (HAS NO MEANING IF INTERVAL IS DOUBLY-INFINITE) +C +C INF - DOUBLE PRECISION +C INDICATING THE KIND OF INTEGRATION RANGE INVOLVED +C INF = 1 CORRESPONDS TO (BOUND,+INFINITY), +C INF = -1 TO (-INFINITY,BOUND), +C INF = 2 TO (-INFINITY,+INFINITY). +C +C EPSABS - DOUBLE PRECISION +C ABSOLUTE ACCURACY REQUESTED +C EPSREL - DOUBLE PRECISION +C RELATIVE ACCURACY REQUESTED +C IF EPSABS.LE.0 +C AND EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28), +C THE ROUTINE WILL END WITH IER = 6. +C +C LIMIT - INTEGER +C GIVES AN UPPER BOUND ON THE NUMBER OF SUBINTERVALS +C IN THE PARTITION OF (A,B), LIMIT.GE.1 +C +C ON RETURN +C RESULT - DOUBLE PRECISION +C APPROXIMATION TO THE INTEGRAL +C +C ABSERR - DOUBLE PRECISION +C ESTIMATE OF THE MODULUS OF THE ABSOLUTE ERROR, +C WHICH SHOULD EQUAL OR EXCEED ABS(I-RESULT) +C +C NEVAL - INTEGER +C NUMBER OF INTEGRAND EVALUATIONS +C +C IER - INTEGER +C IER = 0 NORMAL AND RELIABLE TERMINATION OF THE +C ROUTINE. IT IS ASSUMED THAT THE REQUESTED +C ACCURACY HAS BEEN ACHIEVED. +C IER.GT.0 ABNORMAL TERMINATION OF THE ROUTINE. THE +C ESTIMATES FOR RESULT AND ERROR ARE LESS +C RELIABLE. IT IS ASSUMED THAT THE REQUESTED +C ACCURACY HAS NOT BEEN ACHIEVED. +C IER.LT.0 EXIT REQUESTED FROM USER-SUPPLIED +C FUNCTION. +C +C ERROR MESSAGES +C IER = 1 MAXIMUM NUMBER OF SUBDIVISIONS ALLOWED +C HAS BEEN ACHIEVED. ONE CAN ALLOW MORE +C SUBDIVISIONS BY INCREASING THE VALUE OF +C LIMIT (AND TAKING THE ACCORDING DIMENSION +C ADJUSTMENTS INTO ACCOUNT). HOWEVER,IF +C THIS YIELDS NO IMPROVEMENT IT IS ADVISED +C TO ANALYZE THE INTEGRAND IN ORDER TO +C DETERMINE THE INTEGRATION DIFFICULTIES. +C IF THE POSITION OF A LOCAL DIFFICULTY CAN +C BE DETERMINED (E.G. SINGULARITY, +C DISCONTINUITY WITHIN THE INTERVAL) ONE +C WILL PROBABLY GAIN FROM SPLITTING UP THE +C INTERVAL AT THIS POINT AND CALLING THE +C INTEGRATOR ON THE SUBRANGES. IF POSSIBLE, +C AN APPROPRIATE SPECIAL-PURPOSE INTEGRATOR +C SHOULD BE USED, WHICH IS DESIGNED FOR +C HANDLING THE TYPE OF DIFFICULTY INVOLVED. +C = 2 THE OCCURRENCE OF ROUNDOFF ERROR IS +C DETECTED, WHICH PREVENTS THE REQUESTED +C TOLERANCE FROM BEING ACHIEVED. +C THE ERROR MAY BE UNDER-ESTIMATED. +C = 3 EXTREMELY BAD INTEGRAND BEHAVIOUR OCCURS +C AT SOME POINTS OF THE INTEGRATION +C INTERVAL. +C = 4 THE ALGORITHM DOES NOT CONVERGE. +C ROUNDOFF ERROR IS DETECTED IN THE +C EXTRAPOLATION TABLE. +C IT IS ASSUMED THAT THE REQUESTED TOLERANCE +C CANNOT BE ACHIEVED, AND THAT THE RETURNED +C RESULT IS THE BEST WHICH CAN BE OBTAINED. +C = 5 THE INTEGRAL IS PROBABLY DIVERGENT, OR +C SLOWLY CONVERGENT. IT MUST BE NOTED THAT +C DIVERGENCE CAN OCCUR WITH ANY OTHER VALUE +C OF IER. +C = 6 THE INPUT IS INVALID, BECAUSE +C (EPSABS.LE.0 AND +C EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28), +C RESULT, ABSERR, NEVAL, LAST, RLIST(1), +C ELIST(1) AND IORD(1) ARE SET TO ZERO. +C ALIST(1) AND BLIST(1) ARE SET TO 0 +C AND 1 RESPECTIVELY. +C +C ALIST - DOUBLE PRECISION +C VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST +C LAST ELEMENTS OF WHICH ARE THE LEFT +C END POINTS OF THE SUBINTERVALS IN THE PARTITION +C OF THE TRANSFORMED INTEGRATION RANGE (0,1). +C +C BLIST - DOUBLE PRECISION +C VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST +C LAST ELEMENTS OF WHICH ARE THE RIGHT +C END POINTS OF THE SUBINTERVALS IN THE PARTITION +C OF THE TRANSFORMED INTEGRATION RANGE (0,1). +C +C RLIST - DOUBLE PRECISION +C VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST +C LAST ELEMENTS OF WHICH ARE THE INTEGRAL +C APPROXIMATIONS ON THE SUBINTERVALS +C +C ELIST - DOUBLE PRECISION +C VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST +C LAST ELEMENTS OF WHICH ARE THE MODULI OF THE +C ABSOLUTE ERROR ESTIMATES ON THE SUBINTERVALS +C +C IORD - INTEGER +C VECTOR OF DIMENSION LIMIT, THE FIRST K +C ELEMENTS OF WHICH ARE POINTERS TO THE +C ERROR ESTIMATES OVER THE SUBINTERVALS, +C SUCH THAT ELIST(IORD(1)), ..., ELIST(IORD(K)) +C FORM A DECREASING SEQUENCE, WITH K = LAST +C IF LAST.LE.(LIMIT/2+2), AND K = LIMIT+1-LAST +C OTHERWISE +C +C LAST - INTEGER +C NUMBER OF SUBINTERVALS ACTUALLY PRODUCED +C IN THE SUBDIVISION PROCESS +C +C***REFERENCES (NONE) +C***ROUTINES CALLED D1MACH,DQELG,DQK15I,DQPSRT +C***END PROLOGUE DQAGIE + DOUBLE PRECISION ABSEPS,ABSERR,ALIST,AREA,AREA1,AREA12,AREA2,A1, + * A2,BLIST,BOUN,BOUND,B1,B2,CORREC,DABS,DEFABS,DEFAB1,DEFAB2, + * DMAX1,DRES,D1MACH,ELIST,EPMACH,EPSABS,EPSREL,ERLARG,ERLAST, + * ERRBND,ERRMAX,ERROR1,ERROR2,ERRO12,ERRSUM,ERTEST,OFLOW,RESABS, + * RESEPS,RESULT,RES3LA,RLIST,RLIST2,SMALL,UFLOW + INTEGER ID,IER,IERRO,INF,IORD,IROFF1,IROFF2,IROFF3,JUPBND,K,KSGN, + * KTMIN,LAST,LIMIT,MAXERR,NEVAL,NRES,NRMAX,NUMRL2 + LOGICAL EXTRAP,NOEXT +C + DIMENSION ALIST(LIMIT),BLIST(LIMIT),ELIST(LIMIT),IORD(LIMIT), + * RES3LA(3),RLIST(LIMIT),RLIST2(52) +C + EXTERNAL F +C +C THE DIMENSION OF RLIST2 IS DETERMINED BY THE VALUE OF +C LIMEXP IN SUBROUTINE DQELG. +C +C +C LIST OF MAJOR VARIABLES +C ----------------------- +C +C ALIST - LIST OF LEFT END POINTS OF ALL SUBINTERVALS +C CONSIDERED UP TO NOW +C BLIST - LIST OF RIGHT END POINTS OF ALL SUBINTERVALS +C CONSIDERED UP TO NOW +C RLIST(I) - APPROXIMATION TO THE INTEGRAL OVER +C (ALIST(I),BLIST(I)) +C RLIST2 - ARRAY OF DIMENSION AT LEAST (LIMEXP+2), +C CONTAINING THE PART OF THE EPSILON TABLE +C WICH IS STILL NEEDED FOR FURTHER COMPUTATIONS +C ELIST(I) - ERROR ESTIMATE APPLYING TO RLIST(I) +C MAXERR - POINTER TO THE INTERVAL WITH LARGEST ERROR +C ESTIMATE +C ERRMAX - ELIST(MAXERR) +C ERLAST - ERROR ON THE INTERVAL CURRENTLY SUBDIVIDED +C (BEFORE THAT SUBDIVISION HAS TAKEN PLACE) +C AREA - SUM OF THE INTEGRALS OVER THE SUBINTERVALS +C ERRSUM - SUM OF THE ERRORS OVER THE SUBINTERVALS +C ERRBND - REQUESTED ACCURACY MAX(EPSABS,EPSREL* +C ABS(RESULT)) +C *****1 - VARIABLE FOR THE LEFT SUBINTERVAL +C *****2 - VARIABLE FOR THE RIGHT SUBINTERVAL +C LAST - INDEX FOR SUBDIVISION +C NRES - NUMBER OF CALLS TO THE EXTRAPOLATION ROUTINE +C NUMRL2 - NUMBER OF ELEMENTS CURRENTLY IN RLIST2. IF AN +C APPROPRIATE APPROXIMATION TO THE COMPOUNDED +C INTEGRAL HAS BEEN OBTAINED, IT IS PUT IN +C RLIST2(NUMRL2) AFTER NUMRL2 HAS BEEN INCREASED +C BY ONE. +C SMALL - LENGTH OF THE SMALLEST INTERVAL CONSIDERED UP +C TO NOW, MULTIPLIED BY 1.5 +C ERLARG - SUM OF THE ERRORS OVER THE INTERVALS LARGER +C THAN THE SMALLEST INTERVAL CONSIDERED UP TO NOW +C EXTRAP - LOGICAL VARIABLE DENOTING THAT THE ROUTINE +C IS ATTEMPTING TO PERFORM EXTRAPOLATION. I.E. +C BEFORE SUBDIVIDING THE SMALLEST INTERVAL WE +C TRY TO DECREASE THE VALUE OF ERLARG. +C NOEXT - LOGICAL VARIABLE DENOTING THAT EXTRAPOLATION +C IS NO LONGER ALLOWED (TRUE-VALUE) +C +C MACHINE DEPENDENT CONSTANTS +C --------------------------- +C +C EPMACH IS THE LARGEST RELATIVE SPACING. +C UFLOW IS THE SMALLEST POSITIVE MAGNITUDE. +C OFLOW IS THE LARGEST POSITIVE MAGNITUDE. +C +C***FIRST EXECUTABLE STATEMENT DQAGIE + EPMACH = D1MACH(4) +C +C TEST ON VALIDITY OF PARAMETERS +C ----------------------------- +C + IER = 0 + NEVAL = 0 + LAST = 0 + RESULT = 0.0D+00 + ABSERR = 0.0D+00 + ALIST(1) = 0.0D+00 + BLIST(1) = 0.1D+01 + RLIST(1) = 0.0D+00 + ELIST(1) = 0.0D+00 + IORD(1) = 0 + IF(EPSABS.LE.0.0D+00.AND.EPSREL.LT.DMAX1(0.5D+02*EPMACH,0.5D-28)) + * IER = 6 + IF(IER.EQ.6) GO TO 999 +C +C +C FIRST APPROXIMATION TO THE INTEGRAL +C ----------------------------------- +C +C DETERMINE THE INTERVAL TO BE MAPPED ONTO (0,1). +C IF INF = 2 THE INTEGRAL IS COMPUTED AS I = I1+I2, WHERE +C I1 = INTEGRAL OF F OVER (-INFINITY,0), +C I2 = INTEGRAL OF F OVER (0,+INFINITY). +C + BOUN = BOUND + IF(INF.EQ.2) BOUN = 0.0D+00 + CALL DQK15I(F,BOUN,INF,0.0D+00,0.1D+01,RESULT,ABSERR, + * DEFABS,RESABS,IER) + IF (IER .LT. 0) RETURN +C +C TEST ON ACCURACY +C + LAST = 1 + RLIST(1) = RESULT + ELIST(1) = ABSERR + IORD(1) = 1 + DRES = DABS(RESULT) + ERRBND = DMAX1(EPSABS,EPSREL*DRES) + IF(ABSERR.LE.1.0D+02*EPMACH*DEFABS.AND.ABSERR.GT.ERRBND) IER = 2 + IF(LIMIT.EQ.1) IER = 1 + IF(IER.NE.0.OR.(ABSERR.LE.ERRBND.AND.ABSERR.NE.RESABS).OR. + * ABSERR.EQ.0.0D+00) GO TO 130 +C +C INITIALIZATION +C -------------- +C + UFLOW = D1MACH(1) + OFLOW = D1MACH(2) + RLIST2(1) = RESULT + ERRMAX = ABSERR + MAXERR = 1 + AREA = RESULT + ERRSUM = ABSERR + ABSERR = OFLOW + NRMAX = 1 + NRES = 0 + KTMIN = 0 + NUMRL2 = 2 + EXTRAP = .FALSE. + NOEXT = .FALSE. + IERRO = 0 + IROFF1 = 0 + IROFF2 = 0 + IROFF3 = 0 + KSGN = -1 + IF(DRES.GE.(0.1D+01-0.5D+02*EPMACH)*DEFABS) KSGN = 1 +C +C MAIN DO-LOOP +C ------------ +C + DO 90 LAST = 2,LIMIT +C +C BISECT THE SUBINTERVAL WITH NRMAX-TH LARGEST ERROR ESTIMATE. +C + A1 = ALIST(MAXERR) + B1 = 0.5D+00*(ALIST(MAXERR)+BLIST(MAXERR)) + A2 = B1 + B2 = BLIST(MAXERR) + ERLAST = ERRMAX + CALL DQK15I(F,BOUN,INF,A1,B1,AREA1,ERROR1,RESABS,DEFAB1,IER) + IF (IER .LT. 0) RETURN + CALL DQK15I(F,BOUN,INF,A2,B2,AREA2,ERROR2,RESABS,DEFAB2,IER) + IF (IER .LT. 0) RETURN +C +C IMPROVE PREVIOUS APPROXIMATIONS TO INTEGRAL +C AND ERROR AND TEST FOR ACCURACY. +C + AREA12 = AREA1+AREA2 + ERRO12 = ERROR1+ERROR2 + ERRSUM = ERRSUM+ERRO12-ERRMAX + AREA = AREA+AREA12-RLIST(MAXERR) + IF(DEFAB1.EQ.ERROR1.OR.DEFAB2.EQ.ERROR2)GO TO 15 + IF(DABS(RLIST(MAXERR)-AREA12).GT.0.1D-04*DABS(AREA12) + * .OR.ERRO12.LT.0.99D+00*ERRMAX) GO TO 10 + IF(EXTRAP) IROFF2 = IROFF2+1 + IF(.NOT.EXTRAP) IROFF1 = IROFF1+1 + 10 IF(LAST.GT.10.AND.ERRO12.GT.ERRMAX) IROFF3 = IROFF3+1 + 15 RLIST(MAXERR) = AREA1 + RLIST(LAST) = AREA2 + ERRBND = DMAX1(EPSABS,EPSREL*DABS(AREA)) +C +C TEST FOR ROUNDOFF ERROR AND EVENTUALLY SET ERROR FLAG. +C + IF(IROFF1+IROFF2.GE.10.OR.IROFF3.GE.20) IER = 2 + IF(IROFF2.GE.5) IERRO = 3 +C +C SET ERROR FLAG IN THE CASE THAT THE NUMBER OF +C SUBINTERVALS EQUALS LIMIT. +C + IF(LAST.EQ.LIMIT) IER = 1 +C +C SET ERROR FLAG IN THE CASE OF BAD INTEGRAND BEHAVIOUR +C AT SOME POINTS OF THE INTEGRATION RANGE. +C + IF(DMAX1(DABS(A1),DABS(B2)).LE.(0.1D+01+0.1D+03*EPMACH)* + * (DABS(A2)+0.1D+04*UFLOW)) IER = 4 +C +C APPEND THE NEWLY-CREATED INTERVALS TO THE LIST. +C + IF(ERROR2.GT.ERROR1) GO TO 20 + ALIST(LAST) = A2 + BLIST(MAXERR) = B1 + BLIST(LAST) = B2 + ELIST(MAXERR) = ERROR1 + ELIST(LAST) = ERROR2 + GO TO 30 + 20 ALIST(MAXERR) = A2 + ALIST(LAST) = A1 + BLIST(LAST) = B1 + RLIST(MAXERR) = AREA2 + RLIST(LAST) = AREA1 + ELIST(MAXERR) = ERROR2 + ELIST(LAST) = ERROR1 +C +C CALL SUBROUTINE DQPSRT TO MAINTAIN THE DESCENDING ORDERING +C IN THE LIST OF ERROR ESTIMATES AND SELECT THE SUBINTERVAL +C WITH NRMAX-TH LARGEST ERROR ESTIMATE (TO BE BISECTED NEXT). +C + 30 CALL DQPSRT(LIMIT,LAST,MAXERR,ERRMAX,ELIST,IORD,NRMAX) + IF(ERRSUM.LE.ERRBND) GO TO 115 + IF(IER.NE.0) GO TO 100 + IF(LAST.EQ.2) GO TO 80 + IF(NOEXT) GO TO 90 + ERLARG = ERLARG-ERLAST + IF(DABS(B1-A1).GT.SMALL) ERLARG = ERLARG+ERRO12 + IF(EXTRAP) GO TO 40 +C +C TEST WHETHER THE INTERVAL TO BE BISECTED NEXT IS THE +C SMALLEST INTERVAL. +C + IF(DABS(BLIST(MAXERR)-ALIST(MAXERR)).GT.SMALL) GO TO 90 + EXTRAP = .TRUE. + NRMAX = 2 + 40 IF(IERRO.EQ.3.OR.ERLARG.LE.ERTEST) GO TO 60 +C +C THE SMALLEST INTERVAL HAS THE LARGEST ERROR. +C BEFORE BISECTING DECREASE THE SUM OF THE ERRORS OVER THE +C LARGER INTERVALS (ERLARG) AND PERFORM EXTRAPOLATION. +C + ID = NRMAX + JUPBND = LAST + IF(LAST.GT.(2+LIMIT/2)) JUPBND = LIMIT+3-LAST + DO 50 K = ID,JUPBND + MAXERR = IORD(NRMAX) + ERRMAX = ELIST(MAXERR) + IF(DABS(BLIST(MAXERR)-ALIST(MAXERR)).GT.SMALL) GO TO 90 + NRMAX = NRMAX+1 + 50 CONTINUE +C +C PERFORM EXTRAPOLATION. +C + 60 NUMRL2 = NUMRL2+1 + RLIST2(NUMRL2) = AREA + CALL DQELG(NUMRL2,RLIST2,RESEPS,ABSEPS,RES3LA,NRES) + KTMIN = KTMIN+1 + IF(KTMIN.GT.5.AND.ABSERR.LT.0.1D-02*ERRSUM) IER = 5 + IF(ABSEPS.GE.ABSERR) GO TO 70 + KTMIN = 0 + ABSERR = ABSEPS + RESULT = RESEPS + CORREC = ERLARG + ERTEST = DMAX1(EPSABS,EPSREL*DABS(RESEPS)) + IF(ABSERR.LE.ERTEST) GO TO 100 +C +C PREPARE BISECTION OF THE SMALLEST INTERVAL. +C + 70 IF(NUMRL2.EQ.1) NOEXT = .TRUE. + IF(IER.EQ.5) GO TO 100 + MAXERR = IORD(1) + ERRMAX = ELIST(MAXERR) + NRMAX = 1 + EXTRAP = .FALSE. + SMALL = SMALL*0.5D+00 + ERLARG = ERRSUM + GO TO 90 + 80 SMALL = 0.375D+00 + ERLARG = ERRSUM + ERTEST = ERRBND + RLIST2(2) = AREA + 90 CONTINUE +C +C SET FINAL RESULT AND ERROR ESTIMATE. +C ------------------------------------ +C + 100 IF(ABSERR.EQ.OFLOW) GO TO 115 + IF((IER+IERRO).EQ.0) GO TO 110 + IF(IERRO.EQ.3) ABSERR = ABSERR+CORREC + IF(IER.EQ.0) IER = 3 + IF(RESULT.NE.0.0D+00.AND.AREA.NE.0.0D+00)GO TO 105 + IF(ABSERR.GT.ERRSUM)GO TO 115 + IF(AREA.EQ.0.0D+00) GO TO 130 + GO TO 110 + 105 IF(ABSERR/DABS(RESULT).GT.ERRSUM/DABS(AREA))GO TO 115 +C +C TEST ON DIVERGENCE +C + 110 IF(KSGN.EQ.(-1).AND.DMAX1(DABS(RESULT),DABS(AREA)).LE. + * DEFABS*0.1D-01) GO TO 130 + IF(0.1D-01.GT.(RESULT/AREA).OR.(RESULT/AREA).GT.0.1D+03. + *OR.ERRSUM.GT.DABS(AREA)) IER = 6 + GO TO 130 +C +C COMPUTE GLOBAL INTEGRAL SUM. +C + 115 RESULT = 0.0D+00 + DO 120 K = 1,LAST + RESULT = RESULT+RLIST(K) + 120 CONTINUE + ABSERR = ERRSUM + 130 NEVAL = 30*LAST-15 + IF(INF.EQ.2) NEVAL = 2*NEVAL + IF(IER.GT.2) IER=IER-1 + 999 RETURN + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/quadpack/dqagp.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,224 @@ + SUBROUTINE DQAGP(F,A,B,NPTS2,POINTS,EPSABS,EPSREL,RESULT,ABSERR, + * NEVAL,IER,LENIW,LENW,LAST,IWORK,WORK) +C***BEGIN PROLOGUE DQAGP +C***DATE WRITTEN 800101 (YYMMDD) +C***REVISION DATE 830518 (YYMMDD) +C***CATEGORY NO. H2A2A1 +C***KEYWORDS AUTOMATIC INTEGRATOR, GENERAL-PURPOSE, +C SINGULARITIES AT USER SPECIFIED POINTS, +C EXTRAPOLATION, GLOBALLY ADAPTIVE +C***AUTHOR PIESSENS,ROBERT,APPL. MATH. & PROGR. DIV - K.U.LEUVEN +C DE DONCKER,ELISE,APPL. MATH. & PROGR. DIV. - K.U.LEUVEN +C***PURPOSE THE ROUTINE CALCULATES AN APPROXIMATION RESULT TO A GIVEN +C DEFINITE INTEGRAL I = INTEGRAL OF F OVER (A,B), +C HOPEFULLY SATISFYING FOLLOWING CLAIM FOR ACCURACY +C BREAK POINTS OF THE INTEGRATION INTERVAL, WHERE LOCAL +C DIFFICULTIES OF THE INTEGRAND MAY OCCUR (E.G. +C SINGULARITIES, DISCONTINUITIES), ARE PROVIDED BY THE USER. +C***DESCRIPTION +C +C COMPUTATION OF A DEFINITE INTEGRAL +C STANDARD FORTRAN SUBROUTINE +C DOUBLE PRECISION VERSION +C +C PARAMETERS +C ON ENTRY +C F - SUBROUTINE F(X,IERR,RESULT) DEFINING THE INTEGRAND +C FUNCTION F(X). THE ACTUAL NAME FOR F NEEDS TO BE +C DECLARED E X T E R N A L IN THE DRIVER PROGRAM. +C +C A - DOUBLE PRECISION +C LOWER LIMIT OF INTEGRATION +C +C B - DOUBLE PRECISION +C UPPER LIMIT OF INTEGRATION +C +C NPTS2 - INTEGER +C NUMBER EQUAL TO TWO MORE THAN THE NUMBER OF +C USER-SUPPLIED BREAK POINTS WITHIN THE INTEGRATION +C RANGE, NPTS.GE.2. +C IF NPTS2.LT.2, THE ROUTINE WILL END WITH IER = 6. +C +C POINTS - DOUBLE PRECISION +C VECTOR OF DIMENSION NPTS2, THE FIRST (NPTS2-2) +C ELEMENTS OF WHICH ARE THE USER PROVIDED BREAK +C POINTS. IF THESE POINTS DO NOT CONSTITUTE AN +C ASCENDING SEQUENCE THERE WILL BE AN AUTOMATIC +C SORTING. +C +C EPSABS - DOUBLE PRECISION +C ABSOLUTE ACCURACY REQUESTED +C EPSREL - DOUBLE PRECISION +C RELATIVE ACCURACY REQUESTED +C IF EPSABS.LE.0 +C AND EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28), +C THE ROUTINE WILL END WITH IER = 6. +C +C ON RETURN +C RESULT - DOUBLE PRECISION +C APPROXIMATION TO THE INTEGRAL +C +C ABSERR - DOUBLE PRECISION +C ESTIMATE OF THE MODULUS OF THE ABSOLUTE ERROR, +C WHICH SHOULD EQUAL OR EXCEED ABS(I-RESULT) +C +C NEVAL - INTEGER +C NUMBER OF INTEGRAND EVALUATIONS +C +C IER - INTEGER +C IER = 0 NORMAL AND RELIABLE TERMINATION OF THE +C ROUTINE. IT IS ASSUMED THAT THE REQUESTED +C ACCURACY HAS BEEN ACHIEVED. +C IER.GT.0 ABNORMAL TERMINATION OF THE ROUTINE. +C THE ESTIMATES FOR INTEGRAL AND ERROR ARE +C LESS RELIABLE. IT IS ASSUMED THAT THE +C REQUESTED ACCURACY HAS NOT BEEN ACHIEVED. +C ERROR MESSAGES +C IER = 1 MAXIMUM NUMBER OF SUBDIVISIONS ALLOWED +C HAS BEEN ACHIEVED. ONE CAN ALLOW MORE +C SUBDIVISIONS BY INCREASING THE VALUE OF +C LIMIT (AND TAKING THE ACCORDING DIMENSION +C ADJUSTMENTS INTO ACCOUNT). HOWEVER, IF +C THIS YIELDS NO IMPROVEMENT IT IS ADVISED +C TO ANALYZE THE INTEGRAND IN ORDER TO +C DETERMINE THE INTEGRATION DIFFICULTIES. IF +C THE POSITION OF A LOCAL DIFFICULTY CAN BE +C DETERMINED (I.E. SINGULARITY, +C DISCONTINUITY WITHIN THE INTERVAL), IT +C SHOULD BE SUPPLIED TO THE ROUTINE AS AN +C ELEMENT OF THE VECTOR POINTS. IF NECESSARY +C AN APPROPRIATE SPECIAL-PURPOSE INTEGRATOR +C MUST BE USED, WHICH IS DESIGNED FOR +C HANDLING THE TYPE OF DIFFICULTY INVOLVED. +C = 2 THE OCCURRENCE OF ROUNDOFF ERROR IS +C DETECTED, WHICH PREVENTS THE REQUESTED +C TOLERANCE FROM BEING ACHIEVED. +C THE ERROR MAY BE UNDER-ESTIMATED. +C = 3 EXTREMELY BAD INTEGRAND BEHAVIOUR OCCURS +C AT SOME POINTS OF THE INTEGRATION +C INTERVAL. +C = 4 THE ALGORITHM DOES NOT CONVERGE. +C ROUNDOFF ERROR IS DETECTED IN THE +C EXTRAPOLATION TABLE. +C IT IS PRESUMED THAT THE REQUESTED +C TOLERANCE CANNOT BE ACHIEVED, AND THAT +C THE RETURNED RESULT IS THE BEST WHICH +C CAN BE OBTAINED. +C = 5 THE INTEGRAL IS PROBABLY DIVERGENT, OR +C SLOWLY CONVERGENT. IT MUST BE NOTED THAT +C DIVERGENCE CAN OCCUR WITH ANY OTHER VALUE +C OF IER.GT.0. +C = 6 THE INPUT IS INVALID BECAUSE +C NPTS2.LT.2 OR +C BREAK POINTS ARE SPECIFIED OUTSIDE +C THE INTEGRATION RANGE OR +C (EPSABS.LE.0 AND +C EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28)) +C RESULT, ABSERR, NEVAL, LAST ARE SET TO +C ZERO. EXEPT WHEN LENIW OR LENW OR NPTS2 IS +C INVALID, IWORK(1), IWORK(LIMIT+1), +C WORK(LIMIT*2+1) AND WORK(LIMIT*3+1) +C ARE SET TO ZERO. +C WORK(1) IS SET TO A AND WORK(LIMIT+1) +C TO B (WHERE LIMIT = (LENIW-NPTS2)/2). +C +C DIMENSIONING PARAMETERS +C LENIW - INTEGER +C DIMENSIONING PARAMETER FOR IWORK +C LENIW DETERMINES LIMIT = (LENIW-NPTS2)/2, +C WHICH IS THE MAXIMUM NUMBER OF SUBINTERVALS IN THE +C PARTITION OF THE GIVEN INTEGRATION INTERVAL (A,B), +C LENIW.GE.(3*NPTS2-2). +C IF LENIW.LT.(3*NPTS2-2), THE ROUTINE WILL END WITH +C IER = 6. +C +C LENW - INTEGER +C DIMENSIONING PARAMETER FOR WORK +C LENW MUST BE AT LEAST LENIW*2-NPTS2. +C IF LENW.LT.LENIW*2-NPTS2, THE ROUTINE WILL END +C WITH IER = 6. +C +C LAST - INTEGER +C ON RETURN, LAST EQUALS THE NUMBER OF SUBINTERVALS +C PRODUCED IN THE SUBDIVISION PROCESS, WHICH +C DETERMINES THE NUMBER OF SIGNIFICANT ELEMENTS +C ACTUALLY IN THE WORK ARRAYS. +C +C WORK ARRAYS +C IWORK - INTEGER +C VECTOR OF DIMENSION AT LEAST LENIW. ON RETURN, +C THE FIRST K ELEMENTS OF WHICH CONTAIN +C POINTERS TO THE ERROR ESTIMATES OVER THE +C SUBINTERVALS, SUCH THAT WORK(LIMIT*3+IWORK(1)),..., +C WORK(LIMIT*3+IWORK(K)) FORM A DECREASING +C SEQUENCE, WITH K = LAST IF LAST.LE.(LIMIT/2+2), AND +C K = LIMIT+1-LAST OTHERWISE +C IWORK(LIMIT+1), ...,IWORK(LIMIT+LAST) CONTAIN THE +C SUBDIVISION LEVELS OF THE SUBINTERVALS, I.E. +C IF (AA,BB) IS A SUBINTERVAL OF (P1,P2) +C WHERE P1 AS WELL AS P2 IS A USER-PROVIDED +C BREAK POINT OR INTEGRATION LIMIT, THEN (AA,BB) HAS +C LEVEL L IF ABS(BB-AA) = ABS(P2-P1)*2**(-L), +C IWORK(LIMIT*2+1), ..., IWORK(LIMIT*2+NPTS2) HAVE +C NO SIGNIFICANCE FOR THE USER, +C NOTE THAT LIMIT = (LENIW-NPTS2)/2. +C +C WORK - DOUBLE PRECISION +C VECTOR OF DIMENSION AT LEAST LENW +C ON RETURN +C WORK(1), ..., WORK(LAST) CONTAIN THE LEFT +C END POINTS OF THE SUBINTERVALS IN THE +C PARTITION OF (A,B), +C WORK(LIMIT+1), ..., WORK(LIMIT+LAST) CONTAIN +C THE RIGHT END POINTS, +C WORK(LIMIT*2+1), ..., WORK(LIMIT*2+LAST) CONTAIN +C THE INTEGRAL APPROXIMATIONS OVER THE SUBINTERVALS, +C WORK(LIMIT*3+1), ..., WORK(LIMIT*3+LAST) +C CONTAIN THE CORRESPONDING ERROR ESTIMATES, +C WORK(LIMIT*4+1), ..., WORK(LIMIT*4+NPTS2) +C CONTAIN THE INTEGRATION LIMITS AND THE +C BREAK POINTS SORTED IN AN ASCENDING SEQUENCE. +C NOTE THAT LIMIT = (LENIW-NPTS2)/2. +C +C***REFERENCES (NONE) +C***ROUTINES CALLED DQAGPE,XERROR +C***END PROLOGUE DQAGP +C + DOUBLE PRECISION A,ABSERR,B,EPSABS,EPSREL,POINTS,RESULT,WORK + INTEGER IER,IWORK,LAST,LENIW,LENW,LIMIT,LVL,L1,L2,L3,L4,NEVAL, + * NPTS2 +C + DIMENSION IWORK(LENIW),POINTS(NPTS2),WORK(LENW) +C + EXTERNAL F +C +C CHECK VALIDITY OF LIMIT AND LENW. +C +C***FIRST EXECUTABLE STATEMENT DQAGP + IER = 6 + NEVAL = 0 + LAST = 0 + RESULT = 0.0D+00 + ABSERR = 0.0D+00 + IF(LENIW.LT.(3*NPTS2-2).OR.LENW.LT.(LENIW*2-NPTS2).OR.NPTS2.LT.2) + * GO TO 10 +C +C PREPARE CALL FOR DQAGPE. +C + LIMIT = (LENIW-NPTS2)/2 + L1 = LIMIT+1 + L2 = LIMIT+L1 + L3 = LIMIT+L2 + L4 = LIMIT+L3 +C + CALL DQAGPE(F,A,B,NPTS2,POINTS,EPSABS,EPSREL,LIMIT,RESULT,ABSERR, + * NEVAL,IER,WORK(1),WORK(L1),WORK(L2),WORK(L3),WORK(L4), + * IWORK(1),IWORK(L1),IWORK(L2),LAST) +C +C CALL ERROR HANDLER IF NECESSARY. +C + LVL = 0 +10 IF(IER.EQ.6) LVL = 1 + IF(IER.GT.0) CALL XERROR('ABNORMAL RETURN FROM DQAGP',26,IER,LVL) + RETURN + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/quadpack/dqagpe.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,555 @@ + SUBROUTINE DQAGPE(F,A,B,NPTS2,POINTS,EPSABS,EPSREL,LIMIT,RESULT, + * ABSERR,NEVAL,IER,ALIST,BLIST,RLIST,ELIST,PTS,IORD,LEVEL,NDIN, + * LAST) +C***BEGIN PROLOGUE DQAGPE +C***DATE WRITTEN 800101 (YYMMDD) +C***REVISION DATE 830518 (YYMMDD) +C***CATEGORY NO. H2A2A1 +C***KEYWORDS AUTOMATIC INTEGRATOR, GENERAL-PURPOSE, +C SINGULARITIES AT USER SPECIFIED POINTS, +C EXTRAPOLATION, GLOBALLY ADAPTIVE. +C***AUTHOR PIESSENS,ROBERT ,APPL. MATH. & PROGR. DIV. - K.U.LEUVEN +C DE DONCKER,ELISE,APPL. MATH. & PROGR. DIV. - K.U.LEUVEN +C***PURPOSE THE ROUTINE CALCULATES AN APPROXIMATION RESULT TO A GIVEN +C DEFINITE INTEGRAL I = INTEGRAL OF F OVER (A,B), HOPEFULLY +C SATISFYING FOLLOWING CLAIM FOR ACCURACY ABS(I-RESULT).LE. +C MAX(EPSABS,EPSREL*ABS(I)). BREAK POINTS OF THE INTEGRATION +C INTERVAL, WHERE LOCAL DIFFICULTIES OF THE INTEGRAND MAY +C OCCUR(E.G. SINGULARITIES,DISCONTINUITIES),PROVIDED BY USER. +C***DESCRIPTION +C +C COMPUTATION OF A DEFINITE INTEGRAL +C STANDARD FORTRAN SUBROUTINE +C DOUBLE PRECISION VERSION +C +C PARAMETERS +C ON ENTRY +C F - SUBROUTINE F(X,IERR,RESULT) DEFINING THE INTEGRAND +C FUNCTION F(X). THE ACTUAL NAME FOR F NEEDS TO BE +C DECLARED E X T E R N A L IN THE DRIVER PROGRAM. +C +C A - DOUBLE PRECISION +C LOWER LIMIT OF INTEGRATION +C +C B - DOUBLE PRECISION +C UPPER LIMIT OF INTEGRATION +C +C NPTS2 - INTEGER +C NUMBER EQUAL TO TWO MORE THAN THE NUMBER OF +C USER-SUPPLIED BREAK POINTS WITHIN THE INTEGRATION +C RANGE, NPTS2.GE.2. +C IF NPTS2.LT.2, THE ROUTINE WILL END WITH IER = 6. +C +C POINTS - DOUBLE PRECISION +C VECTOR OF DIMENSION NPTS2, THE FIRST (NPTS2-2) +C ELEMENTS OF WHICH ARE THE USER PROVIDED BREAK +C POINTS. IF THESE POINTS DO NOT CONSTITUTE AN +C ASCENDING SEQUENCE THERE WILL BE AN AUTOMATIC +C SORTING. +C +C EPSABS - DOUBLE PRECISION +C ABSOLUTE ACCURACY REQUESTED +C EPSREL - DOUBLE PRECISION +C RELATIVE ACCURACY REQUESTED +C IF EPSABS.LE.0 +C AND EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28), +C THE ROUTINE WILL END WITH IER = 6. +C +C LIMIT - INTEGER +C GIVES AN UPPER BOUND ON THE NUMBER OF SUBINTERVALS +C IN THE PARTITION OF (A,B), LIMIT.GE.NPTS2 +C IF LIMIT.LT.NPTS2, THE ROUTINE WILL END WITH +C IER = 6. +C +C ON RETURN +C RESULT - DOUBLE PRECISION +C APPROXIMATION TO THE INTEGRAL +C +C ABSERR - DOUBLE PRECISION +C ESTIMATE OF THE MODULUS OF THE ABSOLUTE ERROR, +C WHICH SHOULD EQUAL OR EXCEED ABS(I-RESULT) +C +C NEVAL - INTEGER +C NUMBER OF INTEGRAND EVALUATIONS +C +C IER - INTEGER +C IER = 0 NORMAL AND RELIABLE TERMINATION OF THE +C ROUTINE. IT IS ASSUMED THAT THE REQUESTED +C ACCURACY HAS BEEN ACHIEVED. +C IER.GT.0 ABNORMAL TERMINATION OF THE ROUTINE. +C THE ESTIMATES FOR INTEGRAL AND ERROR ARE +C LESS RELIABLE. IT IS ASSUMED THAT THE +C REQUESTED ACCURACY HAS NOT BEEN ACHIEVED. +C IER.LT.0 EXIT REQUESTED FROM USER-SUPPLIED +C FUNCTION. +C +C ERROR MESSAGES +C IER = 1 MAXIMUM NUMBER OF SUBDIVISIONS ALLOWED +C HAS BEEN ACHIEVED. ONE CAN ALLOW MORE +C SUBDIVISIONS BY INCREASING THE VALUE OF +C LIMIT (AND TAKING THE ACCORDING DIMENSION +C ADJUSTMENTS INTO ACCOUNT). HOWEVER, IF +C THIS YIELDS NO IMPROVEMENT IT IS ADVISED +C TO ANALYZE THE INTEGRAND IN ORDER TO +C DETERMINE THE INTEGRATION DIFFICULTIES. IF +C THE POSITION OF A LOCAL DIFFICULTY CAN BE +C DETERMINED (I.E. SINGULARITY, +C DISCONTINUITY WITHIN THE INTERVAL), IT +C SHOULD BE SUPPLIED TO THE ROUTINE AS AN +C ELEMENT OF THE VECTOR POINTS. IF NECESSARY +C AN APPROPRIATE SPECIAL-PURPOSE INTEGRATOR +C MUST BE USED, WHICH IS DESIGNED FOR +C HANDLING THE TYPE OF DIFFICULTY INVOLVED. +C = 2 THE OCCURRENCE OF ROUNDOFF ERROR IS +C DETECTED, WHICH PREVENTS THE REQUESTED +C TOLERANCE FROM BEING ACHIEVED. +C THE ERROR MAY BE UNDER-ESTIMATED. +C = 3 EXTREMELY BAD INTEGRAND BEHAVIOUR OCCURS +C AT SOME POINTS OF THE INTEGRATION +C INTERVAL. +C = 4 THE ALGORITHM DOES NOT CONVERGE. +C ROUNDOFF ERROR IS DETECTED IN THE +C EXTRAPOLATION TABLE. IT IS PRESUMED THAT +C THE REQUESTED TOLERANCE CANNOT BE +C ACHIEVED, AND THAT THE RETURNED RESULT IS +C THE BEST WHICH CAN BE OBTAINED. +C = 5 THE INTEGRAL IS PROBABLY DIVERGENT, OR +C SLOWLY CONVERGENT. IT MUST BE NOTED THAT +C DIVERGENCE CAN OCCUR WITH ANY OTHER VALUE +C OF IER.GT.0. +C = 6 THE INPUT IS INVALID BECAUSE +C NPTS2.LT.2 OR +C BREAK POINTS ARE SPECIFIED OUTSIDE +C THE INTEGRATION RANGE OR +C (EPSABS.LE.0 AND +C EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28)) +C OR LIMIT.LT.NPTS2. +C RESULT, ABSERR, NEVAL, LAST, RLIST(1), +C AND ELIST(1) ARE SET TO ZERO. ALIST(1) AND +C BLIST(1) ARE SET TO A AND B RESPECTIVELY. +C +C ALIST - DOUBLE PRECISION +C VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST +C LAST ELEMENTS OF WHICH ARE THE LEFT END POINTS +C OF THE SUBINTERVALS IN THE PARTITION OF THE GIVEN +C INTEGRATION RANGE (A,B) +C +C BLIST - DOUBLE PRECISION +C VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST +C LAST ELEMENTS OF WHICH ARE THE RIGHT END POINTS +C OF THE SUBINTERVALS IN THE PARTITION OF THE GIVEN +C INTEGRATION RANGE (A,B) +C +C RLIST - DOUBLE PRECISION +C VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST +C LAST ELEMENTS OF WHICH ARE THE INTEGRAL +C APPROXIMATIONS ON THE SUBINTERVALS +C +C ELIST - DOUBLE PRECISION +C VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST +C LAST ELEMENTS OF WHICH ARE THE MODULI OF THE +C ABSOLUTE ERROR ESTIMATES ON THE SUBINTERVALS +C +C PTS - DOUBLE PRECISION +C VECTOR OF DIMENSION AT LEAST NPTS2, CONTAINING THE +C INTEGRATION LIMITS AND THE BREAK POINTS OF THE +C INTERVAL IN ASCENDING SEQUENCE. +C +C LEVEL - INTEGER +C VECTOR OF DIMENSION AT LEAST LIMIT, CONTAINING THE +C SUBDIVISION LEVELS OF THE SUBINTERVAL, I.E. IF +C (AA,BB) IS A SUBINTERVAL OF (P1,P2) WHERE P1 AS +C WELL AS P2 IS A USER-PROVIDED BREAK POINT OR +C INTEGRATION LIMIT, THEN (AA,BB) HAS LEVEL L IF +C ABS(BB-AA) = ABS(P2-P1)*2**(-L). +C +C NDIN - INTEGER +C VECTOR OF DIMENSION AT LEAST NPTS2, AFTER FIRST +C INTEGRATION OVER THE INTERVALS (PTS(I)),PTS(I+1), +C I = 0,1, ..., NPTS2-2, THE ERROR ESTIMATES OVER +C SOME OF THE INTERVALS MAY HAVE BEEN INCREASED +C ARTIFICIALLY, IN ORDER TO PUT THEIR SUBDIVISION +C FORWARD. IF THIS HAPPENS FOR THE SUBINTERVAL +C NUMBERED K, NDIN(K) IS PUT TO 1, OTHERWISE +C NDIN(K) = 0. +C +C IORD - INTEGER +C VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST K +C ELEMENTS OF WHICH ARE POINTERS TO THE +C ERROR ESTIMATES OVER THE SUBINTERVALS, +C SUCH THAT ELIST(IORD(1)), ..., ELIST(IORD(K)) +C FORM A DECREASING SEQUENCE, WITH K = LAST +C IF LAST.LE.(LIMIT/2+2), AND K = LIMIT+1-LAST +C OTHERWISE +C +C LAST - INTEGER +C NUMBER OF SUBINTERVALS ACTUALLY PRODUCED IN THE +C SUBDIVISIONS PROCESS +C +C***REFERENCES (NONE) +C***ROUTINES CALLED D1MACH,DQELG,DQK21,DQPSRT +C***END PROLOGUE DQAGPE + DOUBLE PRECISION A,ABSEPS,ABSERR,ALIST,AREA,AREA1,AREA12,AREA2,A1, + * A2,B,BLIST,B1,B2,CORREC,DABS,DEFABS,DEFAB1,DEFAB2,DMAX1,DMIN1, + * DRES,D1MACH,ELIST,EPMACH,EPSABS,EPSREL,ERLARG,ERLAST,ERRBND, + * ERRMAX,ERROR1,ERRO12,ERROR2,ERRSUM,ERTEST,OFLOW,POINTS,PTS, + * RESA,RESABS,RESEPS,RESULT,RES3LA,RLIST,RLIST2,SIGN,TEMP,UFLOW + INTEGER I,ID,IER,IERRO,IND1,IND2,IORD,IP1,IROFF1,IROFF2,IROFF3,J, + * JLOW,JUPBND,K,KSGN,KTMIN,LAST,LEVCUR,LEVEL,LEVMAX,LIMIT,MAXERR, + * NDIN,NEVAL,NINT,NINTP1,NPTS,NPTS2,NRES,NRMAX,NUMRL2 + LOGICAL EXTRAP,NOEXT +C +C + DIMENSION ALIST(LIMIT),BLIST(LIMIT),ELIST(LIMIT),IORD(LIMIT), + * LEVEL(LIMIT),NDIN(NPTS2),POINTS(NPTS2),PTS(NPTS2),RES3LA(3), + * RLIST(LIMIT),RLIST2(52) +C + EXTERNAL F +C +C THE DIMENSION OF RLIST2 IS DETERMINED BY THE VALUE OF +C LIMEXP IN SUBROUTINE EPSALG (RLIST2 SHOULD BE OF DIMENSION +C (LIMEXP+2) AT LEAST). +C +C +C LIST OF MAJOR VARIABLES +C ----------------------- +C +C ALIST - LIST OF LEFT END POINTS OF ALL SUBINTERVALS +C CONSIDERED UP TO NOW +C BLIST - LIST OF RIGHT END POINTS OF ALL SUBINTERVALS +C CONSIDERED UP TO NOW +C RLIST(I) - APPROXIMATION TO THE INTEGRAL OVER +C (ALIST(I),BLIST(I)) +C RLIST2 - ARRAY OF DIMENSION AT LEAST LIMEXP+2 +C CONTAINING THE PART OF THE EPSILON TABLE WHICH +C IS STILL NEEDED FOR FURTHER COMPUTATIONS +C ELIST(I) - ERROR ESTIMATE APPLYING TO RLIST(I) +C MAXERR - POINTER TO THE INTERVAL WITH LARGEST ERROR +C ESTIMATE +C ERRMAX - ELIST(MAXERR) +C ERLAST - ERROR ON THE INTERVAL CURRENTLY SUBDIVIDED +C (BEFORE THAT SUBDIVISION HAS TAKEN PLACE) +C AREA - SUM OF THE INTEGRALS OVER THE SUBINTERVALS +C ERRSUM - SUM OF THE ERRORS OVER THE SUBINTERVALS +C ERRBND - REQUESTED ACCURACY MAX(EPSABS,EPSREL* +C ABS(RESULT)) +C *****1 - VARIABLE FOR THE LEFT SUBINTERVAL +C *****2 - VARIABLE FOR THE RIGHT SUBINTERVAL +C LAST - INDEX FOR SUBDIVISION +C NRES - NUMBER OF CALLS TO THE EXTRAPOLATION ROUTINE +C NUMRL2 - NUMBER OF ELEMENTS IN RLIST2. IF AN APPROPRIATE +C APPROXIMATION TO THE COMPOUNDED INTEGRAL HAS +C BEEN OBTAINED, IT IS PUT IN RLIST2(NUMRL2) AFTER +C NUMRL2 HAS BEEN INCREASED BY ONE. +C ERLARG - SUM OF THE ERRORS OVER THE INTERVALS LARGER +C THAN THE SMALLEST INTERVAL CONSIDERED UP TO NOW +C EXTRAP - LOGICAL VARIABLE DENOTING THAT THE ROUTINE +C IS ATTEMPTING TO PERFORM EXTRAPOLATION. I.E. +C BEFORE SUBDIVIDING THE SMALLEST INTERVAL WE +C TRY TO DECREASE THE VALUE OF ERLARG. +C NOEXT - LOGICAL VARIABLE DENOTING THAT EXTRAPOLATION IS +C NO LONGER ALLOWED (TRUE-VALUE) +C +C MACHINE DEPENDENT CONSTANTS +C --------------------------- +C +C EPMACH IS THE LARGEST RELATIVE SPACING. +C UFLOW IS THE SMALLEST POSITIVE MAGNITUDE. +C OFLOW IS THE LARGEST POSITIVE MAGNITUDE. +C +C***FIRST EXECUTABLE STATEMENT DQAGPE + EPMACH = D1MACH(4) +C +C TEST ON VALIDITY OF PARAMETERS +C ----------------------------- +C + IER = 0 + NEVAL = 0 + LAST = 0 + RESULT = 0.0D+00 + ABSERR = 0.0D+00 + ALIST(1) = A + BLIST(1) = B + RLIST(1) = 0.0D+00 + ELIST(1) = 0.0D+00 + IORD(1) = 0 + LEVEL(1) = 0 + NPTS = NPTS2-2 + IF(NPTS2.LT.2.OR.LIMIT.LE.NPTS.OR.(EPSABS.LE.0.0D+00.AND. + * EPSREL.LT.DMAX1(0.5D+02*EPMACH,0.5D-28))) IER = 6 + IF(IER.EQ.6) GO TO 999 +C +C IF ANY BREAK POINTS ARE PROVIDED, SORT THEM INTO AN +C ASCENDING SEQUENCE. +C + SIGN = 1.0D+00 + IF(A.GT.B) SIGN = -1.0D+00 + PTS(1) = DMIN1(A,B) + IF(NPTS.EQ.0) GO TO 15 + DO 10 I = 1,NPTS + PTS(I+1) = POINTS(I) + 10 CONTINUE + 15 PTS(NPTS+2) = DMAX1(A,B) + NINT = NPTS+1 + A1 = PTS(1) + IF(NPTS.EQ.0) GO TO 40 + NINTP1 = NINT+1 + DO 20 I = 1,NINT + IP1 = I+1 + DO 20 J = IP1,NINTP1 + IF(PTS(I).LE.PTS(J)) GO TO 20 + TEMP = PTS(I) + PTS(I) = PTS(J) + PTS(J) = TEMP + 20 CONTINUE + IF(PTS(1).NE.DMIN1(A,B).OR.PTS(NINTP1).NE.DMAX1(A,B)) IER = 6 + IF(IER.EQ.6) GO TO 999 +C +C COMPUTE FIRST INTEGRAL AND ERROR APPROXIMATIONS. +C ------------------------------------------------ +C + 40 RESABS = 0.0D+00 + DO 50 I = 1,NINT + B1 = PTS(I+1) + CALL DQK21(F,A1,B1,AREA1,ERROR1,DEFABS,RESA,IER) + IF (IER .LT. 0) RETURN + ABSERR = ABSERR+ERROR1 + RESULT = RESULT+AREA1 + NDIN(I) = 0 + IF(ERROR1.EQ.RESA.AND.ERROR1.NE.0.0D+00) NDIN(I) = 1 + RESABS = RESABS+DEFABS + LEVEL(I) = 0 + ELIST(I) = ERROR1 + ALIST(I) = A1 + BLIST(I) = B1 + RLIST(I) = AREA1 + IORD(I) = I + A1 = B1 + 50 CONTINUE + ERRSUM = 0.0D+00 + DO 55 I = 1,NINT + IF(NDIN(I).EQ.1) ELIST(I) = ABSERR + ERRSUM = ERRSUM+ELIST(I) + 55 CONTINUE +C +C TEST ON ACCURACY. +C + LAST = NINT + NEVAL = 21*NINT + DRES = DABS(RESULT) + ERRBND = DMAX1(EPSABS,EPSREL*DRES) + IF(ABSERR.LE.0.1D+03*EPMACH*RESABS.AND.ABSERR.GT.ERRBND) IER = 2 + IF(NINT.EQ.1) GO TO 80 + DO 70 I = 1,NPTS + JLOW = I+1 + IND1 = IORD(I) + DO 60 J = JLOW,NINT + IND2 = IORD(J) + IF(ELIST(IND1).GT.ELIST(IND2)) GO TO 60 + IND1 = IND2 + K = J + 60 CONTINUE + IF(IND1.EQ.IORD(I)) GO TO 70 + IORD(K) = IORD(I) + IORD(I) = IND1 + 70 CONTINUE + IF(LIMIT.LT.NPTS2) IER = 1 + 80 IF(IER.NE.0.OR.ABSERR.LE.ERRBND) GO TO 210 +C +C INITIALIZATION +C -------------- +C + RLIST2(1) = RESULT + MAXERR = IORD(1) + ERRMAX = ELIST(MAXERR) + AREA = RESULT + NRMAX = 1 + NRES = 0 + NUMRL2 = 1 + KTMIN = 0 + EXTRAP = .FALSE. + NOEXT = .FALSE. + ERLARG = ERRSUM + ERTEST = ERRBND + LEVMAX = 1 + IROFF1 = 0 + IROFF2 = 0 + IROFF3 = 0 + IERRO = 0 + UFLOW = D1MACH(1) + OFLOW = D1MACH(2) + ABSERR = OFLOW + KSGN = -1 + IF(DRES.GE.(0.1D+01-0.5D+02*EPMACH)*RESABS) KSGN = 1 +C +C MAIN DO-LOOP +C ------------ +C + DO 160 LAST = NPTS2,LIMIT +C +C BISECT THE SUBINTERVAL WITH THE NRMAX-TH LARGEST ERROR +C ESTIMATE. +C + LEVCUR = LEVEL(MAXERR)+1 + A1 = ALIST(MAXERR) + B1 = 0.5D+00*(ALIST(MAXERR)+BLIST(MAXERR)) + A2 = B1 + B2 = BLIST(MAXERR) + ERLAST = ERRMAX + CALL DQK21(F,A1,B1,AREA1,ERROR1,RESA,DEFAB1,IER) + IF (IER .LT. 0) RETURN + CALL DQK21(F,A2,B2,AREA2,ERROR2,RESA,DEFAB2,IER) + IF (IER .LT. 0) RETURN +C +C IMPROVE PREVIOUS APPROXIMATIONS TO INTEGRAL +C AND ERROR AND TEST FOR ACCURACY. +C + NEVAL = NEVAL+42 + AREA12 = AREA1+AREA2 + ERRO12 = ERROR1+ERROR2 + ERRSUM = ERRSUM+ERRO12-ERRMAX + AREA = AREA+AREA12-RLIST(MAXERR) + IF(DEFAB1.EQ.ERROR1.OR.DEFAB2.EQ.ERROR2) GO TO 95 + IF(DABS(RLIST(MAXERR)-AREA12).GT.0.1D-04*DABS(AREA12) + * .OR.ERRO12.LT.0.99D+00*ERRMAX) GO TO 90 + IF(EXTRAP) IROFF2 = IROFF2+1 + IF(.NOT.EXTRAP) IROFF1 = IROFF1+1 + 90 IF(LAST.GT.10.AND.ERRO12.GT.ERRMAX) IROFF3 = IROFF3+1 + 95 LEVEL(MAXERR) = LEVCUR + LEVEL(LAST) = LEVCUR + RLIST(MAXERR) = AREA1 + RLIST(LAST) = AREA2 + ERRBND = DMAX1(EPSABS,EPSREL*DABS(AREA)) +C +C TEST FOR ROUNDOFF ERROR AND EVENTUALLY SET ERROR FLAG. +C + IF(IROFF1+IROFF2.GE.10.OR.IROFF3.GE.20) IER = 2 + IF(IROFF2.GE.5) IERRO = 3 +C +C SET ERROR FLAG IN THE CASE THAT THE NUMBER OF +C SUBINTERVALS EQUALS LIMIT. +C + IF(LAST.EQ.LIMIT) IER = 1 +C +C SET ERROR FLAG IN THE CASE OF BAD INTEGRAND BEHAVIOUR +C AT A POINT OF THE INTEGRATION RANGE +C + IF(DMAX1(DABS(A1),DABS(B2)).LE.(0.1D+01+0.1D+03*EPMACH)* + * (DABS(A2)+0.1D+04*UFLOW)) IER = 4 +C +C APPEND THE NEWLY-CREATED INTERVALS TO THE LIST. +C + IF(ERROR2.GT.ERROR1) GO TO 100 + ALIST(LAST) = A2 + BLIST(MAXERR) = B1 + BLIST(LAST) = B2 + ELIST(MAXERR) = ERROR1 + ELIST(LAST) = ERROR2 + GO TO 110 + 100 ALIST(MAXERR) = A2 + ALIST(LAST) = A1 + BLIST(LAST) = B1 + RLIST(MAXERR) = AREA2 + RLIST(LAST) = AREA1 + ELIST(MAXERR) = ERROR2 + ELIST(LAST) = ERROR1 +C +C CALL SUBROUTINE DQPSRT TO MAINTAIN THE DESCENDING ORDERING +C IN THE LIST OF ERROR ESTIMATES AND SELECT THE SUBINTERVAL +C WITH NRMAX-TH LARGEST ERROR ESTIMATE (TO BE BISECTED NEXT). +C + 110 CALL DQPSRT(LIMIT,LAST,MAXERR,ERRMAX,ELIST,IORD,NRMAX) +C ***JUMP OUT OF DO-LOOP + IF(ERRSUM.LE.ERRBND) GO TO 190 +C ***JUMP OUT OF DO-LOOP + IF(IER.NE.0) GO TO 170 + IF(NOEXT) GO TO 160 + ERLARG = ERLARG-ERLAST + IF(LEVCUR+1.LE.LEVMAX) ERLARG = ERLARG+ERRO12 + IF(EXTRAP) GO TO 120 +C +C TEST WHETHER THE INTERVAL TO BE BISECTED NEXT IS THE +C SMALLEST INTERVAL. +C + IF(LEVEL(MAXERR)+1.LE.LEVMAX) GO TO 160 + EXTRAP = .TRUE. + NRMAX = 2 + 120 IF(IERRO.EQ.3.OR.ERLARG.LE.ERTEST) GO TO 140 +C +C THE SMALLEST INTERVAL HAS THE LARGEST ERROR. +C BEFORE BISECTING DECREASE THE SUM OF THE ERRORS OVER +C THE LARGER INTERVALS (ERLARG) AND PERFORM EXTRAPOLATION. +C + ID = NRMAX + JUPBND = LAST + IF(LAST.GT.(2+LIMIT/2)) JUPBND = LIMIT+3-LAST + DO 130 K = ID,JUPBND + MAXERR = IORD(NRMAX) + ERRMAX = ELIST(MAXERR) +C ***JUMP OUT OF DO-LOOP + IF(LEVEL(MAXERR)+1.LE.LEVMAX) GO TO 160 + NRMAX = NRMAX+1 + 130 CONTINUE +C +C PERFORM EXTRAPOLATION. +C + 140 NUMRL2 = NUMRL2+1 + RLIST2(NUMRL2) = AREA + IF(NUMRL2.LE.2) GO TO 155 + CALL DQELG(NUMRL2,RLIST2,RESEPS,ABSEPS,RES3LA,NRES) + KTMIN = KTMIN+1 + IF(KTMIN.GT.5.AND.ABSERR.LT.0.1D-02*ERRSUM) IER = 5 + IF(ABSEPS.GE.ABSERR) GO TO 150 + KTMIN = 0 + ABSERR = ABSEPS + RESULT = RESEPS + CORREC = ERLARG + ERTEST = DMAX1(EPSABS,EPSREL*DABS(RESEPS)) +C ***JUMP OUT OF DO-LOOP + IF(ABSERR.LT.ERTEST) GO TO 170 +C +C PREPARE BISECTION OF THE SMALLEST INTERVAL. +C + 150 IF(NUMRL2.EQ.1) NOEXT = .TRUE. + IF(IER.GE.5) GO TO 170 + 155 MAXERR = IORD(1) + ERRMAX = ELIST(MAXERR) + NRMAX = 1 + EXTRAP = .FALSE. + LEVMAX = LEVMAX+1 + ERLARG = ERRSUM + 160 CONTINUE +C +C SET THE FINAL RESULT. +C --------------------- +C +C + 170 IF(ABSERR.EQ.OFLOW) GO TO 190 + IF((IER+IERRO).EQ.0) GO TO 180 + IF(IERRO.EQ.3) ABSERR = ABSERR+CORREC + IF(IER.EQ.0) IER = 3 + IF(RESULT.NE.0.0D+00.AND.AREA.NE.0.0D+00)GO TO 175 + IF(ABSERR.GT.ERRSUM)GO TO 190 + IF(AREA.EQ.0.0D+00) GO TO 210 + GO TO 180 + 175 IF(ABSERR/DABS(RESULT).GT.ERRSUM/DABS(AREA))GO TO 190 +C +C TEST ON DIVERGENCE. +C + 180 IF(KSGN.EQ.(-1).AND.DMAX1(DABS(RESULT),DABS(AREA)).LE. + * RESABS*0.1D-01) GO TO 210 + IF(0.1D-01.GT.(RESULT/AREA).OR.(RESULT/AREA).GT.0.1D+03.OR. + * ERRSUM.GT.DABS(AREA)) IER = 6 + GO TO 210 +C +C COMPUTE GLOBAL INTEGRAL SUM. +C + 190 RESULT = 0.0D+00 + DO 200 K = 1,LAST + RESULT = RESULT+RLIST(K) + 200 CONTINUE + ABSERR = ERRSUM + 210 IF(IER.GT.2) IER = IER-1 + RESULT = RESULT*SIGN + 999 RETURN + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/quadpack/dqelg.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,184 @@ + SUBROUTINE DQELG(N,EPSTAB,RESULT,ABSERR,RES3LA,NRES) +C***BEGIN PROLOGUE DQELG +C***REFER TO DQAGIE,DQAGOE,DQAGPE,DQAGSE +C***ROUTINES CALLED D1MACH +C***REVISION DATE 830518 (YYMMDD) +C***KEYWORDS EPSILON ALGORITHM, CONVERGENCE ACCELERATION, +C EXTRAPOLATION +C***AUTHOR PIESSENS,ROBERT,APPL. MATH. & PROGR. DIV. - K.U.LEUVEN +C DE DONCKER,ELISE,APPL. MATH & PROGR. DIV. - K.U.LEUVEN +C***PURPOSE THE ROUTINE DETERMINES THE LIMIT OF A GIVEN SEQUENCE OF +C APPROXIMATIONS, BY MEANS OF THE EPSILON ALGORITHM OF +C P.WYNN. AN ESTIMATE OF THE ABSOLUTE ERROR IS ALSO GIVEN. +C THE CONDENSED EPSILON TABLE IS COMPUTED. ONLY THOSE +C ELEMENTS NEEDED FOR THE COMPUTATION OF THE NEXT DIAGONAL +C ARE PRESERVED. +C***DESCRIPTION +C +C EPSILON ALGORITHM +C STANDARD FORTRAN SUBROUTINE +C DOUBLE PRECISION VERSION +C +C PARAMETERS +C N - INTEGER +C EPSTAB(N) CONTAINS THE NEW ELEMENT IN THE +C FIRST COLUMN OF THE EPSILON TABLE. +C +C EPSTAB - DOUBLE PRECISION +C VECTOR OF DIMENSION 52 CONTAINING THE ELEMENTS +C OF THE TWO LOWER DIAGONALS OF THE TRIANGULAR +C EPSILON TABLE. THE ELEMENTS ARE NUMBERED +C STARTING AT THE RIGHT-HAND CORNER OF THE +C TRIANGLE. +C +C RESULT - DOUBLE PRECISION +C RESULTING APPROXIMATION TO THE INTEGRAL +C +C ABSERR - DOUBLE PRECISION +C ESTIMATE OF THE ABSOLUTE ERROR COMPUTED FROM +C RESULT AND THE 3 PREVIOUS RESULTS +C +C RES3LA - DOUBLE PRECISION +C VECTOR OF DIMENSION 3 CONTAINING THE LAST 3 +C RESULTS +C +C NRES - INTEGER +C NUMBER OF CALLS TO THE ROUTINE +C (SHOULD BE ZERO AT FIRST CALL) +C +C***END PROLOGUE DQELG +C + DOUBLE PRECISION ABSERR,DABS,DELTA1,DELTA2,DELTA3,DMAX1,D1MACH, + * EPMACH,EPSINF,EPSTAB,ERROR,ERR1,ERR2,ERR3,E0,E1,E1ABS,E2,E3, + * OFLOW,RES,RESULT,RES3LA,SS,TOL1,TOL2,TOL3 + INTEGER I,IB,IB2,IE,INDX,K1,K2,K3,LIMEXP,N,NEWELM,NRES,NUM + DIMENSION EPSTAB(52),RES3LA(3) +C +C LIST OF MAJOR VARIABLES +C ----------------------- +C +C E0 - THE 4 ELEMENTS ON WHICH THE COMPUTATION OF A NEW +C E1 ELEMENT IN THE EPSILON TABLE IS BASED +C E2 +C E3 E0 +C E3 E1 NEW +C E2 +C NEWELM - NUMBER OF ELEMENTS TO BE COMPUTED IN THE NEW +C DIAGONAL +C ERROR - ERROR = ABS(E1-E0)+ABS(E2-E1)+ABS(NEW-E2) +C RESULT - THE ELEMENT IN THE NEW DIAGONAL WITH LEAST VALUE +C OF ERROR +C +C MACHINE DEPENDENT CONSTANTS +C --------------------------- +C +C EPMACH IS THE LARGEST RELATIVE SPACING. +C OFLOW IS THE LARGEST POSITIVE MAGNITUDE. +C LIMEXP IS THE MAXIMUM NUMBER OF ELEMENTS THE EPSILON +C TABLE CAN CONTAIN. IF THIS NUMBER IS REACHED, THE UPPER +C DIAGONAL OF THE EPSILON TABLE IS DELETED. +C +C***FIRST EXECUTABLE STATEMENT DQELG + EPMACH = D1MACH(4) + OFLOW = D1MACH(2) + NRES = NRES+1 + ABSERR = OFLOW + RESULT = EPSTAB(N) + IF(N.LT.3) GO TO 100 + LIMEXP = 50 + EPSTAB(N+2) = EPSTAB(N) + NEWELM = (N-1)/2 + EPSTAB(N) = OFLOW + NUM = N + K1 = N + DO 40 I = 1,NEWELM + K2 = K1-1 + K3 = K1-2 + RES = EPSTAB(K1+2) + E0 = EPSTAB(K3) + E1 = EPSTAB(K2) + E2 = RES + E1ABS = DABS(E1) + DELTA2 = E2-E1 + ERR2 = DABS(DELTA2) + TOL2 = DMAX1(DABS(E2),E1ABS)*EPMACH + DELTA3 = E1-E0 + ERR3 = DABS(DELTA3) + TOL3 = DMAX1(E1ABS,DABS(E0))*EPMACH + IF(ERR2.GT.TOL2.OR.ERR3.GT.TOL3) GO TO 10 +C +C IF E0, E1 AND E2 ARE EQUAL TO WITHIN MACHINE +C ACCURACY, CONVERGENCE IS ASSUMED. +C RESULT = E2 +C ABSERR = ABS(E1-E0)+ABS(E2-E1) +C + RESULT = RES + ABSERR = ERR2+ERR3 +C ***JUMP OUT OF DO-LOOP + GO TO 100 + 10 E3 = EPSTAB(K1) + EPSTAB(K1) = E1 + DELTA1 = E1-E3 + ERR1 = DABS(DELTA1) + TOL1 = DMAX1(E1ABS,DABS(E3))*EPMACH +C +C IF TWO ELEMENTS ARE VERY CLOSE TO EACH OTHER, OMIT +C A PART OF THE TABLE BY ADJUSTING THE VALUE OF N +C + IF(ERR1.LE.TOL1.OR.ERR2.LE.TOL2.OR.ERR3.LE.TOL3) GO TO 20 + SS = 0.1D+01/DELTA1+0.1D+01/DELTA2-0.1D+01/DELTA3 + EPSINF = DABS(SS*E1) +C +C TEST TO DETECT IRREGULAR BEHAVIOUR IN THE TABLE, AND +C EVENTUALLY OMIT A PART OF THE TABLE ADJUSTING THE VALUE +C OF N. +C + IF(EPSINF.GT.0.1D-03) GO TO 30 + 20 N = I+I-1 +C ***JUMP OUT OF DO-LOOP + GO TO 50 +C +C COMPUTE A NEW ELEMENT AND EVENTUALLY ADJUST +C THE VALUE OF RESULT. +C + 30 RES = E1+0.1D+01/SS + EPSTAB(K1) = RES + K1 = K1-2 + ERROR = ERR2+DABS(RES-E2)+ERR3 + IF(ERROR.GT.ABSERR) GO TO 40 + ABSERR = ERROR + RESULT = RES + 40 CONTINUE +C +C SHIFT THE TABLE. +C + 50 IF(N.EQ.LIMEXP) N = 2*(LIMEXP/2)-1 + IB = 1 + IF((NUM/2)*2.EQ.NUM) IB = 2 + IE = NEWELM+1 + DO 60 I=1,IE + IB2 = IB+2 + EPSTAB(IB) = EPSTAB(IB2) + IB = IB2 + 60 CONTINUE + IF(NUM.EQ.N) GO TO 80 + INDX = NUM-N+1 + DO 70 I = 1,N + EPSTAB(I)= EPSTAB(INDX) + INDX = INDX+1 + 70 CONTINUE + 80 IF(NRES.GE.4) GO TO 90 + RES3LA(NRES) = RESULT + ABSERR = OFLOW + GO TO 100 +C +C COMPUTE ERROR ESTIMATE +C + 90 ABSERR = DABS(RESULT-RES3LA(3))+DABS(RESULT-RES3LA(2)) + * +DABS(RESULT-RES3LA(1)) + RES3LA(1) = RES3LA(2) + RES3LA(2) = RES3LA(3) + RES3LA(3) = RESULT + 100 ABSERR = DMAX1(ABSERR,0.5D+01*EPMACH*DABS(RESULT)) + RETURN + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/quadpack/dqk15i.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,211 @@ + SUBROUTINE DQK15I(F,BOUN,INF,A,B,RESULT,ABSERR,RESABS,RESASC, + 1 IERR) +C***BEGIN PROLOGUE DQK15I +C***DATE WRITTEN 800101 (YYMMDD) +C***REVISION DATE 830518 (YYMMDD) +C***CATEGORY NO. H2A3A2,H2A4A2 +C***KEYWORDS 15-POINT TRANSFORMED GAUSS-KRONROD RULES +C***AUTHOR PIESSENS,ROBERT,APPL. MATH. & PROGR. DIV. - K.U.LEUVEN +C DE DONCKER,ELISE,APPL. MATH. & PROGR. DIV. - K.U.LEUVEN +C***PURPOSE THE ORIGINAL (INFINITE INTEGRATION RANGE IS MAPPED +C ONTO THE INTERVAL (0,1) AND (A,B) IS A PART OF (0,1). +C IT IS THE PURPOSE TO COMPUTE +C I = INTEGRAL OF TRANSFORMED INTEGRAND OVER (A,B), +C J = INTEGRAL OF ABS(TRANSFORMED INTEGRAND) OVER (A,B). +C***DESCRIPTION +C +C INTEGRATION RULE +C STANDARD FORTRAN SUBROUTINE +C DOUBLE PRECISION VERSION +C +C PARAMETERS +C ON ENTRY +C F - SUBROUTINE F(X,IERR,RESULT) DEFINING THE INTEGRAND +C FUNCTION F(X). THE ACTUAL NAME FOR F NEEDS TO BE +C DECLARED E X T E R N A L IN THE CALLING PROGRAM. +C +C BOUN - DOUBLE PRECISION +C FINITE BOUND OF ORIGINAL INTEGRATION +C RANGE (SET TO ZERO IF INF = +2) +C +C INF - INTEGER +C IF INF = -1, THE ORIGINAL INTERVAL IS +C (-INFINITY,BOUND), +C IF INF = +1, THE ORIGINAL INTERVAL IS +C (BOUND,+INFINITY), +C IF INF = +2, THE ORIGINAL INTERVAL IS +C (-INFINITY,+INFINITY) AND +C THE INTEGRAL IS COMPUTED AS THE SUM OF TWO +C INTEGRALS, ONE OVER (-INFINITY,0) AND ONE OVER +C (0,+INFINITY). +C +C A - DOUBLE PRECISION +C LOWER LIMIT FOR INTEGRATION OVER SUBRANGE +C OF (0,1) +C +C B - DOUBLE PRECISION +C UPPER LIMIT FOR INTEGRATION OVER SUBRANGE +C OF (0,1) +C +C ON RETURN +C RESULT - DOUBLE PRECISION +C APPROXIMATION TO THE INTEGRAL I +C RESULT IS COMPUTED BY APPLYING THE 15-POINT +C KRONROD RULE(RESK) OBTAINED BY OPTIMAL ADDITION +C OF ABSCISSAE TO THE 7-POINT GAUSS RULE(RESG). +C +C ABSERR - DOUBLE PRECISION +C ESTIMATE OF THE MODULUS OF THE ABSOLUTE ERROR, +C WHICH SHOULD EQUAL OR EXCEED ABS(I-RESULT) +C +C RESABS - DOUBLE PRECISION +C APPROXIMATION TO THE INTEGRAL J +C +C RESASC - DOUBLE PRECISION +C APPROXIMATION TO THE INTEGRAL OF +C ABS((TRANSFORMED INTEGRAND)-I/(B-A)) OVER (A,B) +C +C***REFERENCES (NONE) +C***ROUTINES CALLED D1MACH +C***END PROLOGUE DQK15I +C + DOUBLE PRECISION A,ABSC,ABSC1,ABSC2,ABSERR,B,BOUN,CENTR,DABS,DINF, + * DMAX1,DMIN1,D1MACH,EPMACH,FC,FSUM,FVAL1,FVAL2,FV1,FV2,HLGTH, + * RESABS,RESASC,RESG,RESK,RESKH,RESULT,TABSC1,TABSC2,UFLOW,WG,WGK, + * XGK,FVALT + INTEGER INF,J + EXTERNAL F +C + DIMENSION FV1(7),FV2(7),XGK(8),WGK(8),WG(8) +C +C THE ABSCISSAE AND WEIGHTS ARE SUPPLIED FOR THE INTERVAL +C (-1,1). BECAUSE OF SYMMETRY ONLY THE POSITIVE ABSCISSAE AND +C THEIR CORRESPONDING WEIGHTS ARE GIVEN. +C +C XGK - ABSCISSAE OF THE 15-POINT KRONROD RULE +C XGK(2), XGK(4), ... ABSCISSAE OF THE 7-POINT +C GAUSS RULE +C XGK(1), XGK(3), ... ABSCISSAE WHICH ARE OPTIMALLY +C ADDED TO THE 7-POINT GAUSS RULE +C +C WGK - WEIGHTS OF THE 15-POINT KRONROD RULE +C +C WG - WEIGHTS OF THE 7-POINT GAUSS RULE, CORRESPONDING +C TO THE ABSCISSAE XGK(2), XGK(4), ... +C WG(1), WG(3), ... ARE SET TO ZERO. +C + DATA WG(1) / 0.0D0 / + DATA WG(2) / 0.1294849661 6886969327 0611432679 082D0 / + DATA WG(3) / 0.0D0 / + DATA WG(4) / 0.2797053914 8927666790 1467771423 780D0 / + DATA WG(5) / 0.0D0 / + DATA WG(6) / 0.3818300505 0511894495 0369775488 975D0 / + DATA WG(7) / 0.0D0 / + DATA WG(8) / 0.4179591836 7346938775 5102040816 327D0 / +C + DATA XGK(1) / 0.9914553711 2081263920 6854697526 329D0 / + DATA XGK(2) / 0.9491079123 4275852452 6189684047 851D0 / + DATA XGK(3) / 0.8648644233 5976907278 9712788640 926D0 / + DATA XGK(4) / 0.7415311855 9939443986 3864773280 788D0 / + DATA XGK(5) / 0.5860872354 6769113029 4144838258 730D0 / + DATA XGK(6) / 0.4058451513 7739716690 6606412076 961D0 / + DATA XGK(7) / 0.2077849550 0789846760 0689403773 245D0 / + DATA XGK(8) / 0.0000000000 0000000000 0000000000 000D0 / +C + DATA WGK(1) / 0.0229353220 1052922496 3732008058 970D0 / + DATA WGK(2) / 0.0630920926 2997855329 0700663189 204D0 / + DATA WGK(3) / 0.1047900103 2225018383 9876322541 518D0 / + DATA WGK(4) / 0.1406532597 1552591874 5189590510 238D0 / + DATA WGK(5) / 0.1690047266 3926790282 6583426598 550D0 / + DATA WGK(6) / 0.1903505780 6478540991 3256402421 014D0 / + DATA WGK(7) / 0.2044329400 7529889241 4161999234 649D0 / + DATA WGK(8) / 0.2094821410 8472782801 2999174891 714D0 / +C +C +C LIST OF MAJOR VARIABLES +C ----------------------- +C +C CENTR - MID POINT OF THE INTERVAL +C HLGTH - HALF-LENGTH OF THE INTERVAL +C ABSC* - ABSCISSA +C TABSC* - TRANSFORMED ABSCISSA +C FVAL* - FUNCTION VALUE +C RESG - RESULT OF THE 7-POINT GAUSS FORMULA +C RESK - RESULT OF THE 15-POINT KRONROD FORMULA +C RESKH - APPROXIMATION TO THE MEAN VALUE OF THE TRANSFORMED +C INTEGRAND OVER (A,B), I.E. TO I/(B-A) +C +C MACHINE DEPENDENT CONSTANTS +C --------------------------- +C +C EPMACH IS THE LARGEST RELATIVE SPACING. +C UFLOW IS THE SMALLEST POSITIVE MAGNITUDE. +C +C***FIRST EXECUTABLE STATEMENT DQK15I + EPMACH = D1MACH(4) + UFLOW = D1MACH(1) + DINF = MIN0(1,INF) +C + CENTR = 0.5D+00*(A+B) + HLGTH = 0.5D+00*(B-A) + TABSC1 = BOUN+DINF*(0.1D+01-CENTR)/CENTR + IERR = 0 + CALL F(TABSC1,IERR,FVAL1) + IF (IERR .LT. 0) RETURN + IF(INF.EQ.2) THEN + CALL F(-TABSC1,IERR,FVALT) + IF (IERR .LT. 0) RETURN + FVAL1 = FVAL1+FVALT + ENDIF + FC = (FVAL1/CENTR)/CENTR +C +C COMPUTE THE 15-POINT KRONROD APPROXIMATION TO +C THE INTEGRAL, AND ESTIMATE THE ERROR. +C + RESG = WG(8)*FC + RESK = WGK(8)*FC + RESABS = DABS(RESK) + DO 10 J=1,7 + ABSC = HLGTH*XGK(J) + ABSC1 = CENTR-ABSC + ABSC2 = CENTR+ABSC + TABSC1 = BOUN+DINF*(0.1D+01-ABSC1)/ABSC1 + TABSC2 = BOUN+DINF*(0.1D+01-ABSC2)/ABSC2 + CALL F(TABSC1,IERR,FVAL1) + IF (IERR .LT. 0) RETURN + CALL F(TABSC2,IERR,FVAL2) + IF (IERR .LT. 0) RETURN + IF(INF.EQ.2) THEN + CALL F(-TABSC1,IERR,FVALT) + IF (IERR .LT. 0) RETURN + FVAL1 = FVAL1+FVALT + ENDIF + IF(INF.EQ.2) THEN + CALL F(-TABSC2,IERR,FVALT) + IF (IERR .LT. 0) RETURN + FVAL2 = FVAL2+FVALT + ENDIF + FVAL1 = (FVAL1/ABSC1)/ABSC1 + FVAL2 = (FVAL2/ABSC2)/ABSC2 + FV1(J) = FVAL1 + FV2(J) = FVAL2 + FSUM = FVAL1+FVAL2 + RESG = RESG+WG(J)*FSUM + RESK = RESK+WGK(J)*FSUM + RESABS = RESABS+WGK(J)*(DABS(FVAL1)+DABS(FVAL2)) + 10 CONTINUE + RESKH = RESK*0.5D+00 + RESASC = WGK(8)*DABS(FC-RESKH) + DO 20 J=1,7 + RESASC = RESASC+WGK(J)*(DABS(FV1(J)-RESKH)+DABS(FV2(J)-RESKH)) + 20 CONTINUE + RESULT = RESK*HLGTH + RESASC = RESASC*HLGTH + RESABS = RESABS*HLGTH + ABSERR = DABS((RESK-RESG)*HLGTH) + IF(RESASC.NE.0.0D+00.AND.ABSERR.NE.0.D0) ABSERR = RESASC* + * DMIN1(0.1D+01,(0.2D+03*ABSERR/RESASC)**1.5D+00) + IF(RESABS.GT.UFLOW/(0.5D+02*EPMACH)) ABSERR = DMAX1 + * ((EPMACH*0.5D+02)*RESABS,ABSERR) + RETURN + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/quadpack/dqk21.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,187 @@ + SUBROUTINE DQK21(F,A,B,RESULT,ABSERR,RESABS,RESASC,IERR) +C***BEGIN PROLOGUE DQK21 +C***DATE WRITTEN 800101 (YYMMDD) +C***REVISION DATE 830518 (YYMMDD) +C***CATEGORY NO. H2A1A2 +C***KEYWORDS 21-POINT GAUSS-KRONROD RULES +C***AUTHOR PIESSENS,ROBERT,APPL. MATH. & PROGR. DIV. - K.U.LEUVEN +C DE DONCKER,ELISE,APPL. MATH. & PROGR. DIV. - K.U.LEUVEN +C***PURPOSE TO COMPUTE I = INTEGRAL OF F OVER (A,B), WITH ERROR +C ESTIMATE +C J = INTEGRAL OF ABS(F) OVER (A,B) +C***DESCRIPTION +C +C INTEGRATION RULES +C STANDARD FORTRAN SUBROUTINE +C DOUBLE PRECISION VERSION +C +C PARAMETERS +C ON ENTRY +C F - SUBROUTINE F(X,IERR,RESULT) DEFINING THE INTEGRAND +C FUNCTION F(X). THE ACTUAL NAME FOR F NEEDS TO BE +C DECLARED E X T E R N A L IN THE DRIVER PROGRAM. +C +C A - DOUBLE PRECISION +C LOWER LIMIT OF INTEGRATION +C +C B - DOUBLE PRECISION +C UPPER LIMIT OF INTEGRATION +C +C ON RETURN +C RESULT - DOUBLE PRECISION +C APPROXIMATION TO THE INTEGRAL I +C RESULT IS COMPUTED BY APPLYING THE 21-POINT +C KRONROD RULE (RESK) OBTAINED BY OPTIMAL ADDITION +C OF ABSCISSAE TO THE 10-POINT GAUSS RULE (RESG). +C +C ABSERR - DOUBLE PRECISION +C ESTIMATE OF THE MODULUS OF THE ABSOLUTE ERROR, +C WHICH SHOULD NOT EXCEED ABS(I-RESULT) +C +C RESABS - DOUBLE PRECISION +C APPROXIMATION TO THE INTEGRAL J +C +C RESASC - DOUBLE PRECISION +C APPROXIMATION TO THE INTEGRAL OF ABS(F-I/(B-A)) +C OVER (A,B) +C +C***REFERENCES (NONE) +C***ROUTINES CALLED D1MACH +C***END PROLOGUE DQK21 +C + DOUBLE PRECISION A,ABSC,ABSERR,B,CENTR,DABS,DHLGTH,DMAX1,DMIN1, + * D1MACH,EPMACH,FC,FSUM,FVAL1,FVAL2,FV1,FV2,HLGTH,RESABS,RESASC, + * RESG,RESK,RESKH,RESULT,UFLOW,WG,WGK,XGK + INTEGER J,JTW,JTWM1 + EXTERNAL F +C + DIMENSION FV1(10),FV2(10),WG(5),WGK(11),XGK(11) +C +C THE ABSCISSAE AND WEIGHTS ARE GIVEN FOR THE INTERVAL (-1,1). +C BECAUSE OF SYMMETRY ONLY THE POSITIVE ABSCISSAE AND THEIR +C CORRESPONDING WEIGHTS ARE GIVEN. +C +C XGK - ABSCISSAE OF THE 21-POINT KRONROD RULE +C XGK(2), XGK(4), ... ABSCISSAE OF THE 10-POINT +C GAUSS RULE +C XGK(1), XGK(3), ... ABSCISSAE WHICH ARE OPTIMALLY +C ADDED TO THE 10-POINT GAUSS RULE +C +C WGK - WEIGHTS OF THE 21-POINT KRONROD RULE +C +C WG - WEIGHTS OF THE 10-POINT GAUSS RULE +C +C +C GAUSS QUADRATURE WEIGHTS AND KRONRON QUADRATURE ABSCISSAE AND WEIGHTS +C AS EVALUATED WITH 80 DECIMAL DIGIT ARITHMETIC BY L. W. FULLERTON, +C BELL LABS, NOV. 1981. +C + DATA WG ( 1) / 0.0666713443 0868813759 3568809893 332 D0 / + DATA WG ( 2) / 0.1494513491 5058059314 5776339657 697 D0 / + DATA WG ( 3) / 0.2190863625 1598204399 5534934228 163 D0 / + DATA WG ( 4) / 0.2692667193 0999635509 1226921569 469 D0 / + DATA WG ( 5) / 0.2955242247 1475287017 3892994651 338 D0 / +C + DATA XGK ( 1) / 0.9956571630 2580808073 5527280689 003 D0 / + DATA XGK ( 2) / 0.9739065285 1717172007 7964012084 452 D0 / + DATA XGK ( 3) / 0.9301574913 5570822600 1207180059 508 D0 / + DATA XGK ( 4) / 0.8650633666 8898451073 2096688423 493 D0 / + DATA XGK ( 5) / 0.7808177265 8641689706 3717578345 042 D0 / + DATA XGK ( 6) / 0.6794095682 9902440623 4327365114 874 D0 / + DATA XGK ( 7) / 0.5627571346 6860468333 9000099272 694 D0 / + DATA XGK ( 8) / 0.4333953941 2924719079 9265943165 784 D0 / + DATA XGK ( 9) / 0.2943928627 0146019813 1126603103 866 D0 / + DATA XGK ( 10) / 0.1488743389 8163121088 4826001129 720 D0 / + DATA XGK ( 11) / 0.0000000000 0000000000 0000000000 000 D0 / +C + DATA WGK ( 1) / 0.0116946388 6737187427 8064396062 192 D0 / + DATA WGK ( 2) / 0.0325581623 0796472747 8818972459 390 D0 / + DATA WGK ( 3) / 0.0547558965 7435199603 1381300244 580 D0 / + DATA WGK ( 4) / 0.0750396748 1091995276 7043140916 190 D0 / + DATA WGK ( 5) / 0.0931254545 8369760553 5065465083 366 D0 / + DATA WGK ( 6) / 0.1093871588 0229764189 9210590325 805 D0 / + DATA WGK ( 7) / 0.1234919762 6206585107 7958109831 074 D0 / + DATA WGK ( 8) / 0.1347092173 1147332592 8054001771 707 D0 / + DATA WGK ( 9) / 0.1427759385 7706008079 7094273138 717 D0 / + DATA WGK ( 10) / 0.1477391049 0133849137 4841515972 068 D0 / + DATA WGK ( 11) / 0.1494455540 0291690566 4936468389 821 D0 / +C +C +C LIST OF MAJOR VARIABLES +C ----------------------- +C +C CENTR - MID POINT OF THE INTERVAL +C HLGTH - HALF-LENGTH OF THE INTERVAL +C ABSC - ABSCISSA +C FVAL* - FUNCTION VALUE +C RESG - RESULT OF THE 10-POINT GAUSS FORMULA +C RESK - RESULT OF THE 21-POINT KRONROD FORMULA +C RESKH - APPROXIMATION TO THE MEAN VALUE OF F OVER (A,B), +C I.E. TO I/(B-A) +C +C +C MACHINE DEPENDENT CONSTANTS +C --------------------------- +C +C EPMACH IS THE LARGEST RELATIVE SPACING. +C UFLOW IS THE SMALLEST POSITIVE MAGNITUDE. +C +C***FIRST EXECUTABLE STATEMENT DQK21 + EPMACH = D1MACH(4) + UFLOW = D1MACH(1) +C + CENTR = 0.5D+00*(A+B) + HLGTH = 0.5D+00*(B-A) + DHLGTH = DABS(HLGTH) +C +C COMPUTE THE 21-POINT KRONROD APPROXIMATION TO +C THE INTEGRAL, AND ESTIMATE THE ABSOLUTE ERROR. +C + RESG = 0.0D+00 + IERR = 0 + CALL F(CENTR,IERR,FC) + IF (IERR .LT. 0) RETURN + RESK = WGK(11)*FC + RESABS = DABS(RESK) + DO 10 J=1,5 + JTW = 2*J + ABSC = HLGTH*XGK(JTW) + CALL F(CENTR-ABSC,IERR,FVAL1) + IF (IERR .LT. 0) RETURN + CALL F(CENTR+ABSC,IERR,FVAL2) + IF (IERR .LT. 0) RETURN + FV1(JTW) = FVAL1 + FV2(JTW) = FVAL2 + FSUM = FVAL1+FVAL2 + RESG = RESG+WG(J)*FSUM + RESK = RESK+WGK(JTW)*FSUM + RESABS = RESABS+WGK(JTW)*(DABS(FVAL1)+DABS(FVAL2)) + 10 CONTINUE + DO 15 J = 1,5 + JTWM1 = 2*J-1 + ABSC = HLGTH*XGK(JTWM1) + CALL F(CENTR-ABSC,IERR,FVAL1) + IF (IERR .LT. 0) RETURN + CALL F(CENTR+ABSC,IERR,FVAL2) + IF (IERR .LT. 0) RETURN + FV1(JTWM1) = FVAL1 + FV2(JTWM1) = FVAL2 + FSUM = FVAL1+FVAL2 + RESK = RESK+WGK(JTWM1)*FSUM + RESABS = RESABS+WGK(JTWM1)*(DABS(FVAL1)+DABS(FVAL2)) + 15 CONTINUE + RESKH = RESK*0.5D+00 + RESASC = WGK(11)*DABS(FC-RESKH) + DO 20 J=1,10 + RESASC = RESASC+WGK(J)*(DABS(FV1(J)-RESKH)+DABS(FV2(J)-RESKH)) + 20 CONTINUE + RESULT = RESK*HLGTH + RESABS = RESABS*DHLGTH + RESASC = RESASC*DHLGTH + ABSERR = DABS((RESK-RESG)*HLGTH) + IF(RESASC.NE.0.0D+00.AND.ABSERR.NE.0.0D+00) + * ABSERR = RESASC*DMIN1(0.1D+01,(0.2D+03*ABSERR/RESASC)**1.5D+00) + IF(RESABS.GT.UFLOW/(0.5D+02*EPMACH)) ABSERR = DMAX1 + * ((EPMACH*0.5D+02)*RESABS,ABSERR) + RETURN + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/quadpack/dqpsrt.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,129 @@ + SUBROUTINE DQPSRT(LIMIT,LAST,MAXERR,ERMAX,ELIST,IORD,NRMAX) +C***BEGIN PROLOGUE DQPSRT +C***REFER TO DQAGE,DQAGIE,DQAGPE,DQAWSE +C***ROUTINES CALLED (NONE) +C***REVISION DATE 810101 (YYMMDD) +C***KEYWORDS SEQUENTIAL SORTING +C***AUTHOR PIESSENS,ROBERT,APPL. MATH. & PROGR. DIV. - K.U.LEUVEN +C DE DONCKER,ELISE,APPL. MATH. & PROGR. DIV. - K.U.LEUVEN +C***PURPOSE THIS ROUTINE MAINTAINS THE DESCENDING ORDERING IN THE +C LIST OF THE LOCAL ERROR ESTIMATED RESULTING FROM THE +C INTERVAL SUBDIVISION PROCESS. AT EACH CALL TWO ERROR +C ESTIMATES ARE INSERTED USING THE SEQUENTIAL SEARCH +C METHOD, TOP-DOWN FOR THE LARGEST ERROR ESTIMATE AND +C BOTTOM-UP FOR THE SMALLEST ERROR ESTIMATE. +C***DESCRIPTION +C +C ORDERING ROUTINE +C STANDARD FORTRAN SUBROUTINE +C DOUBLE PRECISION VERSION +C +C PARAMETERS (MEANING AT OUTPUT) +C LIMIT - INTEGER +C MAXIMUM NUMBER OF ERROR ESTIMATES THE LIST +C CAN CONTAIN +C +C LAST - INTEGER +C NUMBER OF ERROR ESTIMATES CURRENTLY IN THE LIST +C +C MAXERR - INTEGER +C MAXERR POINTS TO THE NRMAX-TH LARGEST ERROR +C ESTIMATE CURRENTLY IN THE LIST +C +C ERMAX - DOUBLE PRECISION +C NRMAX-TH LARGEST ERROR ESTIMATE +C ERMAX = ELIST(MAXERR) +C +C ELIST - DOUBLE PRECISION +C VECTOR OF DIMENSION LAST CONTAINING +C THE ERROR ESTIMATES +C +C IORD - INTEGER +C VECTOR OF DIMENSION LAST, THE FIRST K ELEMENTS +C OF WHICH CONTAIN POINTERS TO THE ERROR +C ESTIMATES, SUCH THAT +C ELIST(IORD(1)),..., ELIST(IORD(K)) +C FORM A DECREASING SEQUENCE, WITH +C K = LAST IF LAST.LE.(LIMIT/2+2), AND +C K = LIMIT+1-LAST OTHERWISE +C +C NRMAX - INTEGER +C MAXERR = IORD(NRMAX) +C +C***END PROLOGUE DQPSRT +C + DOUBLE PRECISION ELIST,ERMAX,ERRMAX,ERRMIN + INTEGER I,IBEG,IDO,IORD,ISUCC,J,JBND,JUPBN,K,LAST,LIMIT,MAXERR, + * NRMAX + DIMENSION ELIST(LAST),IORD(LAST) +C +C CHECK WHETHER THE LIST CONTAINS MORE THAN +C TWO ERROR ESTIMATES. +C +C***FIRST EXECUTABLE STATEMENT DQPSRT + IF(LAST.GT.2) GO TO 10 + IORD(1) = 1 + IORD(2) = 2 + GO TO 90 +C +C THIS PART OF THE ROUTINE IS ONLY EXECUTED IF, DUE TO A +C DIFFICULT INTEGRAND, SUBDIVISION INCREASED THE ERROR +C ESTIMATE. IN THE NORMAL CASE THE INSERT PROCEDURE SHOULD +C START AFTER THE NRMAX-TH LARGEST ERROR ESTIMATE. +C + 10 ERRMAX = ELIST(MAXERR) + IF(NRMAX.EQ.1) GO TO 30 + IDO = NRMAX-1 + DO 20 I = 1,IDO + ISUCC = IORD(NRMAX-1) +C ***JUMP OUT OF DO-LOOP + IF(ERRMAX.LE.ELIST(ISUCC)) GO TO 30 + IORD(NRMAX) = ISUCC + NRMAX = NRMAX-1 + 20 CONTINUE +C +C COMPUTE THE NUMBER OF ELEMENTS IN THE LIST TO BE MAINTAINED +C IN DESCENDING ORDER. THIS NUMBER DEPENDS ON THE NUMBER OF +C SUBDIVISIONS STILL ALLOWED. +C + 30 JUPBN = LAST + IF(LAST.GT.(LIMIT/2+2)) JUPBN = LIMIT+3-LAST + ERRMIN = ELIST(LAST) +C +C INSERT ERRMAX BY TRAVERSING THE LIST TOP-DOWN, +C STARTING COMPARISON FROM THE ELEMENT ELIST(IORD(NRMAX+1)). +C + JBND = JUPBN-1 + IBEG = NRMAX+1 + IF(IBEG.GT.JBND) GO TO 50 + DO 40 I=IBEG,JBND + ISUCC = IORD(I) +C ***JUMP OUT OF DO-LOOP + IF(ERRMAX.GE.ELIST(ISUCC)) GO TO 60 + IORD(I-1) = ISUCC + 40 CONTINUE + 50 IORD(JBND) = MAXERR + IORD(JUPBN) = LAST + GO TO 90 +C +C INSERT ERRMIN BY TRAVERSING THE LIST BOTTOM-UP. +C + 60 IORD(I-1) = MAXERR + K = JBND + DO 70 J=I,JBND + ISUCC = IORD(K) +C ***JUMP OUT OF DO-LOOP + IF(ERRMIN.LT.ELIST(ISUCC)) GO TO 80 + IORD(K+1) = ISUCC + K = K-1 + 70 CONTINUE + IORD(I) = LAST + GO TO 90 + 80 IORD(K+1) = LAST +C +C SET MAXERR AND ERMAX. +C + 90 MAXERR = IORD(NRMAX) + ERMAX = ELIST(MAXERR) + RETURN + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/quadpack/module.mk Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,18 @@ +EXTERNAL_SOURCES += \ + liboctave/external/quadpack/dqagi.f \ + liboctave/external/quadpack/dqagie.f \ + liboctave/external/quadpack/dqagp.f \ + liboctave/external/quadpack/dqagpe.f \ + liboctave/external/quadpack/dqelg.f \ + liboctave/external/quadpack/dqk15i.f \ + liboctave/external/quadpack/dqk21.f \ + liboctave/external/quadpack/dqpsrt.f \ + liboctave/external/quadpack/qagie.f \ + liboctave/external/quadpack/qagi.f \ + liboctave/external/quadpack/qagpe.f \ + liboctave/external/quadpack/qagp.f \ + liboctave/external/quadpack/qelg.f \ + liboctave/external/quadpack/qk15i.f \ + liboctave/external/quadpack/qk21.f \ + liboctave/external/quadpack/qpsrt.f \ + liboctave/external/quadpack/xerror.f
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/quadpack/qagi.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,190 @@ + subroutine qagi(f,bound,inf,epsabs,epsrel,result,abserr,neval, + * ier,limit,lenw,last,iwork,work) +c***begin prologue qagi +c***date written 800101 (yymmdd) +c***revision date 830518 (yymmdd) +c***category no. h2a3a1,h2a4a1 +c***keywords automatic integrator, infinite intervals, +c general-purpose, transformation, extrapolation, +c globally adaptive +c***author piessens,robert,appl. math. & progr. div. - k.u.leuven +c de doncker,elise,appl. math. & progr. div. -k.u.leuven +c***purpose the routine calculates an approximation result to a given +c integral i = integral of f over (bound,+infinity) +c or i = integral of f over (-infinity,bound) +c or i = integral of f over (-infinity,+infinity) +c hopefully satisfying following claim for accuracy +c abs(i-result).le.max(epsabs,epsrel*abs(i)). +c***description +c +c integration over infinite intervals +c standard fortran subroutine +c +c parameters +c on entry +c f - subroutine f(x,result) defining the integrand +c function f(x). the actual name for f needs to be +c declared e x t e r n a l in the driver program. +c +c bound - real +c finite bound of integration range +c (has no meaning if interval is doubly-infinite) +c +c inf - integer +c indicating the kind of integration range involved +c inf = 1 corresponds to (bound,+infinity), +c inf = -1 to (-infinity,bound), +c inf = 2 to (-infinity,+infinity). +c +c epsabs - real +c absolute accuracy requested +c epsrel - real +c relative accuracy requested +c if epsabs.le.0 +c and epsrel.lt.max(50*rel.mach.acc.,0.5d-28), +c the routine will end with ier = 6. +c +c +c on return +c result - real +c approximation to the integral +c +c abserr - real +c estimate of the modulus of the absolute error, +c which should equal or exceed abs(i-result) +c +c neval - integer +c number of integrand evaluations +c +c ier - integer +c ier = 0 normal and reliable termination of the +c routine. it is assumed that the requested +c accuracy has been achieved. +c - ier.gt.0 abnormal termination of the routine. the +c estimates for result and error are less +c reliable. it is assumed that the requested +c accuracy has not been achieved. +c error messages +c ier = 1 maximum number of subdivisions allowed +c has been achieved. one can allow more +c subdivisions by increasing the value of +c limit (and taking the according dimension +c adjustments into account). however, if +c this yields no improvement it is advised +c to analyze the integrand in order to +c determine the integration difficulties. if +c the position of a local difficulty can be +c determined (e.g. singularity, +c discontinuity within the interval) one +c will probably gain from splitting up the +c interval at this point and calling the +c integrator on the subranges. if possible, +c an appropriate special-purpose integrator +c should be used, which is designed for +c handling the type of difficulty involved. +c = 2 the occurrence of roundoff error is +c detected, which prevents the requested +c tolerance from being achieved. +c the error may be under-estimated. +c = 3 extremely bad integrand behaviour occurs +c at some points of the integration +c interval. +c = 4 the algorithm does not converge. +c roundoff error is detected in the +c extrapolation table. +c it is assumed that the requested tolerance +c cannot be achieved, and that the returned +c result is the best which can be obtained. +c = 5 the integral is probably divergent, or +c slowly convergent. it must be noted that +c divergence can occur with any other value +c of ier. +c = 6 the input is invalid, because +c (epsabs.le.0 and +c epsrel.lt.max(50*rel.mach.acc.,0.5d-28)) +c or limit.lt.1 or leniw.lt.limit*4. +c result, abserr, neval, last are set to +c zero. exept when limit or leniw is +c invalid, iwork(1), work(limit*2+1) and +c work(limit*3+1) are set to zero, work(1) +c is set to a and work(limit+1) to b. +c +c dimensioning parameters +c limit - integer +c dimensioning parameter for iwork +c limit determines the maximum number of subintervals +c in the partition of the given integration interval +c (a,b), limit.ge.1. +c if limit.lt.1, the routine will end with ier = 6. +c +c lenw - integer +c dimensioning parameter for work +c lenw must be at least limit*4. +c if lenw.lt.limit*4, the routine will end +c with ier = 6. +c +c last - integer +c on return, last equals the number of subintervals +c produced in the subdivision process, which +c determines the number of significant elements +c actually in the work arrays. +c +c work arrays +c iwork - integer +c vector of dimension at least limit, the first +c k elements of which contain pointers +c to the error estimates over the subintervals, +c such that work(limit*3+iwork(1)),... , +c work(limit*3+iwork(k)) form a decreasing +c sequence, with k = last if last.le.(limit/2+2), and +c k = limit+1-last otherwise +c +c work - real +c vector of dimension at least lenw +c on return +c work(1), ..., work(last) contain the left +c end points of the subintervals in the +c partition of (a,b), +c work(limit+1), ..., work(limit+last) contain +c the right end points, +c work(limit*2+1), ...,work(limit*2+last) contain the +c integral approximations over the subintervals, +c work(limit*3+1), ..., work(limit*3) +c contain the error estimates. +c***references (none) +c***routines called qagie,xerror +c***end prologue qagi +c + real abserr, epsabs,epsrel,result,work + integer ier,iwork, lenw,limit,lvl,l1,l2,l3,neval +c + dimension iwork(limit),work(lenw) +c + external f +c +c check validity of limit and lenw. +c +c***first executable statement qagi + ier = 6 + neval = 0 + last = 0 + result = 0.0e+00 + abserr = 0.0e+00 + if(limit.lt.1.or.lenw.lt.limit*4) go to 10 +c +c prepare call for qagie. +c + l1 = limit+1 + l2 = limit+l1 + l3 = limit+l2 +c + call qagie(f,bound,inf,epsabs,epsrel,limit,result,abserr, + * neval,ier,work(1),work(l1),work(l2),work(l3),iwork,last) +c +c call error handler if necessary. +c + lvl = 0 +10 if(ier.eq.6) lvl = 1 + if(ier.ne.0) call xerror('abnormal return from qagi',26,ier,lvl) + return + end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/quadpack/qagie.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,460 @@ + subroutine qagie(f,bound,inf,epsabs,epsrel,limit,result,abserr, + * neval,ier,alist,blist,rlist,elist,iord,last) +c***begin prologue qagie +c***date written 800101 (yymmdd) +c***revision date 830518 (yymmdd) +c***category no. h2a3a1,h2a4a1 +c***keywords automatic integrator, infinite intervals, +c general-purpose, transformation, extrapolation, +c globally adaptive +c***author piessens,robert,appl. math & progr. div - k.u.leuven +c de doncker,elise,appl. math & progr. div - k.u.leuven +c***purpose the routine calculates an approximation result to a given +c integral i = integral of f over (bound,+infinity) +c or i = integral of f over (-infinity,bound) +c or i = integral of f over (-infinity,+infinity), +c hopefully satisfying following claim for accuracy +c abs(i-result).le.max(epsabs,epsrel*abs(i)) +c***description +c +c integration over infinite intervals +c standard fortran subroutine +c +c f - subroutine f(x,ierr,result) defining the integrand +c function f(x). the actual name for f needs to be +c declared e x t e r n a l in the driver program. +c +c bound - real +c finite bound of integration range +c (has no meaning if interval is doubly-infinite) +c +c inf - real +c indicating the kind of integration range involved +c inf = 1 corresponds to (bound,+infinity), +c inf = -1 to (-infinity,bound), +c inf = 2 to (-infinity,+infinity). +c +c epsabs - real +c absolute accuracy requested +c epsrel - real +c relative accuracy requested +c if epsabs.le.0 +c and epsrel.lt.max(50*rel.mach.acc.,0.5d-28), +c the routine will end with ier = 6. +c +c limit - integer +c gives an upper bound on the number of subintervals +c in the partition of (a,b), limit.ge.1 +c +c on return +c result - real +c approximation to the integral +c +c abserr - real +c estimate of the modulus of the absolute error, +c which should equal or exceed abs(i-result) +c +c neval - integer +c number of integrand evaluations +c +c ier - integer +c ier = 0 normal and reliable termination of the +c routine. it is assumed that the requested +c accuracy has been achieved. +c - ier.gt.0 abnormal termination of the routine. the +c estimates for result and error are less +c reliable. it is assumed that the requested +c accuracy has not been achieved. +c error messages +c ier = 1 maximum number of subdivisions allowed +c has been achieved. one can allow more +c subdivisions by increasing the value of +c limit (and taking the according dimension +c adjustments into account). however,if +c this yields no improvement it is advised +c to analyze the integrand in order to +c determine the integration difficulties. +c if the position of a local difficulty can +c be determined (e.g. singularity, +c discontinuity within the interval) one +c will probably gain from splitting up the +c interval at this point and calling the +c integrator on the subranges. if possible, +c an appropriate special-purpose integrator +c should be used, which is designed for +c handling the type of difficulty involved. +c = 2 the occurrence of roundoff error is +c detected, which prevents the requested +c tolerance from being achieved. +c the error may be under-estimated. +c = 3 extremely bad integrand behaviour occurs +c at some points of the integration +c interval. +c = 4 the algorithm does not converge. +c roundoff error is detected in the +c extrapolation table. +c it is assumed that the requested tolerance +c cannot be achieved, and that the returned +c result is the best which can be obtained. +c = 5 the integral is probably divergent, or +c slowly convergent. it must be noted that +c divergence can occur with any other value +c of ier. +c = 6 the input is invalid, because +c (epsabs.le.0 and +c epsrel.lt.max(50*rel.mach.acc.,0.5d-28), +c result, abserr, neval, last, rlist(1), +c elist(1) and iord(1) are set to zero. +c alist(1) and blist(1) are set to 0 +c and 1 respectively. +c +c alist - real +c vector of dimension at least limit, the first +c last elements of which are the left +c end points of the subintervals in the partition +c of the transformed integration range (0,1). +c +c blist - real +c vector of dimension at least limit, the first +c last elements of which are the right +c end points of the subintervals in the partition +c of the transformed integration range (0,1). +c +c rlist - real +c vector of dimension at least limit, the first +c last elements of which are the integral +c approximations on the subintervals +c +c elist - real +c vector of dimension at least limit, the first +c last elements of which are the moduli of the +c absolute error estimates on the subintervals +c +c iord - integer +c vector of dimension limit, the first k +c elements of which are pointers to the +c error estimates over the subintervals, +c such that elist(iord(1)), ..., elist(iord(k)) +c form a decreasing sequence, with k = last +c if last.le.(limit/2+2), and k = limit+1-last +c otherwise +c +c last - integer +c number of subintervals actually produced +c in the subdivision process +c +c***references (none) +c***routines called qelg,qk15i,qpsrt,r1mach +c***end prologue qagie +c + real abseps,abserr,alist,area,area1,area12,area2,a1, + * a2,blist,boun,bound,b1,b2,correc,defabs,defab1,defab2, + * dres,r1mach,elist,epmach,epsabs,epsrel,erlarg,erlast, + * errbnd,errmax,error1,error2,erro12,errsum,ertest,oflow,resabs, + * reseps,result,res3la,rlist,rlist2,small,uflow + integer id,ier,ierro,inf,iord,iroff1,iroff2,iroff3,jupbnd,k,ksgn, + * ktmin,last,limit,maxerr,neval,nres,nrmax,numrl2 + logical extrap,noext +c + dimension alist(limit),blist(limit),elist(limit),iord(limit), + * res3la(3),rlist(limit),rlist2(52) +c + external f +c +c the dimension of rlist2 is determined by the value of +c limexp in subroutine qelg. +c +c +c list of major variables +c ----------------------- +c +c alist - list of left end points of all subintervals +c considered up to now +c blist - list of right end points of all subintervals +c considered up to now +c rlist(i) - approximation to the integral over +c (alist(i),blist(i)) +c rlist2 - array of dimension at least (limexp+2), +c containing the part of the epsilon table +c wich is still needed for further computations +c elist(i) - error estimate applying to rlist(i) +c maxerr - pointer to the interval with largest error +c estimate +c errmax - elist(maxerr) +c erlast - error on the interval currently subdivided +c (before that subdivision has taken place) +c area - sum of the integrals over the subintervals +c errsum - sum of the errors over the subintervals +c errbnd - requested accuracy max(epsabs,epsrel* +c abs(result)) +c *****1 - variable for the left subinterval +c *****2 - variable for the right subinterval +c last - index for subdivision +c nres - number of calls to the extrapolation routine +c numrl2 - number of elements currently in rlist2. if an +c appropriate approximation to the compounded +c integral has been obtained, it is put in +c rlist2(numrl2) after numrl2 has been increased +c by one. +c small - length of the smallest interval considered up +c to now, multiplied by 1.5 +c erlarg - sum of the errors over the intervals larger +c than the smallest interval considered up to now +c extrap - logical variable denoting that the routine +c is attempting to perform extrapolation. i.e. +c before subdividing the smallest interval we +c try to decrease the value of erlarg. +c noext - logical variable denoting that extrapolation +c is no longer allowed (true-value) +c +c machine dependent constants +c --------------------------- +c +c epmach is the largest relative spacing. +c uflow is the smallest positive magnitude. +c oflow is the largest positive magnitude. +c + epmach = r1mach(4) +c +c test on validity of parameters +c ----------------------------- +c +c***first executable statement qagie + ier = 0 + neval = 0 + last = 0 + result = 0.0e+00 + abserr = 0.0e+00 + alist(1) = 0.0e+00 + blist(1) = 0.1e+01 + rlist(1) = 0.0e+00 + elist(1) = 0.0e+00 + iord(1) = 0 + if(epsabs.le.0.0e+00.and.epsrel.lt.amax1(0.5e+02*epmach,0.5e-14)) + * ier = 6 + if(ier.eq.6) go to 999 +c +c +c first approximation to the integral +c ----------------------------------- +c +c determine the interval to be mapped onto (0,1). +c if inf = 2 the integral is computed as i = i1+i2, where +c i1 = integral of f over (-infinity,0), +c i2 = integral of f over (0,+infinity). +c + boun = bound + if(inf.eq.2) boun = 0.0e+00 + call qk15i(f,boun,inf,0.0e+00,0.1e+01,result,abserr, + * defabs,resabs,ier) + if (ier.lt.0) return +c +c test on accuracy +c + last = 1 + rlist(1) = result + elist(1) = abserr + iord(1) = 1 + dres = abs(result) + errbnd = amax1(epsabs,epsrel*dres) + if(abserr.le.1.0e+02*epmach*defabs.and.abserr.gt. + * errbnd) ier = 2 + if(limit.eq.1) ier = 1 + if(ier.ne.0.or.(abserr.le.errbnd.and.abserr.ne.resabs).or. + * abserr.eq.0.0e+00) go to 130 +c +c initialization +c -------------- +c + uflow = r1mach(1) + oflow = r1mach(2) + rlist2(1) = result + errmax = abserr + maxerr = 1 + area = result + errsum = abserr + abserr = oflow + nrmax = 1 + nres = 0 + ktmin = 0 + numrl2 = 2 + extrap = .false. + noext = .false. + ierro = 0 + iroff1 = 0 + iroff2 = 0 + iroff3 = 0 + ksgn = -1 + if(dres.ge.(0.1e+01-0.5e+02*epmach)*defabs) ksgn = 1 +c +c main do-loop +c ------------ +c + do 90 last = 2,limit +c +c bisect the subinterval with nrmax-th largest +c error estimate. +c + a1 = alist(maxerr) + b1 = 0.5e+00*(alist(maxerr)+blist(maxerr)) + a2 = b1 + b2 = blist(maxerr) + erlast = errmax + call qk15i(f,boun,inf,a1,b1,area1,error1,resabs,defab1,ier) + if (ier.lt.0) return + call qk15i(f,boun,inf,a2,b2,area2,error2,resabs,defab2,ier) + if (ier.lt.0) return +c +c improve previous approximations to integral +c and error and test for accuracy. +c + area12 = area1+area2 + erro12 = error1+error2 + errsum = errsum+erro12-errmax + area = area+area12-rlist(maxerr) + if(defab1.eq.error1.or.defab2.eq.error2)go to 15 + if(abs(rlist(maxerr)-area12).gt.0.1e-04*abs(area12) + * .or.erro12.lt.0.99e+00*errmax) go to 10 + if(extrap) iroff2 = iroff2+1 + if(.not.extrap) iroff1 = iroff1+1 + 10 if(last.gt.10.and.erro12.gt.errmax) iroff3 = iroff3+1 + 15 rlist(maxerr) = area1 + rlist(last) = area2 + errbnd = amax1(epsabs,epsrel*abs(area)) +c +c test for roundoff error and eventually +c set error flag. +c + if(iroff1+iroff2.ge.10.or.iroff3.ge.20) ier = 2 + if(iroff2.ge.5) ierro = 3 +c +c set error flag in the case that the number of +c subintervals equals limit. +c + if(last.eq.limit) ier = 1 +c +c set error flag in the case of bad integrand behaviour +c at some points of the integration range. +c + if(amax1(abs(a1),abs(b2)).le.(0.1e+01+0.1e+03*epmach)* + * (abs(a2)+0.1e+04*uflow)) ier = 4 +c +c append the newly-created intervals to the list. +c + if(error2.gt.error1) go to 20 + alist(last) = a2 + blist(maxerr) = b1 + blist(last) = b2 + elist(maxerr) = error1 + elist(last) = error2 + go to 30 + 20 alist(maxerr) = a2 + alist(last) = a1 + blist(last) = b1 + rlist(maxerr) = area2 + rlist(last) = area1 + elist(maxerr) = error2 + elist(last) = error1 +c +c call subroutine qpsrt to maintain the descending ordering +c in the list of error estimates and select the +c subinterval with nrmax-th largest error estimate (to be +c bisected next). +c + 30 call qpsrt(limit,last,maxerr,errmax,elist,iord,nrmax) + if(errsum.le.errbnd) go to 115 + if(ier.ne.0) go to 100 + if(last.eq.2) go to 80 + if(noext) go to 90 + erlarg = erlarg-erlast + if(abs(b1-a1).gt.small) erlarg = erlarg+erro12 + if(extrap) go to 40 +c +c test whether the interval to be bisected next is the +c smallest interval. +c + if(abs(blist(maxerr)-alist(maxerr)).gt.small) go to 90 + extrap = .true. + nrmax = 2 + 40 if(ierro.eq.3.or.erlarg.le.ertest) go to 60 +c +c the smallest interval has the largest error. +c before bisecting decrease the sum of the errors +c over the larger intervals (erlarg) and perform +c extrapolation. +c + id = nrmax + jupbnd = last + if(last.gt.(2+limit/2)) jupbnd = limit+3-last + do 50 k = id,jupbnd + maxerr = iord(nrmax) + errmax = elist(maxerr) + if(abs(blist(maxerr)-alist(maxerr)).gt.small) go to 90 + nrmax = nrmax+1 + 50 continue +c +c perform extrapolation. +c + 60 numrl2 = numrl2+1 + rlist2(numrl2) = area + call qelg(numrl2,rlist2,reseps,abseps,res3la,nres) + ktmin = ktmin+1 + if(ktmin.gt.5.and.abserr.lt.0.1e-02*errsum) ier = 5 + if(abseps.ge.abserr) go to 70 + ktmin = 0 + abserr = abseps + result = reseps + correc = erlarg + ertest = amax1(epsabs,epsrel*abs(reseps)) + if(abserr.le.ertest) go to 100 +c +c prepare bisection of the smallest interval. +c + 70 if(numrl2.eq.1) noext = .true. + if(ier.eq.5) go to 100 + maxerr = iord(1) + errmax = elist(maxerr) + nrmax = 1 + extrap = .false. + small = small*0.5e+00 + erlarg = errsum + go to 90 + 80 small = 0.375e+00 + erlarg = errsum + ertest = errbnd + rlist2(2) = area + 90 continue +c +c set final result and error estimate. +c ------------------------------------ +c + 100 if(abserr.eq.oflow) go to 115 + if((ier+ierro).eq.0) go to 110 + if(ierro.eq.3) abserr = abserr+correc + if(ier.eq.0) ier = 3 + if(result.ne.0.0e+00.and.area.ne.0.0e+00)go to 105 + if(abserr.gt.errsum)go to 115 + if(area.eq.0.0e+00) go to 130 + go to 110 + 105 if(abserr/abs(result).gt.errsum/abs(area))go to 115 +c +c test on divergence +c + 110 if(ksgn.eq.(-1).and.amax1(abs(result),abs(area)).le. + * defabs*0.1e-01) go to 130 + if(0.1e-01.gt.(result/area).or.(result/area).gt.0.1e+03. + *or.errsum.gt.abs(area)) ier = 6 + go to 130 +c +c compute global integral sum. +c + 115 result = 0.0e+00 + do 120 k = 1,last + result = result+rlist(k) + 120 continue + abserr = errsum + 130 neval = 30*last-15 + if(inf.eq.2) neval = 2*neval + if(ier.gt.2) ier=ier-1 + 999 return + end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/quadpack/qagp.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,223 @@ + subroutine qagp(f,a,b,npts2,points,epsabs,epsrel,result,abserr, + * neval,ier,leniw,lenw,last,iwork,work) +c***begin prologue qagp +c***date written 800101 (yymmdd) +c***revision date 830518 (yymmdd) +c***category no. h2a2a1 +c***keywords automatic integrator, general-purpose, +c singularities at user specified points, +c extrapolation, globally adaptive +c***author piessens,robert,appl. math. & progr. div - k.u.leuven +c de doncker,elise,appl. math. & progr. div. - k.u.leuven +c***purpose the routine calculates an approximation result to a given +c definite integral i = integral of f over (a,b), +c hopefully satisfying following claim for accuracy +c break points of the integration interval, where local +c difficulties of the integrand may occur(e.g. singularities, +c discontinuities), are provided by the user. +c***description +c +c computation of a definite integral +c standard fortran subroutine +c real version +c +c parameters +c on entry +c f - subroutine f(x,ierr,result) defining the integrand +c function f(x). the actual name for f needs to be +c declared e x t e r n a l in the driver program. +c +c a - real +c lower limit of integration +c +c b - real +c upper limit of integration +c +c npts2 - integer +c number equal to two more than the number of +c user-supplied break points within the integration +c range, npts.ge.2. +c if npts2.lt.2, the routine will end with ier = 6. +c +c points - real +c vector of dimension npts2, the first (npts2-2) +c elements of which are the user provided break +c points. if these points do not constitute an +c ascending sequence there will be an automatic +c sorting. +c +c epsabs - real +c absolute accuracy requested +c epsrel - real +c relative accuracy requested +c if epsabs.le.0 +c and epsrel.lt.max(50*rel.mach.acc.,0.5d-28), +c the routine will end with ier = 6. +c +c on return +c result - real +c approximation to the integral +c +c abserr - real +c estimate of the modulus of the absolute error, +c which should equal or exceed abs(i-result) +c +c neval - integer +c number of integrand evaluations +c +c ier - integer +c ier = 0 normal and reliable termination of the +c routine. it is assumed that the requested +c accuracy has been achieved. +c ier.gt.0 abnormal termination of the routine. +c the estimates for integral and error are +c less reliable. it is assumed that the +c requested accuracy has not been achieved. +c error messages +c ier = 1 maximum number of subdivisions allowed +c has been achieved. one can allow more +c subdivisions by increasing the value of +c limit (and taking the according dimension +c adjustments into account). however, if +c this yields no improvement it is advised +c to analyze the integrand in order to +c determine the integration difficulties. if +c the position of a local difficulty can be +c determined (i.e. singularity, +c discontinuity within the interval), it +c should be supplied to the routine as an +c element of the vector points. if necessary +c an appropriate special-purpose integrator +c must be used, which is designed for +c handling the type of difficulty involved. +c = 2 the occurrence of roundoff error is +c detected, which prevents the requested +c tolerance from being achieved. +c the error may be under-estimated. +c = 3 extremely bad integrand behaviour occurs +c at some points of the integration +c interval. +c = 4 the algorithm does not converge. +c roundoff error is detected in the +c extrapolation table. +c it is presumed that the requested +c tolerance cannot be achieved, and that +c the returned result is the best which +c can be obtained. +c = 5 the integral is probably divergent, or +c slowly convergent. it must be noted that +c divergence can occur with any other value +c of ier.gt.0. +c = 6 the input is invalid because +c npts2.lt.2 or +c break points are specified outside +c the integration range or +c (epsabs.le.0 and +c epsrel.lt.max(50*rel.mach.acc.,0.5d-28)) +c result, abserr, neval, last are set to +c zero. exept when leniw or lenw or npts2 is +c invalid, iwork(1), iwork(limit+1), +c work(limit*2+1) and work(limit*3+1) +c are set to zero. +c work(1) is set to a and work(limit+1) +c to b (where limit = (leniw-npts2)/2). +c +c dimensioning parameters +c leniw - integer +c dimensioning parameter for iwork +c leniw determines limit = (leniw-npts2)/2, +c which is the maximum number of subintervals in the +c partition of the given integration interval (a,b), +c leniw.ge.(3*npts2-2). +c if leniw.lt.(3*npts2-2), the routine will end with +c ier = 6. +c +c lenw - integer +c dimensioning parameter for work +c lenw must be at least leniw*2-npts2. +c if lenw.lt.leniw*2-npts2, the routine will end +c with ier = 6. +c +c last - integer +c on return, last equals the number of subintervals +c produced in the subdivision process, which +c determines the number of significant elements +c actually in the work arrays. +c +c work arrays +c iwork - integer +c vector of dimension at least leniw. on return, +c the first k elements of which contain +c pointers to the error estimates over the +c subintervals, such that work(limit*3+iwork(1)),..., +c work(limit*3+iwork(k)) form a decreasing +c sequence, with k = last if last.le.(limit/2+2), and +c k = limit+1-last otherwise +c iwork(limit+1), ...,iwork(limit+last) contain the +c subdivision levels of the subintervals, i.e. +c if (aa,bb) is a subinterval of (p1,p2) +c where p1 as well as p2 is a user-provided +c break point or integration limit, then (aa,bb) has +c level l if abs(bb-aa) = abs(p2-p1)*2**(-l), +c iwork(limit*2+1), ..., iwork(limit*2+npts2) have +c no significance for the user, +c note that limit = (leniw-npts2)/2. +c +c work - real +c vector of dimension at least lenw +c on return +c work(1), ..., work(last) contain the left +c end points of the subintervals in the +c partition of (a,b), +c work(limit+1), ..., work(limit+last) contain +c the right end points, +c work(limit*2+1), ..., work(limit*2+last) contain +c the integral approximations over the subintervals, +c work(limit*3+1), ..., work(limit*3+last) +c contain the corresponding error estimates, +c work(limit*4+1), ..., work(limit*4+npts2) +c contain the integration limits and the +c break points sorted in an ascending sequence. +c note that limit = (leniw-npts2)/2. +c +c***references (none) +c***routines called qagpe,xerror +c***end prologue qagp +c + real a,abserr,b,epsabs,epsrel,points,result,work + integer ier,iwork,leniw,lenw,limit,lvl,l1,l2,l3,neval,npts2 +c + dimension iwork(leniw),points(npts2),work(lenw) +c + external f +c +c check validity of limit and lenw. +c +c***first executable statement qagp + ier = 6 + neval = 0 + last = 0 + result = 0.0e+00 + abserr = 0.0e+00 + if(leniw.lt.(3*npts2-2).or.lenw.lt.(leniw*2-npts2).or.npts2.lt.2) + * go to 10 +c +c prepare call for qagpe. +c + limit = (leniw-npts2)/2 + l1 = limit+1 + l2 = limit+l1 + l3 = limit+l2 + l4 = limit+l3 +c + call qagpe(f,a,b,npts2,points,epsabs,epsrel,limit,result,abserr, + * neval,ier,work(1),work(l1),work(l2),work(l3),work(l4), + * iwork(1),iwork(l1),iwork(l2),last) +c +c call error handler if necessary. +c + lvl = 0 +10 if(ier.eq.6) lvl = 1 + if(ier.ne.0) call xerror('abnormal return from qagp',26,ier,lvl) + return + end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/quadpack/qagpe.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,560 @@ + subroutine qagpe(f,a,b,npts2,points,epsabs,epsrel,limit,result, + * abserr,neval,ier,alist,blist,rlist,elist,pts,iord,level,ndin, + * last) +c***begin prologue qagpe +c***date written 800101 (yymmdd) +c***revision date 830518 (yymmdd) +c***category no. h2a2a1 +c***keywords automatic integrator, general-purpose, +c singularities at user specified points, +c extrapolation, globally adaptive. +c***author piessens,robert ,appl. math. & progr. div. - k.u.leuven +c de doncker,elise,appl. math. & progr. div. - k.u.leuven +c***purpose the routine calculates an approximation result to a given +c definite integral i = integral of f over (a,b),hopefully +c satisfying following claim for accuracy abs(i-result).le. +c max(epsabs,epsrel*abs(i)). break points of the integration +c interval, where local difficulties of the integrand may +c occur(e.g. singularities,discontinuities),provided by user. +c***description +c +c computation of a definite integral +c standard fortran subroutine +c real version +c +c parameters +c on entry +c f - subroutine f(x,ierr,result) defining the integrand +c function f(x). the actual name for f needs to be +c declared e x t e r n a l in the driver program. +c +c a - real +c lower limit of integration +c +c b - real +c upper limit of integration +c +c npts2 - integer +c number equal to two more than the number of +c user-supplied break points within the integration +c range, npts2.ge.2. +c if npts2.lt.2, the routine will end with ier = 6. +c +c points - real +c vector of dimension npts2, the first (npts2-2) +c elements of which are the user provided break +c points. if these points do not constitute an +c ascending sequence there will be an automatic +c sorting. +c +c epsabs - real +c absolute accuracy requested +c epsrel - real +c relative accuracy requested +c if epsabs.le.0 +c and epsrel.lt.max(50*rel.mach.acc.,0.5d-28), +c the routine will end with ier = 6. +c +c limit - integer +c gives an upper bound on the number of subintervals +c in the partition of (a,b), limit.ge.npts2 +c if limit.lt.npts2, the routine will end with +c ier = 6. +c +c on return +c result - real +c approximation to the integral +c +c abserr - real +c estimate of the modulus of the absolute error, +c which should equal or exceed abs(i-result) +c +c neval - integer +c number of integrand evaluations +c +c ier - integer +c ier = 0 normal and reliable termination of the +c routine. it is assumed that the requested +c accuracy has been achieved. +c ier.gt.0 abnormal termination of the routine. +c the estimates for integral and error are +c less reliable. it is assumed that the +c requested accuracy has not been achieved. +c error messages +c ier = 1 maximum number of subdivisions allowed +c has been achieved. one can allow more +c subdivisions by increasing the value of +c limit (and taking the according dimension +c adjustments into account). however, if +c this yields no improvement it is advised +c to analyze the integrand in order to +c determine the integration difficulties. if +c the position of a local difficulty can be +c determined (i.e. singularity, +c discontinuity within the interval), it +c should be supplied to the routine as an +c element of the vector points. if necessary +c an appropriate special-purpose integrator +c must be used, which is designed for +c handling the type of difficulty involved. +c = 2 the occurrence of roundoff error is +c detected, which prevents the requested +c tolerance from being achieved. +c the error may be under-estimated. +c = 3 extremely bad integrand behaviour occurs +c at some points of the integration +c interval. +c = 4 the algorithm does not converge. +c roundoff error is detected in the +c extrapolation table. it is presumed that +c the requested tolerance cannot be +c achieved, and that the returned result is +c the best which can be obtained. +c = 5 the integral is probably divergent, or +c slowly convergent. it must be noted that +c divergence can occur with any other value +c of ier.gt.0. +c = 6 the input is invalid because +c npts2.lt.2 or +c break points are specified outside +c the integration range or +c (epsabs.le.0 and +c epsrel.lt.max(50*rel.mach.acc.,0.5d-28)) +c or limit.lt.npts2. +c result, abserr, neval, last, rlist(1), +c and elist(1) are set to zero. alist(1) and +c blist(1) are set to a and b respectively. +c +c alist - real +c vector of dimension at least limit, the first +c last elements of which are the left end points +c of the subintervals in the partition of the given +c integration range (a,b) +c +c blist - real +c vector of dimension at least limit, the first +c last elements of which are the right end points +c of the subintervals in the partition of the given +c integration range (a,b) +c +c rlist - real +c vector of dimension at least limit, the first +c last elements of which are the integral +c approximations on the subintervals +c +c elist - real +c vector of dimension at least limit, the first +c last elements of which are the moduli of the +c absolute error estimates on the subintervals +c +c pts - real +c vector of dimension at least npts2, containing the +c integration limits and the break points of the +c interval in ascending sequence. +c +c level - integer +c vector of dimension at least limit, containing the +c subdivision levels of the subinterval, i.e. if +c (aa,bb) is a subinterval of (p1,p2) where p1 as +c well as p2 is a user-provided break point or +c integration limit, then (aa,bb) has level l if +c abs(bb-aa) = abs(p2-p1)*2**(-l). +c +c ndin - integer +c vector of dimension at least npts2, after first +c integration over the intervals (pts(i)),pts(i+1), +c i = 0,1, ..., npts2-2, the error estimates over +c some of the intervals may have been increased +c artificially, in order to put their subdivision +c forward. if this happens for the subinterval +c numbered k, ndin(k) is put to 1, otherwise +c ndin(k) = 0. +c +c iord - integer +c vector of dimension at least limit, the first k +c elements of which are pointers to the +c error estimates over the subintervals, +c such that elist(iord(1)), ..., elist(iord(k)) +c form a decreasing sequence, with k = last +c if last.le.(limit/2+2), and k = limit+1-last +c otherwise +c +c last - integer +c number of subintervals actually produced in the +c subdivisions process +c +c***references (none) +c***routines called qelg,qk21,qpsrt,r1mach +c***end prologue qagpe + real a,abseps,abserr,alist,area,area1,area12,area2,a1, + * a2,b,blist,b1,b2,correc,defabs,defab1,defab2, + * dres,r1mach,elist,epmach,epsabs,epsrel,erlarg,erlast,errbnd, + * errmax,error1,erro12,error2,errsum,ertest,oflow,points,pts, + * resa,resabs,reseps,result,res3la,rlist,rlist2,sign,temp, + * uflow + integer i,id,ier,ierro,ind1,ind2,iord,ip1,iroff1,iroff2, + * iroff3,j,jlow,jupbnd,k,ksgn,ktmin,last,levcur,level,levmax, + * limit,maxerr,ndin,neval,nint,nintp1,npts,npts2,nres, + * nrmax,numrl2 + logical extrap,noext +c +c + dimension alist(limit),blist(limit),elist(limit),iord(limit), + * level(limit),ndin(npts2),points(npts2),pts(npts2),res3la(3), + * rlist(limit),rlist2(52) +c + external f +c +c the dimension of rlist2 is determined by the value of +c limexp in subroutine epsalg (rlist2 should be of dimension +c (limexp+2) at least). +c +c +c list of major variables +c ----------------------- +c +c alist - list of left end points of all subintervals +c considered up to now +c blist - list of right end points of all subintervals +c considered up to now +c rlist(i) - approximation to the integral over +c (alist(i),blist(i)) +c rlist2 - array of dimension at least limexp+2 +c containing the part of the epsilon table which +c is still needed for further computations +c elist(i) - error estimate applying to rlist(i) +c maxerr - pointer to the interval with largest error +c estimate +c errmax - elist(maxerr) +c erlast - error on the interval currently subdivided +c (before that subdivision has taken place) +c area - sum of the integrals over the subintervals +c errsum - sum of the errors over the subintervals +c errbnd - requested accuracy max(epsabs,epsrel* +c abs(result)) +c *****1 - variable for the left subinterval +c *****2 - variable for the right subinterval +c last - index for subdivision +c nres - number of calls to the extrapolation routine +c numrl2 - number of elements in rlist2. if an +c appropriate approximation to the compounded +c integral has been obtained, it is put in +c rlist2(numrl2) after numrl2 has been increased +c by one. +c erlarg - sum of the errors over the intervals larger +c than the smallest interval considered up to now +c extrap - logical variable denoting that the routine +c is attempting to perform extrapolation. i.e. +c before subdividing the smallest interval we +c try to decrease the value of erlarg. +c noext - logical variable denoting that extrapolation is +c no longer allowed (true-value) +c +c machine dependent constants +c --------------------------- +c +c epmach is the largest relative spacing. +c uflow is the smallest positive magnitude. +c oflow is the largest positive magnitude. +c +c***first executable statement qagpe + epmach = r1mach(4) +c +c test on validity of parameters +c ----------------------------- +c + ier = 0 + neval = 0 + last = 0 + result = 0.0e+00 + abserr = 0.0e+00 + alist(1) = a + blist(1) = b + rlist(1) = 0.0e+00 + elist(1) = 0.0e+00 + iord(1) = 0 + level(1) = 0 + npts = npts2-2 + if(npts2.lt.2.or.limit.le.npts.or.(epsabs.le.0.0e+00.and. + * epsrel.lt.amax1(0.5e+02*epmach,0.5e-14))) ier = 6 + if(ier.eq.6) go to 210 +c +c if any break points are provided, sort them into an +c ascending sequence. +c + sign = 1.0e+00 + if(a.gt.b) sign = -1.0e+00 + pts(1) = amin1(a,b) + if(npts.eq.0) go to 15 + do 10 i = 1,npts + pts(i+1) = points(i) + 10 continue + 15 pts(npts+2) = amax1(a,b) + nint = npts+1 + a1 = pts(1) + if(npts.eq.0) go to 40 + nintp1 = nint+1 + do 20 i = 1,nint + ip1 = i+1 + do 20 j = ip1,nintp1 + if(pts(i).le.pts(j)) go to 20 + temp = pts(i) + pts(i) = pts(j) + pts(j) = temp + 20 continue + if(pts(1).ne.amin1(a,b).or.pts(nintp1).ne. + * amax1(a,b)) ier = 6 + if(ier.eq.6) go to 999 +c +c compute first integral and error approximations. +c ------------------------------------------------ +c + 40 resabs = 0.0e+00 + do 50 i = 1,nint + b1 = pts(i+1) + call qk21(f,a1,b1,area1,error1,defabs,resa,ier) + if (ier.lt.0) return + abserr = abserr+error1 + result = result+area1 + ndin(i) = 0 + if(error1.eq.resa.and.error1.ne.0.0e+00) ndin(i) = 1 + resabs = resabs+defabs + level(i) = 0 + elist(i) = error1 + alist(i) = a1 + blist(i) = b1 + rlist(i) = area1 + iord(i) = i + a1 = b1 + 50 continue + errsum = 0.0e+00 + do 55 i = 1,nint + if(ndin(i).eq.1) elist(i) = abserr + errsum = errsum+elist(i) + 55 continue +c +c test on accuracy. +c + last = nint + neval = 21*nint + dres = abs(result) + errbnd = amax1(epsabs,epsrel*dres) + if(abserr.le.0.1e+03*epmach*resabs.and.abserr.gt. + * errbnd) ier = 2 + if(nint.eq.1) go to 80 + do 70 i = 1,npts + jlow = i+1 + ind1 = iord(i) + do 60 j = jlow,nint + ind2 = iord(j) + if(elist(ind1).gt.elist(ind2)) go to 60 + ind1 = ind2 + k = j + 60 continue + if(ind1.eq.iord(i)) go to 70 + iord(k) = iord(i) + iord(i) = ind1 + 70 continue + if(limit.lt.npts2) ier = 1 + 80 if(ier.ne.0.or.abserr.le.errbnd) go to 999 +c +c initialization +c -------------- +c + rlist2(1) = result + maxerr = iord(1) + errmax = elist(maxerr) + area = result + nrmax = 1 + nres = 0 + numrl2 = 1 + ktmin = 0 + extrap = .false. + noext = .false. + erlarg = errsum + ertest = errbnd + levmax = 1 + iroff1 = 0 + iroff2 = 0 + iroff3 = 0 + ierro = 0 + uflow = r1mach(1) + oflow = r1mach(2) + abserr = oflow + ksgn = -1 + if(dres.ge.(0.1e+01-0.5e+02*epmach)*resabs) ksgn = 1 +c +c main do-loop +c ------------ +c + do 160 last = npts2,limit +c +c bisect the subinterval with the nrmax-th largest +c error estimate. +c + levcur = level(maxerr)+1 + a1 = alist(maxerr) + b1 = 0.5e+00*(alist(maxerr)+blist(maxerr)) + a2 = b1 + b2 = blist(maxerr) + erlast = errmax + call qk21(f,a1,b1,area1,error1,resa,defab1,ier) + if (ier.lt.0) return + call qk21(f,a2,b2,area2,error2,resa,defab2,ier) + if (ier.lt.0) return +c +c improve previous approximations to integral +c and error and test for accuracy. +c + neval = neval+42 + area12 = area1+area2 + erro12 = error1+error2 + errsum = errsum+erro12-errmax + area = area+area12-rlist(maxerr) + if(defab1.eq.error1.or.defab2.eq.error2) go to 95 + if(abs(rlist(maxerr)-area12).gt.0.1e-04*abs(area12) + * .or.erro12.lt.0.99e+00*errmax) go to 90 + if(extrap) iroff2 = iroff2+1 + if(.not.extrap) iroff1 = iroff1+1 + 90 if(last.gt.10.and.erro12.gt.errmax) iroff3 = iroff3+1 + 95 level(maxerr) = levcur + level(last) = levcur + rlist(maxerr) = area1 + rlist(last) = area2 + errbnd = amax1(epsabs,epsrel*abs(area)) +c +c test for roundoff error and eventually +c set error flag. +c + if(iroff1+iroff2.ge.10.or.iroff3.ge.20) ier = 2 + if(iroff2.ge.5) ierro = 3 +c +c set error flag in the case that the number of +c subintervals equals limit. +c + if(last.eq.limit) ier = 1 +c +c set error flag in the case of bad integrand behaviour +c at a point of the integration range +c + if(amax1(abs(a1),abs(b2)).le.(0.1e+01+0.1e+03*epmach)* + * (abs(a2)+0.1e+04*uflow)) ier = 4 +c +c append the newly-created intervals to the list. +c + if(error2.gt.error1) go to 100 + alist(last) = a2 + blist(maxerr) = b1 + blist(last) = b2 + elist(maxerr) = error1 + elist(last) = error2 + go to 110 + 100 alist(maxerr) = a2 + alist(last) = a1 + blist(last) = b1 + rlist(maxerr) = area2 + rlist(last) = area1 + elist(maxerr) = error2 + elist(last) = error1 +c +c call subroutine qpsrt to maintain the descending ordering +c in the list of error estimates and select the +c subinterval with nrmax-th largest error estimate (to be +c bisected next). +c + 110 call qpsrt(limit,last,maxerr,errmax,elist,iord,nrmax) +c ***jump out of do-loop + if(errsum.le.errbnd) go to 190 +c ***jump out of do-loop + if(ier.ne.0) go to 170 + if(noext) go to 160 + erlarg = erlarg-erlast + if(levcur+1.le.levmax) erlarg = erlarg+erro12 + if(extrap) go to 120 +c +c test whether the interval to be bisected next is the +c smallest interval. +c + if(level(maxerr)+1.le.levmax) go to 160 + extrap = .true. + nrmax = 2 + 120 if(ierro.eq.3.or.erlarg.le.ertest) go to 140 +c +c the smallest interval has the largest error. +c before bisecting decrease the sum of the errors +c over the larger intervals (erlarg) and perform +c extrapolation. +c + id = nrmax + jupbnd = last + if(last.gt.(2+limit/2)) jupbnd = limit+3-last + do 130 k = id,jupbnd + maxerr = iord(nrmax) + errmax = elist(maxerr) +c ***jump out of do-loop + if(level(maxerr)+1.le.levmax) go to 160 + nrmax = nrmax+1 + 130 continue +c +c perform extrapolation. +c + 140 numrl2 = numrl2+1 + rlist2(numrl2) = area + if(numrl2.le.2) go to 155 + call qelg(numrl2,rlist2,reseps,abseps,res3la,nres) + ktmin = ktmin+1 + if(ktmin.gt.5.and.abserr.lt.0.1e-02*errsum) ier = 5 + if(abseps.ge.abserr) go to 150 + ktmin = 0 + abserr = abseps + result = reseps + correc = erlarg + ertest = amax1(epsabs,epsrel*abs(reseps)) +c ***jump out of do-loop + if(abserr.lt.ertest) go to 170 +c +c prepare bisection of the smallest interval. +c + 150 if(numrl2.eq.1) noext = .true. + if(ier.ge.5) go to 170 + 155 maxerr = iord(1) + errmax = elist(maxerr) + nrmax = 1 + extrap = .false. + levmax = levmax+1 + erlarg = errsum + 160 continue +c +c set the final result. +c --------------------- +c +c + 170 if(abserr.eq.oflow) go to 190 + if((ier+ierro).eq.0) go to 180 + if(ierro.eq.3) abserr = abserr+correc + if(ier.eq.0) ier = 3 + if(result.ne.0.0e+00.and.area.ne.0.0e+00)go to 175 + if(abserr.gt.errsum)go to 190 + if(area.eq.0.0e+00) go to 210 + go to 180 + 175 if(abserr/abs(result).gt.errsum/abs(area))go to 190 +c +c test on divergence. +c + 180 if(ksgn.eq.(-1).and.amax1(abs(result),abs(area)).le. + * resabs*0.1e-01) go to 210 + if(0.1e-01.gt.(result/area).or.(result/area).gt.0.1e+03.or. + * errsum.gt.abs(area)) ier = 6 + go to 210 +c +c compute global integral sum. +c + 190 result = 0.0e+00 + do 200 k = 1,last + result = result+rlist(k) + 200 continue + abserr = errsum + 210 if(ier.gt.2) ier = ier - 1 + result = result*sign + 999 return + end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/quadpack/qelg.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,184 @@ + subroutine qelg(n,epstab,result,abserr,res3la,nres) +c***begin prologue qelg +c***refer to qagie,qagoe,qagpe,qagse +c***routines called r1mach +c***revision date 830518 (yymmdd) +c***keywords epsilon algorithm, convergence acceleration, +c extrapolation +c***author piessens,robert,appl. math. & progr. div. - k.u.leuven +c de doncker,elise,appl. math & progr. div. - k.u.leuven +c***purpose the routine determines the limit of a given sequence of +c approximations, by means of the epsilon algorithm of +c p. wynn. an estimate of the absolute error is also given. +c the condensed epsilon table is computed. only those +c elements needed for the computation of the next diagonal +c are preserved. +c***description +c +c epsilon algorithm +c standard fortran subroutine +c real version +c +c parameters +c n - integer +c epstab(n) contains the new element in the +c first column of the epsilon table. +c +c epstab - real +c vector of dimension 52 containing the elements +c of the two lower diagonals of the triangular +c epsilon table. the elements are numbered +c starting at the right-hand corner of the +c triangle. +c +c result - real +c resulting approximation to the integral +c +c abserr - real +c estimate of the absolute error computed from +c result and the 3 previous results +c +c res3la - real +c vector of dimension 3 containing the last 3 +c results +c +c nres - integer +c number of calls to the routine +c (should be zero at first call) +c +c***end prologue qelg +c + real abserr,delta1,delta2,delta3,r1mach, + * epmach,epsinf,epstab,error,err1,err2,err3,e0,e1,e1abs,e2,e3, + * oflow,res,result,res3la,ss,tol1,tol2,tol3 + integer i,ib,ib2,ie,indx,k1,k2,k3,limexp,n,newelm,nres,num + dimension epstab(52),res3la(3) +c +c list of major variables +c ----------------------- +c +c e0 - the 4 elements on which the +c e1 computation of a new element in +c e2 the epsilon table is based +c e3 e0 +c e3 e1 new +c e2 +c newelm - number of elements to be computed in the new +c diagonal +c error - error = abs(e1-e0)+abs(e2-e1)+abs(new-e2) +c result - the element in the new diagonal with least value +c of error +c +c machine dependent constants +c --------------------------- +c +c epmach is the largest relative spacing. +c oflow is the largest positive magnitude. +c limexp is the maximum number of elements the epsilon +c table can contain. if this number is reached, the upper +c diagonal of the epsilon table is deleted. +c +c***first executable statement qelg + epmach = r1mach(4) + oflow = r1mach(2) + nres = nres+1 + abserr = oflow + result = epstab(n) + if(n.lt.3) go to 100 + limexp = 50 + epstab(n+2) = epstab(n) + newelm = (n-1)/2 + epstab(n) = oflow + num = n + k1 = n + do 40 i = 1,newelm + k2 = k1-1 + k3 = k1-2 + res = epstab(k1+2) + e0 = epstab(k3) + e1 = epstab(k2) + e2 = res + e1abs = abs(e1) + delta2 = e2-e1 + err2 = abs(delta2) + tol2 = amax1(abs(e2),e1abs)*epmach + delta3 = e1-e0 + err3 = abs(delta3) + tol3 = amax1(e1abs,abs(e0))*epmach + if(err2.gt.tol2.or.err3.gt.tol3) go to 10 +c +c if e0, e1 and e2 are equal to within machine +c accuracy, convergence is assumed. +c result = e2 +c abserr = abs(e1-e0)+abs(e2-e1) +c + result = res + abserr = err2+err3 +c ***jump out of do-loop + go to 100 + 10 e3 = epstab(k1) + epstab(k1) = e1 + delta1 = e1-e3 + err1 = abs(delta1) + tol1 = amax1(e1abs,abs(e3))*epmach +c +c if two elements are very close to each other, omit +c a part of the table by adjusting the value of n +c + if(err1.le.tol1.or.err2.le.tol2.or.err3.le.tol3) go to 20 + ss = 0.1e+01/delta1+0.1e+01/delta2-0.1e+01/delta3 + epsinf = abs(ss*e1) +c +c test to detect irregular behaviour in the table, and +c eventually omit a part of the table adjusting the value +c of n. +c + if(epsinf.gt.0.1e-03) go to 30 + 20 n = i+i-1 +c ***jump out of do-loop + go to 50 +c +c compute a new element and eventually adjust +c the value of result. +c + 30 res = e1+0.1e+01/ss + epstab(k1) = res + k1 = k1-2 + error = err2+abs(res-e2)+err3 + if(error.gt.abserr) go to 40 + abserr = error + result = res + 40 continue +c +c shift the table. +c + 50 if(n.eq.limexp) n = 2*(limexp/2)-1 + ib = 1 + if((num/2)*2.eq.num) ib = 2 + ie = newelm+1 + do 60 i=1,ie + ib2 = ib+2 + epstab(ib) = epstab(ib2) + ib = ib2 + 60 continue + if(num.eq.n) go to 80 + indx = num-n+1 + do 70 i = 1,n + epstab(i)= epstab(indx) + indx = indx+1 + 70 continue + 80 if(nres.ge.4) go to 90 + res3la(nres) = result + abserr = oflow + go to 100 +c +c compute error estimate +c + 90 abserr = abs(result-res3la(3))+abs(result-res3la(2)) + * +abs(result-res3la(1)) + res3la(1) = res3la(2) + res3la(2) = res3la(3) + res3la(3) = result + 100 abserr = amax1(abserr,0.5e+01*epmach*abs(result)) + return + end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/quadpack/qk15i.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,202 @@ + subroutine qk15i(f,boun,inf,a,b,result,abserr,resabs,resasc,ierr) +c***begin prologue qk15i +c***date written 800101 (yymmdd) +c***revision date 830518 (yymmdd) +c***category no. h2a3a2,h2a4a2 +c***keywords 15-point transformed gauss-kronrod rules +c***author piessens,robert,appl. math. & progr. div. - k.u.leuven +c de doncker,elise,appl. math. & progr. div. - k.u.leuven +c***purpose the original (infinite integration range is mapped +c onto the interval (0,1) and (a,b) is a part of (0,1). +c it is the purpose to compute +c i = integral of transformed integrand over (a,b), +c j = integral of abs(transformed integrand) over (a,b). +c***description +c +c integration rule +c standard fortran subroutine +c real version +c +c parameters +c on entry +c f - subroutine f(x,ierr,result) defining the integrand +c function f(x). the actual name for f needs to be +c declared e x t e r n a l in the calling program. +c +c boun - real +c finite bound of original integration +c range (set to zero if inf = +2) +c +c inf - integer +c if inf = -1, the original interval is +c (-infinity,bound), +c if inf = +1, the original interval is +c (bound,+infinity), +c if inf = +2, the original interval is +c (-infinity,+infinity) and +c the integral is computed as the sum of two +c integrals, one over (-infinity,0) and one over +c (0,+infinity). +c +c a - real +c lower limit for integration over subrange +c of (0,1) +c +c b - real +c upper limit for integration over subrange +c of (0,1) +c +c on return +c result - real +c approximation to the integral i +c result is computed by applying the 15-point +c kronrod rule(resk) obtained by optimal addition +c of abscissae to the 7-point gauss rule(resg). +c +c abserr - real +c estimate of the modulus of the absolute error, +c which should equal or exceed abs(i-result) +c +c resabs - real +c approximation to the integral j +c +c resasc - real +c approximation to the integral of +c abs((transformed integrand)-i/(b-a)) over (a,b) +c +c***references (none) +c***routines called r1mach +c***end prologue qk15i +c + real a,absc,absc1,absc2,abserr,b,boun,centr, + * dinf,r1mach,epmach,fc,fsum,fval1,fval2,fvalt,fv1, + * fv2,hlgth,resabs,resasc,resg,resk,reskh,result,tabsc1,tabsc2, + * uflow,wg,wgk,xgk + integer inf,j,min0 + external f +c + dimension fv1(7),fv2(7),xgk(8),wgk(8),wg(8) +c +c the abscissae and weights are supplied for the interval +c (-1,1). because of symmetry only the positive abscissae and +c their corresponding weights are given. +c +c xgk - abscissae of the 15-point kronrod rule +c xgk(2), xgk(4), ... abscissae of the 7-point +c gauss rule +c xgk(1), xgk(3), ... abscissae which are optimally +c added to the 7-point gauss rule +c +c wgk - weights of the 15-point kronrod rule +c +c wg - weights of the 7-point gauss rule, corresponding +c to the abscissae xgk(2), xgk(4), ... +c wg(1), wg(3), ... are set to zero. +c + data xgk(1),xgk(2),xgk(3),xgk(4),xgk(5),xgk(6),xgk(7), + * xgk(8)/ + * 0.9914553711208126e+00, 0.9491079123427585e+00, + * 0.8648644233597691e+00, 0.7415311855993944e+00, + * 0.5860872354676911e+00, 0.4058451513773972e+00, + * 0.2077849550078985e+00, 0.0000000000000000e+00/ +c + data wgk(1),wgk(2),wgk(3),wgk(4),wgk(5),wgk(6),wgk(7), + * wgk(8)/ + * 0.2293532201052922e-01, 0.6309209262997855e-01, + * 0.1047900103222502e+00, 0.1406532597155259e+00, + * 0.1690047266392679e+00, 0.1903505780647854e+00, + * 0.2044329400752989e+00, 0.2094821410847278e+00/ +c + data wg(1),wg(2),wg(3),wg(4),wg(5),wg(6),wg(7),wg(8)/ + * 0.0000000000000000e+00, 0.1294849661688697e+00, + * 0.0000000000000000e+00, 0.2797053914892767e+00, + * 0.0000000000000000e+00, 0.3818300505051189e+00, + * 0.0000000000000000e+00, 0.4179591836734694e+00/ +c +c +c list of major variables +c ----------------------- +c +c centr - mid point of the interval +c hlgth - half-length of the interval +c absc* - abscissa +c tabsc* - transformed abscissa +c fval* - function value +c resg - result of the 7-point gauss formula +c resk - result of the 15-point kronrod formula +c reskh - approximation to the mean value of the transformed +c integrand over (a,b), i.e. to i/(b-a) +c +c machine dependent constants +c --------------------------- +c +c epmach is the largest relative spacing. +c uflow is the smallest positive magnitude. +c +c***first executable statement qk15i + epmach = r1mach(4) + uflow = r1mach(1) + dinf = min0(1,inf) +c + centr = 0.5e+00*(a+b) + hlgth = 0.5e+00*(b-a) + tabsc1 = boun+dinf*(0.1e+01-centr)/centr + call f(tabsc1, ierr, fval1) + if (ierr.lt.0) return + if(inf.eq.2) then + call f(-tabsc1, ierr, fval1) + if (ierr.lt.0) return + fval1 = fval1 + fvalt + endif + fc = (fval1/centr)/centr +c +c compute the 15-point kronrod approximation to +c the integral, and estimate the error. +c + resg = wg(8)*fc + resk = wgk(8)*fc + resabs = abs(resk) + do 10 j=1,7 + absc = hlgth*xgk(j) + absc1 = centr-absc + absc2 = centr+absc + tabsc1 = boun+dinf*(0.1e+01-absc1)/absc1 + tabsc2 = boun+dinf*(0.1e+01-absc2)/absc2 + call f(tabsc1, ierr, fval1) + if (ierr.lt.0) return + call f(tabsc2, ierr, fval2) + if (ierr.lt.0) return + if(inf.eq.2) then + call f(-tabsc1,ierr,fvalt) + if (ierr.lt.0) return + fval1 = fval1 + fvalt + endif + if(inf.eq.2) then + call f(-tabsc2,ierr,fvalt) + if (ierr.lt.0) return + fval2 = fval2 + fvalt + endif + fval1 = (fval1/absc1)/absc1 + fval2 = (fval2/absc2)/absc2 + fv1(j) = fval1 + fv2(j) = fval2 + fsum = fval1+fval2 + resg = resg+wg(j)*fsum + resk = resk+wgk(j)*fsum + resabs = resabs+wgk(j)*(abs(fval1)+abs(fval2)) + 10 continue + reskh = resk*0.5e+00 + resasc = wgk(8)*abs(fc-reskh) + do 20 j=1,7 + resasc = resasc+wgk(j)*(abs(fv1(j)-reskh)+abs(fv2(j)-reskh)) + 20 continue + result = resk*hlgth + resasc = resasc*hlgth + resabs = resabs*hlgth + abserr = abs((resk-resg)*hlgth) + if(resasc.ne.0.0e+00.and.abserr.ne.0.e0) abserr = resasc* + * amin1(0.1e+01,(0.2e+03*abserr/resasc)**1.5e+00) + if(resabs.gt.uflow/(0.5e+02*epmach)) abserr = amax1 + * ((epmach*0.5e+02)*resabs,abserr) + return + end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/quadpack/qk21.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,175 @@ + subroutine qk21(f,a,b,result,abserr,resabs,resasc,ierr) +c***begin prologue qk21 +c***date written 800101 (yymmdd) +c***revision date 830518 (yymmdd) +c***category no. h2a1a2 +c***keywords 21-point gauss-kronrod rules +c***author piessens,robert,appl. math. & progr. div. - k.u.leuven +c de doncker,elise,appl. math. & progr. div. - k.u.leuven +c***purpose to compute i = integral of f over (a,b), with error +c estimate +c j = integral of abs(f) over (a,b) +c***description +c +c integration rules +c standard fortran subroutine +c real version +c +c parameters +c on entry +c f - subroutine f(x,ierr,result) defining the integrand +c function f(x). the actual name for f needs to be +c declared e x t e r n a l in the driver program. +c +c a - real +c lower limit of integration +c +c b - real +c upper limit of integration +c +c on return +c result - real +c approximation to the integral i +c result is computed by applying the 21-point +c kronrod rule (resk) obtained by optimal addition +c of abscissae to the 10-point gauss rule (resg). +c +c abserr - real +c estimate of the modulus of the absolute error, +c which should not exceed abs(i-result) +c +c resabs - real +c approximation to the integral j +c +c resasc - real +c approximation to the integral of abs(f-i/(b-a)) +c over (a,b) +c +c***references (none) +c***routines called r1mach +c***end prologue qk21 +c + real a,absc,abserr,b,centr,dhlgth,epmach,fc,fsum,fval1,fval2, + * fv1,fv2,hlgth,resabs,resg,resk,reskh,result,r1mach,uflow,wg,wgk, + * xgk + integer j,jtw,jtwm1 + external f +c + dimension fv1(10),fv2(10),wg(5),wgk(11),xgk(11) +c +c the abscissae and weights are given for the interval (-1,1). +c because of symmetry only the positive abscissae and their +c corresponding weights are given. +c +c xgk - abscissae of the 21-point kronrod rule +c xgk(2), xgk(4), ... abscissae of the 10-point +c gauss rule +c xgk(1), xgk(3), ... abscissae which are optimally +c added to the 10-point gauss rule +c +c wgk - weights of the 21-point kronrod rule +c +c wg - weights of the 10-point gauss rule +c + data xgk(1),xgk(2),xgk(3),xgk(4),xgk(5),xgk(6),xgk(7), + * xgk(8),xgk(9),xgk(10),xgk(11)/ + * 0.9956571630258081e+00, 0.9739065285171717e+00, + * 0.9301574913557082e+00, 0.8650633666889845e+00, + * 0.7808177265864169e+00, 0.6794095682990244e+00, + * 0.5627571346686047e+00, 0.4333953941292472e+00, + * 0.2943928627014602e+00, 0.1488743389816312e+00, + * 0.0000000000000000e+00/ +c + data wgk(1),wgk(2),wgk(3),wgk(4),wgk(5),wgk(6),wgk(7), + * wgk(8),wgk(9),wgk(10),wgk(11)/ + * 0.1169463886737187e-01, 0.3255816230796473e-01, + * 0.5475589657435200e-01, 0.7503967481091995e-01, + * 0.9312545458369761e-01, 0.1093871588022976e+00, + * 0.1234919762620659e+00, 0.1347092173114733e+00, + * 0.1427759385770601e+00, 0.1477391049013385e+00, + * 0.1494455540029169e+00/ +c + data wg(1),wg(2),wg(3),wg(4),wg(5)/ + * 0.6667134430868814e-01, 0.1494513491505806e+00, + * 0.2190863625159820e+00, 0.2692667193099964e+00, + * 0.2955242247147529e+00/ +c +c +c list of major variables +c ----------------------- +c +c centr - mid point of the interval +c hlgth - half-length of the interval +c absc - abscissa +c fval* - function value +c resg - result of the 10-point gauss formula +c resk - result of the 21-point kronrod formula +c reskh - approximation to the mean value of f over (a,b), +c i.e. to i/(b-a) +c +c +c machine dependent constants +c --------------------------- +c +c epmach is the largest relative spacing. +c uflow is the smallest positive magnitude. +c +c***first executable statement qk21 + epmach = r1mach(4) + uflow = r1mach(1) +c + centr = 0.5e+00*(a+b) + hlgth = 0.5e+00*(b-a) + dhlgth = abs(hlgth) +c +c compute the 21-point kronrod approximation to +c the integral, and estimate the absolute error. +c + resg = 0.0e+00 + call f(centr, ierr, fc) + if (ierr .lt. 0) return + resk = wgk(11)*fc + resabs = abs(resk) + do 10 j=1,5 + jtw = 2*j + absc = hlgth*xgk(jtw) + call f(centr-absc,ierr,fval1) + if (ierr .lt. 0) return + call f(centr+absc,ierr,fval2) + if (ierr .lt. 0) return + fv1(jtw) = fval1 + fv2(jtw) = fval2 + fsum = fval1+fval2 + resg = resg+wg(j)*fsum + resk = resk+wgk(jtw)*fsum + resabs = resabs+wgk(jtw)*(abs(fval1)+abs(fval2)) + 10 continue + do 15 j = 1,5 + jtwm1 = 2*j-1 + absc = hlgth*xgk(jtwm1) + call f(centr-absc,ierr,fval1) + if (ierr .lt. 0) return + call f(centr+absc,ierr,fval2) + if (ierr .lt. 0) return + fv1(jtwm1) = fval1 + fv2(jtwm1) = fval2 + fsum = fval1+fval2 + resk = resk+wgk(jtwm1)*fsum + resabs = resabs+wgk(jtwm1)*(abs(fval1)+abs(fval2)) + 15 continue + reskh = resk*0.5e+00 + resasc = wgk(11)*abs(fc-reskh) + do 20 j=1,10 + resasc = resasc+wgk(j)*(abs(fv1(j)-reskh)+abs(fv2(j)-reskh)) + 20 continue + result = resk*hlgth + resabs = resabs*dhlgth + resasc = resasc*dhlgth + abserr = abs((resk-resg)*hlgth) + if(resasc.ne.0.0e+00.and.abserr.ne.0.0e+00) + * abserr = resasc*amin1(0.1e+01, + * (0.2e+03*abserr/resasc)**1.5e+00) + if(resabs.gt.uflow/(0.5e+02*epmach)) abserr = amax1 + * ((epmach*0.5e+02)*resabs,abserr) + return + end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/quadpack/qpsrt.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,136 @@ + subroutine qpsrt(limit,last,maxerr,ermax,elist,iord,nrmax) +c***begin prologue qpsrt +c***refer to qage,qagie,qagpe,qagse,qawce,qawse,qawoe +c***routines called (none) +c***keywords sequential sorting +c***description +c +c 1. qpsrt +c ordering routine +c standard fortran subroutine +c real version +c +c 2. purpose +c this routine maintains the descending ordering +c in the list of the local error estimates resulting from +c the interval subdivision process. at each call two error +c estimates are inserted using the sequential search +c method, top-down for the largest error estimate +c and bottom-up for the smallest error estimate. +c +c 3. calling sequence +c call qpsrt(limit,last,maxerr,ermax,elist,iord,nrmax) +c +c parameters (meaning at output) +c limit - integer +c maximum number of error estimates the list +c can contain +c +c last - integer +c number of error estimates currently +c in the list +c +c maxerr - integer +c maxerr points to the nrmax-th largest error +c estimate currently in the list +c +c ermax - real +c nrmax-th largest error estimate +c ermax = elist(maxerr) +c +c elist - real +c vector of dimension last containing +c the error estimates +c +c iord - integer +c vector of dimension last, the first k +c elements of which contain pointers +c to the error estimates, such that +c elist(iord(1)),... , elist(iord(k)) +c form a decreasing sequence, with +c k = last if last.le.(limit/2+2), and +c k = limit+1-last otherwise +c +c nrmax - integer +c maxerr = iord(nrmax) +c +c 4. no subroutines or functions needed +c***end prologue qpsrt +c + real elist,ermax,errmax,errmin + integer i,ibeg,ido,iord,isucc,j,jbnd,jupbn,k,last,limit,maxerr, + * nrmax + dimension elist(last),iord(last) +c +c check whether the list contains more than +c two error estimates. +c +c***first executable statement qpsrt + if(last.gt.2) go to 10 + iord(1) = 1 + iord(2) = 2 + go to 90 +c +c this part of the routine is only executed +c if, due to a difficult integrand, subdivision +c increased the error estimate. in the normal case +c the insert procedure should start after the +c nrmax-th largest error estimate. +c + 10 errmax = elist(maxerr) + if(nrmax.eq.1) go to 30 + ido = nrmax-1 + do 20 i = 1,ido + isucc = iord(nrmax-1) +c ***jump out of do-loop + if(errmax.le.elist(isucc)) go to 30 + iord(nrmax) = isucc + nrmax = nrmax-1 + 20 continue +c +c compute the number of elements in the list to +c be maintained in descending order. this number +c depends on the number of subdivisions still +c allowed. +c + 30 jupbn = last + if(last.gt.(limit/2+2)) jupbn = limit+3-last + errmin = elist(last) +c +c insert errmax by traversing the list top-down, +c starting comparison from the element elist(iord(nrmax+1)). +c + jbnd = jupbn-1 + ibeg = nrmax+1 + if(ibeg.gt.jbnd) go to 50 + do 40 i=ibeg,jbnd + isucc = iord(i) +c ***jump out of do-loop + if(errmax.ge.elist(isucc)) go to 60 + iord(i-1) = isucc + 40 continue + 50 iord(jbnd) = maxerr + iord(jupbn) = last + go to 90 +c +c insert errmin by traversing the list bottom-up. +c + 60 iord(i-1) = maxerr + k = jbnd + do 70 j=i,jbnd + isucc = iord(k) +c ***jump out of do-loop + if(errmin.lt.elist(isucc)) go to 80 + iord(k+1) = isucc + k = k-1 + 70 continue + iord(i) = last + go to 90 + 80 iord(k+1) = last +c +c set maxerr and ermax. +c + 90 maxerr = iord(nrmax) + ermax = elist(maxerr) + return + end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/quadpack/xerror.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,39 @@ + SUBROUTINE XERROR(MESSG,NMESSG,NERR,LEVEL) +C +C ABSTRACT +C XERROR PROCESSES A DIAGNOSTIC MESSAGE, IN A MANNER +C DETERMINED BY THE VALUE OF LEVEL AND THE CURRENT VALUE +C OF THE LIBRARY ERROR CONTROL FLAG, KONTRL. +C (SEE SUBROUTINE XSETF FOR DETAILS.) +C +C DESCRIPTION OF PARAMETERS +C --INPUT-- +C MESSG - THE HOLLERITH MESSAGE TO BE PROCESSED, CONTAINING +C NO MORE THAN 72 CHARACTERS. +C NMESSG- THE ACTUAL NUMBER OF CHARACTERS IN MESSG. +C NERR - THE ERROR NUMBER ASSOCIATED WITH THIS MESSAGE. +C NERR MUST NOT BE ZERO. +C LEVEL - ERROR CATEGORY. +C =2 MEANS THIS IS AN UNCONDITIONALLY FATAL ERROR. +C =1 MEANS THIS IS A RECOVERABLE ERROR. (I.E., IT IS +C NON-FATAL IF XSETF HAS BEEN APPROPRIATELY CALLED.) +C =0 MEANS THIS IS A WARNING MESSAGE ONLY. +C =-1 MEANS THIS IS A WARNING MESSAGE WHICH IS TO BE +C PRINTED AT MOST ONCE, REGARDLESS OF HOW MANY +C TIMES THIS CALL IS EXECUTED. +C +C EXAMPLES +C CALL XERROR(23HSMOOTH -- NUM WAS ZERO.,23,1,2) +C CALL XERROR(43HINTEG -- LESS THAN FULL ACCURACY ACHIEVED., +C 43,2,1) +C CALL XERROR(65HROOTER -- ACTUAL ZERO OF F FOUND BEFORE INTERVAL +C 1 FULLY COLLAPSED.,65,3,0) +C CALL XERROR(39HEXP -- UNDERFLOWS BEING SET TO ZERO.,39,1,-1) +C +C WRITTEN BY RON JONES, WITH SLATEC COMMON MATH LIBRARY SUBCOMMITTEE +C LATEST REVISION --- 7 FEB 1979 +C + DIMENSION MESSG(NMESSG) + CALL XERRWD(MESSG,NMESSG,NERR,LEVEL,0,0,0,0,0.,0.) + RETURN + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/ranlib/Basegen.doc Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,382 @@ + + + + + + + + + + + + RANDLIB + + Library of Fortran Routines for Random Number Generation + + + + + + + + + Base Generator Documentation + + + + + + + + + Compiled and Written by: + + Barry W. Brown + James Lovato + + + + + + + + + + + Department of Biomathematics, Box 237 + The University of Texas, M.D. Anderson Cancer Center + 1515 Holcombe Boulevard + Houston, TX 77030 + + + This work was supported by grant CA-16672 from the National Cancer Institute. + + + + + Base Random Number Generator + + + +I. OVERVIEW AND DEFAULT BEHAVIOR + +This set of programs contains 32 virtual random number generators. +Each generator can provide 1,048,576 blocks of numbers, and each block +is of length 1,073,741,824. Any generator can be set to the beginning +or end of the current block or to its starting value. The methods are +from the paper cited immediately below, and most of the code is a +transliteration from the Pascal of the paper into Fortran. + +P. L'Ecuyer and S. Cote. Implementing a Random Number Package with +Splitting Facilities. ACM Transactions on Mathematical Software 17:1, +pp 98-111. + +Most users won't need the sophisticated capabilities of this package, +and will desire a single generator. This single generator (which will +have a non-repeating length of 2.3 X 10^18 numbers) is the default. +In order to accommodate this use, the concept of the current generator +is added to those of the cited paper; references to a generator are +always to the current generator. The current generator is initially +generator number 1; it can be changed by SETCGN, and the ordinal +number of the current generator can be obtained from GETCGN. + +The user of the default can set the initial values of the two integer +seeds with SETALL. If the user does not set the seeds, the random +number generation will use the default values, 1234567890 and +123456789. The values of the current seeds can be achieved by a call +to GETSD. Random number may be obtained as integers ranging from 1 to +a large integer by reference to function IGNLGI or as a floating point +number between 0 and 1 by a reference to function RANF. These are the +only routines needed by a user desiring a single stream of random +numbers. + +II. CONCEPTS + +A stream of pseudo-random numbers is a sequence, each member of which +can be obtained either as an integer in the range 1..2,147,483,563 or +as a floating point number in the range [0..1]. The user is in charge +of which representation is desired. + +The method contains an algorithm for generating a stream with a very +long period, 2.3 X 10^18. This stream in partitioned into G (=32) +virtual generators. Each virtual generator contains 2^20 (=1,048,576) +blocks of non-overlapping random numbers. Each block is 2^30 +(=1,073,741,824) in length. + + + +Base Random Number Generator Page 2 + + +The state of a generator is determined by two integers called seeds. +The seeds can be initialized by the user; the initial values of the +first must lie between 1 and 2,147,483,562, that of the second between +1 and 2,147,483,398. Each time a number is generated, the values of +the seeds change. Three values of seeds are remembered by the +generators at all times: the value with which the generator was +initialized, the value at the beginning of the current block, and the +value at the beginning of the next block. The seeds of any generator +can be set to any of these three values at any time. + + Of the 32 virtual generators, exactly one will be the current +generator, i.e., that one will be used to generate values for IGNLGI +and RANDF. Initially, the current generator is set to number one. +The current generator may be changed by calling SETCGN, and the number +of the current generator can be obtained using GETCGN. + +III. AN EXAMPLE + +An example of the need for these capabilities is as follows. Two +statistical techniques are being compared on data of different sizes. +The first technique uses bootstrapping and is thought to be as +accurate using less data than the second method which employs only +brute force. + +For the first method, a data set of size uniformly distributed between +25 and 50 will be generated. Then the data set of the specified size +will be generated and alalyzed. The second method will choose a data +set size between 100 and 200, generate the data and alalyze it. This +process will be repeated 1000 times. + +For variance reduction, we want the random numbers used in the two +methods to be the same for each of the 1000 comparisons. But method +two will use more random numbers than method one and without this +package, synchronization might be difficult. + +With the package, it is a snap. Use generator 1 to obtain the sample +size for method one and generator 2 to obtain the data. Then reset +the state to the beginning of the current block and do the same for +the second method. This assures that the initial data for method two +is that used by method one. When both have concluded, advance the +block for both generators. + +IV. THE INTERFACE + +A random number is obtained either as a random integer between 1 and +2,147,483,562 by invoking integer function IGNLGI (I GeNerate LarGe +Integer) or as a random floating point number between 0 and 1 by +invoking real function RANF. Neither function has arguments. + +The seed of the first generator can be set by invoking subroutine +SETALL; the values of the seeds of the other 31 generators are +calculated from this value. + + + +Base Random Number Generator Page 3 + + +The number of the current generator can be set by calling subroutine +SETCGN, which takes a single argument, the integer generator number in +the range 1..32. The number of the current generator can be obtained +by invoking subroutine GETCGN which returns the number in its single +integer argument. + + +V. CALLING SEQUENCES + + A. SETTING THE SEED OF ALL GENERATORS + +C********************************************************************** +C +C SUBROUTINE SETALL(ISEED1,ISEED2) +C SET ALL random number generators +C +C Sets the initial seed of generator 1 to ISEED1 and ISEED2. The +C initial seeds of the other generators are set accordingly, and +C all generators states are set to these seeds. +C +C Arguments +C +C +C ISEED1 -> First of two integer seeds +C INTEGER ISEED1 +C +C ISEED2 -> Second of two integer seeds +C INTEGER ISEED1 +C +C********************************************************************** + + + B. OBTAINING RANDOM NUMBERS + +C********************************************************************** +C +C INTEGER FUNCTION IGNLGI() +C GeNerate LarGe Integer +C +C Returns a random integer following a uniform distribution over +C (1, 2147483562) using the current generator. +C +C********************************************************************** + +C********************************************************************** +C +C REAL FUNCTION RANF() +C RANDom number generator as a Function +C +C Returns a random floating point number from a uniform distribution +C over 0 - 1 (endpoints of this interval are not returned) using the +C current generator +C +C********************************************************************** + + + +Base Random Number Generator Page 4 + + + C. SETTING AND OBTAINING THE NUMBER OF THE CURRENT GENERATOR + +C********************************************************************** +C +C SUBROUTINE SETCGN( G ) +C Set GeNerator +C +C Sets the current generator to G. All references to a generator +C are to the current generator. +C +C Arguments +C +C G --> Number of the current random number generator (1..32) +C INTEGER G +C +C********************************************************************** + +C********************************************************************** +C +C SUBROUTINE GETCGN(G) +C Get GeNerator +C +C Returns in G the number of the current random number generator +C +C Arguments +C +C G <-- Number of the current random number generator (1..32) +C INTEGER G +C +C********************************************************************** + + D. OBTAINING OR CHANGING SEEDS IN CURRENT GENERATOR + +C********************************************************************** +C +C SUBROUTINE ADVNST(K) +C ADV-a-N-ce ST-ate +C +C Advances the state of the current generator by 2^K values and +C resets the initial seed to that value. +C +C Arguments +C +C +C K -> The generator is advanced by 2^K values +C INTEGER K +C +C********************************************************************** + + + +Base Random Number Generator Page 5 + + +C********************************************************************** +C +C SUBROUTINE GETSD(ISEED1,ISEED2) +C GET SeeD +C +C Returns the value of two integer seeds of the current generator +C +C Arguments +C +C +C +C ISEED1 <- First integer seed of generator G +C INTEGER ISEED1 +C +C ISEED2 <- Second integer seed of generator G +C INTEGER ISEED1 +C +C********************************************************************** + +C********************************************************************** +C +C SUBROUTINE INITGN(ISDTYP) +C INIT-ialize current G-e-N-erator +C +C Reinitializes the state of the current generator +C +C Arguments +C +C +C ISDTYP -> The state to which the generator is to be set +C ISDTYP = -1 => sets the seeds to their initial value +C ISDTYP = 0 => sets the seeds to the first value of +C the current block +C ISDTYP = 1 => sets the seeds to the first value of +C the next block +C +C INTEGER ISDTYP +C +C********************************************************************** + +C********************************************************************** +C +C SUBROUTINE SETSD(ISEED1,ISEED2) +C SET S-ee-D of current generator +C +C Resets the initial seed of the current generator to ISEED1 and +C ISEED2. The seeds of the other generators remain unchanged. +C +C Arguments +C +C +C ISEED1 -> First integer seed +C INTEGER ISEED1 +C +C ISEED2 -> Second integer seed +C INTEGER ISEED1 +C +C********************************************************************** + + + +Base Random Number Generator Page 6 + + + E. MISCELLANY + +C********************************************************************** +C +C INTEGER FUNCTION MLTMOD(A,S,M) +C +C Returns (A*S) MOD M +C +C Arguments +C +C +C A, S, M --> +C INTEGER A,S,M +C +C********************************************************************** + +C********************************************************************** +C +C SUBROUTINE SETANT(QVALUE) +C SET ANTithetic +C +C Sets whether the current generator produces antithetic values. If +C X is the value normally returned from a uniform [0,1] random +C number generator then 1 - X is the antithetic value. If X is the +C value normally returned from a uniform [0,N] random number +C generator then N - 1 - X is the antithetic value. +C +C All generators are initialized to NOT generate antithetic values. +C +C Arguments +C +C QVALUE -> .TRUE. if generator G is to generating antithetic +C values, otherwise .FALSE. +C LOGICAL QVALUE +C +C**********************************************************************
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/ranlib/HOWTOGET Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,31 @@ + + WHERE TO GET IT + + Software written by members of the section is freely available to + anyone. Reposting on other archives is encouraged. The code is + furnished in source form and as DOS and Macintosh executables. Readers + with Internet access and a browser might note the following web site + addresses: + + University of Texas M. D. Anderson Cancer Center Home Page: + http://utmdacc.mdacc.tmc.edu/ + + Department of Biomathematics Home Page: + http://odin.mdacc.tmc.edu/ + + + Available Software: + http://odin.mdacc.tmc.edu/anonftp/ + + + Our code can also be obtained by anonymous ftp to odin.mdacc.tmc.edu. + The index is on file ./pub/index. + + Our statistical code is also posted to statlib after some delay. + Statlib can be accessed at: + http://lib.stat.cmu.edu/ + See in particular: + http://lib.stat.cmu.edu/general/Utexas/ + + The code is also archived at many other sites (at their option). Use + your favorite search engine to find one close to you.
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/ranlib/README Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,346 @@ + + + + + + + + + + + + RANDLIB + + Library of Fortran Routines for Random Number Generation + + + Version 1.3 -- August, 1997 + + + + + README + + + + + + + + + Compiled and Written by: + + Barry W. Brown + James Lovato + Kathy Russell + John Venier + + + + + + + + + + Department of Biomathematics, Box 237 + The University of Texas, M.D. Anderson Cancer Center + 1515 Holcombe Boulevard + Houston, TX 77030 + + + This work was supported by grant CA-16672 from the National Cancer Institute. + + + + THANKS TO OUR SUPPORTERS + +This work was supported in part by grant CA-16672 from the National +Cancer Institute. We are grateful to Larry and Pat McNeil of Corpus +Cristi for their generous support. Some equipment used in this effort +was provided by IBM as part of a cooperative study agreement; we thank +them. + + + SUMMARY OF RANDLIB + +The bottom level routines provide 32 virtual random number generators. +Each generator can provide 1,048,576 blocks of numbers, and each block +is of length 1,073,741,824. Any generator can be set to the beginning +or end of the current block or to its starting value. Packaging is +provided so that if these capabilities are not needed, a single +generator with period 2.3 X 10^18 is seen. + +Using this base, routines are provided that return: + (1) Beta random deviates + (2) Chi-square random deviates + (3) Exponential random deviates + (4) F random deviates + (5) Gamma random deviates + (6) Multivariate normal random deviates (mean and covariance + matrix specified) + (7) Noncentral chi-square random deviates + (8) Noncentral F random deviates + (9) Univariate normal random deviates + (10) Random permutations of an integer array + (11) Real uniform random deviates between specified limits + (12) Binomial random deviates + (13) Negative Binomial random deviates + (14) Multinomial random deviates + (15) Poisson random deviates + (16) Integer uniform deviates between specified limits + (17) Seeds for the random number generator calculated from a + character string + + INSTALLATION + +Directory src contains the Fortran source. The Fortran code from this +directory should be compiled and placed in a library. Directory test +contains three test programs for this code. + + + + + + + DOCUMENTATION + +Documentation is on directory doc on the distribution. All of the +documentation is in the form of character (ASCII) files. An +explanation of the concepts involved in the base generator and details +of its implementation are contained in Basegen.doc. A summary of all +of the available routines is contained in randlib.chs (chs is an +abbreviation of 'cheat sheet'). The 'chs' file will probably be the +reference to randlib that is primarily used. The file, randlib.fdoc, +contains all comments heading each routine. There is somewhat more +information in 'fdoc' than 'chs', but the additional information +consists primarily of references to the literature. + + + + SOURCES + +The following routines, which were written by others and lightly +modified for consistency in packaging, are included in RANDLIB. + + Bottom Level Routines + +These routines are a transliteration of the Pascal in the reference to +Fortran. + +L'Ecuyer, P. and Cote, S. "Implementing a Random Number Package with +Splitting Facilities." ACM Transactions on Mathematical Software, +17:98-111 (1991) + + Exponential + +This code was obtained from Netlib. + +Ahrens, J.H. and Dieter, U. Computer Methods for Sampling From the +Exponential and Normal Distributions. Comm. ACM, 15,10 (Oct. 1972), +873 - 882. + + Gamma + +(Case R >= 1.0) + +Ahrens, J.H. and Dieter, U. Generating Gamma Variates by a Modified +Rejection Technique. Comm. ACM, 25,1 (Jan. 1982), 47 - 54. +Algorithm GD + +(Case 0.0 <= R <= 1.0) + +Ahrens, J.H. and Dieter, U. Computer Methods for Sampling from Gamma, +Beta, Poisson and Binomial Distributions. Computing, 12 (1974), +223-246. Adaptation of algorithm GS. + + + + + + + Normal + +This code was obtained from netlib. + +Ahrens, J.H. and Dieter, U. Extensions of Forsythe's Method for +Random Sampling from the Normal Distribution. Math. Comput., 27,124 +(Oct. 1973), 927 - 937. + + Binomial + +This code was kindly sent me by Dr. Kachitvichyanukul. + +Kachitvichyanukul, V. and Schmeiser, B. W. Binomial Random Variate +Generation. Communications of the ACM, 31, 2 (February, 1988) 216. + + + Poisson + +This code was obtained from netlib. + +Ahrens, J.H. and Dieter, U. Computer Generation of Poisson Deviates +From Modified Normal Distributions. ACM Trans. Math. Software, 8, 2 +(June 1982),163-179 + + Beta + +This code was written by us following the recipe in the following. + +R. C. H. Cheng Generating Beta Variables with Nonintegral Shape +Parameters. Communications of the ACM, 21:317-322 (1978) (Algorithms +BB and BC) + + Linpack + +Routines SPOFA and SDOT are used to perform the Cholesky decomposition +of the covariance matrix in SETGMN (used for the generation of +multivariate normal deviates). + +Dongarra, J. J., Moler, C. B., Bunch, J. R. and Stewart, G. W. +Linpack User's Guide. SIAM Press, Philadelphia. (1979) + + + + + LEGALITIES + +Code that appeared in an ACM publication is subject to their +algorithms policy: + + Submittal of an algorithm for publication in one of the ACM + Transactions implies that unrestricted use of the algorithm within a + computer is permissible. General permission to copy and distribute + the algorithm without fee is granted provided that the copies are not + made or distributed for direct commercial advantage. The ACM + copyright notice and the title of the publication and its date appear, + and notice is given that copying is by permission of the Association + for Computing Machinery. To copy otherwise, or to republish, requires + a fee and/or specific permission. + + Krogh, F. Algorithms Policy. ACM Tran. Math. Softw. 13(1987), + 183-186. + +We place the Randlib code that we have written in the public domain. + + NO WARRANTY + + WE PROVIDE ABSOLUTELY NO WARRANTY OF ANY KIND EITHER EXPRESSED OR + IMPLIED, INCLUDING BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF + MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK + AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD + THIS PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY + SERVICING, REPAIR OR CORRECTION. + + IN NO EVENT SHALL THE UNIVERSITY OF TEXAS OR ANY OF ITS COMPONENT + INSTITUTIONS INCLUDING M. D. ANDERSON HOSPITAL BE LIABLE TO YOU FOR + DAMAGES, INCLUDING ANY LOST PROFITS, LOST MONIES, OR OTHER SPECIAL, + INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR + INABILITY TO USE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA OR + ITS ANALYSIS BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY THIRD + PARTIES) THE PROGRAM. + + (Above NO WARRANTY modified from the GNU NO WARRANTY statement.) + + + + WHAT'S NEW IN VERSION 1.1? + + +Random number generation for the Negative Binomial and Multinomial +distributions has been included. + +Two errors in the code which generates random numbers from the Gamma +distribution were fixed. + + + WHAT'S NEW IN VERSION 1.2? + +We changed the name of the package from 'ranlib' to 'randlib'. This +was done so that we can determine who archives it. 'ranlib' is the +name of a Unix utility which produces many spurious hits on a web +search engine. + + +The linpack routines are now housed in the /src directory. + +In several routines, some variables were given an explicit SAVE +attribute and some dummy initial values were changed to prevent +potential errors. +'genbet.f' 'ignbin.f' 'ignpoi.f' 'phrtsd.f' 'sexpo.f' 'sgamma.f' +'snorm.f' + +In several routines, argument checking was implemented; the code now +breaks if inappropriate values are passed to it. +'genbet.f' A and B must be >= 1.0E-37 instead of 0.0 +'genexp.f' AV must be >= 0.0 +'gengam.f' A and R both must be > 0.0 +'gennor.f' SD must be >= 0.0 +'ignbin.f' N must be >= 0, and 0.0 <= PP <= 1.0. +'ignnbn.f' N must be > 0, 0.0 < P < 1.0 (previously allowed N = 0) +'ignpoi.f' MU must be >= 0.0 + +For the Non-Central Chi-Squared and Non-Central F distributions, the +case DF = 1.0 (DFN = 1.0 for the F) is now allowed. +'gennch.f' 'gennf.f' + +Wherever possible, the user-accessible code now calls the base +generators directly. This means improved performance and fewer +dependencies, but the routines should work exactly as before from the +user's point of view. +'genchi.f' 'genf.f' 'gennch.f' 'gennf.f' 'ignnbn.f' + +Many minor modifications have been made which should make the code +more robust, without changing how the code is used. +'genbet.f' 'gengam.f' 'ignpoi.f' 'ignuin.f' 'sgamma.f' 'tstmid.f' + +Finally, five distributions have been added to the mid-level tester, +which test the Exponential, Gamma, Multinomial, Negative Binomial, and +Normal distributions. +'tstmid.f' + + + + + WHAT'S NOT NEW IN VERSION 1.2 ? + +No calling sequences have changed. + + WHAT'S NEW IN VERSION 1.3? + +The calling sequence of SETGMN has been changed! We added an argument +(INTEGER LDCOVM) representing the leading actual dimension of COVM, to +allow the user to use this routine in the case that COVM is contained +in a larger array. This change also makes the routine more compatible +with LINPACK routines. See the following files for details: +'setgmn.f' in the /src directory, and 'randlib.fdoc' and 'randlib.chs' +in the /doc directory. + +Briefly, the declaration of SETGMN has been changed +from: + SUBROUTINE setgmn(meanv,covm,p,parm) +to: + SUBROUTINE setgmn(meanv,covm,ldcovm,p,parm) + +The program 'tstgmn.f' (in the /test directory) was changed to reflect +the change in the calling sequence of SETGMN. + +'randlib.fdoc' and 'randlib.chs' in the /doc directory were changed to +relect the change in the calling sequence of SETGMN. + +Minor changes were made in two routines ('sgamma.f' and 'sexpo.f') to +fix unusual bugs. + +The protection from overflow in deviate generation in two routines +('genf.f' and 'gennf.f') was changed to prevent a constant from +underflowing at compile time. + + WHAT'S NOT NEW IN VERSION 1.3 ? + +No calling sequences (other than SETGMN) have changed. + + MANY THANKS + +The authors would like to thank the many users who have reported bugs +and suggested improvements; Randlib would not be the same today +without them. We heartily encourage others to join them.
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/ranlib/advnst.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,80 @@ + SUBROUTINE advnst(k) +C********************************************************************** +C +C SUBROUTINE ADVNST(K) +C ADV-a-N-ce ST-ate +C +C Advances the state of the current generator by 2^K values and +C resets the initial seed to that value. +C +C This is a transcription from Pascal to Fortran of routine +C Advance_State from the paper +C +C L'Ecuyer, P. and Cote, S. "Implementing a Random Number Package +C with Splitting Facilities." ACM Transactions on Mathematical +C Software, 17:98-111 (1991) +C +C +C Arguments +C +C +C K -> The generator is advanced by2^K values +C INTEGER K +C +C********************************************************************** +C .. Parameters .. + INTEGER numg + PARAMETER (numg=32) +C .. +C .. Scalar Arguments .. + INTEGER k +C .. +C .. Scalars in Common .. + INTEGER a1,a1vw,a1w,a2,a2vw,a2w,m1,m2 +C .. +C .. Arrays in Common .. + INTEGER cg1(numg),cg2(numg),ig1(numg),ig2(numg),lg1(numg), + + lg2(numg) + LOGICAL qanti(numg) +C .. +C .. Local Scalars .. + INTEGER g,i,ib1,ib2 +C .. +C .. External Functions .. + INTEGER mltmod + LOGICAL qrgnin + EXTERNAL mltmod,qrgnin +C .. +C .. External Subroutines .. + EXTERNAL getcgn,setsd +C .. +C .. Common blocks .. + COMMON /globe/m1,m2,a1,a2,a1w,a2w,a1vw,a2vw,ig1,ig2,lg1,lg2,cg1, + + cg2,qanti +C .. +C .. Save statement .. + SAVE /globe/ +C .. +C .. Executable Statements .. +C Abort unless random number generator initialized + IF (qrgnin()) GO TO 10 + WRITE (*,*) ' ADVNST called before random number generator ', + + ' initialized -- abort!' + CALL XSTOPX + + (' ADVNST called before random number generator initialized') + + 10 CALL getcgn(g) +C + ib1 = a1 + ib2 = a2 + DO 20,i = 1,k + ib1 = mltmod(ib1,ib1,m1) + ib2 = mltmod(ib2,ib2,m2) + 20 CONTINUE + CALL setsd(mltmod(ib1,cg1(g),m1),mltmod(ib2,cg2(g),m2)) +C +C NOW, IB1 = A1**K AND IB2 = A2**K +C + RETURN + + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/ranlib/genbet.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,249 @@ + REAL FUNCTION genbet(aa,bb) +C********************************************************************** +C +C REAL FUNCTION GENBET( A, B ) +C GeNerate BETa random deviate +C +C +C Function +C +C +C Returns a single random deviate from the beta distribution with +C parameters A and B. The density of the beta is +C x^(a-1) * (1-x)^(b-1) / B(a,b) for 0 < x < 1 +C +C +C Arguments +C +C +C A --> First parameter of the beta distribution +C REAL A +C JJV (A > 1.0E-37) +C +C B --> Second parameter of the beta distribution +C REAL B +C JJV (B > 1.0E-37) +C +C +C Method +C +C +C R. C. H. Cheng +C Generating Beta Variates with Nonintegral Shape Parameters +C Communications of the ACM, 21:317-322 (1978) +C (Algorithms BB and BC) +C +C********************************************************************** +C .. Parameters .. +C Close to the largest number that can be exponentiated + REAL expmax +C JJV changed this - 89 was too high, and LOG(1.0E38) = 87.49823 + PARAMETER (expmax=87.49823) +C Close to the largest representable single precision number + REAL infnty + PARAMETER (infnty=1.0E38) +C JJV added the parameter minlog +C Close to the smallest number of which a LOG can be taken. + REAL minlog + PARAMETER (minlog=1.0E-37) +C .. +C .. Scalar Arguments .. + REAL aa,bb +C .. +C .. Local Scalars .. + REAL a,alpha,b,beta,delta,gamma,k1,k2,olda,oldb,r,s,t,u1,u2,v,w,y, + + z + LOGICAL qsame +C .. +C .. External Functions .. + REAL ranf + EXTERNAL ranf +C .. +C .. Intrinsic Functions .. + INTRINSIC exp,log,max,min,sqrt +C .. +C .. Save statement .. +C JJV added a,b + SAVE olda,oldb,alpha,beta,gamma,k1,k2,a,b +C .. +C .. Data statements .. +C JJV changed these to ridiculous values + DATA olda,oldb/-1.0E37,-1.0E37/ +C .. +C .. Executable Statements .. + qsame = (olda.EQ.aa) .AND. (oldb.EQ.bb) + IF (qsame) GO TO 20 +C JJV added small minimum for small log problem in calc of W + IF (.NOT. (aa.LT.minlog.OR.bb.LT.minlog)) GO TO 10 + WRITE (*,*) ' AA or BB < ',minlog,' in GENBET - Abort!' + WRITE (*,*) ' AA: ',aa,' BB ',bb + CALL XSTOPX (' AA or BB too small in GENBET - Abort!') + + 10 olda = aa + oldb = bb + 20 IF (.NOT. (min(aa,bb).GT.1.0)) GO TO 100 + + +C Alborithm BB + +C +C Initialize +C + IF (qsame) GO TO 30 + a = min(aa,bb) + b = max(aa,bb) + alpha = a + b + beta = sqrt((alpha-2.0)/ (2.0*a*b-alpha)) + gamma = a + 1.0/beta + 30 CONTINUE + 40 u1 = ranf() +C +C Step 1 +C + u2 = ranf() + v = beta*log(u1/ (1.0-u1)) +C JJV altered this + IF (v.GT.expmax) GO TO 55 +C JJV added checker to see if a*exp(v) will overflow +C JJV 50 _was_ w = a*exp(v); also note here a > 1.0 + 50 w = exp(v) + IF (w.GT.infnty/a) GO TO 55 + w = a*w + GO TO 60 + 55 w = infnty + + 60 z = u1**2*u2 + r = gamma*v - 1.3862944 + s = a + r - w +C +C Step 2 +C + IF ((s+2.609438).GE. (5.0*z)) GO TO 70 +C +C Step 3 +C + t = log(z) + IF (s.GT.t) GO TO 70 +C +C Step 4 +C +C JJV added checker to see if log(alpha/(b+w)) will +C JJV overflow. If so, we count the log as -INF, and +C JJV consequently evaluate conditional as true, i.e. +C JJV the algorithm rejects the trial and starts over +C JJV May not need this here since ALPHA > 2.0 + IF (alpha/(b+w).LT.minlog) GO TO 40 + + IF ((r+alpha*log(alpha/ (b+w))).LT.t) GO TO 40 +C +C Step 5 +C + 70 IF (.NOT. (aa.EQ.a)) GO TO 80 + genbet = w/ (b+w) + GO TO 90 + + 80 genbet = b/ (b+w) + 90 GO TO 230 + + +C Algorithm BC + +C +C Initialize +C + 100 IF (qsame) GO TO 110 + a = max(aa,bb) + b = min(aa,bb) + alpha = a + b + beta = 1.0/b + delta = 1.0 + a - b + k1 = delta* (0.0138889+0.0416667*b)/ (a*beta-0.777778) + k2 = 0.25 + (0.5+0.25/delta)*b + 110 CONTINUE + 120 u1 = ranf() +C +C Step 1 +C + u2 = ranf() + IF (u1.GE.0.5) GO TO 130 +C +C Step 2 +C + y = u1*u2 + z = u1*y + IF ((0.25*u2+z-y).GE.k1) GO TO 120 + GO TO 170 +C +C Step 3 +C + 130 z = u1**2*u2 + IF (.NOT. (z.LE.0.25)) GO TO 160 + v = beta*log(u1/ (1.0-u1)) + +C JJV instead of checking v > expmax at top, I will check +C JJV if a < 1, then check the appropriate values + + IF (a.GT.1.0) GO TO 135 +C JJV A < 1 so it can help out if EXP(V) would overflow + IF (v.GT.expmax) GO TO 132 + w = a*exp(v) + GO TO 200 + 132 w = v + log(a) + IF (w.GT.expmax) GO TO 140 + w = exp(w) + GO TO 200 + +C JJV in this case A > 1 + 135 IF (v.GT.expmax) GO TO 140 + w = exp(v) + IF (w.GT.infnty/a) GO TO 140 + w = a*w + GO TO 200 + 140 w = infnty + GO TO 200 + + 160 IF (z.GE.k2) GO TO 120 +C +C Step 4 +C +C +C Step 5 +C + 170 v = beta*log(u1/ (1.0-u1)) + +C JJV same kind of checking as above + IF (a.GT.1.0) GO TO 175 +C JJV A < 1 so it can help out if EXP(V) would overflow + IF (v.GT.expmax) GO TO 172 + w = a*exp(v) + GO TO 190 + 172 w = v + log(a) + IF (w.GT.expmax) GO TO 180 + w = exp(w) + GO TO 190 + +C JJV in this case A > 1 + 175 IF (v.GT.expmax) GO TO 180 + w = exp(v) + IF (w.GT.infnty/a) GO TO 180 + w = a*w + GO TO 190 + + 180 w = infnty + +C JJV here we also check to see if log overlows; if so, we treat it +C JJV as -INF, which means condition is true, i.e. restart + 190 IF (alpha/(b+w).LT.minlog) GO TO 120 + IF ((alpha* (log(alpha/ (b+w))+v)-1.3862944).LT.log(z)) GO TO 120 +C +C Step 6 +C + 200 IF (.NOT. (a.EQ.aa)) GO TO 210 + genbet = w/ (b+w) + GO TO 220 + + 210 genbet = b/ (b+w) + 220 CONTINUE + 230 RETURN + + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/ranlib/genchi.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,49 @@ + REAL FUNCTION genchi(df) +C********************************************************************** +C +C REAL FUNCTION GENCHI( DF ) +C Generate random value of CHIsquare variable +C +C +C Function +C +C +C Generates random deviate from the distribution of a chisquare +C with DF degrees of freedom random variable. +C +C +C Arguments +C +C +C DF --> Degrees of freedom of the chisquare +C (Must be positive) +C REAL DF +C +C +C Method +C +C +C Uses relation between chisquare and gamma. +C +C********************************************************************** +C .. Scalar Arguments .. + REAL df +C .. +C .. External Functions .. +C REAL gengam +C EXTERNAL gengam + REAL sgamma + EXTERNAL sgamma +C .. +C .. Executable Statements .. + IF (.NOT. (df.LE.0.0)) GO TO 10 + WRITE (*,*) 'DF <= 0 in GENCHI - ABORT' + WRITE (*,*) 'Value of DF: ',df + CALL XSTOPX ('DF <= 0 in GENCHI - ABORT') + +C JJV changed this to call sgamma directly +C 10 genchi = 2.0*gengam(1.0,df/2.0) + 10 genchi = 2.0*sgamma(df/2.0) + RETURN + + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/ranlib/genexp.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,60 @@ + REAL FUNCTION genexp(av) + +C********************************************************************** +C +C REAL FUNCTION GENEXP( AV ) +C +C GENerate EXPonential random deviate +C +C +C Function +C +C +C Generates a single random deviate from an exponential +C distribution with mean AV. +C +C +C Arguments +C +C +C AV --> The mean of the exponential distribution from which +C a random deviate is to be generated. +C REAL AV +C JJV (AV >= 0) +C +C GENEXP <-- The random deviate. +C REAL GENEXP +C +C +C Method +C +C +C Renames SEXPO from TOMS as slightly modified by BWB to use RANF +C instead of SUNIF. +C +C For details see: +C +C Ahrens, J.H. and Dieter, U. +C Computer Methods for Sampling From the +C Exponential and Normal Distributions. +C Comm. ACM, 15,10 (Oct. 1972), 873 - 882. +C +C********************************************************************** +C .. Scalar Arguments .. + REAL av +C .. +C .. External Functions .. + REAL sexpo + EXTERNAL sexpo +C .. +C .. Executable Statements .. +C JJV added check to ensure AV >= 0.0 + IF (av.GE.0.0) GO TO 10 + WRITE (*,*) 'AV < 0.0 in GENEXP - ABORT' + WRITE (*,*) 'Value of AV: ',av + CALL XSTOPX ('AV < 0.0 in GENEXP - ABORT') + + 10 genexp = sexpo()*av + RETURN + + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/ranlib/genf.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,72 @@ + REAL FUNCTION genf(dfn,dfd) +C********************************************************************** +C +C REAL FUNCTION GENF( DFN, DFD ) +C GENerate random deviate from the F distribution +C +C +C Function +C +C +C Generates a random deviate from the F (variance ratio) +C distribution with DFN degrees of freedom in the numerator +C and DFD degrees of freedom in the denominator. +C +C +C Arguments +C +C +C DFN --> Numerator degrees of freedom +C (Must be positive) +C REAL DFN +C DFD --> Denominator degrees of freedom +C (Must be positive) +C REAL DFD +C +C +C Method +C +C +C Directly generates ratio of chisquare variates +C +C********************************************************************** +C .. Scalar Arguments .. + REAL dfd,dfn +C .. +C .. Local Scalars .. + REAL xden,xnum +C .. +C JJV changed this code to call sgamma directly +C .. External Functions .. +C REAL genchi +C EXTERNAL genchi + REAL sgamma + EXTERNAL sgamma +C .. +C .. Executable Statements .. + IF (.NOT. (dfn.LE.0.0.OR.dfd.LE.0.0)) GO TO 10 + WRITE (*,*) 'Degrees of freedom nonpositive in GENF - abort!' + WRITE (*,*) 'DFN value: ',dfn,'DFD value: ',dfd + CALL XSTOPX ('Degrees of freedom nonpositive in GENF - abort!') + + 10 xnum = 2.0*sgamma(dfn/2.0)/dfn + +C GENF = ( GENCHI( DFN ) / DFN ) / ( GENCHI( DFD ) / DFD ) + xden = 2.0*sgamma(dfd/2.0)/dfd +C JJV changed constant so that it will not underflow at compile time +C JJV while not slowing generator by using double precision or logs. +C IF (.NOT. (xden.LE. (1.0E-38*xnum))) GO TO 20 + IF (.NOT. (xden.LE. (1.0E-37*xnum))) GO TO 20 + WRITE (*,*) ' GENF - generated numbers would cause overflow' + WRITE (*,*) ' Numerator ',xnum,' Denominator ',xden +C JJV next 2 lines changed to maintain truncation of large deviates. +C WRITE (*,*) ' GENF returning 1.0E38' +C genf = 1.0E38 + WRITE (*,*) ' GENF returning 1.0E37' + genf = 1.0E37 + GO TO 30 + + 20 genf = xnum/xden + 30 RETURN + + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/ranlib/gengam.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,72 @@ + REAL FUNCTION gengam(a,r) +C********************************************************************** +C +C REAL FUNCTION GENGAM( A, R ) +C GENerates random deviates from GAMma distribution +C +C +C Function +C +C +C Generates random deviates from the gamma distribution whose +C density is +C (A**R)/Gamma(R) * X**(R-1) * Exp(-A*X) +C +C +C Arguments +C +C +C JJV added the argument ranges supported +C A --> Location parameter of Gamma distribution +C REAL A ( A > 0 ) +C +C R --> Shape parameter of Gamma distribution +C REAL R ( R > 0 ) +C +C +C Method +C +C +C Renames SGAMMA from TOMS as slightly modified by BWB to use RANF +C instead of SUNIF. +C +C For details see: +C (Case R >= 1.0) +C Ahrens, J.H. and Dieter, U. +C Generating Gamma Variates by a +C Modified Rejection Technique. +C Comm. ACM, 25,1 (Jan. 1982), 47 - 54. +C Algorithm GD +C +C JJV altered the following to reflect sgamma argument ranges +C (Case 0.0 < R < 1.0) +C Ahrens, J.H. and Dieter, U. +C Computer Methods for Sampling from Gamma, +C Beta, Poisson and Binomial Distributions. +C Computing, 12 (1974), 223-246/ +C Adapted algorithm GS. +C +C********************************************************************** +C .. Scalar Arguments .. + REAL a,r +C .. +C .. External Functions .. + REAL sgamma + EXTERNAL sgamma +C .. +C .. Executable Statements .. + +C JJV added argument value checker + IF ( a.GT.0.0 .AND. r.GT.0.0 ) GO TO 10 + WRITE (*,*) 'In GENGAM - Either (1) Location param A <= 0.0 or' + WRITE (*,*) '(2) Shape param R <= 0.0 - ABORT!' + WRITE (*,*) 'A value: ',a,'R value: ',r + CALL XSTOPX + + ('Location or shape param out of range in GENGAM - ABORT!') +C JJV end addition + + 10 gengam = sgamma(r)/a +C gengam = gengam/a + RETURN + + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/ranlib/genmn.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,82 @@ + SUBROUTINE genmn(parm,x,work) +C********************************************************************** +C +C SUBROUTINE GENMN(PARM,X,WORK) +C GENerate Multivariate Normal random deviate +C +C +C Arguments +C +C +C PARM --> Parameters needed to generate multivariate normal +C deviates (MEANV and Cholesky decomposition of +C COVM). Set by a previous call to SETGMN. +C 1 : 1 - size of deviate, P +C 2 : P + 1 - mean vector +C P+2 : P*(P+3)/2 + 1 - upper half of cholesky +C decomposition of cov matrix +C REAL PARM(*) +C +C X <-- Vector deviate generated. +C REAL X(P) +C +C WORK <--> Scratch array +C REAL WORK(P) +C +C +C Method +C +C +C 1) Generate P independent standard normal deviates - Ei ~ N(0,1) +C +C 2) Using Cholesky decomposition find A s.t. trans(A)*A = COVM +C +C 3) trans(A)E + MEANV ~ N(MEANV,COVM) +C +C********************************************************************** +C .. Array Arguments .. + REAL parm(*),work(*),x(*) +C .. +C .. Local Scalars .. + REAL ae + INTEGER i,icount,j,p +C .. +C .. External Functions .. + REAL snorm + EXTERNAL snorm +C .. +C .. Intrinsic Functions .. + INTRINSIC int +C .. +C .. Executable Statements .. + p = int(parm(1)) +C +C Generate P independent normal deviates - WORK ~ N(0,1) +C + DO 10,i = 1,p + work(i) = snorm() + 10 CONTINUE + DO 30,i = 1,p +C +C PARM (P+2 : P*(P+3)/2 + 1) contains A, the Cholesky +C decomposition of the desired covariance matrix. +C trans(A)(1,1) = PARM(P+2) +C trans(A)(2,1) = PARM(P+3) +C trans(A)(2,2) = PARM(P+2+P) +C trans(A)(3,1) = PARM(P+4) +C trans(A)(3,2) = PARM(P+3+P) +C trans(A)(3,3) = PARM(P+2-1+2P) ... +C +C trans(A)*WORK + MEANV ~ N(MEANV,COVM) +C + icount = 0 + ae = 0.0 + DO 20,j = 1,i + icount = icount + j - 1 + ae = ae + parm(i+ (j-1)*p-icount+p+1)*work(j) + 20 CONTINUE + x(i) = ae + parm(i+1) + 30 CONTINUE + RETURN +C + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/ranlib/genmul.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,92 @@ + SUBROUTINE genmul(n,p,ncat,ix) +C********************************************************************** +C +C SUBROUTINE GENMUL( N, P, NCAT, IX ) +C GENerate an observation from the MULtinomial distribution +C +C +C Arguments +C +C +C N --> Number of events that will be classified into one of +C the categories 1..NCAT +C INTEGER N +C +C P --> Vector of probabilities. P(i) is the probability that +C an event will be classified into category i. Thus, P(i) +C must be [0,1]. Only the first NCAT-1 P(i) must be defined +C since P(NCAT) is 1.0 minus the sum of the first +C NCAT-1 P(i). +C REAL P(NCAT-1) +C +C NCAT --> Number of categories. Length of P and IX. +C INTEGER NCAT +C +C IX <-- Observation from multinomial distribution. All IX(i) +C will be nonnegative and their sum will be N. +C INTEGER IX(NCAT) +C +C +C Method +C +C +C Algorithm from page 559 of +C +C Devroye, Luc +C +C Non-Uniform Random Variate Generation. Springer-Verlag, +C New York, 1986. +C +C********************************************************************** +C .. Scalar Arguments .. + INTEGER n,ncat +C .. +C .. Array Arguments .. + REAL p(*) + INTEGER ix(*) +C .. +C .. Local Scalars .. + REAL prob,ptot,sum + INTEGER i,icat,ntot +C .. +C .. External Functions .. + INTEGER ignbin + EXTERNAL ignbin +C .. +C .. Intrinsic Functions .. + INTRINSIC abs +C .. +C .. Executable Statements .. + +C Check Arguments + IF (n.LT.0) CALL XSTOPX ('N < 0 in GENMUL') + IF (ncat.LE.1) CALL XSTOPX ('NCAT <= 1 in GENMUL') + ptot = 0.0 + DO 10,i = 1,ncat - 1 + IF (p(i).LT.0.0) CALL XSTOPX ('Some P(i) < 0 in GENMUL') + IF (p(i).GT.1.0) CALL XSTOPX ('Some P(i) > 1 in GENMUL') + ptot = ptot + p(i) + 10 CONTINUE + IF (ptot.GT.0.99999) CALL XSTOPX ('Sum of P(i) > 1 in GENMUL') + +C Initialize variables + ntot = n + sum = 1.0 + DO 20,i = 1,ncat + ix(i) = 0 + 20 CONTINUE + +C Generate the observation + DO 30,icat = 1,ncat - 1 + prob = p(icat)/sum + ix(icat) = ignbin(ntot,prob) + ntot = ntot - ix(icat) + IF (ntot.LE.0) RETURN + sum = sum - p(icat) + 30 CONTINUE + ix(ncat) = ntot + +C Finished + RETURN + + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/ranlib/gennch.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,69 @@ + REAL FUNCTION gennch(df,xnonc) +C********************************************************************** +C +C REAL FUNCTION GENNCH( DF, XNONC ) +C Generate random value of Noncentral CHIsquare variable +C +C +C Function +C +C + +C Generates random deviate from the distribution of a noncentral +C chisquare with DF degrees of freedom and noncentrality parameter +C XNONC. +C +C +C Arguments +C +C +C DF --> Degrees of freedom of the chisquare +C (Must be >= 1.0) +C REAL DF +C +C XNONC --> Noncentrality parameter of the chisquare +C (Must be >= 0.0) +C REAL XNONC +C +C +C Method +C +C +C Uses fact that noncentral chisquare is the sum of a chisquare +C deviate with DF-1 degrees of freedom plus the square of a normal +C deviate with mean sqrt(XNONC) and standard deviation 1. +C +C********************************************************************** +C .. Scalar Arguments .. + REAL df,xnonc +C .. +C .. External Functions .. +C JJV changed these to call SGAMMA and SNORM directly +C REAL genchi,gennor +C EXTERNAL genchi,gennor + REAL sgamma,snorm + EXTERNAL sgamma,snorm +C .. +C .. Intrinsic Functions .. + INTRINSIC sqrt +C .. +C JJV changed abort to df < 1, and added case: df = 1 +C .. Executable Statements .. + IF (.NOT. (df.LT.1.0.OR.xnonc.LT.0.0)) GO TO 10 + WRITE (*,*) 'DF < 1 or XNONC < 0 in GENNCH - ABORT' + WRITE (*,*) 'Value of DF: ',df,' Value of XNONC',xnonc + CALL XSTOPX ('DF < 1 or XNONC < 0 in GENNCH - ABORT') + +C JJV changed this to call SGAMMA and SNORM directly +C gennch = genchi(df-1.0) + gennor(sqrt(xnonc),1.0)**2 + + 10 IF (df.GE.1.000001) GO TO 20 +C JJV case DF = 1.0 + gennch = (snorm() + sqrt(xnonc))**2 + GO TO 30 + +C JJV case DF > 1.0 + 20 gennch = 2.0*sgamma((df-1.0)/2.0) + (snorm() + sqrt(xnonc))**2 + 30 RETURN + + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/ranlib/gennf.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,98 @@ + REAL FUNCTION gennf(dfn,dfd,xnonc) + +C********************************************************************** +C +C REAL FUNCTION GENNF( DFN, DFD, XNONC ) +C GENerate random deviate from the Noncentral F distribution +C +C +C Function +C +C +C Generates a random deviate from the noncentral F (variance ratio) +C distribution with DFN degrees of freedom in the numerator, and DFD +C degrees of freedom in the denominator, and noncentrality parameter +C XNONC. +C +C +C Arguments +C +C +C DFN --> Numerator degrees of freedom +C (Must be >= 1.0) +C REAL DFN +C DFD --> Denominator degrees of freedom +C (Must be positive) +C REAL DFD +C +C XNONC --> Noncentrality parameter +C (Must be nonnegative) +C REAL XNONC +C +C +C Method +C +C +C Directly generates ratio of noncentral numerator chisquare variate +C to central denominator chisquare variate. +C +C********************************************************************** +C .. Scalar Arguments .. + REAL dfd,dfn,xnonc +C .. +C .. Local Scalars .. + REAL xden,xnum + LOGICAL qcond +C .. +C .. External Functions .. +C JJV changed the code to call SGAMMA and SNORM directly +C REAL genchi,gennch +C EXTERNAL genchi,gennch + REAL sgamma,snorm + EXTERNAL sgamma,snorm +C .. +C .. Executable Statements .. +C JJV changed the argument checker to allow DFN = 1.0 +C JJV in the same way as GENNCH was changed. + qcond = dfn .LT. 1.0 .OR. dfd .LE. 0.0 .OR. xnonc .LT. 0.0 + IF (.NOT. (qcond)) GO TO 10 + WRITE (*,*) 'In GENNF - Either (1) Numerator DF < 1.0 or' + WRITE (*,*) '(2) Denominator DF <= 0.0 or ' + WRITE (*,*) '(3) Noncentrality parameter < 0.0' + WRITE (*,*) 'DFN value: ',dfn,'DFD value: ',dfd,'XNONC value: ', + + xnonc + + CALL XSTOPX + + ('Degrees of freedom or noncent param out of range in GENNF') + +C GENNF = ( GENNCH( DFN, XNONC ) / DFN ) / ( GENCHI( DFD ) / DFD ) +C JJV changed this to call SGAMMA and SNORM directly +C xnum = gennch(dfn,xnonc)/dfn + 10 IF (dfn.GE.1.000001) GO TO 20 +C JJV case dfn = 1.0 - here I am treating dfn as exactly 1.0 + xnum = (snorm() + sqrt(xnonc))**2 + GO TO 30 + +C JJV case dfn > 1.0 + 20 xnum = (2.0*sgamma((dfn-1.0)/2.0) + (snorm()+sqrt(xnonc))**2)/dfn + +C xden = genchi(dfd)/dfd + 30 xden = 2.0*sgamma(dfd/2.0)/dfd + +C JJV changed constant so that it will not underflow at compile time +C JJV while not slowing generator by using double precision or logs. +C IF (.NOT. (xden.LE. (1.0E-38*xnum))) GO TO 40 + IF (.NOT. (xden.LE. (1.0E-37*xnum))) GO TO 40 + WRITE (*,*) ' GENNF - generated numbers would cause overflow' + WRITE (*,*) ' Numerator ',xnum,' Denominator ',xden +C JJV next 2 lines changed to maintain truncation of large deviates. +C WRITE (*,*) ' GENNF returning 1.0E38' +C gennf = 1.0E38 + WRITE (*,*) ' GENNF returning 1.0E37' + gennf = 1.0E37 + GO TO 50 + + 40 gennf = xnum/xden + 50 RETURN + + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/ranlib/gennor.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,61 @@ + REAL FUNCTION gennor(av,sd) +C********************************************************************** +C +C REAL FUNCTION GENNOR( AV, SD ) +C +C GENerate random deviate from a NORmal distribution +C +C +C Function +C +C +C Generates a single random deviate from a normal distribution +C with mean, AV, and standard deviation, SD. +C +C +C Arguments +C +C +C AV --> Mean of the normal distribution. +C REAL AV +C +C SD --> Standard deviation of the normal distribution. +C REAL SD +C JJV (SD >= 0) +C +C GENNOR <-- Generated normal deviate. +C REAL GENNOR +C +C +C Method +C +C +C Renames SNORM from TOMS as slightly modified by BWB to use RANF +C instead of SUNIF. +C +C For details see: +C Ahrens, J.H. and Dieter, U. +C Extensions of Forsythe's Method for Random +C Sampling from the Normal Distribution. +C Math. Comput., 27,124 (Oct. 1973), 927 - 937. +C +C +C********************************************************************** +C .. Scalar Arguments .. + REAL av,sd +C .. +C .. External Functions .. + REAL snorm + EXTERNAL snorm +C .. +C .. Executable Statements .. +C JJV added check to ensure SD >= 0.0 + IF (sd.GE.0.0) GO TO 10 + WRITE (*,*) 'SD < 0.0 in GENNOR - ABORT' + WRITE (*,*) 'Value of SD: ',sd + CALL XSTOPX ('SD < 0.0 in GENNOR - ABORT') + + 10 gennor = sd*snorm() + av + RETURN + + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/ranlib/genprm.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,41 @@ + SUBROUTINE genprm(iarray,larray) +C********************************************************************** +C +C SUBROUTINE GENPRM( IARRAY, LARRAY ) +C GENerate random PeRMutation of iarray +C +C +C Arguments +C +C +C IARRAY <--> On output IARRAY is a random permutation of its +C value on input +C INTEGER IARRAY( LARRAY ) +C +C LARRAY <--> Length of IARRAY +C INTEGER LARRAY +C +C********************************************************************** +C .. Scalar Arguments .. + INTEGER larray +C .. +C .. Array Arguments .. + INTEGER iarray(larray) +C .. +C .. Local Scalars .. + INTEGER i,itmp,iwhich +C .. +C .. External Functions .. + INTEGER ignuin + EXTERNAL ignuin +C .. +C .. Executable Statements .. + DO 10,i = 1,larray + iwhich = ignuin(i,larray) + itmp = iarray(iwhich) + iarray(iwhich) = iarray(i) + iarray(i) = itmp + 10 CONTINUE + RETURN + + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/ranlib/genunf.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,42 @@ + REAL FUNCTION genunf(low,high) +C********************************************************************** +C +C REAL FUNCTION GENUNF( LOW, HIGH ) +C +C GeNerate Uniform Real between LOW and HIGH +C +C +C Function +C +C +C Generates a real uniformly distributed between LOW and HIGH. +C +C +C Arguments +C +C +C LOW --> Low bound (exclusive) on real value to be generated +C REAL LOW +C +C HIGH --> High bound (exclusive) on real value to be generated +C REAL HIGH +C +C********************************************************************** +C .. Scalar Arguments .. + REAL high,low +C .. +C .. External Functions .. + REAL ranf + EXTERNAL ranf +C .. +C .. Executable Statements .. + IF (.NOT. (low.GT.high)) GO TO 10 + WRITE (*,*) 'LOW > HIGH in GENUNF: LOW ',low,' HIGH: ',high + WRITE (*,*) 'Abort' + CALL XSTOPX ('LOW > High in GENUNF - Abort') + + 10 genunf = low + (high-low)*ranf() + + RETURN + + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/ranlib/getcgn.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,55 @@ + SUBROUTINE getcgn(g) + INTEGER g +C********************************************************************** +C +C SUBROUTINE GETCGN(G) +C Get GeNerator +C +C Returns in G the number of the current random number generator +C +C +C Arguments +C +C +C G <-- Number of the current random number generator (1..32) +C INTEGER G +C +C********************************************************************** +C + INTEGER curntg,numg + SAVE curntg + PARAMETER (numg=32) + DATA curntg/1/ +C + g = curntg + RETURN + + ENTRY setcgn(g) +C********************************************************************** +C +C SUBROUTINE SETCGN( G ) +C Set GeNerator +C +C Sets the current generator to G. All references to a generat +C are to the current generator. +C +C +C Arguments +C +C +C G --> Number of the current random number generator (1..32) +C INTEGER G +C +C********************************************************************** +C +C Abort if generator number out of range +C + IF (.NOT. (g.LT.0.OR.g.GT.numg)) GO TO 10 + WRITE (*,*) ' Generator number out of range in SETCGN:', + + ' Legal range is 1 to ',numg,' -- ABORT!' + CALL XSTOPX (' Generator number out of range in SETCGN') + + 10 curntg = g + RETURN + + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/ranlib/getsd.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,73 @@ + SUBROUTINE getsd(iseed1,iseed2) +C********************************************************************** +C +C SUBROUTINE GETSD(G,ISEED1,ISEED2) +C GET SeeD +C +C Returns the value of two integer seeds of the current generator +C +C This is a transcription from Pascal to Fortran of routine +C Get_State from the paper +C +C L'Ecuyer, P. and Cote, S. "Implementing a Random Number Package +C with Splitting Facilities." ACM Transactions on Mathematical +C Software, 17:98-111 (1991) +C +C +C Arguments +C +C +C +C ISEED1 <- First integer seed of generator G +C INTEGER ISEED1 +C +C ISEED2 <- Second integer seed of generator G +C INTEGER ISEED1 +C +C********************************************************************** +C .. Parameters .. + INTEGER numg + PARAMETER (numg=32) +C .. +C .. Scalar Arguments .. + INTEGER iseed1,iseed2 +C .. +C .. Scalars in Common .. + INTEGER a1,a1vw,a1w,a2,a2vw,a2w,m1,m2 +C .. +C .. Arrays in Common .. + INTEGER cg1(numg),cg2(numg),ig1(numg),ig2(numg),lg1(numg), + + lg2(numg) + LOGICAL qanti(numg) +C .. +C .. Local Scalars .. + INTEGER g +C .. +C .. External Functions .. + LOGICAL qrgnin + EXTERNAL qrgnin +C .. +C .. External Subroutines .. + EXTERNAL getcgn +C .. +C .. Common blocks .. + COMMON /globe/m1,m2,a1,a2,a1w,a2w,a1vw,a2vw,ig1,ig2,lg1,lg2,cg1, + + cg2,qanti +C .. +C .. Save statement .. + SAVE /globe/ +C .. +C .. Executable Statements .. +C Abort unless random number generator initialized + IF (qrgnin()) GO TO 10 + WRITE (*,*) ' GETSD called before random number generator ', + + ' initialized -- abort!' + CALL XSTOPX + + (' GETSD called before random number generator initialized') + + 10 CALL getcgn(g) + iseed1 = cg1(g) + iseed2 = cg2(g) + RETURN + + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/ranlib/ignbin.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,325 @@ + INTEGER FUNCTION ignbin(n,pp) +C********************************************************************** +C +C INTEGER FUNCTION IGNBIN( N, PP ) +C +C GENerate BINomial random deviate +C +C +C Function +C +C +C Generates a single random deviate from a binomial +C distribution whose number of trials is N and whose +C probability of an event in each trial is P. +C +C +C Arguments +C +C +C N --> The number of trials in the binomial distribution +C from which a random deviate is to be generated. +C INTEGER N +C JJV (N >= 0) +C +C PP --> The probability of an event in each trial of the +C binomial distribution from which a random deviate +C is to be generated. +C REAL PP +C JJV (0.0 <= pp <= 1.0) +C +C IGNBIN <-- A random deviate yielding the number of events +C from N independent trials, each of which has +C a probability of event P. +C INTEGER IGNBIN +C +C +C Note +C +C +C Uses RANF so the value of the seeds, ISEED1 and ISEED2 must be set +C by a call similar to the following +C DUM = RANSET( ISEED1, ISEED2 ) +C +C +C Method +C +C +C This is algorithm BTPE from: +C +C Kachitvichyanukul, V. and Schmeiser, B. W. +C +C Binomial Random Variate Generation. +C Communications of the ACM, 31, 2 +C (February, 1988) 216. +C +C********************************************************************** +C SUBROUTINE BTPEC(N,PP,ISEED,JX) +C +C BINOMIAL RANDOM VARIATE GENERATOR +C MEAN .LT. 30 -- INVERSE CDF +C MEAN .GE. 30 -- ALGORITHM BTPE: ACCEPTANCE-REJECTION VIA +C FOUR REGION COMPOSITION. THE FOUR REGIONS ARE A TRIANGLE +C (SYMMETRIC IN THE CENTER), A PAIR OF PARALLELOGRAMS (ABOVE +C THE TRIANGLE), AND EXPONENTIAL LEFT AND RIGHT TAILS. +C +C BTPE REFERS TO BINOMIAL-TRIANGLE-PARALLELOGRAM-EXPONENTIAL. +C BTPEC REFERS TO BTPE AND "COMBINED." THUS BTPE IS THE +C RESEARCH AND BTPEC IS THE IMPLEMENTATION OF A COMPLETE +C USABLE ALGORITHM. +C REFERENCE: VORATAS KACHITVICHYANUKUL AND BRUCE SCHMEISER, +C "BINOMIAL RANDOM VARIATE GENERATION," +C COMMUNICATIONS OF THE ACM, FORTHCOMING +C WRITTEN: SEPTEMBER 1980. +C LAST REVISED: MAY 1985, JULY 1987 +C REQUIRED SUBPROGRAM: RAND() -- A UNIFORM (0,1) RANDOM NUMBER +C GENERATOR +C ARGUMENTS +C +C N : NUMBER OF BERNOULLI TRIALS (INPUT) +C PP : PROBABILITY OF SUCCESS IN EACH TRIAL (INPUT) +C ISEED: RANDOM NUMBER SEED (INPUT AND OUTPUT) +C JX: RANDOMLY GENERATED OBSERVATION (OUTPUT) +C +C VARIABLES +C PSAVE: VALUE OF PP FROM THE LAST CALL TO BTPEC +C NSAVE: VALUE OF N FROM THE LAST CALL TO BTPEC +C XNP: VALUE OF THE MEAN FROM THE LAST CALL TO BTPEC +C +C P: PROBABILITY USED IN THE GENERATION PHASE OF BTPEC +C FFM: TEMPORARY VARIABLE EQUAL TO XNP + P +C M: INTEGER VALUE OF THE CURRENT MODE +C FM: FLOATING POINT VALUE OF THE CURRENT MODE +C XNPQ: TEMPORARY VARIABLE USED IN SETUP AND SQUEEZING STEPS +C P1: AREA OF THE TRIANGLE +C C: HEIGHT OF THE PARALLELOGRAMS +C XM: CENTER OF THE TRIANGLE +C XL: LEFT END OF THE TRIANGLE +C XR: RIGHT END OF THE TRIANGLE +C AL: TEMPORARY VARIABLE +C XLL: RATE FOR THE LEFT EXPONENTIAL TAIL +C XLR: RATE FOR THE RIGHT EXPONENTIAL TAIL +C P2: AREA OF THE PARALLELOGRAMS +C P3: AREA OF THE LEFT EXPONENTIAL TAIL +C P4: AREA OF THE RIGHT EXPONENTIAL TAIL +C U: A U(0,P4) RANDOM VARIATE USED FIRST TO SELECT ONE OF THE +C FOUR REGIONS AND THEN CONDITIONALLY TO GENERATE A VALUE +C FROM THE REGION +C V: A U(0,1) RANDOM NUMBER USED TO GENERATE THE RANDOM VALUE +C (REGION 1) OR TRANSFORMED INTO THE VARIATE TO ACCEPT OR +C REJECT THE CANDIDATE VALUE +C IX: INTEGER CANDIDATE VALUE +C X: PRELIMINARY CONTINUOUS CANDIDATE VALUE IN REGION 2 LOGIC +C AND A FLOATING POINT IX IN THE ACCEPT/REJECT LOGIC +C K: ABSOLUTE VALUE OF (IX-M) +C F: THE HEIGHT OF THE SCALED DENSITY FUNCTION USED IN THE +C ACCEPT/REJECT DECISION WHEN BOTH M AND IX ARE SMALL +C ALSO USED IN THE INVERSE TRANSFORMATION +C R: THE RATIO P/Q +C G: CONSTANT USED IN CALCULATION OF PROBABILITY +C MP: MODE PLUS ONE, THE LOWER INDEX FOR EXPLICIT CALCULATION +C OF F WHEN IX IS GREATER THAN M +C IX1: CANDIDATE VALUE PLUS ONE, THE LOWER INDEX FOR EXPLICIT +C CALCULATION OF F WHEN IX IS LESS THAN M +C I: INDEX FOR EXPLICIT CALCULATION OF F FOR BTPE +C AMAXP: MAXIMUM ERROR OF THE LOGARITHM OF NORMAL BOUND +C YNORM: LOGARITHM OF NORMAL BOUND +C ALV: NATURAL LOGARITHM OF THE ACCEPT/REJECT VARIATE V +C +C X1,F1,Z,W,Z2,X2,F2, AND W2 ARE TEMPORARY VARIABLES TO BE +C USED IN THE FINAL ACCEPT/REJECT TEST +C +C QN: PROBABILITY OF NO SUCCESS IN N TRIALS +C +C REMARK +C IX AND JX COULD LOGICALLY BE THE SAME VARIABLE, WHICH WOULD +C SAVE A MEMORY POSITION AND A LINE OF CODE. HOWEVER, SOME +C COMPILERS (E.G.,CDC MNF) OPTIMIZE BETTER WHEN THE ARGUMENTS +C ARE NOT INVOLVED. +C +C ISEED NEEDS TO BE DOUBLE PRECISION IF THE IMSL ROUTINE +C GGUBFS IS USED TO GENERATE UNIFORM RANDOM NUMBER, OTHERWISE +C TYPE OF ISEED SHOULD BE DICTATED BY THE UNIFORM GENERATOR +C +C********************************************************************** + +C +C +C +C*****DETERMINE APPROPRIATE ALGORITHM AND WHETHER SETUP IS NECESSARY +C +C .. +C .. Scalar Arguments .. + REAL pp + INTEGER n +C .. +C .. Local Scalars .. + REAL al,alv,amaxp,c,f,f1,f2,ffm,fm,g,p,p1,p2,p3,p4,psave,q,qn,r,u, + + v,w,w2,x,x1,x2,xl,xll,xlr,xm,xnp,xnpq,xr,ynorm,z,z2 + INTEGER i,ix,ix1,k,m,mp,nsave +C .. +C .. External Functions .. + REAL ranf + EXTERNAL ranf +C .. +C .. Intrinsic Functions .. + INTRINSIC abs,alog,amin1,iabs,int,sqrt +C JJV .. +C JJV .. Save statement .. + SAVE p,q,m,fm,xnp,xnpq,p1,xm,xl,xr,c,xll,xlr,p2,p3,p4,qn,r,g, + + psave,nsave +C JJV I am including the variables in data statements +C .. +C .. Data statements .. +C JJV made these ridiculous starting values - the hope is that +C JJV no one will call this the first time with them as args + DATA psave,nsave/-1.0E37,-214748365/ +C .. +C .. Executable Statements .. + IF (pp.NE.psave) GO TO 10 + IF (n.NE.nsave) GO TO 20 + IF (xnp-30.0.LT.0.0) GO TO 150 + GO TO 30 +C +C*****SETUP, PERFORM ONLY WHEN PARAMETERS CHANGE +C + +C JJV added the argument checker - involved only renaming 10 +C JJV and 20 to the checkers and adding checkers +C JJV Only remaining problem - if called initially with the +C JJV initial values of psave and nsave, it will hang + 10 IF (pp.LT.0.0) CALL XSTOPX ('PP < 0.0 in IGNBIN - ABORT!') + IF (pp.GT.1.0) CALL XSTOPX ('PP > 1.0 in IGNBIN - ABORT!') + psave = pp + p = amin1(psave,1.-psave) + q = 1. - p + 20 IF (n.LT.0) CALL XSTOPX ('N < 0 in IGNBIN - ABORT!') + xnp = n*p + nsave = n + IF (xnp.LT.30.) GO TO 140 + ffm = xnp + p + m = ffm + fm = m + xnpq = xnp*q + p1 = int(2.195*sqrt(xnpq)-4.6*q) + 0.5 + xm = fm + 0.5 + xl = xm - p1 + xr = xm + p1 + c = 0.134 + 20.5/ (15.3+fm) + al = (ffm-xl)/ (ffm-xl*p) + xll = al* (1.+.5*al) + al = (xr-ffm)/ (xr*q) + xlr = al* (1.+.5*al) + p2 = p1* (1.+c+c) + p3 = p2 + c/xll + p4 = p3 + c/xlr +C WRITE(6,100) N,P,P1,P2,P3,P4,XL,XR,XM,FM +C 100 FORMAT(I15,4F18.7/5F18.7) +C +C*****GENERATE VARIATE +C + 30 u = ranf()*p4 + v = ranf() +C +C TRIANGULAR REGION +C + IF (u.GT.p1) GO TO 40 + ix = xm - p1*v + u + GO TO 170 +C +C PARALLELOGRAM REGION +C + 40 IF (u.GT.p2) GO TO 50 + x = xl + (u-p1)/c + v = v*c + 1. - abs(xm-x)/p1 + IF (v.GT.1. .OR. v.LE.0.) GO TO 30 + ix = x + GO TO 70 +C +C LEFT TAIL +C + 50 IF (u.GT.p3) GO TO 60 + ix = xl + alog(v)/xll + IF (ix.LT.0) GO TO 30 + v = v* (u-p2)*xll + GO TO 70 +C +C RIGHT TAIL +C + 60 ix = xr - alog(v)/xlr + IF (ix.GT.n) GO TO 30 + v = v* (u-p3)*xlr +C +C*****DETERMINE APPROPRIATE WAY TO PERFORM ACCEPT/REJECT TEST +C + 70 k = iabs(ix-m) + IF (k.GT.20 .AND. k.LT.xnpq/2-1) GO TO 130 +C +C EXPLICIT EVALUATION +C + f = 1.0 + r = p/q + g = (n+1)*r + IF (m-ix.LT.0) GO TO 80 + IF (m-ix.EQ.0) GO TO 120 + GO TO 100 + 80 mp = m + 1 + DO 90 i = mp,ix + f = f* (g/i-r) + 90 CONTINUE + GO TO 120 + + 100 ix1 = ix + 1 + DO 110 i = ix1,m + f = f/ (g/i-r) + 110 CONTINUE + 120 IF (v-f.LE.0) GO TO 170 + GO TO 30 +C +C SQUEEZING USING UPPER AND LOWER BOUNDS ON ALOG(F(X)) +C + 130 amaxp = (k/xnpq)* ((k* (k/3.+.625)+.1666666666666)/xnpq+.5) + ynorm = -k*k/ (2.*xnpq) + alv = alog(v) + IF (alv.LT.ynorm-amaxp) GO TO 170 + IF (alv.GT.ynorm+amaxp) GO TO 30 +C +C STIRLING'S FORMULA TO MACHINE ACCURACY FOR +C THE FINAL ACCEPTANCE/REJECTION TEST +C + x1 = ix + 1 + f1 = fm + 1. + z = n + 1 - fm + w = n - ix + 1. + z2 = z*z + x2 = x1*x1 + f2 = f1*f1 + w2 = w*w + IF (alv- (xm*alog(f1/x1)+ (n-m+.5)*alog(z/w)+ (ix- + + m)*alog(w*p/ (x1*q))+ (13860.- (462.- (132.- (99.- + + 140./f2)/f2)/f2)/f2)/f1/166320.+ (13860.- (462.- (132.- (99.- + + 140./z2)/z2)/z2)/z2)/z/166320.+ (13860.- (462.- (132.- (99.- + + 140./x2)/x2)/x2)/x2)/x1/166320.+ (13860.- (462.- (132.- (99.- + + 140./w2)/w2)/w2)/w2)/w/166320.) .LE. 0.) GO TO 170 + GO TO 30 +C +C INVERSE CDF LOGIC FOR MEAN LESS THAN 30 +C + 140 qn = q**n + r = p/q + g = r* (n+1) + 150 ix = 0 + f = qn + u = ranf() + 160 IF (u.LT.f) GO TO 170 + IF (ix.GT.110) GO TO 150 + u = u - f + ix = ix + 1 + f = f* (g/ix-r) + GO TO 160 + + 170 IF (psave.GT.0.5) ix = n - ix + ignbin = ix + RETURN + + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/ranlib/ignlgi.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,77 @@ + INTEGER FUNCTION ignlgi() +C********************************************************************** +C +C INTEGER FUNCTION IGNLGI() +C GeNerate LarGe Integer +C +C Returns a random integer following a uniform distribution over +C (1, 2147483562) using the current generator. +C +C This is a transcription from Pascal to Fortran of routine +C Random from the paper +C +C L'Ecuyer, P. and Cote, S. "Implementing a Random Number Package +C with Splitting Facilities." ACM Transactions on Mathematical +C Software, 17:98-111 (1991) +C +C********************************************************************** +C .. Parameters .. + INTEGER numg + PARAMETER (numg=32) +C .. +C .. Scalars in Common .. + INTEGER a1,a1vw,a1w,a2,a2vw,a2w,m1,m2 +C .. +C .. Arrays in Common .. + INTEGER cg1(numg),cg2(numg),ig1(numg),ig2(numg),lg1(numg), + + lg2(numg) + LOGICAL qanti(numg) +C .. +C .. Local Scalars .. + INTEGER curntg,k,s1,s2,z + LOGICAL qqssd +C .. +C .. External Functions .. + LOGICAL qrgnin + EXTERNAL qrgnin +C .. +C .. External Subroutines .. + EXTERNAL getcgn,inrgcm,rgnqsd,setall +C .. +C .. Common blocks .. + COMMON /globe/m1,m2,a1,a2,a1w,a2w,a1vw,a2vw,ig1,ig2,lg1,lg2,cg1, + + cg2,qanti +C .. +C .. Save statement .. + SAVE /globe/ +C .. +C .. Executable Statements .. +C +C IF THE RANDOM NUMBER PACKAGE HAS NOT BEEN INITIALIZED YET, DO SO. +C IT CAN BE INITIALIZED IN ONE OF TWO WAYS : 1) THE FIRST CALL TO +C THIS ROUTINE 2) A CALL TO SETALL. +C + IF (.NOT. (qrgnin())) CALL inrgcm() + CALL rgnqsd(qqssd) + IF (.NOT. (qqssd)) CALL setall(1234567890,123456789) +C +C Get Current Generator +C + CALL getcgn(curntg) + s1 = cg1(curntg) + s2 = cg2(curntg) + k = s1/53668 + s1 = a1* (s1-k*53668) - k*12211 + IF (s1.LT.0) s1 = s1 + m1 + k = s2/52774 + s2 = a2* (s2-k*52774) - k*3791 + IF (s2.LT.0) s2 = s2 + m2 + cg1(curntg) = s1 + cg2(curntg) = s2 + z = s1 - s2 + IF (z.LT.1) z = z + m1 - 1 + IF (qanti(curntg)) z = m1 - z + ignlgi = z + RETURN + + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/ranlib/ignnbn.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,78 @@ + INTEGER FUNCTION ignnbn(n,p) +C********************************************************************** +C +C INTEGER FUNCTION IGNNBN( N, P ) +C +C GENerate Negative BiNomial random deviate +C +C +C Function +C +C +C Generates a single random deviate from a negative binomial +C distribution. +C +C +C Arguments +C +C +C N --> Required number of events. +C INTEGER N +C JJV (N > 0) +C +C P --> The probability of an event during a Bernoulli trial. +C REAL P +C JJV (0.0 < P < 1.0) +C +C +C +C Method +C +C +C Algorithm from page 480 of +C +C Devroye, Luc +C +C Non-Uniform Random Variate Generation. Springer-Verlag, +C New York, 1986. +C +C********************************************************************** +C .. +C .. Scalar Arguments .. + REAL p + INTEGER n +C .. +C .. Local Scalars .. + REAL y,a,r +C .. +C .. External Functions .. +C JJV changed to call SGAMMA directly +C REAL gengam + REAL sgamma + INTEGER ignpoi +C EXTERNAL gengam,ignpoi + EXTERNAL sgamma,ignpoi +C .. +C .. Intrinsic Functions .. + INTRINSIC real +C .. +C .. Executable Statements .. +C Check Arguments +C JJV changed argumnet checker to abort if N <= 0 + IF (n.LE.0) CALL XSTOPX ('N <= 0 in IGNNBN') + IF (p.LE.0.0) CALL XSTOPX ('P <= 0.0 in IGNNBN') + IF (p.GE.1.0) CALL XSTOPX ('P >= 1.0 in IGNNBN') + +C Generate Y, a random gamma (n,(1-p)/p) variable +C JJV Note: the above parametrization is consistent with Devroye, +C JJV but gamma (p/(1-p),n) is the equivalent in our code + 10 r = real(n) + a = p/ (1.0-p) +C y = gengam(a,r) + y = sgamma(r)/a + +C Generate a random Poisson(y) variable + ignnbn = ignpoi(y) + RETURN + + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/ranlib/ignpoi.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,285 @@ + INTEGER FUNCTION ignpoi(mu) +C********************************************************************** +C +C INTEGER FUNCTION IGNPOI( MU ) +C +C GENerate POIsson random deviate +C +C +C Function +C +C +C Generates a single random deviate from a Poisson +C distribution with mean MU. +C +C +C Arguments +C +C +C MU --> The mean of the Poisson distribution from which +C a random deviate is to be generated. +C REAL MU +C JJV (MU >= 0.0) +C +C IGNPOI <-- The random deviate. +C INTEGER IGNPOI (non-negative) +C +C +C Method +C +C +C Renames KPOIS from TOMS as slightly modified by BWB to use RANF +C instead of SUNIF. +C +C For details see: +C +C Ahrens, J.H. and Dieter, U. +C Computer Generation of Poisson Deviates +C From Modified Normal Distributions. +C ACM Trans. Math. Software, 8, 2 +C (June 1982),163-179 +C +C********************************************************************** +C**********************************************************************C +C**********************************************************************C +C C +C C +C P O I S S O N DISTRIBUTION C +C C +C C +C**********************************************************************C +C**********************************************************************C +C C +C FOR DETAILS SEE: C +C C +C AHRENS, J.H. AND DIETER, U. C +C COMPUTER GENERATION OF POISSON DEVIATES C +C FROM MODIFIED NORMAL DISTRIBUTIONS. C +C ACM TRANS. MATH. SOFTWARE, 8,2 (JUNE 1982), 163 - 179. C +C C +C (SLIGHTLY MODIFIED VERSION OF THE PROGRAM IN THE ABOVE ARTICLE) C +C C +C**********************************************************************C +C +C INTEGER FUNCTION IGNPOI(IR,MU) +C +C INPUT: IR=CURRENT STATE OF BASIC RANDOM NUMBER GENERATOR +C MU=MEAN MU OF THE POISSON DISTRIBUTION +C OUTPUT: IGNPOI=SAMPLE FROM THE POISSON-(MU)-DISTRIBUTION +C +C +C +C MUPREV=PREVIOUS MU, MUOLD=MU AT LAST EXECUTION OF STEP P OR CASE B +C TABLES: COEFFICIENTS A0-A7 FOR STEP F. FACTORIALS FACT +C COEFFICIENTS A(K) - FOR PX = FK*V*V*SUM(A(K)*V**K)-DEL +C +C +C +C SEPARATION OF CASES A AND B +C +C .. Scalar Arguments .. + REAL mu +C .. +C .. Local Scalars .. + REAL a0,a1,a2,a3,a4,a5,a6,a7,b1,b2,c,c0,c1,c2,c3,d,del,difmuk,e, + + fk,fx,fy,g,muold,muprev,omega,p,p0,px,py,q,s,t,u,v,x,xx +C JJV I added a variable 'll' here - it is the 'l' for CASE A + INTEGER j,k,kflag,l,ll,m +C .. +C .. Local Arrays .. + REAL fact(10),pp(35) +C .. +C .. External Functions .. + REAL ranf,sexpo,snorm + EXTERNAL ranf,sexpo,snorm +C .. +C .. Intrinsic Functions .. + INTRINSIC abs,alog,exp,float,ifix,max0,min0,sign,sqrt +C .. +C JJV added this for case: mu unchanged +C .. Save statement .. + SAVE s, d, l, ll, omega, c3, c2, c1, c0, c, m, p, q, p0, + + a0, a1, a2, a3, a4, a5, a6, a7, fact, pp, muprev, muold +C .. +C JJV end addition - I am including vars in Data statements +C .. Data statements .. +C JJV changed initial values of MUPREV and MUOLD to -1.0E37 +C JJV if no one calls IGNPOI with MU = -1.0E37 the first time, +C JJV the code shouldn't break + DATA muprev,muold/-1.0E37,-1.0E37/ + DATA a0,a1,a2,a3,a4,a5,a6,a7/-.5,.3333333,-.2500068,.2000118, + + -.1661269,.1421878,-.1384794,.1250060/ + DATA fact/1.,1.,2.,6.,24.,120.,720.,5040.,40320.,362880./ + DATA pp/35*0.0/ +C .. +C .. Executable Statements .. + + IF (mu.EQ.muprev) GO TO 10 + IF (mu.LT.10.0) GO TO 120 +C +C C A S E A. (RECALCULATION OF S,D,LL IF MU HAS CHANGED) +C +C JJV This is the case where I changed 'l' to 'll' +C JJV Here 'll' is set once and used in a comparison once + + muprev = mu + s = sqrt(mu) + d = 6.0*mu*mu +C +C THE POISSON PROBABILITIES PK EXCEED THE DISCRETE NORMAL +C PROBABILITIES FK WHENEVER K >= M(MU). LL=IFIX(MU-1.1484) +C IS AN UPPER BOUND TO M(MU) FOR ALL MU >= 10 . +C + ll = ifix(mu-1.1484) +C +C STEP N. NORMAL SAMPLE - SNORM(IR) FOR STANDARD NORMAL DEVIATE +C + 10 g = mu + s*snorm() + IF (g.LT.0.0) GO TO 20 + ignpoi = ifix(g) +C +C STEP I. IMMEDIATE ACCEPTANCE IF IGNPOI IS LARGE ENOUGH +C + IF (ignpoi.GE.ll) RETURN +C +C STEP S. SQUEEZE ACCEPTANCE - SUNIF(IR) FOR (0,1)-SAMPLE U +C + fk = float(ignpoi) + difmuk = mu - fk + u = ranf() + IF (d*u.GE.difmuk*difmuk*difmuk) RETURN +C +C STEP P. PREPARATIONS FOR STEPS Q AND H. +C (RECALCULATIONS OF PARAMETERS IF NECESSARY) +C .3989423=(2*PI)**(-.5) .416667E-1=1./24. .1428571=1./7. +C THE QUANTITIES B1, B2, C3, C2, C1, C0 ARE FOR THE HERMITE +C APPROXIMATIONS TO THE DISCRETE NORMAL PROBABILITIES FK. +C C=.1069/MU GUARANTEES MAJORIZATION BY THE 'HAT'-FUNCTION. +C + 20 IF (mu.EQ.muold) GO TO 30 + muold = mu + omega = .3989423/s + b1 = .4166667E-1/mu + b2 = .3*b1*b1 + c3 = .1428571*b1*b2 + c2 = b2 - 15.*c3 + c1 = b1 - 6.*b2 + 45.*c3 + c0 = 1. - b1 + 3.*b2 - 15.*c3 + c = .1069/mu + 30 IF (g.LT.0.0) GO TO 50 +C +C 'SUBROUTINE' F IS CALLED (KFLAG=0 FOR CORRECT RETURN) +C + kflag = 0 + GO TO 70 +C +C STEP Q. QUOTIENT ACCEPTANCE (RARE CASE) +C + 40 IF (fy-u*fy.LE.py*exp(px-fx)) RETURN +C +C STEP E. EXPONENTIAL SAMPLE - SEXPO(IR) FOR STANDARD EXPONENTIAL +C DEVIATE E AND SAMPLE T FROM THE LAPLACE 'HAT' +C (IF T <= -.6744 THEN PK < FK FOR ALL MU >= 10.) +C + 50 e = sexpo() + u = ranf() + u = u + u - 1.0 + t = 1.8 + sign(e,u) + IF (t.LE. (-.6744)) GO TO 50 + ignpoi = ifix(mu+s*t) + fk = float(ignpoi) + difmuk = mu - fk +C +C 'SUBROUTINE' F IS CALLED (KFLAG=1 FOR CORRECT RETURN) +C + kflag = 1 + GO TO 70 +C +C STEP H. HAT ACCEPTANCE (E IS REPEATED ON REJECTION) +C + 60 IF (c*abs(u).GT.py*exp(px+e)-fy*exp(fx+e)) GO TO 50 + RETURN +C +C STEP F. 'SUBROUTINE' F. CALCULATION OF PX,PY,FX,FY. +C CASE IGNPOI .LT. 10 USES FACTORIALS FROM TABLE FACT +C + 70 IF (ignpoi.GE.10) GO TO 80 + px = -mu + py = mu**ignpoi/fact(ignpoi+1) + GO TO 110 +C +C CASE IGNPOI .GE. 10 USES POLYNOMIAL APPROXIMATION +C A0-A7 FOR ACCURACY WHEN ADVISABLE +C .8333333E-1=1./12. .3989423=(2*PI)**(-.5) +C + 80 del = .8333333E-1/fk + del = del - 4.8*del*del*del + v = difmuk/fk + IF (abs(v).LE.0.25) GO TO 90 + px = fk*alog(1.0+v) - difmuk - del + GO TO 100 + + 90 px = fk*v*v* (((((((a7*v+a6)*v+a5)*v+a4)*v+a3)*v+a2)*v+a1)*v+a0) - + + del + 100 py = .3989423/sqrt(fk) + 110 x = (0.5-difmuk)/s + xx = x*x + fx = -0.5*xx + fy = omega* (((c3*xx+c2)*xx+c1)*xx+c0) + IF (kflag.LE.0) GO TO 40 + GO TO 60 +C +C C A S E B. (START NEW TABLE AND CALCULATE P0 IF NECESSARY) +C +C JJV changed MUPREV assignment from 0.0 to initial value + 120 muprev = -1.0E37 + IF (mu.EQ.muold) GO TO 130 +C JJV added argument checker here + IF (mu.GE.0.0) GO TO 125 + WRITE (*,*) 'MU < 0 in IGNPOI - ABORT' + WRITE (*,*) 'Value of MU: ',mu + CALL XSTOPX ('MU < 0 in IGNPOI - ABORT') +C JJV added line label here + 125 muold = mu + m = max0(1,ifix(mu)) + l = 0 + p = exp(-mu) + q = p + p0 = p +C +C STEP U. UNIFORM SAMPLE FOR INVERSION METHOD +C + 130 u = ranf() + ignpoi = 0 + IF (u.LE.p0) RETURN +C +C STEP T. TABLE COMPARISON UNTIL THE END PP(L) OF THE +C PP-TABLE OF CUMULATIVE POISSON PROBABILITIES +C (0.458=PP(9) FOR MU=10) +C + IF (l.EQ.0) GO TO 150 + j = 1 + IF (u.GT.0.458) j = min0(l,m) + DO 140 k = j,l + IF (u.LE.pp(k)) GO TO 180 + 140 CONTINUE + IF (l.EQ.35) GO TO 130 +C +C STEP C. CREATION OF NEW POISSON PROBABILITIES P +C AND THEIR CUMULATIVES Q=PP(K) +C + 150 l = l + 1 + DO 160 k = l,35 + p = p*mu/float(k) + q = q + p + pp(k) = q + IF (u.LE.q) GO TO 170 + 160 CONTINUE + l = 35 + GO TO 130 + + 170 l = k + 180 ignpoi = k + RETURN + + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/ranlib/ignuin.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,95 @@ + INTEGER FUNCTION ignuin(low,high) +C********************************************************************** +C +C INTEGER FUNCTION IGNUIN( LOW, HIGH ) +C +C GeNerate Uniform INteger +C +C +C Function +C +C +C Generates an integer uniformly distributed between LOW and HIGH. +C +C +C Arguments +C +C +C LOW --> Low bound (inclusive) on integer value to be generated +C INTEGER LOW +C +C HIGH --> High bound (inclusive) on integer value to be generated +C INTEGER HIGH +C +C +C Note +C +C +C If (HIGH-LOW) > 2,147,483,561 prints error message on * unit and +C stops the program. +C +C********************************************************************** + +C IGNLGI generates integers between 1 and 2147483562 +C MAXNUM is 1 less than maximum generable value +C .. Parameters .. + INTEGER maxnum + PARAMETER (maxnum=2147483561) + CHARACTER*(*) err1,err2 + PARAMETER (err1='LOW > HIGH in IGNUIN', + + err2=' ( HIGH - LOW ) > 2,147,483,561 in IGNUIN') +C .. +C .. Scalar Arguments .. + INTEGER high,low +C .. +C .. Local Scalars .. + INTEGER err,ign,maxnow,range,ranp1 +C .. +C .. External Functions .. + INTEGER ignlgi + EXTERNAL ignlgi +C .. +C .. Intrinsic Functions .. + INTRINSIC mod +C .. +C .. Executable Statements .. + IF (.NOT. (low.GT.high)) GO TO 10 + err = 1 +C ABORT-PROGRAM + GO TO 80 + + 10 range = high - low + IF (.NOT. (range.GT.maxnum)) GO TO 20 + err = 2 +C ABORT-PROGRAM + GO TO 80 + + 20 IF (.NOT. (low.EQ.high)) GO TO 30 + ignuin = low + RETURN + +C Number to be generated should be in range 0..RANGE +C Set MAXNOW so that the number of integers in 0..MAXNOW is an +C integral multiple of the number in 0..RANGE + + 30 ranp1 = range + 1 + maxnow = (maxnum/ranp1)*ranp1 + 40 ign = ignlgi() - 1 + IF (.NOT. (ign.LE.maxnow)) GO TO 40 + ignuin = low + mod(ign,ranp1) + RETURN + + 80 IF (.NOT. (err.EQ.1)) GO TO 90 + WRITE (*,*) err1 + GO TO 100 + +C TO ABORT-PROGRAM + 90 WRITE (*,*) err2 + 100 WRITE (*,*) ' LOW: ',low,' HIGH: ',high + WRITE (*,*) ' Abort on Fatal ERROR' + IF (.NOT. (err.EQ.1)) GO TO 110 + CALL XSTOPX ('LOW > HIGH in IGNUIN') + + 110 CALL XSTOPX (' ( HIGH - LOW ) > 2,147,483,561 in IGNUIN') + + 120 END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/ranlib/initgn.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,93 @@ + SUBROUTINE initgn(isdtyp) +C********************************************************************** +C +C SUBROUTINE INITGN(ISDTYP) +C INIT-ialize current G-e-N-erator +C +C Reinitializes the state of the current generator +C +C This is a transcription from Pascal to Fortran of routine +C Init_Generator from the paper +C +C L'Ecuyer, P. and Cote, S. "Implementing a Random Number Package +C with Splitting Facilities." ACM Transactions on Mathematical +C Software, 17:98-111 (1991) +C +C +C Arguments +C +C +C ISDTYP -> The state to which the generator is to be set +C +C ISDTYP = -1 => sets the seeds to their initial value +C ISDTYP = 0 => sets the seeds to the first value of +C the current block +C ISDTYP = 1 => sets the seeds to the first value of +C the next block +C +C INTEGER ISDTYP +C +C********************************************************************** +C .. Parameters .. + INTEGER numg + PARAMETER (numg=32) +C .. +C .. Scalar Arguments .. + INTEGER isdtyp +C .. +C .. Scalars in Common .. + INTEGER a1,a1vw,a1w,a2,a2vw,a2w,m1,m2 +C .. +C .. Arrays in Common .. + INTEGER cg1(numg),cg2(numg),ig1(numg),ig2(numg),lg1(numg), + + lg2(numg) + LOGICAL qanti(numg) +C .. +C .. Local Scalars .. + INTEGER g +C .. +C .. External Functions .. + LOGICAL qrgnin + INTEGER mltmod + EXTERNAL qrgnin,mltmod +C .. +C .. External Subroutines .. + EXTERNAL getcgn +C .. +C .. Common blocks .. + COMMON /globe/m1,m2,a1,a2,a1w,a2w,a1vw,a2vw,ig1,ig2,lg1,lg2,cg1, + + cg2,qanti +C .. +C .. Save statement .. + SAVE /globe/ +C .. +C .. Executable Statements .. +C Abort unless random number generator initialized + IF (qrgnin()) GO TO 10 + WRITE (*,*) ' INITGN called before random number generator ', + + ' initialized -- abort!' + CALL XSTOPX + + (' INITGN called before random number generator initialized') + + 10 CALL getcgn(g) + IF ((-1).NE. (isdtyp)) GO TO 20 + lg1(g) = ig1(g) + lg2(g) = ig2(g) + GO TO 50 + + 20 IF ((0).NE. (isdtyp)) GO TO 30 + CONTINUE + GO TO 50 +C do nothing + 30 IF ((1).NE. (isdtyp)) GO TO 40 + lg1(g) = mltmod(a1w,lg1(g),m1) + lg2(g) = mltmod(a2w,lg2(g),m2) + GO TO 50 + + 40 CALL XSTOPX ('ISDTYP NOT IN RANGE') + + 50 cg1(g) = lg1(g) + cg2(g) = lg2(g) + RETURN + + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/ranlib/inrgcm.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,70 @@ + SUBROUTINE inrgcm() +C********************************************************************** +C +C SUBROUTINE INRGCM() +C INitialize Random number Generator CoMmon +C +C +C Function +C +C +C Initializes common area for random number generator. This saves +C the nuisance of a BLOCK DATA routine and the difficulty of +C assuring that the routine is loaded with the other routines. +C +C********************************************************************** +C .. Parameters .. + INTEGER numg + PARAMETER (numg=32) +C .. +C .. Scalars in Common .. + INTEGER a1,a1vw,a1w,a2,a2vw,a2w,m1,m2 +C .. +C .. Arrays in Common .. + INTEGER cg1(numg),cg2(numg),ig1(numg),ig2(numg),lg1(numg), + + lg2(numg) + LOGICAL qanti(numg) +C .. +C .. Local Scalars .. + INTEGER i + LOGICAL qdum +C .. +C .. External Functions .. + LOGICAL qrgnsn + EXTERNAL qrgnsn +C .. +C .. Common blocks .. + COMMON /globe/m1,m2,a1,a2,a1w,a2w,a1vw,a2vw,ig1,ig2,lg1,lg2,cg1, + + cg2,qanti +C .. +C .. Save statement .. + SAVE /globe/ +C .. +C .. Executable Statements .. +C V=20; W=30; +C +C A1W = MOD(A1**(2**W),M1) A2W = MOD(A2**(2**W),M2) +C A1VW = MOD(A1**(2**(V+W)),M1) A2VW = MOD(A2**(2**(V+W)),M2) +C +C If V or W is changed A1W, A2W, A1VW, and A2VW need to be recomputed. +C An efficient way to precompute a**(2*j) MOD m is to start with +C a and square it j times modulo m using the function MLTMOD. +C + m1 = 2147483563 + m2 = 2147483399 + a1 = 40014 + a2 = 40692 + a1w = 1033780774 + a2w = 1494757890 + a1vw = 2082007225 + a2vw = 784306273 + DO 10,i = 1,numg + qanti(i) = .FALSE. + 10 CONTINUE +C +C Tell the world that common has been initialized +C + qdum = qrgnsn(.TRUE.) + RETURN + + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/ranlib/lennob.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,36 @@ + INTEGER FUNCTION lennob(string) + IMPLICIT INTEGER (a-p,r-z),LOGICAL (q) +C********************************************************************** +C +C INTEGER FUNCTION LENNOB( STRING ) +C LENgth NOt counting trailing Blanks +C +C +C Function +C +C +C Returns the length of STRING up to and including the last +C non-blank character. +C +C +C Arguments +C +C +C STRING --> String whose length not counting trailing blanks +C is returned. +C +C********************************************************************** + CHARACTER*(*) string + + end = len(string) + DO 20,i = end,1,-1 + IF (.NOT. (string(i:i).NE.' ')) GO TO 10 + lennob = i + RETURN + + 10 CONTINUE + 20 CONTINUE + lennob = 0 + RETURN + + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/ranlib/mltmod.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,106 @@ + INTEGER FUNCTION mltmod(a,s,m) +C********************************************************************** +C +C INTEGER FUNCTION MLTMOD(A,S,M) +C +C Returns (A*S) MOD M +C +C This is a transcription from Pascal to Fortran of routine +C MULtMod_Decompos from the paper +C +C L'Ecuyer, P. and Cote, S. "Implementing a Random Number Package +C with Splitting Facilities." ACM Transactions on Mathematical +C Software, 17:98-111 (1991) +C +C +C Arguments +C +C +C A, S, M --> +C INTEGER A,S,M +C +C********************************************************************** +C .. Parameters .. + INTEGER h + PARAMETER (h=32768) +C .. +C .. Scalar Arguments .. + INTEGER a,m,s +C .. +C .. Local Scalars .. + INTEGER a0,a1,k,p,q,qh,rh +C .. +C .. Executable Statements .. +C +C H = 2**((b-2)/2) where b = 32 because we are using a 32 bit +C machine. On a different machine recompute H +C + IF (.NOT. (a.LE.0.OR.a.GE.m.OR.s.LE.0.OR.s.GE.m)) GO TO 10 + WRITE (*,*) ' A, M, S out of order in MLTMOD - ABORT!' + WRITE (*,*) ' A = ',a,' S = ',s,' M = ',m + WRITE (*,*) ' MLTMOD requires: 0 < A < M; 0 < S < M' + CALL XSTOPX (' A, M, S out of order in MLTMOD - ABORT!') + + 10 IF (.NOT. (a.LT.h)) GO TO 20 + a0 = a + p = 0 + GO TO 120 + + 20 a1 = a/h + a0 = a - h*a1 + qh = m/h + rh = m - h*qh + IF (.NOT. (a1.GE.h)) GO TO 50 + a1 = a1 - h + k = s/qh + p = h* (s-k*qh) - k*rh + 30 IF (.NOT. (p.LT.0)) GO TO 40 + p = p + m + GO TO 30 + + 40 GO TO 60 + + 50 p = 0 +C +C P = (A2*S*H)MOD M +C + 60 IF (.NOT. (a1.NE.0)) GO TO 90 + q = m/a1 + k = s/q + p = p - k* (m-a1*q) + IF (p.GT.0) p = p - m + p = p + a1* (s-k*q) + 70 IF (.NOT. (p.LT.0)) GO TO 80 + p = p + m + GO TO 70 + + 80 CONTINUE + 90 k = p/qh +C +C P = ((A2*H + A1)*S)MOD M +C + p = h* (p-k*qh) - k*rh + 100 IF (.NOT. (p.LT.0)) GO TO 110 + p = p + m + GO TO 100 + + 110 CONTINUE + 120 IF (.NOT. (a0.NE.0)) GO TO 150 +C +C P = ((A2*H + A1)*H*S)MOD M +C + q = m/a0 + k = s/q + p = p - k* (m-a0*q) + IF (p.GT.0) p = p - m + p = p + a0* (s-k*q) + 130 IF (.NOT. (p.LT.0)) GO TO 140 + p = p + m + GO TO 130 + + 140 CONTINUE + 150 mltmod = p +C + RETURN + + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/ranlib/module.mk Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,63 @@ +RANLIB_SRC = \ + liboctave/external/ranlib/advnst.f \ + liboctave/external/ranlib/genbet.f \ + liboctave/external/ranlib/genchi.f \ + liboctave/external/ranlib/genexp.f \ + liboctave/external/ranlib/genf.f \ + liboctave/external/ranlib/gengam.f \ + liboctave/external/ranlib/genmn.f \ + liboctave/external/ranlib/genmul.f \ + liboctave/external/ranlib/gennch.f \ + liboctave/external/ranlib/gennf.f \ + liboctave/external/ranlib/gennor.f \ + liboctave/external/ranlib/genprm.f \ + liboctave/external/ranlib/genunf.f \ + liboctave/external/ranlib/getcgn.f \ + liboctave/external/ranlib/getsd.f \ + liboctave/external/ranlib/ignbin.f \ + liboctave/external/ranlib/ignlgi.f \ + liboctave/external/ranlib/ignnbn.f \ + liboctave/external/ranlib/ignpoi.f \ + liboctave/external/ranlib/ignuin.f \ + liboctave/external/ranlib/initgn.f \ + liboctave/external/ranlib/inrgcm.f \ + liboctave/external/ranlib/lennob.f \ + liboctave/external/ranlib/mltmod.f \ + liboctave/external/ranlib/phrtsd.f \ + liboctave/external/ranlib/qrgnin.f \ + liboctave/external/ranlib/ranf.f \ + liboctave/external/ranlib/setall.f \ + liboctave/external/ranlib/setant.f \ + liboctave/external/ranlib/setgmn.f \ + liboctave/external/ranlib/setsd.f \ + liboctave/external/ranlib/sexpo.f \ + liboctave/external/ranlib/sgamma.f \ + liboctave/external/ranlib/snorm.f \ + liboctave/external/ranlib/wrap.f + +noinst_LTLIBRARIES += liboctave/external/ranlib/libranlib.la + +liboctave_external_ranlib_libranlib_la_SOURCES = $(RANLIB_SRC) + +liboctave_external_ranlib_libranlib_la_DEPENDENCIES = liboctave/external/ranlib/ranlib.def + +## Special rules for files which must be built before compilation +## ranlib directory may not exist in VPATH build; create it if necessary. +liboctave/external/ranlib/ranlib.def: $(RANLIB_SRC) build-aux/mk-f77-def.sh | liboctave/external/ranlib/$(octave_dirstamp) + $(AM_V_GEN)rm -f $@-t $@ && \ + $(SHELL) build-aux/mk-f77-def.sh $(srcdir) $(RANLIB_SRC) > $@-t && \ + mv $@-t $@ + +liboctave_liboctave_la_LIBADD += liboctave/external/ranlib/libranlib.la + +liboctave_EXTRA_DIST += \ + liboctave/external/ranlib/Basegen.doc \ + liboctave/external/ranlib/HOWTOGET \ + liboctave/external/ranlib/README \ + liboctave/external/ranlib/randlib.chs \ + liboctave/external/ranlib/randlib.fdoc \ + liboctave/external/ranlib/tstbot.for \ + liboctave/external/ranlib/tstgmn.for \ + liboctave/external/ranlib/tstmid.for + +DIRSTAMP_FILES += liboctave/external/ranlib/$(octave_dirstamp)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/ranlib/phrtsd.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,92 @@ + SUBROUTINE phrtsd(phrase,seed1,seed2) +C********************************************************************** +C +C SUBROUTINE PHRTSD( PHRASE, SEED1, SEED2 ) +C PHRase To SeeDs +C +C +C Function +C +C +C Uses a phrase (character string) to generate two seeds for the RGN +C random number generator. +C +C +C Arguments +C +C +C PHRASE --> Phrase to be used for random number generation +C CHARACTER*(*) PHRASE +C +C SEED1 <-- First seed for RGN generator +C INTEGER SEED1 +C +C SEED2 <-- Second seed for RGN generator +C INTEGER SEED2 +C +C +C Note +C +C +C Trailing blanks are eliminated before the seeds are generated. +C +C Generated seed values will fall in the range 1..2^30 +C (1..1,073,741,824) +C +C********************************************************************** +C .. Parameters .. + CHARACTER*(*) table + PARAMETER (table='abcdefghijklmnopqrstuvwxyz'// + + 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'//'0123456789'// + + '!@#$%^&*()_+[];:''"<>?,./') + INTEGER twop30 + PARAMETER (twop30=1073741824) + INTEGER sixty4 + PARAMETER (sixty4=64) +C .. +C .. Scalar Arguments .. + INTEGER seed1,seed2 + CHARACTER phrase* (*) +C .. +C .. Local Scalars .. + INTEGER i,ichr,j,lphr,idxval +C .. +C .. Local Arrays .. + INTEGER shift(0:4),values(5) +C .. +C .. External Functions .. + INTEGER lennob + EXTERNAL lennob +C .. +C .. Intrinsic Functions .. + INTRINSIC index,mod +C .. +C JJV added Save statement for variable in Data statement +C .. Save statements .. + SAVE shift +C JJV end addition +C .. +C .. Data statements .. + DATA shift/1,64,4096,262144,16777216/ +C .. +C .. Executable Statements .. + seed1 = 1234567890 + seed2 = 123456789 + lphr = lennob(phrase) + IF (lphr.LT.1) RETURN + DO 30,i = 1,lphr + idxval = index(table,phrase(i:i)) + ichr = mod(idxval,sixty4) + IF (ichr.EQ.0) ichr = 63 + DO 10,j = 1,5 + values(j) = ichr - j + IF (values(j).LT.1) values(j) = values(j) + 63 + 10 CONTINUE + DO 20,j = 1,5 + seed1 = mod(seed1+shift(j-1)*values(j),twop30) + seed2 = mod(seed2+shift(j-1)*values(6-j),twop30) + 20 CONTINUE + 30 CONTINUE + RETURN + + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/ranlib/qrgnin.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,48 @@ + LOGICAL FUNCTION qrgnin() +C********************************************************************** +C +C LOGICAL FUNCTION QRGNIN() +C Q Random GeNerators INitialized? +C +C A trivial routine to determine whether or not the random +C number generator has been initialized. Returns .TRUE. if +C it has, else .FALSE. +C +C********************************************************************** +C .. Scalar Arguments .. + LOGICAL qvalue +C .. +C .. Local Scalars .. + LOGICAL qinit +C .. +C .. Entry Points .. + LOGICAL qrgnsn +C .. +C .. Save statement .. + SAVE qinit +C .. +C .. Data statements .. + DATA qinit/.FALSE./ +C .. +C .. Executable Statements .. + qrgnin = qinit + RETURN + + ENTRY qrgnsn(qvalue) +C********************************************************************** +C +C LOGICAL FUNCTION QRGNSN( QVALUE ) +C Q Random GeNerators Set whether iNitialized +C +C Sets state of whether random number generator is initialized +C to QVALUE. +C +C This routine is actually an entry in QRGNIN, hence it is a +C logical function. It returns the (meaningless) value .TRUE. +C +C********************************************************************** + qinit = qvalue + qrgnsn = .TRUE. + RETURN + + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/ranlib/randlib.chs Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,362 @@ + SUMMARY OF ROUTINES IN RANDLIB + +0. Base Level Routines to Set and Obtain Values of Seeds + +(These should be the only base level routines used by those who don't +need multiple generators with blocks of numbers.) + +C********************************************************************** +C +C SUBROUTINE SETALL(ISEED1,ISEED2) +C SET ALL random number generators +C INTEGER ISEED1, ISEED2 +C +C********************************************************************** +C********************************************************************** +C +C SUBROUTINE GETSD(ISEED1,ISEED2) +C GET SeeD +C INTEGER ISEED1, ISEED2 +C +C Returns the value of two integer seeds of the current generator +C in ISEED1, ISEED2 +C +C********************************************************************** + +I. Higher Level Routines + +C********************************************************************** +C +C REAL FUNCTION GENBET( A, B ) +C GeNerate BETa random deviate +C REAL A,B +C +C Returns a single random deviate from the beta distribution with +C parameters A and B. The density of the beta is +C x^(a-1) * (1-x)^(b-1) / B(a,b) for 0 < x < 1 +C +C********************************************************************** +C********************************************************************** +C +C REAL FUNCTION GENCHI( DF ) +C Generate random value of CHIsquare variable +C REAL DF +C +C Generates random deviate from the distribution of a chisquare +C with DF degrees of freedom random variable. +C +C********************************************************************** +C********************************************************************** +C +C REAL FUNCTION GENEXP( AV ) +C GENerate EXPonential random deviate +C REAL AV +C +C Generates a single random deviate from an exponential +C distribution with mean AV. +C +C********************************************************************** +C********************************************************************** +C +C REAL FUNCTION GENF( DFN, DFD ) +C GENerate random deviate from the F distribution +C REAL DFN, DFD +C +C Generates a random deviate from the F (variance ratio) +C distribution with DFN degrees of freedom in the numerator +C and DFD degrees of freedom in the denominator. +C +C********************************************************************** +C********************************************************************** +C +C REAL FUNCTION GENGAM( A, R ) +C GENerates random deviates from GAMma distribution +C REAL A, R +C +C Generates random deviates from the gamma distribution whose +C density is +C (A**R)/Gamma(R) * X**(R-1) * Exp(-A*X) +C +C********************************************************************** +C********************************************************************** +C +C SUBROUTINE GENMN(PARM,X,WORK) +C GENerate Multivariate Normal random deviate +C REAL PARM(*), X(*), WORK(*) +C +C PARM is set by SETGMN which must be called prior to GENMN. The +C generated deviates are placed in X. WORK is a work array of the +C same size as X. +C +C********************************************************************** +C********************************************************************** +C +C SUBROUTINE GENMUL( N, P, NCAT, IX ) +C GENerate MULtinomial random deviate +C REAL P(*) +C INTEGER N, NCAT, IX(*) +C +C Generates deviates from a Multinomial distribution with NCAT +C categories. P specifies the probability of an event in each +C category. The generated deviates are placed in IX. +C +C********************************************************************** +C********************************************************************** +C +C REAL FUNCTION GENNCH( DF, XNONC ) +C Generate random value of Noncentral CHIsquare variable +C REAL DF, XNONC +C +C Generates random deviate from the distribution of a noncentral +C chisquare with DF degrees of freedom and noncentrality parameter +C XNONC. +C +C********************************************************************** +C********************************************************************** +C +C REAL FUNCTION GENNF( DFN, DFD, XNONC ) +C GENerate random deviate from the Noncentral F distribution +C REAL DFN, DFD, XNONC +C +C Generates a random deviate from the noncentral F (variance ratio) +C distribution with DFN degrees of freedom in the numerator, and DFD +C degrees of freedom in the denominator, and noncentrality parameter +C XNONC. +C +C********************************************************************** +C********************************************************************** +C +C REAL FUNCTION GENNOR( AV, SD ) +C GENerate random deviate from a NORmal distribution +C REAL AV, SD +C +C Generates a single random deviate from a normal distribution +C with mean, AV, and standard deviation, SD. +C +C********************************************************************** +C********************************************************************** +C +C SUBROUTINE GENPRM( IARRAY, LARRAY ) +C GENerate random PeRMutation of iarray +C INTEGER IARRAY(LARRAY), LARRAY +C +C********************************************************************** +C********************************************************************** +C +C REAL FUNCTION GENUNF( LOW, HIGH ) +C GeNerate Uniform Real between LOW and HIGH +C REAL LOW, HIGH +C +C********************************************************************** +C********************************************************************** +C +C INTEGER FUNCTION IGNBIN( N, P ) +C GENerate BINomial random deviate +C INTEGER N +C REAL P +C +C Returns a single random deviate from a binomial +C distribution whose number of trials is N and whose +C probability of an event in each trial is P. +C +C********************************************************************** +C********************************************************************** +C +C INTEGER FUNCTION IGNNBN( N, P ) +C GENerate Negative BiNomial random deviate +C INTEGER N +C REAL P +C +C Returns a single random deviate from a negative binomial +C distribution with number of events N and whose +C probability of an event in each trial is P. +C +C********************************************************************** +C********************************************************************** +C +C INTEGER FUNCTION IGNPOI( AV ) +C GENerate POIsson random deviate +C REAL AV +C +C Generates a single random deviate from a Poisson +C distribution with mean AV. +C +C********************************************************************** +C********************************************************************** +C +C INTEGER FUNCTION IGNUIN( LOW, HIGH ) +C GeNerate Uniform INteger +C INTEGER LOW, HIGH +C +C Generates an integer uniformly distributed between LOW and HIGH. +C +C********************************************************************** +C********************************************************************** +C +C SUBROUTINE PHRTSD( PHRASE, SEED1, SEED2 ) +C PHRase To SeeDs +C CHARACTER*(*) PHRASE +C INTEGER SEED1, SEED2 +C +C Uses a phrase (character string) to generate two seeds for the RGN +C random number generator. +C +C********************************************************************** +C********************************************************************** +C +C REAL FUNCTION RANF() +C RANDom number generator as a Function +C +C Returns a random floating point number from a uniform distribution +C over 0 - 1 (endpoints of this interval are not returned) using the +C current generator +C +C********************************************************************** +C********************************************************************** +C +C SUBROUTINE SETGMN( MEANV, COVM, LDCOVM, P, PARM) +C SET Generate Multivariate Normal random deviate +C INTEGER LDCOVM, P +C REAL MEANV(P), COVM(LDCOVM,P), PARM(P*(P+3)/2 + 1) +C +C P is the length of normal vectors to be generated, MEANV +C is the vector of their means and COVM(1:P,1:P) is their variance +C covariance matrix. LDCOVM is the leading actual dimension of +C COVM, which this routine needs to know although only the +C (1:P,1:P) slice of COVM is used. +C Places information necessary to generate the deviates in PARM. +C +C********************************************************************** + +II. Uniform Generator and Associated Routines + + + A. SETTING THE SEED OF ALL GENERATORS + +C********************************************************************** +C +C SUBROUTINE SETALL(ISEED1,ISEED2) +C SET ALL random number generators +C INTEGER ISEED1, ISEED2 +C +C********************************************************************** + + B. OBTAINING RANDOM NUMBERS + +C********************************************************************** +C +C INTEGER FUNCTION IGNLGI() +C GeNerate LarGe Integer +C +C Returns a random integer following a uniform distribution over +C (1, 2147483562) using the current generator. +C +C********************************************************************** + +C********************************************************************** +C +C REAL FUNCTION RANF() +C RANDom number generator as a Function +C +C Returns a random floating point number from a uniform distribution +C over 0 - 1 (endpoints of this interval are not returned) using the +C current generator +C +C********************************************************************** + + C. SETTING AND OBTAINING THE NUMBER OF THE CURRENT GENERATOR + +C********************************************************************** +C +C SUBROUTINE SETCGN( G ) +C Set GeNerator +C INTEGER G +C +C Sets the current generator to G. All references to a generator +C are to the current generator. +C +C********************************************************************** + +C********************************************************************** +C +C SUBROUTINE GETCGN(G) +C GET Current GeNerator +C INTEGER G +C +C Returns in G the number of the current random number generator +C +C********************************************************************** + + D. OBTAINING OR CHANGING SEEDS IN CURRENT GENERATOR + +C********************************************************************** +C +C SUBROUTINE ADVNST(K) +C ADV-a-N-ce ST-ate +C INTEGER K +C +C Advances the state of the current generator by 2^K values and +C resets the initial seed to that value. +C +C********************************************************************** + +C********************************************************************** +C +C SUBROUTINE GETSD(ISEED1,ISEED2) +C GET SeeD +C INTEGER ISEED1, ISEED2 +C +C Returns the value of two integer seeds of the current generator +C in ISEED1, ISEED2 +C +C********************************************************************** + +C********************************************************************** +C +C SUBROUTINE INITGN(ISDTYP) +C INIT-ialize current G-e-N-erator +C +C INTEGER ISDTYP The state to which the generator is to be set +C ISDTYP = -1 => sets the seeds to their initial value +C ISDTYP = 0 => sets the seeds to the first value of +C the current block +C ISDTYP = 1 => sets the seeds to the first value of +C the next block +C +C********************************************************************** + +C********************************************************************** +C +C SUBROUTINE SETSD(ISEED1,ISEED2) +C SET S-ee-D of current generator +C +C Resets the initial seed of the current generator to ISEED1 and +C ISEED2. The seeds of the other generators remain unchanged. +C +C********************************************************************** + + E. MISCELLANY + +C********************************************************************** +C +C INTEGER FUNCTION MLTMOD(A,S,M) +C Returns (A*S) MOD M +C INTEGER A, S, M +C +C********************************************************************** + +C********************************************************************** +C +C SUBROUTINE SETANT(QVALUE) +C SET ANTithetic +C LOGICAL QVALUE +C +C Sets whether the current generator produces antithetic values. If +C X is the value normally returned from a uniform [0,1] random +C number generator then 1 - X is the antithetic value. If X is the +C value normally returned from a uniform [0,N] random number +C generator then N - 1 - X is the antithetic value. +C +C All generators are initialized to NOT generate antithetic values. +C +C**********************************************************************
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/ranlib/randlib.fdoc Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,961 @@ + + + + + + + + + + + + RANDLIB + + Library of Fortran Routines for Random Number Generation + + + + + + + + + Full Documentation of Each Routine + + + + + + + + + Compiled and Written by: + + Barry W. Brown + James Lovato + + + + + + + + + + + Department of Biomathematics, Box 237 + The University of Texas, M.D. Anderson Cancer Center + 1515 Holcombe Boulevard + Houston, TX 77030 + + + This work was supported by grant CA-16672 from the National Cancer Institute. + +C********************************************************************** +C +C SUBROUTINE ADVNST(K) +C ADV-a-N-ce ST-ate +C +C Advances the state of the current generator by 2^K values and +C resets the initial seed to that value. +C +C This is a transcription from Pascal to Fortran of routine +C Advance_State from the paper +C +C L'Ecuyer, P. and Cote, S. "Implementing a Random Number Package +C with Splitting Facilities." ACM Transactions on Mathematical +C Software, 17:98-111 (1991) +C +C +C Arguments +C +C +C K -> The generator is advanced by2^K values +C INTEGER K +C +C********************************************************************** +C********************************************************************** +C +C REAL FUNCTION GENBET( A, B ) +C GeNerate BETa random deviate +C +C +C Function +C +C +C Returns a single random deviate from the beta distribution with +C parameters A and B. The density of the beta is +C x^(a-1) * (1-x)^(b-1) / B(a,b) for 0 < x < 1 +C +C +C Arguments +C +C +C A --> First parameter of the beta distribution +C REAL A +C (A >= 1.0E-37) +C +C B --> Second parameter of the beta distribution +C REAL B +C (B >= 1.0E-37) +C +C +C Method +C +C +C R. C. H. Cheng +C Generating Beta Variables with Nonintegral Shape Parameters +C Communications of the ACM, 21:317-322 (1978) +C (Algorithms BB and BC) +C +C********************************************************************** +C********************************************************************** +C +C REAL FUNCTION GENCHI( DF ) +C Generate random value of CHIsquare variable +C +C +C Function +C +C +C Generates random deviate from the distribution of a chisquare +C with DF degrees of freedom random variable. +C +C +C Arguments +C +C +C DF --> Degrees of freedom of the chisquare +C (Must be positive) +C REAL DF +C +C +C Method +C +C +C Uses relation between chisquare and gamma. +C +C********************************************************************** +C********************************************************************** +C +C REAL FUNCTION GENEXP( AV ) +C +C GENerate EXPonential random deviate +C +C +C Function +C +C +C Generates a single random deviate from an exponential +C distribution with mean AV. +C +C +C Arguments +C +C +C AV --> The mean of the exponential distribution from which +C a random deviate is to be generated. +C REAL AV +C (AV >= 0) +C +C GENEXP <-- The random deviate. +C REAL GENEXP +C +C +C Method +C +C +C Renames SEXPO from TOMS as slightly modified by BWB to use RANF +C instead of SUNIF. +C +C For details see: +C +C Ahrens, J.H. and Dieter, U. +C Computer Methods for Sampling From the +C Exponential and Normal Distributions. +C Comm. ACM, 15,10 (Oct. 1972), 873 - 882. +C +C********************************************************************** +C********************************************************************** +C +C REAL FUNCTION GENF( DFN, DFD ) +C GENerate random deviate from the F distribution +C +C +C Function +C +C +C Generates a random deviate from the F (variance ratio) +C distribution with DFN degrees of freedom in the numerator +C and DFD degrees of freedom in the denominator. +C +C +C Arguments +C +C +C DFN --> Numerator degrees of freedom +C (Must be positive) +C REAL DFN +C DFD --> Denominator degrees of freedom +C (Must be positive) +C REAL DFD +C +C +C Method +C +C +C Directly generates ratio of chisquare variates +C +C********************************************************************** +C********************************************************************** +C +C REAL FUNCTION GENGAM( A, R ) +C GENerates random deviates from GAMma distribution +C +C +C Function +C +C +C Generates random deviates from the gamma distribution whose +C density is +C (A**R)/Gamma(R) * X**(R-1) * Exp(-A*X) +C +C +C Arguments +C +C +C A --> Location parameter of Gamma distribution +C REAL A ( A > 0 ) +C +C R --> Shape parameter of Gamma distribution +C REAL R ( R > 0 ) +C +C +C Method +C +C +C Renames SGAMMA from TOMS as slightly modified by BWB to use RANF +C instead of SUNIF. +C +C For details see: +C (Case R >= 1.0) +C Ahrens, J.H. and Dieter, U. +C Generating Gamma Variates by a +C Modified Rejection Technique. +C Comm. ACM, 25,1 (Jan. 1982), 47 - 54. +C Algorithm GD +C +C (Case 0.0 < R < 1.0) +C Ahrens, J.H. and Dieter, U. +C Computer Methods for Sampling from Gamma, +C Beta, Poisson and Binomial Distributions. +C Computing, 12 (1974), 223-246/ +C Adapted algorithm GS. +C +C********************************************************************** +C********************************************************************** +C +C SUBROUTINE GENMN(PARM,X,WORK) +C GENerate Multivariate Normal random deviate +C +C +C Arguments +C +C +C PARM --> Parameters needed to generate multivariate normal +C deviates (MEANV and Cholesky decomposition of +C COVM). Set by a previous call to SETGMN. +C +C 1 : 1 - size of deviate, P +C 2 : P + 1 - mean vector +C P+2 : P*(P+3)/2 + 1 - upper half of cholesky +C decomposition of cov matrix +C REAL PARM(*) +C +C X <-- Vector deviate generated. +C REAL X(P) +C +C WORK <--> Scratch array +C REAL WORK(P) +C +C +C Method +C +C +C 1) Generate P independent standard normal deviates - Ei ~ N(0,1) +C +C 2) SETGMN uses Cholesky decomposition find A s.t. trans(A)*A = COV +C +C 3) Generate trans(A)*E + MEANV ~ N(MEANV,COVM) +C +C********************************************************************** +C********************************************************************** +C +C SUBROUTINE GENMUL( N, P, NCAT, IX ) +C GENerate an observation from the MULtinomial distribution +C +C +C Arguments +C +C +C N --> Number of events that will be classified into one of +C the categories 1..NCAT +C INTEGER N +C (N >= 0) +C +C P --> Vector of probabilities. P(i) is the probability that +C an event will be classified into category i. Thus, P(i) +C must be [0,1]. Only the first NCAT-1 P(i) must be defined +C since P(NCAT) is 1.0 minus the sum of the first +C NCAT-1 P(i). +C REAL P(NCAT-1) +C +C NCAT --> Number of categories. Length of P and IX. +C INTEGER NCAT +C (NCAT > 1) +C +C IX <-- Observation from multinomial distribution. All IX(i) +C will be nonnegative and their sum will be N. +C INTEGER IX(NCAT) +C +C +C Method +C +C +C Algorithm from page 559 of +C +C Devroye, Luc +C +C Non-Uniform Random Variate Generation. Springer-Verlag, +C New York, 1986. +C +C********************************************************************** +C********************************************************************** +C +C REAL FUNCTION GENNCH( DF, XNONC ) +C Generate random value of Noncentral CHIsquare variable +C +C +C Function +C +C +C +C Generates random deviate from the distribution of a noncentral +C chisquare with DF degrees of freedom and noncentrality parameter +C XNONC. +C +C +C Arguments +C +C +C DF --> Degrees of freedom of the chisquare +C (Must be >= 1.0) +C REAL DF +C +C XNONC --> Noncentrality parameter of the chisquare +C (Must be >= 0.0) +C REAL XNONC +C +C +C Method +C +C +C Uses fact that noncentral chisquare is the sum of a chisquare +C deviate with DF-1 degrees of freedom plus the square of a normal +C deviate with mean XNONC and standard deviation 1. +C +C********************************************************************** +C********************************************************************** +C +C REAL FUNCTION GENNF( DFN, DFD, XNONC ) +C GENerate random deviate from the Noncentral F distribution +C +C +C Function +C +C +C Generates a random deviate from the noncentral F (variance ratio) +C distribution with DFN degrees of freedom in the numerator, and DFD +C degrees of freedom in the denominator, and noncentrality parameter +C XNONC. +C +C +C Arguments +C +C +C DFN --> Numerator degrees of freedom +C (Must be >= 1.0) +C REAL DFN +C DFD --> Denominator degrees of freedom +C (Must be positive) +C REAL DFD +C +C XNONC --> Noncentrality parameter +C (Must be nonnegative) +C REAL XNONC +C +C +C Method +C +C +C Directly generates ratio of noncentral numerator chisquare variate +C to central denominator chisquare variate. +C +C********************************************************************** +C********************************************************************** +C +C REAL FUNCTION GENNOR( AV, SD ) +C +C GENerate random deviate from a NORmal distribution +C +C +C Function +C +C +C Generates a single random deviate from a normal distribution +C with mean, AV, and standard deviation, SD. +C +C +C Arguments +C +C +C AV --> Mean of the normal distribution. +C REAL AV +C +C SD --> Standard deviation of the normal distribution. +C REAL SD +C (SD >= 0) +C +C GENNOR <-- Generated normal deviate. +C REAL GENNOR +C +C +C Method +C +C +C Renames SNORM from TOMS as slightly modified by BWB to use RANF +C instead of SUNIF. +C +C For details see: +C Ahrens, J.H. and Dieter, U. +C Extensions of Forsythe's Method for Random +C Sampling from the Normal Distribution. +C Math. Comput., 27,124 (Oct. 1973), 927 - 937. +C +C +C********************************************************************** +C********************************************************************** +C +C SUBROUTINE GENPRM( IARRAY, LARRAY ) +C GENerate random PeRMutation of iarray +C +C +C Arguments +C +C +C IARRAY <--> On output IARRAY is a random permutation of its +C value on input +C INTEGER IARRAY( LARRAY ) +C +C LARRAY <--> Length of IARRAY +C INTEGER LARRAY +C +C********************************************************************** +C********************************************************************** +C +C REAL FUNCTION GENUNF( LOW, HIGH ) +C +C GeNerate Uniform Real between LOW and HIGH +C +C +C Function +C +C +C Generates a real uniformly distributed between LOW and HIGH. +C +C +C Arguments +C +C +C LOW --> Low bound (exclusive) on real value to be generated +C REAL LOW +C +C HIGH --> High bound (exclusive) on real value to be generated +C REAL HIGH +C +C********************************************************************** +C********************************************************************** +C +C SUBROUTINE GETCGN(G) +C Get GeNerator +C +C Returns in G the number of the current random number generator +C +C +C Arguments +C +C +C G <-- Number of the current random number generator (1..32) +C INTEGER G +C +C********************************************************************** +C********************************************************************** +C +C SUBROUTINE GETSD(ISEED1,ISEED2) +C GET SeeD +C +C Returns the value of two integer seeds of the current generator +C +C This is a transcription from Pascal to Fortran of routine +C Get_State from the paper +C +C L'Ecuyer, P. and Cote, S. "Implementing a Random Number Package +C with Splitting Facilities." ACM Transactions on Mathematical +C Software, 17:98-111 (1991) +C +C +C Arguments +C +C +C +C ISEED1 <- First integer seed of generator G +C INTEGER ISEED1 +C +C ISEED2 <- Second integer seed of generator G +C INTEGER ISEED1 +C +C********************************************************************** +C********************************************************************** +C +C INTEGER FUNCTION IGNBIN( N, P ) +C +C GENerate BINomial random deviate +C +C +C Function +C +C +C Generates a single random deviate from a binomial +C distribution whose number of trials is N and whose +C probability of an event in each trial is P. +C +C +C Arguments +C +C +C N --> The number of trials in the binomial distribution +C from which a random deviate is to be generated. +C INTEGER N +C (N >= 0) +C +C P --> The probability of an event in each trial of the +C binomial distribution from which a random deviate +C is to be generated. +C REAL P +C (0.0 <= P <= 1.0) +C +C IGNBIN <-- A random deviate yielding the number of events +C from N independent trials, each of which has +C a probability of event P. +C INTEGER IGNBIN +C +C +C Note +C +C +C Uses RANF so the value of the seeds, ISEED1 and ISEED2 must be set +C by a call similar to the following +C DUM = RANSET( ISEED1, ISEED2 ) +C +C +C Method +C +C +C This is algorithm BTPE from: +C +C Kachitvichyanukul, V. and Schmeiser, B. W. +C +C Binomial Random Variate Generation. +C Communications of the ACM, 31, 2 +C (February, 1988) 216. +C +C********************************************************************** +C********************************************************************** +C +C INTEGER FUNCTION IGNNBN( N, P ) +C +C GENerate Negative BiNomial random deviate +C +C +C Function +C +C +C Generates a single random deviate from a negative binomial +C distribution. +C +C +C Arguments +C +C +C N --> Required number of events. +C INTEGER N +C (N > 0) +C +C P --> The probability of an event during a Bernoulli trial. +C REAL P +C (0.0 < P < 1.0) +C +C +C +C Method +C +C +C Algorithm from page 480 of +C +C Devroye, Luc +C +C Non-Uniform Random Variate Generation. Springer-Verlag, +C New York, 1986. +C +C********************************************************************** +C********************************************************************** +C +C INTEGER FUNCTION IGNLGI() +C GeNerate LarGe Integer +C +C Returns a random integer following a uniform distribution over +C (1, 2147483562) using the current generator. +C +C This is a transcription from Pascal to Fortran of routine +C Random from the paper +C +C L'Ecuyer, P. and Cote, S. "Implementing a Random Number Package +C with Splitting Facilities." ACM Transactions on Mathematical +C Software, 17:98-111 (1991) +C +C********************************************************************** +C********************************************************************** +C +C INTEGER FUNCTION IGNPOI( MU ) +C +C GENerate POIsson random deviate +C +C +C Function +C +C +C Generates a single random deviate from a Poisson +C distribution with mean MU. +C +C +C Arguments +C +C +C MU --> The mean of the Poisson distribution from which +C a random deviate is to be generated. +C REAL MU +C (MU >= 0.0) +C +C IGNPOI <-- The random deviate. +C REAL IGNPOI (non-negative) +C +C +C Method +C +C +C Renames KPOIS from TOMS as slightly modified by BWB to use RANF +C instead of SUNIF. +C +C For details see: +C +C Ahrens, J.H. and Dieter, U. +C Computer Generation of Poisson Deviates +C From Modified Normal Distributions. +C ACM Trans. Math. Software, 8, 2 +C (June 1982),163-179 +C +C********************************************************************** +C********************************************************************** +C +C INTEGER FUNCTION IGNUIN( LOW, HIGH ) +C +C GeNerate Uniform INteger +C +C +C Function +C +C +C Generates an integer uniformly distributed between LOW and HIGH. +C +C +C Arguments +C +C +C LOW --> Low bound (inclusive) on integer value to be generated +C INTEGER LOW +C +C HIGH --> High bound (inclusive) on integer value to be generated +C INTEGER HIGH +C +C +C Note +C +C +C If (HIGH-LOW) > 2,147,483,561 prints error message on * unit and +C stops the program. +C +C********************************************************************** +C********************************************************************** +C +C SUBROUTINE INITGN(ISDTYP) +C INIT-ialize current G-e-N-erator +C +C Reinitializes the state of the current generator +C ISDTYP = -1 => sets the state to its initial seed +C ISDTYP = 0 => sets the state to its last (previous) seed +C ISDTYP = 1 => sets the state to a new seed 2^w values +C from its last seed +C +C This is a transcription from Pascal to Fortran of routine +C Init_Generator from the paper +C +C L'Ecuyer, P. and Cote, S. "Implementing a Random Number Package +C with Splitting Facilities." ACM Transactions on Mathematical +C Software, 17:98-111 (1991) +C +C +C Arguments +C +C +C ISDTYP -> The state to which the generator is to be set +C +C INTEGER ISDTYP +C +C********************************************************************** +C********************************************************************** +C +C SUBROUTINE INRGCM() +C INitialize Random number Generator CoMmon +C +C +C Function +C +C +C Initializes common area for random number generator. This saves +C the nuisance of a BLOCK DATA routine and the difficulty of +C assuring that the routine is loaded with the other routines. +C +C********************************************************************** +C********************************************************************** +C +C INTEGER FUNCTION MLTMOD(A,S,M) +C +C Returns (A*S) MOD M +C +C This is a transcription from Pascal to Fortran of routine +C MULtMod_Decompos from the paper +C +C L'Ecuyer, P. and Cote, S. "Implementing a Random Number Package +C with Splitting Facilities." ACM Transactions on Mathematical +C Software, 17:98-111 (1991) +C +C +C Arguments +C +C +C A, S, M --> +C INTEGER A,S,M +C +C********************************************************************** +C********************************************************************** +C +C SUBROUTINE PHRTSD( PHRASE, SEED1, SEED2 ) +C PHRase To SeeDs +C +C +C Function +C +C +C Uses a phrase (character string) to generate two seeds for the RGN +C random number generator. +C +C +C Arguments +C +C +C PHRASE --> Phrase to be used for random number generation +C CHARACTER*(*) PHRASE +C +C SEED1 <-- First seed for RGN generator +C INTEGER SEED1 +C +C SEED2 <-- Second seed for RGN generator +C INTEGER SEED2 +C +C +C Note +C +C +C Trailing blanks are eliminated before the seeds are generated. +C +C Generated seed values will fall in the range 1..2^30 +C (1..1,073,741,824) +C +C********************************************************************** +C********************************************************************** +C +C REAL FUNCTION RANF() +C RANDom number generator as a Function +C +C Returns a random floating point number from a uniform distribution +C over 0 - 1 (endpoints of this interval are not returned) using the +C current generator +C +C This is a transcription from Pascal to Fortran of routine +C Uniform_01 from the paper +C +C L'Ecuyer, P. and Cote, S. "Implementing a Random Number Package +C with Splitting Facilities." ACM Transactions on Mathematical +C Software, 17:98-111 (1991) +C +C********************************************************************** +C********************************************************************** +C +C SUBROUTINE SETALL(ISEED1,ISEED2) +C SET ALL random number generators +C +C Sets the initial seed of generator 1 to ISEED1 and ISEED2. The +C initial seeds of the other generators are set accordingly, and +C all generators states are set to these seeds. +C +C This is a transcription from Pascal to Fortran of routine +C Set_Initial_Seed from the paper +C +C L'Ecuyer, P. and Cote, S. "Implementing a Random Number Package +C with Splitting Facilities." ACM Transactions on Mathematical +C Software, 17:98-111 (1991) +C +C +C Arguments +C +C +C ISEED1 -> First of two integer seeds +C INTEGER ISEED1 +C +C ISEED2 -> Second of two integer seeds +C INTEGER ISEED1 +C +C********************************************************************** +C********************************************************************** +C +C SUBROUTINE SETANT(QVALUE) +C SET ANTithetic +C +C Sets whether the current generator produces antithetic values. If +C X is the value normally returned from a uniform [0,1] random +C number generator then 1 - X is the antithetic value. If X is the +C value normally returned from a uniform [0,N] random number +C generator then N - 1 - X is the antithetic value. +C +C All generators are initialized to NOT generate antithetic values. +C +C This is a transcription from Pascal to Fortran of routine +C Set_Antithetic from the paper +C +C L'Ecuyer, P. and Cote, S. "Implementing a Random Number Package +C with Splitting Facilities." ACM Transactions on Mathematical +C Software, 17:98-111 (1991) +C +C +C Arguments +C +C +C QVALUE -> .TRUE. if generator G is to generating antithetic +C values, otherwise .FALSE. +C LOGICAL QVALUE +C +C********************************************************************** +C********************************************************************** +C +C SUBROUTINE SETCGN( G ) +C Set GeNerator +C +C Sets the current generator to G. All references to a generato +C are to the current generator. +C +C +C Arguments +C +C +C G --> Number of the current random number generator (1..32) +C INTEGER G +C +C********************************************************************** +C********************************************************************** +C +C SUBROUTINE SETGMN( MEANV, COVM, LDCOVM, P, PARM) +C SET Generate Multivariate Normal random deviate +C +C +C Function +C +C +C Places P, MEANV, and the Cholesky factoriztion of COVM +C in PARM for GENMN. +C +C +C Arguments +C +C +C MEANV --> Mean vector of multivariate normal distribution. +C REAL MEANV(P) +C +C COVM <--> (Input) Covariance matrix of the multivariate +C normal distribution. This routine uses only the +C (1:P,1:P) slice of COVM, but needs to know LDCOVM. +C +C (Output) Destroyed on output +C REAL COVM(LDCOVM,P) +C +C LDCOVM --> Leading actual dimension of COVM. +C INTEGER LDCOVM +C +C P --> Dimension of the normal, or length of MEANV. +C INTEGER P +C +C PARM <-- Array of parameters needed to generate multivariate +C normal deviates (P, MEANV and Cholesky decomposition +C of COVM). +C 1 : 1 - P +C 2 : P + 1 - MEANV +C P+2 : P*(P+3)/2 + 1 - Cholesky decomposition of COVM +C REAL PARM(P*(P+3)/2 + 1) +C +C********************************************************************** +C********************************************************************** +C +C SUBROUTINE SETSD(ISEED1,ISEED2) +C SET S-ee-D of current generator +C +C Resets the initial seed and state of generator g to ISEED1 and +C ISEED2. The seeds and states of the other generators remain +C unchanged. +C +C This is a transcription from Pascal to Fortran of routine +C Set_Seed from the paper +C +C L'Ecuyer, P. and Cote, S. "Implementing a Random Number Package +C with Splitting Facilities." ACM Transactions on Mathematical +C Software, 17:98-111 (1991) +C +C +C Arguments +C +C +C ISEED1 -> First integer seed +C INTEGER ISEED1 +C +C ISEED2 -> Second integer seed +C INTEGER ISEED1 +C +C**********************************************************************
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/ranlib/ranf.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,31 @@ + REAL FUNCTION ranf() +C********************************************************************** +C +C REAL FUNCTION RANF() +C RANDom number generator as a Function +C +C Returns a random floating point number from a uniform distribution +C over 0 - 1 (endpoints of this interval are not returned) using the +C current generator +C +C This is a transcription from Pascal to Fortran of routine +C Uniform_01 from the paper +C +C L'Ecuyer, P. and Cote, S. "Implementing a Random Number Package +C with Splitting Facilities." ACM Transactions on Mathematical +C Software, 17:98-111 (1991) +C +C********************************************************************** +C .. External Functions .. + INTEGER ignlgi + EXTERNAL ignlgi +C .. +C .. Executable Statements .. +C +C 4.656613057E-10 is 1/M1 M1 is set in a data statement in IGNLGI +C and is currently 2147483563. If M1 changes, change this also. +C + ranf = ignlgi()*4.656613057E-10 + RETURN + + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/ranlib/setall.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,103 @@ + SUBROUTINE setall(iseed1,iseed2) +C********************************************************************** +C +C SUBROUTINE SETALL(ISEED1,ISEED2) +C SET ALL random number generators +C +C Sets the initial seed of generator 1 to ISEED1 and ISEED2. The +C initial seeds of the other generators are set accordingly, and +C all generators states are set to these seeds. +C +C This is a transcription from Pascal to Fortran of routine +C Set_Initial_Seed from the paper +C +C L'Ecuyer, P. and Cote, S. "Implementing a Random Number Package +C with Splitting Facilities." ACM Transactions on Mathematical +C Software, 17:98-111 (1991) +C +C +C Arguments +C +C +C ISEED1 -> First of two integer seeds +C INTEGER ISEED1 +C +C ISEED2 -> Second of two integer seeds +C INTEGER ISEED1 +C +C********************************************************************** +C .. Parameters .. + INTEGER numg + PARAMETER (numg=32) +C .. +C .. Scalar Arguments .. + INTEGER iseed1,iseed2 + LOGICAL qssd +C .. +C .. Scalars in Common .. + INTEGER a1,a1vw,a1w,a2,a2vw,a2w,m1,m2 +C .. +C .. Arrays in Common .. + INTEGER cg1(numg),cg2(numg),ig1(numg),ig2(numg),lg1(numg), + + lg2(numg) + LOGICAL qanti(numg) +C .. +C .. Local Scalars .. + INTEGER g,ocgn + LOGICAL qqssd +C .. +C .. External Functions .. + INTEGER mltmod + LOGICAL qrgnin + EXTERNAL mltmod,qrgnin +C .. +C .. External Subroutines .. + EXTERNAL getcgn,initgn,inrgcm,setcgn +C .. +C .. Common blocks .. + COMMON /globe/m1,m2,a1,a2,a1w,a2w,a1vw,a2vw,ig1,ig2,lg1,lg2,cg1, + + cg2,qanti +C .. +C .. Save statement .. + SAVE /globe/,qqssd +C .. +C .. Data statements .. + DATA qqssd/.FALSE./ +C .. +C .. Executable Statements .. +C +C TELL IGNLGI, THE ACTUAL NUMBER GENERATOR, THAT THIS ROUTINE +C HAS BEEN CALLED. +C + qqssd = .TRUE. + CALL getcgn(ocgn) +C +C Initialize Common Block if Necessary +C + IF (.NOT. (qrgnin())) CALL inrgcm() + ig1(1) = iseed1 + ig2(1) = iseed2 + CALL initgn(-1) + DO 10,g = 2,numg + ig1(g) = mltmod(a1vw,ig1(g-1),m1) + ig2(g) = mltmod(a2vw,ig2(g-1),m2) + CALL setcgn(g) + CALL initgn(-1) + 10 CONTINUE + CALL setcgn(ocgn) + RETURN + + ENTRY rgnqsd(qssd) +C********************************************************************** +C +C SUBROUTINE RGNQSD +C Random Number Generator Query SeeD set? +C +C Returns (LOGICAL) QSSD as .TRUE. if SETALL has been invoked, +C otherwise returns .FALSE. +C +C********************************************************************** + qssd = qqssd + RETURN + + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/ranlib/setant.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,75 @@ + SUBROUTINE setant(qvalue) +C********************************************************************** +C +C SUBROUTINE SETANT(QVALUE) +C SET ANTithetic +C +C Sets whether the current generator produces antithetic values. If +C X is the value normally returned from a uniform [0,1] random +C number generator then 1 - X is the antithetic value. If X is the +C value normally returned from a uniform [0,N] random number +C generator then N - 1 - X is the antithetic value. +C +C All generators are initialized to NOT generate antithetic values. +C +C This is a transcription from Pascal to Fortran of routine +C Set_Antithetic from the paper +C +C L'Ecuyer, P. and Cote, S. "Implementing a Random Number Package +C with Splitting Facilities." ACM Transactions on Mathematical +C Software, 17:98-111 (1991) +C +C +C Arguments +C +C +C QVALUE -> .TRUE. if generator G is to generating antithetic +C values, otherwise .FALSE. +C LOGICAL QVALUE +C +C********************************************************************** +C .. Parameters .. + INTEGER numg + PARAMETER (numg=32) +C .. +C .. Scalar Arguments .. + LOGICAL qvalue +C .. +C .. Scalars in Common .. + INTEGER a1,a1vw,a1w,a2,a2vw,a2w,m1,m2 +C .. +C .. Arrays in Common .. + INTEGER cg1(numg),cg2(numg),ig1(numg),ig2(numg),lg1(numg), + + lg2(numg) + LOGICAL qanti(numg) +C .. +C .. Local Scalars .. + INTEGER g +C .. +C .. External Functions .. + LOGICAL qrgnin + EXTERNAL qrgnin +C .. +C .. External Subroutines .. + EXTERNAL getcgn +C .. +C .. Common blocks .. + COMMON /globe/m1,m2,a1,a2,a1w,a2w,a1vw,a2vw,ig1,ig2,lg1,lg2,cg1, + + cg2,qanti +C .. +C .. Save statement .. + SAVE /globe/ +C .. +C .. Executable Statements .. +C Abort unless random number generator initialized + IF (qrgnin()) GO TO 10 + WRITE (*,*) ' SETANT called before random number generator ', + + ' initialized -- abort!' + CALL XSTOPX + + (' SETANT called before random number generator initialized') + + 10 CALL getcgn(g) + qanti(g) = qvalue + RETURN + + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/ranlib/setgmn.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,107 @@ + SUBROUTINE setgmn(meanv,covm,ldcovm,p,parm) +C SUBROUTINE setgmn(meanv,covm,p,parm) +C JJV changed this routine to take leading dimension of COVM +C JJV argument and pass it to SPOTRF, making it easier to use +C JJV if the COVM which is used is contained in a larger matrix +C JJV and to make the routine more consistent with LAPACK. +C JJV Changes are in comments, declarations, and the call to SPOTRF. +C********************************************************************** +C +C SUBROUTINE SETGMN( MEANV, COVM, LDCOVM, P, PARM) +C SET Generate Multivariate Normal random deviate +C +C +C Function +C +C +C Places P, MEANV, and the Cholesky factoriztion of COVM +C in PARM for GENMN. +C +C +C Arguments +C +C +C MEANV --> Mean vector of multivariate normal distribution. +C REAL MEANV(P) +C +C COVM <--> (Input) Covariance matrix of the multivariate +C normal distribution. This routine uses only the +C (1:P,1:P) slice of COVM, but needs to know LDCOVM. +C +C (Output) Destroyed on output +C REAL COVM(LDCOVM,P) +C +C LDCOVM --> Leading actual dimension of COVM. +C INTEGER LDCOVM +C +C P --> Dimension of the normal, or length of MEANV. +C INTEGER P +C +C PARM <-- Array of parameters needed to generate multivariate +C normal deviates (P, MEANV and Cholesky decomposition +C of COVM). +C 1 : 1 - P +C 2 : P + 1 - MEANV +C P+2 : P*(P+3)/2 + 1 - Cholesky decomposition of COVM +C REAL PARM(P*(P+3)/2 + 1) +C +C********************************************************************** +C .. Scalar Arguments .. +C INTEGER p + INTEGER p, ldcovm +C .. +C .. Array Arguments .. +C REAL covm(p,p),meanv(p),parm(p* (p+3)/2+1) + REAL covm(ldcovm,p),meanv(p),parm(p* (p+3)/2+1) +C .. +C .. Local Scalars .. + INTEGER i,icount,info,j +C .. +C .. External Subroutines .. + EXTERNAL spotrf +C .. +C .. Executable Statements .. +C +C +C TEST THE INPUT +C + IF (.NOT. (p.LE.0)) GO TO 10 + WRITE (*,*) 'P nonpositive in SETGMN' + WRITE (*,*) 'Value of P: ',p + CALL XSTOPX ('P nonpositive in SETGMN') + + 10 parm(1) = p +C +C PUT P AND MEANV INTO PARM +C + DO 20,i = 2,p + 1 + parm(i) = meanv(i-1) + 20 CONTINUE +C +C Cholesky decomposition to find A s.t. trans(A)*(A) = COVM +C +C CALL spofa(covm,p,p,info) +C CALL spofa(covm,ldcovm,p,info) + CALL spotrf ( 'Upper', p, covm, ldcovm, info) + IF (.NOT. (info.NE.0)) GO TO 30 + WRITE (*,*) ' COVM not positive definite in SETGMN' + CALL XSTOPX (' COVM not positive definite in SETGMN') + + 30 icount = p + 1 +C +C PUT UPPER HALF OF A, WHICH IS NOW THE CHOLESKY FACTOR, INTO PARM +C COVM(1,1) = PARM(P+2) +C COVM(1,2) = PARM(P+3) +C : +C COVM(1,P) = PARM(2P+1) +C COVM(2,2) = PARM(2P+2) ... +C + DO 50,i = 1,p + DO 40,j = i,p + icount = icount + 1 + parm(icount) = covm(i,j) + 40 CONTINUE + 50 CONTINUE + RETURN +C + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/ranlib/setsd.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,74 @@ + SUBROUTINE setsd(iseed1,iseed2) +C********************************************************************** +C +C SUBROUTINE SETSD(ISEED1,ISEED2) +C SET S-ee-D of current generator +C +C Resets the initial seed of the current generator to ISEED1 and +C ISEED2. The seeds of the other generators remain unchanged. +C +C This is a transcription from Pascal to Fortran of routine +C Set_Seed from the paper +C +C L'Ecuyer, P. and Cote, S. "Implementing a Random Number Package +C with Splitting Facilities." ACM Transactions on Mathematical +C Software, 17:98-111 (1991) +C +C +C Arguments +C +C +C ISEED1 -> First integer seed +C INTEGER ISEED1 +C +C ISEED2 -> Second integer seed +C INTEGER ISEED1 +C +C********************************************************************** +C .. Parameters .. + INTEGER numg + PARAMETER (numg=32) +C .. +C .. Scalar Arguments .. + INTEGER iseed1,iseed2 +C .. +C .. Scalars in Common .. + INTEGER a1,a1vw,a1w,a2,a2vw,a2w,m1,m2 +C .. +C .. Arrays in Common .. + INTEGER cg1(numg),cg2(numg),ig1(numg),ig2(numg),lg1(numg), + + lg2(numg) + LOGICAL qanti(numg) +C .. +C .. Local Scalars .. + INTEGER g +C .. +C .. External Functions .. + LOGICAL qrgnin + EXTERNAL qrgnin +C .. +C .. External Subroutines .. + EXTERNAL getcgn,initgn +C .. +C .. Common blocks .. + COMMON /globe/m1,m2,a1,a2,a1w,a2w,a1vw,a2vw,ig1,ig2,lg1,lg2,cg1, + + cg2,qanti +C .. +C .. Save statement .. + SAVE /globe/ +C .. +C .. Executable Statements .. +C Abort unless random number generator initialized + IF (qrgnin()) GO TO 10 + WRITE (*,*) ' SETSD called before random number generator ', + + ' initialized -- abort!' + CALL XSTOPX + + (' SETSD called before random number generator initialized') + + 10 CALL getcgn(g) + ig1(g) = iseed1 + ig2(g) = iseed2 + CALL initgn(-1) + RETURN + + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/ranlib/sexpo.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,78 @@ + REAL FUNCTION sexpo() +C**********************************************************************C +C C +C C +C (STANDARD-) E X P O N E N T I A L DISTRIBUTION C +C C +C C +C**********************************************************************C +C**********************************************************************C +C C +C FOR DETAILS SEE: C +C C +C AHRENS, J.H. AND DIETER, U. C +C COMPUTER METHODS FOR SAMPLING FROM THE C +C EXPONENTIAL AND NORMAL DISTRIBUTIONS. C +C COMM. ACM, 15,10 (OCT. 1972), 873 - 882. C +C C +C ALL STATEMENT NUMBERS CORRESPOND TO THE STEPS OF ALGORITHM C +C 'SA' IN THE ABOVE PAPER (SLIGHTLY MODIFIED IMPLEMENTATION) C +C C +C Modified by Barry W. Brown, Feb 3, 1988 to use RANF instead of C +C SUNIF. The argument IR thus goes away. C +C C +C**********************************************************************C +C +C +C Q(N) = SUM(ALOG(2.0)**K/K!) K=1,..,N , THE HIGHEST N +C (HERE 8) IS DETERMINED BY Q(N)=1.0 WITHIN STANDARD PRECISION +C +C JJV added a Save statement for q (in Data statement) +C .. Local Scalars .. + REAL a,q1,u,umin,ustar + INTEGER i +C .. +C .. Local Arrays .. + REAL q(8) +C .. +C .. External Functions .. + REAL ranf + EXTERNAL ranf +C .. +C .. Equivalences .. + EQUIVALENCE (q(1),q1) +C .. +C .. Save statement .. + SAVE q +C .. +C .. Data statements .. + DATA q/.6931472,.9333737,.9888778,.9984959,.9998293,.9999833, + + .9999986,.9999999/ +C .. +C + 10 a = 0.0 + u = ranf() + GO TO 30 + + 20 a = a + q1 + 30 u = u + u +C JJV changed the following to reflect the true algorithm and +C JJV prevent unpredictable behavior if U is initially 0.5. +C IF (u.LE.1.0) GO TO 20 + IF (u.LT.1.0) GO TO 20 + 40 u = u - 1.0 + IF (u.GT.q1) GO TO 60 + 50 sexpo = a + u + RETURN + + 60 i = 1 + ustar = ranf() + umin = ustar + 70 ustar = ranf() + IF (ustar.LT.umin) umin = ustar + 80 i = i + 1 + IF (u.GT.q(i)) GO TO 70 + 90 sexpo = a + umin*q1 + RETURN + + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/ranlib/sgamma.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,235 @@ + REAL FUNCTION sgamma(a) +C**********************************************************************C +C C +C C +C (STANDARD-) G A M M A DISTRIBUTION C +C C +C C +C**********************************************************************C +C**********************************************************************C +C C +C PARAMETER A >= 1.0 ! C +C C +C**********************************************************************C +C C +C FOR DETAILS SEE: C +C C +C AHRENS, J.H. AND DIETER, U. C +C GENERATING GAMMA VARIATES BY A C +C MODIFIED REJECTION TECHNIQUE. C +C COMM. ACM, 25,1 (JAN. 1982), 47 - 54. C +C C +C STEP NUMBERS CORRESPOND TO ALGORITHM 'GD' IN THE ABOVE PAPER C +C (STRAIGHTFORWARD IMPLEMENTATION) C +C C +C Modified by Barry W. Brown, Feb 3, 1988 to use RANF instead of C +C SUNIF. The argument IR thus goes away. C +C C +C**********************************************************************C +C C +C PARAMETER 0.0 < A < 1.0 ! C +C C +C**********************************************************************C +C C +C FOR DETAILS SEE: C +C C +C AHRENS, J.H. AND DIETER, U. C +C COMPUTER METHODS FOR SAMPLING FROM GAMMA, C +C BETA, POISSON AND BINOMIAL DISTRIBUTIONS. C +C COMPUTING, 12 (1974), 223 - 246. C +C C +C (ADAPTED IMPLEMENTATION OF ALGORITHM 'GS' IN THE ABOVE PAPER) C +C C +C**********************************************************************C +C +C +C INPUT: A =PARAMETER (MEAN) OF THE STANDARD GAMMA DISTRIBUTION +C OUTPUT: SGAMMA = SAMPLE FROM THE GAMMA-(A)-DISTRIBUTION +C +C COEFFICIENTS Q(K) - FOR Q0 = SUM(Q(K)*A**(-K)) +C COEFFICIENTS A(K) - FOR Q = Q0+(T*T/2)*SUM(A(K)*V**K) +C COEFFICIENTS E(K) - FOR EXP(Q)-1 = SUM(E(K)*Q**K) +C +C .. Scalar Arguments .. + REAL a +C .. +C .. Local Scalars .. (JJV added B0 to fix rare and subtle bug) + REAL a1,a2,a3,a4,a5,a6,a7,aa,aaa,b,b0,c,d,e,e1,e2,e3,e4,e5,p,q,q0, + + q1,q2,q3,q4,q5,q6,q7,r,s,s2,si,sqrt32,t,u,v,w,x +C .. +C .. External Functions .. + REAL ranf,sexpo,snorm + EXTERNAL ranf,sexpo,snorm +C .. +C .. Intrinsic Functions .. + INTRINSIC abs,alog,exp,sign,sqrt +C .. +C .. Save statement .. +C JJV added Save statement for vars in Data satatements + SAVE aa,aaa,s2,s,d,q0,b,si,c,q1,q2,q3,q4,q5,q6,q7,a1,a2,a3,a4,a5, + + a6,a7,e1,e2,e3,e4,e5,sqrt32 +C .. +C .. Data statements .. +C +C PREVIOUS A PRE-SET TO ZERO - AA IS A', AAA IS A" +C SQRT32 IS THE SQUAREROOT OF 32 = 5.656854249492380 +C + DATA q1,q2,q3,q4,q5,q6,q7/.04166669,.02083148,.00801191,.00144121, + + -.00007388,.00024511,.00024240/ + DATA a1,a2,a3,a4,a5,a6,a7/.3333333,-.2500030,.2000062,-.1662921, + + .1423657,-.1367177,.1233795/ + DATA e1,e2,e3,e4,e5/1.,.4999897,.1668290,.0407753,.0102930/ + DATA aa/0.0/,aaa/0.0/,sqrt32/5.656854/ +C .. +C .. Executable Statements .. +C + IF (a.EQ.aa) GO TO 10 + IF (a.LT.1.0) GO TO 130 +C +C STEP 1: RECALCULATIONS OF S2,S,D IF A HAS CHANGED +C + aa = a + s2 = a - 0.5 + s = sqrt(s2) + d = sqrt32 - 12.0*s +C +C STEP 2: T=STANDARD NORMAL DEVIATE, +C X=(S,1/2)-NORMAL DEVIATE. +C IMMEDIATE ACCEPTANCE (I) +C + 10 t = snorm() + x = s + 0.5*t + sgamma = x*x + IF (t.GE.0.0) RETURN +C +C STEP 3: U= 0,1 -UNIFORM SAMPLE. SQUEEZE ACCEPTANCE (S) +C + u = ranf() + IF (d*u.LE.t*t*t) RETURN +C +C STEP 4: RECALCULATIONS OF Q0,B,SI,C IF NECESSARY +C + IF (a.EQ.aaa) GO TO 40 + aaa = a + r = 1.0/a + q0 = ((((((q7*r+q6)*r+q5)*r+q4)*r+q3)*r+q2)*r+q1)*r +C +C APPROXIMATION DEPENDING ON SIZE OF PARAMETER A +C THE CONSTANTS IN THE EXPRESSIONS FOR B, SI AND +C C WERE ESTABLISHED BY NUMERICAL EXPERIMENTS +C + IF (a.LE.3.686) GO TO 30 + IF (a.LE.13.022) GO TO 20 +C +C CASE 3: A .GT. 13.022 +C + b = 1.77 + si = .75 + c = .1515/s + GO TO 40 +C +C CASE 2: 3.686 .LT. A .LE. 13.022 +C + 20 b = 1.654 + .0076*s2 + si = 1.68/s + .275 + c = .062/s + .024 + GO TO 40 +C +C CASE 1: A .LE. 3.686 +C + 30 b = .463 + s + .178*s2 + si = 1.235 + c = .195/s - .079 + .16*s +C +C STEP 5: NO QUOTIENT TEST IF X NOT POSITIVE +C + 40 IF (x.LE.0.0) GO TO 70 +C +C STEP 6: CALCULATION OF V AND QUOTIENT Q +C + v = t/ (s+s) + IF (abs(v).LE.0.25) GO TO 50 + q = q0 - s*t + 0.25*t*t + (s2+s2)*alog(1.0+v) + GO TO 60 + + 50 q = q0 + 0.5*t*t* ((((((a7*v+a6)*v+a5)*v+a4)*v+a3)*v+a2)*v+a1)*v +C +C STEP 7: QUOTIENT ACCEPTANCE (Q) +C + 60 IF (alog(1.0-u).LE.q) RETURN +C +C STEP 8: E=STANDARD EXPONENTIAL DEVIATE +C U= 0,1 -UNIFORM DEVIATE +C T=(B,SI)-DOUBLE EXPONENTIAL (LAPLACE) SAMPLE +C + 70 e = sexpo() + u = ranf() + u = u + u - 1.0 + t = b + sign(si*e,u) +C +C STEP 9: REJECTION IF T .LT. TAU(1) = -.71874483771719 +C + 80 IF (t.LT. (-.7187449)) GO TO 70 +C +C STEP 10: CALCULATION OF V AND QUOTIENT Q +C + v = t/ (s+s) + IF (abs(v).LE.0.25) GO TO 90 + q = q0 - s*t + 0.25*t*t + (s2+s2)*alog(1.0+v) + GO TO 100 + + 90 q = q0 + 0.5*t*t* ((((((a7*v+a6)*v+a5)*v+a4)*v+a3)*v+a2)*v+a1)*v +C +C STEP 11: HAT ACCEPTANCE (H) (IF Q NOT POSITIVE GO TO STEP 8) +C + 100 IF (q.LE.0.0) GO TO 70 + IF (q.LE.0.5) GO TO 110 +C +C JJV modified the code through line 125 to handle large Q case +C + IF (q.LT.15.0) GO TO 105 +C +C JJV Here Q is large enough that Q = log(exp(Q) - 1.0) (for real Q) +C JJV so reformulate test at 120 in terms of one EXP, if not too big +C JJV 87.49823 is close to the largest real which can be +C JJV exponentiated (87.49823 = log(1.0E38)) +C + IF ((q+e-0.5*t*t).GT.87.49823) GO TO 125 + IF (c*abs(u).GT.exp(q+e-0.5*t*t)) GO TO 70 + GO TO 125 + + 105 w = exp(q) - 1.0 + GO TO 120 + + 110 w = ((((e5*q+e4)*q+e3)*q+e2)*q+e1)*q +C +C IF T IS REJECTED, SAMPLE AGAIN AT STEP 8 +C + 120 IF (c*abs(u).GT.w*exp(e-0.5*t*t)) GO TO 70 + 125 x = s + 0.5*t + sgamma = x*x + RETURN +C +C ALTERNATE METHOD FOR PARAMETERS A BELOW 1 (.3678794=EXP(-1.)) +C +C JJV changed B to B0 (which was added to declarations for this) +C JJV in 130 to END to fix rare and subtle bug. +C JJV Line: '130 aa = 0.0' was removed (unnecessary, wasteful). +C JJV Reasons: the state of AA only serves to tell the A .GE. 1.0 +C JJV case if certain A-dependant constants need to be recalculated. +C JJV The A .LT. 1.0 case (here) no longer changes any of these, and +C JJV the recalculation of B (which used to change with an +C JJV A .LT. 1.0 call) is governed by the state of AAA anyway. +C + 130 b0 = 1.0 + .3678794*a + 140 p = b0*ranf() + IF (p.GE.1.0) GO TO 150 + sgamma = exp(alog(p)/a) + IF (sexpo().LT.sgamma) GO TO 140 + RETURN + + 150 sgamma = -alog((b0-p)/a) + IF (sexpo().LT. (1.0-a)*alog(sgamma)) GO TO 140 + RETURN + + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/ranlib/snorm.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,138 @@ + REAL FUNCTION snorm() +C**********************************************************************C +C C +C C +C (STANDARD-) N O R M A L DISTRIBUTION C +C C +C C +C**********************************************************************C +C**********************************************************************C +C C +C FOR DETAILS SEE: C +C C +C AHRENS, J.H. AND DIETER, U. C +C EXTENSIONS OF FORSYTHE'S METHOD FOR RANDOM C +C SAMPLING FROM THE NORMAL DISTRIBUTION. C +C MATH. COMPUT., 27,124 (OCT. 1973), 927 - 937. C +C C +C ALL STATEMENT NUMBERS CORRESPOND TO THE STEPS OF ALGORITHM 'FL' C +C (M=5) IN THE ABOVE PAPER (SLIGHTLY MODIFIED IMPLEMENTATION) C +C C +C Modified by Barry W. Brown, Feb 3, 1988 to use RANF instead of C +C SUNIF. The argument IR thus goes away. C +C C +C**********************************************************************C +C +C +C THE DEFINITIONS OF THE CONSTANTS A(K), D(K), T(K) AND +C H(K) ARE ACCORDING TO THE ABOVEMENTIONED ARTICLE +C +C .. Local Scalars .. + REAL aa,s,tt,u,ustar,w,y + INTEGER i +C .. +C .. Local Arrays .. + REAL a(32),d(31),h(31),t(31) +C .. +C .. External Functions .. + REAL ranf + EXTERNAL ranf +C .. +C .. Intrinsic Functions .. + INTRINSIC float,int +C .. +C .. Save statement .. +C JJV added a Save statement for arrays initialized in Data statmts + SAVE a,d,t,h +C .. +C .. Data statements .. + DATA a/0.0,.3917609E-1,.7841241E-1,.1177699,.1573107,.1970991, + + .2372021,.2776904,.3186394,.3601299,.4022501,.4450965, + + .4887764,.5334097,.5791322,.6260990,.6744898,.7245144, + + .7764218,.8305109,.8871466,.9467818,1.009990,1.077516, + + 1.150349,1.229859,1.318011,1.417797,1.534121,1.675940, + + 1.862732,2.153875/ + DATA d/5*0.0,.2636843,.2425085,.2255674,.2116342,.1999243, + + .1899108,.1812252,.1736014,.1668419,.1607967,.1553497, + + .1504094,.1459026,.1417700,.1379632,.1344418,.1311722, + + .1281260,.1252791,.1226109,.1201036,.1177417,.1155119, + + .1134023,.1114027,.1095039/ + DATA t/.7673828E-3,.2306870E-2,.3860618E-2,.5438454E-2, + + .7050699E-2,.8708396E-2,.1042357E-1,.1220953E-1,.1408125E-1, + + .1605579E-1,.1815290E-1,.2039573E-1,.2281177E-1,.2543407E-1, + + .2830296E-1,.3146822E-1,.3499233E-1,.3895483E-1,.4345878E-1, + + .4864035E-1,.5468334E-1,.6184222E-1,.7047983E-1,.8113195E-1, + + .9462444E-1,.1123001,.1364980,.1716886,.2276241,.3304980, + + .5847031/ + DATA h/.3920617E-1,.3932705E-1,.3950999E-1,.3975703E-1, + + .4007093E-1,.4045533E-1,.4091481E-1,.4145507E-1,.4208311E-1, + + .4280748E-1,.4363863E-1,.4458932E-1,.4567523E-1,.4691571E-1, + + .4833487E-1,.4996298E-1,.5183859E-1,.5401138E-1,.5654656E-1, + + .5953130E-1,.6308489E-1,.6737503E-1,.7264544E-1,.7926471E-1, + + .8781922E-1,.9930398E-1,.1155599,.1404344,.1836142,.2790016, + + .7010474/ +C .. +C .. Executable Statements .. +C + 10 u = ranf() + s = 0.0 + IF (u.GT.0.5) s = 1.0 + u = u + u - s + 20 u = 32.0*u + i = int(u) + IF (i.EQ.32) i = 31 + IF (i.EQ.0) GO TO 100 +C +C START CENTER +C + 30 ustar = u - float(i) + aa = a(i) + 40 IF (ustar.LE.t(i)) GO TO 60 + w = (ustar-t(i))*h(i) +C +C EXIT (BOTH CASES) +C + 50 y = aa + w + snorm = y + IF (s.EQ.1.0) snorm = -y + RETURN +C +C CENTER CONTINUED +C + 60 u = ranf() + w = u* (a(i+1)-aa) + tt = (0.5*w+aa)*w + GO TO 80 + + 70 tt = u + ustar = ranf() + 80 IF (ustar.GT.tt) GO TO 50 + 90 u = ranf() + IF (ustar.GE.u) GO TO 70 + ustar = ranf() + GO TO 40 +C +C START TAIL +C + 100 i = 6 + aa = a(32) + GO TO 120 + + 110 aa = aa + d(i) + i = i + 1 + 120 u = u + u + IF (u.LT.1.0) GO TO 110 + 130 u = u - 1.0 + 140 w = u*d(i) + tt = (0.5*w+aa)*w + GO TO 160 + + 150 tt = u + 160 ustar = ranf() + IF (ustar.GT.tt) GO TO 50 + 170 u = ranf() + IF (ustar.GE.u) GO TO 150 + u = ranf() + GO TO 140 + + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/ranlib/tstbot.for Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,94 @@ + PROGRAM tstbot +C********************************************************************** +C +C A test program for the bottom level routines +C +C********************************************************************** +C Set up the random number generator +C .. Local Scalars .. + INTEGER ians,iblock,igen,iseed1,iseed2,itmp,ix,ixgen,nbad +C .. +C .. Local Arrays .. + INTEGER answer(10000),genlst(5) +C .. +C .. External Functions .. + INTEGER ignlgi + EXTERNAL ignlgi +C .. +C .. External Subroutines .. + EXTERNAL getsd,initgn,setall,setcgn +C .. +C .. Data statements .. + DATA genlst/1,5,10,20,32/ +C .. +C .. Executable Statements .. + nbad = 0 + WRITE (*,9000) + + 9000 FORMAT (' For five virual generators of the 32'/ + + ' This test generates 10000 numbers then resets the block'/ + + ' and does it again'/ + + ' Any disagreements are reported -- there should be none'/) +C +C Set up Generators +C + CALL setall(12345,54321) +C +C For a selected set of generators +C + DO 60,ixgen = 1,5 + igen = genlst(ixgen) + CALL setcgn(igen) + WRITE (*,*) ' Testing generator ',igen +C +C Use 10 blocks +C + CALL initgn(-1) + CALL getsd(iseed1,iseed2) + DO 20,iblock = 1,10 +C +C Generate 1000 numbers +C + DO 10,ians = 1,1000 + ix = ians + (iblock-1)*1000 + answer(ix) = ignlgi() + 10 CONTINUE + CALL initgn(+1) + 20 CONTINUE + CALL initgn(-1) +C +C Do it again and compare answers +C + CALL getsd(iseed1,iseed2) +C +C Use 10 blocks +C + DO 50,iblock = 1,10 +C +C Generate 1000 numbers +C + DO 40,ians = 1,1000 + ix = ians + (iblock-1)*1000 +C ANSWER( IX ) = IGNLGI() + itmp = ignlgi() + IF (.NOT. (itmp.NE.answer(ix))) GO TO 30 + WRITE (*,9010) iblock,ians,ix,answer(ix),itmp + + 9010 FORMAT (' Disagreement on regeneration of numbers'/ + + ' Block ',I2,' N within Block ',I2, + + ' Index in answer ',I5/ + + ' Originally Generated ',I10,' Regenerated ', + + I10) + + nbad = nbad + 1 + IF (nbad.GT.10) STOP ' More than 10 mismatches' + 30 CONTINUE + 40 CONTINUE + CALL initgn(+1) + 50 CONTINUE + WRITE (*,*) ' Finished testing generator ',igen + WRITE (*,*) ' Test completed successfully' + 60 CONTINUE + STOP + + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/ranlib/tstgmn.for Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,229 @@ +C JJV changed name to ONECOV to avoid confusion with array COVAR +C JJV this was also changed in the body of the function +C REAL FUNCTION covar(x,y,n) + REAL FUNCTION onecov(x,y,n) +C .. Scalar Arguments .. + INTEGER n +C .. +C .. Array Arguments .. + REAL x(n),y(n) +C .. +C .. Local Scalars .. + REAL avx,avy,varx,vary,xmax,xmin + INTEGER i +C .. +C .. External Subroutines .. + EXTERNAL stat +C .. +C .. Intrinsic Functions .. + INTRINSIC real +C .. +C .. Executable Statements .. + CALL stat(x,n,avx,varx,xmin,xmax) + CALL stat(y,n,avy,vary,xmin,xmax) +C covar = 0.0 + onecov = 0.0 + DO 10,i = 1,n +C covar = covar + (x(i)-avx)* (y(i)-avy) + onecov = onecov + (x(i)-avx)* (y(i)-avy) + 10 CONTINUE +C covar = covar/real(n-1) + onecov = onecov/real(n-1) + RETURN + + END + +C JJV Added argument LDXCOV (leading dimension of XCOVAR) to be +C JJV consistent with the program TSTGMN, see comments below. +C JJV This change necessitated changes in the declarations. +C SUBROUTINE prcomp(p,mean,xcovar,answer) + SUBROUTINE prcomp(p,mean,xcovar,ldxcov,answer) + +C INTEGER p,maxp + INTEGER p,maxp,ldxcov + PARAMETER (maxp=10) +C REAL mean(p),xcovar(p,p),rcovar(maxp,maxp) + REAL mean(p),xcovar(ldxcov,p),rcovar(maxp,maxp) + REAL answer(1000,maxp) +C JJV added ONECOV because of name change to function COVAR +C REAL rmean(maxp),rvar(maxp) + REAL rmean(maxp),rvar(maxp),onecov + INTEGER maxobs + PARAMETER (maxobs=1000) + + DO 10,i = 1,p + CALL stat(answer(1,i),maxobs,rmean(i),rvar(i),dum1,dum2) + WRITE (*,*) ' Variable Number',i + WRITE (*,*) ' Mean ',mean(i),' Generated ',rmean(i) + WRITE (*,*) ' Variance ',xcovar(i,i),' Generated',rvar(i) + 10 CONTINUE + WRITE (*,*) ' Covariances' + DO 30,i = 1,p + DO 20,j = 1,i - 1 + WRITE (*,*) ' I = ',i,' J = ',j +C JJV changed COVAR to match new name +C rcovar(i,j) = covar(answer(1,i),answer(1,j),maxobs) + rcovar(i,j) = onecov(answer(1,i),answer(1,j),maxobs) + WRITE (*,*) ' Covariance ',xcovar(i,j),' Generated ', + + rcovar(i,j) + 20 CONTINUE + 30 CONTINUE + RETURN + + END + +C JJV added LDCOV (leading dimension of COVAR) to be +C JJV consistent with the program TSTGMN, see comments below. +C JJV This change necessitated changes in the declarations. +C SUBROUTINE setcov(p,var,corr,covar) + SUBROUTINE setcov(p,var,corr,covar,ldcov) +C Set covariance matrix from variance and common correlation +C .. Scalar Arguments .. + REAL corr +C INTEGER p + INTEGER p,ldcov +C .. +C .. Array Arguments .. +C REAL covar(p,p),var(p) + REAL covar(ldcov,p),var(p) +C .. +C .. Local Scalars .. + INTEGER i,j +C .. +C .. Intrinsic Functions .. + INTRINSIC sqrt +C .. +C .. Executable Statements .. + DO 40,i = 1,p + DO 30,j = 1,p + IF (.NOT. (i.EQ.j)) GO TO 10 + covar(i,j) = var(i) + GO TO 20 + + 10 covar(i,j) = corr*sqrt(var(i)*var(j)) + 20 CONTINUE + 30 CONTINUE + 40 CONTINUE + RETURN + + END + + SUBROUTINE stat(x,n,av,var,xmin,xmax) +C .. Scalar Arguments .. + REAL av,var,xmax,xmin + INTEGER n +C .. +C .. Array Arguments .. + REAL x(n) +C .. +C .. Local Scalars .. + REAL sum + INTEGER i +C .. +C .. Intrinsic Functions .. + INTRINSIC real +C .. +C .. Executable Statements .. + xmin = x(1) + xmax = x(1) + sum = 0.0 + DO 10,i = 1,n + sum = sum + x(i) + IF (x(i).LT.xmin) xmin = x(i) + IF (x(i).GT.xmax) xmax = x(i) + 10 CONTINUE + av = sum/real(n) + sum = 0.0 + DO 20,i = 1,n + sum = sum + (x(i)-av)**2 + 20 CONTINUE + var = sum/real(n-1) + RETURN + + END + + PROGRAM tstgmn +C Test Generation of Multivariate Normal Data +C JJV SETGMN was: SUBROUTINE setgmn(meanv,covm,p,parm) +C JJV is: SUBROUTINE setgmn(meanv,covm,ldcovm,p,parm) +C JJV So the covariance matrices have been changed to 2-dim'l +C JJV matrices, and the additional argument has been added to +C JJV the subroutine call. Additional changes have been made +C JJV to reflect this. (in declarations, the matrix copy routine, +C JJV and in subroutine calls.) +C .. Parameters .. + INTEGER maxp + PARAMETER (maxp=10) + INTEGER maxobs + PARAMETER (maxobs=1000) +C JJV this parameter is no longer needed +C INTEGER p2 +C PARAMETER (p2=maxp*maxp) +C .. +C .. Local Scalars .. + REAL corr + INTEGER i,iobs,is1,is2,j,p + CHARACTER phrase*100 +C .. +C .. Local Arrays .. +C REAL answer(1000,maxp),ccovar(p2),covar(p2),mean(maxp),param(500), +C + temp(maxp),var(maxp),work(maxp) + REAL answer(1000,maxp),ccovar(maxp,maxp),covar(maxp,maxp), + + mean(maxp),param(500),temp(maxp),var(maxp),work(maxp) +C .. +C .. External Subroutines .. + EXTERNAL genmn,phrtsd,prcomp,setall,setcov,setgmn +C .. +C .. Executable Statements .. + WRITE (*,9000) + + 9000 FORMAT ( + + ' Tests Multivariate Normal Generator for Up to 10 Variables' + + / + + ' User inputs means, variances, one correlation that is applied' + + /' to all pairs of variables'/ + + ' 1000 multivariate normal deviates are generated'/ + + ' Means, variances and covariances are calculated for these.' + + ) + + 10 WRITE (*,*) 'Enter number of variables for normal generator' + READ (*,*) p + WRITE (*,*) 'Enter mean vector of length ',p + READ (*,*) (mean(i),i=1,p) + WRITE (*,*) 'Enter variance vector of length ',p + READ (*,*) (var(i),i=1,p) + WRITE (*,*) 'Enter correlation of all variables' + READ (*,*) corr +C CALL setcov(p,var,corr,covar) + CALL setcov(p,var,corr,covar,maxp) + WRITE (*,*) ' Enter phrase to initialize rn generator' + READ (*,'(a)') phrase + CALL phrtsd(phrase,is1,is2) + CALL setall(is1,is2) +C DO 20,i = 1,p2 +C ccovar(i) = covar(i) +C 20 CONTINUE + DO 25,i = 1,maxp + DO 20,j = 1,maxp + ccovar(i,j) = covar(i,j) + 20 CONTINUE + 25 CONTINUE +C +C Generate Variables +C +C CALL setgmn(mean,ccovar,p,param) + CALL setgmn(mean,ccovar,maxp,p,param) + DO 40,iobs = 1,maxobs + CALL genmn(param,work,temp) + DO 30,j = 1,p + answer(iobs,j) = work(j) + 30 CONTINUE + 40 CONTINUE +C CALL prcomp(p,mean,covar,answer) + CALL prcomp(p,mean,covar,maxp,answer) +C +C Print Comparison of Generated and Reconstructed Values +C + GO TO 10 + + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/ranlib/tstmid.for Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,611 @@ + SUBROUTINE stat(x,n,av,var,xmin,xmax) +C********************************************************************** +C +C SUBROUTINE STAT( X, N, AV, VAR) +C +C compute STATistics +C +C +C Function +C +C +C Computes AVerage and VARiance of array X(N). +C +C********************************************************************** +C .. Scalar Arguments .. + REAL av,var,xmax,xmin + INTEGER n +C .. +C .. Array Arguments .. + REAL x(n) +C .. +C .. Local Scalars .. + REAL sum + INTEGER i +C .. +C .. Intrinsic Functions .. + INTRINSIC real +C .. +C .. Executable Statements .. + xmin = x(1) + xmax = x(1) + sum = 0.0 + DO 10,i = 1,n + sum = sum + x(i) + IF (x(i).LT.xmin) xmin = x(i) + IF (x(i).GT.xmax) xmax = x(i) + 10 CONTINUE + av = sum/real(n) + sum = 0.0 + DO 20,i = 1,n + sum = sum + (x(i)-av)**2 + 20 CONTINUE + var = sum/real(n-1) + RETURN + + END + PROGRAM tstall + IMPLICIT LOGICAL (q) +C Interactive test for PHRTSD +C .. Parameters .. + INTEGER mxwh,mxncat + PARAMETER (mxwh=15,mxncat=100) +C .. +C .. Local Scalars .. + REAL av,avtr,var,vartr,xmin,xmax,pevt,psum,rtry + INTEGER i,is1,is2,itmp,iwhich,j,mxint,nperm,nrep,ntot,ntry,ncat + CHARACTER ctype*4,phrase*100 +C .. +C .. Local Arrays .. + REAL array(1000),param(3),prob(mxncat) + INTEGER iarray(1000),perm(500) +C .. +C .. External Functions .. + REAL genbet,genchi,genf,gennch,gennf,genunf,genexp,gengam,gennor + INTEGER ignuin,ignnbn + EXTERNAL genbet,genchi,genf,gennch,gennf,genunf,ignuin +C .. +C .. External Subroutines .. + EXTERNAL genprm,phrtsd,setall,stat,trstat,genmul +C .. +C .. Executable Statements .. + WRITE (*,9000) + + 9000 FORMAT (' Tests most generators of specific distributions.'/ + + ' Generates 1000 deviates: reports mean and variance.'/ + + ' Also reports theoretical mean and variance.'/ + + ' If theoretical mean or var doesn''t exist prints -1.'/ + + ' For permutations, generates one permutation of 1..n'/ + + ' and prints it.'/ + + ' For uniform integers asks for upper bound, number of'/ + + ' replicates per integer in 1..upper bound.'/ + + ' Prints table of num times each integer generated.'/ + + ' For multinomial asks for number of events to be'/ + + ' classified, number of categories in which they'/ + + ' are to be classified, and the probabilities that'/ + + ' an event will be classified in the categories,'/ + + ' for all but the last category. Prints table of'/ + + ' number of events by category, true probability'/ + + ' associated with each category, and observed'/ + + ' proportion of events in each category.') +C +C Menu for choosing tests +C + 10 WRITE (*,9010) + + 9010 FORMAT (' Enter number corresponding to choice:'/ + + ' (0) Exit this program'/ + + ' (1) Generate Chi-Square deviates'/ + + ' (2) Generate noncentral Chi-Square deviates'/ + + ' (3) Generate F deviates'/ + + ' (4) Generate noncentral F deviates'/ + + ' (5) Generate random permutation'/ + + ' (6) Generate uniform integers'/ + + ' (7) Generate uniform reals'/ + + ' (8) Generate beta deviates'/ + + ' (9) Generate binomial outcomes'/ + + ' (10) Generate Poisson outcomes'/ + + ' (11) Generate exponential deviates'/ + + ' (12) Generate gamma deviates'/ + + ' (13) Generate multinomial outcomes'/ + + ' (14) Generate normal deviates'/ + + ' (15) Generate negative binomial outcomes'/) + + READ (*,*) iwhich + IF (.NOT. (iwhich.LT.0.OR.iwhich.GT.mxwh)) GO TO 20 + WRITE (*,*) ' Choices are 1..',mxwh,' - try again.' + GO TO 10 + + 20 IF (iwhich.EQ.0) STOP ' Normal termination rn tests' + WRITE (*,*) ' Enter phrase to initialize rn generator' + READ (*,'(a)') phrase + CALL phrtsd(phrase,is1,is2) + CALL setall(is1,is2) + + IF ((1).NE. (iwhich)) GO TO 40 +C +C Chi-square deviates +C + ctype = 'chis' + WRITE (*,*) ' Enter (real) df for the chi-square generation' + READ (*,*) param(1) + DO 30,i = 1,1000 + array(i) = genchi(param(1)) + 30 CONTINUE + CALL stat(array,1000,av,var,xmin,xmax) + CALL trstat(ctype,param,avtr,vartr) + WRITE (*,9020) av,avtr,var,vartr,xmin,xmax + + 9020 FORMAT (' Mean Generated: ',T30,G15.7,5X,'True:',T60, + + G15.7/' Variance Generated:',T30,G15.7,5X,'True:',T60, + + G15.7/' Minimum: ',T30,G15.7,5X,'Maximum:',T60,G15.7) + + GO TO 420 + + 40 IF ((2).NE. (iwhich)) GO TO 60 + +C +C Noncentral Chi-square deviates +C + ctype = 'ncch' + WRITE (*,*) ' Enter (real) df' + WRITE (*,*) ' (real) noncentrality parameter' + READ (*,*) param(1),param(2) + DO 50,i = 1,1000 + array(i) = gennch(param(1),param(2)) + 50 CONTINUE + CALL stat(array,1000,av,var,xmin,xmax) + CALL trstat(ctype,param,avtr,vartr) + WRITE (*,9020) av,avtr,var,vartr,xmin,xmax + GO TO 420 + + 60 IF ((3).NE. (iwhich)) GO TO 80 + +C +C F deviates +C + ctype = 'f' + WRITE (*,*) ' Enter (real) df of the numerator' + WRITE (*,*) ' (real) df of the denominator' + READ (*,*) param(1),param(2) + DO 70,i = 1,1000 + array(i) = genf(param(1),param(2)) + 70 CONTINUE + CALL stat(array,1000,av,var,xmin,xmax) + CALL trstat(ctype,param,avtr,vartr) + WRITE (*,9020) av,avtr,var,vartr,xmin,xmax + GO TO 420 + + 80 IF ((4).NE. (iwhich)) GO TO 100 + +C +C Noncentral F deviates +C + ctype = 'ncf' + WRITE (*,*) ' Enter (real) df of the numerator' + WRITE (*,*) ' (real) df of the denominator' + WRITE (*,*) ' (real) noncentrality parameter' + READ (*,*) param(1),param(2),param(3) + DO 90,i = 1,1000 + array(i) = gennf(param(1),param(2),param(3)) + 90 CONTINUE + CALL stat(array,1000,av,var,xmin,xmax) + CALL trstat(ctype,param,avtr,vartr) + WRITE (*,9020) av,avtr,var,vartr,xmin,xmax + GO TO 420 + + 100 IF ((5).NE. (iwhich)) GO TO 140 + +C +C Random permutation +C + 110 WRITE (*,*) ' Enter size of permutation' + READ (*,*) nperm + IF (.NOT. (nperm.LT.1.OR.nperm.GT.500)) GO TO 120 + WRITE (*,*) ' Permutation size must be between 1 and 500 ', + + '- try again!' + GO TO 110 + + 120 WRITE (*,*) ' Random Permutation Generated - Size',nperm + DO 130,i = 1,500 + perm(i) = i + 130 CONTINUE + CALL genprm(perm,nperm) + WRITE (*,*) ' Perm Generated' + WRITE (*,'(20I4)') (perm(i),i=1,nperm) + GO TO 420 + + 140 IF ((6).NE. (iwhich)) GO TO 170 + +C +C Uniform integer +C + WRITE (*,*) ' Enter maximum uniform integer' + READ (*,*) mxint + WRITE (*,*) ' Enter number of replications per integer' + READ (*,*) nrep + DO 150,i = 1,1000 + iarray(i) = 0 + 150 CONTINUE + ntot = mxint*nrep + DO 160,i = 1,ntot + itmp = ignuin(1,mxint) + iarray(itmp) = iarray(itmp) + 1 + 160 CONTINUE + WRITE (*,*) ' Counts of Integers Generated' + WRITE (*,'(20I4)') (iarray(j),j=1,mxint) + GO TO 420 + + 170 IF ((7).NE. (iwhich)) GO TO 190 + +C +C Uniform real +C + ctype = 'unif' + WRITE (*,*) ' Enter Low then High bound for uniforms' + READ (*,*) param(1),param(2) + DO 180,i = 1,1000 + array(i) = genunf(param(1),param(2)) + 180 CONTINUE + CALL stat(array,1000,av,var,xmin,xmax) + CALL trstat(ctype,param,avtr,vartr) + WRITE (*,9020) av,avtr,var,vartr,xmin,xmax + GO TO 420 + + 190 IF ((8).NE. (iwhich)) GO TO 210 + +C +C Beta deviate +C + ctype = 'beta' + WRITE (*,*) ' Enter A, B for Beta deviate' + READ (*,*) param(1),param(2) + DO 200,i = 1,1000 + array(i) = genbet(param(1),param(2)) + 200 CONTINUE + CALL stat(array,1000,av,var,xmin,xmax) + CALL trstat(ctype,param,avtr,vartr) + WRITE (*,9020) av,avtr,var,vartr,xmin,xmax + GO TO 420 + + 210 IF ((9).NE. (iwhich)) GO TO 240 + +C +C Binomial outcomes +C + ctype = 'bin' + WRITE (*,*) ' Enter number of trials, Prob event for ', + + 'binomial outcomes' + READ (*,*) ntry,pevt + DO 220,i = 1,1000 + iarray(i) = ignbin(ntry,pevt) + 220 CONTINUE + DO 230,i = 1,1000 + array(i) = iarray(i) + 230 CONTINUE + CALL stat(array,1000,av,var,xmin,xmax) + param(1) = ntry + param(2) = pevt + CALL trstat(ctype,param,avtr,vartr) + WRITE (*,9020) av,avtr,var,vartr,xmin,xmax + GO TO 420 + + 240 IF ((10).NE. (iwhich)) GO TO 270 + +C +C Poisson outcomes +C + ctype = 'pois' + WRITE (*,*) ' Enter mean for Poisson generation' + READ (*,*) param(1) + DO 250,i = 1,1000 + iarray(i) = ignpoi(param(1)) + 250 CONTINUE + DO 260,i = 1,1000 + array(i) = iarray(i) + 260 CONTINUE + CALL stat(array,1000,av,var,xmin,xmax) + CALL trstat(ctype,param,avtr,vartr) + WRITE (*,9020) av,avtr,var,vartr,xmin,xmax + GO TO 420 + + 270 IF ((11).NE. (iwhich)) GO TO 290 + +C +C Exponential deviates +C + ctype = 'expo' + WRITE (*,*) ' Enter (real) AV for Exponential' + READ (*,*) param(1) + DO 280,i = 1,1000 + array(i) = genexp(param(1)) + 280 CONTINUE + CALL stat(array,1000,av,var,xmin,xmax) + CALL trstat(ctype,param,avtr,vartr) + WRITE (*,9020) av,avtr,var,vartr,xmin,xmax + + GO TO 420 + + 290 IF ((12).NE. (iwhich)) GO TO 310 + +C +C Gamma deviates +C + ctype = 'gamm' + WRITE (*,*) ' Enter (real) A, (real) R for Gamma deviate' + READ (*,*) param(1),param(2) + DO 300,i = 1,1000 + array(i) = gengam(param(1),param(2)) + 300 CONTINUE + CALL stat(array,1000,av,var,xmin,xmax) + CALL trstat(ctype,param,avtr,vartr) + WRITE (*,9020) av,avtr,var,vartr,xmin,xmax + GO TO 420 + + 310 IF ((13).NE. (iwhich)) GO TO 360 + +C +C Multinomial outcomes +C + WRITE (*,*) ' Enter (int) number of observations: ' + READ (*,*) ntry + 320 WRITE (*,*) ' Enter (int) num. of categories: <= ',mxncat + READ (*,*) ncat + IF (ncat.GT.mxncat) THEN + WRITE (*,*) ' number of categories must be <= ',mxncat + WRITE (*,*) ' Try again ... ' + GO TO 320 + END IF + WRITE (*,*) ' Enter (real) prob. vector of length ',ncat-1 + READ (*,*) (prob(i),i=1,ncat-1) + CALL genmul(ntry,prob,ncat,iarray) + ntot = 0 + IF (ntry.GT.0) THEN + rtry = real(ntry) + DO 330, i = 1,ncat + ntot = ntot + iarray(i) + array(i) = iarray(i)/rtry + 330 CONTINUE + ELSE + DO 340, i = 1,ncat + ntot = ntot + iarray(i) + array(i) = 0.0 + 340 CONTINUE + ENDIF + psum = 0.0 + DO 350, i = 1,ncat-1 + psum = psum + prob(i) + 350 CONTINUE + prob(ncat) = 1.0 - psum + + WRITE (*,*) ' Total number of observations: ',ntot + WRITE (*,*) ' Total observations by category: ' + WRITE (*,'(10I8)') (iarray(i),i=1,ncat) + WRITE (*,*) ' True probabilities by category: ' + WRITE (*,'(8F10.7)') (prob(i),i=1,ncat) + WRITE (*,*) ' Observed proportions by category: ' + WRITE (*,'(8F10.7)') (array(i),i=1,ncat) + GO TO 420 + + 360 IF ((14).NE. (iwhich)) GO TO 380 + +C +C Normal deviates +C + ctype = 'norm' + WRITE (*,*) ' Enter (real) AV, (real) SD for Normal' + READ (*,*) param(1),param(2) + DO 370,i = 1,1000 + array(i) = gennor(param(1),param(2)) + 370 CONTINUE + CALL stat(array,1000,av,var,xmin,xmax) + CALL trstat(ctype,param,avtr,vartr) + WRITE (*,9020) av,avtr,var,vartr,xmin,xmax + GO TO 420 + + 380 IF ((15).NE. (iwhich)) GO TO 410 + +C +C Negative Binomial outcomes +C + ctype = 'nbin' + WRITE (*,*) ' Enter required (int) Number of events then ' + WRITE (*,*) ' (real) Prob of an event for negative binomial' + READ (*,*) ntry,pevt + DO 390,i = 1,1000 + iarray(i) = ignnbn(ntry,pevt) + 390 CONTINUE + DO 400,i = 1,1000 + array(i) = iarray(i) + 400 CONTINUE + CALL stat(array,1000,av,var,xmin,xmax) + param(1) = ntry + param(2) = pevt + CALL trstat(ctype,param,avtr,vartr) + WRITE (*,9020) av,avtr,var,vartr,xmin,xmax + GO TO 420 + + 410 CONTINUE + 420 GO TO 10 + + END + SUBROUTINE trstat(ctype,parin,av,var) + IMPLICIT INTEGER (i-n),REAL (a-h,o-p,r-z),LOGICAL (q) +C********************************************************************** +C +C SUBROUTINE TRSTAT( TYPE, PARIN, AV, VAR ) +C TRue STATistics +C +C Returns mean and variance for a number of statistical distribution +C as a function of their parameters. +C +C +C Arguments +C +C +C CTYPE --> Character string indicating type of distribution +C 'chis' chisquare +C 'ncch' noncentral chisquare +C 'f' F (variance ratio) +C 'ncf' noncentral f +C 'unif' uniform +C 'beta' beta distribution +C 'bin' binomial +C 'pois' poisson +C 'expo' exponential +C 'gamm' gamma +C 'norm' normal +C 'nbin' negative binomial +C CHARACTER*(4) TYPE +C +C PARIN --> Array containing parameters of distribution +C chisquare +C PARIN(1) is df +C noncentral chisquare +C PARIN(1) is df +C PARIN(2) is noncentrality parameter +C F (variance ratio) +C PARIN(1) is df numerator +C PARIN(2) is df denominator +C noncentral F +C PARIN(1) is df numerator +C PARIN(2) is df denominator +C PARIN(3) is noncentrality parameter +C uniform +C PARIN(1) is LOW bound +C PARIN(2) is HIGH bound +C beta +C PARIN(1) is A +C PARIN(2) is B +C binomial +C PARIN(1) is Number of trials +C PARIN(2) is Prob Event at Each Trial +C poisson +C PARIN(1) is Mean +C exponential +C PARIN(1) is Mean +C gamma +C PARIN(1) is A +C PARIN(2) is R +C normal +C PARIN(1) is Mean +C PARIN(2) is Standard Deviation +C negative binomial +C PARIN(1) is required Number of events +C PARIN(2) is Probability of event +C REAL PARIN(*) +C +C AV <-- Mean of specified distribution with specified parameters +C REAL AV +C +C VAR <-- Variance of specified distribution with specified paramete +C REAL VAR +C +C +C Note +C +C +C AV and Var will be returned -1 if mean or variance is infinite +C +C********************************************************************** +C .. Scalar Arguments .. + REAL av,var + CHARACTER ctype* (4) +C .. +C .. Array Arguments .. + REAL parin(*) +C .. +C .. Local Scalars .. + REAL a,b,range +C .. +C .. Executable Statements .. + IF (('chis').NE. (ctype)) GO TO 10 + av = parin(1) + var = 2.0*parin(1) + GO TO 210 + + 10 IF (('ncch').NE. (ctype)) GO TO 20 + a = parin(1) + parin(2) + b = parin(2)/a + av = a + var = 2.0*a* (1.0+b) + GO TO 210 + + 20 IF (('f').NE. (ctype)) GO TO 70 + IF (.NOT. (parin(2).LE.2.0001)) GO TO 30 + av = -1.0 + GO TO 40 + + 30 av = parin(2)/ (parin(2)-2.0) + 40 IF (.NOT. (parin(2).LE.4.0001)) GO TO 50 + var = -1.0 + GO TO 60 + + 50 var = (2.0*parin(2)**2* (parin(1)+parin(2)-2.0))/ + + (parin(1)* (parin(2)-2.0)**2* (parin(2)-4.0)) + 60 GO TO 210 + + 70 IF (('ncf').NE. (ctype)) GO TO 120 + IF (.NOT. (parin(2).LE.2.0001)) GO TO 80 + av = -1.0 + GO TO 90 + + 80 av = (parin(2)* (parin(1)+parin(3)))/ ((parin(2)-2.0)*parin(1)) + 90 IF (.NOT. (parin(2).LE.4.0001)) GO TO 100 + var = -1.0 + GO TO 110 + + 100 a = (parin(1)+parin(3))**2 + (parin(1)+2.0*parin(3))* + + (parin(2)-2.0) + b = (parin(2)-2.0)**2* (parin(2)-4.0) + var = 2.0* (parin(2)/parin(1))**2* (a/b) + 110 GO TO 210 + + 120 IF (('unif').NE. (ctype)) GO TO 130 + range = parin(2) - parin(1) + av = parin(1) + range/2.0 + var = range**2/12.0 + GO TO 210 + + 130 IF (('beta').NE. (ctype)) GO TO 140 + av = parin(1)/ (parin(1)+parin(2)) + var = (av*parin(2))/ ((parin(1)+parin(2))* + + (parin(1)+parin(2)+1.0)) + GO TO 210 + + 140 IF (('bin').NE. (ctype)) GO TO 150 + av = parin(1)*parin(2) + var = av* (1.0-parin(2)) + GO TO 210 + + 150 IF (('pois').NE. (ctype)) GO TO 160 + av = parin(1) + var = parin(1) + GO TO 210 + + 160 IF (('expo').NE. (ctype)) GO TO 170 + av = parin(1) + var = parin(1)**2 + GO TO 210 + + 170 IF (('gamm').NE. (ctype)) GO TO 180 + av = parin(2) / parin(1) + var = av / parin(1) + GO TO 210 + + 180 IF (('norm').NE. (ctype)) GO TO 190 + av = parin(1) + var = parin(2)**2 + GO TO 210 + + 190 IF (('nbin').NE. (ctype)) GO TO 200 + av = parin(1) * (1.0 - parin(2)) / parin(2) + var = av / parin(2) + GO TO 210 + + 200 WRITE (*,*) 'Unimplemented type ',ctype + STOP 'Unimplemented type in TRSTAT' + + 210 RETURN + + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/ranlib/wrap.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,25 @@ + subroutine dgennor (av, sd, result) + double precision av, sd, result + result = gennor (real (av), real (sd)) + return + end + subroutine dgenunf (low, high, result) + double precision low, high, result + result = genunf (real (low), real (high)) + return + end + subroutine dgenexp (av, result) + double precision av, result + result = genexp (real (av)) + return + end + subroutine dgengam (a, r, result) + double precision a, r, result + result = gengam (real (a), real (r)) + return + end + subroutine dignpoi (mu, result) + double precision mu, result + result = ignpoi (real (mu)) + return + end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/slatec-err/fdump.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,31 @@ +*DECK FDUMP + SUBROUTINE FDUMP +C***BEGIN PROLOGUE FDUMP +C***PURPOSE Symbolic dump (should be locally written). +C***LIBRARY SLATEC (XERROR) +C***CATEGORY R3 +C***TYPE ALL (FDUMP-A) +C***KEYWORDS ERROR, XERMSG +C***AUTHOR Jones, R. E., (SNLA) +C***DESCRIPTION +C +C ***Note*** Machine Dependent Routine +C FDUMP is intended to be replaced by a locally written +C version which produces a symbolic dump. Failing this, +C it should be replaced by a version which prints the +C subprogram nesting list. Note that this dump must be +C printed on each of up to five files, as indicated by the +C XGETUA routine. See XSETUA and XGETUA for details. +C +C Written by Ron Jones, with SLATEC Common Math Library Subcommittee +C +C***REFERENCES (NONE) +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 790801 DATE WRITTEN +C 861211 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C***END PROLOGUE FDUMP +C***FIRST EXECUTABLE STATEMENT FDUMP + RETURN + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/slatec-err/ixsav.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,70 @@ +*DECK IXSAV + INTEGER FUNCTION IXSAV (IPAR, IVALUE, ISET) +C***BEGIN PROLOGUE IXSAV +C***SUBSIDIARY +C***PURPOSE Save and recall error message control parameters. +C***LIBRARY MATHLIB +C***CATEGORY R3C +C***TYPE ALL (IXSAV-A) +C***AUTHOR Hindmarsh, Alan C., (LLNL) +C***DESCRIPTION +C +C IXSAV saves and recalls one of two error message parameters: +C LUNIT, the logical unit number to which messages are printed, and +C MESFLG, the message print flag. +C This is a modification of the SLATEC library routine J4SAVE. +C +C Saved local variables.. +C LUNIT = Logical unit number for messages. +C LUNDEF = Default logical unit number, data-loaded to 6 below +C (may be machine-dependent). +C MESFLG = Print control flag.. +C 1 means print all messages (the default). +C 0 means no printing. +C +C On input.. +C IPAR = Parameter indicator (1 for LUNIT, 2 for MESFLG). +C IVALUE = The value to be set for the parameter, if ISET = .TRUE. +C ISET = Logical flag to indicate whether to read or write. +C If ISET = .TRUE., the parameter will be given +C the value IVALUE. If ISET = .FALSE., the parameter +C will be unchanged, and IVALUE is a dummy argument. +C +C On return.. +C IXSAV = The (old) value of the parameter. +C +C***SEE ALSO XERMSG, XERRWD, XERRWV +C***ROUTINES CALLED NONE +C***REVISION HISTORY (YYMMDD) +C 921118 DATE WRITTEN +C 930329 Modified prologue to SLATEC format. (FNF) +C 941025 Minor modification re default unit number. (ACH) +C***END PROLOGUE IXSAV +C +C**End + LOGICAL ISET + INTEGER IPAR, IVALUE +C----------------------------------------------------------------------- + INTEGER LUNIT, LUNDEF, MESFLG +C----------------------------------------------------------------------- +C The following Fortran-77 declaration is to cause the values of the +C listed (local) variables to be saved between calls to this routine. +C----------------------------------------------------------------------- + SAVE LUNIT, LUNDEF, MESFLG + DATA LUNIT/-1/, LUNDEF/6/, MESFLG/1/ +C +C***FIRST EXECUTABLE STATEMENT IXSAV + IF (IPAR .EQ. 1) THEN + IF (LUNIT .EQ. -1) LUNIT = LUNDEF + IXSAV = LUNIT + IF (ISET) LUNIT = IVALUE + ENDIF +C + IF (IPAR .EQ. 2) THEN + IXSAV = MESFLG + IF (ISET) MESFLG = IVALUE + ENDIF +C + RETURN +C----------------------- End of Function IXSAV ------------------------- + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/slatec-err/j4save.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,65 @@ +*DECK J4SAVE + FUNCTION J4SAVE (IWHICH, IVALUE, ISET) +C***BEGIN PROLOGUE J4SAVE +C***SUBSIDIARY +C***PURPOSE Save or recall global variables needed by error +C handling routines. +C***LIBRARY SLATEC (XERROR) +C***TYPE INTEGER (J4SAVE-I) +C***KEYWORDS ERROR MESSAGES, ERROR NUMBER, RECALL, SAVE, XERROR +C***AUTHOR Jones, R. E., (SNLA) +C***DESCRIPTION +C +C Abstract +C J4SAVE saves and recalls several global variables needed +C by the library error handling routines. +C +C Description of Parameters +C --Input-- +C IWHICH - Index of item desired. +C = 1 Refers to current error number. +C = 2 Refers to current error control flag. +C = 3 Refers to current unit number to which error +C messages are to be sent. (0 means use standard.) +C = 4 Refers to the maximum number of times any +C message is to be printed (as set by XERMAX). +C = 5 Refers to the total number of units to which +C each error message is to be written. +C = 6 Refers to the 2nd unit for error messages +C = 7 Refers to the 3rd unit for error messages +C = 8 Refers to the 4th unit for error messages +C = 9 Refers to the 5th unit for error messages +C IVALUE - The value to be set for the IWHICH-th parameter, +C if ISET is .TRUE. . +C ISET - If ISET=.TRUE., the IWHICH-th parameter will BE +C given the value, IVALUE. If ISET=.FALSE., the +C IWHICH-th parameter will be unchanged, and IVALUE +C is a dummy parameter. +C --Output-- +C The (old) value of the IWHICH-th parameter will be returned +C in the function value, J4SAVE. +C +C***SEE ALSO XERMSG +C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC +C Error-handling Package, SAND82-0800, Sandia +C Laboratories, 1982. +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 790801 DATE WRITTEN +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900205 Minor modifications to prologue. (WRB) +C 900402 Added TYPE section. (WRB) +C 910411 Added KEYWORDS section. (WRB) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE J4SAVE + LOGICAL ISET + INTEGER IPARAM(9) + SAVE IPARAM + DATA IPARAM(1),IPARAM(2),IPARAM(3),IPARAM(4)/0,2,0,-1/ + DATA IPARAM(5)/1/ + DATA IPARAM(6),IPARAM(7),IPARAM(8),IPARAM(9)/0,0,0,0/ +C***FIRST EXECUTABLE STATEMENT J4SAVE + J4SAVE = IPARAM(IWHICH) + IF (ISET) IPARAM(IWHICH) = IVALUE + RETURN + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/slatec-err/module.mk Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,15 @@ +EXTERNAL_SOURCES += \ + liboctave/external/slatec-err/fdump.f \ + liboctave/external/slatec-err/ixsav.f \ + liboctave/external/slatec-err/j4save.f \ + liboctave/external/slatec-err/xerclr.f \ + liboctave/external/slatec-err/xercnt.f \ + liboctave/external/slatec-err/xerhlt.f \ + liboctave/external/slatec-err/xermsg.f \ + liboctave/external/slatec-err/xerprn.f \ + liboctave/external/slatec-err/xerrwd.f \ + liboctave/external/slatec-err/xersve.f \ + liboctave/external/slatec-err/xgetf.f \ + liboctave/external/slatec-err/xgetua.f \ + liboctave/external/slatec-err/xsetf.f \ + liboctave/external/slatec-err/xsetua.f
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/slatec-err/xerclr.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,31 @@ +*DECK XERCLR + SUBROUTINE XERCLR +C***BEGIN PROLOGUE XERCLR +C***PURPOSE Reset current error number to zero. +C***LIBRARY SLATEC (XERROR) +C***CATEGORY R3C +C***TYPE ALL (XERCLR-A) +C***KEYWORDS ERROR, XERROR +C***AUTHOR Jones, R. E., (SNLA) +C***DESCRIPTION +C +C Abstract +C This routine simply resets the current error number to zero. +C This may be necessary in order to determine that a certain +C error has occurred again since the last time NUMXER was +C referenced. +C +C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC +C Error-handling Package, SAND82-0800, Sandia +C Laboratories, 1982. +C***ROUTINES CALLED J4SAVE +C***REVISION HISTORY (YYMMDD) +C 790801 DATE WRITTEN +C 861211 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE XERCLR +C***FIRST EXECUTABLE STATEMENT XERCLR + JUNK = J4SAVE(1,0,.TRUE.) + RETURN + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/slatec-err/xercnt.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,60 @@ +*DECK XERCNT + SUBROUTINE XERCNT (LIBRAR, SUBROU, MESSG, NERR, LEVEL, KONTRL) +C***BEGIN PROLOGUE XERCNT +C***SUBSIDIARY +C***PURPOSE Allow user control over handling of errors. +C***LIBRARY SLATEC (XERROR) +C***CATEGORY R3C +C***TYPE ALL (XERCNT-A) +C***KEYWORDS ERROR, XERROR +C***AUTHOR Jones, R. E., (SNLA) +C***DESCRIPTION +C +C Abstract +C Allows user control over handling of individual errors. +C Just after each message is recorded, but before it is +C processed any further (i.e., before it is printed or +C a decision to abort is made), a call is made to XERCNT. +C If the user has provided his own version of XERCNT, he +C can then override the value of KONTROL used in processing +C this message by redefining its value. +C KONTRL may be set to any value from -2 to 2. +C The meanings for KONTRL are the same as in XSETF, except +C that the value of KONTRL changes only for this message. +C If KONTRL is set to a value outside the range from -2 to 2, +C it will be moved back into that range. +C +C Description of Parameters +C +C --Input-- +C LIBRAR - the library that the routine is in. +C SUBROU - the subroutine that XERMSG is being called from +C MESSG - the first 20 characters of the error message. +C NERR - same as in the call to XERMSG. +C LEVEL - same as in the call to XERMSG. +C KONTRL - the current value of the control flag as set +C by a call to XSETF. +C +C --Output-- +C KONTRL - the new value of KONTRL. If KONTRL is not +C defined, it will remain at its original value. +C This changed value of control affects only +C the current occurrence of the current message. +C +C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC +C Error-handling Package, SAND82-0800, Sandia +C Laboratories, 1982. +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 790801 DATE WRITTEN +C 861211 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900206 Routine changed from user-callable to subsidiary. (WRB) +C 900510 Changed calling sequence to include LIBRARY and SUBROUTINE +C names, changed routine name from XERCTL to XERCNT. (RWC) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE XERCNT + CHARACTER*(*) LIBRAR, SUBROU, MESSG +C***FIRST EXECUTABLE STATEMENT XERCNT + RETURN + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/slatec-err/xerhlt.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,39 @@ +*DECK XERHLT + SUBROUTINE XERHLT (MESSG) +C***BEGIN PROLOGUE XERHLT +C***SUBSIDIARY +C***PURPOSE Abort program execution and print error message. +C***LIBRARY SLATEC (XERROR) +C***CATEGORY R3C +C***TYPE ALL (XERHLT-A) +C***KEYWORDS ABORT PROGRAM EXECUTION, ERROR, XERROR +C***AUTHOR Jones, R. E., (SNLA) +C***DESCRIPTION +C +C Abstract +C ***Note*** machine dependent routine +C XERHLT aborts the execution of the program. +C The error message causing the abort is given in the calling +C sequence, in case one needs it for printing on a dayfile, +C for example. +C +C Description of Parameters +C MESSG is as in XERMSG. +C +C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC +C Error-handling Package, SAND82-0800, Sandia +C Laboratories, 1982. +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 790801 DATE WRITTEN +C 861211 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900206 Routine changed from user-callable to subsidiary. (WRB) +C 900510 Changed calling sequence to delete length of character +C and changed routine name from XERABT to XERHLT. (RWC) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE XERHLT + CHARACTER*(*) MESSG +C***FIRST EXECUTABLE STATEMENT XERHLT + CALL XSTOPX (MESSG) + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/slatec-err/xermsg.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,368 @@ +*DECK XERMSG + SUBROUTINE XERMSG (LIBRAR, SUBROU, MESSG, NERR, LEVEL) +C***BEGIN PROLOGUE XERMSG +C***PURPOSE Process error messages for SLATEC and other libraries. +C***LIBRARY SLATEC (XERROR) +C***CATEGORY R3C +C***TYPE ALL (XERMSG-A) +C***KEYWORDS ERROR MESSAGE, XERROR +C***AUTHOR Fong, Kirby, (NMFECC at LLNL) +C***DESCRIPTION +C +C XERMSG processes a diagnostic message in a manner determined by the +C value of LEVEL and the current value of the library error control +C flag, KONTRL. See subroutine XSETF for details. +C +C LIBRAR A character constant (or character variable) with the name +C of the library. This will be 'SLATEC' for the SLATEC +C Common Math Library. The error handling package is +C general enough to be used by many libraries +C simultaneously, so it is desirable for the routine that +C detects and reports an error to identify the library name +C as well as the routine name. +C +C SUBROU A character constant (or character variable) with the name +C of the routine that detected the error. Usually it is the +C name of the routine that is calling XERMSG. There are +C some instances where a user callable library routine calls +C lower level subsidiary routines where the error is +C detected. In such cases it may be more informative to +C supply the name of the routine the user called rather than +C the name of the subsidiary routine that detected the +C error. +C +C MESSG A character constant (or character variable) with the text +C of the error or warning message. In the example below, +C the message is a character constant that contains a +C generic message. +C +C CALL XERMSG ('SLATEC', 'MMPY', +C *'THE ORDER OF THE MATRIX EXCEEDS THE ROW DIMENSION', +C *3, 1) +C +C It is possible (and is sometimes desirable) to generate a +C specific message--e.g., one that contains actual numeric +C values. Specific numeric values can be converted into +C character strings using formatted WRITE statements into +C character variables. This is called standard Fortran +C internal file I/O and is exemplified in the first three +C lines of the following example. You can also catenate +C substrings of characters to construct the error message. +C Here is an example showing the use of both writing to +C an internal file and catenating character strings. +C +C CHARACTER*5 CHARN, CHARL +C WRITE (CHARN,10) N +C WRITE (CHARL,10) LDA +C 10 FORMAT(I5) +C CALL XERMSG ('SLATEC', 'MMPY', 'THE ORDER'//CHARN// +C * ' OF THE MATRIX EXCEEDS ITS ROW DIMENSION OF'// +C * CHARL, 3, 1) +C +C There are two subtleties worth mentioning. One is that +C the // for character catenation is used to construct the +C error message so that no single character constant is +C continued to the next line. This avoids confusion as to +C whether there are trailing blanks at the end of the line. +C The second is that by catenating the parts of the message +C as an actual argument rather than encoding the entire +C message into one large character variable, we avoid +C having to know how long the message will be in order to +C declare an adequate length for that large character +C variable. XERMSG calls XERPRN to print the message using +C multiple lines if necessary. If the message is very long, +C XERPRN will break it into pieces of 72 characters (as +C requested by XERMSG) for printing on multiple lines. +C Also, XERMSG asks XERPRN to prefix each line with ' * ' +C so that the total line length could be 76 characters. +C Note also that XERPRN scans the error message backwards +C to ignore trailing blanks. Another feature is that +C the substring '$$' is treated as a new line sentinel +C by XERPRN. If you want to construct a multiline +C message without having to count out multiples of 72 +C characters, just use '$$' as a separator. '$$' +C obviously must occur within 72 characters of the +C start of each line to have its intended effect since +C XERPRN is asked to wrap around at 72 characters in +C addition to looking for '$$'. +C +C NERR An integer value that is chosen by the library routine's +C author. It must be in the range -99 to 999 (three +C printable digits). Each distinct error should have its +C own error number. These error numbers should be described +C in the machine readable documentation for the routine. +C The error numbers need be unique only within each routine, +C so it is reasonable for each routine to start enumerating +C errors from 1 and proceeding to the next integer. +C +C LEVEL An integer value in the range 0 to 2 that indicates the +C level (severity) of the error. Their meanings are +C +C -1 A warning message. This is used if it is not clear +C that there really is an error, but the user's attention +C may be needed. An attempt is made to only print this +C message once. +C +C 0 A warning message. This is used if it is not clear +C that there really is an error, but the user's attention +C may be needed. +C +C 1 A recoverable error. This is used even if the error is +C so serious that the routine cannot return any useful +C answer. If the user has told the error package to +C return after recoverable errors, then XERMSG will +C return to the Library routine which can then return to +C the user's routine. The user may also permit the error +C package to terminate the program upon encountering a +C recoverable error. +C +C 2 A fatal error. XERMSG will not return to its caller +C after it receives a fatal error. This level should +C hardly ever be used; it is much better to allow the +C user a chance to recover. An example of one of the few +C cases in which it is permissible to declare a level 2 +C error is a reverse communication Library routine that +C is likely to be called repeatedly until it integrates +C across some interval. If there is a serious error in +C the input such that another step cannot be taken and +C the Library routine is called again without the input +C error having been corrected by the caller, the Library +C routine will probably be called forever with improper +C input. In this case, it is reasonable to declare the +C error to be fatal. +C +C Each of the arguments to XERMSG is input; none will be modified by +C XERMSG. A routine may make multiple calls to XERMSG with warning +C level messages; however, after a call to XERMSG with a recoverable +C error, the routine should return to the user. Do not try to call +C XERMSG with a second recoverable error after the first recoverable +C error because the error package saves the error number. The user +C can retrieve this error number by calling another entry point in +C the error handling package and then clear the error number when +C recovering from the error. Calling XERMSG in succession causes the +C old error number to be overwritten by the latest error number. +C This is considered harmless for error numbers associated with +C warning messages but must not be done for error numbers of serious +C errors. After a call to XERMSG with a recoverable error, the user +C must be given a chance to call NUMXER or XERCLR to retrieve or +C clear the error number. +C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC +C Error-handling Package, SAND82-0800, Sandia +C Laboratories, 1982. +C***ROUTINES CALLED FDUMP, J4SAVE, XERCNT, XERHLT, XERPRN, XERSVE +C***REVISION HISTORY (YYMMDD) +C 880101 DATE WRITTEN +C 880621 REVISED AS DIRECTED AT SLATEC CML MEETING OF FEBRUARY 1988. +C THERE ARE TWO BASIC CHANGES. +C 1. A NEW ROUTINE, XERPRN, IS USED INSTEAD OF XERPRT TO +C PRINT MESSAGES. THIS ROUTINE WILL BREAK LONG MESSAGES +C INTO PIECES FOR PRINTING ON MULTIPLE LINES. '$$' IS +C ACCEPTED AS A NEW LINE SENTINEL. A PREFIX CAN BE +C ADDED TO EACH LINE TO BE PRINTED. XERMSG USES EITHER +C ' ***' OR ' * ' AND LONG MESSAGES ARE BROKEN EVERY +C 72 CHARACTERS (AT MOST) SO THAT THE MAXIMUM LINE +C LENGTH OUTPUT CAN NOW BE AS GREAT AS 76. +C 2. THE TEXT OF ALL MESSAGES IS NOW IN UPPER CASE SINCE THE +C FORTRAN STANDARD DOCUMENT DOES NOT ADMIT THE EXISTENCE +C OF LOWER CASE. +C 880708 REVISED AFTER THE SLATEC CML MEETING OF JUNE 29 AND 30. +C THE PRINCIPAL CHANGES ARE +C 1. CLARIFY COMMENTS IN THE PROLOGUES +C 2. RENAME XRPRNT TO XERPRN +C 3. REWORK HANDLING OF '$$' IN XERPRN TO HANDLE BLANK LINES +C SIMILAR TO THE WAY FORMAT STATEMENTS HANDLE THE / +C CHARACTER FOR NEW RECORDS. +C 890706 REVISED WITH THE HELP OF FRED FRITSCH AND REG CLEMENS TO +C CLEAN UP THE CODING. +C 890721 REVISED TO USE NEW FEATURE IN XERPRN TO COUNT CHARACTERS IN +C PREFIX. +C 891013 REVISED TO CORRECT COMMENTS. +C 891214 Prologue converted to Version 4.0 format. (WRB) +C 900510 Changed test on NERR to be -9999999 < NERR < 99999999, but +C NERR .ne. 0, and on LEVEL to be -2 < LEVEL < 3. Added +C LEVEL=-1 logic, changed calls to XERSAV to XERSVE, and +C XERCTL to XERCNT. (RWC) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE XERMSG + CHARACTER*(*) LIBRAR, SUBROU, MESSG + CHARACTER*8 XLIBR, XSUBR + CHARACTER*72 TEMP + CHARACTER*20 LFIRST +C***FIRST EXECUTABLE STATEMENT XERMSG + LKNTRL = J4SAVE (2, 0, .FALSE.) + MAXMES = J4SAVE (4, 0, .FALSE.) +C +C LKNTRL IS A LOCAL COPY OF THE CONTROL FLAG KONTRL. +C MAXMES IS THE MAXIMUM NUMBER OF TIMES ANY PARTICULAR MESSAGE +C SHOULD BE PRINTED. IF MAXMES IS LESS THAN ZERO, THERE IS +C NO LIMIT. +C +C WE PRINT A FATAL ERROR MESSAGE AND TERMINATE FOR AN ERROR IN +C CALLING XERMSG. THE ERROR NUMBER SHOULD BE POSITIVE, +C AND THE LEVEL SHOULD BE BETWEEN 0 AND 2. +C + IF (NERR.LT.-9999999 .OR. NERR.GT.99999999 .OR. NERR.EQ.0 .OR. + * LEVEL.LT.-1 .OR. LEVEL.GT.2) THEN + CALL XERPRN (' ***', -1, 'FATAL ERROR IN...$$ ' // + * 'XERMSG -- INVALID ERROR NUMBER OR LEVEL$$ '// + * 'JOB ABORT DUE TO FATAL ERROR.', 72) + CALL XERSVE (' ', ' ', ' ', 0, 0, 0, KDUMMY) + CALL XERHLT (' ***XERMSG -- INVALID INPUT') + RETURN + ENDIF +C +C RECORD THE MESSAGE. +C + I = J4SAVE (1, NERR, .TRUE.) + CALL XERSVE (LIBRAR, SUBROU, MESSG, 1, NERR, LEVEL, KOUNT) +C +C HANDLE PRINT-ONCE WARNING MESSAGES. +C + IF (LEVEL.EQ.-1 .AND. KOUNT.GT.1) RETURN +C +C ALLOW TEMPORARY USER OVERRIDE OF THE CONTROL FLAG. +C + XLIBR = LIBRAR + XSUBR = SUBROU + LFIRST = MESSG + LERR = NERR + LLEVEL = LEVEL + CALL XERCNT (XLIBR, XSUBR, LFIRST, LERR, LLEVEL, LKNTRL) +C + LKNTRL = MAX(-2, MIN(2,LKNTRL)) + MKNTRL = ABS(LKNTRL) +C +C SKIP PRINTING IF THE CONTROL FLAG VALUE AS RESET IN XERCNT IS +C ZERO AND THE ERROR IS NOT FATAL. +C + IF (LEVEL.LT.2 .AND. LKNTRL.EQ.0) GO TO 30 + IF (LEVEL.EQ.0 .AND. MAXMES.GE.0 .AND. KOUNT.GT.MAXMES) GO TO 30 + IF (LEVEL.EQ.1 .AND. MAXMES.GE.0 .AND. KOUNT.GT.MAXMES + * .AND. MKNTRL.EQ.1) GO TO 30 + IF (LEVEL.EQ.2 .AND. MAXMES.GE.0 .AND. KOUNT.GT.MAX(1,MAXMES)) + * GO TO 30 +C +C ANNOUNCE THE NAMES OF THE LIBRARY AND SUBROUTINE BY BUILDING A +C MESSAGE IN CHARACTER VARIABLE TEMP (NOT EXCEEDING 66 CHARACTERS) +C AND SENDING IT OUT VIA XERPRN. PRINT ONLY IF CONTROL FLAG +C IS NOT ZERO. +C + IF (LKNTRL .NE. 0) THEN + TEMP(1:21) = 'MESSAGE FROM ROUTINE ' + I = MIN(LEN(SUBROU), 16) + TEMP(22:21+I) = SUBROU(1:I) + TEMP(22+I:33+I) = ' IN LIBRARY ' + LTEMP = 33 + I + I = MIN(LEN(LIBRAR), 16) + TEMP(LTEMP+1:LTEMP+I) = LIBRAR (1:I) + TEMP(LTEMP+I+1:LTEMP+I+1) = '.' + LTEMP = LTEMP + I + 1 + CALL XERPRN (' ***', -1, TEMP(1:LTEMP), 72) + ENDIF +C +C IF LKNTRL IS POSITIVE, PRINT AN INTRODUCTORY LINE BEFORE +C PRINTING THE MESSAGE. THE INTRODUCTORY LINE TELLS THE CHOICE +C FROM EACH OF THE FOLLOWING THREE OPTIONS. +C 1. LEVEL OF THE MESSAGE +C 'INFORMATIVE MESSAGE' +C 'POTENTIALLY RECOVERABLE ERROR' +C 'FATAL ERROR' +C 2. WHETHER CONTROL FLAG WILL ALLOW PROGRAM TO CONTINUE +C 'PROG CONTINUES' +C 'PROG ABORTED' +C 3. WHETHER OR NOT A TRACEBACK WAS REQUESTED. (THE TRACEBACK +C MAY NOT BE IMPLEMENTED AT SOME SITES, SO THIS ONLY TELLS +C WHAT WAS REQUESTED, NOT WHAT WAS DELIVERED.) +C 'TRACEBACK REQUESTED' +C 'TRACEBACK NOT REQUESTED' +C NOTICE THAT THE LINE INCLUDING FOUR PREFIX CHARACTERS WILL NOT +C EXCEED 74 CHARACTERS. +C WE SKIP THE NEXT BLOCK IF THE INTRODUCTORY LINE IS NOT NEEDED. +C + IF (LKNTRL .GT. 0) THEN +C +C THE FIRST PART OF THE MESSAGE TELLS ABOUT THE LEVEL. +C + IF (LEVEL .LE. 0) THEN + TEMP(1:20) = 'INFORMATIVE MESSAGE,' + LTEMP = 20 + ELSEIF (LEVEL .EQ. 1) THEN + TEMP(1:30) = 'POTENTIALLY RECOVERABLE ERROR,' + LTEMP = 30 + ELSE + TEMP(1:12) = 'FATAL ERROR,' + LTEMP = 12 + ENDIF +C +C THEN WHETHER THE PROGRAM WILL CONTINUE. +C + IF ((MKNTRL.EQ.2 .AND. LEVEL.GE.1) .OR. + * (MKNTRL.EQ.1 .AND. LEVEL.EQ.2)) THEN + TEMP(LTEMP+1:LTEMP+14) = ' PROG ABORTED,' + LTEMP = LTEMP + 14 + ELSE + TEMP(LTEMP+1:LTEMP+16) = ' PROG CONTINUES,' + LTEMP = LTEMP + 16 + ENDIF +C +C FINALLY TELL WHETHER THERE SHOULD BE A TRACEBACK. +C + IF (LKNTRL .GT. 0) THEN + TEMP(LTEMP+1:LTEMP+20) = ' TRACEBACK REQUESTED' + LTEMP = LTEMP + 20 + ELSE + TEMP(LTEMP+1:LTEMP+24) = ' TRACEBACK NOT REQUESTED' + LTEMP = LTEMP + 24 + ENDIF + CALL XERPRN (' ***', -1, TEMP(1:LTEMP), 72) + ENDIF +C +C NOW SEND OUT THE MESSAGE. +C + CALL XERPRN (' * ', -1, MESSG, 72) +C +C IF LKNTRL IS POSITIVE, WRITE THE ERROR NUMBER AND REQUEST A +C TRACEBACK. +C + IF (LKNTRL .GT. 0) THEN + WRITE (TEMP, '(''ERROR NUMBER = '', I8)') NERR + DO 10 I=16,22 + IF (TEMP(I:I) .NE. ' ') GO TO 20 + 10 CONTINUE +C + 20 CALL XERPRN (' * ', -1, TEMP(1:15) // TEMP(I:23), 72) + CALL FDUMP + ENDIF +C +C IF LKNTRL IS NOT ZERO, PRINT A BLANK LINE AND AN END OF MESSAGE. +C + IF (LKNTRL .NE. 0) THEN + CALL XERPRN (' * ', -1, ' ', 72) + CALL XERPRN (' ***', -1, 'END OF MESSAGE', 72) + CALL XERPRN (' ', 0, ' ', 72) + ENDIF +C +C IF THE ERROR IS NOT FATAL OR THE ERROR IS RECOVERABLE AND THE +C CONTROL FLAG IS SET FOR RECOVERY, THEN RETURN. +C + 30 IF (LEVEL.LE.0 .OR. (LEVEL.EQ.1 .AND. MKNTRL.LE.1)) RETURN +C +C THE PROGRAM WILL BE STOPPED DUE TO AN UNRECOVERED ERROR OR A +C FATAL ERROR. PRINT THE REASON FOR THE ABORT AND THE ERROR +C SUMMARY IF THE CONTROL FLAG AND THE MAXIMUM ERROR COUNT PERMIT. +C + IF (LKNTRL.GT.0 + * .AND. (MAXMES.LT.0 .OR. KOUNT.LT.MAX(1,MAXMES))) THEN + IF (LEVEL .EQ. 1) THEN + CALL XERPRN + * (' ***', -1, 'JOB ABORT DUE TO UNRECOVERED ERROR.', 72) + ELSE + CALL XERPRN(' ***', -1, 'JOB ABORT DUE TO FATAL ERROR.', 72) + ENDIF + CALL XERSVE (' ', ' ', ' ', -1, 0, 0, KDUMMY) + CALL XERHLT (' ') + ELSE + CALL XERHLT (MESSG) + ENDIF + RETURN + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/slatec-err/xerprn.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,228 @@ +*DECK XERPRN + SUBROUTINE XERPRN (PREFIX, NPREF, MESSG, NWRAP) +C***BEGIN PROLOGUE XERPRN +C***SUBSIDIARY +C***PURPOSE Print error messages processed by XERMSG. +C***LIBRARY SLATEC (XERROR) +C***CATEGORY R3C +C***TYPE ALL (XERPRN-A) +C***KEYWORDS ERROR MESSAGES, PRINTING, XERROR +C***AUTHOR Fong, Kirby, (NMFECC at LLNL) +C***DESCRIPTION +C +C This routine sends one or more lines to each of the (up to five) +C logical units to which error messages are to be sent. This routine +C is called several times by XERMSG, sometimes with a single line to +C print and sometimes with a (potentially very long) message that may +C wrap around into multiple lines. +C +C PREFIX Input argument of type CHARACTER. This argument contains +C characters to be put at the beginning of each line before +C the body of the message. No more than 16 characters of +C PREFIX will be used. +C +C NPREF Input argument of type INTEGER. This argument is the number +C of characters to use from PREFIX. If it is negative, the +C intrinsic function LEN is used to determine its length. If +C it is zero, PREFIX is not used. If it exceeds 16 or if +C LEN(PREFIX) exceeds 16, only the first 16 characters will be +C used. If NPREF is positive and the length of PREFIX is less +C than NPREF, a copy of PREFIX extended with blanks to length +C NPREF will be used. +C +C MESSG Input argument of type CHARACTER. This is the text of a +C message to be printed. If it is a long message, it will be +C broken into pieces for printing on multiple lines. Each line +C will start with the appropriate prefix and be followed by a +C piece of the message. NWRAP is the number of characters per +C piece; that is, after each NWRAP characters, we break and +C start a new line. In addition the characters '$$' embedded +C in MESSG are a sentinel for a new line. The counting of +C characters up to NWRAP starts over for each new line. The +C value of NWRAP typically used by XERMSG is 72 since many +C older error messages in the SLATEC Library are laid out to +C rely on wrap-around every 72 characters. +C +C NWRAP Input argument of type INTEGER. This gives the maximum size +C piece into which to break MESSG for printing on multiple +C lines. An embedded '$$' ends a line, and the count restarts +C at the following character. If a line break does not occur +C on a blank (it would split a word) that word is moved to the +C next line. Values of NWRAP less than 16 will be treated as +C 16. Values of NWRAP greater than 132 will be treated as 132. +C The actual line length will be NPREF + NWRAP after NPREF has +C been adjusted to fall between 0 and 16 and NWRAP has been +C adjusted to fall between 16 and 132. +C +C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC +C Error-handling Package, SAND82-0800, Sandia +C Laboratories, 1982. +C***ROUTINES CALLED I1MACH, XGETUA +C***REVISION HISTORY (YYMMDD) +C 880621 DATE WRITTEN +C 880708 REVISED AFTER THE SLATEC CML SUBCOMMITTEE MEETING OF +C JUNE 29 AND 30 TO CHANGE THE NAME TO XERPRN AND TO REWORK +C THE HANDLING OF THE NEW LINE SENTINEL TO BEHAVE LIKE THE +C SLASH CHARACTER IN FORMAT STATEMENTS. +C 890706 REVISED WITH THE HELP OF FRED FRITSCH AND REG CLEMENS TO +C STREAMLINE THE CODING AND FIX A BUG THAT CAUSED EXTRA BLANK +C LINES TO BE PRINTED. +C 890721 REVISED TO ADD A NEW FEATURE. A NEGATIVE VALUE OF NPREF +C CAUSES LEN(PREFIX) TO BE USED AS THE LENGTH. +C 891013 REVISED TO CORRECT ERROR IN CALCULATING PREFIX LENGTH. +C 891214 Prologue converted to Version 4.0 format. (WRB) +C 900510 Added code to break messages between words. (RWC) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE XERPRN + CHARACTER*(*) PREFIX, MESSG + INTEGER NPREF, NWRAP + CHARACTER*148 CBUFF + INTEGER IU(5), NUNIT + CHARACTER*2 NEWLIN + PARAMETER (NEWLIN = '$$') +C***FIRST EXECUTABLE STATEMENT XERPRN + CALL XGETUA(IU,NUNIT) +C +C A ZERO VALUE FOR A LOGICAL UNIT NUMBER MEANS TO USE THE STANDARD +C ERROR MESSAGE UNIT INSTEAD. I1MACH(4) RETRIEVES THE STANDARD +C ERROR MESSAGE UNIT. +C + N = I1MACH(4) + DO 10 I=1,NUNIT + IF (IU(I) .EQ. 0) IU(I) = N + 10 CONTINUE +C +C LPREF IS THE LENGTH OF THE PREFIX. THE PREFIX IS PLACED AT THE +C BEGINNING OF CBUFF, THE CHARACTER BUFFER, AND KEPT THERE DURING +C THE REST OF THIS ROUTINE. +C + IF ( NPREF .LT. 0 ) THEN + LPREF = LEN(PREFIX) + ELSE + LPREF = NPREF + ENDIF + LPREF = MIN(16, LPREF) + IF (LPREF .NE. 0) CBUFF(1:LPREF) = PREFIX +C +C LWRAP IS THE MAXIMUM NUMBER OF CHARACTERS WE WANT TO TAKE AT ONE +C TIME FROM MESSG TO PRINT ON ONE LINE. +C + LWRAP = MAX(16, MIN(132, NWRAP)) +C +C SET LENMSG TO THE LENGTH OF MESSG, IGNORE ANY TRAILING BLANKS. +C + LENMSG = LEN(MESSG) + N = LENMSG + DO 20 I=1,N + IF (MESSG(LENMSG:LENMSG) .NE. ' ') GO TO 30 + LENMSG = LENMSG - 1 + 20 CONTINUE + 30 CONTINUE +C +C IF THE MESSAGE IS ALL BLANKS, THEN PRINT ONE BLANK LINE. +C + IF (LENMSG .EQ. 0) THEN + CBUFF(LPREF+1:LPREF+1) = ' ' + DO 40 I=1,NUNIT + WRITE(IU(I), '(A)') CBUFF(1:LPREF+1) + 40 CONTINUE + RETURN + ENDIF +C +C SET NEXTC TO THE POSITION IN MESSG WHERE THE NEXT SUBSTRING +C STARTS. FROM THIS POSITION WE SCAN FOR THE NEW LINE SENTINEL. +C WHEN NEXTC EXCEEDS LENMSG, THERE IS NO MORE TO PRINT. +C WE LOOP BACK TO LABEL 50 UNTIL ALL PIECES HAVE BEEN PRINTED. +C +C WE LOOK FOR THE NEXT OCCURRENCE OF THE NEW LINE SENTINEL. THE +C INDEX INTRINSIC FUNCTION RETURNS ZERO IF THERE IS NO OCCURRENCE +C OR IF THE LENGTH OF THE FIRST ARGUMENT IS LESS THAN THE LENGTH +C OF THE SECOND ARGUMENT. +C +C THERE ARE SEVERAL CASES WHICH SHOULD BE CHECKED FOR IN THE +C FOLLOWING ORDER. WE ARE ATTEMPTING TO SET LPIECE TO THE NUMBER +C OF CHARACTERS THAT SHOULD BE TAKEN FROM MESSG STARTING AT +C POSITION NEXTC. +C +C LPIECE .EQ. 0 THE NEW LINE SENTINEL DOES NOT OCCUR IN THE +C REMAINDER OF THE CHARACTER STRING. LPIECE +C SHOULD BE SET TO LWRAP OR LENMSG+1-NEXTC, +C WHICHEVER IS LESS. +C +C LPIECE .EQ. 1 THE NEW LINE SENTINEL STARTS AT MESSG(NEXTC: +C NEXTC). LPIECE IS EFFECTIVELY ZERO, AND WE +C PRINT NOTHING TO AVOID PRODUCING UNNECESSARY +C BLANK LINES. THIS TAKES CARE OF THE SITUATION +C WHERE THE LIBRARY ROUTINE HAS A MESSAGE OF +C EXACTLY 72 CHARACTERS FOLLOWED BY A NEW LINE +C SENTINEL FOLLOWED BY MORE CHARACTERS. NEXTC +C SHOULD BE INCREMENTED BY 2. +C +C LPIECE .GT. LWRAP+1 REDUCE LPIECE TO LWRAP. +C +C ELSE THIS LAST CASE MEANS 2 .LE. LPIECE .LE. LWRAP+1 +C RESET LPIECE = LPIECE-1. NOTE THAT THIS +C PROPERLY HANDLES THE END CASE WHERE LPIECE .EQ. +C LWRAP+1. THAT IS, THE SENTINEL FALLS EXACTLY +C AT THE END OF A LINE. +C + NEXTC = 1 + 50 LPIECE = INDEX(MESSG(NEXTC:LENMSG), NEWLIN) + IF (LPIECE .EQ. 0) THEN +C +C THERE WAS NO NEW LINE SENTINEL FOUND. +C + IDELTA = 0 + LPIECE = MIN(LWRAP, LENMSG+1-NEXTC) + IF (LPIECE .LT. LENMSG+1-NEXTC) THEN + DO 52 I=LPIECE+1,2,-1 + IF (MESSG(NEXTC+I-1:NEXTC+I-1) .EQ. ' ') THEN + LPIECE = I-1 + IDELTA = 1 + GOTO 54 + ENDIF + 52 CONTINUE + ENDIF + 54 CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1) + NEXTC = NEXTC + LPIECE + IDELTA + ELSEIF (LPIECE .EQ. 1) THEN +C +C WE HAVE A NEW LINE SENTINEL AT MESSG(NEXTC:NEXTC+1). +C DON'T PRINT A BLANK LINE. +C + NEXTC = NEXTC + 2 + GO TO 50 + ELSEIF (LPIECE .GT. LWRAP+1) THEN +C +C LPIECE SHOULD BE SET DOWN TO LWRAP. +C + IDELTA = 0 + LPIECE = LWRAP + DO 56 I=LPIECE+1,2,-1 + IF (MESSG(NEXTC+I-1:NEXTC+I-1) .EQ. ' ') THEN + LPIECE = I-1 + IDELTA = 1 + GOTO 58 + ENDIF + 56 CONTINUE + 58 CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1) + NEXTC = NEXTC + LPIECE + IDELTA + ELSE +C +C IF WE ARRIVE HERE, IT MEANS 2 .LE. LPIECE .LE. LWRAP+1. +C WE SHOULD DECREMENT LPIECE BY ONE. +C + LPIECE = LPIECE - 1 + CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1) + NEXTC = NEXTC + LPIECE + 2 + ENDIF +C +C PRINT +C + DO 60 I=1,NUNIT + WRITE(IU(I), '(A)') CBUFF(1:LPREF+LPIECE) + 60 CONTINUE +C + IF (NEXTC .LE. LENMSG) GO TO 50 + RETURN + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/slatec-err/xerrwd.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,97 @@ + +*DECK XERRWD + SUBROUTINE XERRWD (MSG, NMES, NERR, LEVEL, NI, I1, I2, NR, R1, R2) +C***BEGIN PROLOGUE XERRWD +C***SUBSIDIARY +C***PURPOSE Write error message with values. +C***LIBRARY MATHLIB +C***CATEGORY R3C +C***TYPE DOUBLE PRECISION (XERRWV-S, XERRWD-D) +C***AUTHOR Hindmarsh, Alan C., (LLNL) +C***DESCRIPTION +C +C Subroutines XERRWD, XSETF, XSETUN, and the function routine IXSAV, +C as given here, constitute a simplified version of the SLATEC error +C handling package. +C +C All arguments are input arguments. +C +C MSG = The message (character array). +C NMES = The length of MSG (number of characters). +C NERR = The error number (not used). +C LEVEL = The error level.. +C 0 or 1 means recoverable (control returns to caller). +C 2 means fatal (run is aborted--see note below). +C NI = Number of integers (0, 1, or 2) to be printed with message. +C I1,I2 = Integers to be printed, depending on NI. +C NR = Number of reals (0, 1, or 2) to be printed with message. +C R1,R2 = Reals to be printed, depending on NR. +C +C Note.. this routine is machine-dependent and specialized for use +C in limited context, in the following ways.. +C 1. The argument MSG is assumed to be of type CHARACTER, and +C the message is printed with a format of (1X,A). +C 2. The message is assumed to take only one line. +C Multi-line messages are generated by repeated calls. +C 3. If LEVEL = 2, control passes to the statement STOP +C to abort the run. This statement may be machine-dependent. +C 4. R1 and R2 are assumed to be in double precision and are printed +C in D21.13 format. +C +C***ROUTINES CALLED IXSAV +C***REVISION HISTORY (YYMMDD) +C 920831 DATE WRITTEN +C 921118 Replaced MFLGSV/LUNSAV by IXSAV. (ACH) +C 930329 Modified prologue to SLATEC format. (FNF) +C 930407 Changed MSG from CHARACTER*1 array to variable. (FNF) +C 930922 Minor cosmetic change. (FNF) +C***END PROLOGUE XERRWD +C +C*Internal Notes: +C +C For a different default logical unit number, IXSAV (or a subsidiary +C routine that it calls) will need to be modified. +C For a different run-abort command, change the statement following +C statement 100 at the end. +C----------------------------------------------------------------------- +C Subroutines called by XERRWD.. None +C Function routine called by XERRWD.. IXSAV +C----------------------------------------------------------------------- +C**End +C +C Declare arguments. +C + DOUBLE PRECISION R1, R2 + INTEGER NMES, NERR, LEVEL, NI, I1, I2, NR + CHARACTER*(*) MSG +C +C Declare local variables. +C + INTEGER LUNIT, IXSAV, MESFLG +C +C Get logical unit number and message print flag. +C +C***FIRST EXECUTABLE STATEMENT XERRWD + LUNIT = IXSAV (1, 0, .FALSE.) + MESFLG = IXSAV (2, 0, .FALSE.) + IF (MESFLG .EQ. 0) GO TO 100 +C +C Write the message. +C + WRITE (LUNIT,10) MSG(1:NMES) + 10 FORMAT(1X,A) + IF (NI .EQ. 1) WRITE (LUNIT, 20) I1 + 20 FORMAT(6X,'In above message, I1 =',I10) + IF (NI .EQ. 2) WRITE (LUNIT, 30) I1,I2 + 30 FORMAT(6X,'In above message, I1 =',I10,3X,'I2 =',I10) + IF (NR .EQ. 1) WRITE (LUNIT, 40) R1 + 40 FORMAT(6X,'In above message, R1 =',D21.13) + IF (NR .EQ. 2) WRITE (LUNIT, 50) R1,R2 + 50 FORMAT(6X,'In above, R1 =',D21.13,3X,'R2 =',D21.13) +C +C Abort the run if LEVEL = 2. +C + 100 IF (LEVEL .NE. 2) RETURN + CALL XSTOPX (' ') +C----------------------- End of Subroutine XERRWD ---------------------- + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/slatec-err/xersve.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,155 @@ +*DECK XERSVE + SUBROUTINE XERSVE (LIBRAR, SUBROU, MESSG, KFLAG, NERR, LEVEL, + + ICOUNT) +C***BEGIN PROLOGUE XERSVE +C***SUBSIDIARY +C***PURPOSE Record that an error has occurred. +C***LIBRARY SLATEC (XERROR) +C***CATEGORY R3 +C***TYPE ALL (XERSVE-A) +C***KEYWORDS ERROR, XERROR +C***AUTHOR Jones, R. E., (SNLA) +C***DESCRIPTION +C +C *Usage: +C +C INTEGER KFLAG, NERR, LEVEL, ICOUNT +C CHARACTER * (len) LIBRAR, SUBROU, MESSG +C +C CALL XERSVE (LIBRAR, SUBROU, MESSG, KFLAG, NERR, LEVEL, ICOUNT) +C +C *Arguments: +C +C LIBRAR :IN is the library that the message is from. +C SUBROU :IN is the subroutine that the message is from. +C MESSG :IN is the message to be saved. +C KFLAG :IN indicates the action to be performed. +C when KFLAG > 0, the message in MESSG is saved. +C when KFLAG=0 the tables will be dumped and +C cleared. +C when KFLAG < 0, the tables will be dumped and +C not cleared. +C NERR :IN is the error number. +C LEVEL :IN is the error severity. +C ICOUNT :OUT the number of times this message has been seen, +C or zero if the table has overflowed and does not +C contain this message specifically. When KFLAG=0, +C ICOUNT will not be altered. +C +C *Description: +C +C Record that this error occurred and possibly dump and clear the +C tables. +C +C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC +C Error-handling Package, SAND82-0800, Sandia +C Laboratories, 1982. +C***ROUTINES CALLED I1MACH, XGETUA +C***REVISION HISTORY (YYMMDD) +C 800319 DATE WRITTEN +C 861211 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900413 Routine modified to remove reference to KFLAG. (WRB) +C 900510 Changed to add LIBRARY NAME and SUBROUTINE to calling +C sequence, use IF-THEN-ELSE, make number of saved entries +C easily changeable, changed routine name from XERSAV to +C XERSVE. (RWC) +C 910626 Added LIBTAB and SUBTAB to SAVE statement. (BKS) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE XERSVE + PARAMETER (LENTAB=10) + INTEGER LUN(5) + CHARACTER*(*) LIBRAR, SUBROU, MESSG + CHARACTER*8 LIBTAB(LENTAB), SUBTAB(LENTAB), LIB, SUB + CHARACTER*20 MESTAB(LENTAB), MES + DIMENSION NERTAB(LENTAB), LEVTAB(LENTAB), KOUNT(LENTAB) + SAVE LIBTAB, SUBTAB, MESTAB, NERTAB, LEVTAB, KOUNT, KOUNTX, NMSG + DATA KOUNTX/0/, NMSG/0/ +C***FIRST EXECUTABLE STATEMENT XERSVE +C + IF (KFLAG.LE.0) THEN +C +C Dump the table. +C + IF (NMSG.EQ.0) RETURN +C +C Print to each unit. +C + CALL XGETUA (LUN, NUNIT) + DO 20 KUNIT = 1,NUNIT + IUNIT = LUN(KUNIT) + IF (IUNIT.EQ.0) IUNIT = I1MACH(4) +C +C Print the table header. +C + WRITE (IUNIT,9000) +C +C Print body of table. +C + DO 10 I = 1,NMSG + WRITE (IUNIT,9010) LIBTAB(I), SUBTAB(I), MESTAB(I), + * NERTAB(I),LEVTAB(I),KOUNT(I) + 10 CONTINUE +C +C Print number of other errors. +C + IF (KOUNTX.NE.0) WRITE (IUNIT,9020) KOUNTX + WRITE (IUNIT,9030) + 20 CONTINUE +C +C Clear the error tables. +C + IF (KFLAG.EQ.0) THEN + NMSG = 0 + KOUNTX = 0 + ENDIF + ELSE +C +C PROCESS A MESSAGE... +C SEARCH FOR THIS MESSG, OR ELSE AN EMPTY SLOT FOR THIS MESSG, +C OR ELSE DETERMINE THAT THE ERROR TABLE IS FULL. +C + LIB = LIBRAR + SUB = SUBROU + MES = MESSG + DO 30 I = 1,NMSG + IF (LIB.EQ.LIBTAB(I) .AND. SUB.EQ.SUBTAB(I) .AND. + * MES.EQ.MESTAB(I) .AND. NERR.EQ.NERTAB(I) .AND. + * LEVEL.EQ.LEVTAB(I)) THEN + KOUNT(I) = KOUNT(I) + 1 + ICOUNT = KOUNT(I) + RETURN + ENDIF + 30 CONTINUE +C + IF (NMSG.LT.LENTAB) THEN +C +C Empty slot found for new message. +C + NMSG = NMSG + 1 + LIBTAB(I) = LIB + SUBTAB(I) = SUB + MESTAB(I) = MES + NERTAB(I) = NERR + LEVTAB(I) = LEVEL + KOUNT (I) = 1 + ICOUNT = 1 + ELSE +C +C Table is full. +C + KOUNTX = KOUNTX+1 + ICOUNT = 0 + ENDIF + ENDIF + RETURN +C +C Formats. +C + 9000 FORMAT ('0 ERROR MESSAGE SUMMARY' / + + ' LIBRARY SUBROUTINE MESSAGE START NERR', + + ' LEVEL COUNT') + 9010 FORMAT (1X,A,3X,A,3X,A,3I10) + 9020 FORMAT ('0OTHER ERRORS NOT INDIVIDUALLY TABULATED = ', I10) + 9030 FORMAT (1X) + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/slatec-err/xgetf.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,30 @@ +*DECK XGETF + SUBROUTINE XGETF (KONTRL) +C***BEGIN PROLOGUE XGETF +C***PURPOSE Return the current value of the error control flag. +C***LIBRARY SLATEC (XERROR) +C***CATEGORY R3C +C***TYPE ALL (XGETF-A) +C***KEYWORDS ERROR, XERROR +C***AUTHOR Jones, R. E., (SNLA) +C***DESCRIPTION +C +C Abstract +C XGETF returns the current value of the error control flag +C in KONTRL. See subroutine XSETF for flag value meanings. +C (KONTRL is an output parameter only.) +C +C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC +C Error-handling Package, SAND82-0800, Sandia +C Laboratories, 1982. +C***ROUTINES CALLED J4SAVE +C***REVISION HISTORY (YYMMDD) +C 790801 DATE WRITTEN +C 861211 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE XGETF +C***FIRST EXECUTABLE STATEMENT XGETF + KONTRL = J4SAVE(2,0,.FALSE.) + RETURN + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/slatec-err/xgetua.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,51 @@ +*DECK XGETUA + SUBROUTINE XGETUA (IUNITA, N) +C***BEGIN PROLOGUE XGETUA +C***PURPOSE Return unit number(s) to which error messages are being +C sent. +C***LIBRARY SLATEC (XERROR) +C***CATEGORY R3C +C***TYPE ALL (XGETUA-A) +C***KEYWORDS ERROR, XERROR +C***AUTHOR Jones, R. E., (SNLA) +C***DESCRIPTION +C +C Abstract +C XGETUA may be called to determine the unit number or numbers +C to which error messages are being sent. +C These unit numbers may have been set by a call to XSETUN, +C or a call to XSETUA, or may be a default value. +C +C Description of Parameters +C --Output-- +C IUNIT - an array of one to five unit numbers, depending +C on the value of N. A value of zero refers to the +C default unit, as defined by the I1MACH machine +C constant routine. Only IUNIT(1),...,IUNIT(N) are +C defined by XGETUA. The values of IUNIT(N+1),..., +C IUNIT(5) are not defined (for N .LT. 5) or altered +C in any way by XGETUA. +C N - the number of units to which copies of the +C error messages are being sent. N will be in the +C range from 1 to 5. +C +C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC +C Error-handling Package, SAND82-0800, Sandia +C Laboratories, 1982. +C***ROUTINES CALLED J4SAVE +C***REVISION HISTORY (YYMMDD) +C 790801 DATE WRITTEN +C 861211 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE XGETUA + DIMENSION IUNITA(5) +C***FIRST EXECUTABLE STATEMENT XGETUA + N = J4SAVE(5,0,.FALSE.) + DO 30 I=1,N + INDEX = I+4 + IF (I.EQ.1) INDEX = 3 + IUNITA(I) = J4SAVE(INDEX,0,.FALSE.) + 30 CONTINUE + RETURN + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/slatec-err/xsetf.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,60 @@ +*DECK XSETF + SUBROUTINE XSETF (KONTRL) +C***BEGIN PROLOGUE XSETF +C***PURPOSE Set the error control flag. +C***LIBRARY SLATEC (XERROR) +C***CATEGORY R3A +C***TYPE ALL (XSETF-A) +C***KEYWORDS ERROR, XERROR +C***AUTHOR Jones, R. E., (SNLA) +C***DESCRIPTION +C +C Abstract +C XSETF sets the error control flag value to KONTRL. +C (KONTRL is an input parameter only.) +C The following table shows how each message is treated, +C depending on the values of KONTRL and LEVEL. (See XERMSG +C for description of LEVEL.) +C +C If KONTRL is zero or negative, no information other than the +C message itself (including numeric values, if any) will be +C printed. If KONTRL is positive, introductory messages, +C trace-backs, etc., will be printed in addition to the message. +C +C ABS(KONTRL) +C LEVEL 0 1 2 +C value +C 2 fatal fatal fatal +C +C 1 not printed printed fatal +C +C 0 not printed printed printed +C +C -1 not printed printed printed +C only only +C once once +C +C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC +C Error-handling Package, SAND82-0800, Sandia +C Laboratories, 1982. +C***ROUTINES CALLED J4SAVE, XERMSG +C***REVISION HISTORY (YYMMDD) +C 790801 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890531 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900510 Change call to XERRWV to XERMSG. (RWC) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE XSETF + CHARACTER *8 XERN1 +C***FIRST EXECUTABLE STATEMENT XSETF + IF (ABS(KONTRL) .GT. 2) THEN + WRITE (XERN1, '(I8)') KONTRL + CALL XERMSG ('SLATEC', 'XSETF', + * 'INVALID ARGUMENT = ' // XERN1, 1, 2) + RETURN + ENDIF +C + JUNK = J4SAVE(2,KONTRL,.TRUE.) + RETURN + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/slatec-err/xsetua.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,59 @@ +*DECK XSETUA + SUBROUTINE XSETUA (IUNITA, N) +C***BEGIN PROLOGUE XSETUA +C***PURPOSE Set logical unit numbers (up to 5) to which error +C messages are to be sent. +C***LIBRARY SLATEC (XERROR) +C***CATEGORY R3B +C***TYPE ALL (XSETUA-A) +C***KEYWORDS ERROR, XERROR +C***AUTHOR Jones, R. E., (SNLA) +C***DESCRIPTION +C +C Abstract +C XSETUA may be called to declare a list of up to five +C logical units, each of which is to receive a copy of +C each error message processed by this package. +C The purpose of XSETUA is to allow simultaneous printing +C of each error message on, say, a main output file, +C an interactive terminal, and other files such as graphics +C communication files. +C +C Description of Parameters +C --Input-- +C IUNIT - an array of up to five unit numbers. +C Normally these numbers should all be different +C (but duplicates are not prohibited.) +C N - the number of unit numbers provided in IUNIT +C must have 1 .LE. N .LE. 5. +C +C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC +C Error-handling Package, SAND82-0800, Sandia +C Laboratories, 1982. +C***ROUTINES CALLED J4SAVE, XERMSG +C***REVISION HISTORY (YYMMDD) +C 790801 DATE WRITTEN +C 861211 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900510 Change call to XERRWV to XERMSG. (RWC) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE XSETUA + DIMENSION IUNITA(5) + CHARACTER *8 XERN1 +C***FIRST EXECUTABLE STATEMENT XSETUA +C + IF (N.LT.1 .OR. N.GT.5) THEN + WRITE (XERN1, '(I8)') N + CALL XERMSG ('SLATEC', 'XSETUA', + * 'INVALID NUMBER OF UNITS, N = ' // XERN1, 1, 2) + RETURN + ENDIF +C + DO 10 I=1,N + INDEX = I+4 + IF (I.EQ.1) INDEX = 3 + JUNK = J4SAVE(INDEX,IUNITA(I),.TRUE.) + 10 CONTINUE + JUNK = J4SAVE(5,N,.TRUE.) + RETURN + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/slatec-fn/acosh.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,39 @@ +*DECK ACOSH + FUNCTION ACOSH (X) +C***BEGIN PROLOGUE ACOSH +C***PURPOSE Compute the arc hyperbolic cosine. +C***LIBRARY SLATEC (FNLIB) +C***CATEGORY C4C +C***TYPE SINGLE PRECISION (ACOSH-S, DACOSH-D, CACOSH-C) +C***KEYWORDS ACOSH, ARC HYPERBOLIC COSINE, ELEMENTARY FUNCTIONS, FNLIB, +C INVERSE HYPERBOLIC COSINE +C***AUTHOR Fullerton, W., (LANL) +C***DESCRIPTION +C +C ACOSH(X) computes the arc hyperbolic cosine of X. +C +C***REFERENCES (NONE) +C***ROUTINES CALLED R1MACH, XERMSG +C***REVISION HISTORY (YYMMDD) +C 770401 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890531 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C 900326 Removed duplicate information from DESCRIPTION section. +C (WRB) +C***END PROLOGUE ACOSH + SAVE ALN2,XMAX + DATA ALN2 / 0.6931471805 5994530942E0/ + DATA XMAX /0./ +C***FIRST EXECUTABLE STATEMENT ACOSH + IF (XMAX.EQ.0.) XMAX = 1.0/SQRT(R1MACH(3)) +C + IF (X .LT. 1.0) CALL XERMSG ('SLATEC', 'ACOSH', 'X LESS THAN 1', + + 1, 2) +C + IF (X.LT.XMAX) ACOSH = LOG (X + SQRT(X*X-1.0)) + IF (X.GE.XMAX) ACOSH = ALN2 + LOG(X) +C + RETURN + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/slatec-fn/albeta.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,63 @@ +*DECK ALBETA + FUNCTION ALBETA (A, B) +C***BEGIN PROLOGUE ALBETA +C***PURPOSE Compute the natural logarithm of the complete Beta +C function. +C***LIBRARY SLATEC (FNLIB) +C***CATEGORY C7B +C***TYPE SINGLE PRECISION (ALBETA-S, DLBETA-D, CLBETA-C) +C***KEYWORDS FNLIB, LOGARITHM OF THE COMPLETE BETA FUNCTION, +C SPECIAL FUNCTIONS +C***AUTHOR Fullerton, W., (LANL) +C***DESCRIPTION +C +C ALBETA computes the natural log of the complete beta function. +C +C Input Parameters: +C A real and positive +C B real and positive +C +C***REFERENCES (NONE) +C***ROUTINES CALLED ALNGAM, ALNREL, GAMMA, R9LGMC, XERMSG +C***REVISION HISTORY (YYMMDD) +C 770701 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890531 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C 900326 Removed duplicate information from DESCRIPTION section. +C (WRB) +C 900727 Added EXTERNAL statement. (WRB) +C***END PROLOGUE ALBETA + EXTERNAL GAMMA + SAVE SQ2PIL + DATA SQ2PIL / 0.9189385332 0467274 E0 / +C***FIRST EXECUTABLE STATEMENT ALBETA + P = MIN (A, B) + Q = MAX (A, B) +C + IF (P .LE. 0.0) CALL XERMSG ('SLATEC', 'ALBETA', + + 'BOTH ARGUMENTS MUST BE GT ZERO', 1, 2) + IF (P.GE.10.0) GO TO 30 + IF (Q.GE.10.0) GO TO 20 +C +C P AND Q ARE SMALL. +C + ALBETA = LOG(GAMMA(P) * (GAMMA(Q)/GAMMA(P+Q)) ) + RETURN +C +C P IS SMALL, BUT Q IS BIG. +C + 20 CORR = R9LGMC(Q) - R9LGMC(P+Q) + ALBETA = ALNGAM(P) + CORR + P - P*LOG(P+Q) + + 1 (Q-0.5)*ALNREL(-P/(P+Q)) + RETURN +C +C P AND Q ARE BIG. +C + 30 CORR = R9LGMC(P) + R9LGMC(Q) - R9LGMC(P+Q) + ALBETA = -0.5*LOG(Q) + SQ2PIL + CORR + (P-0.5)*LOG(P/(P+Q)) + 1 + Q*ALNREL(-P/(P+Q)) + RETURN +C + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/slatec-fn/algams.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,38 @@ +*DECK ALGAMS + SUBROUTINE ALGAMS (X, ALGAM, SGNGAM) +C***BEGIN PROLOGUE ALGAMS +C***PURPOSE Compute the logarithm of the absolute value of the Gamma +C function. +C***LIBRARY SLATEC (FNLIB) +C***CATEGORY C7A +C***TYPE SINGLE PRECISION (ALGAMS-S, DLGAMS-D) +C***KEYWORDS ABSOLUTE VALUE OF THE LOGARITHM OF THE GAMMA FUNCTION, +C FNLIB, SPECIAL FUNCTIONS +C***AUTHOR Fullerton, W., (LANL) +C***DESCRIPTION +C +C Evaluates the logarithm of the absolute value of the gamma +C function. +C X - input argument +C ALGAM - result +C SGNGAM - is set to the sign of GAMMA(X) and will +C be returned at +1.0 or -1.0. +C +C***REFERENCES (NONE) +C***ROUTINES CALLED ALNGAM +C***REVISION HISTORY (YYMMDD) +C 770701 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890531 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C***END PROLOGUE ALGAMS +C***FIRST EXECUTABLE STATEMENT ALGAMS + ALGAM = ALNGAM(X) + SGNGAM = 1.0 + IF (X.GT.0.0) RETURN +C + INT = MOD (-AINT(X), 2.0) + 0.1 + IF (INT.EQ.0) SGNGAM = -1.0 +C + RETURN + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/slatec-fn/alngam.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,70 @@ +*DECK ALNGAM + FUNCTION ALNGAM (X) +C***BEGIN PROLOGUE ALNGAM +C***PURPOSE Compute the logarithm of the absolute value of the Gamma +C function. +C***LIBRARY SLATEC (FNLIB) +C***CATEGORY C7A +C***TYPE SINGLE PRECISION (ALNGAM-S, DLNGAM-D, CLNGAM-C) +C***KEYWORDS ABSOLUTE VALUE, COMPLETE GAMMA FUNCTION, FNLIB, LOGARITHM, +C SPECIAL FUNCTIONS +C***AUTHOR Fullerton, W., (LANL) +C***DESCRIPTION +C +C ALNGAM(X) computes the logarithm of the absolute value of the +C gamma function at X. +C +C***REFERENCES (NONE) +C***ROUTINES CALLED GAMMA, R1MACH, R9LGMC, XERMSG +C***REVISION HISTORY (YYMMDD) +C 770601 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890531 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C 900326 Removed duplicate information from DESCRIPTION section. +C (WRB) +C 900727 Added EXTERNAL statement. (WRB) +C***END PROLOGUE ALNGAM + LOGICAL FIRST + EXTERNAL GAMMA + SAVE SQ2PIL, SQPI2L, PI, XMAX, DXREL, FIRST + DATA SQ2PIL / 0.9189385332 0467274E0/ + DATA SQPI2L / 0.2257913526 4472743E0/ + DATA PI / 3.1415926535 8979324E0/ + DATA FIRST /.TRUE./ +C***FIRST EXECUTABLE STATEMENT ALNGAM + IF (FIRST) THEN + XMAX = R1MACH(2)/LOG(R1MACH(2)) + DXREL = SQRT (R1MACH(4)) + ENDIF + FIRST = .FALSE. +C + Y = ABS(X) + IF (Y.GT.10.0) GO TO 20 +C +C LOG (ABS (GAMMA(X))) FOR ABS(X) .LE. 10.0 +C + ALNGAM = LOG (ABS (GAMMA(X))) + RETURN +C +C LOG (ABS (GAMMA(X))) FOR ABS(X) .GT. 10.0 +C + 20 IF (Y .GT. XMAX) CALL XERMSG ('SLATEC', 'ALNGAM', + + 'ABS(X) SO BIG ALNGAM OVERFLOWS', 2, 2) +C + IF (X.GT.0.) ALNGAM = SQ2PIL + (X-0.5)*LOG(X) - X + R9LGMC(Y) + IF (X.GT.0.) RETURN +C + SINPIY = ABS (SIN(PI*Y)) + IF (SINPIY .EQ. 0.) CALL XERMSG ('SLATEC', 'ALNGAM', + + 'X IS A NEGATIVE INTEGER', 3, 2) +C + IF (ABS((X-AINT(X-0.5))/X) .LT. DXREL) CALL XERMSG ('SLATEC', + + 'ALNGAM', 'ANSWER LT HALF PRECISION BECAUSE X TOO NEAR ' // + + 'NEGATIVE INTEGER', 1, 1) +C + ALNGAM = SQPI2L + (X-0.5)*LOG(Y) - X - LOG(SINPIY) - R9LGMC(Y) + RETURN +C + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/slatec-fn/alnrel.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,78 @@ +*DECK ALNREL + FUNCTION ALNREL (X) +C***BEGIN PROLOGUE ALNREL +C***PURPOSE Evaluate ln(1+X) accurate in the sense of relative error. +C***LIBRARY SLATEC (FNLIB) +C***CATEGORY C4B +C***TYPE SINGLE PRECISION (ALNREL-S, DLNREL-D, CLNREL-C) +C***KEYWORDS ELEMENTARY FUNCTIONS, FNLIB, LOGARITHM +C***AUTHOR Fullerton, W., (LANL) +C***DESCRIPTION +C +C ALNREL(X) evaluates ln(1+X) accurately in the sense of relative +C error when X is very small. This routine must be used to +C maintain relative error accuracy whenever X is small and +C accurately known. +C +C Series for ALNR on the interval -3.75000D-01 to 3.75000D-01 +C with weighted error 1.93E-17 +C log weighted error 16.72 +C significant figures required 16.44 +C decimal places required 17.40 +C +C***REFERENCES (NONE) +C***ROUTINES CALLED CSEVL, INITS, R1MACH, XERMSG +C***REVISION HISTORY (YYMMDD) +C 770401 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890531 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C 900326 Removed duplicate information from DESCRIPTION section. +C (WRB) +C***END PROLOGUE ALNREL + DIMENSION ALNRCS(23) + LOGICAL FIRST + SAVE ALNRCS, NLNREL, XMIN, FIRST + DATA ALNRCS( 1) / 1.0378693562 743770E0 / + DATA ALNRCS( 2) / -.1336430150 4908918E0 / + DATA ALNRCS( 3) / .0194082491 35520563E0 / + DATA ALNRCS( 4) / -.0030107551 12753577E0 / + DATA ALNRCS( 5) / .0004869461 47971548E0 / + DATA ALNRCS( 6) / -.0000810548 81893175E0 / + DATA ALNRCS( 7) / .0000137788 47799559E0 / + DATA ALNRCS( 8) / -.0000023802 21089435E0 / + DATA ALNRCS( 9) / .0000004164 04162138E0 / + DATA ALNRCS(10) / -.0000000735 95828378E0 / + DATA ALNRCS(11) / .0000000131 17611876E0 / + DATA ALNRCS(12) / -.0000000023 54670931E0 / + DATA ALNRCS(13) / .0000000004 25227732E0 / + DATA ALNRCS(14) / -.0000000000 77190894E0 / + DATA ALNRCS(15) / .0000000000 14075746E0 / + DATA ALNRCS(16) / -.0000000000 02576907E0 / + DATA ALNRCS(17) / .0000000000 00473424E0 / + DATA ALNRCS(18) / -.0000000000 00087249E0 / + DATA ALNRCS(19) / .0000000000 00016124E0 / + DATA ALNRCS(20) / -.0000000000 00002987E0 / + DATA ALNRCS(21) / .0000000000 00000554E0 / + DATA ALNRCS(22) / -.0000000000 00000103E0 / + DATA ALNRCS(23) / .0000000000 00000019E0 / + DATA FIRST /.TRUE./ +C***FIRST EXECUTABLE STATEMENT ALNREL + IF (FIRST) THEN + NLNREL = INITS (ALNRCS, 23, 0.1*R1MACH(3)) + XMIN = -1.0 + SQRT(R1MACH(4)) + ENDIF + FIRST = .FALSE. +C + IF (X .LE. (-1.0)) CALL XERMSG ('SLATEC', 'ALNREL', 'X IS LE -1', + + 2, 2) + IF (X .LT. XMIN) CALL XERMSG ('SLATEC', 'ALNREL', + + 'ANSWER LT HALF PRECISION BECAUSE X TOO NEAR -1', 1, 1) +C + IF (ABS(X).LE.0.375) ALNREL = X*(1. - + 1 X*CSEVL (X/.375, ALNRCS, NLNREL)) + IF (ABS(X).GT.0.375) ALNREL = LOG (1.0+X) +C + RETURN + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/slatec-fn/asinh.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,74 @@ +*DECK ASINH + FUNCTION ASINH (X) +C***BEGIN PROLOGUE ASINH +C***PURPOSE Compute the arc hyperbolic sine. +C***LIBRARY SLATEC (FNLIB) +C***CATEGORY C4C +C***TYPE SINGLE PRECISION (ASINH-S, DASINH-D, CASINH-C) +C***KEYWORDS ARC HYPERBOLIC SINE, ASINH, ELEMENTARY FUNCTIONS, FNLIB, +C INVERSE HYPERBOLIC SINE +C***AUTHOR Fullerton, W., (LANL) +C***DESCRIPTION +C +C ASINH(X) computes the arc hyperbolic sine of X. +C +C Series for ASNH on the interval 0. to 1.00000D+00 +C with weighted error 2.19E-17 +C log weighted error 16.66 +C significant figures required 15.60 +C decimal places required 17.31 +C +C***REFERENCES (NONE) +C***ROUTINES CALLED CSEVL, INITS, R1MACH +C***REVISION HISTORY (YYMMDD) +C 770401 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890531 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C***END PROLOGUE ASINH + DIMENSION ASNHCS(20) + LOGICAL FIRST + SAVE ALN2, ASNHCS, NTERMS, XMAX, SQEPS, FIRST + DATA ALN2 /0.6931471805 5994530942E0/ + DATA ASNHCS( 1) / -.1282003991 1738186E0 / + DATA ASNHCS( 2) / -.0588117611 89951768E0 / + DATA ASNHCS( 3) / .0047274654 32212481E0 / + DATA ASNHCS( 4) / -.0004938363 16265361E0 / + DATA ASNHCS( 5) / .0000585062 07058557E0 / + DATA ASNHCS( 6) / -.0000074669 98328931E0 / + DATA ASNHCS( 7) / .0000010011 69358355E0 / + DATA ASNHCS( 8) / -.0000001390 35438587E0 / + DATA ASNHCS( 9) / .0000000198 23169483E0 / + DATA ASNHCS(10) / -.0000000028 84746841E0 / + DATA ASNHCS(11) / .0000000004 26729654E0 / + DATA ASNHCS(12) / -.0000000000 63976084E0 / + DATA ASNHCS(13) / .0000000000 09699168E0 / + DATA ASNHCS(14) / -.0000000000 01484427E0 / + DATA ASNHCS(15) / .0000000000 00229037E0 / + DATA ASNHCS(16) / -.0000000000 00035588E0 / + DATA ASNHCS(17) / .0000000000 00005563E0 / + DATA ASNHCS(18) / -.0000000000 00000874E0 / + DATA ASNHCS(19) / .0000000000 00000138E0 / + DATA ASNHCS(20) / -.0000000000 00000021E0 / + DATA FIRST /.TRUE./ +C***FIRST EXECUTABLE STATEMENT ASINH + IF (FIRST) THEN + NTERMS = INITS (ASNHCS, 20, 0.1*R1MACH(3)) + SQEPS = SQRT (R1MACH(3)) + XMAX = 1.0/SQEPS + ENDIF + FIRST = .FALSE. +C + Y = ABS(X) + IF (Y.GT.1.0) GO TO 20 +C + ASINH = X + IF (Y.GT.SQEPS) ASINH = X*(1.0 + CSEVL (2.*X*X-1., ASNHCS,NTERMS)) + RETURN +C + 20 IF (Y.LT.XMAX) ASINH = LOG (Y + SQRT(Y**2+1.)) + IF (Y.GE.XMAX) ASINH = ALN2 + LOG(Y) + ASINH = SIGN (ASINH, X) +C + RETURN + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/slatec-fn/atanh.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,78 @@ +*DECK ATANH + FUNCTION ATANH (X) +C***BEGIN PROLOGUE ATANH +C***PURPOSE Compute the arc hyperbolic tangent. +C***LIBRARY SLATEC (FNLIB) +C***CATEGORY C4C +C***TYPE SINGLE PRECISION (ATANH-S, DATANH-D, CATANH-C) +C***KEYWORDS ARC HYPERBOLIC TANGENT, ATANH, ELEMENTARY FUNCTIONS, +C FNLIB, INVERSE HYPERBOLIC TANGENT +C***AUTHOR Fullerton, W., (LANL) +C***DESCRIPTION +C +C ATANH(X) computes the arc hyperbolic tangent of X. +C +C Series for ATNH on the interval 0. to 2.50000D-01 +C with weighted error 6.70E-18 +C log weighted error 17.17 +C significant figures required 16.01 +C decimal places required 17.76 +C +C***REFERENCES (NONE) +C***ROUTINES CALLED CSEVL, INITS, R1MACH, XERMSG +C***REVISION HISTORY (YYMMDD) +C 770401 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890531 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C 900326 Removed duplicate information from DESCRIPTION section. +C (WRB) +C***END PROLOGUE ATANH + DIMENSION ATNHCS(15) + LOGICAL FIRST + SAVE ATNHCS, NTERMS, DXREL, SQEPS, FIRST + DATA ATNHCS( 1) / .0943951023 93195492E0 / + DATA ATNHCS( 2) / .0491984370 55786159E0 / + DATA ATNHCS( 3) / .0021025935 22455432E0 / + DATA ATNHCS( 4) / .0001073554 44977611E0 / + DATA ATNHCS( 5) / .0000059782 67249293E0 / + DATA ATNHCS( 6) / .0000003505 06203088E0 / + DATA ATNHCS( 7) / .0000000212 63743437E0 / + DATA ATNHCS( 8) / .0000000013 21694535E0 / + DATA ATNHCS( 9) / .0000000000 83658755E0 / + DATA ATNHCS(10) / .0000000000 05370503E0 / + DATA ATNHCS(11) / .0000000000 00348665E0 / + DATA ATNHCS(12) / .0000000000 00022845E0 / + DATA ATNHCS(13) / .0000000000 00001508E0 / + DATA ATNHCS(14) / .0000000000 00000100E0 / + DATA ATNHCS(15) / .0000000000 00000006E0 / + DATA FIRST /.TRUE./ +C***FIRST EXECUTABLE STATEMENT ATANH + IF (FIRST) THEN + NTERMS = INITS (ATNHCS, 15, 0.1*R1MACH(3)) + DXREL = SQRT (R1MACH(4)) + SQEPS = SQRT (3.0*R1MACH(3)) + ENDIF + FIRST = .FALSE. +C + Y = ABS(X) + IF (Y .GE. 1.0) THEN + IF (Y .GT. 1.0) THEN + ATANH = (X - X) / (X - X) + ELSE + ATANH = X / 0.0 + ENDIF + RETURN + ENDIF +C + IF (1.0-Y .LT. DXREL) CALL XERMSG ('SLATEC', 'ATANH', + + 'ANSWER LT HALF PRECISION BECAUSE ABS(X) TOO NEAR 1', 1, 1) +C + ATANH = X + IF (Y.GT.SQEPS .AND. Y.LE.0.5) ATANH = X*(1.0 + CSEVL (8.*X*X-1., + 1 ATNHCS, NTERMS)) + IF (Y.GT.0.5) ATANH = 0.5*LOG((1.0+X)/(1.0-X)) +C + RETURN + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/slatec-fn/betai.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,118 @@ +*DECK BETAI + REAL FUNCTION BETAI (X, PIN, QIN) +C***BEGIN PROLOGUE BETAI +C***PURPOSE Calculate the incomplete Beta function. +C***LIBRARY SLATEC (FNLIB) +C***CATEGORY C7F +C***TYPE SINGLE PRECISION (BETAI-S, DBETAI-D) +C***KEYWORDS FNLIB, INCOMPLETE BETA FUNCTION, SPECIAL FUNCTIONS +C***AUTHOR Fullerton, W., (LANL) +C***DESCRIPTION +C +C BETAI calculates the REAL incomplete beta function. +C +C The incomplete beta function ratio is the probability that a +C random variable from a beta distribution having parameters PIN and +C QIN will be less than or equal to X. +C +C -- Input Arguments -- All arguments are REAL. +C X upper limit of integration. X must be in (0,1) inclusive. +C PIN first beta distribution parameter. PIN must be .GT. 0.0. +C QIN second beta distribution parameter. QIN must be .GT. 0.0. +C +C***REFERENCES Nancy E. Bosten and E. L. Battiste, Remark on Algorithm +C 179, Communications of the ACM 17, 3 (March 1974), +C pp. 156. +C***ROUTINES CALLED ALBETA, R1MACH, XERMSG +C***REVISION HISTORY (YYMMDD) +C 770401 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890531 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C 900326 Removed duplicate information from DESCRIPTION section. +C (WRB) +C 920528 DESCRIPTION and REFERENCES sections revised. (WRB) +C***END PROLOGUE BETAI + LOGICAL FIRST + SAVE EPS, ALNEPS, SML, ALNSML, FIRST + DATA FIRST /.TRUE./ +C***FIRST EXECUTABLE STATEMENT BETAI + IF (FIRST) THEN + EPS = R1MACH(3) + ALNEPS = LOG(EPS) + SML = R1MACH(1) + ALNSML = LOG(SML) + ENDIF + FIRST = .FALSE. +C + IF (X .LT. 0. .OR. X .GT. 1.0) CALL XERMSG ('SLATEC', 'BETAI', + + 'X IS NOT IN THE RANGE (0,1)', 1, 2) + IF (PIN .LE. 0. .OR. QIN .LE. 0.) CALL XERMSG ('SLATEC', 'BETAI', + + 'P AND/OR Q IS LE ZERO', 2, 2) +C + Y = X + P = PIN + Q = QIN + IF (Q.LE.P .AND. X.LT.0.8) GO TO 20 + IF (X.LT.0.2) GO TO 20 + Y = 1.0 - Y + P = QIN + Q = PIN +C + 20 IF ((P+Q)*Y/(P+1.).LT.EPS) GO TO 80 +C +C EVALUATE THE INFINITE SUM FIRST. +C TERM WILL EQUAL Y**P/BETA(PS,P) * (1.-PS)I * Y**I / FAC(I) +C + PS = Q - AINT(Q) + IF (PS.EQ.0.) PS = 1.0 + XB = P*LOG(Y) - ALBETA(PS, P) - LOG(P) + BETAI = 0.0 + IF (XB.LT.ALNSML) GO TO 40 +C + BETAI = EXP (XB) + TERM = BETAI*P + IF (PS.EQ.1.0) GO TO 40 +C + N = MAX (ALNEPS/LOG(Y), 4.0E0) + DO 30 I=1,N + TERM = TERM*(I-PS)*Y/I + BETAI = BETAI + TERM/(P+I) + 30 CONTINUE +C +C NOW EVALUATE THE FINITE SUM, MAYBE. +C + 40 IF (Q.LE.1.0) GO TO 70 +C + XB = P*LOG(Y) + Q*LOG(1.0-Y) - ALBETA(P,Q) - LOG(Q) + IB = MAX (XB/ALNSML, 0.0E0) + TERM = EXP (XB - IB*ALNSML) + C = 1.0/(1.0-Y) + P1 = Q*C/(P+Q-1.) +C + FINSUM = 0.0 + N = Q + IF (Q.EQ.REAL(N)) N = N - 1 + DO 50 I=1,N + IF (P1.LE.1.0 .AND. TERM/EPS.LE.FINSUM) GO TO 60 + TERM = (Q-I+1)*C*TERM/(P+Q-I) +C + IF (TERM.GT.1.0) IB = IB - 1 + IF (TERM.GT.1.0) TERM = TERM*SML +C + IF (IB.EQ.0) FINSUM = FINSUM + TERM + 50 CONTINUE +C + 60 BETAI = BETAI + FINSUM + 70 IF (Y.NE.X .OR. P.NE.PIN) BETAI = 1.0 - BETAI + BETAI = MAX (MIN (BETAI, 1.0), 0.0) + RETURN +C + 80 BETAI = 0.0 + XB = P*LOG(MAX(Y,SML)) - LOG(P) - ALBETA(P,Q) + IF (XB.GT.ALNSML .AND. Y.NE.0.) BETAI = EXP (XB) + IF (Y.NE.X .OR. P.NE.PIN) BETAI = 1.0 - BETAI + RETURN +C + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/slatec-fn/csevl.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,65 @@ +*DECK CSEVL + FUNCTION CSEVL (X, CS, N) +C***BEGIN PROLOGUE CSEVL +C***PURPOSE Evaluate a Chebyshev series. +C***LIBRARY SLATEC (FNLIB) +C***CATEGORY C3A2 +C***TYPE SINGLE PRECISION (CSEVL-S, DCSEVL-D) +C***KEYWORDS CHEBYSHEV SERIES, FNLIB, SPECIAL FUNCTIONS +C***AUTHOR Fullerton, W., (LANL) +C***DESCRIPTION +C +C Evaluate the N-term Chebyshev series CS at X. Adapted from +C a method presented in the paper by Broucke referenced below. +C +C Input Arguments -- +C X value at which the series is to be evaluated. +C CS array of N terms of a Chebyshev series. In evaluating +C CS, only half the first coefficient is summed. +C N number of terms in array CS. +C +C***REFERENCES R. Broucke, Ten subroutines for the manipulation of +C Chebyshev series, Algorithm 446, Communications of +C the A.C.M. 16, (1973) pp. 254-256. +C L. Fox and I. B. Parker, Chebyshev Polynomials in +C Numerical Analysis, Oxford University Press, 1968, +C page 56. +C***ROUTINES CALLED R1MACH, XERMSG +C***REVISION HISTORY (YYMMDD) +C 770401 DATE WRITTEN +C 890831 Modified array declarations. (WRB) +C 890831 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C 900329 Prologued revised extensively and code rewritten to allow +C X to be slightly outside interval (-1,+1). (WRB) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE CSEVL + REAL B0, B1, B2, CS(*), ONEPL, TWOX, X + LOGICAL FIRST + SAVE FIRST, ONEPL + DATA FIRST /.TRUE./ +C***FIRST EXECUTABLE STATEMENT CSEVL + IF (FIRST) ONEPL = 1.0E0 + R1MACH(4) + FIRST = .FALSE. + IF (N .LT. 1) CALL XERMSG ('SLATEC', 'CSEVL', + + 'NUMBER OF TERMS .LE. 0', 2, 2) + IF (N .GT. 1000) CALL XERMSG ('SLATEC', 'CSEVL', + + 'NUMBER OF TERMS .GT. 1000', 3, 2) + IF (ABS(X) .GT. ONEPL) CALL XERMSG ('SLATEC', 'CSEVL', + + 'X OUTSIDE THE INTERVAL (-1,+1)', 1, 1) +C + B1 = 0.0E0 + B0 = 0.0E0 + TWOX = 2.0*X + DO 10 I = 1,N + B2 = B1 + B1 = B0 + NI = N + 1 - I + B0 = TWOX*B1 - B2 + CS(NI) + 10 CONTINUE +C + CSEVL = 0.5E0*(B0-B2) +C + RETURN + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/slatec-fn/d9gmit.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,91 @@ +*DECK D9GMIT + DOUBLE PRECISION FUNCTION D9GMIT (A, X, ALGAP1, SGNGAM, ALX) +C***BEGIN PROLOGUE D9GMIT +C***SUBSIDIARY +C***PURPOSE Compute Tricomi's incomplete Gamma function for small +C arguments. +C***LIBRARY SLATEC (FNLIB) +C***CATEGORY C7E +C***TYPE DOUBLE PRECISION (R9GMIT-S, D9GMIT-D) +C***KEYWORDS COMPLEMENTARY INCOMPLETE GAMMA FUNCTION, FNLIB, SMALL X, +C SPECIAL FUNCTIONS, TRICOMI +C***AUTHOR Fullerton, W., (LANL) +C***DESCRIPTION +C +C Compute Tricomi's incomplete gamma function for small X. +C +C***REFERENCES (NONE) +C***ROUTINES CALLED D1MACH, DLNGAM, XERMSG +C***REVISION HISTORY (YYMMDD) +C 770701 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890911 Removed unnecessary intrinsics. (WRB) +C 890911 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C 900720 Routine changed from user-callable to subsidiary. (WRB) +C***END PROLOGUE D9GMIT + DOUBLE PRECISION A, X, ALGAP1, SGNGAM, ALX, AE, AEPS, ALGS, ALG2, + 1 BOT, EPS, FK, S, SGNG2, T, TE, D1MACH, DLNGAM + LOGICAL FIRST + SAVE EPS, BOT, FIRST + DATA FIRST /.TRUE./ +C***FIRST EXECUTABLE STATEMENT D9GMIT + IF (FIRST) THEN + EPS = 0.5D0*D1MACH(3) + BOT = LOG (D1MACH(1)) + ENDIF + FIRST = .FALSE. +C + IF (X .LE. 0.D0) CALL XERMSG ('SLATEC', 'D9GMIT', + + 'X SHOULD BE GT 0', 1, 2) +C + MA = A + 0.5D0 + IF (A.LT.0.D0) MA = A - 0.5D0 + AEPS = A - MA +C + AE = A + IF (A.LT.(-0.5D0)) AE = AEPS +C + T = 1.D0 + TE = AE + S = T + DO 20 K=1,200 + FK = K + TE = -X*TE/FK + T = TE/(AE+FK) + S = S + T + IF (ABS(T).LT.EPS*ABS(S)) GO TO 30 + 20 CONTINUE + CALL XERMSG ('SLATEC', 'D9GMIT', + + 'NO CONVERGENCE IN 200 TERMS OF TAYLOR-S SERIES', 2, 2) +C + 30 IF (A.GE.(-0.5D0)) ALGS = -ALGAP1 + LOG(S) + IF (A.GE.(-0.5D0)) GO TO 60 +C + ALGS = -DLNGAM(1.D0+AEPS) + LOG(S) + S = 1.0D0 + M = -MA - 1 + IF (M.EQ.0) GO TO 50 + T = 1.0D0 + DO 40 K=1,M + T = X*T/(AEPS-(M+1-K)) + S = S + T + IF (ABS(T).LT.EPS*ABS(S)) GO TO 50 + 40 CONTINUE +C + 50 D9GMIT = 0.0D0 + ALGS = -MA*LOG(X) + ALGS + IF (S.EQ.0.D0 .OR. AEPS.EQ.0.D0) GO TO 60 +C + SGNG2 = SGNGAM * SIGN (1.0D0, S) + ALG2 = -X - ALGAP1 + LOG(ABS(S)) +C + IF (ALG2.GT.BOT) D9GMIT = SGNG2 * EXP(ALG2) + IF (ALGS.GT.BOT) D9GMIT = D9GMIT + EXP(ALGS) + RETURN +C + 60 D9GMIT = EXP (ALGS) + RETURN +C + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/slatec-fn/d9lgic.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,54 @@ +*DECK D9LGIC + DOUBLE PRECISION FUNCTION D9LGIC (A, X, ALX) +C***BEGIN PROLOGUE D9LGIC +C***SUBSIDIARY +C***PURPOSE Compute the log complementary incomplete Gamma function +C for large X and for A .LE. X. +C***LIBRARY SLATEC (FNLIB) +C***CATEGORY C7E +C***TYPE DOUBLE PRECISION (R9LGIC-S, D9LGIC-D) +C***KEYWORDS COMPLEMENTARY INCOMPLETE GAMMA FUNCTION, FNLIB, LARGE X, +C LOGARITHM, SPECIAL FUNCTIONS +C***AUTHOR Fullerton, W., (LANL) +C***DESCRIPTION +C +C Compute the log complementary incomplete gamma function for large X +C and for A .LE. X. +C +C***REFERENCES (NONE) +C***ROUTINES CALLED D1MACH, XERMSG +C***REVISION HISTORY (YYMMDD) +C 770701 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890531 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C 900720 Routine changed from user-callable to subsidiary. (WRB) +C***END PROLOGUE D9LGIC + DOUBLE PRECISION A, X, ALX, EPS, FK, P, R, S, T, XMA, XPA, D1MACH + SAVE EPS + DATA EPS / 0.D0 / +C***FIRST EXECUTABLE STATEMENT D9LGIC + IF (EPS.EQ.0.D0) EPS = 0.5D0*D1MACH(3) +C + XPA = X + 1.0D0 - A + XMA = X - 1.D0 - A +C + R = 0.D0 + P = 1.D0 + S = P + DO 10 K=1,300 + FK = K + T = FK*(A-FK)*(1.D0+R) + R = -T/((XMA+2.D0*FK)*(XPA+2.D0*FK)+T) + P = R*P + S = S + P + IF (ABS(P).LT.EPS*S) GO TO 20 + 10 CONTINUE + CALL XERMSG ('SLATEC', 'D9LGIC', + + 'NO CONVERGENCE IN 300 TERMS OF CONTINUED FRACTION', 1, 2) +C + 20 D9LGIC = A*ALX - X + LOG(S/XPA) +C + RETURN + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/slatec-fn/d9lgit.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,67 @@ +*DECK D9LGIT + DOUBLE PRECISION FUNCTION D9LGIT (A, X, ALGAP1) +C***BEGIN PROLOGUE D9LGIT +C***SUBSIDIARY +C***PURPOSE Compute the logarithm of Tricomi's incomplete Gamma +C function with Perron's continued fraction for large X and +C A .GE. X. +C***LIBRARY SLATEC (FNLIB) +C***CATEGORY C7E +C***TYPE DOUBLE PRECISION (R9LGIT-S, D9LGIT-D) +C***KEYWORDS FNLIB, INCOMPLETE GAMMA FUNCTION, LOGARITHM, +C PERRON'S CONTINUED FRACTION, SPECIAL FUNCTIONS, TRICOMI +C***AUTHOR Fullerton, W., (LANL) +C***DESCRIPTION +C +C Compute the log of Tricomi's incomplete gamma function with Perron's +C continued fraction for large X and for A .GE. X. +C +C***REFERENCES (NONE) +C***ROUTINES CALLED D1MACH, XERMSG +C***REVISION HISTORY (YYMMDD) +C 770701 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890531 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C 900720 Routine changed from user-callable to subsidiary. (WRB) +C***END PROLOGUE D9LGIT + DOUBLE PRECISION A, X, ALGAP1, AX, A1X, EPS, FK, HSTAR, P, R, S, + 1 SQEPS, T, D1MACH + LOGICAL FIRST + SAVE EPS, SQEPS, FIRST + DATA FIRST /.TRUE./ +C***FIRST EXECUTABLE STATEMENT D9LGIT + IF (FIRST) THEN + EPS = 0.5D0*D1MACH(3) + SQEPS = SQRT(D1MACH(4)) + ENDIF + FIRST = .FALSE. +C + IF (X .LE. 0.D0 .OR. A .LT. X) CALL XERMSG ('SLATEC', 'D9LGIT', + + 'X SHOULD BE GT 0.0 AND LE A', 2, 2) +C + AX = A + X + A1X = AX + 1.0D0 + R = 0.D0 + P = 1.D0 + S = P + DO 20 K=1,200 + FK = K + T = (A+FK)*X*(1.D0+R) + R = T/((AX+FK)*(A1X+FK)-T) + P = R*P + S = S + P + IF (ABS(P).LT.EPS*S) GO TO 30 + 20 CONTINUE + CALL XERMSG ('SLATEC', 'D9LGIT', + + 'NO CONVERGENCE IN 200 TERMS OF CONTINUED FRACTION', 3, 2) +C + 30 HSTAR = 1.0D0 - X*S/A1X + IF (HSTAR .LT. SQEPS) CALL XERMSG ('SLATEC', 'D9LGIT', + + 'RESULT LESS THAN HALF PRECISION', 1, 1) +C + D9LGIT = -X - ALGAP1 - LOG(HSTAR) + RETURN +C + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/slatec-fn/d9lgmc.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,76 @@ +*DECK D9LGMC + DOUBLE PRECISION FUNCTION D9LGMC (X) +C***BEGIN PROLOGUE D9LGMC +C***SUBSIDIARY +C***PURPOSE Compute the log Gamma correction factor so that +C LOG(DGAMMA(X)) = LOG(SQRT(2*PI)) + (X-5.)*LOG(X) - X +C + D9LGMC(X). +C***LIBRARY SLATEC (FNLIB) +C***CATEGORY C7E +C***TYPE DOUBLE PRECISION (R9LGMC-S, D9LGMC-D, C9LGMC-C) +C***KEYWORDS COMPLETE GAMMA FUNCTION, CORRECTION TERM, FNLIB, +C LOG GAMMA, LOGARITHM, SPECIAL FUNCTIONS +C***AUTHOR Fullerton, W., (LANL) +C***DESCRIPTION +C +C Compute the log gamma correction factor for X .GE. 10. so that +C LOG (DGAMMA(X)) = LOG(SQRT(2*PI)) + (X-.5)*LOG(X) - X + D9lGMC(X) +C +C Series for ALGM on the interval 0. to 1.00000E-02 +C with weighted error 1.28E-31 +C log weighted error 30.89 +C significant figures required 29.81 +C decimal places required 31.48 +C +C***REFERENCES (NONE) +C***ROUTINES CALLED D1MACH, DCSEVL, INITDS, XERMSG +C***REVISION HISTORY (YYMMDD) +C 770601 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890531 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C 900720 Routine changed from user-callable to subsidiary. (WRB) +C***END PROLOGUE D9LGMC + DOUBLE PRECISION X, ALGMCS(15), XBIG, XMAX, DCSEVL, D1MACH + LOGICAL FIRST + SAVE ALGMCS, NALGM, XBIG, XMAX, FIRST + DATA ALGMCS( 1) / +.1666389480 4518632472 0572965082 2 D+0 / + DATA ALGMCS( 2) / -.1384948176 0675638407 3298605913 5 D-4 / + DATA ALGMCS( 3) / +.9810825646 9247294261 5717154748 7 D-8 / + DATA ALGMCS( 4) / -.1809129475 5724941942 6330626671 9 D-10 / + DATA ALGMCS( 5) / +.6221098041 8926052271 2601554341 6 D-13 / + DATA ALGMCS( 6) / -.3399615005 4177219443 0333059966 6 D-15 / + DATA ALGMCS( 7) / +.2683181998 4826987489 5753884666 6 D-17 / + DATA ALGMCS( 8) / -.2868042435 3346432841 4462239999 9 D-19 / + DATA ALGMCS( 9) / +.3962837061 0464348036 7930666666 6 D-21 / + DATA ALGMCS( 10) / -.6831888753 9857668701 1199999999 9 D-23 / + DATA ALGMCS( 11) / +.1429227355 9424981475 7333333333 3 D-24 / + DATA ALGMCS( 12) / -.3547598158 1010705471 9999999999 9 D-26 / + DATA ALGMCS( 13) / +.1025680058 0104709120 0000000000 0 D-27 / + DATA ALGMCS( 14) / -.3401102254 3167487999 9999999999 9 D-29 / + DATA ALGMCS( 15) / +.1276642195 6300629333 3333333333 3 D-30 / + DATA FIRST /.TRUE./ +C***FIRST EXECUTABLE STATEMENT D9LGMC + IF (FIRST) THEN + NALGM = INITDS (ALGMCS, 15, REAL(D1MACH(3)) ) + XBIG = 1.0D0/SQRT(D1MACH(3)) + XMAX = EXP (MIN(LOG(D1MACH(2)/12.D0), -LOG(12.D0*D1MACH(1)))) + ENDIF + FIRST = .FALSE. +C + IF (X .LT. 10.D0) CALL XERMSG ('SLATEC', 'D9LGMC', + + 'X MUST BE GE 10', 1, 2) + IF (X.GE.XMAX) GO TO 20 +C + D9LGMC = 1.D0/(12.D0*X) + IF (X.LT.XBIG) D9LGMC = DCSEVL (2.0D0*(10.D0/X)**2-1.D0, ALGMCS, + 1 NALGM) / X + RETURN +C + 20 D9LGMC = 0.D0 + CALL XERMSG ('SLATEC', 'D9LGMC', 'X SO BIG D9LGMC UNDERFLOWS', 2, + + 1) + RETURN +C + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/slatec-fn/dacosh.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,40 @@ +*DECK DACOSH + DOUBLE PRECISION FUNCTION DACOSH (X) +C***BEGIN PROLOGUE DACOSH +C***PURPOSE Compute the arc hyperbolic cosine. +C***LIBRARY SLATEC (FNLIB) +C***CATEGORY C4C +C***TYPE DOUBLE PRECISION (ACOSH-S, DACOSH-D, CACOSH-C) +C***KEYWORDS ACOSH, ARC HYPERBOLIC COSINE, ELEMENTARY FUNCTIONS, FNLIB, +C INVERSE HYPERBOLIC COSINE +C***AUTHOR Fullerton, W., (LANL) +C***DESCRIPTION +C +C DACOSH(X) calculates the double precision arc hyperbolic cosine for +C double precision argument X. The result is returned on the +C positive branch. +C +C***REFERENCES (NONE) +C***ROUTINES CALLED D1MACH, XERMSG +C***REVISION HISTORY (YYMMDD) +C 770601 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890531 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C***END PROLOGUE DACOSH + DOUBLE PRECISION X, DLN2, XMAX, D1MACH + SAVE DLN2, XMAX + DATA DLN2 / 0.6931471805 5994530941 7232121458 18 D0 / + DATA XMAX / 0.D0 / +C***FIRST EXECUTABLE STATEMENT DACOSH + IF (XMAX.EQ.0.D0) XMAX = 1.0D0/SQRT(D1MACH(3)) +C + IF (X .LT. 1.D0) CALL XERMSG ('SLATEC', 'DACOSH', + + 'X LESS THAN 1', 1, 2) +C + IF (X.LT.XMAX) DACOSH = LOG (X+SQRT(X*X-1.0D0)) + IF (X.GE.XMAX) DACOSH = DLN2 + LOG(X) +C + RETURN + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/slatec-fn/dasinh.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,89 @@ +*DECK DASINH + DOUBLE PRECISION FUNCTION DASINH (X) +C***BEGIN PROLOGUE DASINH +C***PURPOSE Compute the arc hyperbolic sine. +C***LIBRARY SLATEC (FNLIB) +C***CATEGORY C4C +C***TYPE DOUBLE PRECISION (ASINH-S, DASINH-D, CASINH-C) +C***KEYWORDS ARC HYPERBOLIC SINE, ASINH, ELEMENTARY FUNCTIONS, FNLIB, +C INVERSE HYPERBOLIC SINE +C***AUTHOR Fullerton, W., (LANL) +C***DESCRIPTION +C +C DASINH(X) calculates the double precision arc hyperbolic +C sine for double precision argument X. +C +C***REFERENCES (NONE) +C***ROUTINES CALLED D1MACH, DCSEVL, INITDS +C***REVISION HISTORY (YYMMDD) +C 770601 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890531 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C***END PROLOGUE DASINH + DOUBLE PRECISION X, ASNHCS(39), ALN2, SQEPS, XMAX, Y, + 1 DCSEVL, D1MACH + LOGICAL FIRST + SAVE ASNHCS, ALN2, NTERMS, XMAX, SQEPS, FIRST + DATA ASNHCS( 1) / -.1282003991 1738186343 3721273592 68 D+0 / + DATA ASNHCS( 2) / -.5881176118 9951767565 2117571383 62 D-1 / + DATA ASNHCS( 3) / +.4727465432 2124815640 7252497560 29 D-2 / + DATA ASNHCS( 4) / -.4938363162 6536172101 3601747902 73 D-3 / + DATA ASNHCS( 5) / +.5850620705 8557412287 4948352593 21 D-4 / + DATA ASNHCS( 6) / -.7466998328 9313681354 7550692171 88 D-5 / + DATA ASNHCS( 7) / +.1001169358 3558199265 9661920158 12 D-5 / + DATA ASNHCS( 8) / -.1390354385 8708333608 6164722588 86 D-6 / + DATA ASNHCS( 9) / +.1982316948 3172793547 3173602371 48 D-7 / + DATA ASNHCS( 10) / -.2884746841 7848843612 7472728003 17 D-8 / + DATA ASNHCS( 11) / +.4267296546 7159937953 4575149959 07 D-9 / + DATA ASNHCS( 12) / -.6397608465 4366357868 7526323096 81 D-10 / + DATA ASNHCS( 13) / +.9699168608 9064704147 8782931311 79 D-11 / + DATA ASNHCS( 14) / -.1484427697 2043770830 2466583656 96 D-11 / + DATA ASNHCS( 15) / +.2290373793 9027447988 0401843789 83 D-12 / + DATA ASNHCS( 16) / -.3558839513 2732645159 9789426513 10 D-13 / + DATA ASNHCS( 17) / +.5563969408 0056789953 3745390885 54 D-14 / + DATA ASNHCS( 18) / -.8746250959 9624678045 6665935201 62 D-15 / + DATA ASNHCS( 19) / +.1381524884 4526692155 8688022981 29 D-15 / + DATA ASNHCS( 20) / -.2191668828 2900363984 9551422641 49 D-16 / + DATA ASNHCS( 21) / +.3490465852 4827565638 3139237068 80 D-17 / + DATA ASNHCS( 22) / -.5578578840 0895742439 6301570321 06 D-18 / + DATA ASNHCS( 23) / +.8944514661 7134012551 0508827989 33 D-19 / + DATA ASNHCS( 24) / -.1438342634 6571317305 5518452394 66 D-19 / + DATA ASNHCS( 25) / +.2319181187 2169963036 3261446826 66 D-20 / + DATA ASNHCS( 26) / -.3748700795 3314343674 5706045439 99 D-21 / + DATA ASNHCS( 27) / +.6073210982 2064279404 5492428800 00 D-22 / + DATA ASNHCS( 28) / -.9859940276 4633583177 3701734400 00 D-23 / + DATA ASNHCS( 29) / +.1603921745 2788496315 2326382933 33 D-23 / + DATA ASNHCS( 30) / -.2613884735 0287686596 7161343999 99 D-24 / + DATA ASNHCS( 31) / +.4267084960 6857390833 3581653333 33 D-25 / + DATA ASNHCS( 32) / -.6977021703 9185243299 7307733333 33 D-26 / + DATA ASNHCS( 33) / +.1142508833 6806858659 8126933333 33 D-26 / + DATA ASNHCS( 34) / -.1873529207 8860968933 0210133333 33 D-27 / + DATA ASNHCS( 35) / +.3076358441 4464922794 0659200000 00 D-28 / + DATA ASNHCS( 36) / -.5057736403 1639824787 0463999999 99 D-29 / + DATA ASNHCS( 37) / +.8325075471 2689142224 2133333333 33 D-30 / + DATA ASNHCS( 38) / -.1371845728 2501044163 9253333333 33 D-30 / + DATA ASNHCS( 39) / +.2262986842 6552784104 1066666666 66 D-31 / + DATA ALN2 / 0.6931471805 5994530941 7232121458 18D0 / + DATA FIRST /.TRUE./ +C***FIRST EXECUTABLE STATEMENT DASINH + IF (FIRST) THEN + NTERMS = INITDS (ASNHCS, 39, 0.1*REAL(D1MACH(3)) ) + SQEPS = SQRT(D1MACH(3)) + XMAX = 1.0D0/SQEPS + ENDIF + FIRST = .FALSE. +C + Y = ABS(X) + IF (Y.GT.1.0D0) GO TO 20 +C + DASINH = X + IF (Y.GT.SQEPS) DASINH = X*(1.0D0 + DCSEVL (2.D0*X*X-1.D0, + 1 ASNHCS, NTERMS) ) + RETURN + 20 IF (Y.LT.XMAX) DASINH = LOG (Y+SQRT(Y*Y+1.D0)) + IF (Y.GE.XMAX) DASINH = ALN2 + LOG(Y) + DASINH = SIGN (DASINH, X) + RETURN +C + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/slatec-fn/datanh.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,89 @@ +*DECK DATANH + DOUBLE PRECISION FUNCTION DATANH (X) +C***BEGIN PROLOGUE DATANH +C***PURPOSE Compute the arc hyperbolic tangent. +C***LIBRARY SLATEC (FNLIB) +C***CATEGORY C4C +C***TYPE DOUBLE PRECISION (ATANH-S, DATANH-D, CATANH-C) +C***KEYWORDS ARC HYPERBOLIC TANGENT, ATANH, ELEMENTARY FUNCTIONS, +C FNLIB, INVERSE HYPERBOLIC TANGENT +C***AUTHOR Fullerton, W., (LANL) +C***DESCRIPTION +C +C DATANH(X) calculates the double precision arc hyperbolic +C tangent for double precision argument X. +C +C Series for ATNH on the interval 0. to 2.50000E-01 +C with weighted error 6.86E-32 +C log weighted error 31.16 +C significant figures required 30.00 +C decimal places required 31.88 +C +C***REFERENCES (NONE) +C***ROUTINES CALLED D1MACH, DCSEVL, INITDS, XERMSG +C***REVISION HISTORY (YYMMDD) +C 770601 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890531 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C***END PROLOGUE DATANH + DOUBLE PRECISION X, ATNHCS(27), DXREL, SQEPS, Y, DCSEVL, D1MACH + LOGICAL FIRST + SAVE ATNHCS, NTERMS, DXREL, SQEPS, FIRST + DATA ATNHCS( 1) / +.9439510239 3195492308 4289221863 3 D-1 / + DATA ATNHCS( 2) / +.4919843705 5786159472 0003457666 8 D-1 / + DATA ATNHCS( 3) / +.2102593522 4554327634 7932733175 2 D-2 / + DATA ATNHCS( 4) / +.1073554449 7761165846 4073104527 6 D-3 / + DATA ATNHCS( 5) / +.5978267249 2930314786 4278751787 2 D-5 / + DATA ATNHCS( 6) / +.3505062030 8891348459 6683488620 0 D-6 / + DATA ATNHCS( 7) / +.2126374343 7653403508 9621931443 1 D-7 / + DATA ATNHCS( 8) / +.1321694535 7155271921 2980172305 5 D-8 / + DATA ATNHCS( 9) / +.8365875501 1780703646 2360405295 9 D-10 / + DATA ATNHCS( 10) / +.5370503749 3110021638 8143458777 2 D-11 / + DATA ATNHCS( 11) / +.3486659470 1571079229 7124578429 0 D-12 / + DATA ATNHCS( 12) / +.2284549509 6034330155 2402411972 2 D-13 / + DATA ATNHCS( 13) / +.1508407105 9447930448 7422906755 8 D-14 / + DATA ATNHCS( 14) / +.1002418816 8041091261 3699572283 7 D-15 / + DATA ATNHCS( 15) / +.6698674738 1650695397 1552688298 6 D-17 / + DATA ATNHCS( 16) / +.4497954546 4949310830 8332762453 3 D-18 / + DATA ATNHCS( 17) / +.3032954474 2794535416 8236714666 6 D-19 / + DATA ATNHCS( 18) / +.2052702064 1909368264 6386141866 6 D-20 / + DATA ATNHCS( 19) / +.1393848977 0538377131 9301461333 3 D-21 / + DATA ATNHCS( 20) / +.9492580637 2245769719 5895466666 6 D-23 / + DATA ATNHCS( 21) / +.6481915448 2423076049 8244266666 6 D-24 / + DATA ATNHCS( 22) / +.4436730205 7236152726 3232000000 0 D-25 / + DATA ATNHCS( 23) / +.3043465618 5431616389 1200000000 0 D-26 / + DATA ATNHCS( 24) / +.2091881298 7923934740 4799999999 9 D-27 / + DATA ATNHCS( 25) / +.1440445411 2340505613 6533333333 3 D-28 / + DATA ATNHCS( 26) / +.9935374683 1416404650 6666666666 6 D-30 / + DATA ATNHCS( 27) / +.6863462444 3582600533 3333333333 3 D-31 / + DATA FIRST /.TRUE./ +C***FIRST EXECUTABLE STATEMENT DATANH + IF (FIRST) THEN + NTERMS = INITDS (ATNHCS, 27, 0.1*REAL(D1MACH(3)) ) + DXREL = SQRT(D1MACH(4)) + SQEPS = SQRT(3.0D0*D1MACH(3)) + ENDIF + FIRST = .FALSE. +C + Y = ABS(X) + IF (Y .GE. 1.D0) THEN + IF (Y .GT. 1.D0) THEN + DATANH = (X - X) / (X - X) + ELSE + DATANH = X / 0.D0 + ENDIF + RETURN + ENDIF +C + IF (1.D0-Y .LT. DXREL) CALL XERMSG ('SLATEC', 'DATANH', + + 'ANSWER LT HALF PRECISION BECAUSE ABS(X) TOO NEAR 1', 1, 1) +C + DATANH = X + IF (Y.GT.SQEPS .AND. Y.LE.0.5D0) DATANH = X*(1.0D0 + + 1 DCSEVL (8.D0*X*X-1.D0, ATNHCS, NTERMS) ) + IF (Y.GT.0.5D0) DATANH = 0.5D0*LOG ((1.0D0+X)/(1.0D0-X)) +C + RETURN + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/slatec-fn/dbetai.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,121 @@ + +*DECK DBETAI + DOUBLE PRECISION FUNCTION DBETAI (X, PIN, QIN) +C***BEGIN PROLOGUE DBETAI +C***PURPOSE Calculate the incomplete Beta function. +C***LIBRARY SLATEC (FNLIB) +C***CATEGORY C7F +C***TYPE DOUBLE PRECISION (BETAI-S, DBETAI-D) +C***KEYWORDS FNLIB, INCOMPLETE BETA FUNCTION, SPECIAL FUNCTIONS +C***AUTHOR Fullerton, W., (LANL) +C***DESCRIPTION +C +C DBETAI calculates the DOUBLE PRECISION incomplete beta function. +C +C The incomplete beta function ratio is the probability that a +C random variable from a beta distribution having parameters PIN and +C QIN will be less than or equal to X. +C +C -- Input Arguments -- All arguments are DOUBLE PRECISION. +C X upper limit of integration. X must be in (0,1) inclusive. +C PIN first beta distribution parameter. PIN must be .GT. 0.0. +C QIN second beta distribution parameter. QIN must be .GT. 0.0. +C +C***REFERENCES Nancy E. Bosten and E. L. Battiste, Remark on Algorithm +C 179, Communications of the ACM 17, 3 (March 1974), +C pp. 156. +C***ROUTINES CALLED D1MACH, DLBETA, XERMSG +C***REVISION HISTORY (YYMMDD) +C 770701 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890911 Removed unnecessary intrinsics. (WRB) +C 890911 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C 920528 DESCRIPTION and REFERENCES sections revised. (WRB) +C***END PROLOGUE DBETAI + DOUBLE PRECISION X, PIN, QIN, ALNEPS, ALNSML, C, EPS, FINSUM, P, + 1 PS, Q, SML, TERM, XB, XI, Y, D1MACH, DLBETA, P1 + LOGICAL FIRST + SAVE EPS, ALNEPS, SML, ALNSML, FIRST + DATA FIRST /.TRUE./ +C***FIRST EXECUTABLE STATEMENT DBETAI + IF (FIRST) THEN + EPS = D1MACH(3) + ALNEPS = LOG (EPS) + SML = D1MACH(1) + ALNSML = LOG (SML) + ENDIF + FIRST = .FALSE. +C + IF (X .LT. 0.D0 .OR. X .GT. 1.D0) CALL XERMSG ('SLATEC', 'DBETAI', + + 'X IS NOT IN THE RANGE (0,1)', 1, 2) + IF (PIN .LE. 0.D0 .OR. QIN .LE. 0.D0) CALL XERMSG ('SLATEC', + + 'DBETAI', 'P AND/OR Q IS LE ZERO', 2, 2) +C + Y = X + P = PIN + Q = QIN + IF (Q.LE.P .AND. X.LT.0.8D0) GO TO 20 + IF (X.LT.0.2D0) GO TO 20 + Y = 1.0D0 - Y + P = QIN + Q = PIN +C + 20 IF ((P+Q)*Y/(P+1.D0).LT.EPS) GO TO 80 +C +C EVALUATE THE INFINITE SUM FIRST. TERM WILL EQUAL +C Y**P/BETA(PS,P) * (1.-PS)-SUB-I * Y**I / FAC(I) . +C + PS = Q - AINT(Q) + IF (PS.EQ.0.D0) PS = 1.0D0 + XB = P*LOG(Y) - DLBETA(PS,P) - LOG(P) + DBETAI = 0.0D0 + IF (XB.LT.ALNSML) GO TO 40 +C + DBETAI = EXP (XB) + TERM = DBETAI*P + IF (PS.EQ.1.0D0) GO TO 40 + N = MAX (ALNEPS/LOG(Y), 4.0D0) + DO 30 I=1,N + XI = I + TERM = TERM * (XI-PS)*Y/XI + DBETAI = DBETAI + TERM/(P+XI) + 30 CONTINUE +C +C NOW EVALUATE THE FINITE SUM, MAYBE. +C + 40 IF (Q.LE.1.0D0) GO TO 70 +C + XB = P*LOG(Y) + Q*LOG(1.0D0-Y) - DLBETA(P,Q) - LOG(Q) + IB = MAX (XB/ALNSML, 0.0D0) + TERM = EXP(XB - IB*ALNSML) + C = 1.0D0/(1.D0-Y) + P1 = Q*C/(P+Q-1.D0) +C + FINSUM = 0.0D0 + N = Q + IF (Q.EQ.DBLE(N)) N = N - 1 + DO 50 I=1,N + IF (P1.LE.1.0D0 .AND. TERM/EPS.LE.FINSUM) GO TO 60 + XI = I + TERM = (Q-XI+1.0D0)*C*TERM/(P+Q-XI) +C + IF (TERM.GT.1.0D0) IB = IB - 1 + IF (TERM.GT.1.0D0) TERM = TERM*SML +C + IF (IB.EQ.0) FINSUM = FINSUM + TERM + 50 CONTINUE +C + 60 DBETAI = DBETAI + FINSUM + 70 IF (Y.NE.X .OR. P.NE.PIN) DBETAI = 1.0D0 - DBETAI + DBETAI = MAX (MIN (DBETAI, 1.0D0), 0.0D0) + RETURN +C + 80 DBETAI = 0.0D0 + XB = P*LOG(MAX(Y,SML)) - LOG(P) - DLBETA(P,Q) + IF (XB.GT.ALNSML .AND. Y.NE.0.0D0) DBETAI = EXP(XB) + IF (Y.NE.X .OR. P.NE.PIN) DBETAI = 1.0D0 - DBETAI +C + RETURN + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/slatec-fn/dcsevl.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,65 @@ +*DECK DCSEVL + DOUBLE PRECISION FUNCTION DCSEVL (X, CS, N) +C***BEGIN PROLOGUE DCSEVL +C***PURPOSE Evaluate a Chebyshev series. +C***LIBRARY SLATEC (FNLIB) +C***CATEGORY C3A2 +C***TYPE DOUBLE PRECISION (CSEVL-S, DCSEVL-D) +C***KEYWORDS CHEBYSHEV SERIES, FNLIB, SPECIAL FUNCTIONS +C***AUTHOR Fullerton, W., (LANL) +C***DESCRIPTION +C +C Evaluate the N-term Chebyshev series CS at X. Adapted from +C a method presented in the paper by Broucke referenced below. +C +C Input Arguments -- +C X value at which the series is to be evaluated. +C CS array of N terms of a Chebyshev series. In evaluating +C CS, only half the first coefficient is summed. +C N number of terms in array CS. +C +C***REFERENCES R. Broucke, Ten subroutines for the manipulation of +C Chebyshev series, Algorithm 446, Communications of +C the A.C.M. 16, (1973) pp. 254-256. +C L. Fox and I. B. Parker, Chebyshev Polynomials in +C Numerical Analysis, Oxford University Press, 1968, +C page 56. +C***ROUTINES CALLED D1MACH, XERMSG +C***REVISION HISTORY (YYMMDD) +C 770401 DATE WRITTEN +C 890831 Modified array declarations. (WRB) +C 890831 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C 900329 Prologued revised extensively and code rewritten to allow +C X to be slightly outside interval (-1,+1). (WRB) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE DCSEVL + DOUBLE PRECISION B0, B1, B2, CS(*), ONEPL, TWOX, X, D1MACH + LOGICAL FIRST + SAVE FIRST, ONEPL + DATA FIRST /.TRUE./ +C***FIRST EXECUTABLE STATEMENT DCSEVL + IF (FIRST) ONEPL = 1.0D0 + D1MACH(4) + FIRST = .FALSE. + IF (N .LT. 1) CALL XERMSG ('SLATEC', 'DCSEVL', + + 'NUMBER OF TERMS .LE. 0', 2, 2) + IF (N .GT. 1000) CALL XERMSG ('SLATEC', 'DCSEVL', + + 'NUMBER OF TERMS .GT. 1000', 3, 2) + IF (ABS(X) .GT. ONEPL) CALL XERMSG ('SLATEC', 'DCSEVL', + + 'X OUTSIDE THE INTERVAL (-1,+1)', 1, 1) +C + B1 = 0.0D0 + B0 = 0.0D0 + TWOX = 2.0D0*X + DO 10 I = 1,N + B2 = B1 + B1 = B0 + NI = N + 1 - I + B0 = TWOX*B1 - B2 + CS(NI) + 10 CONTINUE +C + DCSEVL = 0.5D0*(B0-B2) +C + RETURN + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/slatec-fn/derf.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,83 @@ +*DECK DERF + DOUBLE PRECISION FUNCTION DERF (X) +C***BEGIN PROLOGUE DERF +C***PURPOSE Compute the error function. +C***LIBRARY SLATEC (FNLIB) +C***CATEGORY C8A, L5A1E +C***TYPE DOUBLE PRECISION (ERF-S, DERF-D) +C***KEYWORDS ERF, ERROR FUNCTION, FNLIB, SPECIAL FUNCTIONS +C***AUTHOR Fullerton, W., (LANL) +C***DESCRIPTION +C +C DERF(X) calculates the double precision error function for double +C precision argument X. +C +C Series for ERF on the interval 0. to 1.00000E+00 +C with weighted error 1.28E-32 +C log weighted error 31.89 +C significant figures required 31.05 +C decimal places required 32.55 +C +C***REFERENCES (NONE) +C***ROUTINES CALLED D1MACH, DCSEVL, DERFC, INITDS +C***REVISION HISTORY (YYMMDD) +C 770701 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890531 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900727 Added EXTERNAL statement. (WRB) +C 920618 Removed space from variable name. (RWC, WRB) +C***END PROLOGUE DERF + DOUBLE PRECISION X, ERFCS(21), SQEPS, SQRTPI, XBIG, Y, D1MACH, + 1 DCSEVL, DERFC + LOGICAL FIRST + EXTERNAL DERFC + SAVE ERFCS, SQRTPI, NTERF, XBIG, SQEPS, FIRST + DATA ERFCS( 1) / -.4904612123 4691808039 9845440333 76 D-1 / + DATA ERFCS( 2) / -.1422612051 0371364237 8247418996 31 D+0 / + DATA ERFCS( 3) / +.1003558218 7599795575 7546767129 33 D-1 / + DATA ERFCS( 4) / -.5768764699 7674847650 8270255091 67 D-3 / + DATA ERFCS( 5) / +.2741993125 2196061034 4221607914 71 D-4 / + DATA ERFCS( 6) / -.1104317550 7344507604 1353812959 05 D-5 / + DATA ERFCS( 7) / +.3848875542 0345036949 9613114981 74 D-7 / + DATA ERFCS( 8) / -.1180858253 3875466969 6317518015 81 D-8 / + DATA ERFCS( 9) / +.3233421582 6050909646 4029309533 54 D-10 / + DATA ERFCS( 10) / -.7991015947 0045487581 6073747085 95 D-12 / + DATA ERFCS( 11) / +.1799072511 3961455611 9672454866 34 D-13 / + DATA ERFCS( 12) / -.3718635487 8186926382 3168282094 93 D-15 / + DATA ERFCS( 13) / +.7103599003 7142529711 6899083946 66 D-17 / + DATA ERFCS( 14) / -.1261245511 9155225832 4954248533 33 D-18 / + DATA ERFCS( 15) / +.2091640694 1769294369 1705002666 66 D-20 / + DATA ERFCS( 16) / -.3253973102 9314072982 3641600000 00 D-22 / + DATA ERFCS( 17) / +.4766867209 7976748332 3733333333 33 D-24 / + DATA ERFCS( 18) / -.6598012078 2851343155 1999999999 99 D-26 / + DATA ERFCS( 19) / +.8655011469 9637626197 3333333333 33 D-28 / + DATA ERFCS( 20) / -.1078892517 7498064213 3333333333 33 D-29 / + DATA ERFCS( 21) / +.1281188399 3017002666 6666666666 66 D-31 / + DATA SQRTPI / 1.772453850 9055160272 9816748334 115D0 / + DATA FIRST /.TRUE./ +C***FIRST EXECUTABLE STATEMENT DERF + IF (FIRST) THEN + NTERF = INITDS (ERFCS, 21, 0.1*REAL(D1MACH(3))) + XBIG = SQRT(-LOG(SQRTPI*D1MACH(3))) + SQEPS = SQRT(2.0D0*D1MACH(3)) + ENDIF + FIRST = .FALSE. +C + Y = ABS(X) + IF (Y.GT.1.D0) GO TO 20 +C +C ERF(X) = 1.0 - ERFC(X) FOR -1.0 .LE. X .LE. 1.0 +C + IF (Y.LE.SQEPS) DERF = 2.0D0*X/SQRTPI + IF (Y.GT.SQEPS) DERF = X*(1.0D0 + DCSEVL (2.D0*X*X-1.D0, + 1 ERFCS, NTERF)) + RETURN +C +C ERF(X) = 1.0 - ERFC(X) FOR ABS(X) .GT. 1.0 +C + 20 IF (Y.LE.XBIG) DERF = SIGN (1.0D0-DERFC(Y), X) + IF (Y.GT.XBIG) DERF = SIGN (1.0D0, X) +C + RETURN + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/slatec-fn/derfc.in.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,230 @@ +*DECK DERFC + DOUBLE PRECISION FUNCTION DERFC (X) +C***BEGIN PROLOGUE DERFC +C***PURPOSE Compute the complementary error function. +C***LIBRARY SLATEC (FNLIB) +C***CATEGORY C8A, L5A1E +C***TYPE DOUBLE PRECISION (ERFC-S, DERFC-D) +C***KEYWORDS COMPLEMENTARY ERROR FUNCTION, ERFC, FNLIB, +C SPECIAL FUNCTIONS +C***AUTHOR Fullerton, W., (LANL) +C***DESCRIPTION +C +C DERFC(X) calculates the double precision complementary error function +C for double precision argument X. +C +C Series for ERF on the interval 0. to 1.00000E+00 +C with weighted Error 1.28E-32 +C log weighted Error 31.89 +C significant figures required 31.05 +C decimal places required 32.55 +C +C Series for ERC2 on the interval 2.50000E-01 to 1.00000E+00 +C with weighted Error 2.67E-32 +C log weighted Error 31.57 +C significant figures required 30.31 +C decimal places required 32.42 +C +C Series for ERFC on the interval 0. to 2.50000E-01 +C with weighted error 1.53E-31 +C log weighted error 30.82 +C significant figures required 29.47 +C decimal places required 31.70 +C +C***REFERENCES (NONE) +C***ROUTINES CALLED D1MACH, DCSEVL, INITDS, XERMSG +C***REVISION HISTORY (YYMMDD) +C 770701 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890531 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C 920618 Removed space from variable names. (RWC, WRB) +C***END PROLOGUE DERFC + DOUBLE PRECISION X, ERFCS(21), ERFCCS(59), ERC2CS(49), SQEPS, + 1 SQRTPI, XMAX, TXMAX, XSML, Y, D1MACH, DCSEVL + LOGICAL FIRST + SAVE ERFCS, ERC2CS, ERFCCS, SQRTPI, NTERF, + 1 NTERFC, NTERC2, XSML, XMAX, SQEPS, FIRST + DATA ERFCS( 1) / -.4904612123 4691808039 9845440333 76 D-1 / + DATA ERFCS( 2) / -.1422612051 0371364237 8247418996 31 D+0 / + DATA ERFCS( 3) / +.1003558218 7599795575 7546767129 33 D-1 / + DATA ERFCS( 4) / -.5768764699 7674847650 8270255091 67 D-3 / + DATA ERFCS( 5) / +.2741993125 2196061034 4221607914 71 D-4 / + DATA ERFCS( 6) / -.1104317550 7344507604 1353812959 05 D-5 / + DATA ERFCS( 7) / +.3848875542 0345036949 9613114981 74 D-7 / + DATA ERFCS( 8) / -.1180858253 3875466969 6317518015 81 D-8 / + DATA ERFCS( 9) / +.3233421582 6050909646 4029309533 54 D-10 / + DATA ERFCS( 10) / -.7991015947 0045487581 6073747085 95 D-12 / + DATA ERFCS( 11) / +.1799072511 3961455611 9672454866 34 D-13 / + DATA ERFCS( 12) / -.3718635487 8186926382 3168282094 93 D-15 / + DATA ERFCS( 13) / +.7103599003 7142529711 6899083946 66 D-17 / + DATA ERFCS( 14) / -.1261245511 9155225832 4954248533 33 D-18 / + DATA ERFCS( 15) / +.2091640694 1769294369 1705002666 66 D-20 / + DATA ERFCS( 16) / -.3253973102 9314072982 3641600000 00 D-22 / + DATA ERFCS( 17) / +.4766867209 7976748332 3733333333 33 D-24 / + DATA ERFCS( 18) / -.6598012078 2851343155 1999999999 99 D-26 / + DATA ERFCS( 19) / +.8655011469 9637626197 3333333333 33 D-28 / + DATA ERFCS( 20) / -.1078892517 7498064213 3333333333 33 D-29 / + DATA ERFCS( 21) / +.1281188399 3017002666 6666666666 66 D-31 / + DATA ERC2CS( 1) / -.6960134660 2309501127 3915082619 7 D-1 / + DATA ERC2CS( 2) / -.4110133936 2620893489 8221208466 6 D-1 / + DATA ERC2CS( 3) / +.3914495866 6896268815 6114370524 4 D-2 / + DATA ERC2CS( 4) / -.4906395650 5489791612 8093545077 4 D-3 / + DATA ERC2CS( 5) / +.7157479001 3770363807 6089414182 5 D-4 / + DATA ERC2CS( 6) / -.1153071634 1312328338 0823284791 2 D-4 / + DATA ERC2CS( 7) / +.1994670590 2019976350 5231486770 9 D-5 / + DATA ERC2CS( 8) / -.3642666471 5992228739 3611843071 1 D-6 / + DATA ERC2CS( 9) / +.6944372610 0050125899 3127721463 3 D-7 / + DATA ERC2CS( 10) / -.1371220902 1043660195 3460514121 0 D-7 / + DATA ERC2CS( 11) / +.2788389661 0071371319 6386034808 7 D-8 / + DATA ERC2CS( 12) / -.5814164724 3311615518 6479105031 6 D-9 / + DATA ERC2CS( 13) / +.1238920491 7527531811 8016881795 0 D-9 / + DATA ERC2CS( 14) / -.2690639145 3067434323 9042493788 9 D-10 / + DATA ERC2CS( 15) / +.5942614350 8479109824 4470968384 0 D-11 / + DATA ERC2CS( 16) / -.1332386735 7581195792 8775442057 0 D-11 / + DATA ERC2CS( 17) / +.3028046806 1771320171 7369724330 4 D-12 / + DATA ERC2CS( 18) / -.6966648814 9410325887 9586758895 4 D-13 / + DATA ERC2CS( 19) / +.1620854541 0539229698 1289322762 8 D-13 / + DATA ERC2CS( 20) / -.3809934465 2504919998 7691305772 9 D-14 / + DATA ERC2CS( 21) / +.9040487815 9788311493 6897101297 5 D-15 / + DATA ERC2CS( 22) / -.2164006195 0896073478 0981204700 3 D-15 / + DATA ERC2CS( 23) / +.5222102233 9958549846 0798024417 2 D-16 / + DATA ERC2CS( 24) / -.1269729602 3645553363 7241552778 0 D-16 / + DATA ERC2CS( 25) / +.3109145504 2761975838 3622741295 1 D-17 / + DATA ERC2CS( 26) / -.7663762920 3203855240 0956671481 1 D-18 / + DATA ERC2CS( 27) / +.1900819251 3627452025 3692973329 0 D-18 / + DATA ERC2CS( 28) / -.4742207279 0690395452 2565599996 5 D-19 / + DATA ERC2CS( 29) / +.1189649200 0765283828 8068307845 1 D-19 / + DATA ERC2CS( 30) / -.3000035590 3257802568 4527131306 6 D-20 / + DATA ERC2CS( 31) / +.7602993453 0432461730 1938527709 8 D-21 / + DATA ERC2CS( 32) / -.1935909447 6068728815 6981104913 0 D-21 / + DATA ERC2CS( 33) / +.4951399124 7733378810 0004238677 3 D-22 / + DATA ERC2CS( 34) / -.1271807481 3363718796 0862198988 8 D-22 / + DATA ERC2CS( 35) / +.3280049600 4695130433 1584165205 3 D-23 / + DATA ERC2CS( 36) / -.8492320176 8228965689 2479242239 9 D-24 / + DATA ERC2CS( 37) / +.2206917892 8075602235 1987998719 9 D-24 / + DATA ERC2CS( 38) / -.5755617245 6965284983 1281950719 9 D-25 / + DATA ERC2CS( 39) / +.1506191533 6392342503 5414405119 9 D-25 / + DATA ERC2CS( 40) / -.3954502959 0187969531 0428569599 9 D-26 / + DATA ERC2CS( 41) / +.1041529704 1515009799 8464505173 3 D-26 / + DATA ERC2CS( 42) / -.2751487795 2787650794 5017890133 3 D-27 / + DATA ERC2CS( 43) / +.7290058205 4975574089 9770368000 0 D-28 / + DATA ERC2CS( 44) / -.1936939645 9159478040 7750109866 6 D-28 / + DATA ERC2CS( 45) / +.5160357112 0514872983 7005482666 6 D-29 / + DATA ERC2CS( 46) / -.1378419322 1930940993 8964480000 0 D-29 / + DATA ERC2CS( 47) / +.3691326793 1070690422 5109333333 3 D-30 / + DATA ERC2CS( 48) / -.9909389590 6243654206 5322666666 6 D-31 / + DATA ERC2CS( 49) / +.2666491705 1953884133 2394666666 6 D-31 / + DATA ERFCCS( 1) / +.7151793102 0292477450 3697709496 D-1 / + DATA ERFCCS( 2) / -.2653243433 7606715755 8893386681 D-1 / + DATA ERFCCS( 3) / +.1711153977 9208558833 2699194606 D-2 / + DATA ERFCCS( 4) / -.1637516634 5851788416 3746404749 D-3 / + DATA ERFCCS( 5) / +.1987129350 0552036499 5974806758 D-4 / + DATA ERFCCS( 6) / -.2843712412 7665550875 0175183152 D-5 / + DATA ERFCCS( 7) / +.4606161308 9631303696 9379968464 D-6 / + DATA ERFCCS( 8) / -.8227753025 8792084205 7766536366 D-7 / + DATA ERFCCS( 9) / +.1592141872 7709011298 9358340826 D-7 / + DATA ERFCCS( 10) / -.3295071362 2528432148 6631665072 D-8 / + DATA ERFCCS( 11) / +.7223439760 4005554658 1261153890 D-9 / + DATA ERFCCS( 12) / -.1664855813 3987295934 4695966886 D-9 / + DATA ERFCCS( 13) / +.4010392588 2376648207 7671768814 D-10 / + DATA ERFCCS( 14) / -.1004816214 4257311327 2170176283 D-10 / + DATA ERFCCS( 15) / +.2608275913 3003338085 9341009439 D-11 / + DATA ERFCCS( 16) / -.6991110560 4040248655 7697812476 D-12 / + DATA ERFCCS( 17) / +.1929492333 2617070862 4205749803 D-12 / + DATA ERFCCS( 18) / -.5470131188 7543310649 0125085271 D-13 / + DATA ERFCCS( 19) / +.1589663309 7626974483 9084032762 D-13 / + DATA ERFCCS( 20) / -.4726893980 1975548392 0369584290 D-14 / + DATA ERFCCS( 21) / +.1435873376 7849847867 2873997840 D-14 / + DATA ERFCCS( 22) / -.4449510561 8173583941 7250062829 D-15 / + DATA ERFCCS( 23) / +.1404810884 7682334373 7305537466 D-15 / + DATA ERFCCS( 24) / -.4513818387 7642108962 5963281623 D-16 / + DATA ERFCCS( 25) / +.1474521541 0451330778 7018713262 D-16 / + DATA ERFCCS( 26) / -.4892621406 9457761543 6841552532 D-17 / + DATA ERFCCS( 27) / +.1647612141 4106467389 5301522827 D-17 / + DATA ERFCCS( 28) / -.5626817176 3294080929 9928521323 D-18 / + DATA ERFCCS( 29) / +.1947443382 2320785142 9197867821 D-18 / + DATA ERFCCS( 30) / -.6826305642 9484207295 6664144723 D-19 / + DATA ERFCCS( 31) / +.2421988887 2986492401 8301125438 D-19 / + DATA ERFCCS( 32) / -.8693414133 5030704256 3800861857 D-20 / + DATA ERFCCS( 33) / +.3155180346 2280855712 2363401262 D-20 / + DATA ERFCCS( 34) / -.1157372324 0496087426 1239486742 D-20 / + DATA ERFCCS( 35) / +.4288947161 6056539462 3737097442 D-21 / + DATA ERFCCS( 36) / -.1605030742 0576168500 5737770964 D-21 / + DATA ERFCCS( 37) / +.6063298757 4538026449 5069923027 D-22 / + DATA ERFCCS( 38) / -.2311404251 6979584909 8840801367 D-22 / + DATA ERFCCS( 39) / +.8888778540 6618855255 4702955697 D-23 / + DATA ERFCCS( 40) / -.3447260576 6513765223 0718495566 D-23 / + DATA ERFCCS( 41) / +.1347865460 2069650682 7582774181 D-23 / + DATA ERFCCS( 42) / -.5311794071 1250217364 5873201807 D-24 / + DATA ERFCCS( 43) / +.2109341058 6197831682 8954734537 D-24 / + DATA ERFCCS( 44) / -.8438365587 9237891159 8133256738 D-25 / + DATA ERFCCS( 45) / +.3399982524 9452089062 7359576337 D-25 / + DATA ERFCCS( 46) / -.1379452388 0732420900 2238377110 D-25 / + DATA ERFCCS( 47) / +.5634490311 8332526151 3392634811 D-26 / + DATA ERFCCS( 48) / -.2316490434 4770654482 3427752700 D-26 / + DATA ERFCCS( 49) / +.9584462844 6018101526 3158381226 D-27 / + DATA ERFCCS( 50) / -.3990722880 3301097262 4224850193 D-27 / + DATA ERFCCS( 51) / +.1672129225 9444773601 7228709669 D-27 / + DATA ERFCCS( 52) / -.7045991522 7660138563 8803782587 D-28 / + DATA ERFCCS( 53) / +.2979768402 8642063541 2357989444 D-28 / + DATA ERFCCS( 54) / -.1262522466 4606192972 2422632994 D-28 / + DATA ERFCCS( 55) / +.5395438704 5424879398 5299653154 D-29 / + DATA ERFCCS( 56) / -.2380992882 5314591867 5346190062 D-29 / + DATA ERFCCS( 57) / +.1099052830 1027615735 9726683750 D-29 / + DATA ERFCCS( 58) / -.4867713741 6449657273 2518677435 D-30 / + DATA ERFCCS( 59) / +.1525877264 1103575676 3200828211 D-30 / + DATA SQRTPI / 1.772453850 9055160272 9816748334 115D0 / + DATA FIRST /.TRUE./ +C***FIRST EXECUTABLE STATEMENT DERFC + IF (FIRST) THEN + ETA = 0.1*REAL(D1MACH(3)) + NTERF = INITDS (ERFCS, 21, ETA) + NTERFC = INITDS (ERFCCS, 59, ETA) + NTERC2 = INITDS (ERC2CS, 49, ETA) +C + XSML = -SQRT(-LOG(SQRTPI*D1MACH(3))) + TXMAX = SQRT(-LOG(SQRTPI*D1MACH(1))) + XMAX = TXMAX - 0.5D0*LOG(TXMAX)/TXMAX - 0.01D0 + SQEPS = SQRT(2.0D0*D1MACH(3)) + ENDIF + FIRST = .FALSE. +C + IF (ISNAN(X)) THEN + DERFC = X + RETURN + ENDIF +C + IF (X.GT.XSML) GO TO 20 +C +C ERFC(X) = 1.0 - ERF(X) FOR X .LT. XSML +C + DERFC = 2.0D0 + RETURN +C + 20 IF (X.GT.XMAX) GO TO 40 + Y = ABS(X) + IF (Y.GT.1.0D0) GO TO 30 +C +C ERFC(X) = 1.0 - ERF(X) FOR ABS(X) .LE. 1.0 +C + IF (Y.LT.SQEPS) DERFC = 1.0D0 - 2.0D0*X/SQRTPI + IF (Y.GE.SQEPS) DERFC = 1.0D0 - X*(1.0D0 + DCSEVL (2.D0*X*X-1.D0, + 1 ERFCS, NTERF)) + RETURN +C +C ERFC(X) = 1.0 - ERF(X) FOR 1.0 .LT. ABS(X) .LE. XMAX +C + 30 Y = Y*Y + IF (Y.LE.4.D0) DERFC = EXP(-Y)/ABS(X) * (0.5D0 + DCSEVL ( + 1 (8.D0/Y-5.D0)/3.D0, ERC2CS, NTERC2) ) + IF (Y.GT.4.D0) DERFC = EXP(-Y)/ABS(X) * (0.5D0 + DCSEVL ( + 1 8.D0/Y-1.D0, ERFCCS, NTERFC) ) + IF (X.LT.0.D0) DERFC = 2.0D0 - DERFC + RETURN +C + 40 DERFC = 0.D0 + RETURN +C + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/slatec-fn/dgami.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,47 @@ + +*DECK DGAMI + DOUBLE PRECISION FUNCTION DGAMI (A, X) +C***BEGIN PROLOGUE DGAMI +C***PURPOSE Evaluate the incomplete Gamma function. +C***LIBRARY SLATEC (FNLIB) +C***CATEGORY C7E +C***TYPE DOUBLE PRECISION (GAMI-S, DGAMI-D) +C***KEYWORDS FNLIB, INCOMPLETE GAMMA FUNCTION, SPECIAL FUNCTIONS +C***AUTHOR Fullerton, W., (LANL) +C***DESCRIPTION +C +C Evaluate the incomplete gamma function defined by +C +C DGAMI = integral from T = 0 to X of EXP(-T) * T**(A-1.0) . +C +C DGAMI is evaluated for positive values of A and non-negative values +C of X. A slight deterioration of 2 or 3 digits accuracy will occur +C when DGAMI is very large or very small, because logarithmic variables +C are used. The function and both arguments are double precision. +C +C***REFERENCES (NONE) +C***ROUTINES CALLED DGAMIT, DLNGAM, XERMSG +C***REVISION HISTORY (YYMMDD) +C 770701 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890531 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C***END PROLOGUE DGAMI + DOUBLE PRECISION A, X, FACTOR, DLNGAM, DGAMIT +C***FIRST EXECUTABLE STATEMENT DGAMI + IF (A .LE. 0.D0) CALL XERMSG ('SLATEC', 'DGAMI', + + 'A MUST BE GT ZERO', 1, 2) + IF (X .LT. 0.D0) CALL XERMSG ('SLATEC', 'DGAMI', + + 'X MUST BE GE ZERO', 2, 2) +C + DGAMI = 0.D0 + IF (X.EQ.0.0D0) RETURN +C +C THE ONLY ERROR POSSIBLE IN THE EXPRESSION BELOW IS A FATAL OVERFLOW. + FACTOR = EXP (DLNGAM(A) + A*LOG(X)) +C + DGAMI = FACTOR * DGAMIT (A, X) +C + RETURN + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/slatec-fn/dgamit.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,119 @@ +*DECK DGAMIT + DOUBLE PRECISION FUNCTION DGAMIT (A, X) +C***BEGIN PROLOGUE DGAMIT +C***PURPOSE Calculate Tricomi's form of the incomplete Gamma function. +C***LIBRARY SLATEC (FNLIB) +C***CATEGORY C7E +C***TYPE DOUBLE PRECISION (GAMIT-S, DGAMIT-D) +C***KEYWORDS COMPLEMENTARY INCOMPLETE GAMMA FUNCTION, FNLIB, +C SPECIAL FUNCTIONS, TRICOMI +C***AUTHOR Fullerton, W., (LANL) +C***DESCRIPTION +C +C Evaluate Tricomi's incomplete Gamma function defined by +C +C DGAMIT = X**(-A)/GAMMA(A) * integral from 0 to X of EXP(-T) * +C T**(A-1.) +C +C for A .GT. 0.0 and by analytic continuation for A .LE. 0.0. +C GAMMA(X) is the complete gamma function of X. +C +C DGAMIT is evaluated for arbitrary real values of A and for non- +C negative values of X (even though DGAMIT is defined for X .LT. +C 0.0), except that for X = 0 and A .LE. 0.0, DGAMIT is infinite, +C which is a fatal error. +C +C The function and both arguments are DOUBLE PRECISION. +C +C A slight deterioration of 2 or 3 digits accuracy will occur when +C DGAMIT is very large or very small in absolute value, because log- +C arithmic variables are used. Also, if the parameter A is very +C close to a negative integer (but not a negative integer), there is +C a loss of accuracy, which is reported if the result is less than +C half machine precision. +C +C***REFERENCES W. Gautschi, A computational procedure for incomplete +C gamma functions, ACM Transactions on Mathematical +C Software 5, 4 (December 1979), pp. 466-481. +C W. Gautschi, Incomplete gamma functions, Algorithm 542, +C ACM Transactions on Mathematical Software 5, 4 +C (December 1979), pp. 482-489. +C***ROUTINES CALLED D1MACH, D9GMIT, D9LGIC, D9LGIT, DGAMR, DLGAMS, +C DLNGAM, XERCLR, XERMSG +C***REVISION HISTORY (YYMMDD) +C 770701 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890531 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C 920528 DESCRIPTION and REFERENCES sections revised. (WRB) +C***END PROLOGUE DGAMIT + DOUBLE PRECISION A, X, AEPS, AINTA, ALGAP1, ALNEPS, ALNG, ALX, + 1 BOT, H, SGA, SGNGAM, SQEPS, T, D1MACH, DGAMR, D9GMIT, D9LGIT, + 2 DLNGAM, D9LGIC + LOGICAL FIRST + SAVE ALNEPS, SQEPS, BOT, FIRST + DATA FIRST /.TRUE./ +C***FIRST EXECUTABLE STATEMENT DGAMIT + IF (FIRST) THEN + ALNEPS = -LOG (D1MACH(3)) + SQEPS = SQRT(D1MACH(4)) + BOT = LOG (D1MACH(1)) + ENDIF + FIRST = .FALSE. +C + IF (X .LT. 0.D0) CALL XERMSG ('SLATEC', 'DGAMIT', 'X IS NEGATIVE' + + , 2, 2) +C + IF (X.NE.0.D0) ALX = LOG (X) + SGA = 1.0D0 + IF (A.NE.0.D0) SGA = SIGN (1.0D0, A) + AINTA = AINT (A + 0.5D0*SGA) + AEPS = A - AINTA +C + IF (X.GT.0.D0) GO TO 20 + DGAMIT = 0.0D0 + IF (AINTA.GT.0.D0 .OR. AEPS.NE.0.D0) DGAMIT = DGAMR(A+1.0D0) + RETURN +C + 20 IF (X.GT.1.D0) GO TO 30 + IF (A.GE.(-0.5D0) .OR. AEPS.NE.0.D0) CALL DLGAMS (A+1.0D0, ALGAP1, + 1 SGNGAM) + DGAMIT = D9GMIT (A, X, ALGAP1, SGNGAM, ALX) + RETURN +C + 30 IF (A.LT.X) GO TO 40 + T = D9LGIT (A, X, DLNGAM(A+1.0D0)) + IF (T.LT.BOT) CALL XERCLR + DGAMIT = EXP (T) + RETURN +C + 40 ALNG = D9LGIC (A, X, ALX) +C +C EVALUATE DGAMIT IN TERMS OF LOG (DGAMIC (A, X)) +C + H = 1.0D0 + IF (AEPS.EQ.0.D0 .AND. AINTA.LE.0.D0) GO TO 50 +C + CALL DLGAMS (A+1.0D0, ALGAP1, SGNGAM) + T = LOG (ABS(A)) + ALNG - ALGAP1 + IF (T.GT.ALNEPS) GO TO 60 +C + IF (T.GT.(-ALNEPS)) H = 1.0D0 - SGA * SGNGAM * EXP(T) + IF (ABS(H).GT.SQEPS) GO TO 50 +C + CALL XERCLR + CALL XERMSG ('SLATEC', 'DGAMIT', 'RESULT LT HALF PRECISION', 1, + + 1) +C + 50 T = -A*ALX + LOG(ABS(H)) + IF (T.LT.BOT) CALL XERCLR + DGAMIT = SIGN (EXP(T), H) + RETURN +C + 60 T = T - A*ALX + IF (T.LT.BOT) CALL XERCLR + DGAMIT = -SGA * SGNGAM * EXP(T) + RETURN +C + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/slatec-fn/dgamlm.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,62 @@ +*DECK DGAMLM + SUBROUTINE DGAMLM (XMIN, XMAX) +C***BEGIN PROLOGUE DGAMLM +C***PURPOSE Compute the minimum and maximum bounds for the argument in +C the Gamma function. +C***LIBRARY SLATEC (FNLIB) +C***CATEGORY C7A, R2 +C***TYPE DOUBLE PRECISION (GAMLIM-S, DGAMLM-D) +C***KEYWORDS COMPLETE GAMMA FUNCTION, FNLIB, LIMITS, SPECIAL FUNCTIONS +C***AUTHOR Fullerton, W., (LANL) +C***DESCRIPTION +C +C Calculate the minimum and maximum legal bounds for X in gamma(X). +C XMIN and XMAX are not the only bounds, but they are the only non- +C trivial ones to calculate. +C +C Output Arguments -- +C XMIN double precision minimum legal value of X in gamma(X). Any +C smaller value of X might result in underflow. +C XMAX double precision maximum legal value of X in gamma(X). Any +C larger value of X might cause overflow. +C +C***REFERENCES (NONE) +C***ROUTINES CALLED D1MACH, XERMSG +C***REVISION HISTORY (YYMMDD) +C 770601 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890531 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C***END PROLOGUE DGAMLM + DOUBLE PRECISION XMIN, XMAX, ALNBIG, ALNSML, XLN, XOLD, D1MACH +C***FIRST EXECUTABLE STATEMENT DGAMLM + ALNSML = LOG(D1MACH(1)) + XMIN = -ALNSML + DO 10 I=1,10 + XOLD = XMIN + XLN = LOG(XMIN) + XMIN = XMIN - XMIN*((XMIN+0.5D0)*XLN - XMIN - 0.2258D0 + ALNSML) + 1 / (XMIN*XLN+0.5D0) + IF (ABS(XMIN-XOLD).LT.0.005D0) GO TO 20 + 10 CONTINUE + CALL XERMSG ('SLATEC', 'DGAMLM', 'UNABLE TO FIND XMIN', 1, 2) +C + 20 XMIN = -XMIN + 0.01D0 +C + ALNBIG = LOG (D1MACH(2)) + XMAX = ALNBIG + DO 30 I=1,10 + XOLD = XMAX + XLN = LOG(XMAX) + XMAX = XMAX - XMAX*((XMAX-0.5D0)*XLN - XMAX + 0.9189D0 - ALNBIG) + 1 / (XMAX*XLN-0.5D0) + IF (ABS(XMAX-XOLD).LT.0.005D0) GO TO 40 + 30 CONTINUE + CALL XERMSG ('SLATEC', 'DGAMLM', 'UNABLE TO FIND XMAX', 2, 2) +C + 40 XMAX = XMAX - 0.01D0 + XMIN = MAX (XMIN, -XMAX+1.D0) +C + RETURN + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/slatec-fn/dgamma.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,153 @@ +*DECK DGAMMA + DOUBLE PRECISION FUNCTION DGAMMA (X) +C***BEGIN PROLOGUE DGAMMA +C***PURPOSE Compute the complete Gamma function. +C***LIBRARY SLATEC (FNLIB) +C***CATEGORY C7A +C***TYPE DOUBLE PRECISION (GAMMA-S, DGAMMA-D, CGAMMA-C) +C***KEYWORDS COMPLETE GAMMA FUNCTION, FNLIB, SPECIAL FUNCTIONS +C***AUTHOR Fullerton, W., (LANL) +C***DESCRIPTION +C +C DGAMMA(X) calculates the double precision complete Gamma function +C for double precision argument X. +C +C Series for GAM on the interval 0. to 1.00000E+00 +C with weighted error 5.79E-32 +C log weighted error 31.24 +C significant figures required 30.00 +C decimal places required 32.05 +C +C***REFERENCES (NONE) +C***ROUTINES CALLED D1MACH, D9LGMC, DCSEVL, DGAMLM, INITDS, XERMSG +C***REVISION HISTORY (YYMMDD) +C 770601 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890911 Removed unnecessary intrinsics. (WRB) +C 890911 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C 920618 Removed space from variable name. (RWC, WRB) +C***END PROLOGUE DGAMMA + DOUBLE PRECISION X, GAMCS(42), DXREL, PI, SINPIY, SQ2PIL, XMAX, + 1 XMIN, Y, D9LGMC, DCSEVL, D1MACH + LOGICAL FIRST +C + SAVE GAMCS, PI, SQ2PIL, NGAM, XMIN, XMAX, DXREL, FIRST + DATA GAMCS( 1) / +.8571195590 9893314219 2006239994 2 D-2 / + DATA GAMCS( 2) / +.4415381324 8410067571 9131577165 2 D-2 / + DATA GAMCS( 3) / +.5685043681 5993633786 3266458878 9 D-1 / + DATA GAMCS( 4) / -.4219835396 4185605010 1250018662 4 D-2 / + DATA GAMCS( 5) / +.1326808181 2124602205 8400679635 2 D-2 / + DATA GAMCS( 6) / -.1893024529 7988804325 2394702388 6 D-3 / + DATA GAMCS( 7) / +.3606925327 4412452565 7808221722 5 D-4 / + DATA GAMCS( 8) / -.6056761904 4608642184 8554829036 5 D-5 / + DATA GAMCS( 9) / +.1055829546 3022833447 3182350909 3 D-5 / + DATA GAMCS( 10) / -.1811967365 5423840482 9185589116 6 D-6 / + DATA GAMCS( 11) / +.3117724964 7153222777 9025459316 9 D-7 / + DATA GAMCS( 12) / -.5354219639 0196871408 7408102434 7 D-8 / + DATA GAMCS( 13) / +.9193275519 8595889468 8778682594 0 D-9 / + DATA GAMCS( 14) / -.1577941280 2883397617 6742327395 3 D-9 / + DATA GAMCS( 15) / +.2707980622 9349545432 6654043308 9 D-10 / + DATA GAMCS( 16) / -.4646818653 8257301440 8166105893 3 D-11 / + DATA GAMCS( 17) / +.7973350192 0074196564 6076717535 9 D-12 / + DATA GAMCS( 18) / -.1368078209 8309160257 9949917230 9 D-12 / + DATA GAMCS( 19) / +.2347319486 5638006572 3347177168 8 D-13 / + DATA GAMCS( 20) / -.4027432614 9490669327 6657053469 9 D-14 / + DATA GAMCS( 21) / +.6910051747 3721009121 3833697525 7 D-15 / + DATA GAMCS( 22) / -.1185584500 2219929070 5238712619 2 D-15 / + DATA GAMCS( 23) / +.2034148542 4963739552 0102605193 2 D-16 / + DATA GAMCS( 24) / -.3490054341 7174058492 7401294910 8 D-17 / + DATA GAMCS( 25) / +.5987993856 4853055671 3505106602 6 D-18 / + DATA GAMCS( 26) / -.1027378057 8722280744 9006977843 1 D-18 / + DATA GAMCS( 27) / +.1762702816 0605298249 4275966074 8 D-19 / + DATA GAMCS( 28) / -.3024320653 7353062609 5877211204 2 D-20 / + DATA GAMCS( 29) / +.5188914660 2183978397 1783355050 6 D-21 / + DATA GAMCS( 30) / -.8902770842 4565766924 4925160106 6 D-22 / + DATA GAMCS( 31) / +.1527474068 4933426022 7459689130 6 D-22 / + DATA GAMCS( 32) / -.2620731256 1873629002 5732833279 9 D-23 / + DATA GAMCS( 33) / +.4496464047 8305386703 3104657066 6 D-24 / + DATA GAMCS( 34) / -.7714712731 3368779117 0390152533 3 D-25 / + DATA GAMCS( 35) / +.1323635453 1260440364 8657271466 6 D-25 / + DATA GAMCS( 36) / -.2270999412 9429288167 0231381333 3 D-26 / + DATA GAMCS( 37) / +.3896418998 0039914493 2081663999 9 D-27 / + DATA GAMCS( 38) / -.6685198115 1259533277 9212799999 9 D-28 / + DATA GAMCS( 39) / +.1146998663 1400243843 4761386666 6 D-28 / + DATA GAMCS( 40) / -.1967938586 3451346772 9510399999 9 D-29 / + DATA GAMCS( 41) / +.3376448816 5853380903 3489066666 6 D-30 / + DATA GAMCS( 42) / -.5793070335 7821357846 2549333333 3 D-31 / + DATA PI / 3.1415926535 8979323846 2643383279 50 D0 / + DATA SQ2PIL / 0.9189385332 0467274178 0329736405 62 D0 / + DATA FIRST /.TRUE./ +C***FIRST EXECUTABLE STATEMENT DGAMMA + IF (FIRST) THEN + NGAM = INITDS (GAMCS, 42, 0.1*REAL(D1MACH(3)) ) +C + CALL DGAMLM (XMIN, XMAX) + DXREL = SQRT(D1MACH(4)) + ENDIF + FIRST = .FALSE. +C + Y = ABS(X) + IF (Y.GT.10.D0) GO TO 50 +C +C COMPUTE GAMMA(X) FOR -XBND .LE. X .LE. XBND. REDUCE INTERVAL AND FIND +C GAMMA(1+Y) FOR 0.0 .LE. Y .LT. 1.0 FIRST OF ALL. +C + N = X + IF (X.LT.0.D0) N = N - 1 + Y = X - N + N = N - 1 + DGAMMA = 0.9375D0 + DCSEVL (2.D0*Y-1.D0, GAMCS, NGAM) + IF (N.EQ.0) RETURN +C + IF (N.GT.0) GO TO 30 +C +C COMPUTE GAMMA(X) FOR X .LT. 1.0 +C + N = -N + IF (X .EQ. 0.D0) CALL XERMSG ('SLATEC', 'DGAMMA', 'X IS 0', 4, 2) + IF (X .LT. 0.0 .AND. X+N-2 .EQ. 0.D0) CALL XERMSG ('SLATEC', + + 'DGAMMA', 'X IS A NEGATIVE INTEGER', 4, 2) + IF (X .LT. (-0.5D0) .AND. ABS((X-AINT(X-0.5D0))/X) .LT. DXREL) + + CALL XERMSG ('SLATEC', 'DGAMMA', + + 'ANSWER LT HALF PRECISION BECAUSE X TOO NEAR NEGATIVE INTEGER', + + 1, 1) +C + DO 20 I=1,N + DGAMMA = DGAMMA/(X+I-1 ) + 20 CONTINUE + RETURN +C +C GAMMA(X) FOR X .GE. 2.0 AND X .LE. 10.0 +C + 30 DO 40 I=1,N + DGAMMA = (Y+I) * DGAMMA + 40 CONTINUE + RETURN +C +C GAMMA(X) FOR ABS(X) .GT. 10.0. RECALL Y = ABS(X). +C + 50 IF (X .GT. XMAX) CALL XERMSG ('SLATEC', 'DGAMMA', + + 'X SO BIG GAMMA OVERFLOWS', 3, 2) +C + DGAMMA = 0.D0 + IF (X .LT. XMIN) CALL XERMSG ('SLATEC', 'DGAMMA', + + 'X SO SMALL GAMMA UNDERFLOWS', 2, 1) + IF (X.LT.XMIN) RETURN +C + DGAMMA = EXP ((Y-0.5D0)*LOG(Y) - Y + SQ2PIL + D9LGMC(Y) ) + IF (X.GT.0.D0) RETURN +C + IF (ABS((X-AINT(X-0.5D0))/X) .LT. DXREL) CALL XERMSG ('SLATEC', + + 'DGAMMA', + + 'ANSWER LT HALF PRECISION, X TOO NEAR NEGATIVE INTEGER', 1, 1) +C + SINPIY = SIN (PI*Y) + IF (SINPIY .EQ. 0.D0) CALL XERMSG ('SLATEC', 'DGAMMA', + + 'X IS A NEGATIVE INTEGER', 4, 2) +C + DGAMMA = -PI/(Y*SINPIY*DGAMMA) +C + RETURN + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/slatec-fn/dgamr.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,44 @@ +*DECK DGAMR + DOUBLE PRECISION FUNCTION DGAMR (X) +C***BEGIN PROLOGUE DGAMR +C***PURPOSE Compute the reciprocal of the Gamma function. +C***LIBRARY SLATEC (FNLIB) +C***CATEGORY C7A +C***TYPE DOUBLE PRECISION (GAMR-S, DGAMR-D, CGAMR-C) +C***KEYWORDS FNLIB, RECIPROCAL GAMMA FUNCTION, SPECIAL FUNCTIONS +C***AUTHOR Fullerton, W., (LANL) +C***DESCRIPTION +C +C DGAMR(X) calculates the double precision reciprocal of the +C complete Gamma function for double precision argument X. +C +C***REFERENCES (NONE) +C***ROUTINES CALLED DGAMMA, DLGAMS, XERCLR, XGETF, XSETF +C***REVISION HISTORY (YYMMDD) +C 770701 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890531 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900727 Added EXTERNAL statement. (WRB) +C***END PROLOGUE DGAMR + DOUBLE PRECISION X, ALNGX, SGNGX, DGAMMA + EXTERNAL DGAMMA +C***FIRST EXECUTABLE STATEMENT DGAMR + DGAMR = 0.0D0 + IF (X.LE.0.0D0 .AND. AINT(X).EQ.X) RETURN +C + CALL XGETF (IROLD) + CALL XSETF (1) + IF (ABS(X).GT.10.0D0) GO TO 10 + DGAMR = 1.0D0/DGAMMA(X) + CALL XERCLR + CALL XSETF (IROLD) + RETURN +C + 10 CALL DLGAMS (X, ALNGX, SGNGX) + CALL XERCLR + CALL XSETF (IROLD) + DGAMR = SGNGX * EXP(-ALNGX) + RETURN +C + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/slatec-fn/dlbeta.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,62 @@ +*DECK DLBETA + DOUBLE PRECISION FUNCTION DLBETA (A, B) +C***BEGIN PROLOGUE DLBETA +C***PURPOSE Compute the natural logarithm of the complete Beta +C function. +C***LIBRARY SLATEC (FNLIB) +C***CATEGORY C7B +C***TYPE DOUBLE PRECISION (ALBETA-S, DLBETA-D, CLBETA-C) +C***KEYWORDS FNLIB, LOGARITHM OF THE COMPLETE BETA FUNCTION, +C SPECIAL FUNCTIONS +C***AUTHOR Fullerton, W., (LANL) +C***DESCRIPTION +C +C DLBETA(A,B) calculates the double precision natural logarithm of +C the complete beta function for double precision arguments +C A and B. +C +C***REFERENCES (NONE) +C***ROUTINES CALLED D9LGMC, DGAMMA, DLNGAM, DLNREL, XERMSG +C***REVISION HISTORY (YYMMDD) +C 770701 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890531 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C 900727 Added EXTERNAL statement. (WRB) +C***END PROLOGUE DLBETA + DOUBLE PRECISION A, B, P, Q, CORR, SQ2PIL, D9LGMC, DGAMMA, DLNGAM, + 1 DLNREL + EXTERNAL DGAMMA + SAVE SQ2PIL + DATA SQ2PIL / 0.9189385332 0467274178 0329736405 62 D0 / +C***FIRST EXECUTABLE STATEMENT DLBETA + P = MIN (A, B) + Q = MAX (A, B) +C + IF (P .LE. 0.D0) CALL XERMSG ('SLATEC', 'DLBETA', + + 'BOTH ARGUMENTS MUST BE GT ZERO', 1, 2) +C + IF (P.GE.10.D0) GO TO 30 + IF (Q.GE.10.D0) GO TO 20 +C +C P AND Q ARE SMALL. +C + DLBETA = LOG (DGAMMA(P) * (DGAMMA(Q)/DGAMMA(P+Q)) ) + RETURN +C +C P IS SMALL, BUT Q IS BIG. +C + 20 CORR = D9LGMC(Q) - D9LGMC(P+Q) + DLBETA = DLNGAM(P) + CORR + P - P*LOG(P+Q) + 1 + (Q-0.5D0)*DLNREL(-P/(P+Q)) + RETURN +C +C P AND Q ARE BIG. +C + 30 CORR = D9LGMC(P) + D9LGMC(Q) - D9LGMC(P+Q) + DLBETA = -0.5D0*LOG(Q) + SQ2PIL + CORR + (P-0.5D0)*LOG(P/(P+Q)) + 1 + Q*DLNREL(-P/(P+Q)) + RETURN +C + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/slatec-fn/dlgams.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,37 @@ +*DECK DLGAMS + SUBROUTINE DLGAMS (X, DLGAM, SGNGAM) +C***BEGIN PROLOGUE DLGAMS +C***PURPOSE Compute the logarithm of the absolute value of the Gamma +C function. +C***LIBRARY SLATEC (FNLIB) +C***CATEGORY C7A +C***TYPE DOUBLE PRECISION (ALGAMS-S, DLGAMS-D) +C***KEYWORDS ABSOLUTE VALUE OF THE LOGARITHM OF THE GAMMA FUNCTION, +C FNLIB, SPECIAL FUNCTIONS +C***AUTHOR Fullerton, W., (LANL) +C***DESCRIPTION +C +C DLGAMS(X,DLGAM,SGNGAM) calculates the double precision natural +C logarithm of the absolute value of the Gamma function for +C double precision argument X and stores the result in double +C precision argument DLGAM. +C +C***REFERENCES (NONE) +C***ROUTINES CALLED DLNGAM +C***REVISION HISTORY (YYMMDD) +C 770701 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890531 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C***END PROLOGUE DLGAMS + DOUBLE PRECISION X, DLGAM, SGNGAM, DLNGAM +C***FIRST EXECUTABLE STATEMENT DLGAMS + DLGAM = DLNGAM(X) + SGNGAM = 1.0D0 + IF (X.GT.0.D0) RETURN +C + INT = MOD (-AINT(X), 2.0D0) + 0.1D0 + IF (INT.EQ.0) SGNGAM = -1.0D0 +C + RETURN + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/slatec-fn/dlngam.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,73 @@ +*DECK DLNGAM + DOUBLE PRECISION FUNCTION DLNGAM (X) +C***BEGIN PROLOGUE DLNGAM +C***PURPOSE Compute the logarithm of the absolute value of the Gamma +C function. +C***LIBRARY SLATEC (FNLIB) +C***CATEGORY C7A +C***TYPE DOUBLE PRECISION (ALNGAM-S, DLNGAM-D, CLNGAM-C) +C***KEYWORDS ABSOLUTE VALUE, COMPLETE GAMMA FUNCTION, FNLIB, LOGARITHM, +C SPECIAL FUNCTIONS +C***AUTHOR Fullerton, W., (LANL) +C***DESCRIPTION +C +C DLNGAM(X) calculates the double precision logarithm of the +C absolute value of the Gamma function for double precision +C argument X. +C +C***REFERENCES (NONE) +C***ROUTINES CALLED D1MACH, D9LGMC, DGAMMA, XERMSG +C***REVISION HISTORY (YYMMDD) +C 770601 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890531 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C 900727 Added EXTERNAL statement. (WRB) +C***END PROLOGUE DLNGAM + DOUBLE PRECISION X, DXREL, PI, SINPIY, SQPI2L, SQ2PIL, XMAX, + 1 Y, DGAMMA, D9LGMC, D1MACH, TEMP + LOGICAL FIRST + EXTERNAL DGAMMA + SAVE SQ2PIL, SQPI2L, PI, XMAX, DXREL, FIRST + DATA SQ2PIL / 0.9189385332 0467274178 0329736405 62 D0 / + DATA SQPI2L / +.2257913526 4472743236 3097614947 441 D+0 / + DATA PI / 3.1415926535 8979323846 2643383279 50 D0 / + DATA FIRST /.TRUE./ +C***FIRST EXECUTABLE STATEMENT DLNGAM + IF (FIRST) THEN + TEMP = 1.D0/LOG(D1MACH(2)) + XMAX = TEMP*D1MACH(2) + DXREL = SQRT(D1MACH(4)) + ENDIF + FIRST = .FALSE. +C + Y = ABS (X) + IF (Y.GT.10.D0) GO TO 20 +C +C LOG (ABS (DGAMMA(X)) ) FOR ABS(X) .LE. 10.0 +C + DLNGAM = LOG (ABS (DGAMMA(X)) ) + RETURN +C +C LOG ( ABS (DGAMMA(X)) ) FOR ABS(X) .GT. 10.0 +C + 20 IF (Y .GT. XMAX) CALL XERMSG ('SLATEC', 'DLNGAM', + + 'ABS(X) SO BIG DLNGAM OVERFLOWS', 2, 2) +C + IF (X.GT.0.D0) DLNGAM = SQ2PIL + (X-0.5D0)*LOG(X) - X + D9LGMC(Y) + IF (X.GT.0.D0) RETURN +C + SINPIY = ABS (SIN(PI*Y)) + IF (SINPIY .EQ. 0.D0) CALL XERMSG ('SLATEC', 'DLNGAM', + + 'X IS A NEGATIVE INTEGER', 3, 2) +C + IF (ABS((X-AINT(X-0.5D0))/X) .LT. DXREL) CALL XERMSG ('SLATEC', + + 'DLNGAM', + + 'ANSWER LT HALF PRECISION BECAUSE X TOO NEAR NEGATIVE INTEGER', + + 1, 1) +C + DLNGAM = SQPI2L + (X-0.5D0)*LOG(Y) - X - LOG(SINPIY) - D9LGMC(Y) + RETURN +C + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/slatec-fn/dlnrel.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,98 @@ +*DECK DLNREL + DOUBLE PRECISION FUNCTION DLNREL (X) +C***BEGIN PROLOGUE DLNREL +C***PURPOSE Evaluate ln(1+X) accurate in the sense of relative error. +C***LIBRARY SLATEC (FNLIB) +C***CATEGORY C4B +C***TYPE DOUBLE PRECISION (ALNREL-S, DLNREL-D, CLNREL-C) +C***KEYWORDS ELEMENTARY FUNCTIONS, FNLIB, LOGARITHM +C***AUTHOR Fullerton, W., (LANL) +C***DESCRIPTION +C +C DLNREL(X) calculates the double precision natural logarithm of +C (1.0+X) for double precision argument X. This routine should +C be used when X is small and accurate to calculate the logarithm +C accurately (in the relative error sense) in the neighborhood +C of 1.0. +C +C Series for ALNR on the interval -3.75000E-01 to 3.75000E-01 +C with weighted error 6.35E-32 +C log weighted error 31.20 +C significant figures required 30.93 +C decimal places required 32.01 +C +C***REFERENCES (NONE) +C***ROUTINES CALLED D1MACH, DCSEVL, INITDS, XERMSG +C***REVISION HISTORY (YYMMDD) +C 770601 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890531 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C***END PROLOGUE DLNREL + DOUBLE PRECISION ALNRCS(43), X, XMIN, DCSEVL, D1MACH + LOGICAL FIRST + SAVE ALNRCS, NLNREL, XMIN, FIRST + DATA ALNRCS( 1) / +.1037869356 2743769800 6862677190 98 D+1 / + DATA ALNRCS( 2) / -.1336430150 4908918098 7660415531 33 D+0 / + DATA ALNRCS( 3) / +.1940824913 5520563357 9261993747 50 D-1 / + DATA ALNRCS( 4) / -.3010755112 7535777690 3765377765 92 D-2 / + DATA ALNRCS( 5) / +.4869461479 7154850090 4563665091 37 D-3 / + DATA ALNRCS( 6) / -.8105488189 3175356066 8099430086 22 D-4 / + DATA ALNRCS( 7) / +.1377884779 9559524782 9382514960 59 D-4 / + DATA ALNRCS( 8) / -.2380221089 4358970251 3699929149 35 D-5 / + DATA ALNRCS( 9) / +.4164041621 3865183476 3918599019 89 D-6 / + DATA ALNRCS( 10) / -.7359582837 8075994984 2668370319 98 D-7 / + DATA ALNRCS( 11) / +.1311761187 6241674949 1522943450 11 D-7 / + DATA ALNRCS( 12) / -.2354670931 7742425136 6960923301 75 D-8 / + DATA ALNRCS( 13) / +.4252277327 6034997775 6380529625 67 D-9 / + DATA ALNRCS( 14) / -.7719089413 4840796826 1081074933 00 D-10 / + DATA ALNRCS( 15) / +.1407574648 1359069909 2153564721 91 D-10 / + DATA ALNRCS( 16) / -.2576907205 8024680627 5370786275 84 D-11 / + DATA ALNRCS( 17) / +.4734240666 6294421849 1543950059 38 D-12 / + DATA ALNRCS( 18) / -.8724901267 4742641745 3012632926 75 D-13 / + DATA ALNRCS( 19) / +.1612461490 2740551465 7398331191 15 D-13 / + DATA ALNRCS( 20) / -.2987565201 5665773006 7107924168 15 D-14 / + DATA ALNRCS( 21) / +.5548070120 9082887983 0413216972 79 D-15 / + DATA ALNRCS( 22) / -.1032461915 8271569595 1413339619 32 D-15 / + DATA ALNRCS( 23) / +.1925023920 3049851177 8785032448 68 D-16 / + DATA ALNRCS( 24) / -.3595507346 5265150011 1897078442 66 D-17 / + DATA ALNRCS( 25) / +.6726454253 7876857892 1945742267 73 D-18 / + DATA ALNRCS( 26) / -.1260262416 8735219252 0824256375 46 D-18 / + DATA ALNRCS( 27) / +.2364488440 8606210044 9161589555 19 D-19 / + DATA ALNRCS( 28) / -.4441937705 0807936898 8783891797 33 D-20 / + DATA ALNRCS( 29) / +.8354659446 4034259016 2412939946 66 D-21 / + DATA ALNRCS( 30) / -.1573155941 6479562574 8992535210 66 D-21 / + DATA ALNRCS( 31) / +.2965312874 0247422686 1543697066 66 D-22 / + DATA ALNRCS( 32) / -.5594958348 1815947292 1560132266 66 D-23 / + DATA ALNRCS( 33) / +.1056635426 8835681048 1872841386 66 D-23 / + DATA ALNRCS( 34) / -.1997248368 0670204548 3149994666 66 D-24 / + DATA ALNRCS( 35) / +.3778297781 8839361421 0498559999 99 D-25 / + DATA ALNRCS( 36) / -.7153158688 9081740345 0381653333 33 D-26 / + DATA ALNRCS( 37) / +.1355248846 3674213646 5020245333 33 D-26 / + DATA ALNRCS( 38) / -.2569467304 8487567430 0798293333 33 D-27 / + DATA ALNRCS( 39) / +.4874775606 6216949076 4595199999 99 D-28 / + DATA ALNRCS( 40) / -.9254211253 0849715321 1323733333 33 D-29 / + DATA ALNRCS( 41) / +.1757859784 1760239233 2697600000 00 D-29 / + DATA ALNRCS( 42) / -.3341002667 7731010351 3770666666 66 D-30 / + DATA ALNRCS( 43) / +.6353393618 0236187354 1802666666 66 D-31 / + DATA FIRST /.TRUE./ +C***FIRST EXECUTABLE STATEMENT DLNREL + IF (FIRST) THEN + NLNREL = INITDS (ALNRCS, 43, 0.1*REAL(D1MACH(3))) + XMIN = -1.0D0 + SQRT(D1MACH(4)) + ENDIF + FIRST = .FALSE. +C + IF (X .LE. (-1.D0)) CALL XERMSG ('SLATEC', 'DLNREL', 'X IS LE -1' + + , 2, 2) + IF (X .LT. XMIN) CALL XERMSG ('SLATEC', 'DLNREL', + + 'ANSWER LT HALF PRECISION BECAUSE X TOO NEAR -1', 1, 1) +C + IF (ABS(X).LE.0.375D0) DLNREL = X*(1.D0 - + 1 X*DCSEVL (X/.375D0, ALNRCS, NLNREL)) +C + IF (ABS(X).GT.0.375D0) DLNREL = LOG (1.0D0+X) +C + RETURN + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/slatec-fn/dpchim.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,285 @@ +*DECK DPCHIM + SUBROUTINE DPCHIM (N, X, F, D, INCFD, IERR) +C***BEGIN PROLOGUE DPCHIM +C***PURPOSE Set derivatives needed to determine a monotone piecewise +C cubic Hermite interpolant to given data. Boundary values +C are provided which are compatible with monotonicity. The +C interpolant will have an extremum at each point where mono- +C tonicity switches direction. (See DPCHIC if user control +C is desired over boundary or switch conditions.) +C***LIBRARY SLATEC (PCHIP) +C***CATEGORY E1A +C***TYPE DOUBLE PRECISION (PCHIM-S, DPCHIM-D) +C***KEYWORDS CUBIC HERMITE INTERPOLATION, MONOTONE INTERPOLATION, +C PCHIP, PIECEWISE CUBIC INTERPOLATION +C***AUTHOR Fritsch, F. N., (LLNL) +C Lawrence Livermore National Laboratory +C P.O. Box 808 (L-316) +C Livermore, CA 94550 +C FTS 532-4275, (510) 422-4275 +C***DESCRIPTION +C +C DPCHIM: Piecewise Cubic Hermite Interpolation to +C Monotone data. +C +C Sets derivatives needed to determine a monotone piecewise cubic +C Hermite interpolant to the data given in X and F. +C +C Default boundary conditions are provided which are compatible +C with monotonicity. (See DPCHIC if user control of boundary con- +C ditions is desired.) +C +C If the data are only piecewise monotonic, the interpolant will +C have an extremum at each point where monotonicity switches direc- +C tion. (See DPCHIC if user control is desired in such cases.) +C +C To facilitate two-dimensional applications, includes an increment +C between successive values of the F- and D-arrays. +C +C The resulting piecewise cubic Hermite function may be evaluated +C by DPCHFE or DPCHFD. +C +C ---------------------------------------------------------------------- +C +C Calling sequence: +C +C PARAMETER (INCFD = ...) +C INTEGER N, IERR +C DOUBLE PRECISION X(N), F(INCFD,N), D(INCFD,N) +C +C CALL DPCHIM (N, X, F, D, INCFD, IERR) +C +C Parameters: +C +C N -- (input) number of data points. (Error return if N.LT.2 .) +C If N=2, simply does linear interpolation. +C +C X -- (input) real*8 array of independent variable values. The +C elements of X must be strictly increasing: +C X(I-1) .LT. X(I), I = 2(1)N. +C (Error return if not.) +C +C F -- (input) real*8 array of dependent variable values to be +C interpolated. F(1+(I-1)*INCFD) is value corresponding to +C X(I). DPCHIM is designed for monotonic data, but it will +C work for any F-array. It will force extrema at points where +C monotonicity switches direction. If some other treatment of +C switch points is desired, DPCHIC should be used instead. +C ----- +C D -- (output) real*8 array of derivative values at the data +C points. If the data are monotonic, these values will +C determine a monotone cubic Hermite function. +C The value corresponding to X(I) is stored in +C D(1+(I-1)*INCFD), I=1(1)N. +C No other entries in D are changed. +C +C INCFD -- (input) increment between successive values in F and D. +C This argument is provided primarily for 2-D applications. +C (Error return if INCFD.LT.1 .) +C +C IERR -- (output) error flag. +C Normal return: +C IERR = 0 (no errors). +C Warning error: +C IERR.GT.0 means that IERR switches in the direction +C of monotonicity were detected. +C "Recoverable" errors: +C IERR = -1 if N.LT.2 . +C IERR = -2 if INCFD.LT.1 . +C IERR = -3 if the X-array is not strictly increasing. +C (The D-array has not been changed in any of these cases.) +C NOTE: The above errors are checked in the order listed, +C and following arguments have **NOT** been validated. +C +C***REFERENCES 1. F. N. Fritsch and J. Butland, A method for construc- +C ting local monotone piecewise cubic interpolants, SIAM +C Journal on Scientific and Statistical Computing 5, 2 +C (June 1984), pp. 300-304. +C 2. F. N. Fritsch and R. E. Carlson, Monotone piecewise +C cubic interpolation, SIAM Journal on Numerical Ana- +C lysis 17, 2 (April 1980), pp. 238-246. +C***ROUTINES CALLED DPCHST, XERMSG +C***REVISION HISTORY (YYMMDD) +C 811103 DATE WRITTEN +C 820201 1. Introduced DPCHST to reduce possible over/under- +C flow problems. +C 2. Rearranged derivative formula for same reason. +C 820602 1. Modified end conditions to be continuous functions +C of data when monotonicity switches in next interval. +C 2. Modified formulas so end conditions are less prone +C of over/underflow problems. +C 820803 Minor cosmetic changes for release 1. +C 870707 Corrected XERROR calls for d.p. name(s). +C 870813 Updated Reference 1. +C 890206 Corrected XERROR calls. +C 890411 Added SAVE statements (Vers. 3.2). +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890703 Corrected category record. (WRB) +C 890831 Modified array declarations. (WRB) +C 891006 Cosmetic changes to prologue. (WRB) +C 891006 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C 920429 Revised format and order of references. (WRB,FNF) +C***END PROLOGUE DPCHIM +C Programming notes: +C +C 1. The function DPCHST(ARG1,ARG2) is assumed to return zero if +C either argument is zero, +1 if they are of the same sign, and +C -1 if they are of opposite sign. +C 2. To produce a single precision version, simply: +C a. Change DPCHIM to PCHIM wherever it occurs, +C b. Change DPCHST to PCHST wherever it occurs, +C c. Change all references to the Fortran intrinsics to their +C single precision equivalents, +C d. Change the double precision declarations to real, and +C e. Change the constants ZERO and THREE to single precision. +C +C DECLARE ARGUMENTS. +C + INTEGER N, INCFD, IERR + DOUBLE PRECISION X(*), F(INCFD,*), D(INCFD,*) +C +C DECLARE LOCAL VARIABLES. +C + INTEGER I, NLESS1 + DOUBLE PRECISION DEL1, DEL2, DMAX, DMIN, DRAT1, DRAT2, DSAVE, + * H1, H2, HSUM, HSUMT3, THREE, W1, W2, ZERO + SAVE ZERO, THREE + DOUBLE PRECISION DPCHST + DATA ZERO /0.D0/, THREE/3.D0/ +C +C VALIDITY-CHECK ARGUMENTS. +C +C***FIRST EXECUTABLE STATEMENT DPCHIM + IF ( N.LT.2 ) GO TO 5001 + IF ( INCFD.LT.1 ) GO TO 5002 + DO 1 I = 2, N + IF ( X(I).LE.X(I-1) ) GO TO 5003 + 1 CONTINUE +C +C FUNCTION DEFINITION IS OK, GO ON. +C + IERR = 0 + NLESS1 = N - 1 + H1 = X(2) - X(1) + DEL1 = (F(1,2) - F(1,1))/H1 + DSAVE = DEL1 +C +C SPECIAL CASE N=2 -- USE LINEAR INTERPOLATION. +C + IF (NLESS1 .GT. 1) GO TO 10 + D(1,1) = DEL1 + D(1,N) = DEL1 + GO TO 5000 +C +C NORMAL CASE (N .GE. 3). +C + 10 CONTINUE + H2 = X(3) - X(2) + DEL2 = (F(1,3) - F(1,2))/H2 +C +C SET D(1) VIA NON-CENTERED THREE-POINT FORMULA, ADJUSTED TO BE +C SHAPE-PRESERVING. +C + HSUM = H1 + H2 + W1 = (H1 + HSUM)/HSUM + W2 = -H1/HSUM + D(1,1) = W1*DEL1 + W2*DEL2 + IF ( DPCHST(D(1,1),DEL1) .LE. ZERO) THEN + D(1,1) = ZERO + ELSE IF ( DPCHST(DEL1,DEL2) .LT. ZERO) THEN +C NEED DO THIS CHECK ONLY IF MONOTONICITY SWITCHES. + DMAX = THREE*DEL1 + IF (ABS(D(1,1)) .GT. ABS(DMAX)) D(1,1) = DMAX + ENDIF +C +C LOOP THROUGH INTERIOR POINTS. +C + DO 50 I = 2, NLESS1 + IF (I .EQ. 2) GO TO 40 +C + H1 = H2 + H2 = X(I+1) - X(I) + HSUM = H1 + H2 + DEL1 = DEL2 + DEL2 = (F(1,I+1) - F(1,I))/H2 + 40 CONTINUE +C +C SET D(I)=0 UNLESS DATA ARE STRICTLY MONOTONIC. +C + D(1,I) = ZERO + IF ( DPCHST(DEL1,DEL2) .LT. 0.) GO TO 42 + IF ( DPCHST(DEL1,DEL2) .EQ. 0.) GO TO 41 + GO TO 45 +C +C COUNT NUMBER OF CHANGES IN DIRECTION OF MONOTONICITY. +C + 41 CONTINUE + IF (DEL2 .EQ. ZERO) GO TO 50 + IF ( DPCHST(DSAVE,DEL2) .LT. ZERO) IERR = IERR + 1 + DSAVE = DEL2 + GO TO 50 +C + 42 CONTINUE + IERR = IERR + 1 + DSAVE = DEL2 + GO TO 50 +C +C USE BRODLIE MODIFICATION OF BUTLAND FORMULA. +C + 45 CONTINUE + HSUMT3 = HSUM+HSUM+HSUM + W1 = (HSUM + H1)/HSUMT3 + W2 = (HSUM + H2)/HSUMT3 + DMAX = MAX( ABS(DEL1), ABS(DEL2) ) + DMIN = MIN( ABS(DEL1), ABS(DEL2) ) + DRAT1 = DEL1/DMAX + DRAT2 = DEL2/DMAX + D(1,I) = DMIN/(W1*DRAT1 + W2*DRAT2) +C + 50 CONTINUE +C +C SET D(N) VIA NON-CENTERED THREE-POINT FORMULA, ADJUSTED TO BE +C SHAPE-PRESERVING. +C + W1 = -H2/HSUM + W2 = (H2 + HSUM)/HSUM + D(1,N) = W1*DEL1 + W2*DEL2 + IF ( DPCHST(D(1,N),DEL2) .LE. ZERO) THEN + D(1,N) = ZERO + ELSE IF ( DPCHST(DEL1,DEL2) .LT. ZERO) THEN +C NEED DO THIS CHECK ONLY IF MONOTONICITY SWITCHES. + DMAX = THREE*DEL2 + IF (ABS(D(1,N)) .GT. ABS(DMAX)) D(1,N) = DMAX + ENDIF +C +C NORMAL RETURN. +C + 5000 CONTINUE + RETURN +C +C ERROR RETURNS. +C + 5001 CONTINUE +C N.LT.2 RETURN. + IERR = -1 + CALL XERMSG ('SLATEC', 'DPCHIM', + + 'NUMBER OF DATA POINTS LESS THAN TWO', IERR, 1) + RETURN +C + 5002 CONTINUE +C INCFD.LT.1 RETURN. + IERR = -2 + CALL XERMSG ('SLATEC', 'DPCHIM', 'INCREMENT LESS THAN ONE', IERR, + + 1) + RETURN +C + 5003 CONTINUE +C X-ARRAY NOT STRICTLY INCREASING. + IERR = -3 + CALL XERMSG ('SLATEC', 'DPCHIM', + + 'X-ARRAY NOT STRICTLY INCREASING', IERR, 1) + RETURN +C------------- LAST LINE OF DPCHIM FOLLOWS ----------------------------- + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/slatec-fn/dpchst.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,59 @@ +*DECK DPCHST + DOUBLE PRECISION FUNCTION DPCHST (ARG1, ARG2) +C***BEGIN PROLOGUE DPCHST +C***SUBSIDIARY +C***PURPOSE DPCHIP Sign-Testing Routine +C***LIBRARY SLATEC (PCHIP) +C***TYPE DOUBLE PRECISION (PCHST-S, DPCHST-D) +C***AUTHOR Fritsch, F. N., (LLNL) +C***DESCRIPTION +C +C DPCHST: DPCHIP Sign-Testing Routine. +C +C +C Returns: +C -1. if ARG1 and ARG2 are of opposite sign. +C 0. if either argument is zero. +C +1. if ARG1 and ARG2 are of the same sign. +C +C The object is to do this without multiplying ARG1*ARG2, to avoid +C possible over/underflow problems. +C +C Fortran intrinsics used: SIGN. +C +C***SEE ALSO DPCHCE, DPCHCI, DPCHCS, DPCHIM +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 811103 DATE WRITTEN +C 820805 Converted to SLATEC library version. +C 870813 Minor cosmetic changes. +C 890411 Added SAVE statements (Vers. 3.2). +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890531 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900328 Added TYPE section. (WRB) +C 910408 Updated AUTHOR and DATE WRITTEN sections in prologue. (WRB) +C 930503 Improved purpose. (FNF) +C***END PROLOGUE DPCHST +C +C**End +C +C DECLARE ARGUMENTS. +C + DOUBLE PRECISION ARG1, ARG2 +C +C DECLARE LOCAL VARIABLES. +C + DOUBLE PRECISION ONE, ZERO + SAVE ZERO, ONE + DATA ZERO /0.D0/, ONE/1.D0/ +C +C PERFORM THE TEST. +C +C***FIRST EXECUTABLE STATEMENT DPCHST + DPCHST = SIGN(ONE,ARG1) * SIGN(ONE,ARG2) + IF ((ARG1.EQ.ZERO) .OR. (ARG2.EQ.ZERO)) DPCHST = ZERO +C + RETURN +C------------- LAST LINE OF DPCHST FOLLOWS ----------------------------- + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/slatec-fn/dpsifn.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,368 @@ +*DECK DPSIFN + SUBROUTINE DPSIFN (X, N, KODE, M, ANS, NZ, IERR) +C***BEGIN PROLOGUE DPSIFN +C***PURPOSE Compute derivatives of the Psi function. +C***LIBRARY SLATEC +C***CATEGORY C7C +C***TYPE DOUBLE PRECISION (PSIFN-S, DPSIFN-D) +C***KEYWORDS DERIVATIVES OF THE GAMMA FUNCTION, POLYGAMMA FUNCTION, +C PSI FUNCTION +C***AUTHOR Amos, D. E., (SNLA) +C***DESCRIPTION +C +C The following definitions are used in DPSIFN: +C +C Definition 1 +C PSI(X) = d/dx (ln(GAMMA(X)), the first derivative of +C the log GAMMA function. +C Definition 2 +C K K +C PSI(K,X) = d /dx (PSI(X)), the K-th derivative of PSI(X). +C ___________________________________________________________________ +C DPSIFN computes a sequence of SCALED derivatives of +C the PSI function; i.e. for fixed X and M it computes +C the M-member sequence +C +C ((-1)**(K+1)/GAMMA(K+1))*PSI(K,X) +C for K = N,...,N+M-1 +C +C where PSI(K,X) is as defined above. For KODE=1, DPSIFN returns +C the scaled derivatives as described. KODE=2 is operative only +C when K=0 and in that case DPSIFN returns -PSI(X) + LN(X). That +C is, the logarithmic behavior for large X is removed when KODE=2 +C and K=0. When sums or differences of PSI functions are computed +C the logarithmic terms can be combined analytically and computed +C separately to help retain significant digits. +C +C Note that CALL DPSIFN(X,0,1,1,ANS) results in +C ANS = -PSI(X) +C +C Input X is DOUBLE PRECISION +C X - Argument, X .gt. 0.0D0 +C N - First member of the sequence, 0 .le. N .le. 100 +C N=0 gives ANS(1) = -PSI(X) for KODE=1 +C -PSI(X)+LN(X) for KODE=2 +C KODE - Selection parameter +C KODE=1 returns scaled derivatives of the PSI +C function. +C KODE=2 returns scaled derivatives of the PSI +C function EXCEPT when N=0. In this case, +C ANS(1) = -PSI(X) + LN(X) is returned. +C M - Number of members of the sequence, M.ge.1 +C +C Output ANS is DOUBLE PRECISION +C ANS - A vector of length at least M whose first M +C components contain the sequence of derivatives +C scaled according to KODE. +C NZ - Underflow flag +C NZ.eq.0, A normal return +C NZ.ne.0, Underflow, last NZ components of ANS are +C set to zero, ANS(M-K+1)=0.0, K=1,...,NZ +C IERR - Error flag +C IERR=0, A normal return, computation completed +C IERR=1, Input error, no computation +C IERR=2, Overflow, X too small or N+M-1 too +C large or both +C IERR=3, Error, N too large. Dimensioned +C array TRMR(NMAX) is not large enough for N +C +C The nominal computational accuracy is the maximum of unit +C roundoff (=D1MACH(4)) and 1.0D-18 since critical constants +C are given to only 18 digits. +C +C PSIFN is the single precision version of DPSIFN. +C +C *Long Description: +C +C The basic method of evaluation is the asymptotic expansion +C for large X.ge.XMIN followed by backward recursion on a two +C term recursion relation +C +C W(X+1) + X**(-N-1) = W(X). +C +C This is supplemented by a series +C +C SUM( (X+K)**(-N-1) , K=0,1,2,... ) +C +C which converges rapidly for large N. Both XMIN and the +C number of terms of the series are calculated from the unit +C roundoff of the machine environment. +C +C***REFERENCES Handbook of Mathematical Functions, National Bureau +C of Standards Applied Mathematics Series 55, edited +C by M. Abramowitz and I. A. Stegun, equations 6.3.5, +C 6.3.18, 6.4.6, 6.4.9 and 6.4.10, pp.258-260, 1964. +C D. E. Amos, A portable Fortran subroutine for +C derivatives of the Psi function, Algorithm 610, ACM +C Transactions on Mathematical Software 9, 4 (1983), +C pp. 494-502. +C***ROUTINES CALLED D1MACH, I1MACH +C***REVISION HISTORY (YYMMDD) +C 820601 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890911 Removed unnecessary intrinsics. (WRB) +C 891006 Cosmetic changes to prologue. (WRB) +C 891006 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE DPSIFN + INTEGER I, IERR, J, K, KODE, M, MM, MX, N, NMAX, NN, NP, NX, NZ, + * FN + INTEGER I1MACH + DOUBLE PRECISION ANS, ARG, B, DEN, ELIM, EPS, FLN, + * FX, RLN, RXSQ, R1M4, R1M5, S, SLOPE, T, TA, TK, TOL, TOLS, TRM, + * TRMR, TSS, TST, TT, T1, T2, WDTOL, X, XDMLN, XDMY, XINC, XLN, + * XM, XMIN, XQ, YINT + DOUBLE PRECISION D1MACH + DIMENSION B(22), TRM(22), TRMR(100), ANS(*) + SAVE NMAX, B + DATA NMAX /100/ +C----------------------------------------------------------------------- +C BERNOULLI NUMBERS +C----------------------------------------------------------------------- + DATA B(1), B(2), B(3), B(4), B(5), B(6), B(7), B(8), B(9), B(10), + * B(11), B(12), B(13), B(14), B(15), B(16), B(17), B(18), B(19), + * B(20), B(21), B(22) /1.00000000000000000D+00, + * -5.00000000000000000D-01,1.66666666666666667D-01, + * -3.33333333333333333D-02,2.38095238095238095D-02, + * -3.33333333333333333D-02,7.57575757575757576D-02, + * -2.53113553113553114D-01,1.16666666666666667D+00, + * -7.09215686274509804D+00,5.49711779448621554D+01, + * -5.29124242424242424D+02,6.19212318840579710D+03, + * -8.65802531135531136D+04,1.42551716666666667D+06, + * -2.72982310678160920D+07,6.01580873900642368D+08, + * -1.51163157670921569D+10,4.29614643061166667D+11, + * -1.37116552050883328D+13,4.88332318973593167D+14, + * -1.92965793419400681D+16/ +C +C***FIRST EXECUTABLE STATEMENT DPSIFN + IERR = 0 + NZ=0 + IF (X.LE.0.0D0) IERR=1 + IF (N.LT.0) IERR=1 + IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1 + IF (M.LT.1) IERR=1 + IF (IERR.NE.0) RETURN + MM=M + NX = MIN(-I1MACH(15),I1MACH(16)) + R1M5 = D1MACH(5) + R1M4 = D1MACH(4)*0.5D0 + WDTOL = MAX(R1M4,0.5D-18) +C----------------------------------------------------------------------- +C ELIM = APPROXIMATE EXPONENTIAL OVER AND UNDERFLOW LIMIT +C----------------------------------------------------------------------- + ELIM = 2.302D0*(NX*R1M5-3.0D0) + XLN = LOG(X) + 41 CONTINUE + NN = N + MM - 1 + FN = NN + T = (FN+1)*XLN +C----------------------------------------------------------------------- +C OVERFLOW AND UNDERFLOW TEST FOR SMALL AND LARGE X +C----------------------------------------------------------------------- + IF (ABS(T).GT.ELIM) GO TO 290 + IF (X.LT.WDTOL) GO TO 260 +C----------------------------------------------------------------------- +C COMPUTE XMIN AND THE NUMBER OF TERMS OF THE SERIES, FLN+1 +C----------------------------------------------------------------------- + RLN = R1M5*I1MACH(14) + RLN = MIN(RLN,18.06D0) + FLN = MAX(RLN,3.0D0) - 3.0D0 + YINT = 3.50D0 + 0.40D0*FLN + SLOPE = 0.21D0 + FLN*(0.0006038D0*FLN+0.008677D0) + XM = YINT + SLOPE*FN + MX = INT(XM) + 1 + XMIN = MX + IF (N.EQ.0) GO TO 50 + XM = -2.302D0*RLN - MIN(0.0D0,XLN) + ARG = XM/N + ARG = MIN(0.0D0,ARG) + EPS = EXP(ARG) + XM = 1.0D0 - EPS + IF (ABS(ARG).LT.1.0D-3) XM = -ARG + FLN = X*XM/EPS + XM = XMIN - X + IF (XM.GT.7.0D0 .AND. FLN.LT.15.0D0) GO TO 200 + 50 CONTINUE + XDMY = X + XDMLN = XLN + XINC = 0.0D0 + IF (X.GE.XMIN) GO TO 60 + NX = INT(X) + XINC = XMIN - NX + XDMY = X + XINC + XDMLN = LOG(XDMY) + 60 CONTINUE +C----------------------------------------------------------------------- +C GENERATE W(N+MM-1,X) BY THE ASYMPTOTIC EXPANSION +C----------------------------------------------------------------------- + T = FN*XDMLN + T1 = XDMLN + XDMLN + T2 = T + XDMLN + TK = MAX(ABS(T),ABS(T1),ABS(T2)) + IF (TK.GT.ELIM) GO TO 380 + TSS = EXP(-T) + TT = 0.5D0/XDMY + T1 = TT + TST = WDTOL*TT + IF (NN.NE.0) T1 = TT + 1.0D0/FN + RXSQ = 1.0D0/(XDMY*XDMY) + TA = 0.5D0*RXSQ + T = (FN+1)*TA + S = T*B(3) + IF (ABS(S).LT.TST) GO TO 80 + TK = 2.0D0 + DO 70 K=4,22 + T = T*((TK+FN+1)/(TK+1.0D0))*((TK+FN)/(TK+2.0D0))*RXSQ + TRM(K) = T*B(K) + IF (ABS(TRM(K)).LT.TST) GO TO 80 + S = S + TRM(K) + TK = TK + 2.0D0 + 70 CONTINUE + 80 CONTINUE + S = (S+T1)*TSS + IF (XINC.EQ.0.0D0) GO TO 100 +C----------------------------------------------------------------------- +C BACKWARD RECUR FROM XDMY TO X +C----------------------------------------------------------------------- + NX = INT(XINC) + NP = NN + 1 + IF (NX.GT.NMAX) GO TO 390 + IF (NN.EQ.0) GO TO 160 + XM = XINC - 1.0D0 + FX = X + XM +C----------------------------------------------------------------------- +C THIS LOOP SHOULD NOT BE CHANGED. FX IS ACCURATE WHEN X IS SMALL +C----------------------------------------------------------------------- + DO 90 I=1,NX + TRMR(I) = FX**(-NP) + S = S + TRMR(I) + XM = XM - 1.0D0 + FX = X + XM + 90 CONTINUE + 100 CONTINUE + ANS(MM) = S + IF (FN.EQ.0) GO TO 180 +C----------------------------------------------------------------------- +C GENERATE LOWER DERIVATIVES, J.LT.N+MM-1 +C----------------------------------------------------------------------- + IF (MM.EQ.1) RETURN + DO 150 J=2,MM + FN = FN - 1 + TSS = TSS*XDMY + T1 = TT + IF (FN.NE.0) T1 = TT + 1.0D0/FN + T = (FN+1)*TA + S = T*B(3) + IF (ABS(S).LT.TST) GO TO 120 + TK = 4 + FN + DO 110 K=4,22 + TRM(K) = TRM(K)*(FN+1)/TK + IF (ABS(TRM(K)).LT.TST) GO TO 120 + S = S + TRM(K) + TK = TK + 2.0D0 + 110 CONTINUE + 120 CONTINUE + S = (S+T1)*TSS + IF (XINC.EQ.0.0D0) GO TO 140 + IF (FN.EQ.0) GO TO 160 + XM = XINC - 1.0D0 + FX = X + XM + DO 130 I=1,NX + TRMR(I) = TRMR(I)*FX + S = S + TRMR(I) + XM = XM - 1.0D0 + FX = X + XM + 130 CONTINUE + 140 CONTINUE + MX = MM - J + 1 + ANS(MX) = S + IF (FN.EQ.0) GO TO 180 + 150 CONTINUE + RETURN +C----------------------------------------------------------------------- +C RECURSION FOR N = 0 +C----------------------------------------------------------------------- + 160 CONTINUE + DO 170 I=1,NX + S = S + 1.0D0/(X+NX-I) + 170 CONTINUE + 180 CONTINUE + IF (KODE.EQ.2) GO TO 190 + ANS(1) = S - XDMLN + RETURN + 190 CONTINUE + IF (XDMY.EQ.X) RETURN + XQ = XDMY/X + ANS(1) = S - LOG(XQ) + RETURN +C----------------------------------------------------------------------- +C COMPUTE BY SERIES (X+K)**(-(N+1)) , K=0,1,2,... +C----------------------------------------------------------------------- + 200 CONTINUE + NN = INT(FLN) + 1 + NP = N + 1 + T1 = (N+1)*XLN + T = EXP(-T1) + S = T + DEN = X + DO 210 I=1,NN + DEN = DEN + 1.0D0 + TRM(I) = DEN**(-NP) + S = S + TRM(I) + 210 CONTINUE + ANS(1) = S + IF (N.NE.0) GO TO 220 + IF (KODE.EQ.2) ANS(1) = S + XLN + 220 CONTINUE + IF (MM.EQ.1) RETURN +C----------------------------------------------------------------------- +C GENERATE HIGHER DERIVATIVES, J.GT.N +C----------------------------------------------------------------------- + TOL = WDTOL/5.0D0 + DO 250 J=2,MM + T = T/X + S = T + TOLS = T*TOL + DEN = X + DO 230 I=1,NN + DEN = DEN + 1.0D0 + TRM(I) = TRM(I)/DEN + S = S + TRM(I) + IF (TRM(I).LT.TOLS) GO TO 240 + 230 CONTINUE + 240 CONTINUE + ANS(J) = S + 250 CONTINUE + RETURN +C----------------------------------------------------------------------- +C SMALL X.LT.UNIT ROUND OFF +C----------------------------------------------------------------------- + 260 CONTINUE + ANS(1) = X**(-N-1) + IF (MM.EQ.1) GO TO 280 + K = 1 + DO 270 I=2,MM + ANS(K+1) = ANS(K)/X + K = K + 1 + 270 CONTINUE + 280 CONTINUE + IF (N.NE.0) RETURN + IF (KODE.EQ.2) ANS(1) = ANS(1) + XLN + RETURN + 290 CONTINUE + IF (T.GT.0.0D0) GO TO 380 + NZ=0 + IERR=2 + RETURN + 380 CONTINUE + NZ=NZ+1 + ANS(MM)=0.0D0 + MM=MM-1 + IF (MM.EQ.0) RETURN + GO TO 41 + 390 CONTINUE + NZ=0 + IERR=3 + RETURN + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/slatec-fn/erf.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,73 @@ +*DECK ERF + FUNCTION ERF (X) +C***BEGIN PROLOGUE ERF +C***PURPOSE Compute the error function. +C***LIBRARY SLATEC (FNLIB) +C***CATEGORY C8A, L5A1E +C***TYPE SINGLE PRECISION (ERF-S, DERF-D) +C***KEYWORDS ERF, ERROR FUNCTION, FNLIB, SPECIAL FUNCTIONS +C***AUTHOR Fullerton, W., (LANL) +C***DESCRIPTION +C +C ERF(X) calculates the single precision error function for +C single precision argument X. +C +C Series for ERF on the interval 0. to 1.00000D+00 +C with weighted error 7.10E-18 +C log weighted error 17.15 +C significant figures required 16.31 +C decimal places required 17.71 +C +C***REFERENCES (NONE) +C***ROUTINES CALLED CSEVL, ERFC, INITS, R1MACH +C***REVISION HISTORY (YYMMDD) +C 770401 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890531 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900727 Added EXTERNAL statement. (WRB) +C 920618 Removed space from variable name. (RWC, WRB) +C***END PROLOGUE ERF + DIMENSION ERFCS(13) + LOGICAL FIRST + EXTERNAL ERFC + SAVE ERFCS, SQRTPI, NTERF, XBIG, SQEPS, FIRST + DATA ERFCS( 1) / -.0490461212 34691808E0 / + DATA ERFCS( 2) / -.1422612051 0371364E0 / + DATA ERFCS( 3) / .0100355821 87599796E0 / + DATA ERFCS( 4) / -.0005768764 69976748E0 / + DATA ERFCS( 5) / .0000274199 31252196E0 / + DATA ERFCS( 6) / -.0000011043 17550734E0 / + DATA ERFCS( 7) / .0000000384 88755420E0 / + DATA ERFCS( 8) / -.0000000011 80858253E0 / + DATA ERFCS( 9) / .0000000000 32334215E0 / + DATA ERFCS(10) / -.0000000000 00799101E0 / + DATA ERFCS(11) / .0000000000 00017990E0 / + DATA ERFCS(12) / -.0000000000 00000371E0 / + DATA ERFCS(13) / .0000000000 00000007E0 / + DATA SQRTPI /1.772453850 9055160E0/ + DATA FIRST /.TRUE./ +C***FIRST EXECUTABLE STATEMENT ERF + IF (FIRST) THEN + NTERF = INITS (ERFCS, 13, 0.1*R1MACH(3)) + XBIG = SQRT(-LOG(SQRTPI*R1MACH(3))) + SQEPS = SQRT(2.0*R1MACH(3)) + ENDIF + FIRST = .FALSE. +C + Y = ABS(X) + IF (Y.GT.1.) GO TO 20 +C +C ERF(X) = 1. - ERFC(X) FOR -1. .LE. X .LE. 1. +C + IF (Y.LE.SQEPS) ERF = 2.0*X/SQRTPI + IF (Y.GT.SQEPS) ERF = X*(1.0 + CSEVL(2.*X**2-1., ERFCS, NTERF)) + RETURN +C +C ERF(X) = 1. - ERFC(X) FOR ABS(X) .GT. 1. +C + 20 IF (Y.LE.XBIG) ERF = SIGN (1.0-ERFC(Y), X) + IF (Y.GT.XBIG) ERF = SIGN (1.0, X) +C + RETURN + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/slatec-fn/erfc.in.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,160 @@ +*DECK ERFC + FUNCTION ERFC (X) +C***BEGIN PROLOGUE ERFC +C***PURPOSE Compute the complementary error function. +C***LIBRARY SLATEC (FNLIB) +C***CATEGORY C8A, L5A1E +C***TYPE SINGLE PRECISION (ERFC-S, DERFC-D) +C***KEYWORDS COMPLEMENTARY ERROR FUNCTION, ERFC, FNLIB, +C SPECIAL FUNCTIONS +C***AUTHOR Fullerton, W., (LANL) +C***DESCRIPTION +C +C ERFC(X) calculates the single precision complementary error +C function for single precision argument X. +C +C Series for ERF on the interval 0. to 1.00000D+00 +C with weighted error 7.10E-18 +C log weighted error 17.15 +C significant figures required 16.31 +C decimal places required 17.71 +C +C Series for ERFC on the interval 0. to 2.50000D-01 +C with weighted error 4.81E-17 +C log weighted error 16.32 +C approx significant figures required 15.0 +C +C +C Series for ERC2 on the interval 2.50000D-01 to 1.00000D+00 +C with weighted error 5.22E-17 +C log weighted error 16.28 +C approx significant figures required 15.0 +C decimal places required 16.96 +C +C***REFERENCES (NONE) +C***ROUTINES CALLED CSEVL, INITS, R1MACH, XERMSG +C***REVISION HISTORY (YYMMDD) +C 770701 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890531 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C 920618 Removed space from variable names. (RWC, WRB) +C***END PROLOGUE ERFC + DIMENSION ERFCS(13), ERFCCS(24), ERC2CS(23) + LOGICAL FIRST + SAVE ERFCS, ERC2CS, ERFCCS, SQRTPI, NTERF, NTERFC, + 1 NTERC2, XSML, XMAX, SQEPS, FIRST + DATA ERFCS( 1) / -.0490461212 34691808E0 / + DATA ERFCS( 2) / -.1422612051 0371364E0 / + DATA ERFCS( 3) / .0100355821 87599796E0 / + DATA ERFCS( 4) / -.0005768764 69976748E0 / + DATA ERFCS( 5) / .0000274199 31252196E0 / + DATA ERFCS( 6) / -.0000011043 17550734E0 / + DATA ERFCS( 7) / .0000000384 88755420E0 / + DATA ERFCS( 8) / -.0000000011 80858253E0 / + DATA ERFCS( 9) / .0000000000 32334215E0 / + DATA ERFCS(10) / -.0000000000 00799101E0 / + DATA ERFCS(11) / .0000000000 00017990E0 / + DATA ERFCS(12) / -.0000000000 00000371E0 / + DATA ERFCS(13) / .0000000000 00000007E0 / + DATA ERC2CS( 1) / -.0696013466 02309501E0 / + DATA ERC2CS( 2) / -.0411013393 62620893E0 / + DATA ERC2CS( 3) / .0039144958 66689626E0 / + DATA ERC2CS( 4) / -.0004906395 65054897E0 / + DATA ERC2CS( 5) / .0000715747 90013770E0 / + DATA ERC2CS( 6) / -.0000115307 16341312E0 / + DATA ERC2CS( 7) / .0000019946 70590201E0 / + DATA ERC2CS( 8) / -.0000003642 66647159E0 / + DATA ERC2CS( 9) / .0000000694 43726100E0 / + DATA ERC2CS(10) / -.0000000137 12209021E0 / + DATA ERC2CS(11) / .0000000027 88389661E0 / + DATA ERC2CS(12) / -.0000000005 81416472E0 / + DATA ERC2CS(13) / .0000000001 23892049E0 / + DATA ERC2CS(14) / -.0000000000 26906391E0 / + DATA ERC2CS(15) / .0000000000 05942614E0 / + DATA ERC2CS(16) / -.0000000000 01332386E0 / + DATA ERC2CS(17) / .0000000000 00302804E0 / + DATA ERC2CS(18) / -.0000000000 00069666E0 / + DATA ERC2CS(19) / .0000000000 00016208E0 / + DATA ERC2CS(20) / -.0000000000 00003809E0 / + DATA ERC2CS(21) / .0000000000 00000904E0 / + DATA ERC2CS(22) / -.0000000000 00000216E0 / + DATA ERC2CS(23) / .0000000000 00000052E0 / + DATA ERFCCS( 1) / 0.0715179310 202925E0 / + DATA ERFCCS( 2) / -.0265324343 37606719E0 / + DATA ERFCCS( 3) / .0017111539 77920853E0 / + DATA ERFCCS( 4) / -.0001637516 63458512E0 / + DATA ERFCCS( 5) / .0000198712 93500549E0 / + DATA ERFCCS( 6) / -.0000028437 12412769E0 / + DATA ERFCCS( 7) / .0000004606 16130901E0 / + DATA ERFCCS( 8) / -.0000000822 77530261E0 / + DATA ERFCCS( 9) / .0000000159 21418724E0 / + DATA ERFCCS(10) / -.0000000032 95071356E0 / + DATA ERFCCS(11) / .0000000007 22343973E0 / + DATA ERFCCS(12) / -.0000000001 66485584E0 / + DATA ERFCCS(13) / .0000000000 40103931E0 / + DATA ERFCCS(14) / -.0000000000 10048164E0 / + DATA ERFCCS(15) / .0000000000 02608272E0 / + DATA ERFCCS(16) / -.0000000000 00699105E0 / + DATA ERFCCS(17) / .0000000000 00192946E0 / + DATA ERFCCS(18) / -.0000000000 00054704E0 / + DATA ERFCCS(19) / .0000000000 00015901E0 / + DATA ERFCCS(20) / -.0000000000 00004729E0 / + DATA ERFCCS(21) / .0000000000 00001432E0 / + DATA ERFCCS(22) / -.0000000000 00000439E0 / + DATA ERFCCS(23) / .0000000000 00000138E0 / + DATA ERFCCS(24) / -.0000000000 00000048E0 / + DATA SQRTPI /1.772453850 9055160E0/ + DATA FIRST /.TRUE./ +C***FIRST EXECUTABLE STATEMENT ERFC + IF (FIRST) THEN + ETA = 0.1*R1MACH(3) + NTERF = INITS (ERFCS, 13, ETA) + NTERFC = INITS (ERFCCS, 24, ETA) + NTERC2 = INITS (ERC2CS, 23, ETA) +C + XSML = -SQRT (-LOG(SQRTPI*R1MACH(3))) + TXMAX = SQRT (-LOG(SQRTPI*R1MACH(1))) + XMAX = TXMAX - 0.5*LOG(TXMAX)/TXMAX - 0.01 + SQEPS = SQRT (2.0*R1MACH(3)) + ENDIF + FIRST = .FALSE. +C + IF (ISNAN(X)) THEN + ERFC = X + RETURN + ENDIF +C + IF (X.GT.XSML) GO TO 20 +C +C ERFC(X) = 1.0 - ERF(X) FOR X .LT. XSML +C + ERFC = 2. + RETURN +C + 20 IF (X.GT.XMAX) GO TO 40 + Y = ABS(X) + IF (Y.GT.1.0) GO TO 30 +C +C ERFC(X) = 1.0 - ERF(X) FOR -1. .LE. X .LE. 1. +C + IF (Y.LT.SQEPS) ERFC = 1.0 - 2.0*X/SQRTPI + IF (Y.GE.SQEPS) ERFC = 1.0 - + 1 X*(1.0 + CSEVL (2.*X*X-1., ERFCS, NTERF) ) + RETURN +C +C ERFC(X) = 1.0 - ERF(X) FOR 1. .LT. ABS(X) .LE. XMAX +C + 30 Y = Y*Y + IF (Y.LE.4.) ERFC = EXP(-Y)/ABS(X) * (0.5 + CSEVL ((8./Y-5.)/3., + 1 ERC2CS, NTERC2) ) + IF (Y.GT.4.) ERFC = EXP(-Y)/ABS(X) * (0.5 + CSEVL (8./Y-1., + 1 ERFCCS, NTERFC) ) + IF (X.LT.0.) ERFC = 2.0 - ERFC + RETURN +C + 40 ERFC = 0. + RETURN +C + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/slatec-fn/gami.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,45 @@ +*DECK GAMI + FUNCTION GAMI (A, X) +C***BEGIN PROLOGUE GAMI +C***PURPOSE Evaluate the incomplete Gamma function. +C***LIBRARY SLATEC (FNLIB) +C***CATEGORY C7E +C***TYPE SINGLE PRECISION (GAMI-S, DGAMI-D) +C***KEYWORDS FNLIB, INCOMPLETE GAMMA FUNCTION, SPECIAL FUNCTIONS +C***AUTHOR Fullerton, W., (LANL) +C***DESCRIPTION +C +C Evaluate the incomplete gamma function defined by +C +C GAMI = integral from T = 0 to X of EXP(-T) * T**(A-1.0) . +C +C GAMI is evaluated for positive values of A and non-negative values +C of X. A slight deterioration of 2 or 3 digits accuracy will occur +C when GAMI is very large or very small, because logarithmic variables +C are used. GAMI, A, and X are single precision. +C +C***REFERENCES (NONE) +C***ROUTINES CALLED ALNGAM, GAMIT, XERMSG +C***REVISION HISTORY (YYMMDD) +C 770701 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890531 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C***END PROLOGUE GAMI +C***FIRST EXECUTABLE STATEMENT GAMI + IF (A .LE. 0.0) CALL XERMSG ('SLATEC', 'GAMI', + + 'A MUST BE GT ZERO', 1, 2) + IF (X .LT. 0.0) CALL XERMSG ('SLATEC', 'GAMI', + + 'X MUST BE GE ZERO', 2, 2) +C + GAMI = 0.0 + IF (X.EQ.0.0) RETURN +C +C THE ONLY ERROR POSSIBLE IN THE EXPRESSION BELOW IS A FATAL OVERFLOW. + FACTOR = EXP (ALNGAM(A) + A*LOG(X) ) +C + GAMI = FACTOR * GAMIT(A, X) +C + RETURN + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/slatec-fn/gamit.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,112 @@ +*DECK GAMIT + REAL FUNCTION GAMIT (A, X) +C***BEGIN PROLOGUE GAMIT +C***PURPOSE Calculate Tricomi's form of the incomplete Gamma function. +C***LIBRARY SLATEC (FNLIB) +C***CATEGORY C7E +C***TYPE SINGLE PRECISION (GAMIT-S, DGAMIT-D) +C***KEYWORDS COMPLEMENTARY INCOMPLETE GAMMA FUNCTION, FNLIB, +C SPECIAL FUNCTIONS, TRICOMI +C***AUTHOR Fullerton, W., (LANL) +C***DESCRIPTION +C +C Evaluate Tricomi's incomplete gamma function defined by +C +C GAMIT = X**(-A)/GAMMA(A) * integral from 0 to X of EXP(-T) * +C T**(A-1.) +C +C for A .GT. 0.0 and by analytic continuation for A .LE. 0.0. +C GAMMA(X) is the complete gamma function of X. +C +C GAMIT is evaluated for arbitrary real values of A and for non- +C negative values of X (even though GAMIT is defined for X .LT. +C 0.0), except that for X = 0 and A .LE. 0.0, GAMIT is infinite, +C which is a fatal error. +C +C The function and both arguments are REAL. +C +C A slight deterioration of 2 or 3 digits accuracy will occur when +C GAMIT is very large or very small in absolute value, because log- +C arithmic variables are used. Also, if the parameter A is very +C close to a negative integer (but not a negative integer), there is +C a loss of accuracy, which is reported if the result is less than +C half machine precision. +C +C***REFERENCES W. Gautschi, A computational procedure for incomplete +C gamma functions, ACM Transactions on Mathematical +C Software 5, 4 (December 1979), pp. 466-481. +C W. Gautschi, Incomplete gamma functions, Algorithm 542, +C ACM Transactions on Mathematical Software 5, 4 +C (December 1979), pp. 482-489. +C***ROUTINES CALLED ALGAMS, ALNGAM, GAMR, R1MACH, R9GMIT, R9LGIC, +C R9LGIT, XERCLR, XERMSG +C***REVISION HISTORY (YYMMDD) +C 770701 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890531 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C 920528 DESCRIPTION and REFERENCES sections revised. (WRB) +C***END PROLOGUE GAMIT + LOGICAL FIRST + SAVE ALNEPS, SQEPS, BOT, FIRST + DATA FIRST /.TRUE./ +C***FIRST EXECUTABLE STATEMENT GAMIT + IF (FIRST) THEN + ALNEPS = -LOG(R1MACH(3)) + SQEPS = SQRT(R1MACH(4)) + BOT = LOG(R1MACH(1)) + ENDIF + FIRST = .FALSE. +C + IF (X .LT. 0.0) CALL XERMSG ('SLATEC', 'GAMIT', 'X IS NEGATIVE', + + 2, 2) +C + IF (X.NE.0.0) ALX = LOG(X) + SGA = 1.0 + IF (A.NE.0.0) SGA = SIGN (1.0, A) + AINTA = AINT (A+0.5*SGA) + AEPS = A - AINTA +C + IF (X.GT.0.0) GO TO 20 + GAMIT = 0.0 + IF (AINTA.GT.0.0 .OR. AEPS.NE.0.0) GAMIT = GAMR(A+1.0) + RETURN +C + 20 IF (X.GT.1.0) GO TO 40 + IF (A.GE.(-0.5) .OR. AEPS.NE.0.0) CALL ALGAMS (A+1.0, ALGAP1, + 1 SGNGAM) + GAMIT = R9GMIT (A, X, ALGAP1, SGNGAM, ALX) + RETURN +C + 40 IF (A.LT.X) GO TO 50 + T = R9LGIT (A, X, ALNGAM(A+1.0)) + IF (T.LT.BOT) CALL XERCLR + GAMIT = EXP(T) + RETURN +C + 50 ALNG = R9LGIC (A, X, ALX) +C +C EVALUATE GAMIT IN TERMS OF LOG(GAMIC(A,X)) +C + H = 1.0 + IF (AEPS.EQ.0.0 .AND. AINTA.LE.0.0) GO TO 60 + CALL ALGAMS (A+1.0, ALGAP1, SGNGAM) + T = LOG(ABS(A)) + ALNG - ALGAP1 + IF (T.GT.ALNEPS) GO TO 70 + IF (T.GT.(-ALNEPS)) H = 1.0 - SGA*SGNGAM*EXP(T) + IF (ABS(H).GT.SQEPS) GO TO 60 + CALL XERCLR + CALL XERMSG ('SLATEC', 'GAMIT', 'RESULT LT HALF PRECISION', 1, 1) +C + 60 T = -A*ALX + LOG(ABS(H)) + IF (T.LT.BOT) CALL XERCLR + GAMIT = SIGN (EXP(T), H) + RETURN +C + 70 T = T - A*ALX + IF (T.LT.BOT) CALL XERCLR + GAMIT = -SGA*SGNGAM*EXP(T) + RETURN +C + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/slatec-fn/gamlim.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,61 @@ +*DECK GAMLIM + SUBROUTINE GAMLIM (XMIN, XMAX) +C***BEGIN PROLOGUE GAMLIM +C***PURPOSE Compute the minimum and maximum bounds for the argument in +C the Gamma function. +C***LIBRARY SLATEC (FNLIB) +C***CATEGORY C7A, R2 +C***TYPE SINGLE PRECISION (GAMLIM-S, DGAMLM-D) +C***KEYWORDS COMPLETE GAMMA FUNCTION, FNLIB, LIMITS, SPECIAL FUNCTIONS +C***AUTHOR Fullerton, W., (LANL) +C***DESCRIPTION +C +C Calculate the minimum and maximum legal bounds for X in GAMMA(X). +C XMIN and XMAX are not the only bounds, but they are the only non- +C trivial ones to calculate. +C +C Output Arguments -- +C XMIN minimum legal value of X in GAMMA(X). Any smaller value of +C X might result in underflow. +C XMAX maximum legal value of X in GAMMA(X). Any larger value will +C cause overflow. +C +C***REFERENCES (NONE) +C***ROUTINES CALLED R1MACH, XERMSG +C***REVISION HISTORY (YYMMDD) +C 770401 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890531 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C***END PROLOGUE GAMLIM +C***FIRST EXECUTABLE STATEMENT GAMLIM + ALNSML = LOG(R1MACH(1)) + XMIN = -ALNSML + DO 10 I=1,10 + XOLD = XMIN + XLN = LOG(XMIN) + XMIN = XMIN - XMIN*((XMIN+0.5)*XLN - XMIN - 0.2258 + ALNSML) + 1 / (XMIN*XLN + 0.5) + IF (ABS(XMIN-XOLD).LT.0.005) GO TO 20 + 10 CONTINUE + CALL XERMSG ('SLATEC', 'GAMLIM', 'UNABLE TO FIND XMIN', 1, 2) +C + 20 XMIN = -XMIN + 0.01 +C + ALNBIG = LOG(R1MACH(2)) + XMAX = ALNBIG + DO 30 I=1,10 + XOLD = XMAX + XLN = LOG(XMAX) + XMAX = XMAX - XMAX*((XMAX-0.5)*XLN - XMAX + 0.9189 - ALNBIG) + 1 / (XMAX*XLN - 0.5) + IF (ABS(XMAX-XOLD).LT.0.005) GO TO 40 + 30 CONTINUE + CALL XERMSG ('SLATEC', 'GAMLIM', 'UNABLE TO FIND XMAX', 2, 2) +C + 40 XMAX = XMAX - 0.01 + XMIN = MAX (XMIN, -XMAX+1.) +C + RETURN + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/slatec-fn/gamma.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,138 @@ +*DECK GAMMA + FUNCTION GAMMA (X) +C***BEGIN PROLOGUE GAMMA +C***PURPOSE Compute the complete Gamma function. +C***LIBRARY SLATEC (FNLIB) +C***CATEGORY C7A +C***TYPE SINGLE PRECISION (GAMMA-S, DGAMMA-D, CGAMMA-C) +C***KEYWORDS COMPLETE GAMMA FUNCTION, FNLIB, SPECIAL FUNCTIONS +C***AUTHOR Fullerton, W., (LANL) +C***DESCRIPTION +C +C GAMMA computes the gamma function at X, where X is not 0, -1, -2, .... +C GAMMA and X are single precision. +C +C***REFERENCES (NONE) +C***ROUTINES CALLED CSEVL, GAMLIM, INITS, R1MACH, R9LGMC, XERMSG +C***REVISION HISTORY (YYMMDD) +C 770601 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890531 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C***END PROLOGUE GAMMA + DIMENSION GCS(23) + LOGICAL FIRST + SAVE GCS, PI, SQ2PIL, NGCS, XMIN, XMAX, DXREL, FIRST + DATA GCS ( 1) / .0085711955 90989331E0/ + DATA GCS ( 2) / .0044153813 24841007E0/ + DATA GCS ( 3) / .0568504368 1599363E0/ + DATA GCS ( 4) /-.0042198353 96418561E0/ + DATA GCS ( 5) / .0013268081 81212460E0/ + DATA GCS ( 6) /-.0001893024 529798880E0/ + DATA GCS ( 7) / .0000360692 532744124E0/ + DATA GCS ( 8) /-.0000060567 619044608E0/ + DATA GCS ( 9) / .0000010558 295463022E0/ + DATA GCS (10) /-.0000001811 967365542E0/ + DATA GCS (11) / .0000000311 772496471E0/ + DATA GCS (12) /-.0000000053 542196390E0/ + DATA GCS (13) / .0000000009 193275519E0/ + DATA GCS (14) /-.0000000001 577941280E0/ + DATA GCS (15) / .0000000000 270798062E0/ + DATA GCS (16) /-.0000000000 046468186E0/ + DATA GCS (17) / .0000000000 007973350E0/ + DATA GCS (18) /-.0000000000 001368078E0/ + DATA GCS (19) / .0000000000 000234731E0/ + DATA GCS (20) /-.0000000000 000040274E0/ + DATA GCS (21) / .0000000000 000006910E0/ + DATA GCS (22) /-.0000000000 000001185E0/ + DATA GCS (23) / .0000000000 000000203E0/ + DATA PI /3.14159 26535 89793 24E0/ +C SQ2PIL IS LOG (SQRT (2.*PI) ) + DATA SQ2PIL /0.91893 85332 04672 74E0/ + DATA FIRST /.TRUE./ +C +C LANL DEPENDENT CODE REMOVED 81.02.04 +C +C***FIRST EXECUTABLE STATEMENT GAMMA + IF (FIRST) THEN +C +C --------------------------------------------------------------------- +C INITIALIZE. FIND LEGAL BOUNDS FOR X, AND DETERMINE THE NUMBER OF +C TERMS IN THE SERIES REQUIRED TO ATTAIN AN ACCURACY TEN TIMES BETTER +C THAN MACHINE PRECISION. +C + NGCS = INITS (GCS, 23, 0.1*R1MACH(3)) +C + CALL GAMLIM (XMIN, XMAX) + DXREL = SQRT (R1MACH(4)) +C +C --------------------------------------------------------------------- +C FINISH INITIALIZATION. START EVALUATING GAMMA(X). +C + ENDIF + FIRST = .FALSE. +C + Y = ABS(X) + IF (Y.GT.10.0) GO TO 50 +C +C COMPUTE GAMMA(X) FOR ABS(X) .LE. 10.0. REDUCE INTERVAL AND +C FIND GAMMA(1+Y) FOR 0. .LE. Y .LT. 1. FIRST OF ALL. +C + N = X + IF (X.LT.0.) N = N - 1 + Y = X - N + N = N - 1 + GAMMA = 0.9375 + CSEVL(2.*Y-1., GCS, NGCS) + IF (N.EQ.0) RETURN +C + IF (N.GT.0) GO TO 30 +C +C COMPUTE GAMMA(X) FOR X .LT. 1. +C + N = -N + IF (X .EQ. 0.) CALL XERMSG ('SLATEC', 'GAMMA', 'X IS 0', 4, 2) + IF (X .LT. 0. .AND. X+N-2 .EQ. 0.) CALL XERMSG ('SLATEC', 'GAMMA' + 1, 'X IS A NEGATIVE INTEGER', 4, 2) + IF (X .LT. (-0.5) .AND. ABS((X-AINT(X-0.5))/X) .LT. DXREL) CALL + 1XERMSG ( 'SLATEC', 'GAMMA', + 2'ANSWER LT HALF PRECISION BECAUSE X TOO NEAR NEGATIVE INTEGER' + 3, 1, 1) +C + DO 20 I=1,N + GAMMA = GAMMA / (X+I-1) + 20 CONTINUE + RETURN +C +C GAMMA(X) FOR X .GE. 2. +C + 30 DO 40 I=1,N + GAMMA = (Y+I)*GAMMA + 40 CONTINUE + RETURN +C +C COMPUTE GAMMA(X) FOR ABS(X) .GT. 10.0. RECALL Y = ABS(X). +C + 50 IF (X .GT. XMAX) CALL XERMSG ('SLATEC', 'GAMMA', + + 'X SO BIG GAMMA OVERFLOWS', 3, 2) +C + GAMMA = 0. + IF (X .LT. XMIN) CALL XERMSG ('SLATEC', 'GAMMA', + + 'X SO SMALL GAMMA UNDERFLOWS', 2, 1) + IF (X.LT.XMIN) RETURN +C + GAMMA = EXP((Y-0.5)*LOG(Y) - Y + SQ2PIL + R9LGMC(Y) ) + IF (X.GT.0.) RETURN +C + IF (ABS((X-AINT(X-0.5))/X) .LT. DXREL) CALL XERMSG ('SLATEC', + + 'GAMMA', + + 'ANSWER LT HALF PRECISION, X TOO NEAR NEGATIVE INTEGER', 1, 1) +C + SINPIY = SIN (PI*Y) + IF (SINPIY .EQ. 0.) CALL XERMSG ('SLATEC', 'GAMMA', + + 'X IS A NEGATIVE INTEGER', 4, 2) +C + GAMMA = -PI / (Y*SINPIY*GAMMA) +C + RETURN + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/slatec-fn/gamr.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,42 @@ +*DECK GAMR + FUNCTION GAMR (X) +C***BEGIN PROLOGUE GAMR +C***PURPOSE Compute the reciprocal of the Gamma function. +C***LIBRARY SLATEC (FNLIB) +C***CATEGORY C7A +C***TYPE SINGLE PRECISION (GAMR-S, DGAMR-D, CGAMR-C) +C***KEYWORDS FNLIB, RECIPROCAL GAMMA FUNCTION, SPECIAL FUNCTIONS +C***AUTHOR Fullerton, W., (LANL) +C***DESCRIPTION +C +C GAMR is a single precision function that evaluates the reciprocal +C of the gamma function for single precision argument X. +C +C***REFERENCES (NONE) +C***ROUTINES CALLED ALGAMS, GAMMA, XERCLR, XGETF, XSETF +C***REVISION HISTORY (YYMMDD) +C 770701 DATE WRITTEN +C 861211 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900727 Added EXTERNAL statement. (WRB) +C***END PROLOGUE GAMR + EXTERNAL GAMMA +C***FIRST EXECUTABLE STATEMENT GAMR + GAMR = 0.0 + IF (X.LE.0.0 .AND. AINT(X).EQ.X) RETURN +C + CALL XGETF (IROLD) + CALL XSETF (1) + IF (ABS(X).GT.10.0) GO TO 10 + GAMR = 1.0/GAMMA(X) + CALL XERCLR + CALL XSETF (IROLD) + RETURN +C + 10 CALL ALGAMS (X, ALNGX, SGNGX) + CALL XERCLR + CALL XSETF (IROLD) + GAMR = SGNGX * EXP(-ALNGX) + RETURN +C + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/slatec-fn/initds.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,54 @@ +*DECK INITDS + FUNCTION INITDS (OS, NOS, ETA) +C***BEGIN PROLOGUE INITDS +C***PURPOSE Determine the number of terms needed in an orthogonal +C polynomial series so that it meets a specified accuracy. +C***LIBRARY SLATEC (FNLIB) +C***CATEGORY C3A2 +C***TYPE DOUBLE PRECISION (INITS-S, INITDS-D) +C***KEYWORDS CHEBYSHEV, FNLIB, INITIALIZE, ORTHOGONAL POLYNOMIAL, +C ORTHOGONAL SERIES, SPECIAL FUNCTIONS +C***AUTHOR Fullerton, W., (LANL) +C***DESCRIPTION +C +C Initialize the orthogonal series, represented by the array OS, so +C that INITDS is the number of terms needed to insure the error is no +C larger than ETA. Ordinarily, ETA will be chosen to be one-tenth +C machine precision. +C +C Input Arguments -- +C OS double precision array of NOS coefficients in an orthogonal +C series. +C NOS number of coefficients in OS. +C ETA single precision scalar containing requested accuracy of +C series. +C +C***REFERENCES (NONE) +C***ROUTINES CALLED XERMSG +C***REVISION HISTORY (YYMMDD) +C 770601 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890831 Modified array declarations. (WRB) +C 891115 Modified error message. (WRB) +C 891115 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C***END PROLOGUE INITDS + DOUBLE PRECISION OS(*) +C***FIRST EXECUTABLE STATEMENT INITDS + IF (NOS .LT. 1) CALL XERMSG ('SLATEC', 'INITDS', + + 'Number of coefficients is less than 1', 2, 1) +C + ERR = 0. + DO 10 II = 1,NOS + I = NOS + 1 - II + ERR = ERR + ABS(REAL(OS(I))) + IF (ERR.GT.ETA) GO TO 20 + 10 CONTINUE +C + 20 IF (I .EQ. NOS) CALL XERMSG ('SLATEC', 'INITDS', + + 'Chebyshev series too short for specified accuracy', 1, 1) + INITDS = I +C + RETURN + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/slatec-fn/inits.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,53 @@ +*DECK INITS + FUNCTION INITS (OS, NOS, ETA) +C***BEGIN PROLOGUE INITS +C***PURPOSE Determine the number of terms needed in an orthogonal +C polynomial series so that it meets a specified accuracy. +C***LIBRARY SLATEC (FNLIB) +C***CATEGORY C3A2 +C***TYPE SINGLE PRECISION (INITS-S, INITDS-D) +C***KEYWORDS CHEBYSHEV, FNLIB, INITIALIZE, ORTHOGONAL POLYNOMIAL, +C ORTHOGONAL SERIES, SPECIAL FUNCTIONS +C***AUTHOR Fullerton, W., (LANL) +C***DESCRIPTION +C +C Initialize the orthogonal series, represented by the array OS, so +C that INITS is the number of terms needed to insure the error is no +C larger than ETA. Ordinarily, ETA will be chosen to be one-tenth +C machine precision. +C +C Input Arguments -- +C OS single precision array of NOS coefficients in an orthogonal +C series. +C NOS number of coefficients in OS. +C ETA single precision scalar containing requested accuracy of +C series. +C +C***REFERENCES (NONE) +C***ROUTINES CALLED XERMSG +C***REVISION HISTORY (YYMMDD) +C 770401 DATE WRITTEN +C 890831 Modified array declarations. (WRB) +C 891115 Modified error message. (WRB) +C 891115 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C***END PROLOGUE INITS + REAL OS(*) +C***FIRST EXECUTABLE STATEMENT INITS + IF (NOS .LT. 1) CALL XERMSG ('SLATEC', 'INITS', + + 'Number of coefficients is less than 1', 2, 1) +C + ERR = 0. + DO 10 II = 1,NOS + I = NOS + 1 - II + ERR = ERR + ABS(OS(I)) + IF (ERR.GT.ETA) GO TO 20 + 10 CONTINUE +C + 20 IF (I .EQ. NOS) CALL XERMSG ('SLATEC', 'INITS', + + 'Chebyshev series too short for specified accuracy', 1, 1) + INITS = I +C + RETURN + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/slatec-fn/module.mk Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,81 @@ +EXTERNAL_SOURCES += \ + liboctave/external/slatec-fn/albeta.f \ + liboctave/external/slatec-fn/alngam.f \ + liboctave/external/slatec-fn/alnrel.f \ + liboctave/external/slatec-fn/algams.f \ + liboctave/external/slatec-fn/acosh.f \ + liboctave/external/slatec-fn/asinh.f \ + liboctave/external/slatec-fn/atanh.f \ + liboctave/external/slatec-fn/betai.f \ + liboctave/external/slatec-fn/csevl.f \ + liboctave/external/slatec-fn/d9gmit.f \ + liboctave/external/slatec-fn/d9lgic.f \ + liboctave/external/slatec-fn/d9lgit.f \ + liboctave/external/slatec-fn/d9lgmc.f \ + liboctave/external/slatec-fn/dacosh.f \ + liboctave/external/slatec-fn/dasinh.f \ + liboctave/external/slatec-fn/datanh.f \ + liboctave/external/slatec-fn/dbetai.f \ + liboctave/external/slatec-fn/dcsevl.f \ + liboctave/external/slatec-fn/derf.f \ + liboctave/external/slatec-fn/dgami.f \ + liboctave/external/slatec-fn/dgamit.f \ + liboctave/external/slatec-fn/dgamlm.f \ + liboctave/external/slatec-fn/dgamma.f \ + liboctave/external/slatec-fn/dgamr.f \ + liboctave/external/slatec-fn/dlbeta.f \ + liboctave/external/slatec-fn/dlgams.f \ + liboctave/external/slatec-fn/dlngam.f \ + liboctave/external/slatec-fn/dlnrel.f \ + liboctave/external/slatec-fn/dpchim.f \ + liboctave/external/slatec-fn/dpchst.f \ + liboctave/external/slatec-fn/dpsifn.f \ + liboctave/external/slatec-fn/erf.f \ + liboctave/external/slatec-fn/gami.f \ + liboctave/external/slatec-fn/gamit.f \ + liboctave/external/slatec-fn/gamlim.f \ + liboctave/external/slatec-fn/gamma.f \ + liboctave/external/slatec-fn/gamr.f \ + liboctave/external/slatec-fn/initds.f \ + liboctave/external/slatec-fn/inits.f \ + liboctave/external/slatec-fn/pchim.f \ + liboctave/external/slatec-fn/pchst.f \ + liboctave/external/slatec-fn/psifn.f \ + liboctave/external/slatec-fn/r9lgmc.f \ + liboctave/external/slatec-fn/r9lgit.f \ + liboctave/external/slatec-fn/r9gmit.f \ + liboctave/external/slatec-fn/r9lgic.f \ + liboctave/external/slatec-fn/xdacosh.f \ + liboctave/external/slatec-fn/xdasinh.f \ + liboctave/external/slatec-fn/xdatanh.f \ + liboctave/external/slatec-fn/xdbetai.f \ + liboctave/external/slatec-fn/xderf.f \ + liboctave/external/slatec-fn/xderfc.f \ + liboctave/external/slatec-fn/xdgami.f \ + liboctave/external/slatec-fn/xdgamit.f \ + liboctave/external/slatec-fn/xdgamma.f \ + liboctave/external/slatec-fn/xgmainc.f \ + liboctave/external/slatec-fn/xacosh.f \ + liboctave/external/slatec-fn/xasinh.f \ + liboctave/external/slatec-fn/xatanh.f \ + liboctave/external/slatec-fn/xerf.f \ + liboctave/external/slatec-fn/xerfc.f \ + liboctave/external/slatec-fn/xsgmainc.f \ + liboctave/external/slatec-fn/xgamma.f \ + liboctave/external/slatec-fn/xbetai.f + +nodist_liboctave_external_libexternal_la_SOURCES += \ + liboctave/external/slatec-fn/derfc.f \ + liboctave/external/slatec-fn/erfc.f + +liboctave/external/slatec-fn/erfc.f: liboctave/external/slatec-fn/erfc.in.f build-aux/subst-f77-isnan-macro.sh | liboctave/external/slatec-fn/$(octave_dirstamp) + $(AM_V_GEN)$(call simple-filter-rule,build-aux/subst-f77-isnan-macro.sh) + +liboctave/external/slatec-fn/derfc.f: liboctave/external/slatec-fn/derfc.in.f build-aux/subst-f77-isnan-macro.sh | liboctave/external/slatec-fn/$(octave_dirstamp) + $(AM_V_GEN)$(call simple-filter-rule,build-aux/subst-f77-isnan-macro.sh) + +liboctave_EXTRA_DIST += \ + liboctave/external/slatec-fn/derfc.in.f \ + liboctave/external/slatec-fn/erfc.in.f + +DIRSTAMP_FILES += liboctave/external/slatec-fn/$(octave_dirstamp)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/slatec-fn/pchim.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,280 @@ +*DECK PCHIM + SUBROUTINE PCHIM (N, X, F, D, INCFD, IERR) +C***BEGIN PROLOGUE PCHIM +C***PURPOSE Set derivatives needed to determine a monotone piecewise +C cubic Hermite interpolant to given data. Boundary values +C are provided which are compatible with monotonicity. The +C interpolant will have an extremum at each point where mono- +C tonicity switches direction. (See PCHIC if user control is +C desired over boundary or switch conditions.) +C***LIBRARY SLATEC (PCHIP) +C***CATEGORY E1A +C***TYPE SINGLE PRECISION (PCHIM-S, DPCHIM-D) +C***KEYWORDS CUBIC HERMITE INTERPOLATION, MONOTONE INTERPOLATION, +C PCHIP, PIECEWISE CUBIC INTERPOLATION +C***AUTHOR Fritsch, F. N., (LLNL) +C Lawrence Livermore National Laboratory +C P.O. Box 808 (L-316) +C Livermore, CA 94550 +C FTS 532-4275, (510) 422-4275 +C***DESCRIPTION +C +C PCHIM: Piecewise Cubic Hermite Interpolation to +C Monotone data. +C +C Sets derivatives needed to determine a monotone piecewise cubic +C Hermite interpolant to the data given in X and F. +C +C Default boundary conditions are provided which are compatible +C with monotonicity. (See PCHIC if user control of boundary con- +C ditions is desired.) +C +C If the data are only piecewise monotonic, the interpolant will +C have an extremum at each point where monotonicity switches direc- +C tion. (See PCHIC if user control is desired in such cases.) +C +C To facilitate two-dimensional applications, includes an increment +C between successive values of the F- and D-arrays. +C +C The resulting piecewise cubic Hermite function may be evaluated +C by PCHFE or PCHFD. +C +C ---------------------------------------------------------------------- +C +C Calling sequence: +C +C PARAMETER (INCFD = ...) +C INTEGER N, IERR +C REAL X(N), F(INCFD,N), D(INCFD,N) +C +C CALL PCHIM (N, X, F, D, INCFD, IERR) +C +C Parameters: +C +C N -- (input) number of data points. (Error return if N.LT.2 .) +C If N=2, simply does linear interpolation. +C +C X -- (input) real array of independent variable values. The +C elements of X must be strictly increasing: +C X(I-1) .LT. X(I), I = 2(1)N. +C (Error return if not.) +C +C F -- (input) real array of dependent variable values to be inter- +C polated. F(1+(I-1)*INCFD) is value corresponding to X(I). +C PCHIM is designed for monotonic data, but it will work for +C any F-array. It will force extrema at points where mono- +C tonicity switches direction. If some other treatment of +C switch points is desired, PCHIC should be used instead. +C ----- +C D -- (output) real array of derivative values at the data points. +C If the data are monotonic, these values will determine a +C a monotone cubic Hermite function. +C The value corresponding to X(I) is stored in +C D(1+(I-1)*INCFD), I=1(1)N. +C No other entries in D are changed. +C +C INCFD -- (input) increment between successive values in F and D. +C This argument is provided primarily for 2-D applications. +C (Error return if INCFD.LT.1 .) +C +C IERR -- (output) error flag. +C Normal return: +C IERR = 0 (no errors). +C Warning error: +C IERR.GT.0 means that IERR switches in the direction +C of monotonicity were detected. +C "Recoverable" errors: +C IERR = -1 if N.LT.2 . +C IERR = -2 if INCFD.LT.1 . +C IERR = -3 if the X-array is not strictly increasing. +C (The D-array has not been changed in any of these cases.) +C NOTE: The above errors are checked in the order listed, +C and following arguments have **NOT** been validated. +C +C***REFERENCES 1. F. N. Fritsch and J. Butland, A method for construc- +C ting local monotone piecewise cubic interpolants, SIAM +C Journal on Scientific and Statistical Computing 5, 2 +C (June 1984), pp. 300-304. +C 2. F. N. Fritsch and R. E. Carlson, Monotone piecewise +C cubic interpolation, SIAM Journal on Numerical Ana- +C lysis 17, 2 (April 1980), pp. 238-246. +C***ROUTINES CALLED PCHST, XERMSG +C***REVISION HISTORY (YYMMDD) +C 811103 DATE WRITTEN +C 820201 1. Introduced PCHST to reduce possible over/under- +C flow problems. +C 2. Rearranged derivative formula for same reason. +C 820602 1. Modified end conditions to be continuous functions +C of data when monotonicity switches in next interval. +C 2. Modified formulas so end conditions are less prone +C of over/underflow problems. +C 820803 Minor cosmetic changes for release 1. +C 870813 Updated Reference 1. +C 890411 Added SAVE statements (Vers. 3.2). +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890703 Corrected category record. (WRB) +C 890831 Modified array declarations. (WRB) +C 890831 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C 920429 Revised format and order of references. (WRB,FNF) +C***END PROLOGUE PCHIM +C Programming notes: +C +C 1. The function PCHST(ARG1,ARG2) is assumed to return zero if +C either argument is zero, +1 if they are of the same sign, and +C -1 if they are of opposite sign. +C 2. To produce a double precision version, simply: +C a. Change PCHIM to DPCHIM wherever it occurs, +C b. Change PCHST to DPCHST wherever it occurs, +C c. Change all references to the Fortran intrinsics to their +C double precision equivalents, +C d. Change the real declarations to double precision, and +C e. Change the constants ZERO and THREE to double precision. +C +C DECLARE ARGUMENTS. +C + INTEGER N, INCFD, IERR + REAL X(*), F(INCFD,*), D(INCFD,*) +C +C DECLARE LOCAL VARIABLES. +C + INTEGER I, NLESS1 + REAL DEL1, DEL2, DMAX, DMIN, DRAT1, DRAT2, DSAVE, + * H1, H2, HSUM, HSUMT3, THREE, W1, W2, ZERO + SAVE ZERO, THREE + REAL PCHST + DATA ZERO /0./, THREE /3./ +C +C VALIDITY-CHECK ARGUMENTS. +C +C***FIRST EXECUTABLE STATEMENT PCHIM + IF ( N.LT.2 ) GO TO 5001 + IF ( INCFD.LT.1 ) GO TO 5002 + DO 1 I = 2, N + IF ( X(I).LE.X(I-1) ) GO TO 5003 + 1 CONTINUE +C +C FUNCTION DEFINITION IS OK, GO ON. +C + IERR = 0 + NLESS1 = N - 1 + H1 = X(2) - X(1) + DEL1 = (F(1,2) - F(1,1))/H1 + DSAVE = DEL1 +C +C SPECIAL CASE N=2 -- USE LINEAR INTERPOLATION. +C + IF (NLESS1 .GT. 1) GO TO 10 + D(1,1) = DEL1 + D(1,N) = DEL1 + GO TO 5000 +C +C NORMAL CASE (N .GE. 3). +C + 10 CONTINUE + H2 = X(3) - X(2) + DEL2 = (F(1,3) - F(1,2))/H2 +C +C SET D(1) VIA NON-CENTERED THREE-POINT FORMULA, ADJUSTED TO BE +C SHAPE-PRESERVING. +C + HSUM = H1 + H2 + W1 = (H1 + HSUM)/HSUM + W2 = -H1/HSUM + D(1,1) = W1*DEL1 + W2*DEL2 + IF ( PCHST(D(1,1),DEL1) .LE. ZERO) THEN + D(1,1) = ZERO + ELSE IF ( PCHST(DEL1,DEL2) .LT. ZERO) THEN +C NEED DO THIS CHECK ONLY IF MONOTONICITY SWITCHES. + DMAX = THREE*DEL1 + IF (ABS(D(1,1)) .GT. ABS(DMAX)) D(1,1) = DMAX + ENDIF +C +C LOOP THROUGH INTERIOR POINTS. +C + DO 50 I = 2, NLESS1 + IF (I .EQ. 2) GO TO 40 +C + H1 = H2 + H2 = X(I+1) - X(I) + HSUM = H1 + H2 + DEL1 = DEL2 + DEL2 = (F(1,I+1) - F(1,I))/H2 + 40 CONTINUE +C +C SET D(I)=0 UNLESS DATA ARE STRICTLY MONOTONIC. +C + D(1,I) = ZERO + IF ( PCHST(DEL1,DEL2) ) 42, 41, 45 +C +C COUNT NUMBER OF CHANGES IN DIRECTION OF MONOTONICITY. +C + 41 CONTINUE + IF (DEL2 .EQ. ZERO) GO TO 50 + IF ( PCHST(DSAVE,DEL2) .LT. ZERO) IERR = IERR + 1 + DSAVE = DEL2 + GO TO 50 +C + 42 CONTINUE + IERR = IERR + 1 + DSAVE = DEL2 + GO TO 50 +C +C USE BRODLIE MODIFICATION OF BUTLAND FORMULA. +C + 45 CONTINUE + HSUMT3 = HSUM+HSUM+HSUM + W1 = (HSUM + H1)/HSUMT3 + W2 = (HSUM + H2)/HSUMT3 + DMAX = MAX( ABS(DEL1), ABS(DEL2) ) + DMIN = MIN( ABS(DEL1), ABS(DEL2) ) + DRAT1 = DEL1/DMAX + DRAT2 = DEL2/DMAX + D(1,I) = DMIN/(W1*DRAT1 + W2*DRAT2) +C + 50 CONTINUE +C +C SET D(N) VIA NON-CENTERED THREE-POINT FORMULA, ADJUSTED TO BE +C SHAPE-PRESERVING. +C + W1 = -H2/HSUM + W2 = (H2 + HSUM)/HSUM + D(1,N) = W1*DEL1 + W2*DEL2 + IF ( PCHST(D(1,N),DEL2) .LE. ZERO) THEN + D(1,N) = ZERO + ELSE IF ( PCHST(DEL1,DEL2) .LT. ZERO) THEN +C NEED DO THIS CHECK ONLY IF MONOTONICITY SWITCHES. + DMAX = THREE*DEL2 + IF (ABS(D(1,N)) .GT. ABS(DMAX)) D(1,N) = DMAX + ENDIF +C +C NORMAL RETURN. +C + 5000 CONTINUE + RETURN +C +C ERROR RETURNS. +C + 5001 CONTINUE +C N.LT.2 RETURN. + IERR = -1 + CALL XERMSG ('SLATEC', 'PCHIM', + + 'NUMBER OF DATA POINTS LESS THAN TWO', IERR, 1) + RETURN +C + 5002 CONTINUE +C INCFD.LT.1 RETURN. + IERR = -2 + CALL XERMSG ('SLATEC', 'PCHIM', 'INCREMENT LESS THAN ONE', IERR, + + 1) + RETURN +C + 5003 CONTINUE +C X-ARRAY NOT STRICTLY INCREASING. + IERR = -3 + CALL XERMSG ('SLATEC', 'PCHIM', 'X-ARRAY NOT STRICTLY INCREASING' + + , IERR, 1) + RETURN +C------------- LAST LINE OF PCHIM FOLLOWS ------------------------------ + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/slatec-fn/pchst.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,57 @@ +*DECK PCHST + REAL FUNCTION PCHST (ARG1, ARG2) +C***BEGIN PROLOGUE PCHST +C***SUBSIDIARY +C***PURPOSE PCHIP Sign-Testing Routine +C***LIBRARY SLATEC (PCHIP) +C***TYPE SINGLE PRECISION (PCHST-S, DPCHST-D) +C***AUTHOR Fritsch, F. N., (LLNL) +C***DESCRIPTION +C +C PCHST: PCHIP Sign-Testing Routine. +C +C Returns: +C -1. if ARG1 and ARG2 are of opposite sign. +C 0. if either argument is zero. +C +1. if ARG1 and ARG2 are of the same sign. +C +C The object is to do this without multiplying ARG1*ARG2, to avoid +C possible over/underflow problems. +C +C Fortran intrinsics used: SIGN. +C +C***SEE ALSO PCHCE, PCHCI, PCHCS, PCHIM +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 811103 DATE WRITTEN +C 820805 Converted to SLATEC library version. +C 870813 Minor cosmetic changes. +C 890411 Added SAVE statements (Vers. 3.2). +C 890411 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900328 Added TYPE section. (WRB) +C 910408 Updated AUTHOR and DATE WRITTEN sections in prologue. (WRB) +C 930503 Improved purpose. (FNF) +C***END PROLOGUE PCHST +C +C**End +C +C DECLARE ARGUMENTS. +C + REAL ARG1, ARG2 +C +C DECLARE LOCAL VARIABLES. +C + REAL ONE, ZERO + SAVE ZERO, ONE + DATA ZERO /0./, ONE /1./ +C +C PERFORM THE TEST. +C +C***FIRST EXECUTABLE STATEMENT PCHST + PCHST = SIGN(ONE,ARG1) * SIGN(ONE,ARG2) + IF ((ARG1.EQ.ZERO) .OR. (ARG2.EQ.ZERO)) PCHST = ZERO +C + RETURN +C------------- LAST LINE OF PCHST FOLLOWS ------------------------------ + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/slatec-fn/psifn.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,368 @@ +*DECK PSIFN + SUBROUTINE PSIFN (X, N, KODE, M, ANS, NZ, IERR) +C***BEGIN PROLOGUE PSIFN +C***PURPOSE Compute derivatives of the Psi function. +C***LIBRARY SLATEC +C***CATEGORY C7C +C***TYPE SINGLE PRECISION (PSIFN-S, DPSIFN-D) +C***KEYWORDS DERIVATIVES OF THE GAMMA FUNCTION, POLYGAMMA FUNCTION, +C PSI FUNCTION +C***AUTHOR Amos, D. E., (SNLA) +C***DESCRIPTION +C +C The following definitions are used in PSIFN: +C +C Definition 1 +C PSI(X) = d/dx (ln(GAMMA(X)), the first derivative of +C the LOG GAMMA function. +C Definition 2 +C K K +C PSI(K,X) = d /dx (PSI(X)), the K-th derivative of PSI(X). +C ___________________________________________________________________ +C PSIFN computes a sequence of SCALED derivatives of +C the PSI function; i.e. for fixed X and M it computes +C the M-member sequence +C +C ((-1)**(K+1)/GAMMA(K+1))*PSI(K,X) +C for K = N,...,N+M-1 +C +C where PSI(K,X) is as defined above. For KODE=1, PSIFN returns +C the scaled derivatives as described. KODE=2 is operative only +C when K=0 and in that case PSIFN returns -PSI(X) + LN(X). That +C is, the logarithmic behavior for large X is removed when KODE=1 +C and K=0. When sums or differences of PSI functions are computed +C the logarithmic terms can be combined analytically and computed +C separately to help retain significant digits. +C +C Note that CALL PSIFN(X,0,1,1,ANS) results in +C ANS = -PSI(X) +C +C Input +C X - Argument, X .gt. 0.0E0 +C N - First member of the sequence, 0 .le. N .le. 100 +C N=0 gives ANS(1) = -PSI(X) for KODE=1 +C -PSI(X)+LN(X) for KODE=2 +C KODE - Selection parameter +C KODE=1 returns scaled derivatives of the PSI +C function. +C KODE=2 returns scaled derivatives of the PSI +C function EXCEPT when N=0. In this case, +C ANS(1) = -PSI(X) + LN(X) is returned. +C M - Number of members of the sequence, M .ge. 1 +C +C Output +C ANS - A vector of length at least M whose first M +C components contain the sequence of derivatives +C scaled according to KODE. +C NZ - Underflow flag +C NZ.eq.0, A normal return +C NZ.ne.0, Underflow, last NZ components of ANS are +C set to zero, ANS(M-K+1)=0.0, K=1,...,NZ +C IERR - Error flag +C IERR=0, A normal return, computation completed +C IERR=1, Input error, no computation +C IERR=2, Overflow, X too small or N+M-1 too +C large or both +C IERR=3, Error, N too large. Dimensioned +C array TRMR(NMAX) is not large enough for N +C +C The nominal computational accuracy is the maximum of unit +C roundoff (=R1MACH(4)) and 1.0E-18 since critical constants +C are given to only 18 digits. +C +C DPSIFN is the Double Precision version of PSIFN. +C +C *Long Description: +C +C The basic method of evaluation is the asymptotic expansion +C for large X.ge.XMIN followed by backward recursion on a two +C term recursion relation +C +C W(X+1) + X**(-N-1) = W(X). +C +C This is supplemented by a series +C +C SUM( (X+K)**(-N-1) , K=0,1,2,... ) +C +C which converges rapidly for large N. Both XMIN and the +C number of terms of the series are calculated from the unit +C roundoff of the machine environment. +C +C***REFERENCES Handbook of Mathematical Functions, National Bureau +C of Standards Applied Mathematics Series 55, edited +C by M. Abramowitz and I. A. Stegun, equations 6.3.5, +C 6.3.18, 6.4.6, 6.4.9 and 6.4.10, pp.258-260, 1964. +C D. E. Amos, A portable Fortran subroutine for +C derivatives of the Psi function, Algorithm 610, ACM +C Transactions on Mathematical Software 9, 4 (1983), +C pp. 494-502. +C***ROUTINES CALLED I1MACH, R1MACH +C***REVISION HISTORY (YYMMDD) +C 820601 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890531 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE PSIFN + INTEGER I, IERR, J, K, KODE, M, MM, MX, N, NMAX, NN, NP, NX, NZ + INTEGER I1MACH + REAL ANS, ARG, B, DEN, ELIM, EPS, FLN, FN, FNP, FNS, FX, RLN, + * RXSQ, R1M4, R1M5, S, SLOPE, T, TA, TK, TOL, TOLS, TRM, TRMR, + * TSS, TST, TT, T1, T2, WDTOL, X, XDMLN, XDMY, XINC, XLN, XM, + * XMIN, XQ, YINT + REAL R1MACH + DIMENSION B(22), TRM(22), TRMR(100), ANS(*) + SAVE NMAX, B + DATA NMAX /100/ +C----------------------------------------------------------------------- +C BERNOULLI NUMBERS +C----------------------------------------------------------------------- + DATA B(1), B(2), B(3), B(4), B(5), B(6), B(7), B(8), B(9), B(10), + * B(11), B(12), B(13), B(14), B(15), B(16), B(17), B(18), B(19), + * B(20), B(21), B(22) /1.00000000000000000E+00, + * -5.00000000000000000E-01,1.66666666666666667E-01, + * -3.33333333333333333E-02,2.38095238095238095E-02, + * -3.33333333333333333E-02,7.57575757575757576E-02, + * -2.53113553113553114E-01,1.16666666666666667E+00, + * -7.09215686274509804E+00,5.49711779448621554E+01, + * -5.29124242424242424E+02,6.19212318840579710E+03, + * -8.65802531135531136E+04,1.42551716666666667E+06, + * -2.72982310678160920E+07,6.01580873900642368E+08, + * -1.51163157670921569E+10,4.29614643061166667E+11, + * -1.37116552050883328E+13,4.88332318973593167E+14, + * -1.92965793419400681E+16/ +C +C***FIRST EXECUTABLE STATEMENT PSIFN + IERR = 0 + NZ=0 + IF (X.LE.0.0E0) IERR=1 + IF (N.LT.0) IERR=1 + IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1 + IF (M.LT.1) IERR=1 + IF (IERR.NE.0) RETURN + MM=M + NX = MIN(-I1MACH(12),I1MACH(13)) + R1M5 = R1MACH(5) + R1M4 = R1MACH(4)*0.5E0 + WDTOL = MAX(R1M4,0.5E-18) +C----------------------------------------------------------------------- +C ELIM = APPROXIMATE EXPONENTIAL OVER AND UNDERFLOW LIMIT +C----------------------------------------------------------------------- + ELIM = 2.302E0*(NX*R1M5-3.0E0) + XLN = LOG(X) + 41 CONTINUE + NN = N + MM - 1 + FN = NN + FNP = FN + 1.0E0 + T = FNP*XLN +C----------------------------------------------------------------------- +C OVERFLOW AND UNDERFLOW TEST FOR SMALL AND LARGE X +C----------------------------------------------------------------------- + IF (ABS(T).GT.ELIM) GO TO 290 + IF (X.LT.WDTOL) GO TO 260 +C----------------------------------------------------------------------- +C COMPUTE XMIN AND THE NUMBER OF TERMS OF THE SERIES, FLN+1 +C----------------------------------------------------------------------- + RLN = R1M5*I1MACH(11) + RLN = MIN(RLN,18.06E0) + FLN = MAX(RLN,3.0E0) - 3.0E0 + YINT = 3.50E0 + 0.40E0*FLN + SLOPE = 0.21E0 + FLN*(0.0006038E0*FLN+0.008677E0) + XM = YINT + SLOPE*FN + MX = INT(XM) + 1 + XMIN = MX + IF (N.EQ.0) GO TO 50 + XM = -2.302E0*RLN - MIN(0.0E0,XLN) + FNS = N + ARG = XM/FNS + ARG = MIN(0.0E0,ARG) + EPS = EXP(ARG) + XM = 1.0E0 - EPS + IF (ABS(ARG).LT.1.0E-3) XM = -ARG + FLN = X*XM/EPS + XM = XMIN - X + IF (XM.GT.7.0E0 .AND. FLN.LT.15.0E0) GO TO 200 + 50 CONTINUE + XDMY = X + XDMLN = XLN + XINC = 0.0E0 + IF (X.GE.XMIN) GO TO 60 + NX = INT(X) + XINC = XMIN - NX + XDMY = X + XINC + XDMLN = LOG(XDMY) + 60 CONTINUE +C----------------------------------------------------------------------- +C GENERATE W(N+MM-1,X) BY THE ASYMPTOTIC EXPANSION +C----------------------------------------------------------------------- + T = FN*XDMLN + T1 = XDMLN + XDMLN + T2 = T + XDMLN + TK = MAX(ABS(T),ABS(T1),ABS(T2)) + IF (TK.GT.ELIM) GO TO 380 + TSS = EXP(-T) + TT = 0.5E0/XDMY + T1 = TT + TST = WDTOL*TT + IF (NN.NE.0) T1 = TT + 1.0E0/FN + RXSQ = 1.0E0/(XDMY*XDMY) + TA = 0.5E0*RXSQ + T = FNP*TA + S = T*B(3) + IF (ABS(S).LT.TST) GO TO 80 + TK = 2.0E0 + DO 70 K=4,22 + T = T*((TK+FN+1.0E0)/(TK+1.0E0))*((TK+FN)/(TK+2.0E0))*RXSQ + TRM(K) = T*B(K) + IF (ABS(TRM(K)).LT.TST) GO TO 80 + S = S + TRM(K) + TK = TK + 2.0E0 + 70 CONTINUE + 80 CONTINUE + S = (S+T1)*TSS + IF (XINC.EQ.0.0E0) GO TO 100 +C----------------------------------------------------------------------- +C BACKWARD RECUR FROM XDMY TO X +C----------------------------------------------------------------------- + NX = INT(XINC) + NP = NN + 1 + IF (NX.GT.NMAX) GO TO 390 + IF (NN.EQ.0) GO TO 160 + XM = XINC - 1.0E0 + FX = X + XM +C----------------------------------------------------------------------- +C THIS LOOP SHOULD NOT BE CHANGED. FX IS ACCURATE WHEN X IS SMALL +C----------------------------------------------------------------------- + DO 90 I=1,NX + TRMR(I) = FX**(-NP) + S = S + TRMR(I) + XM = XM - 1.0E0 + FX = X + XM + 90 CONTINUE + 100 CONTINUE + ANS(MM) = S + IF (FN.EQ.0.0E0) GO TO 180 +C----------------------------------------------------------------------- +C GENERATE LOWER DERIVATIVES, J.LT.N+MM-1 +C----------------------------------------------------------------------- + IF (MM.EQ.1) RETURN + DO 150 J=2,MM + FNP = FN + FN = FN - 1.0E0 + TSS = TSS*XDMY + T1 = TT + IF (FN.NE.0.0E0) T1 = TT + 1.0E0/FN + T = FNP*TA + S = T*B(3) + IF (ABS(S).LT.TST) GO TO 120 + TK = 3.0E0 + FNP + DO 110 K=4,22 + TRM(K) = TRM(K)*FNP/TK + IF (ABS(TRM(K)).LT.TST) GO TO 120 + S = S + TRM(K) + TK = TK + 2.0E0 + 110 CONTINUE + 120 CONTINUE + S = (S+T1)*TSS + IF (XINC.EQ.0.0E0) GO TO 140 + IF (FN.EQ.0.0E0) GO TO 160 + XM = XINC - 1.0E0 + FX = X + XM + DO 130 I=1,NX + TRMR(I) = TRMR(I)*FX + S = S + TRMR(I) + XM = XM - 1.0E0 + FX = X + XM + 130 CONTINUE + 140 CONTINUE + MX = MM - J + 1 + ANS(MX) = S + IF (FN.EQ.0.0E0) GO TO 180 + 150 CONTINUE + RETURN +C----------------------------------------------------------------------- +C RECURSION FOR N = 0 +C----------------------------------------------------------------------- + 160 CONTINUE + DO 170 I=1,NX + S = S + 1.0E0/(X+NX-I) + 170 CONTINUE + 180 CONTINUE + IF (KODE.EQ.2) GO TO 190 + ANS(1) = S - XDMLN + RETURN + 190 CONTINUE + IF (XDMY.EQ.X) RETURN + XQ = XDMY/X + ANS(1) = S - LOG(XQ) + RETURN +C----------------------------------------------------------------------- +C COMPUTE BY SERIES (X+K)**(-(N+1)) , K=0,1,2,... +C----------------------------------------------------------------------- + 200 CONTINUE + NN = INT(FLN) + 1 + NP = N + 1 + T1 = (FNS+1.0E0)*XLN + T = EXP(-T1) + S = T + DEN = X + DO 210 I=1,NN + DEN = DEN + 1.0E0 + TRM(I) = DEN**(-NP) + S = S + TRM(I) + 210 CONTINUE + ANS(1) = S + IF (N.NE.0) GO TO 220 + IF (KODE.EQ.2) ANS(1) = S + XLN + 220 CONTINUE + IF (MM.EQ.1) RETURN +C----------------------------------------------------------------------- +C GENERATE HIGHER DERIVATIVES, J.GT.N +C----------------------------------------------------------------------- + TOL = WDTOL/5.0E0 + DO 250 J=2,MM + T = T/X + S = T + TOLS = T*TOL + DEN = X + DO 230 I=1,NN + DEN = DEN + 1.0E0 + TRM(I) = TRM(I)/DEN + S = S + TRM(I) + IF (TRM(I).LT.TOLS) GO TO 240 + 230 CONTINUE + 240 CONTINUE + ANS(J) = S + 250 CONTINUE + RETURN +C----------------------------------------------------------------------- +C SMALL X.LT.UNIT ROUND OFF +C----------------------------------------------------------------------- + 260 CONTINUE + ANS(1) = X**(-N-1) + IF (MM.EQ.1) GO TO 280 + K = 1 + DO 270 I=2,MM + ANS(K+1) = ANS(K)/X + K = K + 1 + 270 CONTINUE + 280 CONTINUE + IF (N.NE.0) RETURN + IF (KODE.EQ.2) ANS(1) = ANS(1) + XLN + RETURN + 290 CONTINUE + IF (T.GT.0.0E0) GO TO 380 + NZ=0 + IERR=2 + RETURN + 380 CONTINUE + NZ=NZ+1 + ANS(MM)=0.0E0 + MM=MM-1 + IF(MM.EQ.0) RETURN + GO TO 41 + 390 CONTINUE + IERR=3 + NZ=0 + RETURN + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/slatec-fn/r9gmit.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,84 @@ +*DECK R9GMIT + FUNCTION R9GMIT (A, X, ALGAP1, SGNGAM, ALX) +C***BEGIN PROLOGUE R9GMIT +C***SUBSIDIARY +C***PURPOSE Compute Tricomi's incomplete Gamma function for small +C arguments. +C***LIBRARY SLATEC (FNLIB) +C***CATEGORY C7E +C***TYPE SINGLE PRECISION (R9GMIT-S, D9GMIT-D) +C***KEYWORDS COMPLEMENTARY INCOMPLETE GAMMA FUNCTION, FNLIB, SMALL X, +C SPECIAL FUNCTIONS, TRICOMI +C***AUTHOR Fullerton, W., (LANL) +C***DESCRIPTION +C +C Compute Tricomi's incomplete gamma function for small X. +C +C***REFERENCES (NONE) +C***ROUTINES CALLED ALNGAM, R1MACH, XERMSG +C***REVISION HISTORY (YYMMDD) +C 770701 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890531 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C 900720 Routine changed from user-callable to subsidiary. (WRB) +C***END PROLOGUE R9GMIT + SAVE EPS, BOT + DATA EPS, BOT / 2*0.0 / +C***FIRST EXECUTABLE STATEMENT R9GMIT + IF (EPS.EQ.0.0) EPS = 0.5*R1MACH(3) + IF (BOT.EQ.0.0) BOT = LOG(R1MACH(1)) +C + IF (X .LE. 0.0) CALL XERMSG ('SLATEC', 'R9GMIT', + + 'X SHOULD BE GT 0', 1, 2) +C + MA = A + 0.5 + IF (A.LT.0.0) MA = A - 0.5 + AEPS = A - MA +C + AE = A + IF (A.LT.(-0.5)) AE = AEPS +C + T = 1.0 + TE = AE + S = T + DO 20 K=1,200 + FK = K + TE = -X*TE/FK + T = TE/(AE+FK) + S = S + T + IF (ABS(T).LT.EPS*ABS(S)) GO TO 30 + 20 CONTINUE + CALL XERMSG ('SLATEC', 'R9GMIT', + + 'NO CONVERGENCE IN 200 TERMS OF TAYLOR-S SERIES', 2, 2) +C + 30 IF (A.GE.(-0.5)) ALGS = -ALGAP1 + LOG(S) + IF (A.GE.(-0.5)) GO TO 60 +C + ALGS = -ALNGAM(1.0+AEPS) + LOG(S) + S = 1.0 + M = -MA - 1 + IF (M.EQ.0) GO TO 50 + T = 1.0 + DO 40 K=1,M + T = X*T/(AEPS-M-1+K) + S = S + T + IF (ABS(T).LT.EPS*ABS(S)) GO TO 50 + 40 CONTINUE +C + 50 R9GMIT = 0.0 + ALGS = -MA*LOG(X) + ALGS + IF (S.EQ.0.0 .OR. AEPS.EQ.0.0) GO TO 60 +C + SGNG2 = SGNGAM*SIGN(1.0,S) + ALG2 = -X - ALGAP1 + LOG(ABS(S)) +C + IF (ALG2.GT.BOT) R9GMIT = SGNG2*EXP(ALG2) + IF (ALGS.GT.BOT) R9GMIT = R9GMIT + EXP(ALGS) + RETURN +C + 60 R9GMIT = EXP(ALGS) + RETURN +C + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/slatec-fn/r9lgic.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,53 @@ +*DECK R9LGIC + FUNCTION R9LGIC (A, X, ALX) +C***BEGIN PROLOGUE R9LGIC +C***SUBSIDIARY +C***PURPOSE Compute the log complementary incomplete Gamma function +C for large X and for A .LE. X. +C***LIBRARY SLATEC (FNLIB) +C***CATEGORY C7E +C***TYPE SINGLE PRECISION (R9LGIC-S, D9LGIC-D) +C***KEYWORDS COMPLEMENTARY INCOMPLETE GAMMA FUNCTION, FNLIB, LARGE X, +C LOGARITHM, SPECIAL FUNCTIONS +C***AUTHOR Fullerton, W., (LANL) +C***DESCRIPTION +C +C Compute the log complementary incomplete gamma function for large X +C and for A .LE. X. +C +C***REFERENCES (NONE) +C***ROUTINES CALLED R1MACH, XERMSG +C***REVISION HISTORY (YYMMDD) +C 770701 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890531 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C 900720 Routine changed from user-callable to subsidiary. (WRB) +C***END PROLOGUE R9LGIC + SAVE EPS + DATA EPS / 0.0 / +C***FIRST EXECUTABLE STATEMENT R9LGIC + IF (EPS.EQ.0.0) EPS = 0.5*R1MACH(3) +C + XPA = X + 1.0 - A + XMA = X - 1.0 - A +C + R = 0.0 + P = 1.0 + S = P + DO 10 K=1,200 + FK = K + T = FK*(A-FK)*(1.0+R) + R = -T/((XMA+2.0*FK)*(XPA+2.0*FK)+T) + P = R*P + S = S + P + IF (ABS(P).LT.EPS*S) GO TO 20 + 10 CONTINUE + CALL XERMSG ('SLATEC', 'R9LGIC', + + 'NO CONVERGENCE IN 200 TERMS OF CONTINUED FRACTION', 1, 2) +C + 20 R9LGIC = A*ALX - X + LOG(S/XPA) +C + RETURN + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/slatec-fn/r9lgit.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,61 @@ +*DECK R9LGIT + FUNCTION R9LGIT (A, X, ALGAP1) +C***BEGIN PROLOGUE R9LGIT +C***SUBSIDIARY +C***PURPOSE Compute the logarithm of Tricomi's incomplete Gamma +C function with Perron's continued fraction for large X and +C A .GE. X. +C***LIBRARY SLATEC (FNLIB) +C***CATEGORY C7E +C***TYPE SINGLE PRECISION (R9LGIT-S, D9LGIT-D) +C***KEYWORDS FNLIB, INCOMPLETE GAMMA FUNCTION, LOGARITHM, +C PERRON'S CONTINUED FRACTION, SPECIAL FUNCTIONS, TRICOMI +C***AUTHOR Fullerton, W., (LANL) +C***DESCRIPTION +C +C Compute the log of Tricomi's incomplete gamma function with Perron's +C continued fraction for large X and for A .GE. X. +C +C***REFERENCES (NONE) +C***ROUTINES CALLED R1MACH, XERMSG +C***REVISION HISTORY (YYMMDD) +C 770701 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890531 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C 900720 Routine changed from user-callable to subsidiary. (WRB) +C***END PROLOGUE R9LGIT + SAVE EPS, SQEPS + DATA EPS, SQEPS / 2*0.0 / +C***FIRST EXECUTABLE STATEMENT R9LGIT + IF (EPS.EQ.0.0) EPS = 0.5*R1MACH(3) + IF (SQEPS.EQ.0.0) SQEPS = SQRT(R1MACH(4)) +C + IF (X .LE. 0.0 .OR. A .LT. X) CALL XERMSG ('SLATEC', 'R9LGIT', + + 'X SHOULD BE GT 0.0 AND LE A', 2, 2) +C + AX = A + X + A1X = AX + 1.0 + R = 0.0 + P = 1.0 + S = P + DO 20 K=1,200 + FK = K + T = (A+FK)*X*(1.0+R) + R = T/((AX+FK)*(A1X+FK)-T) + P = R*P + S = S + P + IF (ABS(P).LT.EPS*S) GO TO 30 + 20 CONTINUE + CALL XERMSG ('SLATEC', 'R9LGIT', + + 'NO CONVERGENCE IN 200 TERMS OF CONTINUED FRACTION', 3, 2) +C + 30 HSTAR = 1.0 - X*S/A1X + IF (HSTAR .LT. SQEPS) CALL XERMSG ('SLATEC', 'R9LGIT', + + 'RESULT LESS THAN HALF PRECISION', 1, 1) +C + R9LGIT = -X - ALGAP1 - LOG(HSTAR) +C + RETURN + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/slatec-fn/r9lgmc.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,66 @@ +*DECK R9LGMC + FUNCTION R9LGMC (X) +C***BEGIN PROLOGUE R9LGMC +C***SUBSIDIARY +C***PURPOSE Compute the log Gamma correction factor so that +C LOG(GAMMA(X)) = LOG(SQRT(2*PI)) + (X-.5)*LOG(X) - X +C + R9LGMC(X). +C***LIBRARY SLATEC (FNLIB) +C***CATEGORY C7E +C***TYPE SINGLE PRECISION (R9LGMC-S, D9LGMC-D, C9LGMC-C) +C***KEYWORDS COMPLETE GAMMA FUNCTION, CORRECTION TERM, FNLIB, +C LOG GAMMA, LOGARITHM, SPECIAL FUNCTIONS +C***AUTHOR Fullerton, W., (LANL) +C***DESCRIPTION +C +C Compute the log gamma correction factor for X .GE. 10.0 so that +C LOG (GAMMA(X)) = LOG(SQRT(2*PI)) + (X-.5)*LOG(X) - X + R9LGMC(X) +C +C Series for ALGM on the interval 0. to 1.00000D-02 +C with weighted error 3.40E-16 +C log weighted error 15.47 +C significant figures required 14.39 +C decimal places required 15.86 +C +C***REFERENCES (NONE) +C***ROUTINES CALLED CSEVL, INITS, R1MACH, XERMSG +C***REVISION HISTORY (YYMMDD) +C 770801 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890531 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C 900720 Routine changed from user-callable to subsidiary. (WRB) +C***END PROLOGUE R9LGMC + DIMENSION ALGMCS(6) + LOGICAL FIRST + SAVE ALGMCS, NALGM, XBIG, XMAX, FIRST + DATA ALGMCS( 1) / .1666389480 45186E0 / + DATA ALGMCS( 2) / -.0000138494 817606E0 / + DATA ALGMCS( 3) / .0000000098 108256E0 / + DATA ALGMCS( 4) / -.0000000000 180912E0 / + DATA ALGMCS( 5) / .0000000000 000622E0 / + DATA ALGMCS( 6) / -.0000000000 000003E0 / + DATA FIRST /.TRUE./ +C***FIRST EXECUTABLE STATEMENT R9LGMC + IF (FIRST) THEN + NALGM = INITS (ALGMCS, 6, R1MACH(3)) + XBIG = 1.0/SQRT(R1MACH(3)) + XMAX = EXP (MIN(LOG(R1MACH(2)/12.0), -LOG(12.0*R1MACH(1))) ) + ENDIF + FIRST = .FALSE. +C + IF (X .LT. 10.0) CALL XERMSG ('SLATEC', 'R9LGMC', + + 'X MUST BE GE 10', 1, 2) + IF (X.GE.XMAX) GO TO 20 +C + R9LGMC = 1.0/(12.0*X) + IF (X.LT.XBIG) R9LGMC = CSEVL (2.0*(10./X)**2-1., ALGMCS, NALGM)/X + RETURN +C + 20 R9LGMC = 0.0 + CALL XERMSG ('SLATEC', 'R9LGMC', 'X SO BIG R9LGMC UNDERFLOWS', 2, + + 1) + RETURN +C + END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/slatec-fn/xacosh.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,6 @@ + subroutine xacosh (x, result) + external acosh + real x, result, acosh + result = acosh (x) + return + end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/slatec-fn/xasinh.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,6 @@ + subroutine xasinh (x, result) + external asinh + real x, result, asinh + result = asinh (x) + return + end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/slatec-fn/xatanh.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,6 @@ + subroutine xatanh (x, result) + external atanh + real x, result, atanh + result = atanh (x) + return + end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/slatec-fn/xbetai.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,6 @@ + subroutine xbetai (x, a, b, result) + external betai + real x, a, b, result, betai + result = betai (x, a, b) + return + end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/slatec-fn/xdacosh.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,6 @@ + subroutine xdacosh (x, result) + external dacosh + double precision x, result, dacosh + result = dacosh (x) + return + end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/slatec-fn/xdasinh.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,6 @@ + subroutine xdasinh (x, result) + external dasinh + double precision x, result, dasinh + result = dasinh (x) + return + end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/slatec-fn/xdatanh.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,6 @@ + subroutine xdatanh (x, result) + external datanh + double precision x, result, datanh + result = datanh (x) + return + end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/slatec-fn/xdbetai.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,6 @@ + subroutine xdbetai (x, a, b, result) + external dbetai + double precision x, a, b, result, dbetai + result = dbetai (x, a, b) + return + end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/slatec-fn/xderf.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,6 @@ + subroutine xderf (x, result) + external derf + double precision x, result, derf + result = derf (x) + return + end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/slatec-fn/xderfc.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,6 @@ + subroutine xderfc (x, result) + external derfc + double precision x, result, derfc + result = derfc (x) + return + end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/slatec-fn/xdgami.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,6 @@ + subroutine xdgami (a, x, result) + external dgami + double precision a, x, result, dgami + result = dgami (a, x) + return + end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/slatec-fn/xdgamit.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,6 @@ + subroutine xdgamit (a, x, result) + external dgamit + double precision a, x, result, dgamit + result = dgamit (a, x) + return + end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/slatec-fn/xdgamma.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,6 @@ + subroutine xdgamma (x, result) + external dgamma + double precision x, result, dgamma + result = dgamma (x) + return + end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/slatec-fn/xerf.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,6 @@ + subroutine xerf (x, result) + external erf + real x, result, erf + result = erf (x) + return + end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/slatec-fn/xerfc.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,6 @@ + subroutine xerfc (x, result) + external erfc + real x, result, erfc + result = erfc (x) + return + end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/slatec-fn/xgamma.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,6 @@ + subroutine xgamma (x, result) + external gamma + real x, result, gamma + result = gamma (x) + return + end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/slatec-fn/xgmainc.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,100 @@ + subroutine xgammainc (a, x, result) + +c -- jwe, based on DGAMIT. +c +c -- Do a better job than dgami for large values of x. + + double precision a, x, result + intrinsic exp, log, sqrt, sign, aint + external dgami, dlngam, d9lgit, d9lgic, d9gmit + +C external dgamr +C DOUBLE PRECISION DGAMR + + DOUBLE PRECISION AEPS, AINTA, ALGAP1, ALNEPS, ALNG, ALX, + $ BOT, H, SGA, SGNGAM, SQEPS, T, D1MACH, D9GMIT, + $ D9LGIC, D9LGIT, DLNGAM, DGAMI + + LOGICAL FIRST + + SAVE ALNEPS, SQEPS, BOT, FIRST + + DATA FIRST /.TRUE./ + + if (x .eq. 0.0d0) then + + if (a .eq. 0.0d0) then + result = 1.0d0 + else + result = 0.0d0 + endif + + else + + IF (FIRST) THEN + ALNEPS = -LOG (D1MACH(3)) + SQEPS = SQRT(D1MACH(4)) + BOT = LOG (D1MACH(1)) + ENDIF + FIRST = .FALSE. +C + IF (X .LT. 0.D0) CALL XERMSG ('SLATEC', 'XGMAINC', 'X IS NEGATIVE' + + , 2, 2) +C + IF (X.NE.0.D0) ALX = LOG (X) + SGA = 1.0D0 + IF (A.NE.0.D0) SGA = SIGN (1.0D0, A) + AINTA = AINT (A + 0.5D0*SGA) + AEPS = A - AINTA +C +C IF (X.GT.0.D0) GO TO 20 +C DGAMIT = 0.0D0 +C IF (AINTA.GT.0.D0 .OR. AEPS.NE.0.D0) DGAMIT = DGAMR(A+1.0D0) +C RETURN +C + 20 IF (X.GT.1.D0) GO TO 30 + IF (A.GE.(-0.5D0) .OR. AEPS.NE.0.D0) CALL DLGAMS (A+1.0D0, ALGAP1, + 1 SGNGAM) +C DGAMIT = D9GMIT (A, X, ALGAP1, SGNGAM, ALX) + result = exp (a*alx + log (D9GMIT (A, X, ALGAP1, SGNGAM, ALX))) + RETURN +C + 30 IF (A.LT.X) GO TO 40 + T = D9LGIT (A, X, DLNGAM(A+1.0D0)) + IF (T.LT.BOT) CALL XERCLR +C DGAMIT = EXP (T) + result = EXP (a*alx + T) + RETURN +C + 40 ALNG = D9LGIC (A, X, ALX) +C +C EVALUATE DGAMIT IN TERMS OF LOG (DGAMIC (A, X)) +C + H = 1.0D0 + IF (AEPS.EQ.0.D0 .AND. AINTA.LE.0.D0) GO TO 50 +C + CALL DLGAMS (A+1.0D0, ALGAP1, SGNGAM) + T = LOG (ABS(A)) + ALNG - ALGAP1 + IF (T.GT.ALNEPS) GO TO 60 +C + IF (T.GT.(-ALNEPS)) H = 1.0D0 - SGA * SGNGAM * EXP(T) + IF (ABS(H).GT.SQEPS) GO TO 50 +C + CALL XERCLR + CALL XERMSG ('SLATEC', 'XGMAINC', 'RESULT LT HALF PRECISION', 1, + + 1) +C +C 50 T = -A*ALX + LOG(ABS(H)) +C IF (T.LT.BOT) CALL XERCLR +C DGAMIT = SIGN (EXP(T), H) + 50 result = H + RETURN +C +C 60 T = T - A*ALX + 60 IF (T.LT.BOT) CALL XERCLR + result = -SGA * SGNGAM * EXP(T) + RETURN + + endif + return + end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/slatec-fn/xsgmainc.f Mon Apr 24 21:03:38 2017 -0700 @@ -0,0 +1,100 @@ + subroutine xsgammainc (a, x, result) + +c -- jwe, based on GAMIT. +c +c -- Do a better job than gami for large values of x. + + real a, x, result + intrinsic exp, log, sqrt, sign, aint + external gami, alngam, r9lgit, r9lgic, r9gmit + +C external gamr +C real GAMR + + REAL AEPS, AINTA, ALGAP1, ALNEPS, ALNG, ALX, + $ BOT, H, SGA, SGNGAM, SQEPS, T, R1MACH, R9GMIT, + $ R9LGIC, R9LGIT, ALNGAM, GAMI + + LOGICAL FIRST + + SAVE ALNEPS, SQEPS, BOT, FIRST + + DATA FIRST /.TRUE./ + + if (x .eq. 0.0e0) then + + if (a .eq. 0.0e0) then + result = 1.0e0 + else + result = 0.0e0 + endif + + else + + IF (FIRST) THEN + ALNEPS = -LOG (R1MACH(3)) + SQEPS = SQRT(R1MACH(4)) + BOT = LOG (R1MACH(1)) + ENDIF + FIRST = .FALSE. +C + IF (X .LT. 0.E0) CALL XERMSG ('SLATEC', 'XGMAINC', 'X IS NEGATIVE' + + , 2, 2) +C + IF (X.NE.0.E0) ALX = LOG (X) + SGA = 1.0E0 + IF (A.NE.0.E0) SGA = SIGN (1.0E0, A) + AINTA = AINT (A + 0.5E0*SGA) + AEPS = A - AINTA +C +C IF (X.GT.0.E0) GO TO 20 +C GAMIT = 0.0E0 +C IF (AINTA.GT.0.E0 .OR. AEPS.NE.0.E0) GAMIT = GAMR(A+1.0E0) +C RETURN +C + 20 IF (X.GT.1.E0) GO TO 30 + IF (A.GE.(-0.5E0) .OR. AEPS.NE.0.E0) CALL ALGAMS (A+1.0E0, ALGAP1, + 1 SGNGAM) +C GAMIT = R9GMIT (A, X, ALGAP1, SGNGAM, ALX) + result = exp (a*alx + log (R9GMIT (A, X, ALGAP1, SGNGAM, ALX))) + RETURN +C + 30 IF (A.LT.X) GO TO 40 + T = R9LGIT (A, X, ALNGAM(A+1.0E0)) + IF (T.LT.BOT) CALL XERCLR +C GAMIT = EXP (T) + result = EXP (a*alx + T) + RETURN +C + 40 ALNG = R9LGIC (A, X, ALX) +C +C EVALUATE GAMIT IN TERMS OF LOG (DGAMIC (A, X)) +C + H = 1.0E0 + IF (AEPS.EQ.0.E0 .AND. AINTA.LE.0.E0) GO TO 50 +C + CALL ALGAMS (A+1.0E0, ALGAP1, SGNGAM) + T = LOG (ABS(A)) + ALNG - ALGAP1 + IF (T.GT.ALNEPS) GO TO 60 +C + IF (T.GT.(-ALNEPS)) H = 1.0E0 - SGA * SGNGAM * EXP(T) + IF (ABS(H).GT.SQEPS) GO TO 50 +C + CALL XERCLR + CALL XERMSG ('SLATEC', 'XGMAINC', 'RESULT LT HALF PRECISION', 1, + + 1) +C +C 50 T = -A*ALX + LOG(ABS(H)) +C IF (T.LT.BOT) CALL XERCLR +C GAMIT = SIGN (EXP(T), H) + 50 result = H + RETURN +C +C 60 T = T - A*ALX + 60 IF (T.LT.BOT) CALL XERCLR + result = -SGA * SGNGAM * EXP(T) + RETURN + + endif + return + end
--- a/liboctave/module.mk Mon Apr 24 17:20:37 2017 -0700 +++ b/liboctave/module.mk Mon Apr 24 21:03:38 2017 -0700 @@ -8,7 +8,7 @@ ## Search local directories before those specified by the user. liboctave_liboctave_la_CPPFLAGS = \ @OCTAVE_DLL_DEFS@ \ - @CRUFT_DLL_DEFS@ \ + @EXTERNAL_DLL_DEFS@ \ -Iliboctave -I$(srcdir)/liboctave \ -I$(srcdir)/liboctave/array \ -Iliboctave/numeric -I$(srcdir)/liboctave/numeric \ @@ -37,7 +37,7 @@ octinclude_HEADERS += \ liboctave/liboctave-build-info.h \ $(ARRAY_INC) \ - $(CRUFT_INC) \ + $(EXTERNAL_INC) \ $(NUMERIC_INC) \ $(LIBOCTAVE_OPERATORS_INC) \ $(SYSTEM_INC) \ @@ -58,7 +58,7 @@ liboctave_liboctave_la_LIBADD = include liboctave/array/module.mk -include liboctave/cruft/module.mk +include liboctave/external/module.mk include liboctave/numeric/module.mk include liboctave/operators/module.mk include liboctave/system/module.mk @@ -82,7 +82,7 @@ liboctave_liboctave_la_LDFLAGS = \ -version-info $(liboctave_liboctave_version_info) \ $(NO_UNDEFINED_LDFLAG) \ - @XTRA_CRUFT_SH_LDFLAGS@ \ + @XTRA_EXTERNAL_SH_LDFLAGS@ \ -bindir $(bindir) \ $(LIBOCTAVE_LINK_OPTS) \ $(WARN_LDFLAGS)
--- a/liboctave/numeric/lo-blas-proto.h Mon Apr 24 17:20:37 2017 -0700 +++ b/liboctave/numeric/lo-blas-proto.h Mon Apr 24 21:03:38 2017 -0700 @@ -29,7 +29,7 @@ extern "C" { - // DOT (liboctave/cruft/blas-xtra) + // DOT (liboctave/external/blas-xtra) F77_RET_T F77_FUNC (xddot, XDDOT) (const F77_INT&, const F77_DBLE*, @@ -53,7 +53,7 @@ const F77_INT&, const F77_REAL*, const F77_REAL*, F77_REAL*); - // DOTC (liboctave/cruft/blas-xtra) + // DOTC (liboctave/external/blas-xtra) F77_RET_T F77_FUNC (xcdotc, XCDOTC) (const F77_INT&, const F77_CMPLX*, @@ -77,7 +77,7 @@ const F77_INT&, const F77_DBLE_CMPLX*, const F77_DBLE_CMPLX*, F77_DBLE_CMPLX*); - // DOTU (liboctave/cruft/blas-xtra) + // DOTU (liboctave/external/blas-xtra) F77_RET_T F77_FUNC (xcdotu, XCDOTU) (const F77_INT&, const F77_CMPLX*,
--- a/liboctave/numeric/lo-lapack-proto.h Mon Apr 24 17:20:37 2017 -0700 +++ b/liboctave/numeric/lo-lapack-proto.h Mon Apr 24 21:03:38 2017 -0700 @@ -1077,7 +1077,7 @@ F77_CHAR_ARG_LEN_DECL F77_CHAR_ARG_LEN_DECL); - // LAENV (liboctave/cruft/lapack-xtra) + // LAENV (liboctave/external/lapack-xtra) F77_RET_T F77_FUNC (xilaenv, XILAENV) (const F77_INT&, @@ -1098,14 +1098,14 @@ F77_DBLE& SCALE2, F77_DBLE& WR1, F77_DBLE& WR2, F77_DBLE& WI); - // LAMCH (liboctave/cruft/lapack-xtra) + // LAMCH (liboctave/external/lapack-xtra) F77_RET_T F77_FUNC (xdlamch, XDLAMCH) (F77_CONST_CHAR_ARG_DECL, F77_DBLE& retval F77_CHAR_ARG_LEN_DECL); - // LANGE (liboctave/cruft/lapack-xtra) + // LANGE (liboctave/external/lapack-xtra) F77_RET_T F77_FUNC (xclange, XCLANGE) (F77_CONST_CHAR_ARG_DECL, @@ -1357,7 +1357,7 @@ F77_DBLE*, F77_DBLE_CMPLX*, F77_DBLE_CMPLX*, const F77_INT&, F77_INT&); - // RSF2CSF (liboctave/cruft/lapack-xtra) + // RSF2CSF (liboctave/external/lapack-xtra) F77_RET_T F77_FUNC (zrsf2csf, ZRSF2CSF) (const F77_INT&, F77_DBLE_CMPLX *,
--- a/liboctave/numeric/module.mk Mon Apr 24 17:20:37 2017 -0700 +++ b/liboctave/numeric/module.mk Mon Apr 24 21:03:38 2017 -0700 @@ -117,7 +117,7 @@ liboctave_numeric_libnumeric_la_CPPFLAGS = \ $(liboctave_liboctave_la_CPPFLAGS) \ - -I$(srcdir)/liboctave/cruft/Faddeeva \ + -I$(srcdir)/liboctave/external/Faddeeva \ $(FFTW_XCPPFLAGS) \ $(SPARSE_XCPPFLAGS)