1
2 /* tools.c
3 */
4 #include "paml.h"
5
6 #ifdef USE_GSL
7 #include <gsl/gsl_blas.h>
8 #include <gsl/gsl_linalg.h>
9 #endif
10
11 /************************
12 sequences
13 *************************/
14
15 char BASEs[] = "TCAGUYRMKSWHBVD-N?";
16 char *EquateBASE[] = { "T","C","A","G", "T", "TC","AG","CA","TG","CG","TA",
17 "TCA","TCG","CAG","TAG", "TCAG","TCAG","TCAG" };
18 char CODONs[256][4];
19 char AAs[] = "ARNDCQEGHILKMFPSTWYV-*?X";
20 char nChara[256], CharaMap[256][64];
21 char AA3Str[] = { "AlaArgAsnAspCysGlnGluGlyHisIleLeuLysMetPheProSerThrTrpTyrVal***" };
22 char BINs[] = "TC";
23 int GeneticCode[][64] =
24 { {13,13,10,10,15,15,15,15,18,18,-1,-1, 4, 4,-1,17,
25 10,10,10,10,14,14,14,14, 8, 8, 5, 5, 1, 1, 1, 1,
26 9, 9, 9,12,16,16,16,16, 2, 2,11,11,15,15, 1, 1,
27 19,19,19,19, 0, 0, 0, 0, 3, 3, 6, 6, 7, 7, 7, 7}, /* 0:universal */
28
29 {13,13,10,10,15,15,15,15,18,18,-1,-1, 4, 4,17,17,
30 10,10,10,10,14,14,14,14, 8, 8, 5, 5, 1, 1, 1, 1,
31 9, 9,12,12,16,16,16,16, 2, 2,11,11,15,15,-1,-1,
32 19,19,19,19, 0, 0, 0, 0, 3, 3, 6, 6, 7, 7, 7, 7}, /* 1:vertebrate mt.*/
33
34 {13,13,10,10,15,15,15,15,18,18,-1,-1, 4, 4,17,17,
35 16,16,16,16,14,14,14,14, 8, 8, 5, 5, 1, 1, 1, 1,
36 9, 9,12,12,16,16,16,16, 2, 2,11,11,15,15, 1, 1,
37 19,19,19,19, 0, 0, 0, 0, 3, 3, 6, 6, 7, 7, 7, 7}, /* 2:yeast mt. */
38
39 {13,13,10,10,15,15,15,15,18,18,-1,-1, 4, 4,17,17,
40 10,10,10,10,14,14,14,14, 8, 8, 5, 5, 1, 1, 1, 1,
41 9, 9, 9,12,16,16,16,16, 2, 2,11,11,15,15, 1, 1,
42 19,19,19,19, 0, 0, 0, 0, 3, 3, 6, 6, 7, 7, 7, 7}, /* 3:mold mt. */
43
44 {13,13,10,10,15,15,15,15,18,18,-1,-1, 4, 4,17,17,
45 10,10,10,10,14,14,14,14, 8, 8, 5, 5, 1, 1, 1, 1,
46 9, 9,12,12,16,16,16,16, 2, 2,11,11,15,15,15,15,
47 19,19,19,19, 0, 0, 0, 0, 3, 3, 6, 6, 7, 7, 7, 7}, /* 4:invertebrate mt. */
48
49 {13,13,10,10,15,15,15,15,18,18, 5, 5, 4, 4,-1,17,
50 10,10,10,10,14,14,14,14, 8, 8, 5, 5, 1, 1, 1, 1,
51 9, 9, 9,12,16,16,16,16, 2, 2,11,11,15,15, 1, 1,
52 19,19,19,19, 0, 0, 0, 0, 3, 3, 6, 6, 7, 7, 7, 7}, /* 5:ciliate nuclear*/
53
54 {13,13,10,10,15,15,15,15,18,18,-1,-1, 4, 4,17,17,
55 10,10,10,10,14,14,14,14, 8, 8, 5, 5, 1, 1, 1, 1,
56 9, 9, 9,12,16,16,16,16, 2, 2, 2,11,15,15,15,15,
57 19,19,19,19, 0, 0, 0, 0, 3, 3, 6, 6, 7, 7, 7, 7}, /* 6:echinoderm mt.*/
58
59 {13,13,10,10,15,15,15,15,18,18,-1,-1, 4, 4, 4,17,
60 10,10,10,10,14,14,14,14, 8, 8, 5, 5, 1, 1, 1, 1,
61 9, 9, 9,12,16,16,16,16, 2, 2,11,11,15,15, 1, 1,
62 19,19,19,19, 0, 0, 0, 0, 3, 3, 6, 6, 7, 7, 7, 7}, /* 7:euplotid mt. */
63
64 {13,13,10,10,15,15,15,15,18,18,-1,-1, 4, 4,-1,17,
65 10,10,10,15,14,14,14,14, 8, 8, 5, 5, 1, 1, 1, 1,
66 9, 9, 9,12,16,16,16,16, 2, 2,11,11,15,15, 1, 1,
67 19,19,19,19, 0, 0, 0, 0, 3, 3, 6, 6, 7, 7, 7, 7},
68 /* 8:alternative yeast nu.*/
69
70 {13,13,10,10,15,15,15,15,18,18,-1,-1, 4, 4,17,17,
71 10,10,10,10,14,14,14,14, 8, 8, 5, 5, 1, 1, 1, 1,
72 9, 9,12,12,16,16,16,16, 2, 2,11,11,15,15, 7, 7,
73 19,19,19,19, 0, 0, 0, 0, 3, 3, 6, 6, 7, 7, 7, 7}, /* 9:ascidian mt. */
74
75 {13,13,10,10,15,15,15,15,18,18,-1, 5, 4, 4,-1,17,
76 10,10,10,10,14,14,14,14, 8, 8, 5, 5, 1, 1, 1, 1,
77 9, 9, 9,12,16,16,16,16, 2, 2,11,11,15,15, 1, 1,
78 19,19,19,19, 0, 0, 0, 0, 3, 3, 6, 6, 7, 7, 7, 7}, /* 10:blepharisma nu.*/
79
80 { 1, 1, 1, 1, 2, 2, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4,
81 5, 5, 5, 5, 6, 6, 6, 6, 7, 7, 7, 7, 8, 8, 8, 8,
82 9, 9, 9, 9,10,10,10,10,11,11,11,11,12,12,12,12,
83 13,13,13,13,14,14,14,14,15,15,15,15,16,16,16,16} /* 11:Ziheng's regular code */
84 }; /* GeneticCode[icode][#codon] */
85
86
87
88 int noisy = 0, Iround = 0, NFunCall = 0, NEigenQ, NPMatUVRoot;
89 double SIZEp = 0;
90
blankline(char * str)91 int blankline(char *str)
92 {
93 char *p = str;
94 while (*p) if (isalnum(*p++)) return(0);
95 return(1);
96 }
97
PopEmptyLines(FILE * fseq,int lline,char line[])98 int PopEmptyLines(FILE* fseq, int lline, char line[])
99 {
100 /* pop out empty lines in the sequence data file.
101 returns -1 if EOF.
102 */
103 char *eqdel = ".-?", *p;
104 int i;
105
106 for (i = 0; ; i++) {
107 p = fgets(line, lline, fseq);
108 if (p == NULL) return(-1);
109 while (*p)
110 if (*p == eqdel[0] || *p == eqdel[1] || *p == eqdel[2] || isalpha(*p))
111 /*
112 if (*p==eqdel[0] || *p==eqdel[1] || *p==eqdel[2] || isalnum(*p))
113 */
114 return(0);
115 else p++;
116 }
117 }
118
119
picksite(char * z,int l,int begin,int gap,char * result)120 int picksite(char *z, int l, int begin, int gap, char *result)
121 {
122 /* pick every gap-th site, e.g., the third codon position for example.
123 */
124 int il = begin;
125
126 for (il = 0, z += begin; il < l; il += gap, z += gap) *result++ = *z;
127 return(0);
128 }
129
CodeChara(char b,int seqtype)130 int CodeChara(char b, int seqtype)
131 {
132 /* This codes nucleotides or amino acids into 0, 1, 2, ...
133 */
134 int i, n = (seqtype <= 1 ? 4 : (seqtype == 2 ? 20 : 2));
135 char *pch = (seqtype <= 1 ? BASEs : (seqtype == 2 ? AAs : BINs));
136
137 if (seqtype <= 1)
138 switch (b) {
139 case 'T': case 'U': return(0);
140 case 'C': return(1);
141 case 'A': return(2);
142 case 'G': return(3);
143 }
144 else
145 for (i = 0; i < n; i++)
146 if (b == pch[i]) return (i);
147 if (noisy >= 9) printf("\nwarning: strange character '%c' ", b);
148 return (-1);
149 }
150
dnamaker(char z[],int ls,double pi[])151 int dnamaker(char z[], int ls, double pi[])
152 {
153 /* sequences z[] are coded 0,1,2,3
154 */
155 int i, j;
156 double p[4], r, smallv = 1e-5;
157
158 xtoy(pi, p, 4);
159 for (i = 1; i < 4; i++) p[i] += p[i - 1];
160 if (fabs(p[3] - 1) > smallv)
161 error2("sum pi != 1..");
162 for (i = 0; i < ls; i++) {
163 for (j = 0, r = rndu(); j < 4; j++)
164 if (r < p[j]) break;
165 z[i] = (char)j;
166 }
167 return (0);
168 }
169
transform(char * z,int ls,int direction,int seqtype)170 int transform(char *z, int ls, int direction, int seqtype)
171 {
172 /* direction==1 from TCAG to 0123, ==0 from 0123 to TCGA.
173 */
174 int il, status = 0;
175 char *p;
176 char *pch = (seqtype <= 1 ? BASEs : (seqtype == 2 ? AAs : BINs));
177
178 if (direction)
179 for (il = 0, p = z; il < ls; il++, p++) {
180 if ((*p = (char)CodeChara(*p, seqtype)) == (char)(-1)) status = -1;
181 }
182 else
183 for (il = 0, p = z; il < ls; il++, p++) *p = pch[(int)(*p)];
184 return (status);
185 }
186
187
f_mono_di(FILE * fout,char * z,int ls,int iring,double fb1[],double fb2[],double CondP[])188 int f_mono_di(FILE *fout, char *z, int ls, int iring,
189 double fb1[], double fb2[], double CondP[])
190 {
191 /* get mono- di- nucleitide frequencies.
192 */
193 int i, j, il;
194 char *s;
195 double t1, t2;
196
197 t1 = 1. / (double)ls;
198 t2 = 1. / (double)(ls - 1 + iring);
199 for (i = 0; i < 4; fb1[i++] = 0.0) for (j = 0; j < 4; fb2[i * 4 + j++] = 0.0);
200 for (il = 0, s = z; il < ls - 1; il++, s++) {
201 fb1[*s - 1] += t1;
202 fb2[(*s - 1) * 4 + *(s + 1) - 1] += t2;
203 }
204 fb1[*s - 1] += t1;
205 if (iring) fb2[(*s - 1) * 4 + z[0] - 1] += t2;
206 for (i = 0; i < 4; i++) for (j = 0; j < 4; j++) CondP[i * 4 + j] = fb2[i * 4 + j] / fb1[i];
207 fprintf(fout, "\nmono-\n");
208 FOR(i, 4) fprintf(fout, "%12.4f", fb1[i]);
209 fprintf(fout, "\n\ndi- & conditional P\n");
210 for (i = 0; i < 4; i++) {
211 for (j = 0; j < 4; j++) fprintf(fout, "%9.4f%7.4f ", fb2[i * 4 + j], CondP[i * 4 + j]);
212 fprintf(fout, "\n");
213 }
214 fprintf(fout, "\n");
215 return (0);
216 }
217
PickExtreme(FILE * fout,char * z,int ls,int iring,int lfrag,int * ffrag)218 int PickExtreme(FILE *fout, char *z, int ls, int iring, int lfrag, int *ffrag)
219 {
220 /* picking up (lfrag)-tuples with extreme frequencies.
221 */
222 char *pz = z;
223 int i, j, isf, n = (1 << 2 * lfrag), lvirt = ls - (lfrag - 1)*(1 - iring);
224 double fb1[4], fb2[4 * 4], p_2[4 * 4];
225 double prob1, prob2, ne1, ne2, u1, u2, ualpha = 2.0;
226 int ib[10];
227
228 f_mono_di(fout, z, ls, iring, fb1, fb2, p_2);
229 if (iring) {
230 error2("change PickExtreme()");
231 FOR(i, lfrag - 1) z[ls + i] = z[i]; /* dangerous */
232 z[ls + i] = (char)0;
233 }
234 printf("\ncounting %d tuple frequencies", lfrag);
235 FOR(i, n) ffrag[i] = 0;
236 for (i = 0; i < lvirt; i++, pz++) {
237 for (j = 0, isf = 0; j < lfrag; j++) isf = isf * 4 + (int)pz[j] - 1;
238 ffrag[isf] ++;
239 }
240 /* analyze */
241 for (i = 0; i < n; i++) {
242 for (j = 0, isf = i; j < lfrag; ib[lfrag - 1 - j] = isf % 4, isf = isf / 4, j++);
243 for (j = 0, prob1 = 1.0; j < lfrag; prob1 *= fb1[ib[j++]]);
244 for (j = 0, prob2 = fb1[ib[0]]; j < lfrag - 1; j++)
245 prob2 *= p_2[ib[j] * 4 + ib[j + 1]];
246 ne1 = (double)lvirt * prob1;
247 ne2 = (double)lvirt * prob2;
248 if (ne1 <= 0.0) ne1 = 0.5;
249 if (ne2 <= 0.0) ne2 = 0.5;
250 u1 = ((double)ffrag[i] - ne1) / sqrt(ne1);
251 u2 = ((double)ffrag[i] - ne2) / sqrt(ne2);
252 if (fabs(u1) > ualpha /* && fabs(u2)>ualpha */) {
253 fprintf(fout, "\n");
254 FOR(j, lfrag) fprintf(fout, "%1c", BASEs[ib[j]]);
255 fprintf(fout, "%6d %8.1f%7.2f %8.1f%7.2f ", ffrag[i], ne1, u1, ne2, u2);
256 if (u1 < -ualpha && u2 < -ualpha) fprintf(fout, " %c", '-');
257 else if (u1 > ualpha && u2 > ualpha) fprintf(fout, " %c", '+');
258 else if (u1*u2<0 && fabs(u1) > ualpha && fabs(u2) > ualpha)
259 fprintf(fout, " %c", '?');
260 else
261 fprintf(fout, " %c", ' ');
262 }
263 }
264 return (0);
265 }
266
zztox(int n31,int l,char * z1,char * z2,double * x)267 int zztox(int n31, int l, char *z1, char *z2, double *x)
268 {
269 /* x[n31][4][4] */
270 double t = 1. / (double)(l / n31);
271 int i, ib[2];
272 int il;
273
274 zero(x, n31 * 16);
275 for (i = 0; i < n31; i++) {
276 for (il = 0; il < l; il += n31) {
277 ib[0] = z1[il + i] - 1;
278 ib[1] = z2[il + i] - 1;
279 x[i * 16 + ib[0] * 4 + ib[1]] += t;
280 }
281 /*
282 fprintf (f1, "\nThe difference matrix X %6d\tin %6d\n", i+1,n31);
283 for (j=0; j<4; j++) {
284 for (k=0; k<4; k++) fprintf(f1, "%10.2f", x[i][j][k]);
285 fputc ('\n', f1);
286 }
287 */
288 }
289 return (0);
290 }
291
testXMat(double x[])292 int testXMat(double x[])
293 {
294 /* test whether X matrix is acceptable (0) or not (-1) */
295 int it = 0, i, j;
296 double t;
297 for (i = 0, t = 0; i < 4; i++) FOR(j, 4) {
298 if (x[i * 4 + j] < 0 || x[i * 4 + j]>1) it = -1;
299 t += x[i * 4 + j];
300 }
301 if (fabs(t - 1) > 1e-4) it = -1;
302 return(it);
303 }
304
305
difcodonNG(char codon1[],char codon2[],double * SynSite,double * AsynSite,double * SynDif,double * AsynDif,int transfed,int icode)306 int difcodonNG(char codon1[], char codon2[], double *SynSite, double *AsynSite,
307 double *SynDif, double *AsynDif, int transfed, int icode)
308 {
309 /* # of synonymous and non-synonymous sites and differences.
310 Nei, M. and T. Gojobori (1986)
311 returns the number of differences between two codons.
312 The two codons (codon1 & codon2) do not contain ambiguity characters.
313 dmark[i] (=0,1,2) is the i_th different codon position, with i=0,1,ndiff
314 step[j] (=0,1,2) is the codon position to be changed at step j (j=0,1,ndiff)
315 b[i][j] (=0,1,2,3) is the nucleotide at position j (0,1,2) in codon i (0,1)
316
317 I made some arbitrary decisions when the two codons have ambiguity characters
318 20 September 2002.
319 */
320 int i, j, k, i1, i2, iy[2] = { 0 }, iaa[2], ic[2];
321 int ndiff, npath, nstop, sdpath, ndpath, dmark[3], step[3], b[2][3], bt1[3], bt2[3];
322 int by[3] = { 16, 4, 1 };
323 char str[4] = "";
324
325 for (i = 0, *SynSite = 0, nstop = 0; i < 2; i++) {
326 for (j = 0; j < 3; j++) {
327 if (transfed) b[i][j] = (i ? codon1[j] : codon2[j]);
328 else b[i][j] = (int)CodeChara((char)(i ? codon1[j] : codon2[j]), 0);
329 iy[i] += by[j] * b[i][j];
330 if (b[i][j] < 0 || b[i][j]>3) {
331 if (noisy >= 9)
332 printf("\nwarning ambiguity in difcodonNG: %s %s", codon1, codon2);
333 *SynSite = 0.5; *AsynSite = 2.5;
334 *SynDif = (codon1[2] != codon2[2]) / 2;
335 *AsynDif = *SynDif + (codon1[0] != codon2[0]) + (codon1[1] != codon2[1]);
336 return((int)(*SynDif + *AsynDif));
337 }
338 }
339 iaa[i] = GeneticCode[icode][iy[i]];
340 if (iaa[i] == -1) {
341 printf("\nNG86: stop codon %s.\n", getcodon(str, iy[i]));
342 exit(-1);
343 }
344 for (j = 0; j < 3; j++)
345 for (k = 0; k < 4; k++) {
346 if (k == b[i][j]) continue;
347 i1 = GeneticCode[icode][iy[i] + (k - b[i][j])*by[j]];
348 if (i1 == -1)
349 nstop++;
350 else if (i1 == iaa[i])
351 (*SynSite)++;
352 }
353 }
354 *SynSite *= 3 / 18.; /* 2 codons, 2*9 possibilities. */
355 *AsynSite = 3 * (1 - nstop / 18.) - *SynSite;
356
357 #if 0 /* MEGA 1.1 */
358 * AsynSite = 3 - *SynSite;
359 #endif
360
361 ndiff = 0; *SynDif = *AsynDif = 0;
362 for (k = 0; k < 3; k++) dmark[k] = -1;
363 for (k = 0; k < 3; k++)
364 if (b[0][k] - b[1][k]) dmark[ndiff++] = k;
365 if (ndiff == 0) return(0);
366 npath = 1;
367 nstop = 0;
368 if (ndiff > 1)
369 npath = (ndiff == 2 ? 2 : 6);
370 if (ndiff == 1) {
371 if (iaa[0] == iaa[1]) (*SynDif)++;
372 else (*AsynDif)++;
373 }
374 else { /* ndiff=2 or 3 */
375 for (k = 0; k < npath; k++) {
376 for (i1 = 0; i1 < 3; i1++)
377 step[i1] = -1;
378 if (ndiff == 2) {
379 step[0] = dmark[k];
380 step[1] = dmark[1 - k];
381 }
382 else {
383 step[0] = k / 2; step[1] = k % 2;
384 if (step[0] <= step[1]) step[1]++;
385 step[2] = 3 - step[0] - step[1];
386 }
387
388 for (i1 = 0; i1 < 3; i1++)
389 bt1[i1] = bt2[i1] = b[0][i1];
390 sdpath = ndpath = 0; /* mutations for each path */
391 for (i1 = 0; i1 < ndiff; i1++) { /* mutation steps for each path */
392 bt2[step[i1]] = b[1][step[i1]];
393 for (i2 = 0, ic[0] = ic[1] = 0; i2 < 3; i2++) {
394 ic[0] += bt1[i2] * by[i2];
395 ic[1] += bt2[i2] * by[i2];
396 }
397 for (i2 = 0; i2 < 2; i2++) iaa[i2] = GeneticCode[icode][ic[i2]];
398 if (iaa[1] == -1) {
399 nstop++; sdpath = ndpath = 0; break;
400 }
401 if (iaa[0] == iaa[1]) sdpath++;
402 else ndpath++;
403 for (i2 = 0; i2 < 3; i2++)
404 bt1[i2] = bt2[i2];
405 }
406 *SynDif += (double)sdpath;
407 *AsynDif += (double)ndpath;
408 }
409 }
410 if (npath == nstop) {
411 puts("NG86: All paths are through stop codons..");
412 if (ndiff == 2) { *SynDif = 0; *AsynDif = 2; }
413 else { *SynDif = 1; *AsynDif = 2; }
414 }
415 else {
416 *SynDif /= (double)(npath - nstop); *AsynDif /= (double)(npath - nstop);
417 }
418 return (ndiff);
419 }
420
421
422
difcodonLWL85(char codon1[],char codon2[],double sites[3],double sdiff[3],double vdiff[3],int transfed,int icode)423 int difcodonLWL85(char codon1[], char codon2[], double sites[3], double sdiff[3],
424 double vdiff[3], int transfed, int icode)
425 {
426 /* This partitions codon sites according to degeneracy, that is sites[3] has
427 L0, L2, L4, averaged between the two codons. It also compares the two codons
428 and add the differences to the transition and transversion differences for use
429 in LWL85 and similar methods.
430 The two codons (codon1 & codon2) should not contain ambiguity characters.
431 c[0] & c[1] are the two codons, coded 0, 1, ..., 63.
432 b[][] has the nucleotides, coded 0123 for TCAG.
433 */
434 int b[2][3], by[3] = { 16, 4, 1 }, i, j, ifold[2], c[2], ct, aa[2], ibase, nsame;
435 char str[4] = "";
436
437 for (i = 0; i < 3; i++) sites[i] = sdiff[i] = vdiff[i] = 0;
438 /* check the two codons and code them */
439 for (i = 0; i < 2; i++) {
440 for (j = 0, c[i] = 0; j < 3; j++) {
441 if (transfed) b[i][j] = (i ? codon1[j] : codon2[j]);
442 else b[i][j] = (int)CodeChara((char)(i ? codon1[j] : codon2[j]), 0);
443 c[i] += b[i][j] * by[j];
444 if (b[i][j] < 0 || b[i][j]>3) {
445 if (noisy >= 9)
446 printf("\nwarning ambiguity in difcodonLWL85: %s %s", codon1, codon2);
447 return(0);
448 }
449 }
450 aa[i] = GeneticCode[icode][c[i]];
451 if (aa[i] == -1) {
452 printf("\nLWL85: stop codon %s.\n", getcodon(str, c[i]));
453 exit(-1);
454 }
455 }
456
457 for (j = 0; j < 3; j++) { /* three codon positions */
458 for (i = 0; i < 2; i++) { /* two codons */
459 for (ibase = 0, nsame = 0; ibase < 4; ibase++) { /* change codon i pos j into ibase */
460 ct = c[i] + (ibase - b[i][j])*by[j];
461 if (ibase != b[i][j] && aa[i] == GeneticCode[icode][ct]) nsame++;
462 }
463 if (nsame == 0) ifold[i] = 0; /* codon i pos j is 0-fold */
464 else if (nsame == 1 || nsame == 2) ifold[i] = 1; /* codon i pos j is 2-fold */
465 else ifold[i] = 2; /* codon i pos j is 4-fold */
466 sites[ifold[i]] += .5;
467 }
468
469 if (b[0][j] == b[1][j]) continue;
470 if (b[0][j] + b[1][j] == 1 || b[0][j] + b[1][j] == 5) { /* pos j has a transition */
471 sdiff[ifold[0]] += .5; sdiff[ifold[1]] += .5;
472 }
473 else { /* pos j has a transversion */
474 vdiff[ifold[0]] += .5; vdiff[ifold[1]] += .5;
475 }
476 }
477 return (0);
478 }
479
480
481
testTransP(double P[],int n)482 int testTransP(double P[], int n)
483 {
484 int i, j, status = 0;
485 double sum, smallv = 1e-10;
486
487 for (i = 0; i < n; i++) {
488 for (j = 0, sum = 0; j < n; sum += P[i*n + j++])
489 if (P[i*n + j] < -smallv) status = -1;
490 if (fabs(sum - 1) > smallv && status == 0) {
491 printf("\nrow sum (#%2d) = 1 = %10.6f", i + 1, sum);
492 status = -1;
493 }
494 }
495 return (status);
496 }
497
testDetailedBalance(double P[],double pi[],int n)498 double testDetailedBalance(double P[], double pi[], int n)
499 {
500 /* this calculates maxdiff for the detailed balance check. maxdiff should be close
501 to 0 if the detailed balance condition holds.
502 */
503 int i, j, status = 0;
504 double smallv = 1e-10, maxdiff = 0, d;
505
506 for (i = 0; i < n; i++) {
507 for (j = 0; j < n; j++) {
508 d = fabs(pi[i] * P[i*n + j] - pi[j] * P[j*n + i]);
509 if (d > maxdiff) maxdiff = d;
510 }
511 }
512 return (maxdiff);
513 }
514
515
PMatUVRoot(double P[],double t,int n,double U[],double V[],double Root[])516 int PMatUVRoot(double P[], double t, int n, double U[], double V[], double Root[])
517 {
518 /* P(t) = U * exp{Root*t} * V
519 */
520 int i, j, k;
521 double exptm1, uexpt, *pP;
522
523 NPMatUVRoot++;
524 memset(P, 0, n*n * sizeof(double));
525 for (k = 0; k < n; k++) {
526 for (i = 0, pP = P, exptm1 = expm1(t*Root[k]); i < n; i++)
527 for (j = 0, uexpt = U[i*n + k] * exptm1; j < n; j++)
528 *pP++ += uexpt*V[k*n + j];
529 }
530 for (i = 0; i < n; i++) P[i*n+i] ++;
531
532 #if (DEBUG>=5)
533 if (testTransP(P, n)) {
534 printf("\nP(%.6f) err in PMatUVRoot.\n", t);
535 exit(-1);
536 }
537 #endif
538
539 return (0);
540 }
541
542
543
PMatQRev(double Q[],double pi[],double t,int n,double space[])544 int PMatQRev(double Q[], double pi[], double t, int n, double space[])
545 {
546 /* This calculates P(t) = exp(Q*t), where Q is the rate matrix for a
547 time-reversible Markov process.
548
549 Q[] or P[] has the rate matrix as input, and P(t) in return.
550 space[n*n*2+n*2]
551 */
552 double *U = space, *V = U + n*n, *Root = V + n*n, *spacesqrtpi = Root + n;
553
554 eigenQREV(Q, pi, n, Root, U, V, spacesqrtpi);
555 PMatUVRoot(Q, t, n, U, V, Root);
556 return(0);
557 }
558
559
pijJC69(double pij[2],double t)560 void pijJC69(double pij[2], double t)
561 {
562 double exptm1;
563 if (t < -1e-6)
564 printf("\nt = %.5f in pijJC69", t);
565 exptm1 = expm1(-4 * t / 3.);
566 pij[0] = 1. + 3/4.0 * exptm1;
567 pij[1] = -exptm1 / 4;
568 }
569
570
571
PMatK80(double P[],double t,double kappa)572 int PMatK80(double P[], double t, double kappa)
573 {
574 /* PMat for JC69 and K80
575 */
576 int i, j;
577 double e1, e2;
578
579 if (t < -1e-6)
580 printf("\nt = %.5f in PMatK80", t);
581
582 e1 = expm1(-4 * t / (kappa + 2));
583 if (fabs(kappa - 1) < 1e-20) {
584 for (i = 0; i < 4; i++)
585 for (j = 0; j < 4; j++)
586 if (i == j) P[i * 4 + j] = 1. + 3 / 4.0 * e1;
587 else P[i * 4 + j] = -e1 / 4;
588 }
589 else {
590 e2 = expm1(-2 * t*(kappa + 1) / (kappa + 2));
591 for (i = 0; i < 4; i++)
592 P[i * 4 + i] = 1 + (e1 + 2 * e2) / 4;
593 P[0 * 4 + 1] = P[1 * 4 + 0] = P[2 * 4 + 3] = P[3 * 4 + 2] = (e1 - 2 * e2) / 4;
594 P[0 * 4 + 2] = P[0 * 4 + 3] = P[2 * 4 + 0] = P[3 * 4 + 0] =
595 P[1 * 4 + 2] = P[1 * 4 + 3] = P[2 * 4 + 1] = P[3 * 4 + 1] = -e1 / 4;
596 }
597 return (0);
598 }
599
600
PMatT92(double P[],double t,double kappa,double pGC)601 int PMatT92(double P[], double t, double kappa, double pGC)
602 {
603 /* PMat for Tamura'92
604 t is branch lnegth, number of changes per site.
605 */
606 double e1, e2;
607 t /= (pGC*(1 - pGC)*kappa + .5);
608
609 if (t < -1e-4) printf("\nt = %.5f in PMatT92", t);
610 e1 = expm1(-t);
611 e2 = expm1(-(kappa + 1)*t / 2);
612
613 P[0 * 4 + 0] = P[2 * 4 + 2] = 1 + 0.5*(1 - pGC) * e1 + pGC*e2;
614 P[1 * 4 + 1] = P[3 * 4 + 3] = 1 + pGC / 2 * e1 + (1 - pGC)*e2;
615 P[1 * 4 + 0] = P[3 * 4 + 2] = (1 - pGC) / 2 * e1 - (1 - pGC)*e2;
616 P[0 * 4 + 1] = P[2 * 4 + 3] = pGC / 2 * e1 - pGC*e2;
617
618 P[0 * 4 + 2] = P[2 * 4 + 0] = P[3 * 4 + 0] = P[1 * 4 + 2] = -(1 - pGC) / 2 * e1;
619 P[1 * 4 + 3] = P[3 * 4 + 1] = P[0 * 4 + 3] = P[2 * 4 + 1] = -pGC / 2 * e1;
620
621 return (0);
622 }
623
624
PMatTN93(double P[],double a1t,double a2t,double bt,double pi[])625 int PMatTN93(double P[], double a1t, double a2t, double bt, double pi[])
626 {
627 double T = pi[0], C = pi[1], A = pi[2], G = pi[3], Y = T + C, R = A + G;
628 double e1, e2, e3, smallv = -1e-6;
629
630 if (noisy && (a1t < smallv || a2t < smallv || bt < smallv))
631 printf("\nat=%12.6f %12.6f bt=%12.6f", a1t, a2t, bt);
632
633 e1 = expm1(-bt);
634 e2 = expm1(-(R*a2t + Y*bt));
635 e3 = expm1(-(Y*a1t + R*bt));
636
637 P[0 * 4 + 0] = 1 + (R*T*e1 + C*e3) / Y;
638 P[0 * 4 + 1] = (R*e1 - e3)*C / Y;
639 P[0 * 4 + 2] = -A*e1;
640 P[0 * 4 + 3] = -G*e1;
641
642 P[1 * 4 + 0] = (R*e1 - e3)*T / Y;
643 P[1 * 4 + 1] = 1 + (R*C*e1 + T*e3) / Y;
644 P[1 * 4 + 2] = -A*e1;
645 P[1 * 4 + 3] = -G*e1;
646
647 P[2 * 4 + 0] = -T*e1;
648 P[2 * 4 + 1] = -C*e1;
649 P[2 * 4 + 2] = 1 + Y*A / R*e1 + G / R*e2;
650 P[2 * 4 + 3] = Y*G / R*e1 - G / R*e2;
651
652 P[3 * 4 + 0] = -T*e1;
653 P[3 * 4 + 1] = -C*e1;
654 P[3 * 4 + 2] = Y*A / R*e1 - A / R*e2;
655 P[3 * 4 + 3] = 1 + Y*G / R*e1 + A / R*e2;
656
657 return(0);
658 }
659
660
EvolveHKY85(char source[],char target[],int ls,double t,double rates[],double pi[4],double kappa,int isHKY85)661 int EvolveHKY85(char source[], char target[], int ls, double t,
662 double rates[], double pi[4], double kappa, int isHKY85)
663 {
664 /* isHKY85=1 if HKY85, =0 if F84
665 Use NULL for rates if rates are identical among sites.
666 */
667 int i, j, h, n = 4;
668 double TransP[16], a1t, a2t, bt, r, Y = pi[0] + pi[1], R = pi[2] + pi[3];
669
670 if (isHKY85) a1t = a2t = kappa;
671 else { a1t = 1 + kappa / Y; a2t = 1 + kappa / R; }
672 bt = t / (2 * (pi[0] * pi[1] * a1t + pi[2] * pi[3] * a2t) + 2 * Y*R);
673 a1t *= bt; a2t *= bt;
674 FOR(h, ls) {
675 if (h == 0 || (rates && rates[h] != rates[h - 1])) {
676 r = (rates ? rates[h] : 1);
677 PMatTN93(TransP, a1t*r, a2t*r, bt*r, pi);
678 for (i = 0; i < n; i++) {
679 for (j = 1; j < n; j++) TransP[i*n + j] += TransP[i*n + j - 1];
680 if (fabs(TransP[i*n + n - 1] - 1) > 1e-5) error2("TransP err");
681 }
682 }
683 for (j = 0, i = source[h], r = rndu(); j < n - 1; j++) if (r < TransP[i*n + j]) break;
684 target[h] = (char)j;
685 }
686 return (0);
687 }
688
Rates4Sites(double rates[],double alpha,int ncatG,int ls,int cdf,double space[])689 int Rates4Sites(double rates[], double alpha, int ncatG, int ls, int cdf, double space[])
690 {
691 /* Rates for sites from the gamma (ncatG=0) or discrete-gamma (ncatG>1).
692 Rates are converted into the c.d.f. if cdf=1, which is useful for
693 simulation under JC69-like models.
694 space[ncatG*5]
695 */
696 int h, ir, j, K = ncatG, *Lalias = (int*)(space + 3 * K), *counts = (int*)(space + 4 * K);
697 double *rK = space, *freqK = space + K, *Falias = space + 2 * K;
698
699 if (alpha == 0) {
700 if (rates) FOR(h, ls) rates[h] = 1;
701 }
702 else {
703 if (K > 1) {
704 DiscreteGamma(freqK, rK, alpha, alpha, K, DGammaUseMedian);
705
706 MultiNomialAliasSetTable(K, freqK, Falias, Lalias, space + 5 * K);
707 MultiNomialAlias(ls, K, Falias, Lalias, counts);
708
709 for (ir = 0, h = 0; ir < K; ir++)
710 for (j = 0; j < counts[ir]; j++) rates[h++] = rK[ir];
711 }
712 else
713 for (h = 0; h < ls; h++) rates[h] = rndgamma(alpha) / alpha;
714 if (cdf) {
715 for (h = 1; h < ls; h++) rates[h] += rates[h - 1];
716 abyx(1 / rates[ls - 1], rates, ls); /* this rescaling may not be needed. */
717 }
718 }
719 return (0);
720 }
721
722
getcodon(char codon[],int icodon)723 char *getcodon(char codon[], int icodon)
724 {
725 /* id : (0,63) */
726 if (icodon < 0 || icodon>63) {
727 printf("\ncodon %d\n", icodon);
728 error2("getcodon.");
729 }
730 codon[0] = BASEs[icodon / 16];
731 codon[1] = BASEs[(icodon % 16) / 4];
732 codon[2] = BASEs[icodon % 4];
733 codon[3] = 0;
734 return (codon);
735 }
736
737
getAAstr(char * AAstr,int iaa)738 char *getAAstr(char *AAstr, int iaa)
739 {
740 /* iaa (0,20) with 20 meaning termination */
741 if (iaa < 0 || iaa>20) error2("getAAstr: iaa err. \n");
742 strncpy(AAstr, AA3Str + iaa * 3, 3);
743 return (AAstr);
744 }
745
NucListall(char b,int * nb,int ib[4])746 int NucListall(char b, int *nb, int ib[4])
747 {
748 /* Resolve an ambiguity nucleotide b into all possibilities.
749 nb is number of bases and ib (0,1,2,3) list all of them.
750 Data are complete if (nb==1).
751 */
752 int j, k;
753
754 k = (int)(strchr(BASEs, (int)b) - BASEs);
755 if (k < 0)
756 {
757 printf("NucListall: strange character %c\n", b); return(-1);
758 }
759 if (k < 4) {
760 *nb = 1; ib[0] = k;
761 }
762 else {
763 *nb = (int)strlen(EquateBASE[k]);
764 for (j = 0; j < *nb; j++)
765 ib[j] = (int)(strchr(BASEs, EquateBASE[k][j]) - BASEs);
766 }
767 return(0);
768 }
769
Codon2AA(char codon[3],char aa[3],int icode,int * iaa)770 int Codon2AA(char codon[3], char aa[3], int icode, int *iaa)
771 {
772 /* translate a triplet codon[] into amino acid (aa[] and iaa), using
773 genetic code icode. This deals with ambiguity nucleotides.
774 *iaa=(0,...,19), 20 for stop or missing data.
775 Distinquish between stop codon and missing data?
776 naa=0: only stop codons; 1: one AA; 2: more than 1 AA.
777
778 Returns 0: if one amino acid
779 1: if multiple amino acids (ambiguity data)
780 -1: if stop codon
781 */
782 int nb[3], ib[3][4], ic, i, i0, i1, i2, iaa0 = -1, naa = 0;
783
784 for (i = 0; i < 3; i++)
785 NucListall(codon[i], &nb[i], ib[i]);
786 for (i0 = 0; i0 < nb[0]; i0++)
787 for (i1 = 0; i1 < nb[1]; i1++)
788 for (i2 = 0; i2 < nb[2]; i2++) {
789 ic = ib[0][i0] * 16 + ib[1][i1] * 4 + ib[2][i2];
790 *iaa = GeneticCode[icode][ic];
791 if (*iaa == -1) continue;
792 if (naa == 0) { iaa0 = *iaa; naa++; }
793 else if (*iaa != iaa0) naa = 2;
794 }
795
796 if (naa == 0) {
797 printf("stop codon %c%c%c\n", codon[0], codon[1], codon[2]);
798 *iaa = 20;
799 }
800 else if (naa == 2) *iaa = 20;
801 else *iaa = iaa0;
802 strncpy(aa, AA3Str + *iaa * 3, 3);
803
804 return(naa == 1 ? 0 : (naa == 0 ? -1 : 1));
805 }
806
DNA2protein(char dna[],char protein[],int lc,int icode)807 int DNA2protein(char dna[], char protein[], int lc, int icode)
808 {
809 /* translate a DNA into a protein, using genetic code icode, with lc codons.
810 dna[] and protein[] can be the same string.
811 */
812 int h, iaa, k;
813 char aa3[4];
814
815 for (h = 0; h < lc; h++) {
816 k = Codon2AA(dna + h * 3, aa3, icode, &iaa);
817 if (k == -1) printf(" stop codon at %d out of %d\n", h + 1, lc);
818 protein[h] = AAs[iaa];
819 }
820 return(0);
821 }
822
823
printcu(FILE * fout,double fcodon[],int icode)824 int printcu(FILE *fout, double fcodon[], int icode)
825 {
826 /* output codon usage table and other related statistics
827 space[20+1+3*5]
828 Outputs the genetic code table if fcodon==NULL
829 */
830 int wc = 8, wd = 0; /* wc: for codon, wd: decimal */
831 int it, i, j, k, iaa;
832 double faa[21], fb3x4[3 * 5]; /* chi34, Ic, lc, */
833 char *word = "|-", aa3[4] = " ", codon[4] = " ", ss3[4][4], *noodle;
834 static double aawt[] = { 89.1, 174.2, 132.1, 133.1, 121.2, 146.2,
835 147.1, 75.1, 155.2, 131.2, 131.2, 146.2, 149.2, 165.2, 115.1,
836 105.1, 119.1, 204.2, 181.2, 117.1 };
837
838 if (fcodon) { zero(faa, 21); zero(fb3x4, 12); }
839 else wc = 0;
840 for (i = 0; i < 4; i++) strcpy(ss3[i], "\0\0\0");
841 noodle = strc(4 * (10 + 2 + wc) - 2, word[1]);
842 fprintf(fout, "\n%s\n", noodle);
843 for (i = 0; i < 4; i++) {
844 for (j = 0; j < 4; j++) {
845 for (k = 0; k < 4; k++) {
846 it = i * 16 + k * 4 + j;
847 iaa = GeneticCode[icode][it];
848 if (iaa == -1) iaa = 20;
849 getcodon(codon, it); getAAstr(aa3, iaa);
850 if (!strcmp(ss3[k], aa3) && j > 0)
851 fprintf(fout, " ");
852 else {
853 fprintf(fout, "%s %c", aa3, (iaa < 20 ? AAs[iaa] : '*'));
854 strcpy(ss3[k], aa3);
855 }
856 fprintf(fout, " %s", codon);
857 if (fcodon) fprintf(fout, "%*.*f", wc, wd, fcodon[it]);
858 if (k < 3) fprintf(fout, " %c ", word[0]);
859 }
860 fprintf(fout, "\n");
861 }
862 fprintf(fout, "%s\n", noodle);
863 }
864 return(0);
865 }
866
printcums(FILE * fout,int ns,double fcodons[],int icode)867 int printcums(FILE *fout, int ns, double fcodons[], int icode)
868 {
869 int neach0 = 6, neach = neach0, wc = 4, wd = 0; /* wc: for codon, wd: decimal */
870 int iaa, it, i, j, k, i1, ngroup, igroup;
871 char *word = "|-", aa3[4] = " ", codon[4] = " ", ss3[4][4], *noodle;
872
873 ngroup = (ns - 1) / neach + 1;
874 for (igroup = 0; igroup < ngroup; igroup++) {
875 if (igroup == ngroup - 1)
876 neach = ns - neach0*igroup;
877 noodle = strc(4 * (10 + wc*neach) - 2, word[1]);
878 strcat(noodle, "\n");
879 fputs(noodle, fout);
880 for (i = 0; i < 4; i++) strcpy(ss3[i], " ");
881 for (i = 0; i < 4; i++) {
882 for (j = 0; j < 4; j++) {
883 for (k = 0; k < 4; k++) {
884 it = i * 16 + k * 4 + j;
885 iaa = GeneticCode[icode][it];
886 if (iaa == -1) iaa = 20;
887 getcodon(codon, it);
888 getAAstr(aa3, iaa);
889 if (!strcmp(ss3[k], aa3) && j > 0) fprintf(fout, " ");
890 else { fprintf(fout, "%s", aa3); strcpy(ss3[k], aa3); }
891
892 fprintf(fout, " %s", codon);
893 for (i1 = 0; i1 < neach; i1++)
894 fprintf(fout, " %*.*f", wc - 1, wd, fcodons[(igroup*neach0 + i1) * 64 + it]);
895 if (k < 3) fprintf(fout, " %c ", word[0]);
896 }
897 fprintf(fout, "\n");
898 }
899 fputs(noodle, fout);
900 }
901 fprintf(fout, "\n");
902 }
903 return(0);
904 }
905
QtoPi(double Q[],double pi[],int n,double space[])906 int QtoPi(double Q[], double pi[], int n, double space[])
907 {
908 /* from rate matrix Q[] to pi, the stationary frequencies:
909 Q' * pi = 0 pi * 1 = 1
910 space[] is of size n*(n+1).
911 */
912 int i, j;
913 double *T = space; /* T[n*(n+1)] */
914
915 for (i = 0; i < n + 1; i++) T[i] = 1;
916 for (i = 1; i < n; i++) {
917 for (j = 0; j < n; j++)
918 T[i*(n + 1) + j] = Q[j*n + i]; /* transpose */
919 T[i*(n + 1) + n] = 0.;
920 }
921 matinv(T, n, n + 1, pi);
922 for (i = 0; i < n; i++)
923 pi[i] = T[i*(n + 1) + n];
924 return (0);
925 }
926
PtoPi(double P[],double pi[],int n,double space[])927 int PtoPi(double P[], double pi[], int n, double space[])
928 {
929 /* from transition probability P[ij] to pi, the stationary frequencies
930 (P'-I) * pi = 0 pi * 1 = 1
931 space[] is of size n*(n+1).
932 */
933 int i, j;
934 double *T = space; /* T[n*(n+1)] */
935
936 for (i = 0; i < n + 1; i++) T[i] = 1;
937 for (i = 1; i < n; i++) {
938 for (j = 0; j < n; j++)
939 T[i*(n + 1) + j] = P[j*n + i] - (double)(i == j); /* transpose */
940 T[i*(n + 1) + n] = 0;
941 }
942 matinv(T, n, n + 1, pi);
943 for (i = 0; i < n; i++) pi[i] = T[i*(n + 1) + n];
944 return (0);
945 }
946
PtoX(double P1[],double P2[],double pi[],double X[])947 int PtoX(double P1[], double P2[], double pi[], double X[])
948 {
949 /* from P1 & P2 to X. X = P1' diag{pi} P2
950 */
951 int i, j, k;
952
953 for (i = 0; i < 4; i++)
954 for (j = 0; j < 4; j++)
955 for (k = 0, X[i * 4 + j] = 0.0; k < 4; k++) {
956 X[i * 4 + j] += pi[k] * P1[k * 4 + i] * P2[k * 4 + j];
957 }
958 return (0);
959 }
960
961
ScanFastaFile(FILE * fin,int * ns,int * ls,int * aligned)962 int ScanFastaFile(FILE *fin, int *ns, int *ls, int *aligned)
963 {
964 /* This scans a fasta alignment file to get com.ns & com.ls.
965 Returns -1 if the sequences are not aligned and have different lengths.
966 */
967 int len = 0, ch, starter = '>', stop = '/'; /* both EOF and / mark the end of the file. */
968 char name[200], *p;
969
970 if (noisy) printf("\nprocessing fasta file");
971 for (*aligned = 1, *ns = -1, *ls = 0; ; ) {
972 ch = fgetc(fin);
973 if (ch == starter || ch == EOF || ch == stop) {
974 if (*ns >= 0) { /* process end of the sequence */
975 if (noisy) printf(" %7d sites", len);
976
977 if (*ns > 1 && len != *ls) {
978 *aligned = 0;
979 printf("previous sequence %s has len %d, current seq has %d\n", name, *ls, len);
980 }
981 if (len > *ls) *ls = len;
982 }
983 (*ns)++; /* next sequence */
984 if (ch == EOF || ch == stop) break;
985 /* fscanf(fin, "%s", name); */
986 p = name;
987 while ((ch = getc(fin)) != '\n' && ch != EOF) *p++ = ch;
988 *p = '\0';
989 if (noisy) printf("\nreading seq#%2d %-50s", *ns + 1, name);
990 len = 0;
991 }
992 else if (isgraph(ch)) {
993 if (*ns == -1)
994 error2("seq file error: use '>' in fasta format.");
995 len++;
996 }
997 }
998 rewind(fin);
999 return(0);
1000 }
1001
1002
printaSeq(FILE * fout,char z[],int ls,int lline,int gap)1003 int printaSeq(FILE *fout, char z[], int ls, int lline, int gap)
1004 {
1005 int i;
1006 for (i = 0; i < ls; i++) {
1007 fprintf(fout, "%c", z[i]);
1008 if (gap && (i + 1) % gap == 0) fprintf(fout, " ");
1009 if ((i + 1) % lline == 0) fprintf(fout, "%7d\n", i + 1);
1010 }
1011 i = ls%lline;
1012 if (i) fprintf(fout, "%*d\n", 7 + lline + lline / gap - i - i / gap, ls);
1013 fprintf(fout, "\n");
1014 return (0);
1015 }
1016
printsma(FILE * fout,char * spname[],unsigned char * z[],int ns,int l,int lline,int gap,int seqtype,int transformed,int simple,int pose[])1017 int printsma(FILE*fout, char*spname[], unsigned char*z[], int ns, int l, int lline, int gap, int seqtype,
1018 int transformed, int simple, int pose[])
1019 {
1020 /* print multiple aligned sequences.
1021 use spname==NULL if no seq names available.
1022 pose[h] marks the position of the h_th site in z[], useful for
1023 printing out the original sequences after site patterns are collapsed.
1024 Sequences z[] are coded if(transformed) and not if otherwise.
1025 */
1026 int igroup, ngroup, lt, h, hp, i, b, b0 = -1, igap, lspname = 30, lseqlen = 7;
1027 char indel = '-', ambi = '?', equal = '.';
1028 char *pch = (seqtype <= 1 ? BASEs : (seqtype == 2 ? AAs : BINs));
1029 char codon[4] = " ";
1030
1031 if (l == 0) return(1);
1032 codon[0] = -1; /* to avoid warning */
1033 if (gap == 0) gap = lline + 1;
1034 ngroup = (l - 1) / lline + 1;
1035 fprintf(fout, "\n");
1036 for (igroup = 0; igroup < ngroup; igroup++) {
1037 lt = min2(l, (igroup + 1)*lline); /* seqlen mark at the end of block */
1038 igap = lline + (lline / gap) + lspname + 1 - lseqlen - 1; /* spaces */
1039 if (igroup + 1 == ngroup)
1040 igap = (l - igroup*lline) + (l - igroup*lline) / gap + lspname + 1 - lseqlen - 1;
1041 /* fprintf (fout,"%*s[%*d]\n", igap, "", lseqlen,lt); */
1042 for (i = 0; i < ns; i++) {
1043 if (spname) fprintf(fout, "%-*s ", lspname, spname[i]);
1044 for (h = igroup*lline, lt = 0, igap = 0; lt < lline && h < l; h++, lt++) {
1045 hp = (pose ? pose[h] : h);
1046 if (seqtype == CODONseq && transformed) {
1047 fprintf(fout, " %s", CODONs[(int)z[i][hp]]);
1048 continue;
1049 }
1050 b0 = (int)z[0][hp];
1051 b = (int)z[i][hp];
1052 if (transformed) {
1053 b0 = pch[b0];
1054 b = pch[b];
1055 }
1056 if (i&&simple && b == b0 && b != indel && b != ambi)
1057 b = equal;
1058 fputc(b, fout);
1059 if (++igap == gap) {
1060 fputc(' ', fout); igap = 0;
1061 }
1062 }
1063 fprintf(fout, "\n");
1064 }
1065 fprintf(fout, "\n");
1066 }
1067 fprintf(fout, "\n");
1068 return(0);
1069 }
1070
1071
1072
1073 /* ***************************
1074 Simple tools
1075 ******************************/
1076
1077 static time_t time_start;
1078
starttimer(void)1079 void starttimer(void)
1080 {
1081 time_start = time(NULL);
1082 }
1083
printtime(char timestr[])1084 char *printtime(char timestr[])
1085 {
1086 /* print time elapsed since last call to starttimer()
1087 */
1088 time_t t;
1089 int h, m, s;
1090
1091 t = time(NULL) - time_start;
1092 h = (int)t / 3600;
1093 m = (int)(t % 3600) / 60;
1094 s = (int)(t - (t / 60) * 60);
1095 if (h) sprintf(timestr, "%d:%02d:%02d", h, m, s);
1096 else sprintf(timestr, "%2d:%02d", m, s);
1097 return(timestr);
1098 }
1099
sleep2(int wait)1100 void sleep2(int wait)
1101 {
1102 /* Pauses for a specified number of seconds. */
1103 time_t t_cur = time(NULL);
1104
1105 while (time(NULL) < t_cur + wait);
1106 }
1107
1108
1109
strc(int n,int c)1110 char *strc(int n, int c)
1111 {
1112 static char s[256];
1113 int i;
1114
1115 if (n > 255) error2("line >255 in strc");
1116 for (i = 0; i < n; i++) s[i] = (char)c;
1117 s[n] = 0;
1118 return (s);
1119 }
1120
putdouble(FILE * fout,double a)1121 int putdouble(FILE*fout, double a)
1122 {
1123 double aa = fabs(a);
1124 return fprintf(fout, (aa<1e-5 || aa>1e6 ? " %11.4e" : " %11.6f"), a);
1125 }
1126
strcase(char * str,int direction)1127 void strcase(char *str, int direction)
1128 {
1129 /* direction = 0: to lower; 1: to upper */
1130 char *p = str;
1131 if (direction) while (*p) { *p = (char)toupper(*p); p++; }
1132 else while (*p) { *p = (char)tolower(*p); p++; }
1133 }
1134
1135
gfopen(char * filename,char * mode)1136 FILE *gfopen(char *filename, char *mode)
1137 {
1138 FILE *fp;
1139
1140 if (filename == NULL || filename[0] == 0)
1141 error2("file name empty.");
1142
1143 fp = (FILE*)fopen(filename, mode);
1144 if (fp == NULL) {
1145 printf("\nerror when opening file %s\n", filename);
1146 if (!strchr(mode, 'r')) exit(-1);
1147 printf("tell me the full path-name of the file? ");
1148 scanf("%s", filename);
1149 if ((fp = (FILE*)fopen(filename, mode)) != NULL) return(fp);
1150 puts("Can't find the file. I give up.");
1151 exit(-1);
1152 }
1153 return(fp);
1154 }
1155
1156
appendfile(FILE * fout,char * filename)1157 int appendfile(FILE*fout, char*filename)
1158 {
1159 FILE *fin = fopen(filename, "r");
1160 int ch, status = 0;
1161
1162 if (fin == NULL) {
1163 printf("file %s not found!", filename);
1164 status = -1;
1165 }
1166 else {
1167 while ((ch = fgetc(fin)) != EOF)
1168 fputc(ch, fout);
1169 fclose(fin);
1170 fflush(fout);
1171 }
1172 return(status);
1173 }
1174
1175
error2(char * message)1176 void error2(char * message)
1177 {
1178 fprintf(stderr, "\nError: %s.\n", message);
1179 exit(-1);
1180 }
1181
zero(double x[],int n)1182 int zero(double x[], int n)
1183 {
1184 int i; for (i = 0; i < n; i++) x[i] = 0; return (0);
1185 }
1186
sum(double x[],int n)1187 double sum(double x[], int n)
1188 {
1189 int i; double t = 0; for (i = 0; i < n; i++) t += x[i]; return(t);
1190 }
1191
fillxc(double x[],double c,int n)1192 int fillxc(double x[], double c, int n)
1193 {
1194 int i; for (i = 0; i < n; i++) x[i] = c; return (0);
1195 }
1196
xtoy(double x[],double y[],int n)1197 int xtoy(double x[], double y[], int n)
1198 {
1199 int i; for (i = 0; i < n; y[i] = x[i], i++) {} return(0);
1200 }
1201
abyx(double a,double x[],int n)1202 int abyx(double a, double x[], int n)
1203 {
1204 int i; for (i = 0; i < n; x[i] *= a, i++) {} return(0);
1205 }
1206
axtoy(double a,double x[],double y[],int n)1207 int axtoy(double a, double x[], double y[], int n)
1208 {
1209 int i; for (i = 0; i < n; y[i] = a*x[i], i++) {} return(0);
1210 }
1211
axbytoz(double a,double x[],double b,double y[],double z[],int n)1212 int axbytoz(double a, double x[], double b, double y[], double z[], int n)
1213 {
1214 int i; for (i = 0; i < n; i++) z[i] = a*x[i] + b*y[i]; return (0);
1215 }
1216
identity(double x[],int n)1217 int identity(double x[], int n)
1218 {
1219 int i, j; for (i = 0; i < n; i++) { for (j = 0; j < n; j++) x[i*n + j] = 0; x[i*n + i] = 1; } return (0);
1220 }
1221
distance(double x[],double y[],int n)1222 double distance(double x[], double y[], int n)
1223 {
1224 int i; double t = 0;
1225 for (i = 0; i < n; i++) t += square(x[i] - y[i]);
1226 return(sqrt(t));
1227 }
1228
innerp(double x[],double y[],int n)1229 double innerp(double x[], double y[], int n)
1230 {
1231 int i; double t = 0; for (i = 0; i < n; i++) t += x[i] * y[i]; return(t);
1232 }
1233
norm(double x[],int n)1234 double norm(double x[], int n)
1235 {
1236 int i; double t = 0; for (i = 0; i < n; i++) t += x[i] * x[i]; return sqrt(t);
1237 }
1238
1239
Add2Ptree(int counts[3],double Ptree[3])1240 int Add2Ptree(int counts[3], double Ptree[3])
1241 {
1242 /* Suppose counts[3] have the numbers of sites supporting the three trees. This
1243 routine adds a total of probability 1 to Ptree[3], by breaking ties.
1244 */
1245 int i, ibest[3] = { 0,0,0 }, nbest = 1, *x = counts;
1246
1247 for (i = 1; i < 3; i++) {
1248 if (x[i] > x[ibest[0]])
1249 {
1250 nbest = 1; ibest[0] = i;
1251 }
1252 else if (x[i] == x[ibest[0]])
1253 ibest[nbest++] = i;
1254 }
1255 for (i = 0; i < nbest; i++)
1256 Ptree[ibest[i]] += 1. / nbest;
1257 return(0);
1258 }
1259
1260
binarysearch(const void * key,const void * base,size_t n,size_t size,int (* compare)(const void *,const void *),int * found)1261 int binarysearch(const void *key, const void *base, size_t n, size_t size, int(*compare)(const void *, const void *), int *found)
1262 {
1263 /* This searches for key in an array of n elements (base). The n elements are already sorted.
1264 Each element has size size. If a match is found, the function returns the index for the
1265 element found. Otherwise it returns the loc where key should be inserted. This does not deal with ties.
1266 */
1267 int l = 0, u = (int)n - 1, m = u, z;
1268
1269 *found = 0;
1270 while (l <= u) {
1271 m = (l + u) / 2;
1272 z = (*compare)(key, (char*)base + m*size);
1273 if (z < 0) u = m - 1;
1274 else if (z > 0) l = m + 1;
1275 else { *found = 1; break; }
1276 }
1277 if (m < l) m++; /* last comparison had z > 0 */
1278 return(m);
1279 }
1280
1281
indexing(double x[],int n,int index[],int descending,int space[])1282 int indexing(double x[], int n, int index[], int descending, int space[])
1283 {
1284 /* bubble sort to calculate the indecies for the vector x[].
1285 x[index[2]] will be the third largest or smallest number in x[].
1286 This does not change x[].
1287 */
1288 int i, j, it = 0, *mark = space;
1289 double t = 0;
1290
1291 for (i = 0; i < n; i++) mark[i] = 1;
1292 for (i = 0; i < n; i++) {
1293 for (j = 0; j < n; j++)
1294 if (mark[j]) { t = x[j]; it = j++; break; } /* first unused number */
1295 if (descending) {
1296 for (; j < n; j++)
1297 if (mark[j] && x[j] > t) { t = x[j]; it = j; }
1298 }
1299 else {
1300 for (; j < n; j++)
1301 if (mark[j] && x[j] < t) { t = x[j]; it = j; }
1302 }
1303 mark[it] = 0; index[i] = it;
1304 }
1305 return (0);
1306 }
1307
f_and_x(double x[],double f[],int n,int fromf,int LastItem)1308 int f_and_x(double x[], double f[], int n, int fromf, int LastItem)
1309 {
1310 /* This transforms between x and f. x and f can be identical.
1311 If (fromf), f->x
1312 else x->f.
1313 The iterative variable x[] and frequency f[0,1,n-2] are related as:
1314 freq[k] = exp(x[k])/(1+SUM(exp(x[k]))), k=0,1,...,n-2,
1315 x[] and freq[] may be the same vector.
1316 The last element (f[n-1] or x[n-1]=1) is updated only if(LastItem).
1317 */
1318 int i;
1319 double tot;
1320
1321 if (fromf) { /* f => x */
1322 if ((tot = 1 - sum(f, n - 1)) < 1e-80) error2("f[n-1]==1, not dealt with.");
1323 tot = 1 / tot;
1324 for (i = 0; i < n - 1; i++) x[i] = log(f[i] * tot);
1325 if (LastItem) x[n - 1] = 0;
1326 }
1327 else { /* x => f */
1328 for (i = 0, tot = 1; i < n - 1; i++) tot += (f[i] = exp(x[i]));
1329 for (i = 0; i < n - 1; i++) f[i] /= tot;
1330 if (LastItem) f[n - 1] = 1 / tot;
1331 }
1332 return(0);
1333 }
1334
bigexp(double lnx,double * a,double * b)1335 void bigexp(double lnx, double *a, double *b)
1336 {
1337 /* this prints out x = e^lnx as a*10^b
1338 */
1339 double z;
1340 z = lnx*0.43429448190325182765; /* log10(e) = 0.43429448190325182765 */
1341 *b = floor(z);
1342 *a = pow(10, z - (*b));
1343 }
1344
1345 unsigned int z_rndu = 666, w_rndu = 1237;
1346
SetSeed(int seed,int PrintSeed)1347 void SetSeed(int seed, int PrintSeed)
1348 {
1349 /* Note seed is of type int with -1 meaning "please find a seed".
1350 z_rndu and w_rndu are of type unsigned int.
1351 */
1352 if (sizeof(int) != 4)
1353 error2("oh-oh, we are in trouble. int not 32-bit? rndu() assumes 32-bit int.");
1354
1355 if (seed <= 0) {
1356 FILE *frand = fopen("/dev/urandom", "r");
1357 if (frand) {
1358 if (fread(&seed, sizeof(int), 1, frand) != 1)
1359 error2("failure to read white noise...");
1360 fclose(frand);
1361 seed = abs(seed * 2 - 1);
1362 }
1363 else {
1364 seed = abs(1234 * (int)time(NULL) + 1);
1365 }
1366
1367 if (PrintSeed) {
1368 FILE *fseed;
1369 fseed = fopen("SeedUsed", "w");
1370 if (fseed == NULL) error2("can't open file SeedUsed.");
1371 fprintf(fseed, "%d\n", seed);
1372 fclose(fseed);
1373 }
1374 }
1375
1376 z_rndu = (unsigned int)seed;
1377 w_rndu = (unsigned int)seed;
1378 }
1379
1380
1381 #ifdef FAST_RANDOM_NUMBER
1382
rndu(void)1383 double rndu(void)
1384 {
1385 /* 32-bit integer assumed. From Ripley (1987) p. 46 or table 2.4 line 2. */
1386 #if 0
1387 z_rndu = z_rndu * 69069 + 1;
1388 if (z_rndu == 0 || z_rndu == 4294967295) z_rndu = 13;
1389 return z_rndu / 4294967295.0;
1390 #else
1391 z_rndu = z_rndu * 69069 + 1;
1392 if (z_rndu == 0) z_rndu = 12345671;
1393 return ldexp((double)z_rndu, -32);
1394 #endif
1395 }
1396
rndu2(void)1397 double rndu2(void)
1398 {
1399 /* 32-bit integer assumed. From Ripley (1987) table 2.4 line 4. */
1400 w_rndu = (w_rndu * 16807) % 2147483647; /* can this be made faster */
1401 if (w_rndu == 0) w_rndu = 12345671;
1402 return ldexp((double)w_rndu, -31);
1403 }
1404
1405 #else
1406
rndu(void)1407 double rndu(void)
1408 {
1409 /* U(0,1): AS 183: Appl. Stat. 31:188-190
1410 Wichmann BA & Hill ID. 1982. An efficient and portable
1411 pseudo-random number generator. Appl. Stat. 31:188-190
1412
1413 x, y, z are any numbers in the range 1-30000. Integer operation up
1414 to 30323 required.
1415 */
1416 static unsigned int x_rndu = 11, y_rndu = 23;
1417 double r;
1418
1419 x_rndu = 171 * (x_rndu % 177) - 2 * (x_rndu / 177);
1420 y_rndu = 172 * (y_rndu % 176) - 35 * (y_rndu / 176);
1421 z_rndu = 170 * (z_rndu % 178) - 63 * (z_rndu / 178);
1422 /*
1423 if (x_rndu<0) x_rndu += 30269;
1424 if (y_rndu<0) y_rndu += 30307;
1425 if (z_rndu<0) z_rndu += 30323;
1426 */
1427 r = x_rndu / 30269.0 + y_rndu / 30307.0 + z_rndu / 30323.0;
1428 return (r - (int)r);
1429 }
1430
1431 #endif
1432
1433
rnduM0V1(void)1434 double rnduM0V1(void)
1435 {
1436 /* uniform with mean 0 and variance 1 */
1437 return 1.732050807568877*(-1 + rndu() * 2);
1438 }
1439
1440
reflect(double x,double a,double b)1441 double reflect(double x, double a, double b)
1442 {
1443 /* This returns a variable in the range (a, b) by reflecting x back into the range
1444 */
1445 int side = 0; /* n is number of jumps over interval. side=0 (left) or 1 (right). */
1446 double n, e = 0, smallv = 1e-200; /* e is excess */
1447
1448 if (b - a < smallv) {
1449 printf("\nimproper range x0 = %.9g (%.9g, %.9g)\n", x, a, b);
1450 exit(-1);
1451 }
1452 if (x < a) { e = a - x; side = 0; }
1453 else if (x > b) { e = x - b; side = 1; }
1454 if (e) {
1455 n = floor(e / (b - a));
1456 if (fmod(n, 2.0) > 0.1) /* fmod should be 0 if n is even and 1 if n is odd. */
1457 side = 1 - side; /* change side if n is odd */
1458 e -= n*(b - a);
1459 x = (side ? b - e : a + e);
1460 }
1461
1462 /* If x lands on boundary after reflection, sample a point at random in the interval. */
1463 smallv = (b - a)*1e-9;
1464 while (x - a < smallv || b - x < smallv)
1465 x = a + (b - a)*rndu();
1466
1467 return(x);
1468 }
1469
1470
1471 double PjumpOptimum = 0.30; /* this is the optimum for the Bactrian move. */
1472
ResetStepLengths(FILE * fout,double Pjump[],double finetune[],int nsteps)1473 int ResetStepLengths(FILE *fout, double Pjump[], double finetune[], int nsteps)
1474 {
1475 /* this abjusts the MCMC proposal step lengths, using equation 9 in
1476 Yang, Z. & Rodr�guez, C. E. 2013 Searching for efficient Markov chain Monte Carlo proposal kernels. Proc. Natl .Acad. Sci. U.S.A. 110, 19307�19312.
1477 PjumpOptimum = 0.3 is also from that paper.
1478 */
1479 int j, verybadstep = 0;
1480 double maxstep = 99; /* max step length */
1481
1482 if (noisy >= 3) {
1483 printf("\n(nsteps = %d)\nCurrent Pjump: ", nsteps);
1484 for (j = 0; j < nsteps; j++)
1485 printf(" %8.5f", Pjump[j]);
1486 printf("\nCurrent finetune: ");
1487 for (j = 0; j < nsteps; j++)
1488 printf(" %8.5f", finetune[j]);
1489 }
1490 if (fout) {
1491 fprintf(fout, "\nCurrent Pjump: ");
1492 for (j = 0; j < nsteps; j++)
1493 fprintf(fout, " %8.5f", Pjump[j]);
1494 fprintf(fout, "\nCurrent finetune: ");
1495 for (j = 0; j < nsteps; j++)
1496 fprintf(fout, " %8.5f", finetune[j]);
1497 }
1498
1499 for (j = 0; j < nsteps; j++) {
1500 if (Pjump[j] < 0.001) {
1501 finetune[j] /= 100;
1502 verybadstep = 1;
1503 }
1504 else if (Pjump[j] > 0.999) {
1505 finetune[j] = min2(maxstep, finetune[j] * 100);
1506 verybadstep = 1;
1507 }
1508 else {
1509 finetune[j] *= tan(Pi / 2 * Pjump[j]) / tan(Pi / 2 * PjumpOptimum);
1510 finetune[j] = min2(maxstep, finetune[j]);
1511 }
1512 }
1513
1514 if (noisy >= 3) {
1515 printf("\nNew finetune: ");
1516 for (j = 0; j < nsteps; j++)
1517 printf(" %8.5f", finetune[j]);
1518 printf("\n\n");
1519 }
1520 if (fout) {
1521 fprintf(fout, "\nNew finetune: ");
1522 for (j = 0; j < nsteps; j++)
1523 fprintf(fout, " %8.5f", finetune[j]);
1524 fprintf(fout, "\n");
1525 }
1526
1527 return(verybadstep);
1528 }
1529
1530
1531
randorder(int order[],int n,int space[])1532 void randorder(int order[], int n, int space[])
1533 {
1534 /* This orders 0,1,2,...,n-1 at random
1535 space[n]
1536 */
1537 int i, k, *item = space;
1538
1539 for (i = 0; i < n; i++) item[i] = i;
1540 for (i = 0; i < n; i++) {
1541 k = (int)((n - i)*rndu());
1542 order[i] = item[i + k]; item[i + k] = item[i];
1543 }
1544 }
1545
1546
rndNormal(void)1547 double rndNormal(void)
1548 {
1549 /* Standard normal variate, using the Box-Muller method (1958), improved by
1550 Marsaglia and Bray (1964). The method generates a pair of N(0,1) variates,
1551 but only one is used.
1552 Johnson et al. (1994), Continuous univariate distributions, vol 1. p.153.
1553 */
1554 double u, v, s;
1555
1556 for (; ;) {
1557 u = 2 * rndu() - 1;
1558 v = 2 * rndu() - 1;
1559 s = u*u + v*v;
1560 if (s > 0 && s < 1) break;
1561 }
1562 s = sqrt(-2 * log(s) / s);
1563 return (u*s); /* (v*s) is the other N(0,1) variate, wasted. */
1564 }
1565
1566
rndBinomial(int n,double p)1567 int rndBinomial(int n, double p)
1568 {
1569 /* This may be too slow when n is large.
1570 */
1571 int i, x = 0;
1572
1573 for (i = 0; i < n; i++)
1574 if (rndu() < p) x++;
1575 return (x);
1576 }
1577
1578
rndBactrian(void)1579 double rndBactrian(void)
1580 {
1581 /* This returns a variate from the 1:1 mixture of two normals N(-m, 1-m^2) and N(m, 1-m^2),
1582 which has mean 0 and variance 1.
1583
1584 The value m = 0.95 is useful for generating MCMC proposals
1585 */
1586 double z = mBactrian + rndNormal()*sBactrian;
1587 if (rndu() < 0.5) z = -z;
1588 return (z);
1589 }
1590
1591
rndBactrianTriangle(void)1592 double rndBactrianTriangle(void)
1593 {
1594 /* This returns a variate from the 1:1 mixture of two Triangle Tri(-m, 1-m^2) and Tri(m, 1-m^2),
1595 which has mean 0 and variance 1.
1596 */
1597 double z = mBactrian + rndTriangle()*sBactrian;
1598 if (rndu() < 0.5) z = -z;
1599 return (z);
1600 }
1601
rndBactrianLaplace(void)1602 double rndBactrianLaplace(void)
1603 {
1604 /* This returns a variate from the 1:1 mixture of two Laplace Lap(-m, 1-m^2) and Lap(m, 1-m^2),
1605 which has mean 0 and variance 1.
1606 */
1607 double z = mBactrian + rndLaplace()*sBactrian;
1608 if (rndu() < 0.5) z = -z;
1609 return (z);
1610 }
1611
rndBox(void)1612 double rndBox(void)
1613 {
1614 double z = rndu() * (bBox - aBox) + aBox;
1615 if (rndu() < 0.5) z = -z;
1616 return z;
1617 }
1618
getRoot(double (* f)(double),double (* df)(double),double initVal)1619 double getRoot(double(*f)(double), double(*df)(double), double initVal)
1620 {
1621 double x, newx = initVal;
1622 int nIter = 0;
1623 do {
1624 x = newx;
1625 newx = x - (*f)(x) / (*df)(x);
1626 nIter++;
1627 } while ((fabs(x - newx) > 1e-10) && nIter < 100);
1628
1629 if (fabs(x - newx) > 1e-10) {
1630 error2("root finder didn't converge");
1631 }
1632 return(newx);
1633 }
1634
BAirplane(double b)1635 double BAirplane(double b)
1636 {
1637 return 4 * b*b*b - 12 * b + 6 * aAirplane - aAirplane * aAirplane * aAirplane;
1638 }
1639
dBAirplane(double b)1640 double dBAirplane(double b) {
1641 return 12 * b*b - 12;
1642 }
1643
rndAirplane()1644 double rndAirplane()
1645 {
1646 static int firsttime = 1;
1647 static double bAirplane;
1648 double z;
1649
1650 if (firsttime) {
1651 bAirplane = getRoot(&BAirplane, &dBAirplane, 2.5);
1652 firsttime = 0;
1653 }
1654 if (rndu() < aAirplane / (2 * bAirplane - aAirplane)) {
1655 /* sample from linear part */
1656 z = sqrt(aAirplane*aAirplane*rndu());
1657 }
1658 else {
1659 /* sample from box part */
1660 z = rndu() * (bAirplane - aAirplane) + aAirplane;
1661 }
1662 return (rndu() < 0.5 ? -z : z);
1663 }
1664
BStrawhat(double b)1665 double BStrawhat(double b) {
1666 return 5 * b*b*b - 15 * b + 10 * aStrawhat - 2 * aStrawhat*aStrawhat*aStrawhat;
1667 }
1668
dBStrawhat(double b)1669 double dBStrawhat(double b) {
1670 return 15 * b*b - 15;
1671 }
1672
rndStrawhat()1673 double rndStrawhat()
1674 {
1675 static int firsttime = 1;
1676 static double bStrawhat;
1677 double z;
1678
1679 if (firsttime) {
1680 bStrawhat = getRoot(&BStrawhat, &dBStrawhat, 2.0);
1681 firsttime = 0;
1682 }
1683 if (rndu() < aStrawhat / ((3 * bStrawhat - 2 * aStrawhat))) {
1684 /* sample from Strawhat part */
1685 z = aStrawhat * pow(rndu(), 1.0 / 3.0);
1686 }
1687 else {
1688 /* sample from the box part */
1689 z = rndu() * (bStrawhat - aStrawhat) + aStrawhat;
1690 }
1691 return (rndu() < 0.5 ? -z : z);
1692 }
1693
1694
rndloglogistic(double loc,double s)1695 double rndloglogistic(double loc, double s)
1696 {
1697 double t = rndlogistic(), logt = 1E300;
1698 if (t < 800) logt = exp(loc + s*t);
1699 return(logt);
1700 }
1701
rndlogistic(void)1702 double rndlogistic(void)
1703 {
1704 /* log-logistic variate */
1705 double u;
1706
1707 u = rndu();
1708 return log(u / (1 - u));
1709 }
1710
rndlogt2(double loc,double s)1711 double rndlogt2(double loc, double s)
1712 {
1713 double t2 = rndt2(), logt2 = 1E300;
1714 if (t2 < 800) logt2 = exp(loc + s*t2);
1715 return(logt2);
1716 }
1717
rndCauchy(void)1718 double rndCauchy(void)
1719 {
1720 /* Standard Cauchy variate, generated using inverse CDF
1721 */
1722 return tan(Pi*(rndu() - 0.5));
1723 }
1724
1725
rndTriangle(void)1726 double rndTriangle(void)
1727 {
1728 double u, z;
1729 /* Standard Triangle variate, generated using inverse CDF */
1730 u = rndu();
1731 if (u > 0.5)
1732 z = sqrt(6.0) - 2.0*sqrt(3.0*(1.0 - u));
1733 else
1734 z = -sqrt(6.0) + 2.0*sqrt(3.0*u);
1735 return z;
1736 }
1737
1738 #if(1)
rndLaplace(void)1739 double rndLaplace(void)
1740 {
1741 /* Standard Laplace variate, generated using inverse CDF */
1742 double u, r;
1743 u = rndu() - 0.5;
1744 r = log(1 - 2 * fabs(u)) * 0.70710678118654752440;
1745 return (u >= 0 ? -r : r);
1746 }
1747
1748 #else
rndLaplace(void)1749 double rndLaplace(void) {
1750 double u;
1751 /* Standard Laplace variate, generated using inverse CDF */
1752 u = -0.5 + rndu();
1753 return (u >= 0 ? log(1 - 2 * fabs(u)) : -log(1 - 2 * fabs(u)));
1754 }
1755 #endif
1756
rndt2(void)1757 double rndt2(void)
1758 {
1759 /* Standard Student's t_2 variate, with d.f. = 2. t2 has mean 0 and variance infinity.
1760 */
1761 double u, t2;
1762
1763 u = 2 * rndu() - 1;
1764 u *= u;
1765 t2 = sqrt(2 * u / (1 - u));
1766 if (rndu() < 0.5) t2 = -t2;
1767 return t2;
1768 }
1769
rndt4(void)1770 double rndt4(void)
1771 {
1772 /* Student's t_4 variate, with d.f. = 4.
1773 This has variance 1, and is the standard t4 variate divided by sqrt(2).
1774 The standard t4 variate has variance 2.
1775 */
1776 double u, v, w, c2, r2, t4, sqrt2 = 0.7071067811865475244;
1777
1778 for ( ; ; ) {
1779 u = 2 * rndu() - 1;
1780 v = 2 * rndu() - 1;
1781 w = u*u + v*v;
1782 if (w < 1) break;
1783 }
1784 c2 = u*u / w;
1785 r2 = 4 / sqrt(w) - 4;
1786 t4 = sqrt(r2*c2);
1787 if (rndu() < 0.5) t4 = -t4;
1788
1789 return t4 * sqrt2;
1790 }
1791
1792
rndpoisson(double m)1793 int rndpoisson(double m)
1794 {
1795 /* m is the rate parameter of the poisson
1796 Numerical Recipes in C, 2nd ed. pp. 293-295
1797 */
1798 static double sq, alm, g, oldm = -1;
1799 double em, t, y;
1800
1801 /* search from the origin
1802 if (m<5) {
1803 if (m!=oldm) { oldm=m; g=exp(-m); }
1804 y=rndu(); sq=alm=g;
1805 for (em=0; ; ) {
1806 if (y<sq) break;
1807 sq+= (alm*=m/ ++em);
1808 }
1809 }
1810 */
1811 if (m < 12) {
1812 if (m != oldm) { oldm = m; g = exp(-m); }
1813 em = -1; t = 1;
1814 for (; ;) {
1815 em++; t *= rndu();
1816 if (t <= g) break;
1817 }
1818 }
1819 else {
1820 if (m != oldm) {
1821 oldm = m; sq = sqrt(2 * m); alm = log(m);
1822 g = m*alm - LnGamma(m + 1);
1823 }
1824 do {
1825 do {
1826 y = tan(3.141592654*rndu());
1827 em = sq*y + m;
1828 } while (em < 0);
1829 em = floor(em);
1830 t = 0.9*(1 + y*y)*exp(em*alm - LnGamma(em + 1) - g);
1831 } while (rndu() > t);
1832 }
1833 return ((int)em);
1834 }
1835
rndgamma(double a)1836 double rndgamma(double a)
1837 {
1838 /* This returns a random variable from gamma(a, 1).
1839 Marsaglia and Tsang (2000) A Simple Method for generating gamma variables",
1840 ACM Transactions on Mathematical Software, 26 (3): 363-372.
1841 This is not entirely safe and is noted to produce zero when a is small (0.001).
1842 */
1843 double a0 = a, c, d, u, v, x, smallv = 1E-300;
1844
1845 if (a < 1) a++;
1846
1847 d = a - 1.0 / 3.0;
1848 c = (1.0 / 3.0) / sqrt(d);
1849
1850 for (; ; ) {
1851 do {
1852 x = rndNormal();
1853 v = 1.0 + c * x;
1854 } while (v <= 0);
1855
1856 v *= v * v;
1857 u = rndu();
1858
1859 if (u < 1 - 0.0331 * x * x * x * x)
1860 break;
1861 if (log(u) < 0.5 * x * x + d * (1 - v + log(v)))
1862 break;
1863 }
1864 v *= d;
1865
1866 if (a0 < 1) /* this may cause underflow if a is small, like 0.01 */
1867 v *= pow(rndu(), 1 / a0);
1868 if (v == 0) /* underflow */
1869 v = smallv;
1870 return v;
1871 }
1872
rndbeta(double p,double q)1873 double rndbeta(double p, double q)
1874 {
1875 /* this generates a random beta(p,q) variate
1876 */
1877 double gamma1, gamma2;
1878 gamma1 = rndgamma(p);
1879 gamma2 = rndgamma(q);
1880 return gamma1 / (gamma1 + gamma2);
1881 }
1882
rnddirichlet(double x[],double alpha[],int K)1883 int rnddirichlet(double x[], double alpha[], int K)
1884 {
1885 /* this generates a random variate from the dirichlet distribution with K categories.
1886 */
1887 int i;
1888 double s = 0;
1889
1890 for (i = 0; i < K; i++) s += x[i] = rndgamma(alpha[i]);
1891 for (i = 0; i < K; i++) x[i] /= s;
1892 return (0);
1893 }
1894
1895
rndNegBinomial(double shape,double mean)1896 int rndNegBinomial(double shape, double mean)
1897 {
1898 /* mean=mean, var=mean^2/shape+m
1899 */
1900 return (rndpoisson(rndgamma(shape) / shape*mean));
1901 }
1902
1903
MultiNomialAliasSetTable(int ncat,double prob[],double F[],int L[],double space[])1904 int MultiNomialAliasSetTable(int ncat, double prob[], double F[], int L[], double space[])
1905 {
1906 /* This sets up the tables F and L for the alias algorithm for generating samples from the
1907 multinomial distribution MN(ncat, p) (Walker 1974; Kronmal & Peterson 1979).
1908
1909 F[i] has cutoff probabilities, L[i] has aliases.
1910 I[i] is an indicator: -1 for F[i]<1; +1 for F[i]>=1; 0 if the cell is now empty.
1911
1912 Should perhaps check whether prob[] sums to 1.
1913 */
1914 signed char *I = (signed char *)space;
1915 int i, j, k, nsmall;
1916
1917 for (i = 0; i < ncat; i++) L[i] = -9;
1918 for (i = 0; i < ncat; i++) F[i] = ncat*prob[i];
1919 for (i = 0, nsmall = 0; i < ncat; i++) {
1920 if (F[i] >= 1) I[i] = 1;
1921 else { I[i] = -1; nsmall++; }
1922 }
1923 for (i = 0; nsmall > 0; i++) {
1924 for (j = 0; j < ncat; j++) if (I[j] == -1) break;
1925 for (k = 0; k < ncat; k++) if (I[k] == 1) break;
1926 if (k == ncat) break;
1927
1928 L[j] = k;
1929 F[k] -= 1 - F[j];
1930 if (F[k] < 1) { I[k] = -1; nsmall++; }
1931 I[j] = 0; nsmall--;
1932 }
1933 return(0);
1934 }
1935
1936
MultiNomialAlias(int n,int ncat,double F[],int L[],int nobs[])1937 int MultiNomialAlias(int n, int ncat, double F[], int L[], int nobs[])
1938 {
1939 /* This generates multinomial samples using the F and L tables set up before,
1940 using the alias algorithm (Walker 1974; Kronmal & Peterson 1979).
1941
1942 F[i] has cutoff probabilities, L[i] has aliases.
1943 I[i] is an indicator: -1 for F[i]<1; +1 for F[i]>=1; 0 if the cell is now empty.
1944 */
1945 int i, k;
1946 double r;
1947
1948 for (i = 0; i < ncat; i++) nobs[i] = 0;
1949 for (i = 0; i < n; i++) {
1950 r = rndu()*ncat;
1951 k = (int)r;
1952 r -= k;
1953 if (r <= F[k]) nobs[k]++;
1954 else nobs[L[k]]++;
1955 }
1956 return (0);
1957 }
1958
1959
MultiNomial2(int n,int ncat,double prob[],int nobs[],double space[])1960 int MultiNomial2(int n, int ncat, double prob[], int nobs[], double space[])
1961 {
1962 /* sample n times from a mutinomial distribution M(ncat, prob[])
1963 prob[] is considered cumulative prob if (space==NULL)
1964 ncrude is the number or crude categories, and lcrude marks the
1965 starting category for each crude category. These are used
1966 to speed up the process when ncat is large.
1967 */
1968 int i, j, crude = (ncat > 20), ncrude, lcrude[200];
1969 double r, *pcdf = (space == NULL ? prob : space), smallv = 1e-5;
1970
1971 ncrude = max2(5, ncat / 20); ncrude = min2(200, ncrude);
1972 for (i = 0; i < ncat; i++) nobs[i] = 0;
1973 if (space) {
1974 xtoy(prob, pcdf, ncat);
1975 for (i = 1; i < ncat; i++) pcdf[i] += pcdf[i - 1];
1976 }
1977 if (fabs(pcdf[ncat - 1] - 1) > smallv)
1978 error2("sum P!=1 in MultiNomial2");
1979 if (crude) {
1980 for (j = 1, lcrude[0] = i = 0; j < ncrude; j++) {
1981 while (pcdf[i] < (double)j / ncrude) i++;
1982 lcrude[j] = i - 1;
1983 }
1984 }
1985 for (i = 0; i < n; i++) {
1986 r = rndu();
1987 j = 0;
1988 if (crude) {
1989 for (; j < ncrude; j++) if (r < (j + 1.) / ncrude) break;
1990 j = lcrude[j];
1991 }
1992 for (; j < ncat - 1; j++) if (r < pcdf[j]) break;
1993 nobs[j] ++;
1994 }
1995 return (0);
1996 }
1997
1998
1999 /* functions concerning the CDF and percentage points of the gamma and
2000 Chi2 distribution
2001 */
QuantileNormal(double prob)2002 double QuantileNormal(double prob)
2003 {
2004 /* returns z so that Prob{x<z}=prob where x ~ N(0,1) and (1e-12)<prob<1-(1e-12)
2005 returns (-9999) if in error
2006 Odeh RE & Evans JO (1974) The percentage points of the normal distribution.
2007 Applied Statistics 22: 96-97 (AS70)
2008
2009 Newer methods:
2010 Wichura MJ (1988) Algorithm AS 241: the percentage points of the
2011 normal distribution. 37: 477-484.
2012 Beasley JD & Springer SG (1977). Algorithm AS 111: the percentage
2013 points of the normal distribution. 26: 118-121.
2014 */
2015 double a0 = -.322232431088, a1 = -1, a2 = -.342242088547, a3 = -.0204231210245;
2016 double a4 = -.453642210148e-4, b0 = .0993484626060, b1 = .588581570495;
2017 double b2 = .531103462366, b3 = .103537752850, b4 = .0038560700634;
2018 double y, z = 0, p = prob, p1;
2019
2020 p1 = (p < 0.5 ? p : 1 - p);
2021 if (p1 < 1e-20) z = 999;
2022 else {
2023 y = sqrt(log(1 / (p1*p1)));
2024 z = y + ((((y*a4 + a3)*y + a2)*y + a1)*y + a0) / ((((y*b4 + b3)*y + b2)*y + b1)*y + b0);
2025 }
2026 return (p < 0.5 ? -z : z);
2027 }
2028
PDFNormal(double x,double mu,double sigma2)2029 double PDFNormal(double x, double mu, double sigma2)
2030 {
2031 return 1 / sqrt(2 * Pi*sigma2)*exp(-.5 / sigma2*(x - mu)*(x - mu));
2032 }
2033
logPDFNormal(double x,double mu,double sigma2)2034 double logPDFNormal(double x, double mu, double sigma2)
2035 {
2036 return -0.5*log(2 * Pi*sigma2) - 0.5 / sigma2*(x - mu)*(x - mu);
2037 }
2038
CDFNormal(double x)2039 double CDFNormal(double x)
2040 {
2041 /* Hill ID (1973) The normal integral. Applied Statistics, 22:424-427. (Algorithm AS 66)
2042 Adams AG (1969) Algorithm 39. Areas under the normal curve. Computer J. 12: 197-198.
2043 adapted by Z. Yang, March 1994.
2044 */
2045 int invers = 0;
2046 double p, t = 1.28, y = x*x / 2;
2047
2048 if (x < 0) { invers = 1; x = -x; }
2049 if (x < t)
2050 p = .5 - x * (.398942280444 - .399903438504 * y
2051 / (y + 5.75885480458 - 29.8213557808
2052 / (y + 2.62433121679 + 48.6959930692
2053 / (y + 5.92885724438))));
2054 else {
2055 p = 0.398942280385 * exp(-y) /
2056 (x - 3.8052e-8 + 1.00000615302 /
2057 (x + 3.98064794e-4 + 1.98615381364 /
2058 (x - 0.151679116635 + 5.29330324926 /
2059 (x + 4.8385912808 - 15.1508972451 /
2060 (x + 0.742380924027 + 30.789933034 /
2061 (x + 3.99019417011))))));
2062 }
2063 return (invers ? p : 1 - p);
2064 }
2065
logCDFNormal(double x)2066 double logCDFNormal(double x)
2067 {
2068 /* logarithm of CDF of N(0,1).
2069
2070 The accuracy is good for the full range (-inf, 38) on my 32-bit machine.
2071 When x=38, log(F(x)) = -2.88542835e-316. When x > 38, log(F(x)) can't be
2072 distinguished from 0. F(5) = 1 - 1.89E-8, and when x>5, F(x) is hard to
2073 distinguish from 1. Instead the smaller tail area F(-5) is used for the
2074 calculation, using the expansion log(1-z) = -z(1 + z/2 + z*z/3), where
2075 z = F(-5) is small.
2076 For 3 < x < 7, both approaches are close, but when x = 8, Mathematica and
2077 log(CDFNormal) give the incorrect answer -6.66133815E-16, while the correct
2078 value is log(F(8)) = log(1 - F(-8)) ~= -F(-8) = -6.22096057E-16.
2079 Note on 2019.1.5: In R, pnorm(8,0,1, log.p=TRUE) gives -6.220961e-16, which is correct.
2080
2081 F(x) when x<-10 is reliably calculatd using the series expansion, even though
2082 log(CDFNormal) works until F(-38) = 2.88542835E-316.
2083
2084 Regarding calculation of the logarithm of Pr(a < X < b), note that
2085 F(-9) - F(-10) = F(10) - F(9), but the left-hand side is better computationally.
2086 */
2087 double lnF, z = fabs(x), C, low = -10, high = 5;
2088
2089 /* calculate the log of the smaller area */
2090 if (x >= low && x <= high)
2091 return log(CDFNormal(x));
2092 if (x > high && x < -low)
2093 lnF = log(CDFNormal(-z));
2094 else {
2095 C = 1 - 1 / (z*z) + 3 / (z*z*z*z) - 15 / (z*z*z*z*z*z) + 105 / (z*z*z*z*z*z*z*z);
2096 lnF = -z*z / 2 - log(sqrt(2 * Pi)*z) + log(C);
2097 }
2098 if (x > 0) {
2099 z = exp(lnF);
2100 lnF = -z*(1 + z / 2 + z*z / 3 + z*z*z / 4 + z*z*z*z / 5);
2101 }
2102 return(lnF);
2103 }
2104
2105
PDFCauchy(double x,double m,double sigma)2106 double PDFCauchy(double x, double m, double sigma)
2107 {
2108 double z = (x - m) / sigma;
2109 return 1 / (Pi*sigma*(1 + z*z));
2110 }
2111
PDFloglogistic(double x,double loc,double s)2112 double PDFloglogistic(double x, double loc, double s)
2113 {
2114 double y = (log(x) - loc) / s, e = exp(-y);
2115 return 1 / (s*x)*e / ((1 + e)*(1 + e));
2116 }
2117
PDFlogt2(double x,double loc,double s)2118 double PDFlogt2(double x, double loc, double s)
2119 {
2120 double y = (log(x) - loc) / s, pdf;
2121 y = 2 + y*y; y *= y*y; /* [2 + y*y]^3 */
2122 if (y < 1E-300)
2123 error2("y==0");
2124 pdf = 1 / (sqrt(y)*x*s);
2125 return pdf;
2126 }
2127
PDFt2(double x,double m,double s)2128 double PDFt2(double x, double m, double s)
2129 {
2130 double y = (x - m) / s;
2131 y = 2 + y*y; y *= y*y; /* [2 + y*y]^3 */
2132 if (y < 1e-300)
2133 error2("y==0");
2134 return 1 / (sqrt(y)*s);
2135 }
2136
PDFt4(double x,double m,double s)2137 double PDFt4(double x, double m, double s)
2138 {
2139 /* This t4 PDF has mean m and variance s*s. Note that the standard t4 has variance 2*s*s.
2140 */
2141 double z = (x - m) / s, pdf;
2142
2143 pdf = 3 / (4 * 1.414213562*s)*pow(1 + z*z / 2, -2.5);
2144
2145 return pdf;
2146 }
2147
2148
PDFt(double x,double loc,double scale,double df,double lnConst)2149 double PDFt(double x, double loc, double scale, double df, double lnConst)
2150 {
2151 /* CDF of t distribution with lococation, scale, and degree of freedom
2152 */
2153 double z = (x - loc) / scale, lnpdf = lnConst;
2154
2155 if (lnpdf == 0) {
2156 lnpdf = LnGamma((df + 1) / 2) - LnGamma(df / 2) - 0.5*log(Pi*df);
2157 }
2158 lnpdf -= (df + 1) / 2 * log(1 + z*z / df);
2159 return exp(lnpdf) / scale;
2160 }
2161
CDFt(double x,double loc,double scale,double df,double lnbeta)2162 double CDFt(double x, double loc, double scale, double df, double lnbeta)
2163 {
2164 /* CDF of t distribution with location, scale, and degree of freedom
2165 */
2166 double z = (x - loc) / scale, cdf;
2167 double lnghalf = 0.57236494292470008707; /* log{G(1/2)} = log{sqrt(Pi)} */
2168
2169 if (lnbeta == 0) {
2170 lnbeta = LnGamma(df / 2) + lnghalf - LnGamma((df + 1) / 2);
2171 }
2172 cdf = CDFBeta(df / (df + z*z), df / 2, 0.5, lnbeta);
2173
2174 if (z >= 0) cdf = 1 - cdf / 2;
2175 else cdf /= 2;
2176 return(cdf);
2177 }
2178
PDFSkewT(double x,double loc,double scale,double shape,double df)2179 double PDFSkewT(double x, double loc, double scale, double shape, double df)
2180 {
2181 double z = (x - loc) / scale, pdf;
2182 double lnghalf = 0.57236494292470008707; /* log{G(1/2)} = log{sqrt(Pi)} */
2183 double lngv, lngv1, lnConst_pdft, lnbeta_cdft;
2184
2185 lngv = LnGamma(df / 2);
2186 lngv1 = LnGamma((df + 1) / 2);
2187 lnConst_pdft = lngv1 - lngv - 0.5*log(Pi*df);
2188 lnbeta_cdft = lngv1 + lnghalf - lngv - log(df / 2); /* log{ B((df+1)/2, 1/2) } */
2189
2190 pdf = 2 / scale * PDFt(z, 0, 1, df, lnConst_pdft)
2191 * CDFt(shape*z*sqrt((df + 1) / (df + z*z)), 0, 1, df + 1, lnbeta_cdft);
2192
2193 return pdf;
2194 }
2195
PDFSkewN(double x,double loc,double scale,double shape)2196 double PDFSkewN(double x, double loc, double scale, double shape)
2197 {
2198 double z = (x - loc) / scale, pdf = 2 / scale;
2199
2200 pdf *= PDFNormal(z, 0, 1) * CDFNormal(shape*z);
2201 return pdf;
2202 }
2203
logPDFSkewN(double x,double loc,double scale,double shape)2204 double logPDFSkewN(double x, double loc, double scale, double shape)
2205 {
2206 double z = (x - loc) / scale, lnpdf = 2 / scale;
2207
2208 lnpdf = 0.5*log(2 / (Pi*scale*scale)) - z*z / 2 + logCDFNormal(shape*z);
2209 return lnpdf;
2210 }
2211
2212
StirlingS2(int n,int k)2213 int StirlingS2(int n, int k)
2214 {
2215 /* Stirling number of the second type, calculated using the recursion (loop)
2216 S(n, k) = S(n - 1, k - 1) + k*S(n - 1, k).
2217 This works for small numbers of n<=15.
2218 */
2219 int S[16] = { 0 }, i, j;
2220
2221 if ((n == 0 && k == 0) || k == 1 || k == n)
2222 return 1;
2223 if (k == 0 || k > n)
2224 return 0;
2225 if (k == 2)
2226 return (int)ldexp(1, n - 1) - 1;
2227 if (k == n - 1)
2228 return n*(n - 1) / 2;
2229 if (n > 15)
2230 error2("n>15 too large in StirlingS2()");
2231
2232 S[1] = S[2] = 1; /* start with n = 2 */
2233 for (i = 3; i <= n; i++) {
2234 for (j = min2(k, i); j >= 2; j--)
2235 S[j] = S[j - 1] + j*S[j];
2236 }
2237 return S[k];
2238 }
2239
lnStirlingS2(int n,int k)2240 double lnStirlingS2(int n, int k)
2241 {
2242 /* This calculates the logarithm of the Stirling number of the second type.
2243 Temme NM. 1993. Asymptotic estimates of Stirling numbers. Stud Appl Math 89:233-243.
2244 */
2245 int i;
2246 double lnS = 0, t0, x0, x, A, nk, y;
2247
2248 if (k > n) error2("k<n in lnStirlingS2");
2249
2250 if (n == 0 && k == 0)
2251 return 0;
2252 if (k == 0)
2253 return -1e300;
2254 if (k == 1 || k == n)
2255 return (0);
2256 if (k == 2)
2257 return (n < 50 ? log(ldexp(1, n - 1) - 1) : (n - 1)*0.693147);
2258 if (k == n - 1)
2259 return log(n*(n - 1) / 2.0);
2260 if (n < 8)
2261 return log((double)StirlingS2(n, k));
2262
2263 nk = (double)n / k;
2264 for (i = 0, x0 = x = 1; i < 10000; i++) {
2265 x = (x0 + nk - nk*exp(-x0)) / 2;
2266 if (fabs(x - x0) / (1 + x) < 1e-10) break;
2267 x0 = x;
2268 }
2269 t0 = n / (double)k - 1;
2270 if (x < 100)
2271 A = -n * log(x) + k*log(exp(x) - 1);
2272 else
2273 A = -n * log(x) + k*x;
2274
2275 A += -k*t0 + (n - k)*log(t0);
2276 lnS = A + (n - k)*log((double)k) + 0.5*log(t0 / ((1 + t0)*(x - t0)));
2277 lnS += log(Binomial(n, k, &y));
2278 lnS += y;
2279
2280 return(lnS);
2281 }
2282
2283
LnGamma(double x)2284 double LnGamma(double x)
2285 {
2286 /* returns ln(gamma(x)) for x>0, accurate to 10 decimal places.
2287 Stirling's formula is used for the central polynomial part of the procedure.
2288
2289 Pike MC & Hill ID (1966) Algorithm 291: Logarithm of the gamma function.
2290 Communications of the Association for Computing Machinery, 9:684
2291 */
2292 double f = 0, fneg = 0, z, lng;
2293 int nx = (int)x;
2294
2295 if ((double)nx == x && nx >= 0 && nx <= 11)
2296 lng = log(factorial(nx - 1));
2297 else {
2298 if (x <= 0) {
2299 printf("LnGamma(%.6f) not implemented", x);
2300 if ((int)x - x == 0) { puts("lnGamma undefined"); return(-1); }
2301 for (fneg = 1; x < 0; x++) fneg /= x;
2302 if (fneg < 0)
2303 error2("strange!! check lngamma");
2304 fneg = log(fneg);
2305 }
2306 if (x < 7) {
2307 f = 1;
2308 z = x - 1;
2309 while (++z < 7)
2310 f *= z;
2311 x = z;
2312 f = -log(f);
2313 }
2314 z = 1 / (x*x);
2315 lng = fneg + f + (x - 0.5)*log(x) - x + .918938533204673
2316 + (((-.000595238095238*z + .000793650793651)*z - .002777777777778)*z + .083333333333333) / x;
2317 }
2318 return lng;
2319 }
2320
PDFGamma(double x,double alpha,double beta)2321 double PDFGamma(double x, double alpha, double beta)
2322 {
2323 /* gamma density: mean=alpha/beta; var=alpha/beta^2
2324 */
2325 if (x <= 0 || alpha <= 0 || beta <= 0) {
2326 printf("x=%.6f a=%.6f b=%.6f", x, alpha, beta);
2327 error2("x a b outside range in PDFGamma()");
2328 }
2329 if (alpha > 100)
2330 error2("large alpha in PDFGamma()");
2331 return pow(beta*x, alpha) / x * exp(-beta*x - LnGamma(alpha));
2332 }
2333
logPriorRatioGamma(double xnew,double x,double a,double b)2334 double logPriorRatioGamma(double xnew, double x, double a, double b)
2335 {
2336 /* This calculates the log of prior ratio when x has a gamma prior G(x; a, b) with mean a/b
2337 and x is updated from xold to xnew.
2338 */
2339 return (a - 1)*log(xnew / x) - b*(xnew - x);
2340 }
2341
2342
PDFinvGamma(double x,double alpha,double beta)2343 double PDFinvGamma(double x, double alpha, double beta)
2344 {
2345 /* inverse-gamma density:
2346 mean=beta/(alpha-1); var=beta^2/[(alpha-1)^2*(alpha-2)]
2347 */
2348 if (x <= 0 || alpha <= 0 || beta <= 0) {
2349 printf("x=%.6f a=%.6f b=%.6f", x, alpha, beta);
2350 error2("x a b outside range in PDF_IGamma()");
2351 }
2352 if (alpha > 100)
2353 error2("large alpha in PDF_IGamma()");
2354 return pow(beta / x, alpha) / x * exp(-beta / x - LnGamma(alpha));
2355 }
2356
2357
IncompleteGamma(double x,double alpha,double ln_gamma_alpha)2358 double IncompleteGamma(double x, double alpha, double ln_gamma_alpha)
2359 {
2360 /* returns the incomplete gamma ratio I(x,alpha) where x is the upper
2361 limit of the integration and alpha is the shape parameter.
2362 returns (-1) if in error
2363 ln_gamma_alpha = ln(Gamma(alpha)), is almost redundant.
2364 (1) series expansion, if (alpha>x || x<=1)
2365 (2) continued fraction, otherwise
2366 RATNEST FORTRAN by
2367 Bhattacharjee GP (1970) The incomplete gamma integral. Applied Statistics,
2368 19: 285-287 (AS32)
2369 */
2370 int i;
2371 double p = alpha, g = ln_gamma_alpha;
2372 double accurate = 1e-10, overflow = 1e60;
2373 double factor, gin = 0, rn = 0, a = 0, b = 0, an = 0, dif = 0, term = 0, pn[6];
2374
2375 if (x == 0) return (0);
2376 if (x < 0 || p <= 0) return (-1);
2377
2378 factor = exp(p*log(x) - x - g);
2379 if (x > 1 && x >= p) goto l30;
2380 /* (1) series expansion */
2381 gin = 1; term = 1; rn = p;
2382 l20:
2383 rn++;
2384 term *= x / rn; gin += term;
2385 if (term > accurate) goto l20;
2386 gin *= factor / p;
2387 goto l50;
2388 l30:
2389 /* (2) continued fraction */
2390 a = 1 - p; b = a + x + 1; term = 0;
2391 pn[0] = 1; pn[1] = x; pn[2] = x + 1; pn[3] = x*b;
2392 gin = pn[2] / pn[3];
2393 l32:
2394 a++;
2395 b += 2;
2396 term++;
2397 an = a*term;
2398 for (i = 0; i < 2; i++)
2399 pn[i + 4] = b*pn[i + 2] - an*pn[i];
2400 if (pn[5] == 0) goto l35;
2401 rn = pn[4] / pn[5];
2402 dif = fabs(gin - rn);
2403 if (dif > accurate) goto l34;
2404 if (dif <= accurate*rn) goto l42;
2405 l34:
2406 gin = rn;
2407 l35:
2408 for (i = 0; i < 4; i++) pn[i] = pn[i + 2];
2409 if (fabs(pn[4]) < overflow) goto l32;
2410 for (i = 0; i < 4; i++) pn[i] /= overflow;
2411 goto l32;
2412 l42:
2413 gin = 1 - factor*gin;
2414
2415 l50:
2416 return (gin);
2417 }
2418
2419
QuantileChi2(double prob,double v)2420 double QuantileChi2(double prob, double v)
2421 {
2422 /* returns z so that Prob{x<z}=prob where x is Chi2 distributed with df=v
2423 returns -1 if in error. 0.000002<prob<0.999998
2424 RATNEST FORTRAN by
2425 Best DJ & Roberts DE (1975) The percentage points of the
2426 Chi2 distribution. Applied Statistics 24: 385-388. (AS91)
2427 Converted into C by Ziheng Yang, Oct. 1993.
2428 */
2429 double e = .5e-6, aa = .6931471805, p = prob, g, smallv = 1e-6;
2430 double xx, c, ch, a = 0, q = 0, p1 = 0, p2 = 0, t = 0, x = 0, b = 0, s1, s2, s3, s4, s5, s6;
2431
2432 if (p < smallv) return(0);
2433 if (p > 1 - smallv) return(9999);
2434 if (v <= 0) return (-1);
2435
2436 g = LnGamma(v / 2);
2437 xx = v / 2; c = xx - 1;
2438 if (v >= -1.24*log(p)) goto l1;
2439
2440 ch = pow((p*xx*exp(g + xx*aa)), 1 / xx);
2441 if (ch - e < 0) return (ch);
2442 goto l4;
2443 l1:
2444 if (v > .32) goto l3;
2445 ch = 0.4; a = log(1 - p);
2446 l2:
2447 q = ch; p1 = 1 + ch*(4.67 + ch); p2 = ch*(6.73 + ch*(6.66 + ch));
2448 t = -0.5 + (4.67 + 2 * ch) / p1 - (6.73 + ch*(13.32 + 3 * ch)) / p2;
2449 ch -= (1 - exp(a + g + .5*ch + c*aa)*p2 / p1) / t;
2450 if (fabs(q / ch - 1) - .01 <= 0) goto l4;
2451 else goto l2;
2452
2453 l3:
2454 x = QuantileNormal(p);
2455 p1 = 0.222222 / v;
2456 ch = v*pow((x*sqrt(p1) + 1 - p1), 3.0);
2457 if (ch > 2.2*v + 6)
2458 ch = -2 * (log(1 - p) - c*log(.5*ch) + g);
2459 l4:
2460 q = ch; p1 = .5*ch;
2461 if ((t = IncompleteGamma(p1, xx, g)) < 0)
2462 error2("\nIncompleteGamma");
2463 p2 = p - t;
2464 t = p2*exp(xx*aa + g + p1 - c*log(ch));
2465 b = t / ch; a = 0.5*t - b*c;
2466
2467 s1 = (210 + a*(140 + a*(105 + a*(84 + a*(70 + 60 * a))))) / 420;
2468 s2 = (420 + a*(735 + a*(966 + a*(1141 + 1278 * a)))) / 2520;
2469 s3 = (210 + a*(462 + a*(707 + 932 * a))) / 2520;
2470 s4 = (252 + a*(672 + 1182 * a) + c*(294 + a*(889 + 1740 * a))) / 5040;
2471 s5 = (84 + 264 * a + c*(175 + 606 * a)) / 2520;
2472 s6 = (120 + c*(346 + 127 * c)) / 5040;
2473 ch += t*(1 + 0.5*t*s1 - b*c*(s1 - b*(s2 - b*(s3 - b*(s4 - b*(s5 - b*s6))))));
2474 if (fabs(q / ch - 1) > e) goto l4;
2475
2476 return (ch);
2477 }
2478
2479
DiscreteBeta(double freq[],double x[],double p,double q,int K,int UseMedian)2480 int DiscreteBeta(double freq[], double x[], double p, double q, int K, int UseMedian)
2481 {
2482 /* discretization of beta(p, q), with equal proportions in each category.
2483 */
2484 int i;
2485 double mean = p / (p + q), lnbeta, lnbeta1, t;
2486
2487 lnbeta = LnBeta(p, q);
2488 if (UseMedian) { /* median */
2489 for (i = 0, t = 0; i < K; i++)
2490 t += x[i] = QuantileBeta((i + 0.5) / K, p, q, lnbeta);
2491 for (i = 0; i < K; i++)
2492 x[i] *= mean*K / t;
2493
2494 /* printf("\nmedian "); for(i=0; i<K; i++) printf("%9.5f", x[i]); */
2495 }
2496 else { /* mean */
2497 for (i = 0; i < K - 1; i++) /* cutting points */
2498 freq[i] = QuantileBeta((i + 1.0) / K, p, q, lnbeta);
2499 freq[K - 1] = 1;
2500
2501 /* printf("\npoints "); for(i=0; i<K; i++) printf("%9.5f", freq[i]); */
2502 lnbeta1 = lnbeta - log(1 + q / p);
2503 for (i = 0; i < K - 1; i++) /* CDF */
2504 freq[i] = CDFBeta(freq[i], p + 1, q, lnbeta1);
2505
2506 x[0] = freq[0] * mean*K;
2507 for (i = 1; i < K - 1; i++) x[i] = (freq[i] - freq[i - 1])*mean*K;
2508 x[K - 1] = (1 - freq[K - 2])*mean*K;
2509
2510 /* printf("\nmean "); for(i=0; i<K; i++) printf("%9.5f", x[i]); */
2511 for (i = 0, t = 0; i < K; i++) t += x[i] / K;
2512 }
2513
2514 for (i = 0; i < K; i++) freq[i] = 1.0 / K;
2515 return (0);
2516 }
2517
DiscreteGamma(double freqK[],double rK[],double alpha,double beta,int K,int UseMedian)2518 int DiscreteGamma(double freqK[], double rK[], double alpha, double beta, int K, int UseMedian)
2519 {
2520 /* discretization of G(alpha, beta) with equal proportions in each category.
2521 */
2522 int i;
2523 double t, mean = alpha / beta, lnga1;
2524
2525 if (UseMedian) { /* median */
2526 for (i = 0; i < K; i++) rK[i] = QuantileGamma((i*2. + 1) / (2.*K), alpha, beta);
2527 for (i = 0, t = 0; i < K; i++) t += rK[i];
2528 for (i = 0; i < K; i++) rK[i] *= mean*K / t; /* rescale so that the mean is alpha/beta. */
2529 }
2530 else { /* mean */
2531 lnga1 = LnGamma(alpha + 1);
2532 for (i = 0; i < K - 1; i++) /* cutting points, Eq. 9 */
2533 freqK[i] = QuantileGamma((i + 1.0) / K, alpha, beta);
2534 for (i = 0; i < K - 1; i++) /* Eq. 10 */
2535 freqK[i] = IncompleteGamma(freqK[i] * beta, alpha + 1, lnga1);
2536 rK[0] = freqK[0] * mean*K;
2537 for (i = 1; i < K - 1; i++) rK[i] = (freqK[i] - freqK[i - 1])*mean*K;
2538 rK[K - 1] = (1 - freqK[K - 2])*mean*K;
2539 }
2540
2541 for (i = 0; i < K; i++) freqK[i] = 1.0 / K;
2542
2543 return (0);
2544 }
2545
2546
AutodGamma(double M[],double freqK[],double rK[],double * rho1,double alpha,double rho,int K)2547 int AutodGamma(double M[], double freqK[], double rK[], double *rho1, double alpha, double rho, int K)
2548 {
2549 /* Auto-discrete-gamma distribution of rates over sites, K equal-probable
2550 categories, with the mean for each category used.
2551 This routine calculates M[], freqK[] and rK[], using alpha, rho and K.
2552 */
2553 int i, j, i1, i2;
2554 double *point = freqK;
2555 double x, y, large = 20, v1;
2556 /*
2557 if (fabs(rho)>1-1e-4) error2("rho out of range");
2558 */
2559 for (i = 0; i < K - 1; i++)
2560 point[i] = QuantileNormal((i + 1.0) / K);
2561 for (i = 0; i < K; i++) {
2562 for (j = 0; j < K; j++) {
2563 x = (i < K - 1 ? point[i] : large);
2564 y = (j < K - 1 ? point[j] : large);
2565 M[i*K + j] = CDFBinormal(x, y, rho);
2566 }
2567 }
2568 for (i1 = 0; i1 < 2 * K - 1; i1++) {
2569 for (i2 = 0; i2 < K*K; i2++) {
2570 i = i2 / K; j = i2%K;
2571 if (i + j != 2 * (K - 1) - i1) continue;
2572 y = 0;
2573 if (i > 0) y -= M[(i - 1)*K + j];
2574 if (j > 0) y -= M[i*K + (j - 1)];
2575 if (i > 0 && j > 0) y += M[(i - 1)*K + (j - 1)];
2576 M[i*K + j] = (M[i*K + j] + y)*K;
2577
2578 if (M[i*K + j] < 0) printf("M(%d,%d) =%12.8f<0\n", i + 1, j + 1, M[i*K + j]);
2579 }
2580 }
2581
2582 DiscreteGamma(freqK, rK, alpha, alpha, K, DGammaUseMedian);
2583
2584 for (i = 0, v1 = *rho1 = 0; i < K; i++) {
2585 v1 += rK[i] * rK[i] * freqK[i];
2586 for (j = 0; j < K; j++)
2587 *rho1 += freqK[i] * M[i*K + j] * rK[i] * rK[j];
2588 }
2589 v1 -= 1;
2590 *rho1 = (*rho1 - 1) / v1;
2591 return (0);
2592 }
2593
2594
LBinormal(double h,double k,double r)2595 double LBinormal(double h, double k, double r)
2596 {
2597 /* L(h,k,r) = prob(X>h, Y>k), where X and Y are standard binormal variables,
2598 with r = corr(X, Y).
2599
2600 (1) Drezner Z., and G.O. Wesolowsky (1990) On the computation of the
2601 bivariate normal integral. J. Statist. Comput. Simul. 35:101-107.
2602
2603 (2) Genz, A.C., Numerical computation of rectangular bivariate and
2604 trivariate normal and t probabilities. Statist. Comput., 2004. 14: p. 1573-1375.
2605
2606 This uses the algorithm of Genz (2004).
2607 Here h<k is assumed. If h>k, a swapping between h and k is performed.
2608
2609 Gauss-Legendre quadrature points used.
2610
2611 |r| Genz nGL
2612 <0.3 (eq. 3) 6 10
2613 <0.75 (eq. 3) 12 20
2614 <0.925 (eq. 3) 20 20
2615 <1 (eq. 6) 20 20
2616 */
2617 int nGL = (fabs(r) < 0.3 ? 16 : 32), i, j;
2618 const double *x = NULL, *w = NULL; /* Gauss-Legendre quadrature points */
2619 double shk, h0 = h, k0 = k, sk, L = 0, t[2], hk2, y, a = 0, b, c, d, bs, as, rs, smallr = 1e-10;
2620
2621 h = min2(h0, k0); k = max2(h0, k0);
2622 sk = (r >= 0 ? k : -k);
2623 shk = (r >= 0 ? h*k : -h*k);
2624 if (fabs(r) > 1) error2("|r| > 1 in LBinormal");
2625 GaussLegendreRule(&x, &w, nGL);
2626
2627 if (fabs(r) < 0.925) { /* equation 3 */
2628 if (fabs(r) > smallr) {
2629 hk2 = (h*h + k*k) / 2;
2630 a = asin(r) / 2;
2631 for (i = 0, L = 0; i < nGL / 2; i++) {
2632 t[0] = a*(1 - x[i]); t[0] = sin(t[0]);
2633 t[1] = a*(1 + x[i]); t[1] = sin(t[1]);
2634 for (j = 0; j < 2; j++)
2635 L += w[i] * exp((t[j] * h*k - hk2) / (1 - t[j] * t[j]));
2636 }
2637 }
2638 L = L*a / (2 * Pi) + CDFNormal(-h)*CDFNormal(-k);
2639 }
2640 else { /* equation 6, using equation 7 instead of equation 5. */
2641 if (fabs(r) < 1) {
2642 /* first term in equation (6), analytical */
2643 as = 1 - r*r;
2644 a = sqrt(as);
2645 b = fabs(h - sk);
2646 bs = b*b;
2647 c = (4 - shk) / 8;
2648 d = (12 - shk) / 16;
2649 y = -(bs / as + shk) / 2;
2650 if (y > -500)
2651 L = a*exp(y)*(1 - c*(bs - as)*(1 - d*bs / 5) / 3 + c*d*as*as / 5);
2652 if (shk > -500) {
2653 L -= exp(-shk / 2)*sqrt(2 * Pi) * CDFNormal(-b / a) * b * (1 - c*bs*(1 - d*bs / 5) / 3);
2654 }
2655 /* second term in equation (6), numerical */
2656 a /= 2;
2657 for (i = 0; i < nGL / 2; i++) {
2658 t[0] = a*(1 - x[i]); t[0] = t[0] * t[0];
2659 t[1] = a*(1 + x[i]); t[1] = t[1] * t[1];
2660 for (j = 0; j < 2; j++) {
2661 rs = sqrt(1 - t[j]);
2662 y = -(bs / t[j] + shk) / 2;
2663 if (y > -500)
2664 L += a*w[i] * exp(y)*(exp(-shk*(1 - rs) / (2 * (1 + rs))) / rs - (1 + c*t[j] * (1 + d*t[j])));
2665 }
2666 }
2667 L /= -2 * Pi;
2668 }
2669 if (r > 0)
2670 L += CDFNormal(-max2(h, k));
2671 else if (r < 0) {
2672 L = -L;
2673 if (h + k < 0)
2674 L += CDFNormal(-h) - CDFNormal(k);
2675 }
2676 }
2677
2678 if (L < -1e-12) printf("L = %.9g very negative. Let me know please.\n", L);
2679 if (L < 0) L = 0;
2680 return (L);
2681 }
2682
2683
logLBinormal(double h,double k,double r)2684 double logLBinormal(double h, double k, double r)
2685 {
2686 /* This calculates the logarithm of the tail probability
2687 log{Pr(X>h, Y>k)} where X and Y have a standard bivariate normal distribution
2688 with correlation r. This is modified from LBinormal().
2689
2690 L(-10, 9, -1) = F(-9) - F(-10) is better than L(-10, 9, -1) = F(10) - F(9).
2691 So we use L(-10, 9, -0.3) = F(-9) - L(10, 9, 0.3).
2692 not L(-10, 9, -0.3) = F(10) - L(-10, -9, 0.3).
2693
2694 Results for the left tail, the very negative log(L), are reliable.
2695 Results for the right tail are not reliable, that is,
2696 if log(L) is close to 0 and L ~= 1. Perhaps try to use the following to reflect:
2697 L(-5,-9,r) = 1 - [ F(-5) + F(-9) - L(5,9,r) ]
2698 See logCDFNormal() for more details of the idea.
2699 */
2700 int nGL = (fabs(r) < 0.3 ? 16 : 32), i, j;
2701 const double *x = NULL, *w = NULL; /* Gauss-Legendre quadrature points */
2702 double shk, h0 = h, k0 = k, sk, L, t[2], hk2, a, b, c, d, bs, as, rs, signr = (r >= 0 ? 1 : -1);
2703 double S1 = 0, S2 = -1e300, S3 = -1e300, y, L1 = 0, L2 = 0, L3 = 0, largeneg = -1e300, smallr = 1e-10;
2704
2705 h = min2(h0, k0); k = max2(h0, k0);
2706 sk = signr*k;
2707 shk = signr*h*k;
2708 if (fabs(r) > 1 + smallr) error2("|r| > 1 in LBinormal");
2709 GaussLegendreRule(&x, &w, nGL);
2710
2711 if (fabs(r) < 0.925) { /* equation 3 */
2712 S1 = L = logCDFNormal(-h) + logCDFNormal(-k);
2713 if (fabs(r) > smallr) { /* this saves computation for the case of r = 0 */
2714 hk2 = (h*h + k*k) / 2;
2715 a = asin(r) / 2;
2716 for (i = 0, L2 = 0, S2 = -hk2; i < nGL / 2; i++) {
2717 t[0] = a*(1 - x[i]); t[0] = sin(t[0]);
2718 t[1] = a*(1 + x[i]); t[1] = sin(t[1]);
2719 for (j = 0; j < 2; j++) {
2720 y = -(hk2 - t[j] * h*k) / (1 - t[j] * t[j]);
2721 if (y > S2 + 30) {
2722 L *= exp(S2 - y);
2723 S2 = y;
2724 }
2725 L2 += a*w[i] * exp(y - S2);
2726 }
2727 }
2728 L2 /= 2 * Pi;
2729 y = max2(S1, S2);
2730 a = exp(S1 - y) + L2*exp(S2 - y);
2731 L = (a > 0 ? y + log(a) : largeneg);
2732 }
2733 }
2734 else { /* equation 6, using equation 7 instead of equation 5. */
2735 /* L = L1*exp(S1) + L2*exp(S2) + L3*exp(S3) */
2736 if (fabs(r) < 1) {
2737 /* first term in equation (6), analytical: L2 & S2 */
2738 as = 1 - r*r;
2739 a = sqrt(as);
2740 b = fabs(h - sk);
2741 bs = b*b;
2742 c = (4 - shk) / 8;
2743 d = (12 - shk) / 16;
2744 S2 = -(bs / as + shk) / 2; /* is this too large? */
2745 L2 = a*(1 - c*(bs - as)*(1 - d*bs / 5) / 3 + c*d*as*as / 5);
2746 y = -shk / 2 + logCDFNormal(-b / a);
2747 if (y > S2 + 30) {
2748 L2 *= exp(S2 - y);
2749 S2 = y;
2750 }
2751 L2 -= sqrt(2 * Pi) * exp(y - S2) * b * (1 - c*bs*(1 - d*bs / 5) / 3);
2752
2753 /* second term in equation (6), numerical: L3 & S3 */
2754 a /= 2;
2755 for (i = 0, L3 = 0, S3 = -1e300; i < nGL / 2; i++) {
2756 t[0] = a*(1 - x[i]); t[0] = t[0] * t[0];
2757 t[1] = a*(1 + x[i]); t[1] = t[1] * t[1];
2758 for (j = 0; j < 2; j++) {
2759 rs = sqrt(1 - t[j]);
2760 y = -(bs / t[j] + shk) / 2;
2761 if (y > S3 + 30) {
2762 L3 *= exp(S3 - y);
2763 S3 = y;
2764 }
2765 L3 += a*w[i] * exp(y - S3) * (exp(-shk*(1 - rs) / (2 * (1 + rs))) / rs - (1 + c*t[j] * (1 + d*t[j])));
2766 }
2767 }
2768 }
2769
2770
2771 /* L(h,k,s) term in equation (6), L1 & S1 */
2772 if (r > 0) {
2773 S1 = logCDFNormal(-max2(h, k));
2774 L1 = 1;
2775 }
2776 else if (r < 0 && h + k < 0) {
2777 a = logCDFNormal(-k);
2778 y = logCDFNormal(h);
2779 S1 = max2(a, y);
2780 L1 = exp(a - S1) - exp(y - S1);
2781 }
2782
2783 y = max2(S1, S2);
2784 y = max2(y, S3);
2785 a = L1*exp(S1 - y) - signr / (2 * Pi) * (L2*exp(S2 - y) + L3*exp(S3 - y));
2786
2787 L = (a > 0 ? y + log(a) : largeneg);
2788 }
2789
2790 if (L > 1e-12)
2791 printf("ln L(%2g, %.2g, %.2g) = %.6g is very large.\n", h0, k0, r, L);
2792 if (L > 0) L = 0;
2793
2794 return(L);
2795 }
2796
IntegerPartitions(int n,int prinT)2797 int IntegerPartitions(int n, int prinT)
2798 {
2799 /* Jerome Kelleher's algorithm for generating ascending partitions.
2800 */
2801 int a[256] = { 0 }, npartitions = 0, x, y, k, i;
2802
2803 if (n > 255) puts("n too large here");
2804 a[k = 1] = n;
2805 while (k) {
2806 y = a[k] - 1;
2807 k--;
2808 x = a[k] + 1;
2809 while (x <= y) {
2810 a[k] = x;
2811 y -= x;
2812 k++;
2813 }
2814 a[k] = x + y;
2815 a[k + 1] = 0;
2816 npartitions++;
2817 if (prinT && n < 64) {
2818 printf("[%3d ] ", k + 1);
2819 for (i = 0; i < k + 1; i++) printf(" %d", a[i]);
2820 printf("\n");
2821 }
2822 }
2823 return(npartitions);
2824 }
2825
2826
2827 #if (0)
testLBinormal(void)2828 void testLBinormal(void)
2829 {
2830 double x, y, r, L, lnL;
2831
2832 for (r = -1; r < 1.01; r += 0.05) {
2833 if (fabs(r - 1) < 1e-5) r = 1;
2834 printf("\nr = %.2f\n", r);
2835 for (x = -10; x <= 10.01; x += 0.5) {
2836 for (y = -10; y <= 10.01; y += 0.5) {
2837
2838 printf("x y r? "); scanf("%lf%lf%lf", &x, &y, &r);
2839
2840 L = LBinormal(x, y, r);
2841 lnL = logLBinormal(x, y, r);
2842
2843 if (fabs(L - exp(lnL)) > 1e-10)
2844 printf("L - exp(lnL) = %.10g very different.\n", L - exp(lnL));
2845
2846 if (L < 0 || L>1)
2847 printf("%6.2f %6.2f %6.2f L %15.8g = %15.8g %9.5g\n", x, y, r, L, exp(lnL), lnL);
2848
2849 if (lnL > 0) exit(-1);
2850 }
2851 }
2852 }
2853 }
2854 #endif
2855
2856
2857
2858
probBinomialDistribution(int n,double p,double prob[])2859 int probBinomialDistribution(int n, double p, double prob[])
2860 {
2861 /* calculates {n\choose k} * p^k * (1-p)^(n-k), for k=0,1,...,n and store in prob[].
2862 */
2863 int k;
2864 double y;
2865
2866 prob[0] = y = pow(1 - p, (double)n);
2867 for (k = 1; k <= n; k++)
2868 prob[k] = y *= ((n - k + 1)*p) / (k*(1 - p));
2869 return 0;
2870 }
2871
2872
probBinomial(int n,int k,double p)2873 double probBinomial(int n, int k, double p)
2874 {
2875 /* calculates {n\choose k} * p^k * (1-p)^(n-k)
2876 */
2877 double C, up, down;
2878
2879 if (n < 40 || (n < 1000 && k < 10)) {
2880 for (down = min2(k, n - k), up = n, C = 1; down > 0; down--, up--) C *= up / down;
2881 if (fabs(p - .5) < 1e-6) C *= pow(p, (double)n);
2882 else C *= pow(p, (double)k)*pow((1 - p), (double)(n - k));
2883 }
2884 else {
2885 C = exp((LnGamma(n + 1.) - LnGamma(k + 1.) - LnGamma(n - k + 1.)) / n);
2886 C = pow(p*C, (double)k) * pow((1 - p)*C, (double)(n - k));
2887 }
2888 return C;
2889 }
2890
2891
probBetaBinomial(int n,int k,double p,double q)2892 double probBetaBinomial(int n, int k, double p, double q)
2893 {
2894 /* This calculates beta-binomial probability of k succeses out of n trials,
2895 The binomial probability parameter has distribution beta(a, b)
2896
2897 prob(x) = C1(-a, k) * C2(-b, n-k) / C3(-a-b, n)
2898 */
2899 double a = p, b = q, C1, C2, C3, scale1, scale2, scale3;
2900
2901 if (a <= 0 || b <= 0) return(0);
2902 C1 = Binomial(-a, k, &scale1);
2903 C2 = Binomial(-b, n - k, &scale2);
2904 C3 = Binomial(-a - b, n, &scale3);
2905 C1 *= C2 / C3;
2906 if (C1 < 0)
2907 error2("error in probBetaBinomial");
2908 return C1*exp(scale1 + scale2 - scale3);
2909 }
2910
2911
PDFBeta(double x,double p,double q)2912 double PDFBeta(double x, double p, double q)
2913 {
2914 /* Returns pdf of beta(p,q)
2915 */
2916 double y, smallv = 1e-20;
2917
2918 if (x < smallv || x>1 - smallv)
2919 error2("bad x in PDFbeta");
2920
2921 y = (p - 1)*log(x) + (q - 1)*log(1 - x);
2922 y -= LnGamma(p) + LnGamma(q) - LnGamma(p + q);
2923
2924 return(exp(y));
2925 }
2926
CDFBeta(double x,double pin,double qin,double lnbeta)2927 double CDFBeta(double x, double pin, double qin, double lnbeta)
2928 {
2929 /* Returns distribution function of the standard form of the beta distribution,
2930 that is, the incomplete beta ratio I_x(p,q).
2931
2932 This is also known as the incomplete beta function ratio I_x(p, q)
2933
2934 lnbeta is log of the complete beta function; provide it if known,
2935 and otherwise use 0.
2936
2937 This is called from QuantileBeta() in a root-finding loop.
2938
2939 This routine is a translation into C of a Fortran subroutine
2940 by W. Fullerton of Los Alamos Scientific Laboratory.
2941 Bosten and Battiste (1974).
2942 Remark on Algorithm 179, CACM 17, p153, (1974).
2943 */
2944 double ans, c, finsum, p, ps, p1, q, term, xb, xi, y, smallv = 1e-15;
2945 int n, i, ib;
2946 static double eps = 0, alneps = 0, sml = 0, alnsml = 0;
2947
2948 if (x < smallv) return 0;
2949 else if (x > 1 - smallv) return 1;
2950 if (pin <= 0 || qin <= 0) {
2951 printf("p=%.4f q=%.4f: parameter outside range in CDFBeta", pin, qin);
2952 return (-1);
2953 }
2954
2955 if (eps == 0) {/* initialize machine constants ONCE */
2956 eps = pow((double)FLT_RADIX, -(double)DBL_MANT_DIG);
2957 alneps = log(eps);
2958 sml = DBL_MIN;
2959 alnsml = log(sml);
2960 }
2961 y = x; p = pin; q = qin;
2962
2963 /* swap tails if x is greater than the mean */
2964 if (p / (p + q) < x) {
2965 y = 1 - y;
2966 p = qin;
2967 q = pin;
2968 }
2969
2970 if (lnbeta == 0) lnbeta = LnBeta(p, q);
2971
2972 if ((p + q) * y / (p + 1) < eps) { /* tail approximation */
2973 ans = 0;
2974 xb = p * log(max2(y, sml)) - log(p) - lnbeta;
2975 if (xb > alnsml && y != 0)
2976 ans = exp(xb);
2977 if (y != x || p != pin)
2978 ans = 1 - ans;
2979 }
2980 else {
2981 /* evaluate the infinite sum first. term will equal */
2982 /* y^p / beta(ps, p) * (1 - ps)-sub-i * y^i / fac(i) */
2983 ps = q - floor(q);
2984 if (ps == 0)
2985 ps = 1;
2986
2987 xb = LnGamma(ps) + LnGamma(p) - LnGamma(ps + p);
2988 xb = p * log(y) - xb - log(p);
2989
2990 ans = 0;
2991 if (xb >= alnsml) {
2992 ans = exp(xb);
2993 term = ans * p;
2994 if (ps != 1) {
2995 n = (int)max2(alneps / log(y), 4.0);
2996 for (i = 1; i <= n; i++) {
2997 xi = i;
2998 term = term * (xi - ps) * y / xi;
2999 ans = ans + term / (p + xi);
3000 }
3001 }
3002 }
3003
3004 /* evaluate the finite sum. */
3005 if (q > 1) {
3006 xb = p * log(y) + q * log(1 - y) - lnbeta - log(q);
3007 ib = (int)(xb / alnsml); if (ib < 0) ib = 0;
3008 term = exp(xb - ib * alnsml);
3009 c = 1 / (1 - y);
3010 p1 = q * c / (p + q - 1);
3011
3012 finsum = 0;
3013 n = (int)q;
3014 if (q == (double)n)
3015 n = n - 1;
3016 for (i = 1; i <= n; i++) {
3017 if (p1 <= 1 && term / eps <= finsum)
3018 break;
3019 xi = i;
3020 term = (q - xi + 1) * c * term / (p + q - xi);
3021 if (term > 1) {
3022 ib = ib - 1;
3023 term = term * sml;
3024 }
3025 if (ib == 0)
3026 finsum = finsum + term;
3027 }
3028 ans = ans + finsum;
3029 }
3030 if (y != x || p != pin)
3031 ans = 1 - ans;
3032 if (ans > 1) ans = 1;
3033 if (ans < 0) ans = 0;
3034 }
3035 return ans;
3036 }
3037
QuantileBeta(double prob,double p,double q,double lnbeta)3038 double QuantileBeta(double prob, double p, double q, double lnbeta)
3039 {
3040 /* This calculates the Quantile of the beta distribution
3041
3042 Cran, G. W., K. J. Martin and G. E. Thomas (1977).
3043 Remark AS R19 and Algorithm AS 109, Applied Statistics, 26(1), 111-114.
3044 Remark AS R83 (v.39, 309-310) and correction (v.40(1) p.236).
3045
3046 My own implementation of the algorithm did not bracket the variable well.
3047 This version is Adpated from the pbeta and qbeta routines from
3048 "R : A Computer Language for Statistical Data Analysis". It fails for
3049 extreme values of p and q as well, although it seems better than my
3050 previous version.
3051 Ziheng Yang, May 2001
3052 */
3053 double fpu = 3e-308, acu_min = 1e-300, lower = fpu, upper = 1 - 2.22e-16;
3054 /* acu_min>= fpu: Minimal value for accuracy 'acu' which will depend on (a,p); */
3055 int swap_tail, i_pb, i_inn, niterations = 2000;
3056 double a, adj, g, h, pp, prev = 0, qq, r, s, t, tx = 0, w, y, yprev;
3057 double acu, xinbta;
3058
3059 if (prob < 0 || prob>1 || p < 0 || q < 0) error2("out of range in QuantileBeta");
3060
3061 /* define accuracy and initialize */
3062 xinbta = prob;
3063
3064 /* test for admissibility of parameters */
3065 if (p < 0 || q < 0 || prob < 0 || prob>1) error2("beta par err");
3066 if (prob == 0 || prob == 1)
3067 return prob;
3068
3069 if (lnbeta == 0) lnbeta = LnBeta(p, q);
3070
3071 /* change tail if necessary; afterwards 0 < a <= 1/2 */
3072 if (prob <= 0.5) {
3073 a = prob; pp = p; qq = q; swap_tail = 0;
3074 }
3075 else {
3076 a = 1. - prob; pp = q; qq = p; swap_tail = 1;
3077 }
3078
3079 /* calculate the initial approximation */
3080 r = sqrt(-log(a * a));
3081 y = r - (2.30753 + 0.27061*r) / (1. + (0.99229 + 0.04481*r) * r);
3082
3083 if (pp > 1. && qq > 1.) {
3084 r = (y * y - 3.) / 6.;
3085 s = 1. / (pp*2. - 1.);
3086 t = 1. / (qq*2. - 1.);
3087 h = 2. / (s + t);
3088 w = y * sqrt(h + r) / h - (t - s) * (r + 5. / 6. - 2. / (3.*h));
3089 xinbta = pp / (pp + qq * exp(w + w));
3090 }
3091 else {
3092 r = qq*2.;
3093 t = 1. / (9. * qq);
3094 t = r * pow(1. - t + y * sqrt(t), 3.);
3095 if (t <= 0.)
3096 xinbta = 1. - exp((log((1. - a) * qq) + lnbeta) / qq);
3097 else {
3098 t = (4.*pp + r - 2.) / t;
3099 if (t <= 1.)
3100 xinbta = exp((log(a * pp) + lnbeta) / pp);
3101 else
3102 xinbta = 1. - 2. / (t + 1.);
3103 }
3104 }
3105
3106 /* solve for x by a modified newton-raphson method, using CDFBeta */
3107 r = 1. - pp;
3108 t = 1. - qq;
3109 yprev = 0.;
3110 adj = 1.;
3111
3112
3113 /* Changes made by Ziheng to fix a bug in qbeta()
3114 qbeta(0.25, 0.143891, 0.05) = 3e-308 wrong (correct value is 0.457227)
3115 */
3116 if (xinbta <= lower || xinbta >= upper) xinbta = (a + .5) / 2;
3117
3118 /* Desired accuracy should depend on (a,p)
3119 * This is from Remark .. on AS 109, adapted.
3120 * However, it's not clear if this is "optimal" for IEEE double prec.
3121 * acu = fmax2(acu_min, pow(10., -25. - 5./(pp * pp) - 1./(a * a)));
3122 * NEW: 'acu' accuracy NOT for squared adjustment, but simple;
3123 * ---- i.e., "new acu" = sqrt(old acu)
3124 */
3125 acu = pow(10., -13. - 2.5 / (pp * pp) - 0.5 / (a * a));
3126 acu = max2(acu, acu_min);
3127
3128 for (i_pb = 0; i_pb < niterations; i_pb++) {
3129 y = CDFBeta(xinbta, pp, qq, lnbeta);
3130 y = (y - a) *
3131 exp(lnbeta + r * log(xinbta) + t * log(1. - xinbta));
3132 if (y * yprev <= 0)
3133 prev = max2(fabs(adj), fpu);
3134 for (i_inn = 0, g = 1; i_inn < niterations; i_inn++) {
3135 adj = g * y;
3136 if (fabs(adj) < prev) {
3137 tx = xinbta - adj; /* trial new x */
3138 if (tx >= 0. && tx <= 1.) {
3139 if (prev <= acu || fabs(y) <= acu) goto L_converged;
3140 if (tx != 0. && tx != 1.) break;
3141 }
3142 }
3143 g /= 3.;
3144 }
3145 if (fabs(tx - xinbta) < fpu)
3146 goto L_converged;
3147 xinbta = tx;
3148 yprev = y;
3149 }
3150 if (!PAML_RELEASE)
3151 printf("\nQuantileBeta(%.2f, %.5f, %.5f) = %.6e\t%d rounds\n",
3152 prob, p, q, (swap_tail ? 1. - xinbta : xinbta), niterations);
3153
3154 L_converged:
3155 return (swap_tail ? 1. - xinbta : xinbta);
3156 }
3157
3158
3159 static double prob_Quantile, *par_Quantile;
3160 static double(*cdf_Quantile)(double x, double par[]);
3161 double diff_Quantile(double x);
3162
diff_Quantile(double x)3163 double diff_Quantile(double x)
3164 {
3165 /* This is the difference between the given p and the CDF(x), the
3166 objective function to be minimized.
3167 */
3168 double px = (*cdf_Quantile)(x, par_Quantile);
3169 return(square(prob_Quantile - px));
3170 }
3171
Quantile(double (* cdf)(double x,double par[]),double p,double x,double par[],double xb[2])3172 double Quantile(double(*cdf)(double x, double par[]),
3173 double p, double x, double par[], double xb[2])
3174 {
3175 /* Use x for initial value if in range
3176 */
3177 int noisy0 = noisy;
3178 double sdiff, step = min2(0.05, (xb[1] - xb[0]) / 100), e = 1e-15;
3179
3180 noisy = 0;
3181 prob_Quantile = p; par_Quantile = par; cdf_Quantile = cdf;
3182 if (x <= xb[0] || x >= xb[1]) x = .5;
3183 LineSearch(diff_Quantile, &sdiff, &x, xb, step, e);
3184 noisy = noisy0;
3185
3186 return(x);
3187 }
3188
3189
3190
3191
GaussLegendreRule(const double ** x,const double ** w,int npoints)3192 int GaussLegendreRule(const double **x, const double **w, int npoints)
3193 {
3194 /* This returns the Gauss-Legendre nodes and weights in x[] and w[].
3195 npoints = 10, 20, 32, 64, 128, 256, 512, 1024
3196 */
3197 int status = 0;
3198 static const double x4[] = { 0.3399810435848562648026658, 0.8611363115940525752239465 };
3199 static const double w4[] = { 0.6521451548625461426269361, 0.3478548451374538573730639 };
3200
3201 static const double x8[] = { 0.1834346424956498049394761, 0.5255324099163289858177390,
3202 0.7966664774136267395915539, 0.9602898564975362316835609 };
3203 static const double w8[] = { 0.3626837833783619829651504, 0.3137066458778872873379622,
3204 0.2223810344533744705443560, 0.1012285362903762591525314 };
3205
3206 static const double x16[] = { 0.0950125098376374401853193, 0.2816035507792589132304605,
3207 0.4580167776572273863424194, 0.6178762444026437484466718,
3208 0.7554044083550030338951012, 0.8656312023878317438804679,
3209 0.9445750230732325760779884, 0.9894009349916499325961542 };
3210 static const double w16[] = { 0.1894506104550684962853967, 0.1826034150449235888667637,
3211 0.1691565193950025381893121, 0.1495959888165767320815017,
3212 0.1246289712555338720524763, 0.0951585116824927848099251,
3213 0.0622535239386478928628438, 0.0271524594117540948517806 };
3214
3215 static const double x32[] = { 0.048307665687738316234812570441, 0.144471961582796493485186373599,
3216 0.239287362252137074544603209166, 0.331868602282127649779916805730,
3217 0.421351276130635345364119436172, 0.506899908932229390023747474378,
3218 0.587715757240762329040745476402, 0.663044266930215200975115168663,
3219 0.732182118740289680387426665091, 0.794483795967942406963097298970,
3220 0.849367613732569970133693004968, 0.896321155766052123965307243719,
3221 0.934906075937739689170919134835, 0.964762255587506430773811928118,
3222 0.985611511545268335400175044631, 0.997263861849481563544981128665 };
3223 static const double w32[] = { 0.0965400885147278005667648300636, 0.0956387200792748594190820022041,
3224 0.0938443990808045656391802376681, 0.0911738786957638847128685771116,
3225 0.0876520930044038111427714627518, 0.0833119242269467552221990746043,
3226 0.0781938957870703064717409188283, 0.0723457941088485062253993564785,
3227 0.0658222227763618468376500637069, 0.0586840934785355471452836373002,
3228 0.0509980592623761761961632446895, 0.0428358980222266806568786466061,
3229 0.0342738629130214331026877322524, 0.0253920653092620594557525897892,
3230 0.0162743947309056706051705622064, 0.0070186100094700966004070637389 };
3231
3232 static const double x64[] = { 0.024350292663424432508955842854, 0.072993121787799039449542941940,
3233 0.121462819296120554470376463492, 0.169644420423992818037313629748,
3234 0.217423643740007084149648748989, 0.264687162208767416373964172510,
3235 0.311322871990210956157512698560, 0.357220158337668115950442615046,
3236 0.402270157963991603695766771260, 0.446366017253464087984947714759,
3237 0.489403145707052957478526307022, 0.531279464019894545658013903544,
3238 0.571895646202634034283878116659, 0.611155355172393250248852971019,
3239 0.648965471254657339857761231993, 0.685236313054233242563558371031,
3240 0.719881850171610826848940217832, 0.752819907260531896611863774886,
3241 0.783972358943341407610220525214, 0.813265315122797559741923338086,
3242 0.840629296252580362751691544696, 0.865999398154092819760783385070,
3243 0.889315445995114105853404038273, 0.910522137078502805756380668008,
3244 0.929569172131939575821490154559, 0.946411374858402816062481491347,
3245 0.961008799652053718918614121897, 0.973326827789910963741853507352,
3246 0.983336253884625956931299302157, 0.991013371476744320739382383443,
3247 0.996340116771955279346924500676, 0.999305041735772139456905624346 };
3248 static const double w64[] = { 0.0486909570091397203833653907347, 0.0485754674415034269347990667840,
3249 0.0483447622348029571697695271580, 0.0479993885964583077281261798713,
3250 0.0475401657148303086622822069442, 0.0469681828162100173253262857546,
3251 0.0462847965813144172959532492323, 0.0454916279274181444797709969713,
3252 0.0445905581637565630601347100309, 0.0435837245293234533768278609737,
3253 0.0424735151236535890073397679088, 0.0412625632426235286101562974736,
3254 0.0399537411327203413866569261283, 0.0385501531786156291289624969468,
3255 0.0370551285402400460404151018096, 0.0354722132568823838106931467152,
3256 0.0338051618371416093915654821107, 0.0320579283548515535854675043479,
3257 0.0302346570724024788679740598195, 0.0283396726142594832275113052002,
3258 0.0263774697150546586716917926252, 0.0243527025687108733381775504091,
3259 0.0222701738083832541592983303842, 0.0201348231535302093723403167285,
3260 0.0179517157756973430850453020011, 0.0157260304760247193219659952975,
3261 0.0134630478967186425980607666860, 0.0111681394601311288185904930192,
3262 0.0088467598263639477230309146597, 0.0065044579689783628561173604000,
3263 0.0041470332605624676352875357286, 0.0017832807216964329472960791450 };
3264
3265 static const double x128[] = { 0.0122236989606157641980521, 0.0366637909687334933302153,
3266 0.0610819696041395681037870, 0.0854636405045154986364980,
3267 0.1097942311276437466729747, 0.1340591994611877851175753,
3268 0.1582440427142249339974755, 0.1823343059853371824103826,
3269 0.2063155909020792171540580, 0.2301735642266599864109866,
3270 0.2538939664226943208556180, 0.2774626201779044028062316,
3271 0.3008654388776772026671541, 0.3240884350244133751832523,
3272 0.3471177285976355084261628, 0.3699395553498590266165917,
3273 0.3925402750332674427356482, 0.4149063795522750154922739,
3274 0.4370245010371041629370429, 0.4588814198335521954490891,
3275 0.4804640724041720258582757, 0.5017595591361444642896063,
3276 0.5227551520511754784539479, 0.5434383024128103634441936,
3277 0.5637966482266180839144308, 0.5838180216287630895500389,
3278 0.6034904561585486242035732, 0.6228021939105849107615396,
3279 0.6417416925623075571535249, 0.6602976322726460521059468,
3280 0.6784589224477192593677557, 0.6962147083695143323850866,
3281 0.7135543776835874133438599, 0.7304675667419088064717369,
3282 0.7469441667970619811698824, 0.7629743300440947227797691,
3283 0.7785484755064119668504941, 0.7936572947621932902433329,
3284 0.8082917575079136601196422, 0.8224431169556438424645942,
3285 0.8361029150609068471168753, 0.8492629875779689691636001,
3286 0.8619154689395484605906323, 0.8740527969580317986954180,
3287 0.8856677173453972174082924, 0.8967532880491581843864474,
3288 0.9073028834017568139214859, 0.9173101980809605370364836,
3289 0.9267692508789478433346245, 0.9356743882779163757831268,
3290 0.9440202878302201821211114, 0.9518019613412643862177963,
3291 0.9590147578536999280989185, 0.9656543664319652686458290,
3292 0.9717168187471365809043384, 0.9771984914639073871653744,
3293 0.9820961084357185360247656, 0.9864067427245862088712355,
3294 0.9901278184917343833379303, 0.9932571129002129353034372,
3295 0.9957927585349811868641612, 0.9977332486255140198821574,
3296 0.9990774599773758950119878, 0.9998248879471319144736081 };
3297 static const double w128[] = { 0.0244461801962625182113259, 0.0244315690978500450548486,
3298 0.0244023556338495820932980, 0.0243585572646906258532685,
3299 0.0243002001679718653234426, 0.0242273192228152481200933,
3300 0.0241399579890192849977167, 0.0240381686810240526375873,
3301 0.0239220121367034556724504, 0.0237915577810034006387807,
3302 0.0236468835844476151436514, 0.0234880760165359131530253,
3303 0.0233152299940627601224157, 0.0231284488243870278792979,
3304 0.0229278441436868469204110, 0.0227135358502364613097126,
3305 0.0224856520327449668718246, 0.0222443288937997651046291,
3306 0.0219897106684604914341221, 0.0217219495380520753752610,
3307 0.0214412055392084601371119, 0.0211476464682213485370195,
3308 0.0208414477807511491135839, 0.0205227924869600694322850,
3309 0.0201918710421300411806732, 0.0198488812328308622199444,
3310 0.0194940280587066028230219, 0.0191275236099509454865185,
3311 0.0187495869405447086509195, 0.0183604439373313432212893,
3312 0.0179603271850086859401969, 0.0175494758271177046487069,
3313 0.0171281354231113768306810, 0.0166965578015892045890915,
3314 0.0162550009097851870516575, 0.0158037286593993468589656,
3315 0.0153430107688651440859909, 0.0148731226021473142523855,
3316 0.0143943450041668461768239, 0.0139069641329519852442880,
3317 0.0134112712886163323144890, 0.0129075627392673472204428,
3318 0.0123961395439509229688217, 0.0118773073727402795758911,
3319 0.0113513763240804166932817, 0.0108186607395030762476596,
3320 0.0102794790158321571332153, 0.0097341534150068058635483,
3321 0.0091830098716608743344787, 0.0086263777986167497049788,
3322 0.0080645898904860579729286, 0.0074979819256347286876720,
3323 0.0069268925668988135634267, 0.0063516631617071887872143,
3324 0.0057726375428656985893346, 0.0051901618326763302050708,
3325 0.0046045842567029551182905, 0.0040162549837386423131943,
3326 0.0034255260409102157743378, 0.0028327514714579910952857,
3327 0.0022382884309626187436221, 0.0016425030186690295387909,
3328 0.0010458126793403487793129, 0.0004493809602920903763943 };
3329
3330 static const double x256[] = { 0.0061239123751895295011702, 0.0183708184788136651179263,
3331 0.0306149687799790293662786, 0.0428545265363790983812423,
3332 0.0550876556946339841045614, 0.0673125211657164002422903,
3333 0.0795272891002329659032271, 0.0917301271635195520311456,
3334 0.1039192048105094036391969, 0.1160926935603328049407349,
3335 0.1282487672706070947420496, 0.1403856024113758859130249,
3336 0.1525013783386563953746068, 0.1645942775675538498292845,
3337 0.1766624860449019974037218, 0.1887041934213888264615036,
3338 0.2007175933231266700680007, 0.2127008836226259579370402,
3339 0.2246522667091319671478783, 0.2365699497582840184775084,
3340 0.2484521450010566668332427, 0.2602970699919425419785609,
3341 0.2721029478763366095052447, 0.2838680076570817417997658,
3342 0.2955904844601356145637868, 0.3072686197993190762586103,
3343 0.3189006618401062756316834, 0.3304848656624169762291870,
3344 0.3420194935223716364807297, 0.3535028151129699895377902,
3345 0.3649331078236540185334649, 0.3763086569987163902830557,
3346 0.3876277561945155836379846, 0.3988887074354591277134632,
3347 0.4100898214687165500064336, 0.4212294180176238249768124,
3348 0.4323058260337413099534411, 0.4433173839475273572169258,
3349 0.4542624399175899987744552, 0.4651393520784793136455705,
3350 0.4759464887869833063907375, 0.4866822288668903501036214,
3351 0.4973449618521814771195124, 0.5079330882286160362319249,
3352 0.5184450196736744762216617, 0.5288791792948222619514764,
3353 0.5392340018660591811279362, 0.5495079340627185570424269,
3354 0.5596994346944811451369074, 0.5698069749365687590576675,
3355 0.5798290385590829449218317, 0.5897641221544543007857861,
3356 0.5996107353629683217303882, 0.6093674010963339395223108,
3357 0.6190326557592612194309676, 0.6286050494690149754322099,
3358 0.6380831462729113686686886, 0.6474655243637248626170162,
3359 0.6567507762929732218875002, 0.6659375091820485599064084,
3360 0.6750243449311627638559187, 0.6840099204260759531248771,
3361 0.6928928877425769601053416, 0.7016719143486851594060835,
3362 0.7103456833045433133945663, 0.7189128934599714483726399,
3363 0.7273722596496521265868944, 0.7357225128859178346203729,
3364 0.7439624005491115684556831, 0.7520906865754920595875297,
3365 0.7601061516426554549419068, 0.7680075933524456359758906,
3366 0.7757938264113257391320526, 0.7834636828081838207506702,
3367 0.7910160119895459945467075, 0.7984496810321707587825429,
3368 0.8057635748129986232573891, 0.8129565961764315431364104,
3369 0.8200276660989170674034781, 0.8269757238508125142890929,
3370 0.8337997271555048943484439, 0.8404986523457627138950680,
3371 0.8470714945172962071870724, 0.8535172676795029650730355,
3372 0.8598350049033763506961731, 0.8660237584665545192975154,
3373 0.8720825999954882891300459, 0.8780106206047065439864349,
3374 0.8838069310331582848598262, 0.8894706617776108888286766,
3375 0.8950009632230845774412228, 0.9003970057703035447716200,
3376 0.9056579799601446470826819, 0.9107830965950650118909072,
3377 0.9157715868574903845266696, 0.9206227024251464955050471,
3378 0.9253357155833162028727303, 0.9299099193340056411802456,
3379 0.9343446275020030942924765, 0.9386391748378148049819261,
3380 0.9427929171174624431830761, 0.9468052312391274813720517,
3381 0.9506755153166282763638521, 0.9544031887697162417644479,
3382 0.9579876924111781293657904, 0.9614284885307321440064075,
3383 0.9647250609757064309326123, 0.9678769152284894549090038,
3384 0.9708835784807430293209233, 0.9737445997043704052660786,
3385 0.9764595497192341556210107, 0.9790280212576220388242380,
3386 0.9814496290254644057693031, 0.9837240097603154961666861,
3387 0.9858508222861259564792451, 0.9878297475648606089164877,
3388 0.9896604887450652183192437, 0.9913427712075830869221885,
3389 0.9928763426088221171435338, 0.9942609729224096649628775,
3390 0.9954964544810963565926471, 0.9965826020233815404305044,
3391 0.9975192527567208275634088, 0.9983062664730064440555005,
3392 0.9989435258434088565550263, 0.9994309374662614082408542,
3393 0.9997684374092631861048786, 0.9999560500189922307348012 };
3394 static const double w256[] = { 0.0122476716402897559040703, 0.0122458343697479201424639,
3395 0.0122421601042728007697281, 0.0122366493950401581092426,
3396 0.0122293030687102789041463, 0.0122201222273039691917087,
3397 0.0122091082480372404075141, 0.0121962627831147135181810,
3398 0.0121815877594817721740476, 0.0121650853785355020613073,
3399 0.0121467581157944598155598, 0.0121266087205273210347185,
3400 0.0121046402153404630977578, 0.0120808558957245446559752,
3401 0.0120552593295601498143471, 0.0120278543565825711612675,
3402 0.0119986450878058119345367, 0.0119676359049058937290073,
3403 0.0119348314595635622558732, 0.0119002366727664897542872,
3404 0.0118638567340710787319046, 0.0118256971008239777711607,
3405 0.0117857634973434261816901, 0.0117440619140605503053767,
3406 0.0117005986066207402881898, 0.0116553800949452421212989,
3407 0.0116084131622531057220847, 0.0115597048540436357726687,
3408 0.0115092624770394979585864, 0.0114570935980906391523344,
3409 0.0114032060430391859648471, 0.0113476078955454919416257,
3410 0.0112903074958755095083676, 0.0112313134396496685726568,
3411 0.0111706345765534494627109, 0.0111082800090098436304608,
3412 0.0110442590908139012635176, 0.0109785814257295706379882,
3413 0.0109112568660490397007968, 0.0108422955111147959952935,
3414 0.0107717077058046266366536, 0.0106995040389797856030482,
3415 0.0106256953418965611339617, 0.0105502926865814815175336,
3416 0.0104733073841704030035696, 0.0103947509832117289971017,
3417 0.0103146352679340150682607, 0.0102329722564782196569549,
3418 0.0101497741990948656546341, 0.0100650535763063833094610,
3419 0.0099788230970349101247339, 0.0098910956966958286026307,
3420 0.0098018845352573278254988, 0.0097112029952662799642497,
3421 0.0096190646798407278571622, 0.0095254834106292848118297,
3422 0.0094304732257377527473528, 0.0093340483776232697124660,
3423 0.0092362233309563026873787, 0.0091370127604508064020005,
3424 0.0090364315486628736802278, 0.0089344947837582075484084,
3425 0.0088312177572487500253183, 0.0087266159616988071403366,
3426 0.0086207050884010143053688, 0.0085135010250224906938384,
3427 0.0084050198532215357561803, 0.0082952778462352254251714,
3428 0.0081842914664382699356198, 0.0080720773628734995009470,
3429 0.0079586523687543483536132, 0.0078440334989397118668103,
3430 0.0077282379473815556311102, 0.0076112830845456594616187,
3431 0.0074931864548058833585998, 0.0073739657738123464375724,
3432 0.0072536389258339137838291, 0.0071322239610753900716724,
3433 0.0070097390929698226212344, 0.0068862026954463203467133,
3434 0.0067616333001737987809279, 0.0066360495937810650445900,
3435 0.0065094704150536602678099, 0.0063819147521078805703752,
3436 0.0062534017395424012720636, 0.0061239506555679325423891,
3437 0.0059935809191153382211277, 0.0058623120869226530606616,
3438 0.0057301638506014371773844, 0.0055971560336829100775514,
3439 0.0054633085886443102775705, 0.0053286415939159303170811,
3440 0.0051931752508692809303288, 0.0050569298807868423875578,
3441 0.0049199259218138656695588, 0.0047821839258926913729317,
3442 0.0046437245556800603139791, 0.0045045685814478970686418,
3443 0.0043647368779680566815684, 0.0042242504213815362723565,
3444 0.0040831302860526684085998, 0.0039413976414088336277290,
3445 0.0037990737487662579981170, 0.0036561799581425021693892,
3446 0.0035127377050563073309711, 0.0033687685073155510120191,
3447 0.0032242939617941981570107, 0.0030793357411993375832054,
3448 0.0029339155908297166460123, 0.0027880553253277068805748,
3449 0.0026417768254274905641208, 0.0024951020347037068508395,
3450 0.0023480529563273120170065, 0.0022006516498399104996849,
3451 0.0020529202279661431745488, 0.0019048808534997184044191,
3452 0.0017565557363307299936069, 0.0016079671307493272424499,
3453 0.0014591373333107332010884, 0.0013100886819025044578317,
3454 0.0011608435575677247239706, 0.0010114243932084404526058,
3455 0.0008618537014200890378141, 0.0007121541634733206669090,
3456 0.0005623489540314098028152, 0.0004124632544261763284322,
3457 0.0002625349442964459062875, 0.0001127890178222721755125 };
3458
3459 static const double x512[] = { 0.0030649621851593961529232, 0.0091947713864329108047442,
3460 0.0153242350848981855249677, 0.0214531229597748745137841,
3461 0.0275812047119197840615246, 0.0337082500724805951232271,
3462 0.0398340288115484476830396, 0.0459583107468090617788760,
3463 0.0520808657521920701127271, 0.0582014637665182372392330,
3464 0.0643198748021442404045319, 0.0704358689536046871990309,
3465 0.0765492164062510452915674, 0.0826596874448871596284651,
3466 0.0887670524624010326092165, 0.0948710819683925428909483,
3467 0.1009715465977967786264323, 0.1070682171195026611052004,
3468 0.1131608644449665349442888, 0.1192492596368204011642726,
3469 0.1253331739174744696875513, 0.1314123786777137080093018,
3470 0.1374866454852880630171099, 0.1435557460934960331730353,
3471 0.1496194524497612685217272, 0.1556775367042018762501969,
3472 0.1617297712181921097989489, 0.1677759285729161198103670,
3473 0.1738157815779134454985394, 0.1798491032796159253350647,
3474 0.1858756669698757062678115, 0.1918952461944840310240859,
3475 0.1979076147616804833961808, 0.2039125467506523717658375,
3476 0.2099098165200239314947094, 0.2158991987163350271904893,
3477 0.2218804682825090362529109, 0.2278534004663095955103621,
3478 0.2338177708287858931763260, 0.2397733552527061887852891,
3479 0.2457199299509792442100997, 0.2516572714750633493170137,
3480 0.2575851567233626262808095, 0.2635033629496102970603704,
3481 0.2694116677712385990250046, 0.2753098491777350342234845,
3482 0.2811976855389846383013106, 0.2870749556135979555970354,
3483 0.2929414385572244074855835, 0.2987969139308507415853707,
3484 0.3046411617090842500066247, 0.3104739622884204453906292,
3485 0.3162950964954948840736281, 0.3221043455953188263048133,
3486 0.3279014912994984240551598, 0.3336863157744371275728377,
3487 0.3394586016495210024715049, 0.3452181320252866497799379,
3488 0.3509646904815714220351686, 0.3566980610856456291665404,
3489 0.3624180284003264285948478, 0.3681243774920730946589582,
3490 0.3738168939390633631820054, 0.3794953638392505477003659,
3491 0.3851595738184011246011504, 0.3908093110381124851478484,
3492 0.3964443632038105531190080, 0.4020645185727269675414064,
3493 0.4076695659618555307670286, 0.4132592947558876229222955,
3494 0.4188334949151262845483445, 0.4243919569833786700527309,
3495 0.4299344720958265754056529, 0.4354608319868747443376920,
3496 0.4409708289979766581310498, 0.4464642560854375149423431,
3497 0.4519409068281941054521446, 0.4574005754355712925046003,
3498 0.4628430567550148032795831, 0.4682681462798000434299255,
3499 0.4736756401567166435172692, 0.4790653351937284489919577,
3500 0.4844370288676086658851277, 0.4897905193315498753147078,
3501 0.4951256054227486308513615, 0.5004420866699643537454866,
3502 0.5057397633010522419821678, 0.5110184362504699101074361,
3503 0.5162779071667574777562819, 0.5215179784199908258105606,
3504 0.5267384531092077401231844, 0.5319391350698066637637706,
3505 0.5371198288809177797701793, 0.5422803398727461474300859,
3506 0.5474204741338866161668468, 0.5525400385186102421644070,
3507 0.5576388406541219339368088, 0.5627166889477890541289656,
3508 0.5677733925943407059267120, 0.5728087615830374335557009,
3509 0.5778226067048110674604360, 0.5828147395593744458765762,
3510 0.5877849725623007456415722, 0.5927331189520721562306608,
3511 0.5976589927970976321572046, 0.6025624090026994600382737,
3512 0.6074431833180683777981926, 0.6123011323431869846644595,
3513 0.6171360735357211818019505, 0.6219478252178793846326095,
3514 0.6267362065832392490988318, 0.6315010377035416553494506,
3515 0.6362421395354516935575740, 0.6409593339272863978194482,
3516 0.6456524436257089753330001, 0.6503212922823892793136899,
3517 0.6549657044606302753737317, 0.6595855056419602523685720,
3518 0.6641805222326905300017078, 0.6687505815704384167754210,
3519 0.6732955119306151731807642, 0.6778151425328787363350998,
3520 0.6823093035475509635996236, 0.6867778261019991540425409,
3521 0.6912205422869816079558685, 0.6956372851629569859851427,
3522 0.7000278887663572307915895, 0.7043921881158238155354902,
3523 0.7087300192184070848475163, 0.7130412190757284553416507,
3524 0.7173256256901052441189100, 0.7215830780706378951153816,
3525 0.7258134162392593745610389, 0.7300164812367465082373380,
3526 0.7341921151286930346516885, 0.7383401610114441496854630,
3527 0.7424604630179923197192207, 0.7465528663238341416942072,
3528 0.7506172171527880300329109, 0.7546533627827725118134392,
3529 0.7586611515515449130726824, 0.7626404328624002206015913,
3530 0.7665910571898299050923647, 0.7705128760851404930018538,
3531 0.7744057421820316760079998, 0.7782695092021337484565606,
3532 0.7821040319605041647237048, 0.7859091663710830099561901,
3533 0.7896847694521071791947507, 0.7934306993314830614379285,
3534 0.7971468152521175267628422, 0.8008329775772070161862372,
3535 0.8044890477954845355235412, 0.8081148885264243560855026,
3536 0.8117103635254042266412553, 0.8152753376888249026732770,
3537 0.8188096770591868005536242, 0.8223132488301235858819787,
3538 0.8257859213513925068443721, 0.8292275641338212850768968,
3539 0.8326380478542113781512150, 0.8360172443601974294381733,
3540 0.8393650266750627227522641, 0.8426812690025104608329811,
3541 0.8459658467313906883792422, 0.8492186364403826820199251,
3542 0.8524395159026326312771384, 0.8556283640903464362590494,
3543 0.8587850611793374495058711, 0.8619094885535289911058997,
3544 0.8650015288094114678982387, 0.8680610657604539292849800,
3545 0.8710879844414698938880857, 0.8740821711129372830049576,
3546 0.8770435132652722985416439, 0.8799718996230570848337538,
3547 0.8828672201492210155023745, 0.8857293660491754482355527,
3548 0.8885582297749017921351663, 0.8913537050289927340242104,
3549 0.8941156867686464718706125, 0.8968440712096138052506156,
3550 0.8995387558300979345474886, 0.9021996393746068223597927,
3551 0.9048266218577579723776075, 0.9074196045680354827749729,
3552 0.9099784900714992329623006, 0.9125031822154460643436214,
3553 0.9149935861320228175302595, 0.9174496082417910902748409,
3554 0.9198711562572435822074657, 0.9222581391862718942794141,
3555 0.9246104673355856526489486, 0.9269280523140828285786768,
3556 0.9292108070361711277546193, 0.9314586457250403242837002,
3557 0.9336714839158854164789745, 0.9358492384590804834007204,
3558 0.9379918275233031229867813, 0.9400991705986093544775539,
3559 0.9421711884994588697201555, 0.9442078033676905198230562,
3560 0.9462089386754479255274304, 0.9481745192280551015654245,
3561 0.9501044711668419871894147, 0.9519987219719197769813274,
3562 0.9538572004649059479887372, 0.9556798368115988811866200,
3563 0.9574665625246019772327448, 0.9592173104658971684737507,
3564 0.9609320148493677311718534, 0.9626106112432703039637754,
3565 0.9642530365726560206402068, 0.9658592291217406674540047,
3566 0.9674291285362237773389233, 0.9689626758255565756615864,
3567 0.9704598133651586944555050, 0.9719204848985835745206522,
3568 0.9733446355396324773464471, 0.9747322117744170315712560,
3569 0.9760831614633702416830300, 0.9773974338432058899681861,
3570 0.9786749795288262664309572, 0.9799157505151781656726285,
3571 0.9811197001790570947322311, 0.9822867832808596419166429,
3572 0.9834169559662839640681455, 0.9845101757679783590716126,
3573 0.9855664016071379024692622, 0.9865855937950491429603684,
3574 0.9875677140345828729848910, 0.9885127254216350200148487,
3575 0.9894205924465157453777048, 0.9902912809952868962106899,
3576 0.9911247583510480415528399, 0.9919209931951714500244370,
3577 0.9926799556084865573546763, 0.9934016170724147657859271,
3578 0.9940859504700558793702825, 0.9947329300872282225027936,
3579 0.9953425316134657151476031, 0.9959147321429772566997088,
3580 0.9964495101755774022837600, 0.9969468456176038804367370,
3581 0.9974067197828498321611183, 0.9978291153935628466036470,
3582 0.9982140165816127953876923, 0.9985614088900397275573677,
3583 0.9988712792754494246541769, 0.9991436161123782382453400,
3584 0.9993784092025992514480161, 0.9995756497983108555936109,
3585 0.9997353306710426625827368, 0.9998574463699794385446275,
3586 0.9999419946068456536361287, 0.9999889909843818679872841 };
3587 static const double w512[] = { 0.0061299051754057857591564, 0.0061296748380364986664278,
3588 0.0061292141719530834395471, 0.0061285231944655327693402,
3589 0.0061276019315380226384508, 0.0061264504177879366912426,
3590 0.0061250686964845654506976, 0.0061234568195474804311878,
3591 0.0061216148475445832082156, 0.0061195428496898295184288,
3592 0.0061172409038406284754329, 0.0061147090964949169991245,
3593 0.0061119475227879095684795, 0.0061089562864885234199252,
3594 0.0061057354999954793256260, 0.0061022852843330780981965,
3595 0.0060986057691466529805468, 0.0060946970926976980917399,
3596 0.0060905594018586731119147, 0.0060861928521074844014940,
3597 0.0060815976075216427620556, 0.0060767738407720980583934,
3598 0.0060717217331167509334394, 0.0060664414743936418598512,
3599 0.0060609332630138177841916, 0.0060551973059538766317450,
3600 0.0060492338187481899521175, 0.0060430430254808039978627,
3601 0.0060366251587770195404584, 0.0060299804597946507400317,
3602 0.0060231091782149633972884, 0.0060160115722332929281516,
3603 0.0060086879085493424136484, 0.0060011384623571610896056,
3604 0.0059933635173348036527221, 0.0059853633656336707715812,
3605 0.0059771383078675312031423, 0.0059686886531012259272183,
3606 0.0059600147188390547233923, 0.0059511168310128456267588,
3607 0.0059419953239697077107922, 0.0059326505404594676575446,
3608 0.0059230828316217905872556, 0.0059132925569729856313229,
3609 0.0059032800843924967444267, 0.0058930457901090792634301,
3610 0.0058825900586866627324847, 0.0058719132830099005255609,
3611 0.0058610158642694068093892, 0.0058498982119466814015496,
3612 0.0058385607437987230901727, 0.0058270038858423319934219,
3613 0.0058152280723381015486124, 0.0058032337457741007324836,
3614 0.0057910213568492471257818, 0.0057785913644563714469284,
3615 0.0057659442356649741911390, 0.0057530804457036750229319,
3616 0.0057400004779423555815070, 0.0057267048238739963699973,
3617 0.0057131939830962084110906, 0.0056994684632924603629882,
3618 0.0056855287802130018011102, 0.0056713754576554833823756,
3619 0.0056570090274452746202723, 0.0056424300294154800102991,
3620 0.0056276390113866542566918, 0.0056126365291462173626557,
3621 0.0055974231464275703576030, 0.0055819994348889124461425,
3622 0.0055663659740917603747899, 0.0055505233514791708235538,
3623 0.0055344721623536666407146, 0.0055182130098548677502395,
3624 0.0055017465049368275723757, 0.0054850732663450758090285,
3625 0.0054681939205933684565648, 0.0054511091019401459196852,
3626 0.0054338194523647001109732, 0.0054163256215430514316688,
3627 0.0053986282668235365401123, 0.0053807280532021078251738,
3628 0.0053626256532973455128155, 0.0053443217473251833447318,
3629 0.0053258170230733487787774, 0.0053071121758755186716175,
3630 0.0052882079085851914147269, 0.0052691049315492765055207,
3631 0.0052498039625814025460136, 0.0052303057269349446719890,
3632 0.0052106109572757724261988, 0.0051907203936547190996206,
3633 0.0051706347834797735752665, 0.0051503548814879957194620,
3634 0.0051298814497171563759039, 0.0051092152574771030281542,
3635 0.0050883570813208522065339, 0.0050673077050154097256505,
3636 0.0050460679195123198490183, 0.0050246385229179444874178,
3637 0.0050030203204634735477834, 0.0049812141244746675595135,
3638 0.0049592207543413337151533, 0.0049370410364865364724225,
3639 0.0049146758043355438745290, 0.0048921258982845107556462,
3640 0.0048693921656689000083132, 0.0048464754607316430993636,
3641 0.0048233766445910410307843, 0.0048000965852084069516609,
3642 0.0047766361573554516370718, 0.0047529962425814130594576,
3643 0.0047291777291799312876071, 0.0047051815121556699579709,
3644 0.0046810084931906855725376, 0.0046566595806105458869828,
3645 0.0046321356893501986622283, 0.0046074377409195920619320,
3646 0.0045825666633690479877601, 0.0045575233912543896535753,
3647 0.0045323088656018247089130, 0.0045069240338725852313010,
3648 0.0044813698499273259161146, 0.0044556472739902818017469,
3649 0.0044297572726131868769073, 0.0044037008186389549258496,
3650 0.0043774788911651239762643, 0.0043510924755070657234522,
3651 0.0043245425631609613132305, 0.0042978301517665448748000,
3652 0.0042709562450696162035304, 0.0042439218528843240022977,
3653 0.0042167279910552210986262, 0.0041893756814190930634598,
3654 0.0041618659517665616659011, 0.0041341998358034646067195,
3655 0.0041063783731120129818357, 0.0040784026091117279353449,
3656 0.0040502735950201579699371, 0.0040219923878133783908191,
3657 0.0039935600501862743674273, 0.0039649776505126091053562,
3658 0.0039362462628048786290012, 0.0039073669666739546834366,
3659 0.0038783408472885172720108, 0.0038491689953342783540510,
3660 0.0038198525069729982349166, 0.0037903924838012961884344,
3661 0.0037607900328092568594835, 0.0037310462663388340021755,
3662 0.0037011623020420531166926, 0.0036711392628390145554094,
3663 0.0036409782768756986764252, 0.0036106804774815746300758,
3664 0.0035802470031270143713799, 0.0035496789973805134987000,
3665 0.0035189776088657205261605, 0.0034881439912182762045767,
3666 0.0034571793030424645127888, 0.0034260847078676769483860,
3667 0.0033948613741046917538288, 0.0033635104750017697209450,
3668 0.0033320331886005682236783, 0.0033004306976918751358177,
3669 0.0032687041897711642972145, 0.0032368548569939741987234,
3670 0.0032048838961311115627642, 0.0031727925085236815030060,
3671 0.0031405819000379459532169, 0.0031082532810200120618074,
3672 0.0030758078662503522550163, 0.0030432468748981576780527,
3673 0.0030105715304755267298129, 0.0029777830607914904130339,
3674 0.0029448826979058762279357, 0.0029118716780830123435331,
3675 0.0028787512417452737868732, 0.0028455226334264723964728,
3676 0.0028121871017250922921949, 0.0027787458992573726197173,
3677 0.0027452002826102393336092, 0.0027115515122940877888456,
3678 0.0026778008526954179163600, 0.0026439495720293237639656,
3679 0.0026099989422918391896635, 0.0025759502392121415000167,
3680 0.0025418047422046148318992, 0.0025075637343207750815413,
3681 0.0024732285022010581903898, 0.0024388003360264736029032,
3682 0.0024042805294701247170072, 0.0023696703796485981535706,
3683 0.0023349711870732236769383, 0.0023001842556012066042973,
3684 0.0022653108923866345474810, 0.0022303524078313603367724,
3685 0.0021953101155357629823745, 0.0021601853322493885355395,
3686 0.0021249793778214727179358, 0.0020896935751513471947536,
3687 0.0020543292501387313744068, 0.0020188877316339116255770,
3688 0.0019833703513878098109153, 0.0019477784440019430461334,
3689 0.0019121133468782766036998, 0.0018763764001689718921795,
3690 0.0018405689467260314557679, 0.0018046923320508429542037,
3691 0.0017687479042436241015783, 0.0017327370139527705642995,
3692 0.0016966610143241088445575, 0.0016605212609500562072903,
3693 0.0016243191118186897474239, 0.0015880559272627267421479,
3694 0.0015517330699084184928942, 0.0015153519046243599371387,
3695 0.0014789137984702174059640, 0.0014424201206453770259886,
3696 0.0014058722424375164225552, 0.0013692715371711025869345,
3697 0.0013326193801558190401403, 0.0012959171486349257824991,
3698 0.0012591662217335559930561, 0.0012223679804069540808915,
3699 0.0011855238073886605549070, 0.0011486350871386503607080,
3700 0.0011117032057914329649653, 0.0010747295511041247428251,
3701 0.0010377155124045074300544, 0.0010006624805390909706032,
3702 0.0009635718478212056798501, 0.0009264450079791582697455,
3703 0.0008892833561045005372012, 0.0008520882886004809402792,
3704 0.0008148612031307819965602, 0.0007776034985686972438014,
3705 0.0007403165749469818962867, 0.0007030018334087411433900,
3706 0.0006656606761599343409382, 0.0006282945064244358390880,
3707 0.0005909047284032230162400, 0.0005534927472403894647847,
3708 0.0005160599690007674370993, 0.0004786078006679509066920,
3709 0.0004411376501795405636493, 0.0004036509265333198797447,
3710 0.0003661490400356268530141, 0.0003286334028523334162522,
3711 0.0002911054302514885125319, 0.0002535665435705865135866,
3712 0.0002160181779769908583388, 0.0001784618055459532946077,
3713 0.0001408990173881984930124, 0.0001033319034969132362968,
3714 0.0000657657316592401958310, 0.0000282526373739346920387 };
3715
3716 static const double x1024[] = { 0.0015332313560626384065387, 0.0045996796509132604743248,
3717 0.0076660846940754867627839, 0.0107324176515422803327458,
3718 0.0137986496899844401539048, 0.0168647519770217265449962,
3719 0.0199306956814939776907024, 0.0229964519737322146859283,
3720 0.0260619920258297325581921, 0.0291272870119131747190088,
3721 0.0321923081084135882953009, 0.0352570264943374577920498,
3722 0.0383214133515377145376052, 0.0413854398649847193632977,
3723 0.0444490772230372159692514, 0.0475122966177132524285687,
3724 0.0505750692449610682823599, 0.0536373663049299446784129,
3725 0.0566991590022410150066456, 0.0597604185462580334848567,
3726 0.0628211161513580991486838, 0.0658812230372023327000985,
3727 0.0689407104290065036692117, 0.0719995495578116053446277,
3728 0.0750577116607543749280791, 0.0781151679813377563695878,
3729 0.0811718897697013033399379, 0.0842278482828915197978074,
3730 0.0872830147851321356094940, 0.0903373605480943146797811,
3731 0.0933908568511667930531222, 0.0964434749817259444449839,
3732 0.0994951862354057706638682, 0.1025459619163678143852404,
3733 0.1055957733375709917393206, 0.1086445918210413421754502,
3734 0.1116923886981416930665228, 0.1147391353098412365177689,
3735 0.1177848030069850158450139, 0.1208293631505633191883714,
3736 0.1238727871119809777282145, 0.1269150462733265659711591,
3737 0.1299561120276415015747167, 0.1329959557791890421802183,
3738 0.1360345489437231767245806, 0.1390718629487574087024745,
3739 0.1421078692338334288514767, 0.1451425392507896747338214,
3740 0.1481758444640297746894331, 0.1512077563507908736360111,
3741 0.1542382464014118381930443, 0.1572672861196013386077717,
3742 0.1602948470227058049622614, 0.1633209006419772551419632,
3743 0.1663454185228409920472972, 0.1693683722251631675310675,
3744 0.1723897333235182105457458, 0.1754094734074561169859457,
3745 0.1784275640817695987127083, 0.1814439769667610892475458,
3746 0.1844586836985096036255346, 0.1874716559291374498981239,
3747 0.1904828653270767897777182, 0.1934922835773360459175133,
3748 0.1964998823817661533215037, 0.1995056334593266523810493,
3749 0.2025095085463516210358758, 0.2055114793968154435588961,
3750 0.2085115177825984134657778, 0.2115095954937521680517391,
3751 0.2145056843387649520596422, 0.2174997561448267079850562,
3752 0.2204917827580939905255947, 0.2234817360439547026834844,
3753 0.2264695878872926510320010, 0.2294553101927519176581055,
3754 0.2324388748850010462953415, 0.2354202539089970401627982,
3755 0.2383994192302491690277166, 0.2413763428350825830111093,
3756 0.2443509967309017306575811, 0.2473233529464535787923793,
3757 0.2502933835320906316905658, 0.2532610605600337470850902,
3758 0.2562263561246347465424530, 0.2591892423426388177365829,
3759 0.2621496913534467061535080, 0.2651076753193766937613805,
3760 0.2680631664259263621824189, 0.2710161368820341379053566,
3761 0.2739665589203406170790369, 0.2769144047974496674298651,
3762 0.2798596467941893048479266, 0.2828022572158723421886958,
3763 0.2857422083925568078394062, 0.2886794726793061316013119,
3764 0.2916140224564490954412652, 0.2945458301298395466682397,
3765 0.2974748681311158710926665, 0.3004011089179602237287060,
3766 0.3033245249743575146018584, 0.3062450888108541472266190,
3767 0.3091627729648165073212094, 0.3120775500006891993287636,
3768 0.3149893925102530283167230, 0.3178982731128827248285835,
3769 0.3208041644558044102645582, 0.3237070392143528003701590,
3770 0.3266068700922281444141618, 0.3295036298217528976399056,
3771 0.3323972911641281245763845, 0.3352878269096896307981228,
3772 0.3381752098781638207253743, 0.3410594129189232790587667,
3773 0.3439404089112420734451077, 0.3468181707645507759736923,
3774 0.3496926714186912011050938, 0.3525638838441708576370887,
3775 0.3554317810424171123150528, 0.3582963360460310626968790,
3776 0.3611575219190411168852009, 0.3640153117571562777424605,
3777 0.3668696786880191292071420, 0.3697205958714585223322883,
3778 0.3725680364997419586702471, 0.3754119737978276686304337,
3779 0.3782523810236163824397703, 0.3810892314682027913383487,
3780 0.3839224984561266966457784, 0.3867521553456238443366159,
3781 0.3895781755288764427662286, 0.3924005324322633611914264,
3782 0.3952191995166100067331951, 0.3980341502774378774318886,
3783 0.4008453582452137890482864, 0.4036527969855987732669841,
3784 0.4064564400996966449616823, 0.4092562612243022361850445,
3785 0.4120522340321492945489319, 0.4148443322321580436639788,
3786 0.4176325295696824033106488, 0.4204167998267568670171117,
3787 0.4231971168223430347225035, 0.4259734544125757982073747,
3788 0.4287457864910091769763965, 0.4315140869888618022816824,
3789 0.4342783298752620469783905, 0.4370384891574927989076034,
3790 0.4397945388812358755048319, 0.4425464531308160773358662,
3791 0.4452942060294448782650898, 0.4480377717394637499647905,
3792 0.4507771244625871184774399, 0.4535122384401449505463744,
3793 0.4562430879533249674337895, 0.4589696473234144839484647,
3794 0.4616918909120418704091584, 0.4644097931214176352731591,
3795 0.4671233283945751261630457, 0.4698324712156108470282980,
3796 0.4725371961099243891820077, 0.4752374776444579739565725,
3797 0.4779332904279356047259052, 0.4806246091111018260453658,
3798 0.4833114083869600876643171, 0.4859936629910107111699206,
3799 0.4886713477014884570245255, 0.4913444373395996897627612,
3800 0.4940129067697591391182235, 0.4966767308998262548534419,
3801 0.4993358846813411530706387, 0.5019903431097601517846292,
3802 0.5046400812246908935430768, 0.5072850741101270528831987,
3803 0.5099252968946826264179220, 0.5125607247518258033484145,
3804 0.5151913329001124142038603, 0.5178170966034189556133159,
3805 0.5204379911711751889184691, 0.5230539919585963104401304,
3806 0.5256650743669146912153147, 0.5282712138436111840258187,
3807 0.5308723858826459955432696, 0.5334685660246891214197081,
3808 0.5360597298573503421568799, 0.5386458530154087775915395,
3809 0.5412269111810419978382210, 0.5438028800840546885350993,
3810 0.5463737355021068682427603, 0.5489394532609416558499039,
3811 0.5515000092346125858442412, 0.5540553793457104693110943,
3812 0.5566055395655897985264809, 0.5591504659145946930157566,
3813 0.5616901344622843849532002, 0.5642245213276582417822586,
3814 0.5667536026793803239405196, 0.5692773547360034755778519,
3815 0.5717957537661929461605442, 0.5743087760889495408586850,
3816 0.5768163980738322976184566, 0.5793185961411806888254667,
3817 0.5818153467623363454697137, 0.5843066264598643017272666,
3818 0.5867924118077737578782574, 0.5892726794317383594853053,
3819 0.5917474060093159907610475, 0.5942165682701680800580147,
3820 0.5966801429962784154186793, 0.5991381070221714681281111,
3821 0.6015904372351302222163013, 0.6040371105754135078618616,
3822 0.6064781040364728366534687, 0.6089133946651687366701116,
3823 0.6113429595619865853458987, 0.6137667758812519380899084,
3824 0.6161848208313453506363029, 0.6185970716749166931046915,
3825 0.6210035057290989537555048, 0.6234041003657215304299416,
3826 0.6257988330115230076688675, 0.6281876811483634175098794,
3827 0.6305706223134359819666081, 0.6329476340994783351992008,
3828 0.6353186941549832233898213, 0.6376837801844086803419153,
3829 0.6400428699483876768269192, 0.6423959412639372417070377,
3830 0.6447429720046670528676835, 0.6470839401009874959981582,
3831 0.6494188235403171892641570, 0.6517476003672899719207013,
3832 0.6540702486839613549191454, 0.6563867466500144315669620,
3833 0.6586970724829652463040876, 0.6610012044583676196647058,
3834 0.6632991209100174274984589, 0.6655908002301563325302097,
3835 0.6678762208696749663426270, 0.6701553613383155598710345,
3836 0.6724282002048740205051479, 0.6746947160974014538975312,
3837 0.6769548877034051285838219, 0.6792086937700488815250166,
3838 0.6814561131043529626873631, 0.6836971245733933167806834,
3839 0.6859317071045003002812397, 0.6881598396854568318705713,
3840 0.6903815013646959744270519, 0.6925966712514979467122689,
3841 0.6948053285161865628996815, 0.6970074523903250980984011,
3842 0.6992030221669115780303307, 0.7013920172005734910243170,
3843 0.7035744169077619204963997, 0.7057502007669450960906928,
3844 0.7079193483188013616608982, 0.7100818391664115582779368,
3845 0.7122376529754508204546805, 0.7143867694743797837842896,
3846 0.7165291684546352021941915, 0.7186648297708199730232898,
3847 0.7207937333408925681355609, 0.7229158591463558692887801,
3848 0.7250311872324454059827217, 0.7271396977083169940167956,
3849 0.7292413707472337729927181, 0.7313361865867526410034676,
3850 0.7334241255289100847554419, 0.7355051679404074033764222,
3851 0.7375792942527953241676460, 0.7396464849626580085640129,
3852 0.7417067206317964465721772, 0.7437599818874112379620360,
3853 0.7458062494222847584928838, 0.7478455039949627094612890,
3854 0.7498777264299350488635483, 0.7519028976178163024713854,
3855 0.7539209985155252531253957, 0.7559320101464640065565832,
3856 0.7579359136006964320521972, 0.7599326900351259762879594,
3857 0.7619223206736728486546595, 0.7639047868074505764130149,
3858 0.7658800697949419280166093, 0.7678481510621742029486694,
3859 0.7698090121028938864243967, 0.7717626344787406673165402,
3860 0.7737089998194208176678866, 0.7756480898228799321603470,
3861 0.7775798862554750259163361, 0.7795043709521459890141759,
3862 0.7814215258165863961053031, 0.7833313328214136695271245,
3863 0.7852337740083385943114429, 0.7871288314883341834944720,
3864 0.7890164874418038921405657, 0.7908967241187491784979139,
3865 0.7927695238389364107105941, 0.7946348689920631175175217,
3866 0.7964927420379235813750136, 0.7983431255065737724458586,
3867 0.8001860019984956219039900, 0.8020213541847606330100649,
3868 0.8038491648071928284194859, 0.8056694166785310321906380,
3869 0.8074820926825904849673728, 0.8092871757744237908160400,
3870 0.8110846489804811942036542, 0.8128744953987701856100790,
3871 0.8146566981990144342734272, 0.8164312406228120465742028,
3872 0.8181981059837931485700490, 0.8199572776677767911993239,
3873 0.8217087391329271766780945, 0.8234524739099092046215225,
3874 0.8251884656020433364270094, 0.8269166978854597764628854,
3875 0.8286371545092519686128428, 0.8303498192956294067327593,
3876 0.8320546761400697575830038, 0.8337517090114702948057846,
3877 0.8354409019522986425235764, 0.8371222390787428271411563,
3878 0.8387957045808606359402829, 0.8404612827227282810625704,
3879 0.8421189578425883674826439, 0.8437687143529971635802028,
3880 0.8454105367409711729261812, 0.8470444095681330059047621,
3881 0.8486703174708565497995875, 0.8502882451604114359791023,
3882 0.8518981774231068028225812, 0.8535000991204343530350070,
3883 0.8550939951892107040056078, 0.8566798506417190298715048,
3884 0.8582576505658499939545848, 0.8598273801252419702463831,
3885 0.8613890245594205526224495, 0.8629425691839373504743648,
3886 0.8644879993905080694542896, 0.8660253006471498760336444,
3887 0.8675544584983180445842596, 0.8690754585650418856970762,
3888 0.8705882865450599544602407, 0.8720929282129545374252050,
3889 0.8735893694202854169962281, 0.8750775960957229119854680,
3890 0.8765575942451801930826613, 0.8780293499519448719952049,
3891 0.8794928493768098630212838, 0.8809480787582035158255322,
3892 0.8823950244123190181935674, 0.8838336727332430675485994,
3893 0.8852640101930838100201983, 0.8866860233420980458621863,
3894 0.8880996988088177000235219, 0.8895050233001755566829532,
3895 0.8909019836016302565651375, 0.8922905665772905558628607,
3896 0.8936707591700388455969280, 0.8950425484016539302522575,
3897 0.8964059213729330645356690, 0.8977608652638132471078410,
3898 0.8991073673334917701488930, 0.9004454149205460236240486,
3899 0.9017749954430525531228459, 0.9030960963987053701523781,
3900 0.9044087053649335137720782, 0.9057128099990178624646022,
3901 0.9070083980382071951444166, 0.9082954572998335002127549,
3902 0.9095739756814265315746820, 0.9108439411608276105410847,
3903 0.9121053417963026725455006, 0.9133581657266545576127977,
3904 0.9146024011713345435238301, 0.9158380364305531206273175,
3905 0.9170650598853900072573273, 0.9182834599979034047218800,
3906 0.9194932253112384908353520, 0.9206943444497351509745089,
3907 0.9218868061190349456451742, 0.9230705991061873135537215,
3908 0.9242457122797550091847637, 0.9254121345899187738936182,
3909 0.9265698550685812395293315, 0.9277188628294700636112689,
3910 0.9288591470682402950895005, 0.9299906970625759697264543,
3911 0.9311135021722909341445515, 0.9322275518394288975917975,
3912 0.9333328355883627104845635, 0.9344293430258928687940732,
3913 0.9355170638413452433503852, 0.9365959878066680331449597,
3914 0.9376661047765279417201973, 0.9387274046884055757416456,
3915 0.9397798775626900648558921, 0.9408235135027729019444869,
3916 0.9418583026951410028915762, 0.9428842354094689849902736,
3917 0.9439013019987106631201510, 0.9449094928991897628355911,
3918 0.9459087986306898495121205, 0.9468992097965434727052183,
3919 0.9478807170837205248834878, 0.9488533112629158137054760,
3920 0.9498169831886358470168335, 0.9507717237992848297519245,
3921 0.9517175241172498719314184, 0.9526543752489854069548347,
3922 0.9535822683850968193944507, 0.9545011948004232815044368,
3923 0.9554111458541197976665483, 0.9563121129897384560011695,
3924 0.9572040877353088863799924, 0.9580870617034179240840996,
3925 0.9589610265912884783587268, 0.9598259741808576051234879,
3926 0.9606818963388537831043733, 0.9615287850168733926613630,
3927 0.9623666322514563965930439, 0.9631954301641612222071790,
3928 0.9640151709616388439537466, 0.9648258469357060659245549,
3929 0.9656274504634180035311332, 0.9664199740071397636802195,
3930 0.9672034101146173227737943, 0.9679777514190476018682591,
3931 0.9687429906391477383350273, 0.9694991205792235533724866,
3932 0.9702461341292372147270016, 0.9709840242648740939883669,
3933 0.9717127840476088178328839, 0.9724324066247705125950353,
3934 0.9731428852296072415565604, 0.9738442131813496343496072,
3935 0.9745363838852737078785517, 0.9752193908327628781730396,
3936 0.9758932276013691625928266, 0.9765578878548735718130775,
3937 0.9772133653433456910269459, 0.9778596539032024498104955,
3938 0.9784967474572660801033674, 0.9791246400148212617670490,
3939 0.9797433256716714551911835, 0.9803527986101944204270933,
3940 0.9809530530993969223366037, 0.9815440834949686212533729,
3941 0.9821258842393351486632952, 0.9826984498617103674201996,
3942 0.9832617749781478160230522, 0.9838158542915913364912672,
3943 0.9843606825919248853856025, 0.9848962547560215275335618,
3944 0.9854225657477916120303537, 0.9859396106182301300994116,
3945 0.9864473845054632544104222, 0.9869458826347940594679517,
3946 0.9874351003187474227003598, 0.9879150329571141058970610,
3947 0.9883856760369940166627304, 0.9888470251328386495802522,
3948 0.9892990759064927068006818, 0.9897418241072348978090276,
3949 0.9901752655718179181502248, 0.9905993962245076069415402,
3950 0.9910142120771212830473891, 0.9914197092290652598522332,
3951 0.9918158838673715386394944, 0.9922027322667336806727008,
3952 0.9925802507895418581838653, 0.9929484358859170846092543,
3953 0.9933072840937446245820355, 0.9936567920387065844051246,
3954 0.9939969564343136839997662, 0.9943277740819362116746914,
3955 0.9946492418708341635125525, 0.9949613567781865697596566,
3956 0.9952641158691200113800912, 0.9955575162967363309635588,
3957 0.9958415553021395435525955, 0.9961162302144619548145649,
3958 0.9963815384508894965215124, 0.9966374775166862927999356,
3959 0.9968840450052184754903082, 0.9971212385979772738362093,
3960 0.9973490560646014135491635, 0.9975674952628988745188845,
3961 0.9977765541388680773265018, 0.9979762307267185998745420,
3962 0.9981665231488915727109186, 0.9983474296160799746514418,
3963 0.9985189484272491654281575, 0.9986810779696581776171579,
3964 0.9988338167188825964389443, 0.9989771632388403756649803,
3965 0.9991111161818228462260355, 0.9992356742885348165163858,
3966 0.9993508363881507486653971, 0.9994566013984000492749057,
3967 0.9995529683257070064969677, 0.9996399362654382464576482,
3968 0.9997175044023747284307007, 0.9997856720116889628341744,
3969 0.9998444384611711916084367, 0.9998938032169419878731474,
3970 0.9999337658606177711221103, 0.9999643261538894550943330,
3971 0.9999854843850284447675914, 0.9999972450545584403516182 };
3972 static const double w1024[] = { 0.0030664603092439082115513, 0.0030664314747171934849726,
3973 0.0030663738059349007324470, 0.0030662873034393008056861,
3974 0.0030661719680437936084028, 0.0030660278008329004477528,
3975 0.0030658548031622538363679, 0.0030656529766585847450783,
3976 0.0030654223232197073064431, 0.0030651628450145009692318,
3977 0.0030648745444828901040266, 0.0030645574243358210601357,
3978 0.0030642114875552366740338, 0.0030638367373940482295700,
3979 0.0030634331773761048702058, 0.0030630008112961604635720,
3980 0.0030625396432198379186545, 0.0030620496774835909559465,
3981 0.0030615309186946633309249, 0.0030609833717310455112352,
3982 0.0030604070417414288079918, 0.0030598019341451569616257,
3983 0.0030591680546321751827342, 0.0030585054091629766484119,
3984 0.0030578140039685464545661, 0.0030570938455503030247440,
3985 0.0030563449406800369760227, 0.0030555672963998474425352,
3986 0.0030547609200220758572342, 0.0030539258191292371925135,
3987 0.0030530620015739486603347, 0.0030521694754788558725307,
3988 0.0030512482492365564619779, 0.0030502983315095211653578,
3989 0.0030493197312300123682482, 0.0030483124576000001133114,
3990 0.0030472765200910755723677, 0.0030462119284443619831693,
3991 0.0030451186926704230517109, 0.0030439968230491688209395,
3992 0.0030428463301297590067471, 0.0030416672247305038021562,
3993 0.0030404595179387621506312, 0.0030392232211108374894710,
3994 0.0030379583458718709642643, 0.0030366649041157321154111,
3995 0.0030353429080049070377385, 0.0030339923699703840142628,
3996 0.0030326133027115366251721, 0.0030312057191960043331307,
3997 0.0030297696326595705460252, 0.0030283050566060381583022,
3998 0.0030268120048071025720655, 0.0030252904913022221991274,
3999 0.0030237405303984864452325, 0.0030221621366704811776946,
4000 0.0030205553249601516777118, 0.0030189201103766630786495,
4001 0.0030172565082962582916016, 0.0030155645343621134195681,
4002 0.0030138442044841906616068, 0.0030120955348390887083441,
4003 0.0030103185418698906302495, 0.0030085132422860092601062,
4004 0.0030066796530630300711306, 0.0030048177914425515522176,
4005 0.0030029276749320230818149, 0.0030010093213045803019478,
4006 0.0029990627485988779939449, 0.0029970879751189204574353,
4007 0.0029950850194338893942123, 0.0029930539003779692985814,
4008 0.0029909946370501703558363, 0.0029889072488141488505262,
4009 0.0029867917552980250862041, 0.0029846481763941988183689,
4010 0.0029824765322591622023349, 0.0029802768433133102577897,
4011 0.0029780491302407488518214, 0.0029757934139891002022209,
4012 0.0029735097157693059028890, 0.0029711980570554274731990,
4013 0.0029688584595844444331918, 0.0029664909453560499065010,
4014 0.0029640955366324437529314, 0.0029616722559381232326340,
4015 0.0029592211260596712038487, 0.0029567421700455418562030,
4016 0.0029542354112058439815854, 0.0029517008731121217846274,
4017 0.0029491385795971332348581, 0.0029465485547546259626151,
4018 0.0029439308229391107008170, 0.0029412854087656322747309,
4019 0.0029386123371095381418860, 0.0029359116331062444843108,
4020 0.0029331833221509998552933, 0.0029304274298986463828860,
4021 0.0029276439822633785324025, 0.0029248330054184994301727,
4022 0.0029219945257961747508486, 0.0029191285700871841705750,
4023 0.0029162351652406703883623, 0.0029133143384638857180205,
4024 0.0029103661172219362530391, 0.0029073905292375236068160,
4025 0.0029043876024906842306667, 0.0029013573652185263120627,
4026 0.0028982998459149642555740, 0.0028952150733304507490135,
4027 0.0028921030764717064173001, 0.0028889638846014470665859,
4028 0.0028857975272381085212091, 0.0028826040341555690560623,
4029 0.0028793834353828694269858, 0.0028761357612039305018167,
4030 0.0028728610421572684947521, 0.0028695593090357078067012,
4031 0.0028662305928860914743281, 0.0028628749250089892305081,
4032 0.0028594923369584031789413, 0.0028560828605414710856927,
4033 0.0028526465278181672904478, 0.0028491833711010012402964,
4034 0.0028456934229547136488796, 0.0028421767161959702837564,
4035 0.0028386332838930533848701, 0.0028350631593655507170153,
4036 0.0028314663761840422592303, 0.0028278429681697845340603,
4037 0.0028241929693943925796601, 0.0028205164141795195677262,
4038 0.0028168133370965340702726, 0.0028130837729661949782821,
4039 0.0028093277568583240752928, 0.0028055453240914762689974,
4040 0.0028017365102326074839556, 0.0027979013510967402185435,
4041 0.0027940398827466267692845, 0.0027901521414924101257281,
4042 0.0027862381638912825390663, 0.0027822979867471417676962,
4043 0.0027783316471102450029635, 0.0027743391822768604783394,
4044 0.0027703206297889167653083, 0.0027662760274336497592617,
4045 0.0027622054132432473587211, 0.0027581088254944918412282,
4046 0.0027539863027083999392661, 0.0027498378836498606195970,
4047 0.0027456636073272705694208, 0.0027414635129921673927833,
4048 0.0027372376401388605206822, 0.0027329860285040598383428,
4049 0.0027287087180665020331547, 0.0027244057490465746667821,
4050 0.0027200771619059379749851, 0.0027157229973471443987056,
4051 0.0027113432963132558499974, 0.0027069380999874587163979,
4052 0.0027025074497926766073634, 0.0026980513873911808464073,
4053 0.0026935699546841987126055, 0.0026890631938115194351518,
4054 0.0026845311471510979446691, 0.0026799738573186563850015,
4055 0.0026753913671672833892344, 0.0026707837197870311237119,
4056 0.0026661509585045101038391, 0.0026614931268824817854798,
4057 0.0026568102687194489357814, 0.0026521024280492437872770,
4058 0.0026473696491406139791397, 0.0026426119764968062894804,
4059 0.0026378294548551481626046, 0.0026330221291866270351630,
4060 0.0026281900446954674651512, 0.0026233332468187060677353,
4061 0.0026184517812257642618999, 0.0026135456938180188319369,
4062 0.0026086150307283703078113, 0.0026036598383208091684657,
4063 0.0025986801631899798721388, 0.0025936760521607427178014,
4064 0.0025886475522877335418257, 0.0025835947108549212540321,
4065 0.0025785175753751632172710, 0.0025734161935897584747222,
4066 0.0025682906134679988291122, 0.0025631408832067177780710,
4067 0.0025579670512298373098703, 0.0025527691661879125638030,
4068 0.0025475472769576743594882, 0.0025423014326415695994010,
4069 0.0025370316825672995489502, 0.0025317380762873559984451,
4070 0.0025264206635785553113127, 0.0025210794944415703629476,
4071 0.0025157146191004603745948, 0.0025103260880021986466869,
4072 0.0025049139518161981960773, 0.0024994782614338353016280,
4073 0.0024940190679679709626349, 0.0024885364227524702745874,
4074 0.0024830303773417197267843, 0.0024775009835101424263432,
4075 0.0024719482932517112531633, 0.0024663723587794599504176,
4076 0.0024607732325249921551741, 0.0024551509671379883737605,
4077 0.0024495056154857109065099, 0.0024438372306525067265426,
4078 0.0024381458659393083172574, 0.0024324315748631324732279,
4079 0.0024266944111565770692147, 0.0024209344287673158020275,
4080 0.0024151516818575909099866, 0.0024093462248037038747545,
4081 0.0024035181121955041103265, 0.0023976673988358756439882,
4082 0.0023917941397402217940673, 0.0023858983901359478493246,
4083 0.0023799802054619417548485, 0.0023740396413680528093376,
4084 0.0023680767537145683786720, 0.0023620915985716886306938,
4085 0.0023560842322189992961374, 0.0023500547111449424606655,
4086 0.0023440030920462853929883, 0.0023379294318275874140606,
4087 0.0023318337876006648123684, 0.0023257162166840538103394,
4088 0.0023195767766024715869239, 0.0023134155250862753614165,
4089 0.0023072325200709195436049, 0.0023010278196964109553481,
4090 0.0022948014823067621287099, 0.0022885535664494426857857,
4091 0.0022822841308748288053830, 0.0022759932345356507817318,
4092 0.0022696809365864386804193, 0.0022633472963829660967620,
4093 0.0022569923734816920218464, 0.0022506162276392008214839,
4094 0.0022442189188116403333494, 0.0022378005071541580875846,
4095 0.0022313610530203356561684, 0.0022249006169616211363732,
4096 0.0022184192597267597736437, 0.0022119170422612227292520,
4097 0.0022053940257066339981005, 0.0021988502714001954820607,
4098 0.0021922858408741102242558, 0.0021857007958550038097087,
4099 0.0021790951982633439377969, 0.0021724691102128581719720,
4100 0.0021658225940099498722195, 0.0021591557121531123157498,
4101 0.0021524685273323410114303, 0.0021457611024285442134846,
4102 0.0021390335005129516400021, 0.0021322857848465214018174,
4103 0.0021255180188793451473363, 0.0021187302662500514289029,
4104 0.0021119225907852072963166, 0.0021050950564987181231273,
4105 0.0020982477275912256713511, 0.0020913806684495044002679,
4106 0.0020844939436458560249764, 0.0020775876179375023304007,
4107 0.0020706617562659762464561, 0.0020637164237565111901030,
4108 0.0020567516857174286800274, 0.0020497676076395242297101,
4109 0.0020427642551954515246552, 0.0020357416942391048895728,
4110 0.0020286999908050000513193, 0.0020216392111076532034194,
4111 0.0020145594215409583780096, 0.0020074606886775631310555,
4112 0.0020003430792682425467160, 0.0019932066602412715667394,
4113 0.0019860514987017956507927, 0.0019788776619311997736447,
4114 0.0019716852173864757651327, 0.0019644742326995879988655,
4115 0.0019572447756768374356240, 0.0019499969142982240274419,
4116 0.0019427307167168074883601, 0.0019354462512580664378677,
4117 0.0019281435864192559230531, 0.0019208227908687633255086,
4118 0.0019134839334454626590447, 0.0019061270831580672642844,
4119 0.0018987523091844809062265, 0.0018913596808711472808775,
4120 0.0018839492677323979370705, 0.0018765211394497986196010,
4121 0.0018690753658714940398285, 0.0018616120170115510799024,
4122 0.0018541311630493004367905, 0.0018466328743286767122991,
4123 0.0018391172213575569552912, 0.0018315842748070976623218,
4124 0.0018240341055110702429247, 0.0018164667844651949558009,
4125 0.0018088823828264733221690, 0.0018012809719125190225581,
4126 0.0017936626232008872833327, 0.0017860274083284027592567,
4127 0.0017783753990904859184165, 0.0017707066674404779358362,
4128 0.0017630212854889641021349, 0.0017553193255030957535871,
4129 0.0017476008599059107299616, 0.0017398659612756523665312,
4130 0.0017321147023450870266539, 0.0017243471560008201813452,
4131 0.0017165633952826110422716, 0.0017087634933826857546100,
4132 0.0017009475236450491562317, 0.0016931155595647951096823,
4133 0.0016852676747874154134422, 0.0016774039431081072989678,
4134 0.0016695244384710795200224, 0.0016616292349688570408253,
4135 0.0016537184068415843295541, 0.0016457920284763272637533,
4136 0.0016378501744063736542136, 0.0016298929193105323938983,
4137 0.0016219203380124312385075, 0.0016139325054798132252838,
4138 0.0016059294968238317366751, 0.0015979113872983442154825,
4139 0.0015898782522992045381361, 0.0015818301673635540527516,
4140 0.0015737672081691112886347, 0.0015656894505334603439125,
4141 0.0015575969704133379579831, 0.0015494898439039192754876,
4142 0.0015413681472381023085203, 0.0015332319567857911038062,
4143 0.0015250813490531776215856, 0.0015169164006820223329593,
4144 0.0015087371884489335424584, 0.0015005437892646454426166,
4145 0.0014923362801732949073323, 0.0014841147383516970308228,
4146 0.0014758792411086194189814, 0.0014676298658840552399621,
4147 0.0014593666902484950408286, 0.0014510897919021973371136,
4148 0.0014427992486744579821480, 0.0014344951385228783230315,
4149 0.0014261775395326321501237, 0.0014178465299157314469528,
4150 0.0014095021880102909474427, 0.0014011445922797915073771,
4151 0.0013927738213123422970256, 0.0013843899538199418218713,
4152 0.0013759930686377377783877, 0.0013675832447232857518263,
4153 0.0013591605611558067629844, 0.0013507250971354436709363,
4154 0.0013422769319825164387192, 0.0013338161451367762689788,
4155 0.0013253428161566586165863, 0.0013168570247185350852537,
4156 0.0013083588506159642151809, 0.0012998483737589411687807,
4157 0.0012913256741731463215379, 0.0012827908319991927650686,
4158 0.0012742439274918727294554, 0.0012656850410194029319476,
4159 0.0012571142530626688591208, 0.0012485316442144679896043,
4160 0.0012399372951787519644928, 0.0012313312867698677125706,
4161 0.0012227136999117975374834, 0.0012140846156373981740056,
4162 0.0012054441150876388205601, 0.0011967922795108381551550,
4163 0.0011881291902619003419159, 0.0011794549288015500353964,
4164 0.0011707695766955663898644, 0.0011620732156140160807669,
4165 0.0011533659273304853455891, 0.0011446477937213110513287,
4166 0.0011359188967648107958214, 0.0011271793185405120501566,
4167 0.0011184291412283803494364, 0.0011096684471080465391373,
4168 0.0011008973185580330843445, 0.0010921158380549794491381,
4169 0.0010833240881728665534171, 0.0010745221515822403144596,
4170 0.0010657101110494342805238, 0.0010568880494357913638046,
4171 0.0010480560496968846800697, 0.0010392141948817375023057,
4172 0.0010303625681320423357186, 0.0010215012526813791214350,
4173 0.0010126303318544325762649, 0.0010037498890662086758941,
4174 0.0009948600078212502888805, 0.0009859607717128519688418,
4175 0.0009770522644222739122264, 0.0009681345697179550890732,
4176 0.0009592077714547255541688, 0.0009502719535730179460261,
4177 0.0009413272000980781811114, 0.0009323735951391753507612,
4178 0.0009234112228888108282347, 0.0009144401676219265933610,
4179 0.0009054605136951127822476, 0.0008964723455458144695262,
4180 0.0008874757476915376906225, 0.0008784708047290547115472,
4181 0.0008694576013336085537138, 0.0008604362222581167813022,
4182 0.0008514067523323745586954, 0.0008423692764622569855308,
4183 0.0008333238796289207169173, 0.0008242706468880048763834,
4184 0.0008152096633688312691343, 0.0008061410142736039032099,
4185 0.0007970647848766078261514, 0.0007879810605234072847989,
4186 0.0007788899266300432158601, 0.0007697914686822300749096,
4187 0.0007606857722345520114971, 0.0007515729229096583980656,
4188 0.0007424530063974587204051, 0.0007333261084543168373926,
4189 0.0007241923149022446178008, 0.0007150517116280949619884,
4190 0.0007059043845827542163241, 0.0006967504197803339882351,
4191 0.0006875899032973623698204, 0.0006784229212719745780188,
4192 0.0006692495599031030193850, 0.0006600699054496667875923,
4193 0.0006508840442297606018626, 0.0006416920626198431946113,
4194 0.0006324940470539251567018, 0.0006232900840227562488244,
4195 0.0006140802600730121876541, 0.0006048646618064809156059,
4196 0.0005956433758792483631993, 0.0005864164890008837132649,
4197 0.0005771840879336241764943, 0.0005679462594915592881427,
4198 0.0005587030905398147360662, 0.0005494546679937357307118,
4199 0.0005402010788180699282026, 0.0005309424100261499182844,
4200 0.0005216787486790752896494, 0.0005124101818848942860548,
4201 0.0005031367967977850677401, 0.0004938586806172365939677,
4202 0.0004845759205872291441124, 0.0004752886039954144966810,
4203 0.0004659968181722957880391, 0.0004567006504904070755681,
4204 0.0004474001883634926336095, 0.0004380955192456860150653,
4205 0.0004287867306306889171352, 0.0004194739100509498966958,
4206 0.0004101571450768429896514, 0.0004008365233158462997325,
4207 0.0003915121324117206363681, 0.0003821840600436882993131,
4208 0.0003728523939256121308821, 0.0003635172218051749865499,
4209 0.0003541786314630598135175, 0.0003448367107121305776064,
4210 0.0003354915473966143456333, 0.0003261432293912849189248,
4211 0.0003167918446006485317858, 0.0003074374809581322877037,
4212 0.0002980802264252762217455, 0.0002887201689909301727620,
4213 0.0002793573966704570567274, 0.0002699919975049447012834,
4214 0.0002606240595604292032823, 0.0002512536709271339139118,
4215 0.0002418809197187298044384, 0.0002325058940716253739001,
4216 0.0002231286821442978268308, 0.0002137493721166826096154,
4217 0.0002043680521896465790359, 0.0001949848105845827899210,
4218 0.0001855997355431850062940, 0.0001762129153274925249194,
4219 0.0001668244382203495280013, 0.0001574343925265138930609,
4220 0.0001480428665748079976500, 0.0001386499487219861751244,
4221 0.0001292557273595155266326, 0.0001198602909254695827354,
4222 0.0001104637279257437565603, 0.0001010661269730276014588,
4223 0.0000916675768613669107254, 0.0000822681667164572752810,
4224 0.0000728679863190274661367, 0.0000634671268598044229933,
4225 0.0000540656828939400071988, 0.0000446637581285753393838,
4226 0.0000352614859871986975067, 0.0000258591246764618586716,
4227 0.0000164577275798968681068, 0.0000070700764101825898713 };
4228
4229 switch (npoints) {
4230 case (4):
4231 *x = x4; *w = w4; break;
4232 case (8):
4233 *x = x8; *w = w8; break;
4234 case (16):
4235 *x = x16; *w = w16; break;
4236 case (32):
4237 *x = x32; *w = w32; break;
4238 case (64):
4239 *x = x64; *w = w64; break;
4240 case (128):
4241 *x = x128; *w = w128; break;
4242 case (256):
4243 *x = x256; *w = w256; break;
4244 case (512):
4245 *x = x512; *w = w512; break;
4246 case (1024):
4247 *x = x1024; *w = w1024; break;
4248 default:
4249 error2("use 4, 8, 16, 32, 64, 128, 512, 1024 for npoints for legendre.");
4250 }
4251 return(status);
4252 }
4253
4254
4255
NIntegrateGaussLegendre(double (* fun)(double x),double a,double b,int npoints)4256 double NIntegrateGaussLegendre(double(*fun)(double x), double a, double b, int npoints)
4257 {
4258 /* this approximates the integral Nintegrate[fun[x], {x,a,b}].
4259 npoints is 10, 20, 32 or 64 nodes for legendre.");
4260 */
4261 int j, ixw, sign;
4262 const double *x = NULL, *w = NULL;
4263 double s = 0, t;
4264
4265 if (npoints % 2 != 0)
4266 error2("this assumes even number of points.");
4267 GaussLegendreRule(&x, &w, npoints);
4268
4269 /* x changes monotonically from a to b. */
4270 for (j = 0; j < npoints; j++) {
4271 if (j < npoints / 2) { ixw = npoints / 2 - 1 - j; sign = -1; }
4272 else { ixw = j - npoints / 2; sign = 1; }
4273 t = (a + b) / 2 + sign*(b - a) / 2 * x[ixw];
4274 s += w[ixw] * fun(t);
4275 }
4276 return s *= (b - a) / 2;
4277 }
4278
4279
GaussLaguerreRule(const double ** x,const double ** w,int npoints)4280 int GaussLaguerreRule(const double **x, const double **w, int npoints)
4281 {
4282 /* this returns the Gauss-Laguerre nodes and weights in x[] and w[].
4283 npoints = 5, 10, 20.
4284 */
4285 int status = 0;
4286 static const double x5[] = { 0.263560319718140910203061943361E+00,
4287 0.141340305910651679221840798019E+01,
4288 0.359642577104072208122318658878E+01,
4289 0.708581000585883755692212418111E+01,
4290 0.126408008442757826594332193066E+02 };
4291 static const double w5[] = { 0.521755610582808652475860928792E+00,
4292 0.398666811083175927454133348144E+00,
4293 0.759424496817075953876533114055E-01,
4294 0.361175867992204845446126257304E-02,
4295 0.233699723857762278911490845516E-04 };
4296
4297 static const double x10[] = { 0.137793470540492430830772505653E+00,
4298 0.729454549503170498160373121676E+00,
4299 0.180834290174031604823292007575E+01,
4300 0.340143369785489951448253222141E+01,
4301 0.555249614006380363241755848687E+01,
4302 0.833015274676449670023876719727E+01,
4303 0.118437858379000655649185389191E+02,
4304 0.162792578313781020995326539358E+02,
4305 0.219965858119807619512770901956E+02,
4306 0.299206970122738915599087933408E+02 };
4307 static const double w10[] = { 0.308441115765020141547470834678E+00,
4308 0.401119929155273551515780309913E+00,
4309 0.218068287611809421588648523475E+00,
4310 0.620874560986777473929021293135E-01,
4311 0.950151697518110055383907219417E-02,
4312 0.753008388587538775455964353676E-03,
4313 0.282592334959956556742256382685E-04,
4314 0.424931398496268637258657665975E-06,
4315 0.183956482397963078092153522436E-08,
4316 0.991182721960900855837754728324E-12 };
4317
4318 static const double x20[] = { 0.705398896919887533666890045842E-01,
4319 0.372126818001611443794241388761E+00,
4320 0.916582102483273564667716277074E+00,
4321 0.170730653102834388068768966741E+01,
4322 0.274919925530943212964503046049E+01,
4323 0.404892531385088692237495336913E+01,
4324 0.561517497086161651410453988565E+01,
4325 0.745901745367106330976886021837E+01,
4326 0.959439286958109677247367273428E+01,
4327 0.120388025469643163096234092989E+02,
4328 0.148142934426307399785126797100E+02,
4329 0.179488955205193760173657909926E+02,
4330 0.214787882402850109757351703696E+02,
4331 0.254517027931869055035186774846E+02,
4332 0.299325546317006120067136561352E+02,
4333 0.350134342404790000062849359067E+02,
4334 0.408330570567285710620295677078E+02,
4335 0.476199940473465021399416271529E+02,
4336 0.558107957500638988907507734445E+02,
4337 0.665244165256157538186403187915E+02 };
4338 static const double w20[] = { 0.168746801851113862149223899689E+00,
4339 0.291254362006068281716795323812E+00,
4340 0.266686102867001288549520868998E+00,
4341 0.166002453269506840031469127816E+00,
4342 0.748260646687923705400624639615E-01,
4343 0.249644173092832210728227383234E-01,
4344 0.620255084457223684744754785395E-02,
4345 0.114496238647690824203955356969E-02,
4346 0.155741773027811974779809513214E-03,
4347 0.154014408652249156893806714048E-04,
4348 0.108648636651798235147970004439E-05,
4349 0.533012090955671475092780244305E-07,
4350 0.175798117905058200357787637840E-08,
4351 0.372550240251232087262924585338E-10,
4352 0.476752925157819052449488071613E-12,
4353 0.337284424336243841236506064991E-14,
4354 0.115501433950039883096396247181E-16,
4355 0.153952214058234355346383319667E-19,
4356 0.528644272556915782880273587683E-23,
4357 0.165645661249902329590781908529E-27 };
4358 if (npoints == 5)
4359 {
4360 *x = x5; *w = w5;
4361 }
4362 else if (npoints == 10)
4363 {
4364 *x = x10; *w = w10;
4365 }
4366 else if (npoints == 20)
4367 {
4368 *x = x20; *w = w20;
4369 }
4370 else {
4371 puts("use 5, 10, 20 nodes for GaussLaguerreRule.");
4372 status = -1;
4373 }
4374 return(status);
4375 }
4376
ScatterPlot(int n,int nseries,int yLorR[],double x[],double y[],int nrow,int ncol,int ForE)4377 int ScatterPlot(int n, int nseries, int yLorR[], double x[], double y[],
4378 int nrow, int ncol, int ForE)
4379 {
4380 /* This plots a scatter diagram. There are nseries of data (y)
4381 for the same x. nrow and ncol specifies the #s of rows and cols
4382 in the text output.
4383 Use ForE=1 for floating format
4384 yLorR[nseries] specifies which y axis (L or R) to use, if nseries>1.
4385 */
4386 char *chart, ch, *fmt[2] = { "%*.*e ", "%*.*f " }, symbol[] = "*~^@", overlap = '&';
4387 int i, j, is, iy, ny = 1, ncolr = ncol + 3, irow = 0, icol = 0, w = 10, wd = 2;
4388 double large = 1e32, xmin, xmax, xgap, ymin[2], ymax[2], ygap[2];
4389
4390 for (i = 1, xmin = xmax = x[0]; i < n; i++)
4391 {
4392 if (xmin > x[i]) xmin = x[i]; if (xmax < x[i]) xmax = x[i];
4393 }
4394 for (i = 0; i < 2; i++) { ymin[i] = large; ymax[i] = -large; }
4395 for (j = 0; j < (nseries > 1)*nseries; j++)
4396 if (yLorR[j] == 1) ny = 2;
4397 else if (yLorR[j] != 0) printf("err: y axis %d", yLorR[j]);
4398 for (j = 0; j < nseries; j++) {
4399 for (i = 0, iy = (nseries == 1 ? 0 : yLorR[j]); i < n; i++) {
4400 if (ymin[iy] > y[j*n + i]) ymin[iy] = y[j*n + i];
4401 if (ymax[iy] < y[j*n + i]) ymax[iy] = y[j*n + i];
4402 }
4403 }
4404 if (xmin == xmax) { puts("no variation in x?"); }
4405 xgap = (xmax - xmin) / ncol;
4406 for (iy = 0; iy < ny; iy++) ygap[iy] = (ymax[iy] - ymin[iy]) / nrow;
4407
4408 printf("\n%10s", "legend: ");
4409 for (is = 0; is < nseries; is++) printf("%2c", symbol[is]);
4410 printf("\n%10s", "y axies: ");
4411 if (ny == 2) for (is = 0; is < nseries; is++) printf("%2d", yLorR[is]);
4412
4413 printf("\nx : (%10.2e, %10.2e)", xmin, xmax);
4414 printf("\ny[1]: (%10.2e, %10.2e)\n", ymin[0], ymax[0]);
4415 if (ny == 2) printf("y[2]: (%10.2e, %10.2e) \n", ymin[1], ymax[1]);
4416
4417 chart = (char*)malloc((nrow + 1)*ncolr * sizeof(char));
4418 for (i = 0; i < nrow + 1; i++) {
4419 for (j = 1; j < ncol; j++) chart[i*ncolr + j] = ' ';
4420 if (i % 5 == 0) chart[i*ncolr + 0] = chart[i*ncolr + j++] = '+';
4421 else chart[i*ncolr + 0] = chart[i*ncolr + j++] = '|';
4422 chart[i*ncolr + j] = '\0';
4423 if (i == 0 || i == nrow)
4424 FOR(j, ncol + 1) chart[i*ncolr + j] = (char)(j % 10 == 0 ? '+' : '-');
4425 }
4426
4427 for (is = 0; is < nseries; is++) {
4428 for (i = 0, iy = (nseries == 1 ? 0 : yLorR[is]); i < n; i++) {
4429 for (j = 0; j < ncol + 1; j++) if (x[i] <= xmin + (j + 0.5)*xgap) { icol = j; break; }
4430 for (j = 0; j < nrow + 1; j++)
4431 if (y[is*n + i] <= ymin[iy] + (j + 0.5)*ygap[iy]) { irow = nrow - j; break; }
4432
4433 /*
4434 chart[irow*ncolr+icol]=symbol[is];
4435 */
4436 if ((ch = chart[irow*ncolr + icol]) == ' ' || ch == '-' || ch == '+')
4437 chart[irow*ncolr + icol] = symbol[is];
4438 else
4439 chart[irow*ncolr + icol] = overlap;
4440
4441 }
4442 }
4443 printf("\n");
4444 for (i = 0; i < nrow + 1; i++) {
4445 if (i % 5 == 0) printf(fmt[ForE], w - 1, wd, ymin[0] + (nrow - i)*ygap[0]);
4446 else printf("%*s", w, "");
4447 printf("%s", chart + i*ncolr);
4448 if (ny == 2 && i % 5 == 0) printf(fmt[ForE], w - 1, wd, ymin[1] + (nrow - i)*ygap[1]);
4449 printf("\n");
4450 }
4451 printf("%*s", w - 6, "");
4452 for (j = 0; j < ncol + 1; j++) if (j % 10 == 0) printf(fmt[ForE], 10 - 1, wd, xmin + j*xgap);
4453 printf("\n%*s\n", ncol / 2 + 1 + w, "x");
4454 free(chart);
4455 return(0);
4456 }
4457
rainbowRGB(double temperature,int * R,int * G,int * B)4458 void rainbowRGB(double temperature, int *R, int *G, int *B)
4459 {
4460 /* This returns the RGB values, each between 0 and 255, for given temperature
4461 value in the range (0, 1) in the rainbow.
4462 Curve fitting from the following data:
4463
4464 T R G B
4465 0 14 1 22
4466 0.1 56 25 57
4467 0.2 82 82 130
4468 0.3 93 120 60
4469 0.4 82 155 137
4470 0.5 68 185 156
4471 0.6 114 207 114
4472 0.7 223 228 70
4473 0.8 243 216 88
4474 0.9 251 47 37
4475 1 177 8 0
4476
4477 */
4478 double T = temperature, maxT = 1;
4479
4480 if (T > maxT) error2("temperature rescaling needed.");
4481 *R = (int)fabs(-5157.3*T*T*T*T + 9681.4*T*T*T - 5491.9*T*T + 1137.7*T + 6.2168);
4482 *G = (int)fabs(-1181.4*T*T*T + 964.8*T*T + 203.66*T + 1.2028);
4483 *B = (int)fabs(92.463*T*T*T - 595.92*T*T + 481.11*T + 21.769);
4484
4485 if (*R > 255) *R = 255;
4486 if (*G > 255) *G = 255;
4487 if (*B > 255) *B = 255;
4488 }
4489
4490
GetIndexTernary(int * ix,int * iy,double * x,double * y,int itriangle,int K)4491 void GetIndexTernary(int *ix, int *iy, double *x, double *y, int itriangle, int K)
4492 {
4493 /* This gives the indices (ix, iy) and the coordinates (x, y, 1-x-y) for
4494 the itriangle-th triangle, with itriangle from 0, 1, ..., KK-1.
4495 The ternary graph (0-1 on each axis) is partitioned into K*K equal-sized
4496 triangles.
4497 In the first row (ix=0), there is one triangle (iy=0);
4498 In the second row (ix=1), there are 3 triangles (iy=0,1,2);
4499 In the i-th row (ix=i), there are 2*i+1 triangles (iy=0,1,...,2*i).
4500
4501 x rises when ix goes up, but y decreases when iy increases. (x,y) is the
4502 centroid in the ij-th small triangle.
4503
4504 x and y each takes on 2*K-1 possible values.
4505 */
4506 *ix = (int)sqrt((double)itriangle);
4507 *iy = itriangle - square(*ix);
4508
4509 *x = (1 + (*iy / 2) * 3 + (*iy % 2)) / (3.*K);
4510 *y = (1 + (K - 1 - *ix) * 3 + (*iy % 2)) / (3.*K);
4511 }
4512
4513
4514
factorial(int n)4515 double factorial(int n)
4516 {
4517 double fact = 1, i;
4518 if (n > 100) printf("factorial(%d) may be too large\n", n);
4519 for (i = 2; i <= n; i++) fact *= i;
4520 return (fact);
4521 }
4522
4523
Binomial(double n,int k,double * scale)4524 double Binomial(double n, int k, double *scale)
4525 {
4526 /* calculates (n choose k), where n is any real number, and k is integer.
4527 If(*scale!=0) the result should be c+exp(*scale).
4528 */
4529 double c = 1, i, large = 1e200;
4530
4531 *scale = 0;
4532 if ((int)k != k)
4533 error2("k is not a whole number in Binomial.");
4534 if (k == 0) return(1);
4535 if (n > 0 && (k<0 || k>n)) return (0);
4536
4537 if (n > 0 && (int)n == n) k = min2(k, (int)n - k);
4538 for (i = 1; i <= k; i++) {
4539 c *= (n - k + i) / i;
4540 if (c > large) {
4541 *scale += log(c); c = 1;
4542 }
4543 }
4544 return(c);
4545 }
4546
BinomialK(double alpha,int n,double C[],double S[])4547 int BinomialK(double alpha, int n, double C[], double S[])
4548 {
4549 /* This calculates (alpha, i), for i = 0, ..., n. The result are in C[i] * exp(S[i]).
4550 */
4551 int i, nround = n, alphaint = (int)alpha;
4552 double c = 1, large = 1E200;
4553
4554 if (alpha > 0 && fabs(alpha - alphaint) < 1e-100) { /* usual combinations */
4555 nround = min2(n, alphaint / 2);
4556 }
4557 C[0] = 1; S[0] = 0;
4558 for (i = 1; i <= nround; i++) {
4559 c *= (alpha - i + 1) / i;
4560 S[i] = S[i - 1];
4561 if (c > large) {
4562 S[i] += log(c); c = 1;
4563 }
4564 C[i] = c;
4565 }
4566 for (; i <= min2(n, alphaint); i++) { /* if alpha is int and n > alpha/2 */
4567 C[i] = C[alphaint - i]; S[i] = S[alphaint - i];
4568 }
4569 for (; i <= n; i++) { /* if alpha is int and n > alpha */
4570 C[i] = 0; S[i] = 0;
4571 }
4572 /*
4573 matout2(F0, C, n / 10, 10, 9, 1);
4574 matout2(F0, S, n / 10, 10, 9, 1);
4575 for (i = 0; i <= n; i++) C[i] *= exp(S[i]);
4576 matout2(F0, C, n / 10, 10, 9, 1);
4577 */
4578 return(0);
4579 }
4580
4581
4582 /****************************
4583 Vectors and matrices
4584 *****************************/
4585
Det3x3(double x[3* 3])4586 double Det3x3(double x[3 * 3])
4587 {
4588 return
4589 x[0 * 3 + 0] * x[1 * 3 + 1] * x[2 * 3 + 2]
4590 + x[0 * 3 + 1] * x[1 * 3 + 2] * x[2 * 3 + 0]
4591 + x[0 * 3 + 2] * x[1 * 3 + 0] * x[2 * 3 + 1]
4592 - x[0 * 3 + 0] * x[1 * 3 + 2] * x[2 * 3 + 1]
4593 - x[0 * 3 + 1] * x[1 * 3 + 0] * x[2 * 3 + 2]
4594 - x[0 * 3 + 2] * x[1 * 3 + 1] * x[2 * 3 + 0];
4595 }
4596
matby(double a[],double b[],double c[],int n,int m,int k)4597 int matby(double a[], double b[], double c[], int n, int m, int k)
4598 /* a[n*m], b[m*k], c[n*k] ...... c = a*b
4599 */
4600 {
4601 #ifdef USE_GSL
4602 memset(c, 0, n*k);
4603 gsl_matrix_view A = gsl_matrix_view_array(a, n, m);
4604 gsl_matrix_view B = gsl_matrix_view_array(b, m, k);
4605 gsl_matrix_view C = gsl_matrix_view_array(c, n, k);
4606
4607 gsl_blas_dgemm(CblasNoTrans, CblasNoTrans, 1.0, &A.matrix, &B.matrix, 0.0, &C.matrix);
4608 #else
4609 int i1, i2, i3;
4610 double t;
4611
4612 for (i1 = 0; i1 < n; i1++)
4613 for (i2 = 0; i2 < k; i2++) {
4614 for (i3 = 0, t = 0; i3 < m; i3++) t += a[i1*m + i3] * b[i3*k + i2];
4615 c[i1*k + i2] = t;
4616 }
4617 #endif
4618 return (0);
4619 }
4620
matbytransposed(double a[],double b_transposed[],double c[],int n,int m,int k)4621 int matbytransposed(double a[], double b_transposed[], double c[], int n, int m, int k)
4622 /* a[n*m], b[m*k], c[n*k] ...... c = a*b, but with b_transposed[k*m]
4623 */
4624 {
4625 int i1, i2, i3;
4626 double t;
4627
4628 for (i1 = 0; i1 < n; i1++)
4629 for (i2 = 0; i2 < k; i2++) {
4630 for (i3 = 0, t = 0; i3 < m; i3++) t += a[i1*m + i3] * b_transposed[i2*m + i3];
4631 c[i1*k + i2] = t;
4632 }
4633 return (0);
4634 }
4635
4636
4637
matIout(FILE * fout,int x[],int n,int m)4638 int matIout(FILE *fout, int x[], int n, int m)
4639 {
4640 int i, j;
4641 fprintf(fout, "\n");
4642 for (i = 0; i < n; i++) {
4643 for (j = 0; j < m; j++) fprintf(fout, " %4d", x[i*m + j]);
4644 fprintf(fout, "\n");
4645 }
4646 return (0);
4647 }
4648
matout(FILE * fout,double x[],int n,int m)4649 int matout(FILE *fout, double x[], int n, int m)
4650 {
4651 int i, j;
4652 fprintf(fout, "\n");
4653 for (i = 0; i < n; i++) {
4654 for (j = 0; j < m; j++)
4655 fprintf(fout, " %11.6f", x[i*m + j]);
4656 fprintf(fout, "\n");
4657 }
4658 return (0);
4659 }
4660
matout2(FILE * fout,double x[],int n,int m,int wid,int deci)4661 int matout2(FILE * fout, double x[], int n, int m, int wid, int deci)
4662 {
4663 int i, j;
4664 fprintf(fout, "\n");
4665 for (i = 0; i < n; i++) {
4666 for (j = 0; j < m; j++)
4667 fprintf(fout, " %*.*g", wid - 1, deci, x[i*m + j]);
4668 fprintf(fout, "\n");
4669 }
4670 return (0);
4671 }
4672
mattransp1(double x[],int n)4673 int mattransp1(double x[], int n)
4674 /* transpose a matrix x[n*n], stored by rows.
4675 */
4676 {
4677 int i, j;
4678 double t;
4679 FOR(i, n) for (j = 0; j < i; j++)
4680 if (i != j) { t = x[i*n + j]; x[i*n + j] = x[j*n + i]; x[j*n + i] = t; }
4681 return (0);
4682 }
4683
mattransp2(double x[],double y[],int n,int m)4684 int mattransp2(double x[], double y[], int n, int m)
4685 {
4686 /* transpose a matrix x[n][m] --> y[m][n]
4687 */
4688 int i, j;
4689
4690 FOR(i, n) FOR(j, m) y[j*n + i] = x[i*m + j];
4691 return (0);
4692 }
4693
matinv(double x[],int n,int m,double space[])4694 int matinv(double x[], int n, int m, double space[])
4695 {
4696 /* x[n*m] ... m>=n
4697 space[n]. This puts the fabs(|x|) into space[0]. Check and calculate |x|.
4698 Det may have the wrong sign. Check and fix.
4699 */
4700 int i, j, k;
4701 int *irow = (int*)space;
4702 double ee = 1e-100, t, t1, xmax, det = 1;
4703
4704 for (i = 0; i < n; i++) irow[i] = i;
4705
4706 for (i = 0; i < n; i++) {
4707 xmax = fabs(x[i*m + i]);
4708 for (j = i + 1; j < n; j++)
4709 if (xmax < fabs(x[j*m + i]))
4710 {
4711 xmax = fabs(x[j*m + i]); irow[i] = j;
4712 }
4713 det *= x[irow[i] * m + i];
4714 if (xmax < ee) {
4715 printf("\nxmax = %.4e close to zero at %3d!\t\n", xmax, i + 1);
4716 exit(-1);
4717 }
4718 if (irow[i] != i) {
4719 for (j = 0; j < m; j++) {
4720 t = x[i*m + j];
4721 x[i*m + j] = x[irow[i] * m + j];
4722 x[irow[i] * m + j] = t;
4723 }
4724 }
4725 t = 1. / x[i*m + i];
4726 for (j = 0; j < n; j++) {
4727 if (j == i) continue;
4728 t1 = t*x[j*m + i];
4729 FOR(k, m) x[j*m + k] -= t1*x[i*m + k];
4730 x[j*m + i] = -t1;
4731 }
4732 for (j = 0; j < m; j++) x[i*m + j] *= t;
4733 x[i*m + i] = t;
4734 } /* for(i) */
4735 for (i = n - 1; i >= 0; i--) {
4736 if (irow[i] == i) continue;
4737 for (j = 0; j < n; j++) {
4738 t = x[j*m + i];
4739 x[j*m + i] = x[j*m + irow[i]];
4740 x[j*m + irow[i]] = t;
4741 }
4742 }
4743 space[0] = det;
4744 return(0);
4745 }
4746
4747 #ifdef USE_GSL
matexpGSL(double A[],int n,double space[])4748 int matexpGSL(double A[], int n, double space[]) {
4749 /* this uses the (unsupported) GSL function for matrix exponential, which
4750 appears to work better than the old implementation below. Because it is
4751 unsupported though, we should keep an eye on it.
4752 */
4753 double * EA = space;
4754 memset(EA, 0, n*n);
4755 gsl_matrix_view m = gsl_matrix_view_array(A, n, n);
4756 gsl_matrix_view expm = gsl_matrix_view_array(EA, n, n);
4757
4758 gsl_linalg_exponential_ss(&m.matrix, &expm.matrix, 0);
4759
4760 memcpy(A, EA, n*n * sizeof(double));
4761
4762 return 0;
4763 }
4764 #endif
4765
matexp(double A[],int n,int nTaylorTerms,int nSquares,double space[])4766 int matexp(double A[], int n, int nTaylorTerms, int nSquares, double space[])
4767 {
4768 /* This calculates the matrix exponential e^A and returns the result in A[].
4769 space[n*n*3]: required working space.
4770
4771 e^A = (I + A/m + (A/m)^2/2! + ...)^m, with m = 2^TimeSquare.
4772
4773 See equation (2.22) in Yang (2006) and the discussion below it.
4774 This is method 3 in Moler & Van Loan (2003. Nineteen dubious ways to compute
4775 the exponential of a matrix, twenty-five years later. SIAM Review 45:3-49).
4776
4777 In the Taylor step, T[1] and T[2] are used to avoid matrix copying.
4778 In the squaring step, T[0] and T[1] are used to avoid matrix copying.
4779 Use an even nSquares to avoid one round of matrix copying.
4780 */
4781 int it, i, j;
4782 double *T[3], *B, m1, factor = 1; /* B = A/2^nSquares */
4783
4784 if (nSquares > 31) error2("nSquares too large");
4785 T[0] = A;
4786 T[1] = space;
4787 T[2] = T[1] + n*n;
4788 B = T[2] + n*n;
4789
4790 m1 = 1.0 / (1 << nSquares);
4791 for (i = 0; i < n*n; i++) B[i] = T[1][i] = A[i] *= m1;
4792
4793 /* Taylor for e^B, with result in A = T[0]. Calculate I + B first. */
4794 for (i = 0; i < n; i++) A[i*n + i] ++;
4795 for (j = 2, it = 2; j <= nTaylorTerms; j++, it = 3 - it) { /* it flips between 1 and 2. */
4796 matby(T[3 - it], B, T[it], n, n, n);
4797 factor /= j;
4798 for (i = 0; i < n*n; i++)
4799 A[i] += T[it][i] * factor;
4800 }
4801
4802 for (i = 0, it = 0; i < nSquares; i++, it = 1 - it) {
4803 matby(T[it], T[it], T[1 - it], n, n, n);
4804 }
4805 if (it == 1)
4806 for (i = 0; i < n*n; i++) A[i] = T[1][i];
4807 return(0);
4808 }
4809
4810
4811 void HouseholderRealSym(double a[], int n, double d[], double e[]);
4812 int EigenTridagQLImplicit(double d[], double e[], int n, double z[]);
4813
matsqrt(double A[],int n,double work[])4814 int matsqrt(double A[], int n, double work[])
4815 {
4816 /* This finds the symmetrical square root of a real symmetrical matrix A[n*n].
4817 R * R = A. The root is returned in A[].
4818 The work space if work[n*n*2+n].
4819 Used the same procedure as eigenRealSym(), but does not sort eigen values.
4820 */
4821 int i, j, status;
4822 double *U = work, *Root = U + n*n, *V = Root + n;
4823
4824 xtoy(A, U, n*n);
4825 HouseholderRealSym(U, n, Root, V);
4826 status = EigenTridagQLImplicit(Root, V, n, U);
4827 mattransp2(U, V, n, n);
4828 for (i = 0; i < n; i++)
4829 if (Root[i] < 0) error2("negative root in matsqrt?");
4830 else Root[i] = sqrt(Root[i]);
4831 for (i = 0; i < n; i++) for (j = 0; j < n; j++)
4832 U[i*n + j] *= Root[j];
4833 matby(U, V, A, n, n, n);
4834
4835 return(status);
4836 }
4837
4838
4839
CholeskyDecomp(double A[],int n,double L[])4840 int CholeskyDecomp(double A[], int n, double L[])
4841 {
4842 /* A=LL', where A is symmetrical and positive-definite, and L is
4843 lower-diagonal
4844 only A[i*n+j] (j>=i) are used.
4845 */
4846 int i, j, k;
4847 double t;
4848
4849 for (i = 0; i < n; i++)
4850 for (j = i + 1; j < n; j++)
4851 L[i*n + j] = 0;
4852 for (i = 0; i < n; i++) {
4853 for (k = 0, t = A[i*n + i]; k < i; k++)
4854 t -= square(L[i*n + k]);
4855 if (t >= 0)
4856 L[i*n + i] = sqrt(t);
4857 else
4858 return (-1);
4859 for (j = i + 1; j < n; j++) {
4860 for (k = 0, t = A[i*n + j]; k < i; k++)
4861 t -= L[i*n + k] * L[j*n + k];
4862 L[j*n + i] = t / L[i*n + i];
4863 }
4864 }
4865 return (0);
4866 }
4867
4868
4869 int Choleskyback(double L[], double b[], double x[], int n);
4870 int CholeskyInverse(double L[], int n);
4871
Choleskyback(double L[],double b[],double x[],int n)4872 int Choleskyback(double L[], double b[], double x[], int n)
4873 {
4874 /* solve Ax=b, where A=LL' is lower-diagonal.
4875 x=b O.K. Only A[i*n+j] (i>=j) are used
4876 */
4877
4878 int i, j;
4879 double t;
4880
4881 for (i = 0; i < n; i++) { /* solve Ly=b, and store results in x */
4882 for (j = 0, t = b[i]; j < i; j++) t -= L[i*n + j] * x[j];
4883 x[i] = t / L[i*n + i];
4884 }
4885 for (i = n - 1; i >= 0; i--) { /* solve L'x=y, and store results in x */
4886 for (j = i + 1, t = x[i]; j < n; j++) t -= L[j*n + i] * x[j];
4887 x[i] = t / L[i*n + i];
4888 }
4889 return (0);
4890 }
4891
CholeskyInverse(double L[],int n)4892 int CholeskyInverse(double L[], int n)
4893 {
4894 /* inverse of L
4895 */
4896 int i, j, k;
4897 double t;
4898
4899 for (i = 0; i < n; i++) {
4900 L[i*n + i] = 1 / L[i*n + i];
4901 for (j = i + 1; j < n; j++) {
4902 for (k = i, t = 0; k < j; k++) t -= L[j*n + k] * L[k*n + i];
4903 L[j*n + i] = t / L[j*n + j];
4904 }
4905 }
4906 return (0);
4907 }
4908
4909
eigenQREV(double Q[],double pi[],int n,double Root[],double U[],double V[],double spacesqrtpi[])4910 int eigenQREV(double Q[], double pi[], int n, double Root[], double U[], double V[], double spacesqrtpi[])
4911 {
4912 /*
4913 This finds the eigen solution of the rate matrix Q for a time-reversible
4914 Markov process, using the algorithm for a real symmetric matrix.
4915 Rate matrix Q = S * diag{pi} = U * diag{Root} * V,
4916 where S is symmetrical, all elements of pi are positive, and UV = I.
4917 space[n] is for storing sqrt(pi).
4918
4919 [U 0] [Q_0 0] [U^-1 0] [Root 0]
4920 [0 I] [0 0] [0 I] = [0 0]
4921
4922 Ziheng Yang, 25 December 2001 (ref is CME/eigenQ.pdf)
4923 */
4924 int i, j, inew, jnew, nnew, status;
4925 double *pi_sqrt = spacesqrtpi, smallv = 1e-100;
4926
4927 for (j = 0, nnew = 0; j < n; j++)
4928 if (pi[j] > smallv)
4929 pi_sqrt[nnew++] = sqrt(pi[j]);
4930
4931 /* store in U the symmetrical matrix S = sqrt(D) * Q * sqrt(-D) */
4932
4933 if (nnew == n) {
4934 for (i = 0; i < n; i++)
4935 for (j = 0, U[i*n + i] = Q[i*n + i]; j < i; j++)
4936 U[i*n + j] = U[j*n + i] = (Q[i*n + j] * pi_sqrt[i] / pi_sqrt[j]);
4937
4938 status = eigenRealSym(U, n, Root, V);
4939 for (i = 0; i < n; i++) for (j = 0; j < n; j++) V[i*n + j] = U[j*n + i] * pi_sqrt[j];
4940 for (i = 0; i < n; i++) for (j = 0; j < n; j++) U[i*n + j] /= pi_sqrt[i];
4941 }
4942 else {
4943 for (i = 0, inew = 0; i < n; i++) {
4944 if (pi[i] > smallv) {
4945 for (j = 0, jnew = 0; j < i; j++)
4946 if (pi[j] > smallv) {
4947 U[inew*nnew + jnew] = U[jnew*nnew + inew]
4948 = Q[i*n + j] * pi_sqrt[inew] / pi_sqrt[jnew];
4949 jnew++;
4950 }
4951 U[inew*nnew + inew] = Q[i*n + i];
4952 inew++;
4953 }
4954 }
4955
4956 status = eigenRealSym(U, nnew, Root, V);
4957
4958 for (i = n - 1, inew = nnew - 1; i >= 0; i--) /* construct Root */
4959 Root[i] = (pi[i] > smallv ? Root[inew--] : 0);
4960 for (i = n - 1, inew = nnew - 1; i >= 0; i--) { /* construct V */
4961 if (pi[i] > smallv) {
4962 for (j = n - 1, jnew = nnew - 1; j >= 0; j--)
4963 if (pi[j] > smallv) {
4964 V[i*n + j] = U[jnew*nnew + inew] * pi_sqrt[jnew];
4965 jnew--;
4966 }
4967 else
4968 V[i*n + j] = (i == j);
4969 inew--;
4970 }
4971 else
4972 for (j = 0; j < n; j++) V[i*n + j] = (i == j);
4973 }
4974 for (i = n - 1, inew = nnew - 1; i >= 0; i--) { /* construct U */
4975 if (pi[i] > smallv) {
4976 for (j = n - 1, jnew = nnew - 1; j >= 0; j--)
4977 if (pi[j] > smallv) {
4978 U[i*n + j] = U[inew*nnew + jnew] / pi_sqrt[inew];
4979 jnew--;
4980 }
4981 else
4982 U[i*n + j] = (i == j);
4983 inew--;
4984 }
4985 else
4986 for (j = 0; j < n; j++)
4987 U[i*n + j] = (i == j);
4988 }
4989 }
4990
4991 /* This routine works on P(t) as well as Q. */
4992 /*
4993 if(fabs(Root[0])>1e-10 && noisy) printf("Root[0] = %.5e\n",Root[0]);
4994 Root[0]=0;
4995 */
4996 return(status);
4997 }
4998
4999
5000 /* eigen solution for real symmetric matrix */
5001 void EigenSort(double d[], double U[], int n);
5002
eigenRealSym(double A[],int n,double Root[],double work[])5003 int eigenRealSym(double A[], int n, double Root[], double work[])
5004 {
5005 /* This finds the eigen solution of a real symmetrical matrix A[n*n]. In return,
5006 A has the right vectors and Root has the eigenvalues.
5007 work[n] is the working space.
5008 The matrix is first reduced to a tridiagonal matrix using HouseholderRealSym(),
5009 and then using the QL algorithm with implicit shifts.
5010
5011 Adapted from routine tqli in Numerical Recipes in C, with reference to LAPACK
5012 Ziheng Yang, 23 May 2001
5013 */
5014 int status = 0;
5015 HouseholderRealSym(A, n, Root, work);
5016 status = EigenTridagQLImplicit(Root, work, n, A);
5017 EigenSort(Root, A, n);
5018
5019 return(status);
5020 }
5021
5022
EigenSort(double d[],double U[],int n)5023 void EigenSort(double d[], double U[], int n)
5024 {
5025 /* this sorts the eigenvalues d[] in decreasing order and rearrange the (right) eigenvectors U[].
5026 */
5027 int k, j, i;
5028 double p;
5029
5030 for (i = 0; i < n - 1; i++) {
5031 p = d[k = i];
5032 for (j = i + 1; j < n; j++)
5033 if (d[j] >= p) p = d[k = j];
5034 if (k != i) {
5035 d[k] = d[i];
5036 d[i] = p;
5037 for (j = 0; j < n; j++) {
5038 p = U[j*n + i];
5039 U[j*n + i] = U[j*n + k];
5040 U[j*n + k] = p;
5041 }
5042 }
5043 }
5044 }
5045
5046
5047
HouseholderRealSym(double a[],int n,double d[],double e[])5048 void HouseholderRealSym(double a[], int n, double d[], double e[])
5049 {
5050 /* This uses HouseholderRealSym transformation to reduce a real symmetrical matrix
5051 a[n*n] into a tridiagonal matrix represented by d and e.
5052 d[] is the diagonal (eigends), and e[] the off-diagonal.
5053 */
5054 int m, k, j, i;
5055 double scale, hh, h, g, f;
5056
5057 for (i = n - 1; i >= 1; i--) {
5058 m = i - 1;
5059 h = scale = 0;
5060 if (m > 0) {
5061 for (k = 0; k <= m; k++)
5062 scale += fabs(a[i*n + k]);
5063 if (scale == 0)
5064 e[i] = a[i*n + m];
5065 else {
5066 for (k = 0; k <= m; k++) {
5067 a[i*n + k] /= scale;
5068 h += a[i*n + k] * a[i*n + k];
5069 }
5070 f = a[i*n + m];
5071 g = (f >= 0 ? -sqrt(h) : sqrt(h));
5072 e[i] = scale*g;
5073 h -= f*g;
5074 a[i*n + m] = f - g;
5075 f = 0;
5076 for (j = 0; j <= m; j++) {
5077 a[j*n + i] = a[i*n + j] / h;
5078 g = 0;
5079 for (k = 0; k <= j; k++)
5080 g += a[j*n + k] * a[i*n + k];
5081 for (k = j + 1; k <= m; k++)
5082 g += a[k*n + j] * a[i*n + k];
5083 e[j] = g / h;
5084 f += e[j] * a[i*n + j];
5085 }
5086 hh = f / (h * 2);
5087 for (j = 0; j <= m; j++) {
5088 f = a[i*n + j];
5089 e[j] = g = e[j] - hh*f;
5090 for (k = 0; k <= j; k++)
5091 a[j*n + k] -= (f*e[k] + g*a[i*n + k]);
5092 }
5093 }
5094 }
5095 else
5096 e[i] = a[i*n + m];
5097 d[i] = h;
5098 }
5099 d[0] = e[0] = 0;
5100
5101 /* Get eigenvectors */
5102 for (i = 0; i < n; i++) {
5103 m = i - 1;
5104 if (d[i]) {
5105 for (j = 0; j <= m; j++) {
5106 g = 0;
5107 for (k = 0; k <= m; k++)
5108 g += a[i*n + k] * a[k*n + j];
5109 for (k = 0; k <= m; k++)
5110 a[k*n + j] -= g*a[k*n + i];
5111 }
5112 }
5113 d[i] = a[i*n + i];
5114 a[i*n + i] = 1;
5115 for (j = 0; j <= m; j++) a[j*n + i] = a[i*n + j] = 0;
5116 }
5117 }
5118
5119 #define SIGN(a,b) ((b) >= 0.0 ? fabs(a) : -fabs(a))
5120
EigenTridagQLImplicit(double d[],double e[],int n,double z[])5121 int EigenTridagQLImplicit(double d[], double e[], int n, double z[])
5122 {
5123 /* This finds the eigen solution of a tridiagonal matrix represented by d and e.
5124 d[] is the diagonal (eigenvalues), e[] is the off-diagonal
5125 z[n*n]: as input should have the identity matrix to get the eigen solution of the
5126 tridiagonal matrix, or the output from HouseholderRealSym() to get the
5127 eigen solution to the original real symmetric matrix.
5128 z[n*n]: has the orthogonal matrix as output
5129
5130 Adapted from routine tqli in Numerical Recipes in C, with reference to
5131 LAPACK fortran code.
5132 Ziheng Yang, May 2001
5133 */
5134 int m, j, iter, niter = 30, status = 0, i, k;
5135 double s, r, p, g, f, dd, c, b, aa, bb;
5136
5137 for (i = 1; i < n; i++) e[i - 1] = e[i]; e[n - 1] = 0;
5138 for (j = 0; j < n; j++) {
5139 iter = 0;
5140 do {
5141 for (m = j; m < n - 1; m++) {
5142 dd = fabs(d[m]) + fabs(d[m + 1]);
5143 if (fabs(e[m]) + dd == dd) break; /* ??? */
5144 }
5145 if (m != j) {
5146 if (iter++ == niter) {
5147 status = -1;
5148 break;
5149 }
5150 g = (d[j + 1] - d[j]) / (2 * e[j]);
5151
5152 /* r=pythag(g,1); */
5153
5154 if ((aa = fabs(g)) > 1) r = aa*sqrt(1 + 1 / (g*g));
5155 else r = sqrt(1 + g*g);
5156
5157 g = d[m] - d[j] + e[j] / (g + SIGN(r, g));
5158 s = c = 1;
5159 p = 0;
5160 for (i = m - 1; i >= j; i--) {
5161 f = s*e[i];
5162 b = c*e[i];
5163
5164 /* r=pythag(f,g); */
5165 aa = fabs(f); bb = fabs(g);
5166 if (aa > bb) { bb /= aa; r = aa*sqrt(1 + bb*bb); }
5167 else if (bb == 0) r = 0;
5168 else { aa /= bb; r = bb*sqrt(1 + aa*aa); }
5169
5170 e[i + 1] = r;
5171 if (r == 0) {
5172 d[i + 1] -= p;
5173 e[m] = 0;
5174 break;
5175 }
5176 s = f / r;
5177 c = g / r;
5178 g = d[i + 1] - p;
5179 r = (d[i] - g)*s + 2 * c*b;
5180 d[i + 1] = g + (p = s*r);
5181 g = c*r - b;
5182 for (k = 0; k < n; k++) {
5183 f = z[k*n + i + 1];
5184 z[k*n + i + 1] = s*z[k*n + i] + c*f;
5185 z[k*n + i] = c*z[k*n + i] - s*f;
5186 }
5187 }
5188 if (r == 0 && i >= j) continue;
5189 d[j] -= p; e[j] = g; e[m] = 0;
5190 }
5191 } while (m != j);
5192 }
5193 return(status);
5194 }
5195
5196 #undef SIGN
5197
5198
5199
5200
5201
5202
5203
5204
MeanVar(double x[],int n,double * m,double * v)5205 int MeanVar(double x[], int n, double *m, double *v)
5206 {
5207 int i;
5208
5209 for (i = 0, *m = 0; i < n; i++) *m += x[i];
5210 *m /= n;
5211 for (i = 0, *v = 0; i < n; i++) *v += square(x[i] - *m);
5212 if (n > 1) *v /= (n - 1.);
5213 return(0);
5214 }
5215
variance(double x[],int n,int p,double m[],double v[])5216 int variance(double x[], int n, int p, double m[], double v[])
5217 {
5218 /* x[p][n], m[p], v[p][p]
5219 */
5220 int i, j, k;
5221
5222 for (i = 0; i < p; i++) {
5223 for (k = 0, m[i] = 0; k < n; k++) m[i] += x[i*n + k];
5224 m[i] /= n;
5225 }
5226 for (i = 0; i < p*p; i++)
5227 v[i] = 0;
5228 for (i = 0; i < p; i++)
5229 for (j = i; j < p; j++) {
5230 for (k = 0; k < n; k++)
5231 v[i*p + j] += (x[i*n + k] - m[i]) * (x[j*n + k] - m[j]);
5232 v[j*p + i] = (v[i*p + j] /= (n - 1.));
5233 }
5234 return(0);
5235 }
5236
correl(double x[],double y[],int n,double * mx,double * my,double * vxx,double * vxy,double * vyy,double * r)5237 int correl(double x[], double y[], int n, double *mx, double *my, double *vxx, double *vxy, double *vyy, double *r)
5238 {
5239 int i;
5240 double dx, dy;
5241
5242 *mx = *my = *vxx = *vxy = *vyy = 0.0;
5243 for (i = 0; i < n; i++) {
5244 /* update vxx & vyy before mx & my */
5245 dx = x[i] - *mx;
5246 dy = y[i] - *my;
5247 *vxx += dx*dx * i / (i + 1.);
5248 *vyy += dy*dy * i / (i + 1.);
5249 *vxy += dx*dy * i / (i + 1.);
5250 *mx += dx / (i + 1.);
5251 *my += dy / (i + 1.);
5252 }
5253 *vxx /= (n - 1.0);
5254 *vyy /= (n - 1.0);
5255 *vxy /= (n - 1.0);
5256 if (*vxx > 0.0 && *vyy > 0.0) *r = *vxy / sqrt(*vxx * *vyy);
5257 else *r = -9;
5258 return(0);
5259 }
5260
5261
bubblesort(float x[],int n)5262 int bubblesort(float x[], int n)
5263 {
5264 /* inefficient bubble sort */
5265 int i, j;
5266 float t = 0;
5267
5268 for (i = 0; i < n; i++) {
5269 for (j = i; j < n; j++)
5270 if (x[j] < x[i]) { t = x[i]; x[i] = x[j]; x[j] = t; }
5271 }
5272 return (0);
5273 }
5274
5275
comparedouble(const void * a,const void * b)5276 int comparedouble(const void *a, const void *b)
5277 {
5278 double aa = *(double*)a, bb = *(double*)b;
5279 return (aa > bb ? 1 : (aa < bb ? -1 : 0));
5280 }
5281
5282
splitline(char line[],int nfields,int fields[])5283 int splitline(char line[], int nfields, int fields[])
5284 {
5285 /* This finds out how many fields there are in the line, and marks the starting positions of the fields.
5286 if(nfield>0), only nfield fiends are read. Otherwise read until end of line or until MAXNFIELDS.
5287 Fields are separated by spaces, and texts are allowed as well.
5288 returns the number of fields read.
5289 */
5290 int i, nfieldsread = 0, InSpace = 1;
5291 char *p = line;
5292
5293 for (i = 0; (nfields==-1 || nfieldsread<nfields) && *p && *p != '\n'; i++, p++) {
5294 if (isspace(*p))
5295 InSpace = 1;
5296 else {
5297 if (InSpace) {
5298 InSpace = 0;
5299 fields[nfieldsread ++] = i;
5300 if (nfieldsread > MAXNFIELDS)
5301 puts("raise MAXNFIELDS?");
5302 }
5303 }
5304 }
5305 return(nfieldsread);
5306 }
5307
5308
scanfile(FILE * fin,int * nrecords,int * nx,int * HasHeader,char line[],int ifields[])5309 int scanfile(FILE*fin, int *nrecords, int *nx, int *HasHeader, char line[], int ifields[])
5310 {
5311 /* If the first line has letters, it is considered to be the header line, and HasHeader=0 is set.
5312 */
5313 int i, lline = 1000000, nxline = 0, eof = 0, hastext;
5314
5315 *nx = 0; *HasHeader = 0;
5316 for (*nrecords = 0; ; ) {
5317 if (!fgets(line, lline, fin)) break;
5318 eof = feof(fin);
5319 if (*nrecords == 0 && strchr(line, '\n') == NULL)
5320 puts(" line too short or too long?");
5321 for (i = 0, hastext = 0; i < lline && line[i]; i++)
5322 if (line[i] != 'e' && line[i] != 'E' && isalpha(line[i])) { hastext = 1; break; }
5323 if (hastext) {
5324 if (*nrecords == 0) {
5325 *HasHeader = 1;
5326 printf("\nData file has a header line.\n");
5327 }
5328 else {
5329 printf("text found on line %d.", *nrecords + 1);
5330 error2("file format");
5331 }
5332 }
5333 nxline = splitline(line, MAXNFIELDS, ifields);
5334
5335 if (nxline == 0)
5336 continue;
5337 if (*nrecords == 0)
5338 *nx = nxline;
5339 else if (*nx != nxline) {
5340 if (eof)
5341 break;
5342 else {
5343 printf("file format error: %d fields in line %d while %d fields in first line.",
5344 nxline, *nrecords + 1, *nx);
5345 error2("error in scanfile()");
5346 }
5347 }
5348 if (*nx > MAXNFIELDS) error2("raise MAXNFIELDS?");
5349
5350 (*nrecords)++;
5351 /* printf("line # %3d: %3d variables\n", *nrecords+1, nxline); */
5352 }
5353 rewind(fin);
5354
5355 if (*HasHeader) {
5356 fgets(line, lline, fin);
5357 splitline(line, MAXNFIELDS, ifields);
5358 }
5359 if (*HasHeader)
5360 (*nrecords)--;
5361
5362 return(0);
5363 }
5364
5365
5366
5367
5368 #define MAXNF2D 5
5369 #define SQRT5 2.2360679774997896964
5370 #define Epanechnikov(t) ((0.75-0.15*(t)*(t))/SQRT5)
5371
5372 /* October 2006: density1d and density2d need to be reworked to account for edge effects.
5373 */
5374
density1d(FILE * fout,double y[],int n,int nbin,double minx,double gap,double h,double space[],int propternary)5375 int density1d(FILE* fout, double y[], int n, int nbin, double minx,
5376 double gap, double h, double space[], int propternary)
5377 {
5378 /* This collects the histogram and uses kernel smoothing and adaptive kernel
5379 smoothing to estimate the density. The kernel is Epanechnikov. The
5380 histogram is collected into fobs, smoothed density into fE, and density
5381 from adaptive kernel smoothing into fEA[].
5382 Data y[] are sorted in increasing order before calling this routine.
5383
5384 space[bin+n]
5385 */
5386 int adaptive = 0, i, k, iL, nused;
5387 double *fobs = space, *lambda = fobs + nbin, fE, fEA, xt, d, G, alpha = 0.5;
5388 double maxx = minx + gap*nbin, edge;
5389 char timestr[32];
5390
5391 for (i = 0; i < nbin; i++) fobs[i] = 0;
5392 for (k = 0, i = 0; k < n; k++) {
5393 for (; i < nbin - 1; i++)
5394 if (y[k] <= minx + gap*(i + 1)) break;
5395 fobs[i] += 1. / n;
5396 }
5397
5398 /* weights for adaptive smoothing */
5399 if (adaptive) {
5400 for (k = 0; k < n; k++) lambda[k] = 0;
5401 for (k = 0, G = 0, iL = 0; k < n; k++) {
5402 xt = y[k];
5403 for (i = iL, nused = 0; i < n; i++) {
5404 d = fabs(xt - y[i]) / h;
5405 if (d < SQRT5) {
5406 nused++;
5407 lambda[k] += 1 - 0.2*d*d; /* based on Epanechnikov kernel */
5408 /* lambda[k] += Epanechnikov(d)/(n*h); */
5409 }
5410 else if (nused == 0)
5411 iL = i;
5412 else
5413 break;
5414 }
5415 G += log(lambda[k]);
5416 if ((k + 1) % 1000 == 0)
5417 printf("\r\tGetting weights: %2d/%d %d terms %s", k + 1, n, nused, printtime(timestr));
5418
5419 }
5420 G = exp(G / n);
5421 for (k = 0; k < n; k++) lambda[k] = pow(lambda[k] / G, -alpha);
5422 if (n > 1000) printf("\r");
5423 }
5424
5425 /* smoothing and printing */
5426 for (k = 0; k < nbin; k++) {
5427 xt = minx + gap*(k + 0.5);
5428 for (i = 0, fE = fEA = 0; i < n; i++) {
5429 d = fabs(xt - y[i]) / h;
5430 if (d > SQRT5) continue;
5431 edge = (y[i] - xt > xt - minx || xt - y[i] > maxx - xt ? 2 : 1);
5432 fE += edge*Epanechnikov(d) / (n*h);
5433 if (adaptive) {
5434 d /= lambda[i];
5435 fEA += edge*Epanechnikov(d) / (n*h*lambda[i]);
5436 }
5437 }
5438 if (!adaptive) fprintf(fout, "%.6f\t%.6f\t%.6f\n", xt, fobs[k], fE);
5439 else fprintf(fout, "%.6f\t%.6f\t%.6f\t%.6f\n", xt, fobs[k], fE, fEA);
5440 }
5441 return(0);
5442 }
5443
density2d(FILE * fout,double y1[],double y2[],int n,int nbin,double minx1,double minx2,double gap1,double gap2,double var[4],double h,double space[],int propternary)5444 int density2d(FILE* fout, double y1[], double y2[], int n, int nbin,
5445 double minx1, double minx2, double gap1, double gap2,
5446 double var[4], double h, double space[], int propternary)
5447 {
5448 /* This collects the histogram and uses kernel smoothing and adaptive kernel
5449 smoothing to estimate the 2-D density. The kernel is Epanechnikov. The
5450 histogram is collected into f, smoothed density into fE, and density
5451 from adaptive kernel smoothing into fEA[].
5452 Data y1 and y2 are not sorted, unlike the 1-D routine.
5453
5454 alpha goes from 0 to 1, with 0 being equivalent to fixed width smoothing.
5455 var[] has the 2x2 variance matrix, which is copied into S[4] and inverted.
5456
5457 space[nbin*nbin*3+n] for observed histogram f[nbin*nbin] and for lambda[n].
5458 */
5459 char timestr[32];
5460 int i, j, k;
5461 double *fO = space, *fE = fO + nbin*nbin, *fEA = fE + nbin*nbin, *lambda = fEA + nbin*nbin;
5462 double h2 = h*h, c2d, a, b, c, d, S[4], detS, G, x1, x2, alpha = 0.5;
5463
5464 /* histogram */
5465 for (i = 0; i < nbin*nbin; i++)
5466 fO[i] = fE[i] = fEA[i] = 0;
5467 for (i = 0; i < n; i++) {
5468 for (j = 0; j < nbin - 1; j++) if (y1[i] <= minx1 + gap1*(j + 1)) break;
5469 for (k = 0; k < nbin - 1; k++) if (y2[i] <= minx2 + gap2*(k + 1)) break;
5470 fO[j*nbin + k] += 1. / n;
5471 }
5472
5473 xtoy(var, S, 4);
5474 a = S[0]; b = c = S[1]; d = S[3]; detS = a*d - b*c;
5475 S[0] = d / detS; S[1] = S[2] = -b / detS; S[3] = a / detS;
5476 /* detS=1; S[0]=S[3]=1; S[1]=S[2]=0; */
5477 c2d = 2 / (n*Pi*h*h*sqrt(detS));
5478
5479 /* weights for adaptive kernel smoothing */
5480 for (k = 0; k < n; k++) lambda[k] = 0;
5481 for (k = 0, G = 0; k < n; k++) {
5482 x1 = y1[k];
5483 x2 = y2[k];
5484 for (i = 0; i < n; i++) {
5485 a = x1 - y1[i];
5486 b = x2 - y2[i];
5487 d = (a*S[0] + b*S[1])*a + (a*S[1] + b*S[3])*b;
5488 d /= h2;
5489 if (d < 1) lambda[k] += (1 - d);
5490 }
5491 G += log(lambda[k]);
5492 if ((k + 1) % 1000 == 0)
5493 printf("\r\tGetting weights: %2d/%d %s", k + 1, n, printtime(timestr));
5494 }
5495 G = exp(G / n);
5496 for (k = 0; k < n; k++) lambda[k] = pow(lambda[k] / G, -alpha);
5497 for (k = 0; k < n; k++) lambda[k] = 1 / square(lambda[k]); /* 1/lambda^2 */
5498 if (n > 1000) printf("\r");
5499
5500 /* smoothing and printing */
5501 puts("\t\tSmoothing and printing.");
5502 for (j = 0; j < nbin; j++) {
5503 for (k = 0; k < nbin; k++) {
5504 x1 = minx1 + gap1*(j + 0.5);
5505 x2 = minx2 + gap2*(k + 0.5);
5506 if (propternary && x1 + x2 > 1)
5507 continue;
5508 for (i = 0; i < n; i++) {
5509 a = x1 - y1[i], b = x2 - y2[i];
5510 d = (a*S[0] + b*S[1])*a + (a*S[1] + b*S[3])*b;
5511 d /= h2;
5512 if (d < 1) fE[j*nbin + k] += (1 - d);
5513
5514 d *= lambda[i];
5515 if (d < 1) fEA[j*nbin + k] += (1 - d)*lambda[i];
5516 }
5517 }
5518 }
5519 for (i = 0; i < nbin*nbin; i++) { fE[i] *= c2d; fEA[i] *= c2d; }
5520
5521 if (propternary == 2) { /* symmetrize for ternary contour plots */
5522 for (j = 0; j < nbin; j++) {
5523 for (k = 0; k <= j; k++) {
5524 x1 = minx1 + gap1*(j + 0.5);
5525 x2 = minx2 + gap2*(k + 0.5);
5526 if (x1 + x2 > 1) continue;
5527 fO[j*nbin + k] = fO[k*nbin + j] = (fO[j*nbin + k] + fO[k*nbin + j]) / 2;
5528 fE[j*nbin + k] = fE[k*nbin + j] = (fE[j*nbin + k] + fE[k*nbin + j]) / 2;
5529 fEA[j*nbin + k] = fEA[k*nbin + j] = (fEA[j*nbin + k] + fEA[k*nbin + j]) / 2;
5530 }
5531 }
5532 }
5533
5534 for (j = 0; j < nbin; j++) {
5535 for (k = 0; k < nbin; k++) {
5536 x1 = minx1 + gap1*(j + 0.5);
5537 x2 = minx2 + gap2*(k + 0.5);
5538 if (!propternary || x1 + x2 <= 1)
5539 fprintf(fout, "%.6f\t%.6f\t%.6f\t%.6f\t%.6f\n", x1, x2, fO[j*nbin + k], fE[j*nbin + k], fEA[j*nbin + k]);
5540 }
5541 }
5542
5543 return(0);
5544 }
5545
5546
HPDinterval(double x[],int n,double HPD[2],double alpha)5547 int HPDinterval(double x[], int n, double HPD[2], double alpha)
5548 {
5549 /* This calculates the HPD interval at the alpha level.
5550 */
5551 int jL0 = (int)(n*alpha / 2), jU0 = (int)(n*(1 - alpha / 2)), jL, jU, jLb = jL0;
5552 double w0 = x[jU0] - x[jL0], w = w0;
5553 int debug = 0;
5554
5555 HPD[0] = x[jL0];
5556 HPD[1] = x[jU0];
5557 if (n < 3) return(-1);
5558 for (jL = 0, jU = jL + (jU0 - jL0); jU < n; jL++, jU++) {
5559 if (x[jU] - x[jL] < w) {
5560 jLb = jL;
5561 w = x[jU] - x[jL];
5562 }
5563 }
5564 HPD[0] = x[jLb];
5565 HPD[1] = x[jLb + jU0 - jL0];
5566 return(0);
5567 }
5568
5569
Eff_IntegratedCorrelationTime(double x[],int n,double * mx,double * vx,double * rho1)5570 double Eff_IntegratedCorrelationTime(double x[], int n, double *mx, double *vx, double *rho1)
5571 {
5572 /* This calculates Efficiency or Tint using Geyer's (1992) initial positive
5573 sequence method.
5574 Note that this destroys x[].
5575 */
5576 double Tint = 1, rho0 = 0, rho, m = 0, s = 0;
5577 int i, ir, minNr = 10, maxNr = 2000;
5578
5579 /* if(n<1000) puts("chain too short for calculating Eff? "); */
5580 for (i = 0; i < n; i++) m += x[i];
5581 m /= n;
5582 for (i = 0; i < n; i++) x[i] -= m;
5583 for (i = 0; i < n; i++) s += x[i] * x[i];
5584 s = sqrt(s / n);
5585 for (i = 0; i < n; i++) x[i] /= s;
5586
5587 if (mx) { *mx = m; *vx = s*s; }
5588 if (s / (fabs(m) + 1) < 1E-9)
5589 Tint = n;
5590 else {
5591 for (ir = 1; ir < min2(maxNr, n - minNr); ir++) {
5592 for (i = 0, rho = 0; i < n - ir; i++)
5593 rho += x[i] * x[i + ir];
5594 rho /= (n - ir);
5595 if (ir == 1) *rho1 = rho;
5596 if (ir > minNr && rho + rho0 < 0) break;
5597 Tint += rho * 2;
5598 rho0 = rho;
5599 }
5600 }
5601 return (1 / Tint);
5602 }
5603
5604
Eff_IntegratedCorrelationTime2(double x[],int n,int nbatch,double * mx,double * vx)5605 double Eff_IntegratedCorrelationTime2 (double x[], int n, int nbatch, double *mx, double *vx)
5606 {
5607 /* This calculates Eff, by using batch means. Tau, the integrated correlation time, is 1/Eff.
5608 This is unreliable when Eff is very low.
5609 V(mxb) = Vx/(lenbatch*E) = 1/(lenbatch*E). The variables are normalized to have mean and Vx=1.
5610 */
5611 int lenbatch, i, j;
5612 double mxb, vxb = 0, E, m = 0, s = 0;
5613
5614 /* if(n<1000) puts("chain too short for calculating Eff? "); */
5615 /* normalize the x vector for numerical stability */
5616 for (i = 0; i < n; i++) m += x[i];
5617 m /= n;
5618 for (i = 0; i < n; i++) x[i] -= m;
5619 for (i = 0; i < n; i++) s += x[i] * x[i];
5620 s = sqrt(s / n);
5621 for (i = 0; i < n; i++) x[i] /= s;
5622 *mx = m; *vx = s*s;
5623
5624 lenbatch = n / nbatch;
5625 for (i = 0, vxb = 0; i < nbatch; i++) {
5626 for (j = 0, mxb = 0; j < lenbatch; j++)
5627 mxb += x[i*lenbatch + j];
5628 mxb /= lenbatch;
5629 vxb += mxb*mxb / nbatch;
5630 }
5631 E = 1 / (vxb*lenbatch);
5632 if (E*lenbatch < 1) puts("batch too short?");
5633 return(E);
5634 }
5635
5636
DescriptiveStatistics(FILE * fout,char infile[],int nbin,int propternary,int SkipColumns)5637 int DescriptiveStatistics(FILE *fout, char infile[], int nbin, int propternary, int SkipColumns)
5638 {
5639 /* This routine reads n records (observations) each of p continuous variables,
5640 to calculate summary statistics. It also uses kernel density estimation to
5641 smooth the histogram for each variable, as well as calculating 2-D densities
5642 for selected variable pairs. The smoothing used the kerney estimator, with
5643 both fixed window size and adaptive kernel smoothing using variable bandwiths.
5644 The kernel function is Epanechnikov. For 2-D smoothing, Fukunaga's transform is used
5645 (p.77 in B.W. Silverman 1986).
5646 */
5647 FILE *fin = gfopen(infile, "r");
5648 int n, p, i, j, k, jj, kk, nrho = 200;
5649 char *fmt = " %9.6f", *fmt1 = " %9.1f", timestr[32];
5650 double *data, *x, *mean, *median, *minx, *maxx, *x005, *x995, *x025, *x975, *xHPD025, *xHPD975, *var;
5651 double *Tint, tmp[2], d, rho1;
5652 double h, *y, *gap, *space, v2d[4];
5653 int nf2d = 0, ivar_f2d[MAXNF2D][2] = { {5,6},{0,2} }, k2d;
5654
5655 static int lline = 1000000, ifields[MAXNFIELDS], HasHeader = 1;
5656 char *line;
5657 static char varstr[MAXNFIELDS][32] = { "" };
5658
5659 if ((line = (char*)malloc(lline * sizeof(char))) == NULL) error2("oom ds");
5660 scanfile(fin, &n, &p, &HasHeader, line, ifields);
5661 printf("\n%d records, %d variables\n", n, p);
5662 data = (double*)malloc(p*n * sizeof(double));
5663 mean = (double*)malloc((p * 13 + p*p + n) * sizeof(double));
5664 if (data == NULL || mean == NULL) error2("oom DescriptiveStatistics.");
5665 memset(data, 0, p*n * sizeof(double));
5666 memset(mean, 0, (p * 13 + p*p + n) * sizeof(double));
5667 median = mean + p; minx = median + p; maxx = minx + p;
5668 x005 = maxx + p; x995 = x005 + p; x025 = x995 + p; x975 = x025 + p; xHPD025 = x975 + p; xHPD975 = xHPD025 + p;
5669 var = xHPD975 + p; gap = var + p*p, Tint = gap + p; y = Tint + p;
5670
5671 space = (double*)malloc((n + nbin*nbin * 3) * sizeof(double));
5672 if (space == NULL) { printf("not enough mem for %d variables\n", n); exit(-1); }
5673
5674 if (HasHeader)
5675 for (i = 0; i < p; i++) sscanf(line + ifields[i], "%s", varstr[i]);
5676 for (i = 0; i < n; i++)
5677 for (j = 0; j < p; j++)
5678 fscanf(fin, "%lf", &data[j*n + i]);
5679 fclose(fin);
5680 /*
5681 if(p>1) {
5682 printf("\nGreat offer! I can smooth a few 2-D densities for free. How many do you want? ");
5683 scanf("%d", &nf2d);
5684 }
5685 */
5686 if (nf2d > MAXNF2D) error2("I don't want to do that many!");
5687 for (i = 0; i < nf2d; i++) {
5688 printf("pair #%d (e.g., type 1 3 to use variables #1 and #3)? ", i + 1);
5689 scanf("%d%d", &ivar_f2d[i][0], &ivar_f2d[i][1]);
5690 ivar_f2d[i][0]--;
5691 ivar_f2d[i][1]--;
5692 }
5693
5694 printf("Collecting mean, median, min, max, percentiles, etc.\n");
5695 for (j = SkipColumns, x = data + j*n; j < p; j++, x += n) {
5696 memmove(y, x, n * sizeof(double));
5697 Tint[j] = 1 / Eff_IntegratedCorrelationTime(y, n, &mean[j], &var[j], &rho1);
5698 memmove(y, x, n * sizeof(double));
5699 qsort(y, (size_t)n, sizeof(double), comparedouble);
5700 minx[j] = y[0]; maxx[j] = y[n - 1];
5701 median[j] = (n % 2 == 0 ? (y[n/2 - 1] + y[n/2]) / 2 : y[n/2]);
5702 x005[j] = y[(int)(n*.005)]; x995[j] = y[(int)(n*.995)];
5703 x025[j] = y[(int)(n*.025)]; x975[j] = y[(int)(n*.975)];
5704
5705 HPDinterval(y, n, tmp, 0.05);
5706 xHPD025[j] = tmp[0];
5707 xHPD975[j] = tmp[1];
5708 if ((j + 1) % 2 == 0 || j == p - 1)
5709 printf("\r\t\t%6d/%6d done %s", j + 1, p, printtime(timestr));
5710 }
5711
5712 /* variance-covariance matrix */
5713 zero(var, p*p);
5714 for (j = SkipColumns; j < p; j++)
5715 for (k = SkipColumns; k <= j; k++)
5716 for (i = 0; i < n; i++)
5717 var[j*p + k] += (data[j*n + i] - mean[j]) * (data[k*n + i] - mean[k]);
5718 for (j = SkipColumns; j < p; j++)
5719 for (k = SkipColumns, var[j*p + j] /= (n - 1.0); k < j; k++)
5720 var[k*p + j] = var[j*p + k] /= (n - 1.0);
5721
5722 fprintf(fout, "\n(A) Descriptive statistics\n\n ");
5723 for (j = SkipColumns; j < p; j++) fprintf(fout, " %s", varstr[j]);
5724 fprintf(fout, "\nmean "); for (j = SkipColumns; j < p; j++) fprintf(fout, fmt, mean[j]);
5725 fprintf(fout, "\nmedian "); for (j = SkipColumns; j < p; j++) fprintf(fout, fmt, median[j]);
5726 fprintf(fout, "\nS.D. "); for (j = SkipColumns; j < p; j++) fprintf(fout, fmt, sqrt(var[j*p + j]));
5727 fprintf(fout, "\nmin "); for (j = SkipColumns; j < p; j++) fprintf(fout, fmt, minx[j]);
5728 fprintf(fout, "\nmax "); for (j = SkipColumns; j < p; j++) fprintf(fout, fmt, maxx[j]);
5729 fprintf(fout, "\n2.5%% "); for (j = SkipColumns; j < p; j++) fprintf(fout, fmt, x025[j]);
5730 fprintf(fout, "\n97.5%% "); for (j = SkipColumns; j < p; j++) fprintf(fout, fmt, x975[j]);
5731 fprintf(fout, "\n2.5%%HPD "); for (j = SkipColumns; j < p; j++) fprintf(fout, fmt, xHPD025[j]);
5732 fprintf(fout, "\n97.5%%HPD"); for (j = SkipColumns; j < p; j++) fprintf(fout, fmt, xHPD975[j]);
5733 fprintf(fout, "\nESS* "); for (j = SkipColumns; j < p; j++) fprintf(fout, fmt1, n / Tint[j]);
5734 fprintf(fout, "\nEff* "); for (j = SkipColumns; j < p; j++) fprintf(fout, fmt, 1 / Tint[j]);
5735
5736 fprintf(fout, "\n\n");
5737 fflush(fout);
5738
5739 return(0);
5740
5741 fprintf(fout, "\nCorrelation matrix");
5742 for (j = SkipColumns; j < p; j++) {
5743 fprintf(fout, "\n%-8s ", varstr[j]);
5744 for (k = SkipColumns; k <= j; k++)
5745 fprintf(fout, " %8.5f", var[k*p + j] / sqrt(var[j*p + j] * var[k*p + k]));
5746 }
5747 fprintf(fout, "\n ");
5748 for (j = SkipColumns; j < p; j++) fprintf(fout, "%9s", varstr[j]);
5749
5750 fprintf(fout, "\n\nHistograms and 1-D densities\n");
5751 for (jj = SkipColumns; jj < p; jj++) {
5752 memmove(y, data + jj*n, n * sizeof(double));
5753 qsort(y, (size_t)n, sizeof(double), comparedouble);
5754 fprintf(fout, "\n%s\nmidvalue freq f(x)\n\n", varstr[jj]);
5755 /* steplength for 1-d kernel density estimation, from Eq 3.24, 3.30, 3.31 */
5756 if (propternary) { minx[jj] = 0; maxx[jj] = 1; }
5757 gap[jj] = (maxx[jj] - minx[jj]) / nbin;
5758 d = sqrt(var[jj*p + jj]);
5759 h = ((y[(int)(n*.75)] - y[(int)(n*.25)]) / 1.34) * 0.9*pow((double)n, -0.2);
5760 h = min2(h, d);
5761 density1d(fout, y, n, nbin, minx[jj], gap[jj], h, space, propternary);
5762 printf(" variable %2d/%d (%s): %s%30s\r", jj + 1, p, varstr[jj], printtime(timestr), "");
5763 }
5764
5765 /* 2-D histogram and density */
5766 if (nf2d <= 0) return(0);
5767 h = 2.4*pow((double)n, -1 / 6.0);
5768 fprintf(fout, "\n2-D histogram and density\n");
5769 for (k2d = 0; k2d < nf2d; k2d++) {
5770 jj = min2(ivar_f2d[k2d][0], ivar_f2d[k2d][1]);
5771 kk = max2(ivar_f2d[k2d][0], ivar_f2d[k2d][1]);
5772 printf("2-D smoothing for variables %s & %s\n", varstr[jj], varstr[kk]);
5773 fprintf(fout, "\n%s\t%s\tfreq\tdensity\n\n", varstr[jj], varstr[kk]);
5774 v2d[0] = var[jj*p + jj];
5775 v2d[1] = v2d[2] = var[jj*p + kk];
5776 v2d[3] = var[kk*p + kk];
5777 density2d(fout, data + jj*n, data + kk*n, n, nbin, minx[jj], minx[kk], gap[jj], gap[kk], v2d, h, space, propternary);
5778 }
5779 free(data); free(mean); free(space); free(line);
5780 printf("\n%10s used\n", printtime(timestr));
5781 return(0);
5782 }
5783
5784 #undef MAXNFIELDS
5785
5786
5787
5788 /******************************************
5789 Minimization
5790 *******************************************/
5791
H_end(double x0[],double x1[],double f0,double f1,double e1,double e2,int n)5792 int H_end(double x0[], double x1[], double f0, double f1,
5793 double e1, double e2, int n)
5794 /* Himmelblau termination rule. return 1 for stop, 0 otherwise.
5795 */
5796 {
5797 double r;
5798 if ((r = norm(x0, n)) < e2)
5799 r = 1;
5800 r *= e1;
5801 if (distance(x1, x0, n) >= r)
5802 return(0);
5803 r = fabs(f0); if (r < e2) r = 1;
5804 r *= e1;
5805 if (fabs(f1 - f0) >= r)
5806 return(0);
5807 return (1);
5808 }
5809
5810 int AlwaysCenter = 0;
5811 double Small_Diff = 1e-6; /* reasonable values 1e-5, 1e-7 */
5812
gradient(int n,double x[],double f0,double g[],double (* fun)(double x[],int n),double space[],int Central)5813 int gradient(int n, double x[], double f0, double g[],
5814 double(*fun)(double x[], int n), double space[], int Central)
5815 {
5816 /* f0 = fun(x) is always given.
5817 */
5818 int i, j;
5819 double *x0 = space, *x1 = space + n, eh0 = Small_Diff, eh; /* 1e-7 */
5820
5821 if (Central) {
5822 for (i = 0; i < n; i++) {
5823 for (j = 0; j < n; j++)
5824 x0[j] = x1[j] = x[j];
5825 eh = pow(eh0*(fabs(x[i]) + 1), 0.67);
5826 x0[i] -= eh; x1[i] += eh;
5827 g[i] = ((*fun)(x1, n) - (*fun)(x0, n)) / (eh*2.0);
5828 }
5829 }
5830 else {
5831 for (i = 0; i < n; i++) {
5832 for (j = 0; j < n; j++)
5833 x1[j] = x[j];
5834 eh = eh0*(fabs(x[i]) + 1);
5835 x1[i] += eh;
5836 g[i] = ((*fun)(x1, n) - f0) / eh;
5837 }
5838 }
5839 return(0);
5840 }
5841
Hessian(int n,double x[],double f0,double g[],double H[],double (* fun)(double x[],int n),double space[])5842 int Hessian(int n, double x[], double f0, double g[], double H[],
5843 double(*fun)(double x[], int n), double space[])
5844 {
5845 /* Hessian matrix H[n*n] by the central difference method.
5846 # of function calls: 2*n*n
5847 */
5848 int i, j, k;
5849 double *x1 = space, *h = x1 + n, h0 = Small_Diff * 2; /* h0=1e-5 or 1e-6 */
5850 double fpp, fmm, fpm, fmp; /* p:+ m:- */
5851
5852 for (k = 0; k < n; k++) {
5853 h[k] = h0*(1 + fabs(x[k]));
5854 if (h[k] > x[k])
5855 printf("Hessian warning: x[%d] = %8.5g < h = %8.5g.\n", k + 1, x[k], h[k]);
5856 }
5857 for (i = 0; i < n; i++) {
5858 for (j = i; j < n; j++) {
5859 for (k = 0; k < n; k++) x1[k] = x[k];
5860 x1[i] += h[i];
5861 x1[j] += h[j];
5862 fpp = (*fun)(x1, n); /* (+hi, +hj) */
5863 x1[i] -= h[i] * 2;
5864 x1[j] -= h[j] * 2;
5865 fmm = (*fun)(x1, n); /* (-hi, -hj) */
5866 if (i == j) {
5867 H[i*n + i] = (fpp + fmm - 2 * f0) / (4 * h[i] * h[i]);
5868 g[i] = (fpp - fmm) / (h[i] * 4);
5869 }
5870 else {
5871 x1[i] += 2 * h[i]; fpm = (*fun)(x1, n); /* (+hi, -hj) */
5872 x1[i] -= 2 * h[i]; x1[j] += 2 * h[j]; fmp = (*fun)(x1, n); /* (-hi, +hj) */
5873 H[i*n + j] = H[j*n + i] = (fpp + fmm - fpm - fmp) / (4 * h[i] * h[j]);
5874 }
5875 }
5876 }
5877 return(0);
5878 }
5879
5880 int jacobi_gradient(double x[], double J[],
5881 int(*fun) (double x[], double y[], int nx, int ny),
5882 double space[], int nx, int ny);
5883
jacobi_gradient(double x[],double J[],int (* fun)(double x[],double y[],int nx,int ny),double space[],int nx,int ny)5884 int jacobi_gradient(double x[], double J[],
5885 int(*fun) (double x[], double y[], int nx, int ny),
5886 double space[], int nx, int ny)
5887 {
5888 /* Jacobi by central difference method
5889 J[ny][nx] space[2*nx+2*ny]
5890 */
5891 int i, j;
5892 double *x0 = space, *x1 = space + nx, *y0 = x1 + nx, *y1 = y0 + ny, eh0 = 1.0e-4, eh;
5893
5894 FOR(i, nx) {
5895 FOR(j, nx) x0[j] = x1[j] = x[j];
5896 eh = (x[i] == 0.0) ? eh0 : fabs(x[i])*eh0;
5897 x0[i] -= eh; x1[i] += eh;
5898 (*fun) (x0, y0, nx, ny);
5899 (*fun) (x1, y1, nx, ny);
5900 FOR(j, ny) J[j*nx + i] = (y1[j] - y0[j]) / (eh*2.0);
5901 }
5902 return(0);
5903 }
5904
nls2(FILE * fout,double * sx,double * x0,int nx,int (* fun)(double x[],double y[],int nx,int ny),int (* jacobi)(double x[],double J[],int nx,int ny),int (* testx)(double x[],int nx),int ny,double e)5905 int nls2(FILE *fout, double *sx, double * x0, int nx,
5906 int(*fun)(double x[], double y[], int nx, int ny),
5907 int(*jacobi)(double x[], double J[], int nx, int ny),
5908 int(*testx) (double x[], int nx),
5909 int ny, double e)
5910 {
5911 /* non-linear least squares: minimization of s=f(x)^2.
5912 by the damped NLS, or Levenberg-Marguard-Morrison(LMM) method.
5913 x[n] C[n,n+1] J[ny,n] y[ny] iworker[n]
5914 */
5915 int n = nx, ii, i, i1, j, istate = 0, increase = 0, maxround = 500, sspace;
5916 double s0 = 0.0, s = 0.0, t;
5917 double v = 0.0, vmax = 1.0 / e, bigger = 2.5, smaller = 0.75;
5918 /* v : Marguardt factor, suggested factors in SSL II (1.5,0.5) */
5919 double *x, *g, *p, *C, *J, *y, *space, *space_J;
5920
5921 sspace = (n*(n + 4 + ny) + ny + 2 * (n + ny)) * sizeof(double);
5922 if ((space = (double*)malloc(sspace)) == NULL) error2("oom in nls2");
5923 zero(space, n*(n + 4 + ny) + ny);
5924 x = space; g = x + n; p = g + n; C = p + n; J = C + n*(n + 1); y = J + ny*n; space_J = y + ny;
5925
5926 (*fun) (x0, y, n, ny);
5927 for (i = 0, s0 = 0; i < ny; i++) s0 += y[i] * y[i];
5928
5929 for (ii = 0; ii < maxround; ii++) {
5930 increase = 0;
5931 if (jacobi) (*jacobi) (x0, J, n, ny);
5932 else jacobi_gradient(x0, J, fun, space_J, n, ny);
5933
5934 if (ii == 0) {
5935 for (j = 0, t = 0; j < ny*n; j++)
5936 t += J[j] * J[j];
5937 v = sqrt(t) / (double)(ny*n); /* v = 0.0; */
5938 }
5939
5940 for (i = 0; i < n; i++) {
5941 for (j = 0, t = 0; j < ny; j++) t += J[j*n + i] * y[j];
5942 g[i] = 2 * t;
5943 C[i*(n + 1) + n] = -t;
5944 for (j = 0; j <= i; j++) {
5945 for (i1 = 0, t = 0; i1 < ny; i1++) t += J[i1*n + i] * J[i1*n + j];
5946 C[i*(n + 1) + j] = C[j*(n + 1) + i] = t;
5947 }
5948 C[i*(n + 1) + i] += v*v;
5949 }
5950
5951 if (matinv(C, n, n + 1, y + ny) == -1) {
5952 v *= bigger;
5953 continue;
5954 }
5955 for (i = 0; i < n; i++) p[i] = C[i*(n + 1) + n];
5956
5957 t = bound(n, x0, p, x, testx);
5958 if (t > 1) t = 1;
5959 for (i = 0; i < n; i++) x[i] = x0[i] + t * p[i];
5960
5961 (*fun) (x, y, n, ny);
5962 for (i = 0, s = 0; i < ny; i++) s += y[i] * y[i];
5963
5964 if (fout) {
5965 fprintf(fout, "\n%4d %10.6f", ii + 1, s);
5966 /* FOR(i,n) fprintf(fout,"%8.4f",x[i]); */
5967 }
5968 if (s0 < s) increase = 1;
5969 if (H_end(x0, x, s0, s, e, e, n)) break;
5970 if (increase) { v *= bigger; if (v > vmax) { istate = 1; break; } }
5971 else { v *= smaller; xtoy(x, x0, n); s0 = s; }
5972 } /* ii, maxround */
5973 if (increase) *sx = s0;
5974 else { *sx = s; xtoy(x, x0, n); }
5975 if (ii == maxround) istate = -1;
5976 free(space);
5977 return (istate);
5978 }
5979
5980
5981
bound(int nx,double x0[],double p[],double x[],int (* testx)(double x[],int nx))5982 double bound(int nx, double x0[], double p[], double x[], int(*testx)(double x[], int nx))
5983 {
5984 /* find largest t so that x[]=x0[]+t*p[] is still acceptable.
5985 for bounded minimization, p is possibly changed in this function
5986 using testx()
5987 */
5988 int i, nd = 0;
5989 double factor = 20, by = 1, smallv = 1e-8; /* small=(SIZEp>1?1e-7:1e-8) */
5990
5991 xtoy(x0, x, nx);
5992 for (i = 0; i < nx; i++) {
5993 x[i] = x0[i] + smallv*p[i];
5994 if ((*testx) (x, nx)) { p[i] = 0.0; nd++; }
5995 x[i] = x0[i];
5996 }
5997 if (nd == nx) { if (noisy) puts("bound:no move.."); return (0); }
5998
5999 for (by = 0.75; ; ) {
6000 for (i = 0; i < nx; i++) x[i] = x0[i] + factor*p[i];
6001 if ((*testx)(x, nx) == 0) break;
6002 factor *= by;
6003 }
6004 return(factor);
6005 }
6006
6007
6008
6009
LineSearch(double (* fun)(double x),double * f,double * x0,double xb[2],double step,double e)6010 double LineSearch(double(*fun)(double x), double *f, double *x0, double xb[2], double step, double e)
6011 {
6012 /* linear search using quadratic interpolation
6013
6014 From Wolfe M. A. 1978. Numerical methods for unconstrained
6015 optimization: An introduction. Van Nostrand Reinhold Company, New York.
6016 pp. 62-73.
6017 step is used to find the bracket (a1,a2,a3)
6018
6019 This is the same routine as LineSearch2(), but I have not got time
6020 to test and improve it properly. Ziheng note, September, 2002
6021 */
6022 int ii = 0, maxround = 100, i;
6023 double factor = 2, step1, percentUse = 0;
6024 double a0, a1, a2, a3, a4 = -1, a5, a6, f0, f1, f2, f3, f4 = -1, f5, f6;
6025
6026 /* find a bracket (a1,a2,a3) with function values (f1,f2,f3)
6027 so that a1<a2<a3 and f2<f1 and f2<f3
6028 */
6029
6030 if (step <= 0) return(*x0);
6031 a0 = a1 = a2 = a3 = f0 = f1 = f2 = f3 = -1;
6032 if (*x0<xb[0] || *x0>xb[1])
6033 error2("err LineSearch: x0 out of range");
6034 f2 = f0 = fun(a2 = a0 = *x0);
6035 step1 = min2(step, (a0 - xb[0]) / 4);
6036 step1 = max2(step1, e);
6037 for (i = 0, a1 = a0, f1 = f0; ; i++) {
6038 a1 -= (step1 *= factor);
6039 if (a1 > xb[0]) {
6040 f1 = fun(a1);
6041 if (f1 > f2) break;
6042 else {
6043 a3 = a2; f3 = f2; a2 = a1; f2 = f1;
6044 }
6045 }
6046 else {
6047 a1 = xb[0]; f1 = fun(a1);
6048 if (f1 <= f2) { a2 = a1; f2 = f1; }
6049 break;
6050 }
6051
6052 /* if(noisy>2) printf("\ta = %.6f\tf = %.6f %5d\n", a2, f2, NFunCall);
6053 */
6054
6055 }
6056
6057 if (i == 0) { /* *x0 is the best point during the previous search */
6058 step1 = min2(step, (xb[1] - a0) / 4);
6059 for (i = 0, a3 = a2, f3 = f2; ; i++) {
6060 a3 += (step1 *= factor);
6061 if (a3 < xb[1]) {
6062 f3 = fun(a3);
6063 if (f3 > f2) break;
6064 else
6065 {
6066 a1 = a2; f1 = f2; a2 = a3; f2 = f3;
6067 }
6068 }
6069 else {
6070 a3 = xb[1]; f3 = fun(a3);
6071 if (f3 < f2) { a2 = a3; f2 = f3; }
6072 break;
6073 }
6074
6075 if (noisy > 2) printf("\ta = %.6f\tf = %.6f %5d\n", a3, f3, NFunCall);
6076
6077 }
6078 }
6079
6080 /* iteration by quadratic interpolation, fig 2.2.9-10 (pp 71-71) */
6081 for (ii = 0; ii < maxround; ii++) {
6082 /* a4 is the minimum from the parabola over (a1,a2,a3) */
6083
6084 if (a1 > a2 + 1e-99 || a3<a2 - 1e-99 || f2>f1 + 1e-99 || f2 > f3 + 1e-99) /* for linux */
6085 {
6086 printf("\npoints out of order (ii=%d)!", ii + 1); break;
6087 }
6088
6089 a4 = (a2 - a3)*f1 + (a3 - a1)*f2 + (a1 - a2)*f3;
6090 if (fabs(a4) > 1e-100)
6091 a4 = ((a2*a2 - a3*a3)*f1 + (a3*a3 - a1*a1)*f2 + (a1*a1 - a2*a2)*f3) / (2 * a4);
6092 if (a4 > a3 || a4 < a1) a4 = (a1 + a2) / 2; /* out of range */
6093 else percentUse++;
6094 f4 = fun(a4);
6095
6096 /*
6097 if (noisy>2) printf("\ta = %.6f\tf = %.6f %5d\n", a4, f4, NFunCall);
6098 */
6099
6100 if (fabs(f2 - f4)*(1 + fabs(f2)) <= e && fabs(a2 - a4)*(1 + fabs(a2)) <= e) break;
6101
6102 if (a1 <= a4 && a4 <= a2) { /* fig 2.2.10 */
6103 if (fabs(a2 - a4) > .2*fabs(a1 - a2)) {
6104 if (f1 >= f4 && f4 <= f2) { a3 = a2; a2 = a4; f3 = f2; f2 = f4; }
6105 else { a1 = a4; f1 = f4; }
6106 }
6107 else {
6108 if (f4 > f2) {
6109 a5 = (a2 + a3) / 2; f5 = fun(a5);
6110 if (f5 > f2) { a1 = a4; a3 = a5; f1 = f4; f3 = f5; }
6111 else { a1 = a2; a2 = a5; f1 = f2; f2 = f5; }
6112 }
6113 else {
6114 a5 = (a1 + a4) / 2; f5 = fun(a5);
6115 if (f5 >= f4 && f4 <= f2)
6116 {
6117 a3 = a2; a2 = a4; a1 = a5; f3 = f2; f2 = f4; f1 = f5;
6118 }
6119 else {
6120 a6 = (a1 + a5) / 2; f6 = fun(a6);
6121 if (f6 > f5)
6122 {
6123 a1 = a6; a2 = a5; a3 = a4; f1 = f6; f2 = f5; f3 = f4;
6124 }
6125 else { a2 = a6; a3 = a5; f2 = f6; f3 = f5; }
6126 }
6127 }
6128 }
6129 }
6130 else { /* fig 2.2.9 */
6131 if (fabs(a2 - a4) > .2*fabs(a2 - a3)) {
6132 if (f2 >= f4 && f4 <= f3) { a1 = a2; a2 = a4; f1 = f2; f2 = f4; }
6133 else { a3 = a4; f3 = f4; }
6134 }
6135 else {
6136 if (f4 > f2) {
6137 a5 = (a1 + a2) / 2; f5 = fun(a5);
6138 if (f5 > f2) { a1 = a5; a3 = a4; f1 = f5; f3 = f4; }
6139 else { a3 = a2; a2 = a5; f3 = f2; f2 = f5; }
6140 }
6141 else {
6142 a5 = (a3 + a4) / 2; f5 = fun(a5);
6143 if (f2 >= f4 && f4 <= f5)
6144 {
6145 a1 = a2; a2 = a4; a3 = a5; f1 = f2; f2 = f4; f3 = f5;
6146 }
6147 else {
6148 a6 = (a3 + a5) / 2; f6 = fun(a6);
6149 if (f6 > f5)
6150 {
6151 a1 = a4; a2 = a5; a3 = a6; f1 = f4; f2 = f5; f3 = f6;
6152 }
6153 else { a1 = a5; a2 = a6; f1 = f5; f2 = f6; }
6154 }
6155 }
6156 }
6157 }
6158 } /* for (ii) */
6159 if (f2 <= f4) { *f = f2; a4 = a2; }
6160 else *f = f4;
6161
6162 return (*x0 = (a4 + a2) / 2);
6163 }
6164
6165
6166
6167 double fun_LineSearch(double t, double(*fun)(double x[], int n),
6168 double x0[], double p[], double x[], int n);
6169
fun_LineSearch(double t,double (* fun)(double x[],int n),double x0[],double p[],double x[],int n)6170 double fun_LineSearch(double t, double(*fun)(double x[], int n),
6171 double x0[], double p[], double x[], int n)
6172 {
6173 int i; FOR(i, n) x[i] = x0[i] + t*p[i]; return((*fun)(x, n));
6174 }
6175
6176
6177
LineSearch2(double (* fun)(double x[],int n),double * f,double x0[],double p[],double step,double limit,double e,double space[],int n)6178 double LineSearch2(double(*fun)(double x[], int n), double *f, double x0[],
6179 double p[], double step, double limit, double e, double space[], int n)
6180 {
6181 /* linear search using quadratic interpolation
6182 from x0[] in the direction of p[],
6183 x = x0 + a*p a ~(0,limit)
6184 returns (a). *f: f(x0) for input and f(x) for output
6185
6186 x0[n] x[n] p[n] space[n]
6187
6188 adapted from Wolfe M. A. 1978. Numerical methods for unconstrained
6189 optimization: An introduction. Van Nostrand Reinhold Company, New York.
6190 pp. 62-73.
6191 step is used to find the bracket and is increased or reduced as necessary,
6192 and is not terribly important.
6193 */
6194 int ii = 0, maxround = 10, status, i, nsymb = 0;
6195 double *x = space, factor = 4, smallv = 1e-10, smallgapa = 0.2;
6196 double a0, a1, a2, a3, a4 = -1, a5, a6, f0, f1, f2, f3, f4 = -1, f5, f6;
6197
6198 /* look for bracket (a1, a2, a3) with function values (f1, f2, f3)
6199 step length step given, and only in the direction a>=0
6200 */
6201
6202 if (noisy > 2)
6203 printf("\n%3d h-m-p %7.4f %6.4f %8.4f ", Iround + 1, step, limit, norm(p, n));
6204
6205 if (step <= 0 || limit < smallv || step >= limit) {
6206 if (noisy > 2)
6207 printf("\nh-m-p:%20.8e%20.8e%20.8e %12.6f\n", step, limit, norm(p, n), *f);
6208 return (0);
6209 }
6210 a0 = a1 = 0; f1 = f0 = *f;
6211 a2 = a0 + step; f2 = fun_LineSearch(a2, fun, x0, p, x, n);
6212 if (f2 > f1) { /* reduce step length so the algorithm is decreasing */
6213 for (; ;) {
6214 step /= factor;
6215 if (step < smallv) return (0);
6216 a3 = a2; f3 = f2;
6217 a2 = a0 + step; f2 = fun_LineSearch(a2, fun, x0, p, x, n);
6218 if (f2 <= f1) break;
6219 if (!PAML_RELEASE && noisy > 2) { printf("-"); nsymb++; }
6220 }
6221 }
6222 else { /* step length is too small? */
6223 for (; ;) {
6224 step *= factor;
6225 if (step > limit) step = limit;
6226 a3 = a0 + step; f3 = fun_LineSearch(a3, fun, x0, p, x, n);
6227 if (f3 >= f2) break;
6228
6229 if (!PAML_RELEASE && noisy > 2) { printf("+"); nsymb++; }
6230 a1 = a2; f1 = f2; a2 = a3; f2 = f3;
6231 if (step >= limit) {
6232 if (!PAML_RELEASE && noisy > 2) for (; nsymb < 5; nsymb++) printf(" ");
6233 if (noisy > 2) printf(" %12.6f%3c %6.4f %5d", *f = f3, 'm', a3, NFunCall);
6234 *f = f3; return(a3);
6235 }
6236 }
6237 }
6238
6239 /* iteration by quadratic interpolation, fig 2.2.9-10 (pp 71-71) */
6240 for (ii = 0; ii < maxround; ii++) {
6241 /* a4 is the minimum from the parabola over (a1,a2,a3) */
6242 a4 = (a2 - a3)*f1 + (a3 - a1)*f2 + (a1 - a2)*f3;
6243 if (fabs(a4) > 1e-100)
6244 a4 = ((a2*a2 - a3*a3)*f1 + (a3*a3 - a1*a1)*f2 + (a1*a1 - a2*a2)*f3) / (2 * a4);
6245 if (a4 > a3 || a4 < a1) { /* out of range */
6246 a4 = (a1 + a2) / 2;
6247 status = 'N';
6248 }
6249 else {
6250 if ((a4 <= a2 && a2 - a4 > smallgapa*(a2 - a1)) || (a4 > a2 && a4 - a2 > smallgapa*(a3 - a2)))
6251 status = 'Y';
6252 else
6253 status = 'C';
6254 }
6255 f4 = fun_LineSearch(a4, fun, x0, p, x, n);
6256 if (!PAML_RELEASE && noisy > 2) putchar(status);
6257 if (fabs(f2 - f4) < e*(1 + fabs(f2))) {
6258 if (!PAML_RELEASE && noisy > 2)
6259 for (nsymb += ii + 1; nsymb < 5; nsymb++) printf(" ");
6260 break;
6261 }
6262
6263 /* possible multiple local optima during line search */
6264 if (!PAML_RELEASE && noisy > 2 && ((a4<a2&&f4>f1) || (a4 > a2&&f4 > f3))) {
6265 printf("\n\na %12.6f %12.6f %12.6f %12.6f", a1, a2, a3, a4);
6266 printf("\nf %12.6f %12.6f %12.6f %12.6f\n", f1, f2, f3, f4);
6267
6268 for (a5 = a1; a5 <= a3; a5 += (a3 - a1) / 20) {
6269 printf("\t%.6e ", a5);
6270 if (n < 5) FOR(i, n) printf("\t%.6f", x0[i] + a5*p[i]);
6271 printf("\t%.6f\n", fun_LineSearch(a5, fun, x0, p, x, n));
6272 }
6273 puts("Linesearch2 a4: multiple optima?");
6274 }
6275 if (a4 <= a2) { /* fig 2.2.10 */
6276 if (a2 - a4 > smallgapa*(a2 - a1)) {
6277 if (f4 <= f2) { a3 = a2; a2 = a4; f3 = f2; f2 = f4; }
6278 else { a1 = a4; f1 = f4; }
6279 }
6280 else {
6281 if (f4 > f2) {
6282 a5 = (a2 + a3) / 2; f5 = fun_LineSearch(a5, fun, x0, p, x, n);
6283 if (f5 > f2) { a1 = a4; a3 = a5; f1 = f4; f3 = f5; }
6284 else { a1 = a2; a2 = a5; f1 = f2; f2 = f5; }
6285 }
6286 else {
6287 a5 = (a1 + a4) / 2; f5 = fun_LineSearch(a5, fun, x0, p, x, n);
6288 if (f5 >= f4)
6289 {
6290 a3 = a2; a2 = a4; a1 = a5; f3 = f2; f2 = f4; f1 = f5;
6291 }
6292 else {
6293 a6 = (a1 + a5) / 2; f6 = fun_LineSearch(a6, fun, x0, p, x, n);
6294 if (f6 > f5)
6295 {
6296 a1 = a6; a2 = a5; a3 = a4; f1 = f6; f2 = f5; f3 = f4;
6297 }
6298 else { a2 = a6; a3 = a5; f2 = f6; f3 = f5; }
6299 }
6300 }
6301 }
6302 }
6303 else { /* fig 2.2.9 */
6304 if (a4 - a2 > smallgapa*(a3 - a2)) {
6305 if (f2 >= f4) { a1 = a2; a2 = a4; f1 = f2; f2 = f4; }
6306 else { a3 = a4; f3 = f4; }
6307 }
6308 else {
6309 if (f4 > f2) {
6310 a5 = (a1 + a2) / 2; f5 = fun_LineSearch(a5, fun, x0, p, x, n);
6311 if (f5 > f2) { a1 = a5; a3 = a4; f1 = f5; f3 = f4; }
6312 else { a3 = a2; a2 = a5; f3 = f2; f2 = f5; }
6313 }
6314 else {
6315 a5 = (a3 + a4) / 2; f5 = fun_LineSearch(a5, fun, x0, p, x, n);
6316 if (f5 >= f4)
6317 {
6318 a1 = a2; a2 = a4; a3 = a5; f1 = f2; f2 = f4; f3 = f5;
6319 }
6320 else {
6321 a6 = (a3 + a5) / 2; f6 = fun_LineSearch(a6, fun, x0, p, x, n);
6322 if (f6 > f5)
6323 {
6324 a1 = a4; a2 = a5; a3 = a6; f1 = f4; f2 = f5; f3 = f6;
6325 }
6326 else { a1 = a5; a2 = a6; f1 = f5; f2 = f6; }
6327 }
6328 }
6329 }
6330 }
6331 }
6332
6333 if (f2 > f0 && f4 > f0) a4 = 0;
6334 if (f2 <= f4) { *f = f2; a4 = a2; }
6335 else *f = f4;
6336 if (noisy > 2) printf(" %12.6f%3d %6.4f %5d", *f, ii, a4, NFunCall);
6337
6338 return (a4);
6339 }
6340
6341
6342
6343
6344 #define Safeguard_Newton
6345
6346
Newton(FILE * fout,double * f,double (* fun)(double x[],int n),int (* ddfun)(double x[],double * fx,double dx[],double ddx[],int n),int (* testx)(double x[],int n),double x0[],double space[],double e,int n)6347 int Newton(FILE *fout, double *f, double(*fun)(double x[], int n),
6348 int(*ddfun) (double x[], double *fx, double dx[], double ddx[], int n),
6349 int(*testx) (double x[], int n),
6350 double x0[], double space[], double e, int n)
6351 {
6352 int i, j, maxround = 500;
6353 double f0 = 1e40, smallv = 1e-10, h, SIZEp, t, *H, *x, *g, *p, *tv;
6354
6355 H = space, x = H + n*n; g = x + n; p = g + n, tv = p + n;
6356
6357 printf("\n\nIterating by Newton\tnp:%6d\nInitial:", n);
6358 for (i = 0; i < n; i++) printf("%8.4f", x0[i]); printf("\n");
6359 if (fout) fprintf(fout, "\n\nNewton\tnp:%6d\n", n);
6360 if (testx(x0, n)) error2("Newton..invalid initials.");
6361 FOR(Iround, maxround) {
6362 if (ddfun)
6363 (*ddfun) (x0, f, g, H, n);
6364 else {
6365 *f = (*fun)(x0, n);
6366 Hessian(n, x0, *f, g, H, fun, tv);
6367 }
6368 matinv(H, n, n, tv);
6369 FOR(i, n) for (j = 0, p[i] = 0; j < n; j++) p[i] -= H[i*n + j] * g[j];
6370
6371 h = bound(n, x0, p, tv, testx);
6372 t = min2(h, 1);
6373 SIZEp = norm(p, n);
6374
6375 #ifdef Safeguard_Newton
6376 if (SIZEp > 4) {
6377 while (t > smallv) {
6378 FOR(i, n) x[i] = x0[i] + t*p[i];
6379 if ((*f = fun(x, n)) < f0) break;
6380 else t /= 2;
6381 }
6382 }
6383 if (t < smallv) t = min2(h, .5);
6384 #endif
6385
6386 FOR(i, n) x[i] = x0[i] + t*p[i];
6387 if (noisy > 2) {
6388 printf("\n%3d h:%7.4f %12.6f x", Iround + 1, SIZEp, *f);
6389 FOR(i, n) printf("%7.4f ", x0[i]);
6390 }
6391 if (fout) {
6392 fprintf(fout, "\n%3d h:%7.4f%12.6f x", Iround + 1, SIZEp, *f);
6393 FOR(i, n) fprintf(fout, "%7.4f ", x0[i]);
6394 fflush(fout);
6395 }
6396 if ((h = norm(x0, n)) < e) h = 1;
6397 if (SIZEp < 0.01 && distance(x, x0, n) < h*e) break;
6398
6399 f0 = *f;
6400 xtoy(x, x0, n);
6401 }
6402 xtoy(x, x0, n); *f = fun(x0, n);
6403
6404 if (Iround == maxround) return(-1);
6405 return(0);
6406 }
6407
6408
6409 int gradientB(int n, double x[], double f0, double g[],
6410 double(*fun)(double x[], int n), double space[], int xmark[]);
6411
6412 extern int noisy, Iround;
6413 extern double SIZEp;
6414
gradientB(int n,double x[],double f0,double g[],double (* fun)(double x[],int n),double space[],int xmark[])6415 int gradientB(int n, double x[], double f0, double g[],
6416 double(*fun)(double x[], int n), double space[], int xmark[])
6417 {
6418 /* f0=fun(x) is always provided.
6419 xmark=0: central; 1: upper; -1: down
6420 */
6421 int i, j;
6422 double *x0 = space, *x1 = space + n, eh0 = Small_Diff, eh; /* eh0=1e-6 || 1e-7 */
6423
6424 for (i = 0; i < n; i++) {
6425 eh = eh0*(fabs(x[i]) + 1);
6426 if (xmark[i] == 0 && (AlwaysCenter || SIZEp < 1)) { /* central */
6427 for (j = 0; j < n; j++) x0[j] = x1[j] = x[j];
6428 eh = pow(eh, .67); x0[i] -= eh; x1[i] += eh;
6429 g[i] = ((*fun)(x1, n) - (*fun)(x0, n)) / (eh*2.0);
6430 }
6431 else { /* forward or backward */
6432 for (j = 0; j < n; j++) x1[j] = x[j];
6433 if (xmark[i]) eh *= -xmark[i];
6434 x1[i] += eh;
6435 g[i] = ((*fun)(x1, n) - f0) / eh;
6436 }
6437 }
6438 return(0);
6439 }
6440
6441 #define BFGS
6442 /*
6443 #define SR1
6444 #define DFP
6445 */
6446
6447 extern FILE *frst;
6448
ming2(FILE * fout,double * f,double (* fun)(double x[],int n),int (* dfun)(double x[],double * f,double dx[],int n),double x[],double xb[][2],double space[],double e,int n)6449 int ming2(FILE *fout, double *f, double(*fun)(double x[], int n),
6450 int(*dfun)(double x[], double *f, double dx[], int n),
6451 double x[], double xb[][2], double space[], double e, int n)
6452 {
6453 /* n-variate minimization with bounds using the BFGS algorithm
6454 g0[n] g[n] p[n] x0[n] y[n] s[n] z[n] H[n*n] C[n*n] tv[2*n]
6455 xmark[n],ix[n]
6456 Size of space should be (check carefully?)
6457 #define spaceming2(n) ((n)*((n)*2+9+2)*sizeof(double))
6458 nfree: # free variables
6459 xmark[i]=0 for inside space; -1 for lower boundary; 1 for upper boundary.
6460 x[] has initial values at input and returns the estimates in return.
6461 ix[i] specifies the i-th free parameter
6462
6463 */
6464 int i, j, i1, i2, it, maxround = 10000, fail = 0, *xmark, *ix, nfree;
6465 int Ngoodtimes = 2, goodtimes = 0;
6466 double smallv = 1.e-30, sizep0 = 0; /* small value for checking |w|=0 */
6467 double f0, *g0, *g, *p, *x0, *y, *s, *z, *H, *C, *tv;
6468 double w, v, alpha, am, h, maxstep = 8;
6469
6470 if (n == 0) return(0);
6471 g0 = space; g = g0 + n; p = g + n; x0 = p + n;
6472 y = x0 + n; s = y + n; z = s + n; H = z + n; C = H + n*n, tv = C + n*n;
6473 xmark = (int*)(tv + 2 * n); ix = xmark + n;
6474
6475 for (i = 0; i < n; i++) { xmark[i] = 0; ix[i] = i; }
6476 for (i = 0, nfree = 0; i < n; i++) {
6477 if (x[i] <= xb[i][0]) { x[i] = xb[i][0]; xmark[i] = -1; continue; }
6478 if (x[i] >= xb[i][1]) { x[i] = xb[i][1]; xmark[i] = 1; continue; }
6479 ix[nfree++] = i;
6480 }
6481 if (noisy > 2 && nfree < n && n < 50) {
6482 printf("\n"); FOR(j, n) printf(" %9.6f", x[j]); printf("\n");
6483 FOR(j, n) printf(" %9.5f", xb[j][0]); printf("\n");
6484 FOR(j, n) printf(" %9.5f", xb[j][1]); printf("\n");
6485 if (nfree < n && noisy >= 3) printf("warning: ming2, %d paras at boundary.", n - nfree);
6486 }
6487
6488 f0 = *f = (*fun)(x, n);
6489 xtoy(x, x0, n);
6490 SIZEp = 99;
6491 if (noisy > 2) {
6492 printf("\nIterating by ming2\nInitial: fx= %12.6f\nx=", f0);
6493 FOR(i, n) printf(" %8.5f", x[i]); printf("\n");
6494 }
6495
6496 if (dfun) (*dfun) (x0, &f0, g0, n);
6497 else gradientB(n, x0, f0, g0, fun, tv, xmark);
6498
6499 identity(H, nfree);
6500 for (Iround = 0; Iround < maxround; Iround++) {
6501 if (fout) {
6502 fprintf(fout, "\n%3d %7.4f %13.6f x: ", Iround, sizep0, f0);
6503 FOR(i, n) fprintf(fout, "%8.5f ", x0[i]);
6504 fflush(fout);
6505 }
6506
6507 for (i = 0, zero(p, n); i < nfree; i++) FOR(j, nfree)
6508 p[ix[i]] -= H[i*nfree + j] * g0[ix[j]];
6509 sizep0 = SIZEp;
6510 SIZEp = norm(p, n); /* check this */
6511
6512 for (i = 0, am = maxstep; i < n; i++) { /* max step length */
6513 if (p[i] > 0 && (xb[i][1] - x0[i]) / p[i] < am) am = (xb[i][1] - x0[i]) / p[i];
6514 else if (p[i] < 0 && (xb[i][0] - x0[i]) / p[i] < am) am = (xb[i][0] - x0[i]) / p[i];
6515 }
6516
6517 if (Iround == 0) {
6518 h = fabs(2 * f0*.01 / innerp(g0, p, n)); /* check this?? */
6519 h = min2(h, am / 2000);
6520
6521 }
6522 else {
6523 h = norm(s, nfree) / SIZEp;
6524 h = max2(h, am / 500);
6525 }
6526 h = max2(h, 1e-5); h = min2(h, am / 5);
6527 *f = f0;
6528 alpha = LineSearch2(fun, f, x0, p, h, am, min2(1e-3, e), tv, n); /* n or nfree? */
6529
6530 if (alpha <= 0) {
6531 if (fail) {
6532 if (AlwaysCenter) { Iround = maxround; break; }
6533 else { AlwaysCenter = 1; identity(H, n); fail = 1; }
6534 }
6535 else
6536 {
6537 if (noisy > 2) printf(".. "); identity(H, nfree); fail = 1;
6538 }
6539 }
6540 else {
6541 fail = 0;
6542 FOR(i, n) x[i] = x0[i] + alpha*p[i];
6543 w = min2(2, e * 1000); if (e<1e-4 && e>1e-6) w = 0.01;
6544
6545 if (Iround == 0 || SIZEp < sizep0 || (SIZEp < .001 && sizep0 < .001)) goodtimes++;
6546 else goodtimes = 0;
6547 if ((n == 1 || goodtimes >= Ngoodtimes) && SIZEp < (e > 1e-5 ? 1 : .001)
6548 && H_end(x0, x, f0, *f, e, e, n))
6549 break;
6550 }
6551 if (dfun)
6552 (*dfun) (x, f, g, n);
6553 else
6554 gradientB(n, x, *f, g, fun, tv, xmark);
6555 /*
6556 for(i=0; i<n; i++) fprintf(frst,"%9.5f", x[i]); fprintf(frst, "%6d",AlwaysCenter);
6557 for(i=0; i<n; i++) fprintf(frst,"%9.2f", g[i]); fprintf(frst, "\n");
6558 */
6559 /* modify the working set */
6560 for (i = 0; i < n; i++) { /* add constraints, reduce H */
6561 if (xmark[i]) continue;
6562 if (fabs(x[i] - xb[i][0]) < 1e-6 && -g[i] < 0) xmark[i] = -1;
6563 else if (fabs(x[i] - xb[i][1]) < 1e-6 && -g[i] > 0) xmark[i] = 1;
6564 if (xmark[i] == 0) continue;
6565 xtoy(H, C, nfree*nfree);
6566 for (it = 0; it < nfree; it++) if (ix[it] == i) break;
6567 for (i1 = it; i1 < nfree - 1; i1++) ix[i1] = ix[i1 + 1];
6568 for (i1 = 0, nfree--; i1 < nfree; i1++) FOR(i2, nfree)
6569 H[i1*nfree + i2] = C[(i1 + (i1 >= it))*(nfree + 1) + i2 + (i2 >= it)];
6570 }
6571 for (i = 0, it = 0, w = 0; i < n; i++) { /* delete a constraint, enlarge H */
6572 if (xmark[i] == -1 && -g[i] > w) { it = i; w = -g[i]; }
6573 else if (xmark[i] == 1 && -g[i] < -w) { it = i; w = g[i]; }
6574 }
6575 if (w > 10 * SIZEp / nfree) { /* *** */
6576 xtoy(H, C, nfree*nfree);
6577 FOR(i1, nfree) FOR(i2, nfree) H[i1*(nfree + 1) + i2] = C[i1*nfree + i2];
6578 FOR(i1, nfree + 1) H[i1*(nfree + 1) + nfree] = H[nfree*(nfree + 1) + i1] = 0;
6579 H[(nfree + 1)*(nfree + 1) - 1] = 1;
6580 xmark[it] = 0; ix[nfree++] = it;
6581 }
6582
6583 if (noisy > 2) {
6584 printf(" | %d/%d", n - nfree, n);
6585 /* FOR (i,n) if (xmark[i]) printf ("%4d", i+1); */
6586 }
6587 for (i = 0, f0 = *f; i < nfree; i++)
6588 {
6589 y[i] = g[ix[i]] - g0[ix[i]]; s[i] = x[ix[i]] - x0[ix[i]];
6590 }
6591 FOR(i, n) { g0[i] = g[i]; x0[i] = x[i]; }
6592
6593
6594 /* renewal of H varies with different algorithms */
6595 #if (defined SR1)
6596 /* Symmetrical Rank One (Broyden, C. G., 1967) */
6597 for (i = 0, w = .0; i < nfree; i++) {
6598 for (j = 0, v = .0; j < nfree; j++) v += H[i*nfree + j] * y[j];
6599 z[i] = s[i] - v;
6600 w += y[i] * z[i];
6601 }
6602 if (fabs(w) < smallv) { identity(H, nfree); fail = 1; continue; }
6603 FOR(i, nfree) FOR(j, nfree) H[i*nfree + j] += z[i] * z[j] / w;
6604 #elif (defined DFP)
6605 /* Davidon (1959), Fletcher and Powell (1963). */
6606 for (i = 0, w = v = 0.; i < nfree; i++) {
6607 for (j = 0, z[i] = 0; j < nfree; j++) z[i] += H[i*nfree + j] * y[j];
6608 w += y[i] * z[i]; v += y[i] * s[i];
6609 }
6610 if (fabs(w) < smallv || fabs(v) < smallv) { identity(H, nfree); fail = 1; continue; }
6611 FOR(i, nfree) FOR(j, nfree)
6612 H[i*nfree + j] += s[i] * s[j] / v - z[i] * z[j] / w;
6613 #else /* BFGS */
6614 for (i = 0, w = v = 0.; i < nfree; i++) {
6615 for (j = 0, z[i] = 0.; j < nfree; j++) z[i] += H[i*nfree + j] * y[j];
6616 w += y[i] * z[i]; v += y[i] * s[i];
6617 }
6618 if (fabs(v) < smallv) { identity(H, nfree); fail = 1; continue; }
6619 FOR(i, nfree) FOR(j, nfree)
6620 H[i*nfree + j] += ((1 + w / v)*s[i] * s[j] - z[i] * s[j] - s[i] * z[j]) / v;
6621 #endif
6622 } /* for (Iround,maxround) */
6623
6624 /* try to remove this after updating LineSearch2() */
6625 *f = (*fun)(x, n);
6626 if (noisy > 2) printf("\n");
6627
6628 if (Iround == maxround) {
6629 if (fout) fprintf(fout, "\ncheck convergence!\n");
6630 return(-1);
6631 }
6632 if (nfree == n) {
6633 xtoy(H, space, n*n); /* H has variance matrix, or inverse of Hessian */
6634 return(1);
6635 }
6636 return(0);
6637 }
6638
6639
6640
ming1(FILE * fout,double * f,double (* fun)(double x[],int n),int (* dfun)(double x[],double * f,double dx[],int n),int (* testx)(double x[],int n),double x0[],double space[],double e,int n)6641 int ming1(FILE *fout, double *f, double(*fun)(double x[], int n),
6642 int(*dfun) (double x[], double *f, double dx[], int n),
6643 int(*testx) (double x[], int n),
6644 double x0[], double space[], double e, int n)
6645 {
6646 /* n-D minimization using quasi-Newton or conjugate gradient algorithms,
6647 using function and its gradient.
6648
6649 g0[n] g[n] p[n] x[n] y[n] s[n] z[n] H[n*n] tv[2*n]
6650 using bound()
6651 */
6652 int i, j, maxround = 1000, fail = 0;
6653 double smallv = 1.e-20; /* small value for checking |w|=0 */
6654 double f0, *g0, *g, *p, *x, *y, *s, *z, *H, *tv;
6655 double w, v, t, h;
6656
6657 if (testx(x0, n))
6658 {
6659 printf("\nInvalid initials..\n"); matout(F0, x0, 1, n); return(-1);
6660 }
6661 f0 = *f = (*fun)(x0, n);
6662
6663 if (noisy > 2) {
6664 printf("\n\nIterating by ming1\nInitial: fx= %12.6f\nx=", f0);
6665 for (i = 0; i < n; i++) printf("%8.4f", x0[i]); printf("\n");
6666 }
6667 if (fout) {
6668 fprintf(fout, "\n\nIterating by ming1\nInitial: fx= %12.6f\nx=", f0);
6669 for (i = 0; i < n; i++) fprintf(fout, "%10.6f", x0[i]);
6670 }
6671 g0 = space; g = g0 + n; p = g + n; x = p + n;
6672 y = x + n; s = y + n; z = s + n; H = z + n; tv = H + n*n;
6673 if (dfun) (*dfun) (x0, &f0, g0, n);
6674 else gradient(n, x0, f0, g0, fun, tv, AlwaysCenter);
6675
6676 SIZEp = 0; xtoy(x0, x, n); xtoy(g0, g, n); identity(H, n);
6677 FOR(Iround, maxround) {
6678 FOR(i, n) for (j = 0, p[i] = 0.; j < n; j++) p[i] -= H[i*n + j] * g[j];
6679 t = bound(n, x0, p, tv, testx);
6680
6681 if (Iround == 0) h = fabs(2 * f0*.01 / innerp(g, p, n));
6682 else h = norm(s, n) / SIZEp;
6683 h = max2(h, 1e-5); h = min2(h, t / 8);
6684 SIZEp = norm(p, n);
6685
6686 t = LineSearch2(fun, f, x0, p, h, t, .00001, tv, n);
6687
6688 if (t <= 0 || *f <= 0 || *f > 1e32) {
6689 if (fail) {
6690 if (SIZEp > .1 && noisy > 2)
6691 printf("\nSIZEp:%9.4f Iround:%5d", SIZEp, Iround + 1);
6692 if (AlwaysCenter) { Iround = maxround; break; }
6693 else { AlwaysCenter = 1; identity(H, n); fail = 1; }
6694 }
6695 else { identity(H, n); fail = 1; }
6696 }
6697 else {
6698 fail = 0;
6699 FOR(i, n) x[i] = x0[i] + t*p[i];
6700
6701 if (fout) {
6702 fprintf(fout, "\n%3d %7.4f%14.6f x", Iround + 1, SIZEp, *f);
6703 FOR(i, n) fprintf(fout, "%8.5f ", x[i]);
6704 fflush(fout);
6705 }
6706 if (SIZEp < 0.001 && H_end(x0, x, f0, *f, e, e, n))
6707 {
6708 xtoy(x, x0, n); break;
6709 }
6710 }
6711 if (dfun) (*dfun) (x, f, g, n);
6712 else gradient(n, x, *f, g, fun, tv, (AlwaysCenter || fail || SIZEp < 0.01));
6713
6714 for (i = 0, f0 = *f; i < n; i++)
6715 {
6716 y[i] = g[i] - g0[i]; s[i] = x[i] - x0[i]; g0[i] = g[i]; x0[i] = x[i];
6717 }
6718
6719 /* renewal of H varies with different algorithms */
6720 #if (defined SR1)
6721 /* Symmetrical Rank One (Broyden, C. G., 1967) */
6722 for (i = 0, w = .0; i < n; i++) {
6723 for (j = 0, t = .0; j < n; j++) t += H[i*n + j] * y[j];
6724 z[i] = s[i] - t;
6725 w += y[i] * z[i];
6726 }
6727 if (fabs(w) < smallv) { identity(H, n); fail = 1; continue; }
6728 FOR(i, n) FOR(j, n) H[i*n + j] += z[i] * z[j] / w;
6729 #elif (defined DFP)
6730 /* Davidon (1959), Fletcher and Powell (1963). */
6731 for (i = 0, w = v = 0.; i < n; i++) {
6732 for (j = 0, z[i] = .0; j < n; j++) z[i] += H[i*n + j] * y[j];
6733 w += y[i] * z[i]; v += y[i] * s[i];
6734 }
6735 if (fabs(w) < smallv || fabs(v) < smallv) { identity(H, n); fail = 1; continue; }
6736 FOR(i, n) FOR(j, n) H[i*n + j] += s[i] * s[j] / v - z[i] * z[j] / w;
6737 #else
6738 for (i = 0, w = v = 0.; i < n; i++) {
6739 for (j = 0, z[i] = 0.; j < n; j++) z[i] += H[i*n + j] * y[j];
6740 w += y[i] * z[i]; v += y[i] * s[i];
6741 }
6742 if (fabs(v) < smallv) { identity(H, n); fail = 1; continue; }
6743 FOR(i, n) FOR(j, n)
6744 H[i*n + j] += ((1 + w / v)*s[i] * s[j] - z[i] * s[j] - s[i] * z[j]) / v;
6745 #endif
6746
6747 } /* for (Iround,maxround) */
6748
6749 if (Iround == maxround) {
6750 if (fout) fprintf(fout, "\ncheck convergence!\n");
6751 return(-1);
6752 }
6753 return(0);
6754 }
6755
6756