/** * Calculates the modified bessel function \f$I_{n+\alpha}(x)\f$, possibly * scaled by \f$\mathrm{e}^{-x}\f$, for real non-negative \f$x,alpha\f$ with * \f$0 \le \alpha < 1\f$, and \f$n=0,1,\ldots,nb-1\f$. * * \arg[in] \c x non-negative real number in \f$I_{n+\alpha}(x)\f$ * \arg[in] \c alpha non-negative real number with \f$0 \le \alpha < 1\f$ in * \f$I_{n+\alpha}(x)\f$ * \arg[in] \c nb number of functions to be calculated * \arg[in] \c ize switch between no scaling (\c ize = 1) and exponential * scaling (\c ize = 2) * \arg[out] \c b real output vector to contain \f$I_{n+\alpha}(x)\f$, * \f$n=0,1,\ldots,nb-1\f$ * \return error indicator. Only if this value is identical to \c nb, then all * values in \c b have been calculated to full accuracy. If not, errors are * indicated using the following scheme: * - ncalc < 0: At least one of the arguments was out of range (e.g. nb <= 0, * ize neither equals 1 nor 2, \f$|x| \ge exparg\f$). In this case, the * output vector b is not calculated and \c ncalc is set to * \f$\min(nb,0)-1\f$. * - 0 < ncalc < nb: Not all requested functions could be calculated to full * accuracy. This can occur when nb is much larger than |x|. in this case, * the values \f$I_{n+\alpha}(x)\f$ are calculated to full accuracy for * \f$n=0,1,\ldots,ncalc\f$. The rest of the values up to * \f$n=0,1,\ldots,nb-1\f$ is calculated to a lower accuracy. * * \acknowledgement * * This program is based on a program written by David J. Sookne [2] that * computes values of the Bessel functions \f$J_{\nu}(x)\f$ or \f$I_{\nu}(x)\f$ * for real argument \f$x\f$ and integer order \f$\nu\f$. modifications include * the restriction of the computation to the Bessel function \f$I_{\nu}(x)\f$ * for non-negative real argument, the extension of the computation to arbitrary * non-negative orders \f$\nu\f$, and the elimination of most underflow. * * References: * [1] F. W. J. Olver and D. J. Sookne, A note on backward recurrence * algorithms", Math. Comput. (26), 1972, pp 125 -- 132. * [2] D. J. Sookne, "Bessel functions of real argument and int order", NBS * Jour. of Res. B. (77B), 1973, pp. 125 -- 132. * * Modified by W. J. Cody, Applied Mathematics Division, Argonne National * Laboratory, Argonne, IL, 60439, USA * * Modified by Jens Keiner, Institute of Mathematics, University of Lübeck, * 23560 Lübeck, Germany */ static int smbi(const R x, const R alpha, const int nb, const int ize, R *b) { /* machine dependent parameters */ /* NSIG - DECIMAL SIGNIFICANCE DESIRED. SHOULD BE SET TO */ /* IFIX(ALOG10(2)*NBIT+1), WHERE NBIT IS THE NUMBER OF */ /* BITS IN THE MANTISSA OF A WORKING PRECISION VARIABLE. */ /* SETTING NSIG LOWER WILL RESULT IN DECREASED ACCURACY */ /* WHILE SETTING NSIG HIGHER WILL INCREASE CPU TIME */ /* WITHOUT INCREASING ACCURACY. THE TRUNCATION ERROR */ /* IS LIMITED TO A RELATIVE ERROR OF T=.5*10**(-NSIG). */ /* ENTEN - 10.0 ** K, WHERE K IS THE LARGEST int SUCH THAT */ /* ENTEN IS MACHINE-REPRESENTABLE IN WORKING PRECISION. */ /* ENSIG - 10.0 ** NSIG. */ /* RTNSIG - 10.0 ** (-K) FOR THE SMALLEST int K SUCH THAT */ /* K .GE. NSIG/4. */ /* ENMTEN - THE SMALLEST ABS(X) SUCH THAT X/4 DOES NOT UNDERFLOW. */ /* XLARGE - UPPER LIMIT ON THE MAGNITUDE OF X WHEN IZE=2. BEAR */ /* IN MIND THAT IF ABS(X)=N, THEN AT LEAST N ITERATIONS */ /* OF THE BACKWARD RECURSION WILL BE EXECUTED. */ /* EXPARG - LARGEST WORKING PRECISION ARGUMENT THAT THE LIBRARY */ /* EXP ROUTINE CAN HANDLE AND UPPER LIMIT ON THE */ /* MAGNITUDE OF X WHEN IZE=1. */ const int nsig = MANT_DIG + 2; const R enten = nfft_float_property(NFFT_R_MAX); const R ensig = POW(K(10.0),(R)nsig); const R rtnsig = POW(K(10.0),-CEIL((R)nsig/K(4.0))); const R xlarge = K(1E4); const R exparg = FLOOR(LOG(POW(K(R_RADIX),K(DBL_MAX_EXP-1)))); /* System generated locals */ int l, n, nend, magx, nbmx, ncalc, nstart; R p, em, en, sum, pold, test, empal, tempa, tempb, tempc, psave, plast, tover, emp2al, psavel; magx = LRINT(FLOOR(x)); /* return if x, nb, or ize out of range */ if ( nb <= 0 || x < K(0.0) || alpha < K(0.0) || K(1.0) <= alpha || ((ize != 1 || exparg < x) && (ize != 2 || xlarge < x))) return (MIN(nb,0) - 1); /* 2-term ascending series for small x */ if (x < rtnsig) return scaled_modified_bessel_i_series(x,alpha,nb,ize,b); ncalc = nb; /* forward sweep, Olver's p-sequence */ nbmx = nb - magx; n = magx + 1; en = (R) (n+n) + (alpha+alpha); plast = K(1.0); p = en/x; /* significance test */ test = ensig + ensig; if ((5*nsig) < (magx << 1)) test = SQRT(test*p); else test /= POW(K(1.585),(R)magx); if (3 <= nbmx) { /* calculate p-sequence until n = nb-1 */ tover = enten/ensig; nstart = magx+2; nend = nb - 1; for (n = nstart; n <= nend; n++) { en += K(2.0); pold = plast; plast = p; p = en*plast/x + pold; if (p > tover) { /* divide p-sequence by tover to avoid overflow. Calculate p-sequence * until 1 <= |p| */ tover = enten; p /= tover; plast /= tover; psave = p; psavel = plast; nstart = n + 1; do { n++; en += K(2.0); pold = plast; plast = p; p = en*plast/x + pold; } while (p <= K(1.0)); tempb = en/x; /* Backward test. Find ncalc as the largest n such that test is passed. */ test = pold*plast*(K(0.5) - K(0.5)/(tempb * tempb))/ensig; p = plast*tover; n--; en -= K(2.0); nend = MIN(nb,n); for (ncalc = nstart; ncalc <= nend; ncalc++) { pold = psavel; psavel = psave; psave = en*psavel/x + pold; if (test < psave * psavel) break; } ncalc--; goto L80; } } n = nend; en = (R) (n+n) + (alpha+alpha); /* special significance test for 2 <= nbmx */ test = FMAX(test,SQRT(plast*ensig)*SQRT(p+p)); } /* calculate p-sequence until significance test is passed */ do { n++; en += K(2.0); pold = plast; plast = p; p = en*plast/x + pold; } while (p < test); /* Initialize backward recursion and normalization sum. */ L80: n++; en += K(2.0); tempb = K(0.0); tempa = K(1.0)/p; em = (R)(n-1); empal = em + alpha; emp2al = em - K(1.0) + (alpha+alpha); sum = tempa*empal*emp2al/em; nend = n-nb; if (nend < 0) { /* We have n <= nb. So store b[n] and set higher orders to zero */ b[n-1] = tempa; nend = -nend; for (l = 1; l <= nend; ++l) b[n-1 + l] = K(0.0); } else { if (nend != 0) { /* recur backward via difference equation, calculating b[n] until n = nb */ for (l = 1; l <= nend; ++l) { n--; en -= K(2.0); tempc = tempb; tempb = tempa; tempa = en*tempb/x + tempc; em -= K(1.0); emp2al -= K(1.0); if (n == 1) break; if (n == 2) emp2al = K(1.0); empal -= K(1.0); sum = (sum + tempa*empal)*emp2al/em; } } /* store b[nb] */ b[n-1] = tempa; if (nb <= 1) { sum = sum + sum + tempa; scaled_modified_bessel_i_normalize(x,alpha,nb,ize,b,sum); return ncalc; } /* calculate and store b[nb-1] */ n--; en -= 2.0; b[n-1] = en*tempa/x + tempb; if (n == 1) { sum = sum + sum + b[0]; scaled_modified_bessel_i_normalize(x,alpha,nb,ize,b,sum); return ncalc; } em -= K(1.0); emp2al -= K(1.0); if (n == 2) emp2al = K(1.0); empal -= K(1.0); sum = (sum + b[n-1]*empal)*emp2al/em; } nend = n - 2; if (nend != 0) { /* Calculate and store b[n] until n = 2. */ for (l = 1; l <= nend; ++l) { n--; en -= K(2.0); b[n-1] = en*b[n]/x + b[n+1]; em -= K(1.0); emp2al -= K(1.0); if (n == 2) emp2al = K(1.0); empal -= K(1.0); sum = (sum + b[n-1]*empal)*emp2al/em; } } /* calculate b[1] */ b[0] = K(2.0)*empal*b[1]/x + b[2]; sum = sum + sum + b[0]; scaled_modified_bessel_i_normalize(x,alpha,nb,ize,b,sum); return ncalc; }
/* Evaluate the cardinal B-Spline B_{n-1} supported on [0,n]. */ R Y(bsplines)(const INT k, const R _x) { const R kk = (R)k; R result_value; INT r; INT g1, g2; /* boundaries */ INT j, idx, ug, og; /* indices */ R a; /* Alpha of de Boor scheme*/ R x = _x; R scratch[k]; result_value = K(0.0); if (K(0.0) < x && x < kk) { /* Exploit symmetry around k/2, maybe. */ if ( (kk - x) < x) { x = kk - x; } r = (INT)LRINT(CEIL(x) - K(1.0)); /* Do not use the explicit formula x^k / k! for first interval! De Boor's * algorithm is more accurate. See https://github.com/NFFT/nfft/issues/16. */ for (idx = 0; idx < k; idx++) scratch[idx] = K(0.0); scratch[k-r-1] = K(1.0); /* Bounds of the algorithm. */ g1 = r; g2 = k - 1 - r; ug = g2; /* g1 <= g2 */ for (j = 1, og = g2 + 1; j <= g1; j++, og++) { a = (x + (R)(k - r - og - 1)) / ((R)(k - j)); scratch[og] = (K(1.0) - a) * scratch[og-1]; bspline_help(k, x, scratch, j, ug + 1, og - 1, r); a = (x + (R)(k - r - ug - 1)) / ((R)(k - j)); scratch[ug] = a * scratch[ug]; } for (og-- ; j <= g2; j++) { bspline_help(k, x, scratch, j, ug + 1, og, r); a = (x + (R)(k - r - ug - 1)) / ((R)(k - j)); scratch[ug] = a * scratch[ug]; } for(; j < k; j++) { ug++; bspline_help(k, x, scratch, j, ug, og, r); } result_value = scratch[k-1]; } return(result_value); }
static inline int fftw_2N_rev(int n) { return (LRINT(K(0.5) * n) + 1); }