KolmogorovSmirnovDist.c 19 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788
  1. // SPDX-License-Identifier: GPL-3.0
  2. /********************************************************************
  3. *
  4. * File: KolmogorovSmirnovDist.c
  5. * Environment: ISO C99 or ANSI C89
  6. * Author: Richard Simard
  7. * Organization: DIRO, Université de Montréal
  8. * Date: 1 February 2012
  9. * Version 1.1
  10. * Copyright 1 march 2010 by Université de Montréal,
  11. Richard Simard and Pierre L'Ecuyer
  12. =====================================================================
  13. This program is free software: you can redistribute it and/or modify
  14. it under the terms of the GNU General Public License as published by
  15. the Free Software Foundation, version 3 of the License.
  16. This program is distributed in the hope that it will be useful,
  17. but WITHOUT ANY WARRANTY; without even the implied warranty of
  18. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  19. GNU General Public License for more details.
  20. You should have received a copy of the GNU General Public License
  21. along with this program. If not, see <http://www.gnu.org/licenses/>.
  22. =====================================================================*/
  23. #include "KolmogorovSmirnovDist.h"
  24. #include <math.h>
  25. #include <stdlib.h>
  26. #define num_Pi 3.14159265358979323846 /* PI */
  27. #define num_Ln2 0.69314718055994530941 /* log(2) */
  28. /* For x close to 0 or 1, we use the exact formulae of Ruben-Gambino in all
  29. cases. For n <= NEXACT, we use exact algorithms: the Durbin matrix and
  30. the Pomeranz algorithms. For n > NEXACT, we use asymptotic methods
  31. except for x close to 0 where we still use the method of Durbin
  32. for n <= NKOLMO. For n > NKOLMO, we use asymptotic methods only and
  33. so the precision is less for x close to 0.
  34. We could increase the limit NKOLMO to 10^6 to get better precision
  35. for x close to 0, but at the price of a slower speed. */
  36. #define NEXACT 500
  37. #define NKOLMO 100000
  38. /* The Durbin matrix algorithm for the Kolmogorov-Smirnov distribution */
  39. static double DurbinMatrix (int n, double d);
  40. /*========================================================================*/
  41. #if 0
  42. /* For ANSI C89 only, not for ISO C99 */
  43. #define MAXI 50
  44. #define EPSILON 1.0e-15
  45. double log1p (double x)
  46. {
  47. /* returns a value equivalent to log(1 + x) accurate also for small x. */
  48. if (fabs (x) > 0.1) {
  49. return log (1.0 + x);
  50. } else {
  51. double term = x;
  52. double sum = x;
  53. int s = 2;
  54. while ((fabs (term) > EPSILON * fabs (sum)) && (s < MAXI)) {
  55. term *= -x;
  56. sum += term / s;
  57. s++;
  58. }
  59. return sum;
  60. }
  61. }
  62. #undef MAXI
  63. #undef EPSILON
  64. #endif
  65. /*========================================================================*/
  66. #define MFACT 30
  67. /* The natural logarithm of factorial n! for 0 <= n <= MFACT */
  68. static double LnFactorial[MFACT + 1] = {
  69. 0.,
  70. 0.,
  71. 0.6931471805599453,
  72. 1.791759469228055,
  73. 3.178053830347946,
  74. 4.787491742782046,
  75. 6.579251212010101,
  76. 8.525161361065415,
  77. 10.60460290274525,
  78. 12.80182748008147,
  79. 15.10441257307552,
  80. 17.50230784587389,
  81. 19.98721449566188,
  82. 22.55216385312342,
  83. 25.19122118273868,
  84. 27.89927138384088,
  85. 30.67186010608066,
  86. 33.50507345013688,
  87. 36.39544520803305,
  88. 39.33988418719949,
  89. 42.33561646075348,
  90. 45.3801388984769,
  91. 48.47118135183522,
  92. 51.60667556776437,
  93. 54.7847293981123,
  94. 58.00360522298051,
  95. 61.26170176100199,
  96. 64.55753862700632,
  97. 67.88974313718154,
  98. 71.257038967168,
  99. 74.65823634883016
  100. };
  101. /*------------------------------------------------------------------------*/
  102. static double getLogFactorial (int n)
  103. {
  104. /* Returns the natural logarithm of factorial n! */
  105. if (n <= MFACT) {
  106. return LnFactorial[n];
  107. } else {
  108. double x = (double) (n + 1);
  109. double y = 1.0 / (x * x);
  110. double z = ((-(5.95238095238E-4 * y) + 7.936500793651E-4) * y -
  111. 2.7777777777778E-3) * y + 8.3333333333333E-2;
  112. z = ((x - 0.5) * log (x) - x) + 9.1893853320467E-1 + z / x;
  113. return z;
  114. }
  115. }
  116. /*------------------------------------------------------------------------*/
  117. static double rapfac (int n)
  118. {
  119. /* Computes n! / n^n */
  120. int i;
  121. double res = 1.0 / n;
  122. for (i = 2; i <= n; i++) {
  123. res *= (double) i / n;
  124. }
  125. return res;
  126. }
  127. /*========================================================================*/
  128. static double **CreateMatrixD (int N, int M)
  129. {
  130. int i;
  131. double **T2;
  132. T2 = (double **) malloc (N * sizeof (double *));
  133. T2[0] = (double *) malloc ((size_t) N * M * sizeof (double));
  134. for (i = 1; i < N; i++)
  135. T2[i] = T2[0] + i * M;
  136. return T2;
  137. }
  138. static void DeleteMatrixD (double **T)
  139. {
  140. free (T[0]);
  141. free (T);
  142. }
  143. /*========================================================================*/
  144. static double KSPlusbarAsymp (int n, double x)
  145. {
  146. /* Compute the probability of the KS+ distribution using an asymptotic
  147. formula */
  148. double t = (6.0 * n * x + 1);
  149. double z = t * t / (18.0 * n);
  150. double v = 1.0 - (2.0 * z * z - 4.0 * z - 1.0) / (18.0 * n);
  151. if (v <= 0.0)
  152. return 0.0;
  153. v = v * exp (-z);
  154. if (v >= 1.0)
  155. return 1.0;
  156. return v;
  157. }
  158. /*-------------------------------------------------------------------------*/
  159. static double KSPlusbarUpper (int n, double x)
  160. {
  161. /* Compute the probability of the KS+ distribution in the upper tail using
  162. Smirnov's stable formula */
  163. const double EPSILON = 1.0E-12;
  164. double q;
  165. double Sum = 0.0;
  166. double term;
  167. double t;
  168. double LogCom;
  169. double LOGJMAX;
  170. int j;
  171. int jdiv;
  172. int jmax = (int) (n * (1.0 - x));
  173. if (n > 200000)
  174. return KSPlusbarAsymp (n, x);
  175. /* Avoid log(0) for j = jmax and q ~ 1.0 */
  176. if ((1.0 - x - (double) jmax / n) <= 0.0)
  177. jmax--;
  178. if (n > 3000)
  179. jdiv = 2;
  180. else
  181. jdiv = 3;
  182. j = jmax / jdiv + 1;
  183. LogCom = getLogFactorial (n) - getLogFactorial (j) -
  184. getLogFactorial (n - j);
  185. LOGJMAX = LogCom;
  186. while (j <= jmax) {
  187. q = (double) j / n + x;
  188. term = LogCom + (j - 1) * log (q) + (n - j) * log1p (-q);
  189. t = exp (term);
  190. Sum += t;
  191. LogCom += log ((double) (n - j) / (j + 1));
  192. if (t <= Sum * EPSILON)
  193. break;
  194. j++;
  195. }
  196. j = jmax / jdiv;
  197. LogCom = LOGJMAX + log ((double) (j + 1) / (n - j));
  198. while (j > 0) {
  199. q = (double) j / n + x;
  200. term = LogCom + (j - 1) * log (q) + (n - j) * log1p (-q);
  201. t = exp (term);
  202. Sum += t;
  203. LogCom += log ((double) j / (n - j + 1));
  204. if (t <= Sum * EPSILON)
  205. break;
  206. j--;
  207. }
  208. Sum *= x;
  209. /* add the term j = 0 */
  210. Sum += exp (n * log1p (-x));
  211. return Sum;
  212. }
  213. /*========================================================================*/
  214. static double Pelz (int n, double x)
  215. {
  216. /* Approximating the Lower Tail-Areas of the Kolmogorov-Smirnov One-Sample
  217. Statistic,
  218. Wolfgang Pelz and I. J. Good,
  219. Journal of the Royal Statistical Society, Series B.
  220. Vol. 38, No. 2 (1976), pp. 152-156
  221. */
  222. const int JMAX = 20;
  223. const double EPS = 1.0e-10;
  224. const double C = 2.506628274631001; /* sqrt(2*Pi) */
  225. const double C2 = 1.2533141373155001; /* sqrt(Pi/2) */
  226. const double PI2 = num_Pi * num_Pi;
  227. const double PI4 = PI2 * PI2;
  228. const double RACN = sqrt ((double) n);
  229. const double z = RACN * x;
  230. const double z2 = z * z;
  231. const double z4 = z2 * z2;
  232. const double z6 = z4 * z2;
  233. const double w = PI2 / (2.0 * z * z);
  234. double ti, term, tom;
  235. double sum;
  236. int j;
  237. term = 1;
  238. j = 0;
  239. sum = 0;
  240. while (j <= JMAX && term > EPS * sum) {
  241. ti = j + 0.5;
  242. term = exp (-ti * ti * w);
  243. sum += term;
  244. j++;
  245. }
  246. sum *= C / z;
  247. term = 1;
  248. tom = 0;
  249. j = 0;
  250. while (j <= JMAX && fabs (term) > EPS * fabs (tom)) {
  251. ti = j + 0.5;
  252. term = (PI2 * ti * ti - z2) * exp (-ti * ti * w);
  253. tom += term;
  254. j++;
  255. }
  256. sum += tom * C2 / (RACN * 3.0 * z4);
  257. term = 1;
  258. tom = 0;
  259. j = 0;
  260. while (j <= JMAX && fabs (term) > EPS * fabs (tom)) {
  261. ti = j + 0.5;
  262. term = 6 * z6 + 2 * z4 + PI2 * (2 * z4 - 5 * z2) * ti * ti +
  263. PI4 * (1 - 2 * z2) * ti * ti * ti * ti;
  264. term *= exp (-ti * ti * w);
  265. tom += term;
  266. j++;
  267. }
  268. sum += tom * C2 / (n * 36.0 * z * z6);
  269. term = 1;
  270. tom = 0;
  271. j = 1;
  272. while (j <= JMAX && term > EPS * tom) {
  273. ti = j;
  274. term = PI2 * ti * ti * exp (-ti * ti * w);
  275. tom += term;
  276. j++;
  277. }
  278. sum -= tom * C2 / (n * 18.0 * z * z2);
  279. term = 1;
  280. tom = 0;
  281. j = 0;
  282. while (j <= JMAX && fabs (term) > EPS * fabs (tom)) {
  283. ti = j + 0.5;
  284. ti = ti * ti;
  285. term = -30 * z6 - 90 * z6 * z2 + PI2 * (135 * z4 - 96 * z6) * ti +
  286. PI4 * (212 * z4 - 60 * z2) * ti * ti + PI2 * PI4 * ti * ti * ti * (5 -
  287. 30 * z2);
  288. term *= exp (-ti * w);
  289. tom += term;
  290. j++;
  291. }
  292. sum += tom * C2 / (RACN * n * 3240.0 * z4 * z6);
  293. term = 1;
  294. tom = 0;
  295. j = 1;
  296. while (j <= JMAX && fabs (term) > EPS * fabs (tom)) {
  297. ti = j * j;
  298. term = (3 * PI2 * ti * z2 - PI4 * ti * ti) * exp (-ti * w);
  299. tom += term;
  300. j++;
  301. }
  302. sum += tom * C2 / (RACN * n * 108.0 * z6);
  303. return sum;
  304. }
  305. /*=========================================================================*/
  306. static void CalcFloorCeil (
  307. int n, /* sample size */
  308. double t, /* = nx */
  309. double *A, /* A_i */
  310. double *Atflo, /* floor (A_i - t) */
  311. double *Atcei /* ceiling (A_i + t) */
  312. )
  313. {
  314. /* Precompute A_i, floors, and ceilings for limits of sums in the Pomeranz
  315. algorithm */
  316. int i;
  317. int ell = (int) t; /* floor (t) */
  318. double z = t - ell; /* t - floor (t) */
  319. double w = ceil (t) - t;
  320. if (z > 0.5) {
  321. for (i = 2; i <= 2 * n + 2; i += 2)
  322. Atflo[i] = i / 2 - 2 - ell;
  323. for (i = 1; i <= 2 * n + 2; i += 2)
  324. Atflo[i] = i / 2 - 1 - ell;
  325. for (i = 2; i <= 2 * n + 2; i += 2)
  326. Atcei[i] = i / 2 + ell;
  327. for (i = 1; i <= 2 * n + 2; i += 2)
  328. Atcei[i] = i / 2 + 1 + ell;
  329. } else if (z > 0.0) {
  330. for (i = 1; i <= 2 * n + 2; i++)
  331. Atflo[i] = i / 2 - 1 - ell;
  332. for (i = 2; i <= 2 * n + 2; i++)
  333. Atcei[i] = i / 2 + ell;
  334. Atcei[1] = 1 + ell;
  335. } else { /* z == 0 */
  336. for (i = 2; i <= 2 * n + 2; i += 2)
  337. Atflo[i] = i / 2 - 1 - ell;
  338. for (i = 1; i <= 2 * n + 2; i += 2)
  339. Atflo[i] = i / 2 - ell;
  340. for (i = 2; i <= 2 * n + 2; i += 2)
  341. Atcei[i] = i / 2 - 1 + ell;
  342. for (i = 1; i <= 2 * n + 2; i += 2)
  343. Atcei[i] = i / 2 + ell;
  344. }
  345. if (w < z)
  346. z = w;
  347. A[0] = A[1] = 0;
  348. A[2] = z;
  349. A[3] = 1 - A[2];
  350. for (i = 4; i <= 2 * n + 1; i++)
  351. A[i] = A[i - 2] + 1;
  352. A[2 * n + 2] = n;
  353. }
  354. /*========================================================================*/
  355. static double Pomeranz (int n, double x)
  356. {
  357. /* The Pomeranz algorithm to compute the KS distribution */
  358. const double EPS = 1.0e-15;
  359. const int ENO = 350;
  360. const double RENO = ldexp (1.0, ENO); /* for renormalization of V */
  361. int coreno; /* counter: how many renormalizations */
  362. const double t = n * x;
  363. double w, sum, minsum;
  364. int i, j, k, s;
  365. int r1, r2; /* Indices i and i-1 for V[i][] */
  366. int jlow, jup, klow, kup, kup0;
  367. double *A;
  368. double *Atflo;
  369. double *Atcei;
  370. double **V;
  371. double **H; /* = pow(w, j) / Factorial(j) */
  372. A = (double *) calloc ((size_t) (2 * n + 3), sizeof (double));
  373. Atflo = (double *) calloc ((size_t) (2 * n + 3), sizeof (double));
  374. Atcei = (double *) calloc ((size_t) (2 * n + 3), sizeof (double));
  375. V = (double **) CreateMatrixD (2, n + 2);
  376. H = (double **) CreateMatrixD (4, n + 2);
  377. CalcFloorCeil (n, t, A, Atflo, Atcei);
  378. for (j = 1; j <= n + 1; j++)
  379. V[0][j] = 0;
  380. for (j = 2; j <= n + 1; j++)
  381. V[1][j] = 0;
  382. V[1][1] = RENO;
  383. coreno = 1;
  384. /* Precompute H[][] = (A[j] - A[j-1]^k / k! for speed */
  385. H[0][0] = 1;
  386. w = 2.0 * A[2] / n;
  387. for (j = 1; j <= n + 1; j++)
  388. H[0][j] = w * H[0][j - 1] / j;
  389. H[1][0] = 1;
  390. w = (1.0 - 2.0 * A[2]) / n;
  391. for (j = 1; j <= n + 1; j++)
  392. H[1][j] = w * H[1][j - 1] / j;
  393. H[2][0] = 1;
  394. w = A[2] / n;
  395. for (j = 1; j <= n + 1; j++)
  396. H[2][j] = w * H[2][j - 1] / j;
  397. H[3][0] = 1;
  398. for (j = 1; j <= n + 1; j++)
  399. H[3][j] = 0;
  400. r1 = 0;
  401. r2 = 1;
  402. for (i = 2; i <= 2 * n + 2; i++) {
  403. jlow = 2 + (int) Atflo[i];
  404. if (jlow < 1)
  405. jlow = 1;
  406. jup = (int) Atcei[i];
  407. if (jup > n + 1)
  408. jup = n + 1;
  409. klow = 2 + (int) Atflo[i - 1];
  410. if (klow < 1)
  411. klow = 1;
  412. kup0 = (int) Atcei[i - 1];
  413. /* Find to which case it corresponds */
  414. w = (A[i] - A[i - 1]) / n;
  415. s = -1;
  416. for (j = 0; j < 4; j++) {
  417. if (fabs (w - H[j][1]) <= EPS) {
  418. s = j;
  419. break;
  420. }
  421. }
  422. /* assert (s >= 0, "Pomeranz: s < 0"); */
  423. minsum = RENO;
  424. r1 = (r1 + 1) & 1; /* i - 1 */
  425. r2 = (r2 + 1) & 1; /* i */
  426. for (j = jlow; j <= jup; j++) {
  427. kup = kup0;
  428. if (kup > j)
  429. kup = j;
  430. sum = 0;
  431. for (k = kup; k >= klow; k--)
  432. sum += V[r1][k] * H[s][j - k];
  433. V[r2][j] = sum;
  434. if (sum < minsum)
  435. minsum = sum;
  436. }
  437. if (minsum < 1.0e-280) {
  438. /* V is too small: renormalize to avoid underflow of probabilities */
  439. for (j = jlow; j <= jup; j++)
  440. V[r2][j] *= RENO;
  441. coreno++; /* keep track of log of RENO */
  442. }
  443. }
  444. sum = V[r2][n + 1];
  445. free (A);
  446. free (Atflo);
  447. free (Atcei);
  448. DeleteMatrixD (H);
  449. DeleteMatrixD (V);
  450. w = getLogFactorial (n) - coreno * ENO * num_Ln2 + log (sum);
  451. if (w >= 0.)
  452. return 1.;
  453. return exp (w);
  454. }
  455. /*========================================================================*/
  456. static double cdfSpecial (int n, double x)
  457. {
  458. /* The KS distribution is known exactly for these cases */
  459. /* For nx^2 > 18, KSfbar(n, x) is smaller than 5e-16 */
  460. if ((n * x * x >= 18.0) || (x >= 1.0))
  461. return 1.0;
  462. if (x <= 0.5 / n)
  463. return 0.0;
  464. if (n == 1)
  465. return 2.0 * x - 1.0;
  466. if (x <= 1.0 / n) {
  467. double t = 2.0 * x * n - 1.0;
  468. double w;
  469. if (n <= NEXACT) {
  470. w = rapfac (n);
  471. return w * pow (t, (double) n);
  472. }
  473. w = getLogFactorial (n) + n * log (t / n);
  474. return exp (w);
  475. }
  476. if (x >= 1.0 - 1.0 / n) {
  477. return 1.0 - 2.0 * pow (1.0 - x, (double) n);
  478. }
  479. return -1.0;
  480. }
  481. /*========================================================================*/
  482. double KScdf (int n, double x)
  483. {
  484. const double w = n * x * x;
  485. double u = cdfSpecial (n, x);
  486. if (u >= 0.0)
  487. return u;
  488. if (n <= NEXACT) {
  489. if (w < 0.754693)
  490. return DurbinMatrix (n, x);
  491. if (w < 4.0)
  492. return Pomeranz (n, x);
  493. return 1.0 - KSfbar (n, x);
  494. }
  495. if ((w * x * n <= 7.0) && (n <= NKOLMO))
  496. return DurbinMatrix (n, x);
  497. return Pelz (n, x);
  498. }
  499. /*=========================================================================*/
  500. static double fbarSpecial (int n, double x)
  501. {
  502. const double w = n * x * x;
  503. if ((w >= 370.0) || (x >= 1.0))
  504. return 0.0;
  505. if ((w <= 0.0274) || (x <= 0.5 / n))
  506. return 1.0;
  507. if (n == 1)
  508. return 2.0 - 2.0 * x;
  509. if (x <= 1.0 / n) {
  510. double z;
  511. double t = 2.0 * x * n - 1.0;
  512. if (n <= NEXACT) {
  513. z = rapfac (n);
  514. return 1.0 - z * pow (t, (double) n);
  515. }
  516. z = getLogFactorial (n) + n * log (t / n);
  517. return 1.0 - exp (z);
  518. }
  519. if (x >= 1.0 - 1.0 / n) {
  520. return 2.0 * pow (1.0 - x, (double) n);
  521. }
  522. return -1.0;
  523. }
  524. /*========================================================================*/
  525. double KSfbar (int n, double x)
  526. {
  527. const double w = n * x * x;
  528. double v = fbarSpecial (n, x);
  529. if (v >= 0.0)
  530. return v;
  531. if (n <= NEXACT) {
  532. if (w < 4.0)
  533. return 1.0 - KScdf (n, x);
  534. else
  535. return 2.0 * KSPlusbarUpper (n, x);
  536. }
  537. if (w >= 2.65)
  538. return 2.0 * KSPlusbarUpper (n, x);
  539. return 1.0 - KScdf (n, x);
  540. }
  541. /*=========================================================================
  542. The following implements the Durbin matrix algorithm and was programmed by
  543. G. Marsaglia, Wai Wan Tsang and Jingbo Wong.
  544. I have made small modifications in their program. (Richard Simard)
  545. =========================================================================*/
  546. /*
  547. The C program to compute Kolmogorov's distribution
  548. K(n,d) = Prob(D_n < d), where
  549. D_n = max(x_1-0/n,x_2-1/n...,x_n-(n-1)/n,1/n-x_1,2/n-x_2,...,n/n-x_n)
  550. with x_1<x_2,...<x_n a purported set of n independent uniform [0,1)
  551. random variables sorted into increasing order.
  552. See G. Marsaglia, Wai Wan Tsang and Jingbo Wong,
  553. J.Stat.Software, 8, 18, pp 1--4, (2003).
  554. */
  555. #define NORM 1.0e140
  556. #define INORM 1.0e-140
  557. #define LOGNORM 140
  558. /* Matrix product */
  559. static void mMultiply (double *A, double *B, double *C, int m);
  560. /* Matrix power */
  561. static void mPower (double *A, int eA, double *V, int *eV, int m, int n);
  562. static double DurbinMatrix (int n, double d)
  563. {
  564. int k, m, i, j, g, eH, eQ;
  565. double h, s, *H, *Q;
  566. /* OMIT NEXT TWO LINES IF YOU REQUIRE >7 DIGIT ACCURACY IN THE RIGHT TAIL */
  567. #if 0
  568. s = d * d * n;
  569. if (s > 7.24 || (s > 3.76 && n > 99))
  570. return 1 - 2 * exp (-(2.000071 + .331 / sqrt (n) + 1.409 / n) * s);
  571. #endif
  572. k = (int) (n * d) + 1;
  573. m = 2 * k - 1;
  574. h = k - n * d;
  575. H = (double *) malloc ((m * m) * sizeof (double));
  576. Q = (double *) malloc ((m * m) * sizeof (double));
  577. for (i = 0; i < m; i++)
  578. for (j = 0; j < m; j++)
  579. if (i - j + 1 < 0)
  580. H[i * m + j] = 0;
  581. else
  582. H[i * m + j] = 1;
  583. for (i = 0; i < m; i++) {
  584. H[i * m] -= pow (h, (double) (i + 1));
  585. H[(m - 1) * m + i] -= pow (h, (double) (m - i));
  586. }
  587. H[(m - 1) * m] += (2 * h - 1 > 0 ? pow (2 * h - 1, (double) m) : 0);
  588. for (i = 0; i < m; i++)
  589. for (j = 0; j < m; j++)
  590. if (i - j + 1 > 0)
  591. for (g = 1; g <= i - j + 1; g++)
  592. H[i * m + j] /= g;
  593. eH = 0;
  594. mPower (H, eH, Q, &eQ, m, n);
  595. s = Q[(k - 1) * m + k - 1];
  596. for (i = 1; i <= n; i++) {
  597. s = s * (double) i / n;
  598. if (s < INORM) {
  599. s *= NORM;
  600. eQ -= LOGNORM;
  601. }
  602. }
  603. s *= pow (10., (double) eQ);
  604. free (H);
  605. free (Q);
  606. return s;
  607. }
  608. static void mMultiply (double *A, double *B, double *C, int m)
  609. {
  610. int i, j, k;
  611. double s;
  612. for (i = 0; i < m; i++)
  613. for (j = 0; j < m; j++) {
  614. s = 0.;
  615. for (k = 0; k < m; k++)
  616. s += A[i * m + k] * B[k * m + j];
  617. C[i * m + j] = s;
  618. }
  619. }
  620. static void renormalize (double *V, int m, int *p)
  621. {
  622. int i;
  623. for (i = 0; i < m * m; i++)
  624. V[i] *= INORM;
  625. *p += LOGNORM;
  626. }
  627. static void mPower (double *A, int eA, double *V, int *eV, int m, int n)
  628. {
  629. double *B;
  630. int eB, i;
  631. if (n == 1) {
  632. for (i = 0; i < m * m; i++)
  633. V[i] = A[i];
  634. *eV = eA;
  635. return;
  636. }
  637. mPower (A, eA, V, eV, m, n / 2);
  638. B = (double *) malloc ((m * m) * sizeof (double));
  639. mMultiply (V, V, B, m);
  640. eB = 2 * (*eV);
  641. if (B[(m / 2) * m + (m / 2)] > NORM)
  642. renormalize (B, m, &eB);
  643. if (n % 2 == 0) {
  644. for (i = 0; i < m * m; i++)
  645. V[i] = B[i];
  646. *eV = eB;
  647. } else {
  648. mMultiply (A, B, V, m);
  649. *eV = eA + eB;
  650. }
  651. if (V[(m / 2) * m + (m / 2)] > NORM)
  652. renormalize (V, m, eV);
  653. free (B);
  654. }