1 /*
2 * MrBayes 3
3 *
4 * (c) 2002-2013
5 *
6 * John P. Huelsenbeck
7 * Dept. Integrative Biology
8 * University of California, Berkeley
9 * Berkeley, CA 94720-3140
10 * johnh@berkeley.edu
11 *
12 * Fredrik Ronquist
13 * Swedish Museum of Natural History
14 * Box 50007
15 * SE-10405 Stockholm, SWEDEN
16 * fredrik.ronquist@nrm.se
17 *
18 * With important contributions by
19 *
20 * Paul van der Mark (paulvdm@sc.fsu.edu)
21 * Maxim Teslenko (maxkth@gmail.com)
22 * Chi Zhang (zhangchicool@gmail.com)
23 *
24 * and by many users (run 'acknowledgments' to see more info)
25 *
26 * This program is free software; you can redistribute it and/or
27 * modify it under the terms of the GNU General Public License
28 * as published by the Free Software Foundation; either version 2
29 * of the License, or (at your option) any later version.
30 *
31 * This program is distributed in the hope that it will be useful,
32 * but WITHOUT ANY WARRANTY; without even the implied warranty of
33 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
34 * GNU General Public License for more details (www.gnu.org).
35 *
36 */
37
38 #include "bayes.h"
39 #include "best.h"
40 #include "command.h"
41 #include "mcmc.h"
42 #include "model.h"
43 #include "utils.h"
44
45 #define MAX_RATE_CATS 20
46 #define POINTGAMMA(prob,alpha,beta) PointChi2(prob,2.0*(alpha))/(2.0*(beta))
47 #define PAI2 6.283185307
48 #define TINY 1.0e-20
49 #define EVALUATE_COMPLEX_NUMBERS 2
50 #if !defined(MAX)
51 #define MAX(a,b) (((a) > (b)) ? (a) : (b))
52 #endif
53 #if !defined(MIN)
54 #define MIN(a,b) (((a) < (b)) ? (a) : (b))
55 #endif
56 #define SQUARE(a) ((a)*(a))
57
58 /* local global variable */
59 char noLabel[] = "";
60
61 /* local prototypes */
62 void DatedNodeDepths (TreeNode *p, MrBFlt *nodeDepths, int *index);
63 void DatedNodes (TreeNode *p, TreeNode **datedTips, int *index);
64 int NConstrainedTips (TreeNode *p);
65 int NDatedTips (TreeNode *p);
66 void PrintNode (char **s, int *len, TreeNode *p, int isRooted);
67 void ResetPolyNode (PolyNode *p);
68 void ResetTreeNode (TreeNode *p);
69 void SetNodeDepths (Tree *t);
70
71 void AddTwoMatrices (int dim, MrBFlt **a, MrBFlt **b, MrBFlt **result);
72 void BackSubstitutionRow (int dim, MrBFlt **u, MrBFlt *b);
73 void Balanc (int dim, MrBFlt **a, int *low, int *high, MrBFlt *scale);
74 void BalBak (int dim, int low, int high, MrBFlt *scale, int m, MrBFlt **z);
75 MrBFlt BetaCf (MrBFlt a, MrBFlt b, MrBFlt x);
76 MrBFlt BetaQuantile (MrBFlt alpha, MrBFlt beta, MrBFlt x);
77 MrBFlt CdfBinormal (MrBFlt h1, MrBFlt h2, MrBFlt r);
78 MrBFlt CdfNormal (MrBFlt x);
79 MrBComplex Complex (MrBFlt a, MrBFlt b);
80 MrBFlt ComplexAbsoluteValue (MrBComplex a);
81 MrBComplex ComplexAddition (MrBComplex a, MrBComplex b);
82 MrBComplex ComplexConjugate (MrBComplex a);
83 MrBComplex ComplexDivision (MrBComplex a, MrBComplex b);
84 void ComplexDivision2 (MrBFlt ar, MrBFlt ai, MrBFlt br, MrBFlt bi, MrBFlt *cr, MrBFlt *ci);
85 MrBComplex ComplexExponentiation (MrBComplex a);
86 int ComplexInvertMatrix (int dim, MrBComplex **a, MrBFlt *dwork, int *indx, MrBComplex **aInverse, MrBComplex *col);
87 MrBComplex ComplexLog (MrBComplex a);
88 void ComplexLUBackSubstitution (int dim, MrBComplex **a, int *indx, MrBComplex *b);
89 int ComplexLUDecompose (int dim, MrBComplex **a, MrBFlt *vv, int *indx, MrBFlt *pd);
90 MrBComplex ComplexMultiplication (MrBComplex a, MrBComplex b);
91 MrBComplex ComplexSquareRoot (MrBComplex a);
92 MrBComplex ComplexSubtraction (MrBComplex a, MrBComplex b);
93 int ComputeEigenSystem (int dim, MrBFlt **a, MrBFlt *v, MrBFlt *vi, MrBFlt **u, int *iwork, MrBFlt *dwork);
94 void ComputeLandU (int dim, MrBFlt **aMat, MrBFlt **lMat, MrBFlt **uMat);
95 void ComputeMatrixExponential (int dim, MrBFlt **a, int qValue, MrBFlt **f);
96 void DivideByTwos (int dim, MrBFlt **a, int power);
97 MrBFlt D_sign (MrBFlt a, MrBFlt b);
98 int EigensForRealMatrix (int dim, MrBFlt **a, MrBFlt *wr, MrBFlt *wi, MrBFlt **z, int *iv1, MrBFlt *fv1);
99 void ElmHes (int dim, int low, int high, MrBFlt **a, int *interchanged);
100 void ElTran (int dim, int low, int high, MrBFlt **a, int *interchanged, MrBFlt **z);
101 void Exchange (int j, int k, int l, int m, int n, MrBFlt **a, MrBFlt *scale);
102 MrBFlt Factorial (int x);
103 void ForwardSubstitutionRow (int dim, MrBFlt **L, MrBFlt *b);
104 MrBFlt GammaRandomVariable (MrBFlt a, MrBFlt b, RandLong *seed);
105 void GaussianElimination (int dim, MrBFlt **a, MrBFlt **bMat, MrBFlt **xMat);
106 int Hqr2 (int dim, int low, int high, MrBFlt **h, MrBFlt *wr, MrBFlt *wi, MrBFlt **z);
107 MrBFlt IncompleteBetaFunction (MrBFlt alpha, MrBFlt beta, MrBFlt x);
108 MrBFlt IncompleteGamma (MrBFlt x, MrBFlt alpha, MrBFlt LnGamma_alpha);
109 int InvertMatrix (int dim, MrBFlt **a, MrBFlt *col, int *indx, MrBFlt **aInv);
110 MrBFlt LBinormal (MrBFlt h1, MrBFlt h2, MrBFlt r);
111 int LogBase2Plus1 (MrBFlt x);
112 void LUBackSubstitution (int dim, MrBFlt **a, int *indx, MrBFlt *b);
113 int LUDecompose (int dim, MrBFlt **a, MrBFlt *vv, int *indx, MrBFlt *pd);
114 void MultiplyMatrixByScalar (int dim, MrBFlt **a, MrBFlt scalar, MrBFlt **result);
115 MrBFlt PointChi2 (MrBFlt prob, MrBFlt v);
116 void PrintComplexVector (int dim, MrBComplex *vec);
117 void PrintSquareComplexMatrix (int dim, MrBComplex **m);
118 void PrintSquareDoubleMatrix (int dim, MrBFlt **matrix);
119 void PrintSquareIntegerMatrix (int dim, int **matrix);
120 MrBComplex ProductOfRealAndComplex (MrBFlt a, MrBComplex b);
121 MrBFlt RndGamma (MrBFlt s, RandLong *seed);
122 MrBFlt RndGamma1 (MrBFlt s, RandLong *seed);
123 MrBFlt RndGamma2 (MrBFlt s, RandLong *seed);
124 int SetQvalue (MrBFlt tol);
125 void SetToIdentity (int dim, MrBFlt **matrix);
126 MrBFlt Tha (MrBFlt h1, MrBFlt h2, MrBFlt a1, MrBFlt a2);
127 void TiProbsUsingEigens (int dim, MrBFlt *cijk, MrBFlt *eigenVals, MrBFlt v, MrBFlt r, MrBFlt **tMat, MrBFlt **fMat, MrBFlt **sMat);
128 void TiProbsUsingPadeApprox (int dim, MrBFlt **qMat, MrBFlt v, MrBFlt r, MrBFlt **tMat, MrBFlt **fMat, MrBFlt **sMat);
129
130 MrBFlt QuantileLogNormal (MrBFlt prob, MrBFlt mu, MrBFlt sigma);
131 int DiscreteLogNormal (MrBFlt *rK, MrBFlt sigma, int K, int median);
132 MrBFlt LogNormalPoint (MrBFlt x, MrBFlt mu, MrBFlt sigma);
133
134 #if defined (BEAGLE_V3_ENABLED)
135 int Height(TreeNode *p);
136 void ReverseLevelOrder(Tree *t, TreeNode *p, int *i);
137 void StoreGivenLevel(Tree *t, TreeNode *p, int level, int *i);
138 #endif
139
140 /* qsort compare function for MrBFlt */
cmpMrBFlt(const void * a,const void * b)141 int cmpMrBFlt(const void *a, const void *b)
142 {
143 MrBFlt x = *((MrBFlt *)(a));
144 MrBFlt y = *((MrBFlt *)(b));
145
146 if ( x < y )
147 return -1;
148 else if ( x == y )
149 return 0;
150 else
151 return 1;
152 }
153
154
155 /* AddBitfield: Add bitfield to list of bitfields. The function uses global variable nLongsNeeded. */
AddBitfield(BitsLong *** list,int listLen,int * set,int setLen)156 int AddBitfield (BitsLong ***list, int listLen, int *set, int setLen)
157 {
158 int i, nLongsNeeded;
159
160 nLongsNeeded = (setLen - 1) / nBitsInALong + 1;
161
162 (*list) = (BitsLong **) SafeRealloc ((void *)(*list), ((size_t)listLen+1)*sizeof(BitsLong *));
163 if (!(*list))
164 return ERROR;
165
166 (*list)[listLen] = (BitsLong *) SafeMalloc ((size_t)nLongsNeeded*sizeof(BitsLong));
167 if (!(*list)[listLen])
168 return ERROR;
169
170 ClearBits ((*list)[listLen], nLongsNeeded);
171 for (i=0; i<setLen; i++)
172 if (set[i] == YES)
173 SetBit(i, (*list)[listLen]);
174
175 return NO_ERROR;
176 }
177
178
179 #if defined (SSE_ENABLED) /* SSE or more advanced SIMD */
AlignedMalloc(size_t size,size_t alignment)180 void * AlignedMalloc (size_t size, size_t alignment)
181 {
182 void *mem;
183
184 #if defined GCC_SIMD /* gcc compiler */
185 if (posix_memalign (&mem, alignment, size))
186 return 0;
187 #elif defined ICC_SIMD /* icc compiler */
188 mem = _mm_malloc (size, alignment);
189 #elif defined MS_VCPP_SIMD /* ms visual */
190 mem = _aligned_malloc (size, alignment);
191 #else
192 mem = malloc (size);
193 #endif
194
195 return mem;
196 }
197
198
AlignedSafeFree(void * ptr)199 void *AlignedSafeFree (void *ptr)
200 {
201
202 #if defined ICC_VEC /* icc compiler */
203 _mm_free (ptr);
204 #elif defined MS_VCPP_VEC /* ms visual */
205 _aligned_free (ptr);
206 #else
207 free (ptr);
208 #endif
209
210 ptr = NULL;
211
212 return ptr;
213 }
214 #endif
215
216
AreBitfieldsEqual(BitsLong * p,BitsLong * q,int length)217 int AreBitfieldsEqual (BitsLong *p, BitsLong *q, int length)
218 {
219 int i;
220
221 for (i=0; i<length; i++)
222 {
223 if (p[i] != q[i])
224 return NO;
225 }
226
227 return YES;
228 }
229
230
231 /*----------------------------------------------------------------
232 |
233 | Bit: return 1 if bit n is set in BitsLong *p
234 | else return 0
235 |
236 -----------------------------------------------------------------*/
Bit(int n,BitsLong * p)237 int Bit (int n, BitsLong *p)
238 {
239 BitsLong x, bitsLongOne;
240
241 bitsLongOne = 1;
242
243 p += n / nBitsInALong;
244 x = bitsLongOne << (n % nBitsInALong);
245
246 if ((x & (*p)) == 0)
247 return 0;
248 else
249 return 1;
250
251 }
252
253
254 /* ClearBit: Clear one bit in a bitfield */
ClearBit(int i,BitsLong * bits)255 void ClearBit (int i, BitsLong *bits)
256 {
257 BitsLong x, bitsLongOne=1;
258
259 bits += i / nBitsInALong;
260
261 x = bitsLongOne << (i % nBitsInALong);
262 x ^= bitsLongWithAllBitsSet;
263
264 (*bits) &= x;
265 }
266
267
268 /* ClearBits: Clear all bits in a bitfield */
ClearBits(BitsLong * bits,int nLongs)269 void ClearBits (BitsLong *bits, int nLongs)
270 {
271 int i;
272
273 for (i=0; i<nLongs; i++)
274 bits[i] = 0;
275 }
276
277
278 /* Copy bitfields */
CopyBits(BitsLong * dest,BitsLong * source,int length)279 void CopyBits (BitsLong *dest, BitsLong *source, int length)
280 {
281 int i;
282
283 for (i=0; i<length; i++)
284 dest[i] = source[i];
285 }
286
287
288 /* CopyResults: copy results from one file to another up to lastGen*/
CopyResults(FILE * toFile,char * fromFileName,int lastGen)289 int CopyResults (FILE *toFile, char *fromFileName, int lastGen)
290 {
291 int longestLine;
292 char *strBuf, *strCpy, *word;
293 FILE *fromFile;
294
295 if ((fromFile = OpenBinaryFileR(fromFileName)) == NULL)
296 return ERROR;
297
298 longestLine = LongestLine(fromFile)+10;
299 SafeFclose(&fromFile);
300 strBuf = (char *) SafeCalloc (2*(longestLine+2),sizeof(char));
301 strCpy = strBuf + longestLine + 2;
302
303 if ((fromFile = OpenTextFileR(fromFileName)) == NULL)
304 {
305 free (strBuf);
306 return ERROR;
307 }
308
309 while (fgets(strBuf,longestLine,fromFile)!=NULL)
310 {
311 strncpy (strCpy,strBuf,longestLine);
312 word = strtok(strCpy," ");
313 /* atoi returns 0 when word is not integer number */
314 if (atoi(word)>lastGen)
315 break;
316 fprintf (toFile,"%s",strBuf);
317 fflush (toFile);
318 }
319
320 SafeFclose(&fromFile);
321 free(strBuf);
322 return (NO_ERROR);
323 }
324
325
326 /* CopyProcessSsFile: copy results from one file to another up to lastStep. Also marginalLnLSS is collected for processed steps*/
CopyProcessSsFile(FILE * toFile,char * fromFileName,int lastStep,MrBFlt * marginalLnLSS,MrBFlt * splitfreqSS)327 int CopyProcessSsFile (FILE *toFile, char *fromFileName, int lastStep, MrBFlt *marginalLnLSS, MrBFlt * splitfreqSS)
328 {
329 int longestLine, run, curStep, i;
330 double tmp;
331 char *strBuf, *strCpy, *word, *tmpcp;
332 FILE *fromFile;
333
334 if ((fromFile = OpenBinaryFileR(fromFileName)) == NULL)
335 return ERROR;
336
337 longestLine = LongestLine(fromFile)+10;
338 SafeFclose(&fromFile);
339 strBuf = (char *) SafeCalloc (2*(longestLine+2),sizeof(char));
340 strCpy = strBuf + longestLine + 2;
341
342 if ((fromFile = OpenTextFileR(fromFileName)) == NULL)
343 {
344 free (strBuf);
345 return ERROR;
346 }
347
348 while (fgets(strBuf,longestLine,fromFile)!=NULL)
349 {
350 strncpy (strCpy,strBuf,longestLine);
351 word = strtok(strCpy," \t\n");
352 /* atoi returns 0 when word is not integer number */
353 if (atoi(word)>lastStep)
354 break;
355 fprintf (toFile,"%s",strBuf);
356 fflush (toFile);
357 curStep = atoi(word);
358 if (curStep > 0)
359 {
360 strtok(NULL,"\t\n"); /*skip power*/
361 for (run=0; run<chainParams.numRuns; run++)
362 {
363 tmpcp = strtok(NULL,"\t\n");
364 if (tmpcp == NULL)
365 {
366 MrBayesPrint ("%s Error: In .ss file not enough ellements on the string :%s \n", spacer, strBuf);
367 return ERROR;
368 }
369 tmp = atof(tmpcp);
370 if (tmp == 0.0)
371 {
372 MrBayesPrint ("%s Error: Value of some step contribution is 0.0 or not a number in .ss file. Sting:%s \n", spacer, strBuf);
373 return ERROR;
374 }
375 marginalLnLSS[run]+=tmp;
376 }
377 for (i=0; i<numTopologies; i++)
378 {
379 tmpcp = strtok(NULL,"\t\n");
380 if (tmpcp == NULL)
381 {
382 MrBayesPrint ("%s Error: In .ss file not enough ellements on the string :%s \n", spacer, strBuf);
383 return ERROR;
384 }
385 tmp = atof(tmpcp);
386 splitfreqSS[i*chainParams.numStepsSS + curStep-1] = tmp;
387 }
388 }
389 }
390
391 SafeFclose(&fromFile);
392 free(strBuf);
393 return (NO_ERROR);
394 }
395
396
397 /* CopyTreeResults: copy tree results upto lastGen from one file to another. numTrees is return containing number of trees that were copied. */
CopyTreeResults(FILE * toFile,char * fromFileName,int lastGen,int * numTrees)398 int CopyTreeResults (FILE *toFile, char *fromFileName, int lastGen, int *numTrees)
399 {
400 int longestLine;
401 char *strBuf, *strCpy, *word;
402 FILE *fromFile;
403
404 (*numTrees) = 0;
405
406 if ((fromFile = OpenBinaryFileR(fromFileName)) == NULL)
407 return ERROR;
408
409 longestLine = LongestLine(fromFile)+10;
410 SafeFclose(&fromFile);
411 strBuf = (char *) SafeCalloc (2*(longestLine+2),sizeof(char));
412 strCpy = strBuf + longestLine + 2;
413
414 if ((fromFile = OpenTextFileR(fromFileName)) == NULL)
415 {
416 free (strBuf);
417 return ERROR;
418 }
419
420 while (fgets(strBuf,longestLine,fromFile)!=NULL)
421 {
422 strncpy (strCpy,strBuf,longestLine);
423 word = strtok(strCpy," ");
424 if (strcmp(word,"tree")==0)
425 {
426 word = strtok(NULL," ");
427 /* atoi returns 0 when word is not integer number,
428 4 is offset to get rid of "rep." in tree name */
429 if (atoi(word+4)>lastGen)
430 break;
431 (*numTrees)++;
432 fprintf (toFile,"%s",strBuf);
433 }
434 else if (*numTrees == 0) /* do not print the end statement */
435 fprintf (toFile,"%s",strBuf);
436 fflush (toFile);
437 }
438
439 SafeFclose(&fromFile);
440 free(strBuf);
441 return (NO_ERROR);
442 }
443
444
445 /* FirstTaxonInPartition: Find index of first taxon in partition */
FirstTaxonInPartition(BitsLong * partition,int length)446 int FirstTaxonInPartition (BitsLong *partition, int length)
447 {
448 int i, j, nBits, taxon;
449 BitsLong x, bitsLongOne=1;
450
451 nBits = sizeof(BitsLong) * 8;
452
453 taxon = 0;
454 for (i=0; i<length; i++)
455 {
456 x = bitsLongOne;
457 for (j=0; j<nBits; j++)
458 {
459 if (partition[i] & x)
460 return taxon;
461 taxon++;
462 x <<= 1;
463 }
464 }
465
466 return taxon;
467 }
468
469
470 /* FirstTree: Return file position of first tree after current position */
FirstTree(FILE * fp,char * lineBuf,int longestLine)471 long FirstTree (FILE *fp, char *lineBuf, int longestLine)
472 {
473 long firstTree;
474 char *word;
475
476 do {
477 firstTree = ftell(fp);
478 if ((fgets (lineBuf, longestLine, fp)) == NULL)
479 return 0;
480 word = strtok (lineBuf, " ");
481 } while (strcmp(word,"tree")!=0);
482
483 return (firstTree);
484 }
485
486
Flip01(int x)487 int Flip01 (int x)
488 {
489 if (x == 0)
490 return (1);
491 else
492 return (0);
493 }
494
495
FlipBits(BitsLong * partition,int length,BitsLong * mask)496 void FlipBits (BitsLong *partition, int length, BitsLong *mask)
497 {
498 int i;
499
500 for (i=0; i<length; i++)
501 {
502 partition[i] ^= mask[i];
503 }
504 }
505
506
507 /*-----------------------------------------------------------------
508 |
509 | FlipOneBit: flip bit n in BitsLong *p
510 |
511 ------------------------------------------------------------------*/
FlipOneBit(int n,BitsLong * p)512 void FlipOneBit (int n, BitsLong *p)
513 {
514 BitsLong x, bitsLongOne=1;
515
516 p += n/nBitsInALong;
517 x = bitsLongOne << (n % nBitsInALong);
518 (*p) ^= x;
519 }
520
521
522 /* Convert from 0-based growth function over six states to model index */
FromGrowthFxnToIndex(int * growthFxn)523 int FromGrowthFxnToIndex(int *growthFxn)
524 {
525 int i, j, k, max, fxn[6];
526
527 /* set local growth fxn to lexicographical max */
528 for (i=0; i<6; i++)
529 fxn[i] = i;
530
531 /* decrease until we reach growthFxn */
532 for (k=202; k>=0; k--)
533 {
534 for (i=0; i<6; i++)
535 {
536 if (fxn[i] != growthFxn[i])
537 break;
538 }
539 if (i == 6)
540 break;
541
542 /* get next growth fxn */
543 for (i=5; i>=0; i--)
544 {
545 fxn[i]--;
546 if (fxn[i] >= 0)
547 break;
548 }
549
550 if (i < 0)
551 return -1; /* error */
552 else if (i < 5)
553 {
554 max = 0;
555 for (j=0; j<=i; j++)
556 {
557 if (fxn[j] > max)
558 max = fxn[j];
559 }
560 fxn[++i] = max + 1;
561 for (++i; i<6; i++)
562 fxn[i] = fxn[i-1] + 1;
563 }
564 }
565
566 return k;
567 }
568
569
570 /* Convert from model index to 0-based growth function over six states */
FromIndexToGrowthFxn(int index,int * growthFxn)571 void FromIndexToGrowthFxn(int index, int *growthFxn)
572 {
573 int i, j, max, k;
574
575 /* set growth fxn to lexicographical max */
576 for (i=0; i<6; i++)
577 growthFxn[i] = i;
578
579 /* decrease until we reach index */
580 for (k=202; k>index; k--)
581 {
582 for (i=5; i>=0; i--)
583 {
584 growthFxn[i]--;
585 if (growthFxn[i] >= 0)
586 break;
587 }
588
589 if (i < 0)
590 return; /* ERROR */
591 else if (i < 5)
592 {
593 max = 0;
594 for (j=0; j<=i; j++)
595 {
596 if (growthFxn[j] > max)
597 max = growthFxn[j];
598 }
599 growthFxn[++i] = max + 1;
600 for (++i; i<6; i++)
601 growthFxn[i] = growthFxn[i-1] + 1;
602 }
603 }
604 }
605
606
607 /* GetIntSummary: Get summary statistics for a number of runs (int version) */
GetIntSummary(int ** vals,int nRows,int * rowCount,Stat * theStats,int HPD)608 void GetIntSummary (int **vals, int nRows, int *rowCount, Stat *theStats, int HPD)
609 {
610 int i, j, nVals;
611 MrBFlt *theValues, *p;
612
613 nVals = 0;
614 for (i=0; i<nRows; i++)
615 nVals += rowCount[i];
616
617 theValues = (MrBFlt *) SafeCalloc (nVals, sizeof(MrBFlt));
618
619 /* extract values */
620 p = theValues;
621 for (i=0; i<nRows; i++)
622 {
623 for (j=0; j<rowCount[i]; j++)
624 {
625 (*p++) = (MrBFlt) (vals[i][j]);
626 }
627 }
628
629 /* get statistics */
630 MeanVariance (theValues, nVals, &(theStats->mean), &(theStats->var));
631 if (HPD == YES)
632 LowerUpperMedian (theValues, nVals, &(theStats->lower), &(theStats->upper), &(theStats->median));
633 else
634 LowerUpperMedian (theValues, nVals, &(theStats->lower), &(theStats->upper), &(theStats->median));
635
636 free (theValues);
637 }
638
639
640 /* Get k from 0-based growth function */
GetKFromGrowthFxn(int * growthFxn)641 int GetKFromGrowthFxn(int *growthFxn)
642 {
643 int i, k=0;
644
645 for (i=0; i<6; i++)
646 if (growthFxn[i] > k)
647 k = growthFxn[i];
648
649 return k+1;
650 }
651
652
653 /* GetSummary: Get summary statistics for a number of runs */
GetSummary(MrBFlt ** vals,int nRows,int * rowCount,Stat * theStats,int HPD)654 void GetSummary (MrBFlt **vals, int nRows, int *rowCount, Stat *theStats, int HPD)
655 {
656 int i, nVals;
657 MrBFlt *theValues, *p, *ESS;
658
659 nVals = 0;
660 for (i=0; i<nRows; i++)
661 nVals += rowCount[i];
662
663 theValues = (MrBFlt *) SafeMalloc ((size_t)nVals * sizeof(MrBFlt));
664
665 /* extract values */
666 p = theValues;
667 for (i=0; i<nRows; i++)
668 {
669 memcpy ((void *)(p), (void *)(vals[i]), (size_t)rowCount[i] * sizeof(MrBFlt));
670 p += rowCount[i];
671 }
672
673 /* get statistics */
674 MeanVariance (theValues, nVals, &(theStats->mean), &(theStats->var));
675 if (HPD == YES)
676 LowerUpperMedianHPD (theValues, nVals, &(theStats->lower), &(theStats->upper), &(theStats->median));
677 else
678 LowerUpperMedian (theValues, nVals, &(theStats->lower), &(theStats->upper), &(theStats->median));
679 if (nRows > 1)
680 theStats->PSRF = PotentialScaleReduction (vals, nRows, rowCount);
681
682 ESS = (MrBFlt *) SafeMalloc ((size_t)nRows * sizeof(MrBFlt));
683
684 EstimatedSampleSize (vals, nRows, rowCount, ESS);
685 theStats->avrESS = theStats->minESS = ESS[0];
686 for (i=1; i<nRows; i++)
687 {
688 theStats->avrESS += ESS[i];
689 if (theStats->minESS > ESS[i])
690 {
691 theStats->minESS = ESS[i];
692 }
693 }
694 theStats->avrESS /=nRows;
695
696 free (ESS);
697 free (theValues);
698 }
699
700
701 /* HarmonicArithmeticMean: Calculate harmonic and arithmetic mean from log values */
HarmonicArithmeticMeanOnLogs(MrBFlt * vals,int nVals,MrBFlt * mean,MrBFlt * harm_mean)702 int HarmonicArithmeticMeanOnLogs (MrBFlt *vals, int nVals, MrBFlt *mean, MrBFlt *harm_mean)
703 {
704 int i, reliable;
705 MrBFlt a, x, y, scaler, n;
706
707 reliable = YES;
708
709 scaler = vals[nVals-1];
710 a = n = 0.0;
711 for (i=0; i<nVals; i++)
712 {
713 y = vals[i];
714 y -= scaler;
715 if (y > 400.0)
716 {
717 if (y > 5000.0)
718 {
719 reliable = NO;
720 continue;
721 }
722 a /= exp(y - 100.0);
723 scaler += y - 100.0;
724 y = 100.0;
725 }
726
727 x = (MrBFlt) exp(y);
728
729 if (n < 0.5)
730 a = x;
731 else
732 {
733 a += x;
734 }
735 n += 1.0;
736 }
737
738 /* arithmetic mean */
739 (*mean) = (MrBFlt) log(a/n) + scaler;
740
741 scaler = (MrBFlt) (0.0 - vals[nVals-1]);
742 a = n = 0.0;
743 for (i=0; i<nVals; i++)
744 {
745 y = (MrBFlt) (0.0 - vals[i]);
746 y -= scaler;
747 if (y > 400.0)
748 {
749 if (y > 5000.0)
750 {
751 reliable = NO;
752 continue;
753 }
754 a /= exp(y - 100.0);
755 scaler += y - 100.0;
756 y = 100.0;
757 }
758
759 x = (MrBFlt) exp(y);
760
761 if (n < 0.5)
762 a = x;
763 else
764 {
765 a += x;
766 }
767 n += (MrBFlt) 1.0;
768 }
769
770 /* harmonic mean */
771 (*harm_mean) = - (MrBFlt) log(a/n) - scaler;
772
773 if (reliable == YES)
774 return (NO_ERROR);
775 else
776 return (ERROR);
777 }
778
779
780 /* IsBitSet: Is bit i set in BitsLong *bits ? */
IsBitSet(int i,BitsLong * bits)781 int IsBitSet (int i, BitsLong *bits)
782 {
783 BitsLong x, bitsLongOne=1;
784
785 bits += i / nBitsInALong;
786
787 x = bitsLongOne << (i % nBitsInALong);
788
789 if ((*bits) & x)
790 return (YES);
791 else
792 return (NO);
793 }
794
795
796 /* IsConsistentWith: Is token consistent with expected word, case insensitive ? */
IsConsistentWith(const char * token,const char * expected)797 int IsConsistentWith (const char *token, const char *expected)
798 {
799 int i, len;
800
801 if (strlen(token) > strlen(expected))
802 return NO;
803
804 len = (int) strlen (token);
805
806 for (i=0; i<len; i++)
807 {
808 if (tolower(token[i]) != tolower(expected[i]))
809 return NO;
810 }
811
812 return YES;
813 }
814
815
816 /* IsPartCompatible: Determine whether two partitions are nonoverlapping or nested (compatible) or
817 incompatible (partially overlapping) */
IsPartCompatible(BitsLong * smaller,BitsLong * larger,int length)818 int IsPartCompatible (BitsLong *smaller, BitsLong *larger, int length)
819 {
820 int i;
821
822 /* test first if they overlap */
823 for (i=0; i<length; i++)
824 if ((smaller[i]&larger[i]) != 0)
825 break;
826
827 /* if they overlap, they must be nested */
828 if (i != length) /* potentially incompatible */
829 {
830 for (i=0; i<length; i++)
831 if ((smaller[i]|larger[i]) != larger[i])
832 break;
833 }
834
835 if (i == length) /* passed either one of the tests */
836 return YES;
837 else
838 return NO;
839 }
840
841
842 /* IsPartNested: Test whether smaller partition is nested in larger partition */
IsPartNested(BitsLong * smaller,BitsLong * larger,int length)843 int IsPartNested (BitsLong *smaller, BitsLong *larger, int length)
844 {
845 int i;
846
847 for (i=0; i<length; i++)
848 if ((smaller[i] | larger[i]) != larger[i])
849 break;
850
851 if (i == length)
852 return YES;
853 else
854 return NO;
855 }
856
857
858 /* IsSectionEmpty: Test whether section of two bitfields is empty */
IsSectionEmpty(BitsLong * bitField1,BitsLong * bitField2,int length)859 int IsSectionEmpty (BitsLong *bitField1, BitsLong *bitField2, int length)
860 {
861 int i;
862
863 for (i=0; i<length; i++)
864 if ((bitField1[i] & bitField2[i]) != 0)
865 return NO;
866
867 return YES;
868 }
869
870
871 /* IsSectionEmpty: Test whether union of bitField1 and bitField2 equal to bitField3*/
IsUnionEqThird(BitsLong * bitField1,BitsLong * bitField2,BitsLong * bitField3,int length)872 int IsUnionEqThird (BitsLong *bitField1, BitsLong *bitField2, BitsLong *bitField3, int length)
873 {
874 int i;
875
876 for (i=0; i<length; i++)
877 if ((bitField1[i] | bitField2[i]) != bitField3[i])
878 return NO;
879
880 return YES;
881 }
882
883
884 /* LastBlock: Return file position of last block in file */
LastBlock(FILE * fp,char * lineBuf,int longestLine)885 long LastBlock (FILE *fp, char *lineBuf, int longestLine)
886 {
887 long lastBlock;
888 char *word;
889
890 lastBlock = 0L;
891 rewind (fp);
892
893 while ((fgets (lineBuf, longestLine, fp)) != NULL)
894 {
895 word = strtok (lineBuf, " ");
896 if (strcmp (word, "begin") == 0)
897 lastBlock = ftell (fp);
898 }
899
900 return lastBlock;
901 }
902
903
LineTermType(FILE * fp)904 int LineTermType (FILE *fp)
905 {
906 int ch, nextCh, term;
907
908 term = LINETERM_UNIX; /* default if no line endings are found */
909 while ((ch = getc(fp)) != EOF)
910 {
911 if ((ch == '\n') || (ch == '\r'))
912 {
913 if (ch == '\n')
914 term = LINETERM_UNIX;
915 else /* ch = '\r' */
916 {
917 /* First test below handles one-line MAC file */
918 if (((nextCh = getc(fp)) == EOF) || (nextCh != '\n'))
919 term = LINETERM_MAC;
920 else
921 term = LINETERM_DOS;
922 }
923 break;
924 }
925 }
926 (void)fseek(fp, 0L, 0); /* rewind */
927
928 return (term);
929 }
930
931
932 /*The longest line in a file including line terminating characters present in binary mode.*/
LongestLine(FILE * fp)933 int LongestLine (FILE *fp)
934 {
935 int ch, lineLength, longest;
936
937 longest = 0;
938 lineLength = 0;
939 ch = fgetc(fp);
940 while (ch != EOF)
941 {
942 if ((ch != '\n') && (ch != '\r'))
943 {
944 ch = fgetc(fp);
945 lineLength++;
946 continue;
947 }
948 if (ch == '\r')
949 {
950 if ((ch = fgetc(fp)) == '\n')
951 {
952 /* windows \r\n */
953 lineLength++;
954 ch = fgetc(fp);
955 }
956 else
957 {
958 /* old mac \r */
959 }
960 }
961 else /*unix, linux,new mac or text mode read \n*/
962 {
963 ch = fgetc(fp);
964 }
965
966 if (lineLength > longest)
967 longest = lineLength;
968 lineLength = 0;
969 /*
970 if ((ch == '\n') || (ch == '\r'))
971 {
972 if (lineLength > longest)
973 longest = lineLength;
974 lineLength = 0;
975 }
976 else
977 lineLength++;
978 */
979 }
980 rewind (fp); /* rewind */
981
982 return (longest+1); /*+1 to accommodate last character*/
983 }
984
985
986 /* LowerUpperMedian: Determine median and 95 % credible interval */
LowerUpperMedian(MrBFlt * vals,int nVals,MrBFlt * lower,MrBFlt * upper,MrBFlt * median)987 void LowerUpperMedian (MrBFlt *vals, int nVals, MrBFlt *lower, MrBFlt *upper, MrBFlt *median)
988
989 {
990 SortMrBFlt (vals, 0, nVals-1);
991
992 *lower = vals[(int)(0.025*nVals)];
993 *upper = vals[(int)(0.975*nVals)];
994 *median = vals[nVals/2];
995
996 }
997
998
999 /* LowerUpperMedianHPD: Use a simple way to determine HPD */
LowerUpperMedianHPD(MrBFlt * vals,int nVals,MrBFlt * lower,MrBFlt * upper,MrBFlt * median)1000 void LowerUpperMedianHPD (MrBFlt *vals, int nVals, MrBFlt *lower, MrBFlt *upper, MrBFlt *median)
1001 {
1002 int i, width, theStart;
1003 MrBFlt f, g, interval;
1004
1005 SortMrBFlt (vals, 0, nVals-1);
1006
1007 width = (int)(nVals * 0.95 + 0.5);
1008 theStart = 0;
1009 interval = vals[width-1] - vals[0];
1010 for (i=1; i<nVals-width; i++)
1011 {
1012 f = vals[i];
1013 g = vals[i+width];
1014 if (g - f < interval)
1015 {
1016 interval = g - f;
1017 theStart = i;
1018 }
1019 }
1020
1021 *lower = vals[theStart];
1022 *upper = vals[theStart+width-1];
1023 *median = vals[nVals/2];
1024 }
1025
1026
MaximumValue(MrBFlt x,MrBFlt y)1027 MrBFlt MaximumValue (MrBFlt x, MrBFlt y)
1028 {
1029 if (x > y)
1030 return (x);
1031 else
1032 return (y);
1033 }
1034
1035
MinimumValue(MrBFlt x,MrBFlt y)1036 MrBFlt MinimumValue (MrBFlt x, MrBFlt y)
1037 {
1038 if (x < y)
1039 return (x);
1040 else
1041 return (y);
1042 }
1043
1044
1045 /* NOTE!!!! The result of this function should be used before consecutive call to it again.
1046 It means NEVER use it like this: printf ("%s %s", MbPrintNum (a),MbPrintNum (b)) */
MbPrintNum(MrBFlt num)1047 char *MbPrintNum (MrBFlt num)
1048 {
1049 static char s[40];
1050
1051 if (scientific == YES)
1052 sprintf (s,"%.*le", precision, num);
1053 else
1054 sprintf (s,"%.*lf", precision, num);
1055
1056 return s;
1057 }
1058
1059
MeanVariance(MrBFlt * vals,int nVals,MrBFlt * mean,MrBFlt * var)1060 void MeanVariance (MrBFlt *vals, int nVals, MrBFlt *mean, MrBFlt *var)
1061 {
1062 int i;
1063 MrBFlt a, aOld, s, x;
1064
1065 a = s = 0.0;
1066 for (i=0; i<nVals; i++)
1067 {
1068 x = vals[i];
1069 aOld = a;
1070 a += (x - a) / (MrBFlt) (i + 1);
1071 s += (x - a) * (x - aOld);
1072 }
1073
1074 /* mean */
1075 (*mean) = a;
1076
1077 /* variance */
1078 if (nVals <= 1)
1079 (*var) = 0.0;
1080 else
1081 (*var) = s / (nVals - 1);
1082 }
1083
1084
1085 /* Compute mean and variance of log scaled values.
1086 @param vals pointer to values in log scale
1087 @param nVals number of "vals", minimum 1
1088 @param mean address of variable where computed mean is returned by the function
1089 @param var address of variable where computed variance is returned by the function. Could be set to NULL if this value need not to be returened.
1090 @param varEst address of variable where computed estimate of the population variance is returned, could be set to NULL if this value need not to be returened.
1091 Could be set to NULL if this value need not to be returened.
1092 Note: We devide by nVals or by (nVals-1) when var and varEst is calculated from the sum of square differences. */
MeanVarianceLog(MrBFlt * vals,int nVals,MrBFlt * mean,MrBFlt * var,MrBFlt * varEst)1093 void MeanVarianceLog (MrBFlt *vals, int nVals, MrBFlt *mean, MrBFlt *var, MrBFlt *varEst)
1094 {
1095 int i;
1096 MrBFlt a, aOld, s, x, y, scaler;
1097
1098 a = s = 0.0;
1099 scaler = vals[nVals-1];
1100 for (i=0; i<nVals; i++)
1101 {
1102 y = vals[i];
1103 y -= scaler;
1104 if (y > 200.0)
1105 {
1106 a /= exp(y - 100.0);
1107 s /= exp(2*(y - 100));
1108 scaler += y - 100.0;
1109 y = 100.0;
1110 }
1111
1112 x=(MrBFlt)exp(y);
1113
1114 aOld = a;
1115 a += (x - a) / (MrBFlt) (i + 1);
1116 s += (x - a) * (x - aOld);
1117 }
1118
1119 /* mean */
1120 (*mean) = log(a) + scaler;
1121
1122 /* variance */
1123 if (var!=NULL)
1124 {
1125 if (nVals <= 1)
1126 (*var) = 0.0;
1127 else
1128 (*var) = log(s / nVals) + 2*scaler;
1129 }
1130
1131 /* variance */
1132 if (varEst!=NULL)
1133 {
1134 if (nVals <= 1)
1135 (*varEst) = 0.0;
1136 else
1137 (*varEst) = log(s / (nVals+1)) + 2*scaler;
1138 }
1139 }
1140
1141
MrBayesPrint(char * format,...)1142 void MrBayesPrint (char *format, ...)
1143 {
1144 va_list ptr;
1145
1146 # if defined (MPI_ENABLED)
1147 if (proc_id == 0)
1148 {
1149 if (echoMB == YES)
1150 {
1151 va_start (ptr, format);
1152 vprintf (format, ptr);
1153 va_end(ptr);
1154 fflush (stdout);
1155 }
1156 if (logToFile == YES)
1157 {
1158 if (logFileFp == NULL)
1159 printf ("%s Could not print log output to file\n", spacer);
1160 else
1161 {
1162 va_start (ptr, format);
1163 vfprintf (logFileFp, format, ptr);
1164 va_end(ptr);
1165 fflush (logFileFp);
1166 }
1167 }
1168 }
1169 # else
1170 if (chainParams.redirect == NO)
1171 {
1172 if (echoMB == YES)
1173 {
1174 va_start (ptr, format);
1175 vprintf (format, ptr);
1176 va_end(ptr);
1177 fflush (stdout);
1178 }
1179 if (logToFile == YES)
1180 {
1181 if (logFileFp == NULL)
1182 {
1183 printf ("%s Could not print log output to file\n", spacer);
1184 logToFile = NO;
1185 }
1186 else
1187 {
1188 va_start (ptr, format);
1189 vfprintf (logFileFp, format, ptr);
1190 va_end(ptr);
1191 fflush (logFileFp);
1192 }
1193 }
1194 }
1195 # endif
1196 }
1197
1198
MrBayesPrintf(FILE * f,char * format,...)1199 void MrBayesPrintf (FILE *f, char *format, ...)
1200 {
1201 va_list ptr;
1202
1203 # if defined (MPI_ENABLED)
1204 if (proc_id == 0)
1205 {
1206 va_start (ptr, format);
1207 vfprintf (f, format, ptr);
1208 va_end(ptr);
1209 fflush(f);
1210 }
1211 # else
1212 va_start (ptr, format);
1213 vfprintf (f, format, ptr);
1214 va_end(ptr);
1215 fflush(f);
1216 # endif
1217 }
1218
1219
1220 /** Next taxon in partition, for cycling over set bits in bit fields */
NextTaxonInPartition(int currentTaxon,BitsLong * partition,int length)1221 int NextTaxonInPartition(int currentTaxon, BitsLong *partition, int length)
1222 {
1223 int i, j, taxon;
1224 BitsLong x, bitsLongOne=1;
1225
1226 taxon = currentTaxon + 1;
1227 i = taxon / nBitsInALong;
1228 x = (bitsLongOne << taxon % nBitsInALong);
1229 for (j=taxon%nBitsInALong; j<nBitsInALong; j++)
1230 {
1231 if (partition[i] & x)
1232 return taxon;
1233 taxon++;
1234 x <<= 1;
1235 }
1236
1237 for (i++; i<length; i++)
1238 {
1239 x = 1;
1240 for (j=0; j<nBitsInALong; j++)
1241 {
1242 if (partition[i] & x)
1243 return taxon;
1244 taxon++;
1245 x <<= 1;
1246 }
1247 }
1248
1249 return taxon;
1250 }
1251
1252
1253 /* NBits: count bits in an int */
NBits(int x)1254 int NBits (int x)
1255 {
1256 int n=0;
1257
1258 for (n=0; x != 0; n++)
1259 x &= (x-1);
1260
1261 return n;
1262 }
1263
1264
1265 /* NumBits: Count bits in a bitfield */
NumBits(BitsLong * x,int len)1266 int NumBits (BitsLong *x, int len)
1267 {
1268 int i, n=0;
1269 BitsLong y;
1270
1271 for (i=0; i<len; i++)
1272 {
1273 y = x[i];
1274 while (y != 0)
1275 {
1276 y &= (y-1);
1277 n++;
1278 }
1279 }
1280 return n;
1281 }
1282
1283
OpenBinaryFileR(char * name)1284 FILE *OpenBinaryFileR (char *name)
1285 {
1286 FILE *fp;
1287 char fileName[200];
1288
1289 strcpy(fileName, workingDir);
1290 strncat(fileName, name, 199 - strlen(fileName));
1291
1292 if ((fp = fopen (fileName, "rb")) == NULL)
1293 {
1294 MrBayesPrint ("%s Could not open file \"%s\"\n", spacer, name);
1295 return (NULL);
1296 }
1297 else
1298 return (fp);
1299 }
1300
1301
OpenTextFileR(char * name)1302 FILE *OpenTextFileR (char *name)
1303 {
1304 FILE *fp;
1305 char fileName[200];
1306
1307 strcpy(fileName, workingDir);
1308 strncat(fileName, name, 199 - strlen(fileName));
1309
1310 if ((fp = fopen (fileName, "r")) == NULL)
1311 {
1312 MrBayesPrint ("%s Could not open file \"%s\"\n", spacer, fileName);
1313 return (NULL);
1314 }
1315 else
1316 return (fp);
1317 }
1318
1319
OpenTextFileRQuait(char * name)1320 FILE *OpenTextFileRQuait (char *name)
1321 {
1322 FILE *fp;
1323 char fileName[200];
1324
1325 strcpy(fileName, workingDir);
1326 strncat(fileName, name, 199 - strlen(fileName));
1327
1328 if ((fp = fopen (fileName, "r")) == NULL)
1329 {
1330 return (NULL);
1331 }
1332 else
1333 return (fp);
1334 }
1335
1336
OpenTextFileA(char * name)1337 FILE *OpenTextFileA (char *name)
1338 {
1339 FILE *fp;
1340 char fileName[200];
1341
1342 strcpy(fileName, workingDir);
1343 strncat(fileName, name, 199 - strlen(fileName));
1344
1345 if ((fp = fopen (fileName, "a+")) == NULL)
1346 {
1347 MrBayesPrint ("%s Could not open file \"%s\"\n", spacer, name);
1348 return (NULL);
1349 }
1350 else
1351 return (fp);
1352 }
1353
1354
OpenTextFileW(char * name)1355 FILE *OpenTextFileW (char *name)
1356 {
1357 FILE *fp;
1358 char fileName[200];
1359
1360 strcpy(fileName, workingDir);
1361 strncat(fileName, name, 199 - strlen(fileName));
1362
1363 if ((fp = fopen (fileName, "w+")) == NULL)
1364 {
1365 MrBayesPrint ("%s Could not open file \"%s\"\n", spacer, name);
1366 return (NULL);
1367 }
1368 else
1369 return (fp);
1370 }
1371
1372
1373 /*!
1374 \param vals [0..nRuns][count[]] All records for all runs
1375 \param nRuns Number of runs
1376 \param count [0..nRuns] Number of records in each run
1377 \return PSRF
1378 */
PotentialScaleReduction(MrBFlt ** vals,int nRuns,int * count)1379 MrBFlt PotentialScaleReduction (MrBFlt **vals, int nRuns, int *count)
1380 {
1381 int i, j, nVals;
1382 MrBFlt aW, aOldW, sW, sWj, aB, aOldB, sB, x, R2, weight;
1383
1384 aB = sB = sW = sWj = 0.0;
1385 nVals = 0;
1386 for (j=0; j<nRuns; j++)
1387 {
1388 if (count[j]==0)
1389 {
1390 return -1.0;
1391 }
1392 nVals += count[j];
1393 aW = vals[j][0];
1394 for (i=1; i<count[j]; i++)
1395 {
1396 x = vals[j][i];
1397 aOldW = aW;
1398 aW += (x - aW) / (MrBFlt) (i + 1);
1399 sWj += (x - aW) * (x - aOldW);
1400 }
1401 sW += sWj / (MrBFlt)(count[j] - 1);
1402 x = aW;
1403 aOldB = aB;
1404 aB += (x - aB) / (MrBFlt) (j + 1);
1405 if (j!=0)
1406 sB += (x - aB) * (x - aOldB);
1407 }
1408
1409 sB = sB / (MrBFlt) (nRuns - 1);
1410 sW = sW / (MrBFlt) (nRuns);
1411
1412 weight = (MrBFlt) nVals / (MrBFlt) nRuns;
1413 if (sW > 0.0)
1414 {
1415 R2 = ((weight - 1.0) / weight) + ((MrBFlt)(nRuns + 1) / (MrBFlt) (nRuns)) * (sB / sW);
1416 return sqrt(R2);
1417 }
1418 else
1419 return -1.0;
1420 }
1421
1422
1423 /*!
1424 \param vals [0..nRuns][count[]] All records for all runs
1425 \param nRuns Number of runs
1426 \param count [0..nRuns] Number of records in each run
1427 \param returnESS [0..nRuns] Is an arry in which the routine returns ESS values for each run.
1428 */
EstimatedSampleSize(MrBFlt ** vals,int nRuns,int * count,MrBFlt * returnESS)1429 void EstimatedSampleSize (MrBFlt **vals, int nRuns, int *count, MrBFlt *returnESS)
1430 {
1431 int i, j, lag, maxLag, samples;
1432 MrBFlt *values, mean, del1, del2, varStat=0.0;
1433 MrBFlt gammaStat[2000];
1434
1435 for (i=0; i<nRuns; i++)
1436 {
1437 samples=count[i];
1438 values=vals[i];
1439 mean=0.0;
1440 for (j=0; j<samples; j++)
1441 {
1442 mean+=values[j];
1443 }
1444 mean /=samples;
1445
1446 maxLag = ((samples - 1) > 2000)?2000:(samples - 1);
1447
1448 for (lag = 0; lag < maxLag; lag++)
1449 {
1450 gammaStat[lag]=0;
1451 for (j = 0; j < samples - lag; j++)
1452 {
1453 del1 = values[j] - mean;
1454 del2 = values[j + lag] - mean;
1455 gammaStat[lag] += (del1 * del2);
1456 }
1457
1458 gammaStat[lag] /= ((MrBFlt) (samples - lag));
1459
1460 if (lag == 0)
1461 {
1462 varStat = gammaStat[0];
1463 }
1464 else if (lag % 2 == 0)
1465 {
1466 if (gammaStat[lag - 1] + gammaStat[lag] > 0)
1467 {
1468 varStat += 2.0 * (gammaStat[lag - 1] + gammaStat[lag]);
1469 }
1470 else
1471 maxLag = lag;
1472 }
1473 }
1474 returnESS[i] = (gammaStat[0] * samples) / varStat;
1475 }
1476 }
1477
1478
SafeFclose(FILE ** fp)1479 int SafeFclose(FILE **fp) {
1480 int retval=-1;
1481 # if defined MPI_ENABLED
1482 if (proc_id == 0) {
1483 # endif
1484 if (fp!=NULL && (*fp)!=NULL)
1485 retval=fclose(*fp);
1486 *fp = NULL;
1487 # if defined MPI_ENABLED
1488 }
1489 # endif
1490 return retval;
1491 }
1492
1493
1494 /* SafeFree: Set pointer to freed space to NULL */
1495 /* Calls to be made like this:
1496 *
1497 * ptr = SafeFree(ptr);
1498 *
1499 * or using the SAFEFREE() macro defined in utils.h:
1500 *
1501 * SAFEFREE(ptr);
1502 *
1503 * See http://stackoverflow.com/questions/38569628/calling-a-free-wrapper-dereferencing-type-punned-pointer-will-break-strict-al
1504 *
1505 */
SafeFree(void * ptr)1506 void *SafeFree (void *ptr)
1507 {
1508 free (ptr);
1509 ptr = NULL;
1510
1511 return ptr;
1512 }
1513
1514
1515 /* SafeMalloc: Print error if out of memory; clear memory */
SafeMalloc(size_t s)1516 void *SafeMalloc (size_t s)
1517 {
1518 void *ptr;
1519
1520 if (s == 0)
1521 {
1522 MrBayesPrint ("%s WARNING: Allocation of zero size attempted. This is probably a bug. Problems may follow.\n", spacer);
1523 return NULL;
1524 }
1525
1526 ptr = calloc (1, s);
1527
1528 if (ptr == NULL && s > 0)
1529 {
1530 MrBayesPrint ("%s Out of memory. Most probable cause for the problem is that MrBayes reached \n", spacer);
1531 MrBayesPrint ("%s the limit of allowed memory for a process in your Operating System. Consult\n", spacer);
1532 MrBayesPrint ("%s the documentation of your OS on how to extend the limit. \n", spacer);
1533 MrBayesPrint ("%s Segmentation fault may follow. \n", spacer);
1534 }
1535
1536 return ptr;
1537 }
1538
1539
1540 /* SafeCalloc: Print error if out of memory */
SafeCalloc(size_t n,size_t s)1541 void *SafeCalloc (size_t n, size_t s)
1542 {
1543 void *ptr;
1544
1545 if (s * n == 0)
1546 {
1547 MrBayesPrint ("%s WARNING: Allocation of zero size attempted. This is probably a bug; problems may follow.\n", spacer);
1548 return NULL;
1549 }
1550
1551 ptr = calloc (n, s);
1552
1553 if (ptr == NULL && n * s > 0)
1554 {
1555 MrBayesPrint ("%s Out of memory. Most probable cause for the problem is that MrBayes reached \n", spacer);
1556 MrBayesPrint ("%s the limit of allowed memory for a process in your Operating System. Consult\n", spacer);
1557 MrBayesPrint ("%s the documentation of your OS on how to extend the limit. \n", spacer);
1558 MrBayesPrint ("%s Segmentation fault may follow. \n", spacer);
1559 }
1560
1561 return ptr;
1562 }
1563
1564
1565 /* SafeRealloc: Print error if out of memory */
SafeRealloc(void * ptr,size_t s)1566 void *SafeRealloc (void *ptr, size_t s)
1567 {
1568 void *tmp;
1569
1570 if (s == 0)
1571 {
1572 MrBayesPrint ("%s WARNING: Reallocation of zero size attempted. This is probably a bug. Problems may follow.\n", spacer);
1573 free (ptr);
1574 return NULL;
1575 }
1576
1577 if (ptr == NULL)
1578 tmp = calloc (1, s);
1579 else
1580 tmp = realloc (ptr, s);
1581
1582 if (tmp == NULL)
1583 {
1584 MrBayesPrint ("%s Out of memory. Most probable cause for the problem is that MrBayes reached \n", spacer);
1585 MrBayesPrint ("%s the limit of allowed memory for a process in your Operating System. Consult\n", spacer);
1586 MrBayesPrint ("%s the documentation of your OS on how to extend the limit. \n", spacer);
1587 MrBayesPrint ("%s Segmentation fault may follow. \n", spacer);
1588 }
1589
1590 return tmp;
1591 }
1592
1593
1594 /* SafeStrcat: Allocate or reallocate target to fit result; assumes ptr is NULL if not allocated */
SafeStrcat(char ** target,const char * source)1595 char *SafeStrcat (char **target, const char *source)
1596 {
1597 if (*target == NULL)
1598 *target = (char *) SafeCalloc (strlen (source) + 1, sizeof (char));
1599 else
1600 *target =
1601 (char *) SafeRealloc ((void *) *target,
1602 (strlen (source) + strlen (*target) +
1603 1) * sizeof (char));
1604
1605 if (*target)
1606 strcat (*target, source);
1607
1608 return (*target);
1609 }
1610
1611
1612 /* SafeStrcpy: Allocate or reallocate target to fit result; assumes ptr is NULL if not allocated */
SafeStrcpy(char ** target,const char * source)1613 char *SafeStrcpy (char **target, const char *source)
1614 {
1615 if (*target == NULL)
1616 *target = (char *) SafeCalloc (strlen (source) + 1, sizeof (char));
1617 else
1618 *target =
1619 (char *) SafeRealloc ((void *) *target,
1620 (strlen (source) + 1) * sizeof (char));
1621
1622 if (*target)
1623 strcpy (*target, source);
1624
1625 return (*target);
1626 }
1627
1628
1629 /* SetBit: Set a particular bit in a series of longs */
SetBit(int i,BitsLong * bits)1630 void SetBit (int i, BitsLong *bits)
1631 {
1632 BitsLong x, bitsLongOne=1;
1633
1634 bits += i / nBitsInALong;
1635
1636 x = bitsLongOne << (i % nBitsInALong);
1637
1638 (*bits) |= x;
1639 }
1640
1641
MrBFlt_cmp(const void * a,const void * b)1642 int MrBFlt_cmp (const void *a, const void *b)
1643 {
1644 MrBFlt x = * (MrBFlt *) a;
1645 MrBFlt y = * (MrBFlt *) b;
1646
1647 if (x < y)
1648 return -1;
1649 else if (x > y)
1650 return 1;
1651
1652 return 0;
1653 }
1654
1655 /* SortMrBFlt: Sort in increasing order */
SortMrBFlt(MrBFlt * item,int left,int right)1656 void SortMrBFlt (MrBFlt *item, int left, int right)
1657 {
1658 qsort ((void *) item, right - left + 1, sizeof (MrBFlt),
1659 &MrBFlt_cmp);
1660 }
1661
1662
1663 /* StrCmpCaseInsensitiveLen: Case insensitive string comparison (with maximum
1664 * string length restriction). */
StrCmpCaseInsensitiveLen(const char * s,const char * t,size_t len)1665 int StrCmpCaseInsensitiveLen (const char *s, const char *t, size_t len)
1666 {
1667 char sc, tc;
1668
1669 if (len == 0)
1670 return 0;
1671
1672 while (len-- > 0)
1673 {
1674 sc = tolower (s[0]);
1675 s++;
1676 tc = tolower (t[0]);
1677 t++;
1678
1679 if (sc > tc)
1680 return 1;
1681 else if (sc < tc)
1682 return -1;
1683 else if (sc == '\0')
1684 break;
1685 }
1686
1687 return 0;
1688 }
1689
1690
1691 /* StrCmpCaseInsensitive: Case insensitive string comparison */
StrCmpCaseInsensitive(char * s,char * t)1692 int StrCmpCaseInsensitive (char *s, char *t)
1693 {
1694 int i, minLen;
1695
1696 if (strlen(s) < strlen(t))
1697 minLen = (int) strlen(s);
1698 else
1699 minLen = (int) strlen(t);
1700
1701 for (i=0; i<minLen; i++)
1702 if (tolower(s[i])!= tolower(t[i]))
1703 break;
1704
1705 if (s[i] == '\0' && t[i] == '\0')
1706 return 0;
1707 else if (tolower(s[i]) > tolower(t[i]))
1708 return 1;
1709 else
1710 return -1;
1711 }
1712
1713
1714 /* StripComments: Strip possibly nested comments from the string s.
1715 Example: s="text1[text2[text3]]"-> s="text1" */
StripComments(char * s)1716 void StripComments (char *s)
1717 {
1718 char *t;
1719 int inComment;
1720
1721 inComment = 0;
1722 for (t=s; *s != '\0'; s++)
1723 {
1724 if (inComment == 0)
1725 {
1726 if (*s == '[')
1727 inComment++;
1728 else
1729 *t++ = *s;
1730 }
1731 else
1732 {
1733 if (*s == ']')
1734 inComment--;
1735 else if (*s == '[')
1736 inComment++;
1737 }
1738 }
1739 *t = '\0';
1740 }
1741
1742
TestOpenTextFileR(char * name)1743 FILE *TestOpenTextFileR (char *name)
1744 {
1745 char fileName[100];
1746
1747 strcpy(fileName, workingDir);
1748 strncat(fileName, name, 99 - strlen(fileName));
1749
1750 return fopen (fileName, "r");
1751 }
1752
1753
1754 /*---------
1755 |
1756 | UpdateGrowthFxn: We expect a set of unique indexes from 0 to 5
1757 | indicating a partition of 6 rates into sets. We make sure
1758 | the indices correspond to a restricted growth function here.
1759 |
1760 -----------------------*/
UpdateGrowthFxn(int * growthFxn)1761 void UpdateGrowthFxn(int *growthFxn)
1762 {
1763 int i, j, max, fxn[6];
1764
1765 for (i=0; i<6; i++)
1766 fxn[i] = -1;
1767
1768 max = 0;
1769 for (i=0; i<6; i++)
1770 {
1771 if (fxn[i] != -1)
1772 continue;
1773 for (j=i; j<6; j++)
1774 {
1775 if (growthFxn[j] == growthFxn[i])
1776 fxn[j] = max;
1777 }
1778 max++;
1779 }
1780
1781 for (i=0; i<6; i++)
1782 growthFxn[i] = fxn[i];
1783 }
1784
1785
UpperTriangIndex(int i,int j,int size)1786 int UpperTriangIndex(int i, int j, int size)
1787 {
1788 if (i < j)
1789 return (2*size - i - 3) * i / 2 + j - 1;
1790 else
1791 return (2*size - j - 3) * j / 2 + i - 1;
1792 }
1793
1794
WantTo(const char * msg)1795 int WantTo (const char *msg)
1796 {
1797 char s[100];
1798 int i;
1799
1800 MrBayesPrint ("%s %s? (yes/no): ", spacer, msg);
1801
1802 for (i=0; i<10; i++)
1803 {
1804 if (fgets (s, 98, stdin) == NULL)
1805 {
1806 MrBayesPrint ("%s Failed to retrieve answer; will take that as a no\n", spacer);
1807 return NO;
1808 }
1809
1810 /* Strip away the newline */
1811 s[strlen(s)-1] = '\0';
1812
1813 /* Check answer */
1814 if (IsConsistentWith (s, "yes") == YES)
1815 return YES;
1816 else if (IsConsistentWith (s, "no") == YES)
1817 return NO;
1818
1819 MrBayesPrint ("%s Enter yes or no: ", spacer);
1820 }
1821
1822 MrBayesPrint ("%s MrBayes does not understand; will take that as a no\n", spacer);
1823
1824 return NO;
1825 }
1826
1827
1828 /* the following are moved from tree.c */
1829 /* AddToTreeList: Add tree at end of tree list */
AddToTreeList(TreeList * treeList,Tree * tree)1830 int AddToTreeList (TreeList *treeList, Tree *tree)
1831 {
1832 TreeListElement *listElement = (TreeListElement *) SafeCalloc (1, sizeof(TreeListElement));
1833 if (!listElement)
1834 return (ERROR);
1835
1836 listElement->order = (int *) SafeCalloc (tree->nIntNodes-1, sizeof(int));
1837 if (!listElement->order)
1838 return (ERROR);
1839 listElement->next = NULL;
1840
1841 if (treeList->last == NULL)
1842 treeList->last = treeList->first = listElement;
1843 else
1844 {
1845 treeList->last->next = listElement;
1846 treeList->last = listElement;
1847 }
1848
1849 if (tree->isRooted)
1850 StoreRTopology (tree, listElement->order);
1851 else
1852 StoreUTopology (tree, listElement->order);
1853
1854 return (NO_ERROR);
1855 }
1856
1857
1858 /* AllocatePolyTree: Allocate memory space for a polytomous tree */
AllocatePolyTree(int numTaxa)1859 PolyTree *AllocatePolyTree (int numTaxa)
1860 {
1861 int i;
1862 PolyTree *pt;
1863
1864 pt = (PolyTree *) SafeCalloc (1, sizeof (PolyTree));
1865 if (!pt)
1866 return (NULL);
1867
1868 pt->memNodes = 2*numTaxa;
1869 pt->nodes = (PolyNode *) SafeCalloc (2*numTaxa, sizeof(PolyNode));
1870 pt->allDownPass = (PolyNode **) SafeCalloc (3*numTaxa, sizeof (PolyNode *));
1871 pt->intDownPass = pt->allDownPass + 2*numTaxa;
1872 if (pt->nodes == NULL || pt->allDownPass == NULL)
1873 {
1874 free (pt->nodes);
1875 free (pt->allDownPass);
1876 free (pt);
1877 return (NULL);
1878 }
1879
1880 /* initialize nodes and set index and memoryIndex */
1881 for (i=0; i<2*numTaxa; i++)
1882 {
1883 ResetPolyNode(&pt->nodes[i]);
1884 pt->nodes[i].memoryIndex = i;
1885 pt->nodes[i].index = i;
1886 }
1887
1888 /* initialize tree properties */
1889 pt->nNodes = pt->nIntNodes = 0;
1890 pt->root = NULL;
1891 pt->brlensDef = NO;
1892 pt->isRooted = NO;
1893 pt->isClock = NO;
1894 pt->isCalibrated = NO;
1895 pt->isRelaxed = NO;
1896 pt->clockRate = 0.0;
1897 strcpy(pt->name,"");
1898
1899 /* initialize bitsets */
1900 pt->bitsets = NULL;
1901
1902 /* initialize relaxed clock parameters */
1903 pt->nESets = 0;
1904 pt->nEvents = NULL;
1905 pt->position = NULL;
1906 pt->rateMult = NULL;
1907 pt->eSetName = NULL;
1908
1909 pt->nBSets = 0;
1910 pt->effectiveBrLen = NULL;
1911 pt->bSetName = NULL;
1912
1913 /* initialize population size set parameters */
1914 pt->popSizeSet = NO;
1915 pt->popSize = NULL;
1916 pt->popSizeSetName = NULL;
1917
1918 return (pt);
1919 }
1920
1921
1922 /* AllocatePolyTreeRelClockParams: Allocate space for relaxed clock parameters */
AllocatePolyTreeRelClockParams(PolyTree * pt,int nBSets,int nESets)1923 int AllocatePolyTreeRelClockParams (PolyTree *pt, int nBSets, int nESets)
1924 {
1925 int i;
1926
1927 /* free previous clock params if any */
1928 FreePolyTreeRelClockParams (pt);
1929
1930 /* set number of sets */
1931 pt->nBSets = nBSets;
1932 pt->nESets = nESets;
1933
1934 /* we do not allocate space for the actual names here; these will be NULL pointers */
1935
1936 /* take care of branch params */
1937 if (pt->nBSets > 0)
1938 {
1939 pt->bSetName = (char **) SafeCalloc (pt->nBSets, sizeof (char *));
1940 pt->effectiveBrLen = (MrBFlt **) SafeCalloc (pt->nBSets, sizeof (MrBFlt *));
1941 for (i=0; i<pt->nBSets; i++)
1942 pt->effectiveBrLen[i] = (MrBFlt *) SafeCalloc (pt->memNodes, sizeof(MrBFlt));
1943 }
1944
1945 /* take care of breakpoint params */
1946 if (pt->nESets > 0)
1947 {
1948 pt->eSetName = (char **) SafeCalloc (pt->nESets, sizeof(char *));
1949 pt->nEvents = (int **) SafeCalloc (pt->nESets, sizeof(int *));
1950 pt->position = (MrBFlt ***) SafeCalloc (pt->nESets, sizeof(MrBFlt **));
1951 pt->rateMult = (MrBFlt ***) SafeCalloc (pt->nESets, sizeof(MrBFlt **));
1952 for (i=0; i<pt->nESets; i++)
1953 {
1954 pt->nEvents[i] = (int *) SafeCalloc (pt->memNodes, sizeof(int));
1955 pt->position[i] = (MrBFlt **) SafeCalloc (pt->memNodes, sizeof(MrBFlt *));
1956 pt->rateMult[i] = (MrBFlt **) SafeCalloc (pt->memNodes, sizeof(MrBFlt *));
1957 }
1958 }
1959
1960 return (NO_ERROR);
1961 }
1962
1963
1964 /* AllocatePolyTreePartitions: Allocate space for and set partitions for polytomous tree */
AllocatePolyTreePartitions(PolyTree * pt)1965 int AllocatePolyTreePartitions (PolyTree *pt)
1966 {
1967 int i, nLongsNeeded, numTaxa;
1968
1969 /* get some handy numbers */
1970 numTaxa = pt->memNodes/2;
1971 nLongsNeeded = (numTaxa -1) / nBitsInALong + 1;
1972
1973 /* allocate space */
1974 pt->bitsets = (BitsLong *) SafeRealloc ((void *)pt->bitsets, pt->memNodes*nLongsNeeded*sizeof(BitsLong));
1975 if (pt->bitsets == NULL)
1976 return (ERROR);
1977 for (i=0; i<pt->memNodes*nLongsNeeded; i++)
1978 pt->bitsets[i] = 0;
1979
1980 /* set node partition pointers */
1981 for (i=0; i<pt->memNodes; i++)
1982 pt->nodes[i].partition = pt->bitsets + i*nLongsNeeded;
1983
1984 /* clear and set partitions; if the tree is empty, nothing is set */
1985 ResetPolyTreePartitions(pt);
1986
1987 return (NO_ERROR);
1988 }
1989
1990
1991 /* AllocateTree: Allocate memory space for a tree (unrooted or rooted) */
AllocateTree(int numTaxa)1992 Tree *AllocateTree (int numTaxa)
1993 {
1994 int i;
1995 Tree *t;
1996
1997 t = (Tree *) SafeCalloc (1, sizeof (Tree));
1998
1999 if (t == NULL)
2000 return NULL;
2001
2002 /* initialize basic tree properties */
2003 t->memNodes = 2 * numTaxa;
2004 strcpy (t->name, "");
2005
2006 t->isRooted = NO;
2007 t->isClock = NO;
2008
2009 t->checkConstraints = NO;
2010 t->nConstraints = 0;
2011 t->nLocks = 0;
2012 t->isCalibrated = NO;
2013 t->nNodes = t->nIntNodes = 0;
2014 t->nRelParts = 0;
2015 t->relParts = NULL;
2016
2017 /* initialize pointers */
2018 t->bitsets = NULL;
2019 t->flags = NULL;
2020 t->constraints = NULL;
2021
2022 /* allocate and initialize nodes and node arrays (enough for both rooted and unrooted trees) */
2023 t->nNodes = 0;
2024 t->nIntNodes = 0;
2025
2026 if ((t->nodes =
2027 (TreeNode *) SafeCalloc (2 * numTaxa, sizeof (TreeNode))) == NULL)
2028 {
2029 free (t);
2030 return NULL;
2031 }
2032
2033 if ((t->allDownPass =
2034 (TreeNode **) SafeCalloc (3 * numTaxa, sizeof (TreeNode *))) == NULL)
2035 {
2036 free (t->nodes);
2037 free (t);
2038 return NULL;
2039 }
2040
2041 t->intDownPass = t->allDownPass + t->memNodes;
2042
2043 #if defined (BEAGLE_V3_ENABLED)
2044 t->levelPassEnabled = 0;
2045 #endif
2046
2047 /* initialize nodes and set index and memoryIndex */
2048 for (i = 0; i < t->memNodes; i++)
2049 {
2050 ResetTreeNode (&t->nodes[i]);
2051 t->nodes[i].memoryIndex = i;
2052 t->nodes[i].index = i;
2053 }
2054
2055 return t;
2056 }
2057
2058
2059 /* AllocateFixedTree: Allocate memory space for a fixed unrooted or rooted tree */
AllocateFixedTree(int numTaxa,int isRooted)2060 Tree *AllocateFixedTree (int numTaxa, int isRooted)
2061 {
2062 int i;
2063 Tree *t;
2064
2065 t = (Tree *) SafeCalloc (1, sizeof (Tree));
2066 if (t == NULL)
2067 return NULL;
2068
2069 /* initialize basic tree properties */
2070 if (isRooted == YES)
2071 t->memNodes = 2*numTaxa;
2072 else
2073 t->memNodes = 2*numTaxa - 2;
2074 strcpy (t->name, "");
2075
2076 t->isRooted = isRooted;
2077 t->isClock = NO;
2078
2079 t->checkConstraints = NO;
2080 t->nConstraints = 0;
2081 t->nLocks = 0;
2082 t->isCalibrated = NO;
2083 t->nNodes = t->nIntNodes = 0;
2084 t->nRelParts = 0;
2085 t->relParts = NULL;
2086
2087 /* initialize pointers */
2088 t->bitsets = NULL;
2089 t->flags = NULL;
2090 t->constraints = NULL;
2091
2092 /* allocate and initialize nodes and node arrays (enough for both rooted and unrooted trees) */
2093 if (t->isRooted)
2094 {
2095 t->nNodes = 2*numTaxa;
2096 t->nIntNodes = numTaxa - 1;
2097 }
2098 else
2099 {
2100 t->nNodes = 2*numTaxa - 2;
2101 t->nIntNodes = numTaxa - 2;
2102 }
2103 if ((t->nodes = (TreeNode *) SafeCalloc (t->nNodes, sizeof (TreeNode))) == NULL)
2104 {
2105 free (t);
2106 return NULL;
2107 }
2108 if ((t->allDownPass = (TreeNode **) SafeCalloc (t->nNodes + t->nIntNodes, sizeof (TreeNode *))) == NULL)
2109 {
2110 free (t->nodes);
2111 free (t);
2112 return NULL;
2113 }
2114 t->intDownPass = t->allDownPass + t->nNodes;
2115
2116 #if defined (BEAGLE_V3_ENABLED)
2117 t->levelPassEnabled = 0;
2118 #endif
2119
2120 /* initialize nodes and set index and memoryIndex */
2121 for (i=0; i<t->memNodes; i++)
2122 {
2123 ResetTreeNode(&t->nodes[i]);
2124 t->nodes[i].memoryIndex = i;
2125 t->nodes[i].index = i;
2126 }
2127
2128 return t;
2129 }
2130
2131
2132 /* AllocateTreePartitions: Allocate space for and set partitions for tree */
AllocateTreePartitions(Tree * t)2133 int AllocateTreePartitions (Tree *t)
2134 {
2135 int i, nLongsNeeded, numTaxa;
2136 TreeNode *p;
2137
2138 /* get some handy numbers */
2139 if (t->isRooted == YES)
2140 numTaxa = t->nNodes - t->nIntNodes - 1;
2141 else
2142 numTaxa = t->nNodes - t->nIntNodes;
2143 nLongsNeeded = (numTaxa - 1) / nBitsInALong + 1;
2144
2145 /* reallocate space */
2146 t->bitsets = (BitsLong *) SafeRealloc ((void *)(t->bitsets), (size_t)(t->nNodes) * (size_t)nLongsNeeded * sizeof(BitsLong));
2147 if (!t->bitsets)
2148 return (ERROR);
2149
2150 /* clear bit fields */
2151 for (i=0; i<t->nNodes*nLongsNeeded; i++)
2152 t->bitsets[i] = 0;
2153
2154 /* set node pointers to bit fields */
2155 for (i=0; i<t->nNodes; i++)
2156 {
2157 p = t->allDownPass[i];
2158 p->partition = t->bitsets + i*nLongsNeeded;
2159 }
2160
2161 /* set partition specifiers for terminals */
2162 ResetTreePartitions(t);
2163
2164 return (NO_ERROR);
2165 }
2166
2167
AreTopologiesSame(Tree * t1,Tree * t2)2168 int AreTopologiesSame (Tree *t1, Tree *t2)
2169 {
2170 int i, j, k, nLongsNeeded, nTaxa;
2171 BitsLong *mask;
2172 TreeNode *p, *q;
2173
2174 if (t1->nNodes != t2->nNodes)
2175 return (NO);
2176 if (t1->nIntNodes != t2->nIntNodes)
2177 return (NO);
2178
2179 if (t1->isRooted == YES)
2180 nTaxa = t1->nNodes - t1->nIntNodes - 1;
2181 else
2182 nTaxa = t1->nNodes - t1->nIntNodes;
2183
2184 /* allocate space for mask */
2185 nLongsNeeded = (nTaxa - 1) / nBitsInALong + 1;
2186 mask = (BitsLong *) SafeCalloc (nLongsNeeded, sizeof(BitsLong));
2187
2188 /* set mask */
2189 for (i=0; i<nTaxa; i++)
2190 SetBit(i, mask);
2191
2192 /* allocate and set partition pointers */
2193 AllocateTreePartitions (t1);
2194 AllocateTreePartitions (t2);
2195
2196 /* check for congruence */
2197 for (i=0; i<t1->nIntNodes; i++)
2198 {
2199 p = t1->intDownPass[i];
2200 if (t1->isRooted == NO && IsBitSet(t2->root->index,p->partition))
2201 FlipBits(p->partition,nLongsNeeded, mask);
2202 for (j=0; j<t2->nIntNodes; j++)
2203 {
2204 q = t2->intDownPass[j];
2205 for (k=0; k<nLongsNeeded; k++)
2206 {
2207 if (p->partition[k] != q->partition[k])
2208 break;
2209 }
2210 if (k == nLongsNeeded)
2211 break;
2212 }
2213 if (j == t2->nIntNodes)
2214 {
2215 FreeTreePartitions (t1);
2216 FreeTreePartitions (t2);
2217 free (mask);
2218 return (NO);
2219 }
2220 }
2221
2222 FreeTreePartitions (t1);
2223 FreeTreePartitions (t2);
2224 free (mask);
2225 return (YES);
2226 }
2227
2228
AreTreesSame(Tree * t1,Tree * t2)2229 int AreTreesSame (Tree *t1, Tree *t2)
2230 {
2231 int i, j, k, nLongsNeeded, nTaxa;
2232 BitsLong *mask;
2233 TreeNode *p, *q;
2234
2235 extern void ShowNodes(TreeNode*, int, int);
2236
2237 if (t1->nNodes != t2->nNodes)
2238 return (NO);
2239 if (t1->nIntNodes != t2->nIntNodes)
2240 return (NO);
2241
2242 if (t1->isRooted == YES)
2243 nTaxa = t1->nNodes - t1->nIntNodes - 1;
2244 else
2245 nTaxa = t1->nNodes - t1->nIntNodes;
2246
2247 /* allocate space for mask */
2248 nLongsNeeded = (nTaxa - 1) / nBitsInALong + 1;
2249 mask = (BitsLong *) SafeCalloc (nLongsNeeded, sizeof(BitsLong));
2250
2251 /* set mask */
2252 for (i=0; i<nTaxa; i++)
2253 SetBit(i, mask);
2254
2255 /* allocate and set partition pointers */
2256 AllocateTreePartitions (t1);
2257 AllocateTreePartitions (t2);
2258
2259 /* check for congruence */
2260 for (i=0; i<t1->nNodes; i++)
2261 {
2262 p = t1->allDownPass[i];
2263 if (p->anc == NULL && t1->isRooted == YES)
2264 continue;
2265 if (t1->isRooted == NO && IsBitSet(t2->root->index,p->partition))
2266 FlipBits(p->partition,nLongsNeeded, mask);
2267 for (j=0; j<t2->nNodes; j++)
2268 {
2269 q = t2->allDownPass[j];
2270 for (k=0; k<nLongsNeeded; k++)
2271 {
2272 if (p->partition[k] != q->partition[k])
2273 break;
2274 }
2275 if (k == nLongsNeeded && AreDoublesEqual (p->length, q->length, 0.000001) == YES)
2276 break;
2277 else if (k == nLongsNeeded)
2278 {
2279 FreeTreePartitions (t1);
2280 FreeTreePartitions (t2);
2281 free (mask);
2282 return (NO);
2283 }
2284 }
2285 if (j == t2->nNodes)
2286 {
2287 FreeTreePartitions (t1);
2288 FreeTreePartitions (t2);
2289 free (mask);
2290 return (NO);
2291 }
2292 }
2293
2294 FreeTreePartitions (t1);
2295 FreeTreePartitions (t2);
2296 free (mask);
2297 return (YES);
2298 }
2299
2300
2301 /*----------------------------------------------------------------
2302 |
2303 | BuildConstraintTree: Build constraint tree. The tree t is
2304 | needed only to hold information about constraints and
2305 | included taxa.
2306 |
2307 ----------------------------------------------------------------*/
BuildConstraintTree(Tree * t,PolyTree * pt,char ** localTaxonNames)2308 int BuildConstraintTree (Tree *t, PolyTree *pt, char **localTaxonNames)
2309 {
2310 int i, j, k, constraintId, nLongsNeeded, nextNode;
2311 BitsLong *constraintPartition, *mask;
2312 PolyNode *pp, *qq, *rr, *ss, *tt;
2313
2314 pt->isRooted = t->isRooted;
2315
2316 nLongsNeeded = (numLocalTaxa - 1) / nBitsInALong + 1;
2317 constraintPartition = (BitsLong *) SafeCalloc (2*nLongsNeeded, sizeof(BitsLong));
2318 if (!constraintPartition)
2319 {
2320 MrBayesPrint ("%s Problems allocating constraintPartition in BuildConstraintTree", spacer);
2321 return (ERROR);
2322 }
2323 mask = constraintPartition + nLongsNeeded;
2324
2325 /* calculate mask (needed to take care of unused bits when flipping partitions) */
2326 for (i=0; i<numLocalTaxa; i++)
2327 SetBit (i, mask);
2328
2329 /* reset all nodes */
2330 for (i=0; i<2*numLocalTaxa; i++)
2331 {
2332 pp = &pt->nodes[i];
2333 pp->isDated = NO;
2334 pp->calibration = NULL;
2335 pp->age = -1.0;
2336 pp->isLocked = NO;
2337 pp->lockID = -1;
2338 pp->index = i;
2339 }
2340
2341 /* build a bush */
2342 pt->root = &pt->nodes[numLocalTaxa];
2343 for (i=0; i<numLocalTaxa; i++)
2344 {
2345 pp = &pt->nodes[i];
2346 pp->index = i;
2347 pp->left = NULL;
2348 if (i == numLocalTaxa - 1)
2349 pp->sib = NULL;
2350 else
2351 pp->sib = &pt->nodes[i+1];
2352 pp->anc = pt->root;
2353 }
2354 pp = pt->root;
2355 pp->left = &pt->nodes[0];
2356 pp->anc = pp->sib = NULL;
2357 pt->nNodes = numLocalTaxa + 1;
2358 pt->nIntNodes = 1;
2359
2360 /* make sure the outgroup is the right-most node */
2361 pt->nodes[localOutGroup].index = numLocalTaxa - 1;
2362 pt->nodes[numLocalTaxa - 1].index = localOutGroup;
2363
2364 /* allocate and set partition specifiers in bush */
2365 GetPolyDownPass(pt);
2366 AllocatePolyTreePartitions(pt);
2367
2368 /* set terminal taxon labels */
2369 for (i=0; i<pt->nNodes; i++)
2370 {
2371 pp = pt->allDownPass[i];
2372 if (pp->index < numLocalTaxa)
2373 strcpy (pp->label, localTaxonNames[pp->index]);
2374 }
2375
2376 /* resolve the bush according to constraints */
2377 /* for now, satisfy all constraints */
2378 /* for now, bail out if constraints are not compatible */
2379 /* Eventually, we might want to be build a parsimony (WAB) or compatibility (WIB) matrix and
2380 draw a starting tree from the universe according to the score of the tree. A simple way of accomplishing
2381 approximately this is to use sequential addition, with probabilities in each step determined
2382 by the parsimony or compatibility score of the different possibilities. */
2383 nextNode = numLocalTaxa + 1;
2384 t->nLocks=0;
2385 for (constraintId=0; constraintId<numDefinedConstraints; constraintId++)
2386 {
2387 if (t->constraints[constraintId] == NO || definedConstraintsType[constraintId] != HARD)
2388 continue;
2389
2390 /* initialize bits in partition to add; get rid of deleted taxa in the process */
2391 ClearBits(constraintPartition, nLongsNeeded);
2392 for (i=j=0; i<numTaxa; i++)
2393 {
2394 if (taxaInfo[i].isDeleted == YES)
2395 continue;
2396 if (IsBitSet(i, definedConstraint[constraintId]) == YES)
2397 SetBit(j, constraintPartition);
2398 j++;
2399 }
2400 assert (j == numLocalTaxa);
2401
2402 /* make sure outgroup is outside constrained partition if the tree is unrooted */
2403 if (t->isRooted == NO && IsBitSet(localOutGroup, constraintPartition))
2404 FlipBits(constraintPartition, nLongsNeeded, mask);
2405
2406 /* check that partition should be included */
2407 k = NumBits(constraintPartition, nLongsNeeded);
2408 if (k == 0)
2409 {
2410 MrBayesPrint ("%s WARNING: Constraint '%s' refers only to deleted taxa\n", spacer, constraintNames[constraintId]);
2411 MrBayesPrint ("%s and will be disregarded\n", spacer);
2412 t->constraints[constraintId] = NO;
2413 continue;
2414 }
2415 if (k == 1)
2416 {
2417 MrBayesPrint ("%s WARNING: Constraint '%s' refers to a single tip and\n", spacer, constraintNames[constraintId]);
2418 MrBayesPrint ("%s will be disregarded\n", spacer);
2419 t->constraints[constraintId] = NO;
2420 continue;
2421 }
2422
2423 /* check if root in rooted tree (we allow this to enable inference of ancestral states) */
2424 if (k == numLocalTaxa && t->isRooted == YES)
2425 {
2426 if (pt->root->isLocked == YES) {
2427 MrBayesPrint ("%s WARNING: Constraint '%s' is a duplicate of another constraint\n", spacer, constraintNames[constraintId]);
2428 MrBayesPrint ("%s and will be ignored\n", spacer);
2429 t->constraints[constraintId] = NO;
2430 continue;
2431 }
2432 pt->root->isLocked = YES;
2433 pt->root->lockID = constraintId;
2434 t->nLocks++;
2435 continue;
2436 }
2437
2438 /* check if interior root in unrooted tree (we allow this to enable inference of ancestral states) */
2439 if ((k == numLocalTaxa - 1 || k == numLocalTaxa) && t->isRooted == NO)
2440 {
2441 if (pt->root->isLocked == YES) {
2442 MrBayesPrint ("%s WARNING: Constraint '%s' is a duplicate of another constraint\n", spacer, constraintNames[constraintId]);
2443 MrBayesPrint ("%s and will be ignored\n", spacer);
2444 t->constraints[constraintId] = NO;
2445 continue;
2446 }
2447 pt->root->isLocked = YES;
2448 pt->root->lockID = constraintId;
2449 t->nLocks++;
2450 continue;
2451 }
2452
2453 /* find first included terminal */
2454 k = FirstTaxonInPartition (constraintPartition, nLongsNeeded);
2455 for (i=0; pt->nodes[i].index != k; i++)
2456 ;
2457 pp = &pt->nodes[i];
2458
2459 /* go down until node is not included in constraint */
2460 do {
2461 qq = pp;
2462 pp = pp->anc;
2463 } while (IsPartNested(pp->partition, constraintPartition, nLongsNeeded));
2464
2465 /* check that the node has not yet been included */
2466 for (i=0; i<nLongsNeeded; i++)
2467 {
2468 if (qq->partition[i] != constraintPartition[i])
2469 break;
2470 }
2471 if (i==nLongsNeeded)
2472 {
2473 MrBayesPrint ("%s WARNING: Constraint '%s' is a duplicate of another constraint\n", spacer, constraintNames[constraintId]);
2474 MrBayesPrint ("%s and will be ignored\n", spacer);
2475 t->constraints[constraintId] = NO;
2476 continue;
2477 }
2478
2479 /* create a new node */
2480 tt = &pt->nodes[nextNode++];
2481 tt->anc = pp;
2482 tt->isLocked = YES;
2483 tt->lockID = constraintId;
2484 t->nLocks++;
2485 for (i=0; i<nLongsNeeded; i++)
2486 tt->partition[i] = constraintPartition[i];
2487 pt->nIntNodes++;
2488 pt->nNodes++;
2489
2490 /* sort descendant nodes in two connected groups: included and excluded */
2491 /* if there is a descendant that overlaps (incompatible) then return error */
2492 rr = ss = NULL;
2493 qq = pp->left;
2494 do {
2495 if (IsPartNested(qq->partition, constraintPartition, nLongsNeeded))
2496 {
2497 if (ss != NULL)
2498 ss->sib = qq;
2499 else
2500 tt->left = qq;
2501 ss = qq;
2502 qq->anc = tt;
2503 }
2504 else if (IsPartCompatible(qq->partition, constraintPartition, nLongsNeeded))
2505 {
2506 if (rr != NULL)
2507 rr->sib = qq;
2508 else
2509 tt->sib = qq;
2510 rr = qq;
2511 }
2512 else
2513 {
2514 free (constraintPartition);
2515 return (ERROR);
2516 }
2517 qq = qq->sib;
2518 } while (qq != NULL);
2519 pp->left = tt;
2520 rr->sib = ss->sib = NULL;
2521 }
2522
2523 /* relabel interior nodes */
2524 GetPolyDownPass(pt);
2525 for (i=0; i<pt->nIntNodes; i++)
2526 pt->intDownPass[i]->index = i + numLocalTaxa;
2527
2528 /* exit */
2529 free (constraintPartition);
2530 FreePolyTreePartitions(pt);
2531 return (NO_ERROR);
2532 }
2533
2534
2535 /*----------------------------------------------
2536 |
2537 | BuildRandomRTopology: Builds a random rooted
2538 | topology. Will set indices in t->nodes
2539 | such that they are from 0 to n-1 for the n tips
2540 | and from n to 2n-2 for the n-1 interior
2541 | nodes. Last is root. Does not touch labels
2542 | of tips.
2543 |
2544 ----------------------------------------------*/
BuildRandomRTopology(Tree * t,RandLong * seed)2545 int BuildRandomRTopology (Tree *t, RandLong *seed)
2546 {
2547 int i, j, nTips;
2548 TreeNode *p, *q, *r;
2549
2550 nTips = t->nNodes - t->nIntNodes - 1;
2551
2552 for (i=0; i<t->nNodes; i++)
2553 {
2554 p = &t->nodes[i];
2555 p->index = i;
2556 p->left = p->right = p->anc = NULL;
2557 }
2558
2559 /* connect the first two tip nodes */
2560 q = &t->nodes[0];
2561 r = &t->nodes[1];
2562 p = &t->nodes[nTips];
2563 q->anc = r->anc = p;
2564 p->left = q;
2565 p->right = r;
2566 q = &t->nodes[2*nTips-1];
2567 p->anc = q;
2568 q->left = p;
2569
2570 for (i=2; i<nTips; i++)
2571 {
2572 q = &t->nodes[i];
2573 r = &t->nodes[i-2+nTips+1];
2574 q->anc = r;
2575 r->left = q;
2576 j = (int) (RandomNumber(seed) * (2 * i - 1));
2577 if (j < i)
2578 p = &t->nodes[j];
2579 else
2580 p = &t->nodes[j-i + nTips];
2581 r->right = p;
2582 r->anc = p->anc;
2583 if (p->anc != NULL)
2584 {
2585 if (p->anc->left == p)
2586 p->anc->left = r;
2587 else
2588 p->anc->right = r;
2589 }
2590 p->anc = r;
2591 }
2592
2593 /* set root and get downpass */
2594 t->root = &t->nodes[2*nTips-1];
2595 GetDownPass (t);
2596
2597 /* relabel interior nodes */
2598 for (i=0; i<t->nIntNodes; i++)
2599 t->intDownPass[i]->index = i+nTips;
2600
2601 return (NO_ERROR);
2602 }
2603
2604
2605 /*----------------------------------------------
2606 |
2607 | BuildRandomUTopology: Builds a random unrooted
2608 | topology. Assumes that indices are set
2609 | in t->nodes from 0 to n-1 for the n tips
2610 | and from n to 2n-3 for the n-2 interior
2611 | nodes. Move the calculation root after
2612 | this routine to get the right root.
2613 |
2614 ----------------------------------------------*/
BuildRandomUTopology(Tree * t,RandLong * seed)2615 int BuildRandomUTopology (Tree *t, RandLong *seed)
2616 {
2617 int i, j, nTips;
2618 TreeNode *p, *q, *r;
2619
2620 nTips = t->nNodes - t->nIntNodes;
2621
2622 for (i=0; i<t->nNodes; i++)
2623 {
2624 p = &t->nodes[i];
2625 p->index = i;
2626 p->left = p->right = p->anc = NULL;
2627 }
2628
2629 /* connect the first three nodes, assuming 0 is calc root */
2630 q = &t->nodes[1];
2631 r = &t->nodes[2];
2632 p = &t->nodes[nTips];
2633 q->anc = r->anc = p;
2634 p->left = q;
2635 p->right = r;
2636 q = &t->nodes[0];
2637 p->anc = q;
2638 q->left = p;
2639
2640 for (i=3; i<nTips; i++)
2641 {
2642 q = &t->nodes[i];
2643 r = &t->nodes[i - 3 + nTips + 1];
2644 q->anc = r;
2645 r->left = q;
2646 j = (int) (RandomNumber(seed) * (2 * i - 3));
2647 if (j < i - 1)
2648 p = &t->nodes[j+1];
2649 else
2650 p = &t->nodes[j+1-i + nTips];
2651 r->right = p;
2652 r->anc = p->anc;
2653 if (p->anc->left == p)
2654 p->anc->left = r;
2655 else
2656 p->anc->right = r;
2657 p->anc = r;
2658 }
2659
2660 t->root = &t->nodes[0];
2661
2662 /* get downpass */
2663 GetDownPass (t);
2664
2665 /* relabel interior nodes */
2666 for (i=0; i<t->nIntNodes; i++)
2667 t->intDownPass[i]->index = i+nTips;
2668
2669 return (NO_ERROR);
2670 }
2671
2672
2673 /*----------------------------------------------------------------
2674 |
2675 | CheckConstraints: Check that tree complies with constraints
2676 |
2677 ----------------------------------------------------------------*/
CheckConstraints(Tree * t)2678 int CheckConstraints (Tree *t)
2679 {
2680 int a, i, j, k, nLongsNeeded;
2681 BitsLong *constraintPartition, *mask;
2682 TreeNode *p=NULL;
2683
2684 if (t->checkConstraints == NO)
2685 return (NO_ERROR);
2686
2687 /* allocate space */
2688 nLongsNeeded = (numLocalTaxa - 1) / nBitsInALong + 1;
2689 constraintPartition = (BitsLong *) SafeCalloc (2*nLongsNeeded, sizeof(BitsLong));
2690 if (!constraintPartition)
2691 {
2692 MrBayesPrint ("%s Problems allocating constraintPartition in CheckConstraints", spacer);
2693 return (ERROR);
2694 }
2695 mask = constraintPartition + nLongsNeeded;
2696
2697 /* set mask (needed to reset unused bits when flipping partitions) */
2698 for (i=0; i<numLocalTaxa; i++)
2699 SetBit (i, mask);
2700
2701 if (AllocateTreePartitions(t) == ERROR)
2702 {
2703 MrBayesPrint ("%s Problems allocating tree partitions in CheckConstraints", spacer);
2704 return (ERROR);
2705 }
2706
2707 for (a=0; a<numDefinedConstraints; a++)
2708 {
2709 if (t->constraints[a] == NO || definedConstraintsType[a] != HARD)
2710 continue;
2711
2712 /* set bits in partition to check */
2713 ClearBits(constraintPartition, nLongsNeeded);
2714 for (j=k=0; j<numTaxa; j++)
2715 {
2716 if (taxaInfo[j].isDeleted == YES)
2717 continue;
2718 if (IsBitSet(j, definedConstraint[a]) == YES)
2719 SetBit(k, constraintPartition);
2720 k++;
2721 }
2722
2723 /* make sure outgroup is outside constrained partition if unrooted tree */
2724 if (t->isRooted == NO && IsBitSet(localOutGroup, constraintPartition))
2725 FlipBits(constraintPartition, nLongsNeeded, mask);
2726
2727 /* find the locked node */
2728 for (i=j=0; i<t->nNodes; i++)
2729 {
2730 if (t->allDownPass[i]->isLocked == YES && t->allDownPass[i]->lockID == a)
2731 {
2732 p = t->allDownPass[i];
2733 j++;
2734 }
2735 }
2736
2737 if (j != 1)
2738 {
2739 MrBayesPrint ("%s Tree has %d locks with id %d identifying constraint '%s'\n", spacer, j, a, constraintNames[a]);
2740 free (constraintPartition);
2741 FreeTreePartitions(t);
2742 return (ERROR);
2743 }
2744
2745 /* check that locked node is correct */
2746 for (i=0; i<nLongsNeeded; i++)
2747 {
2748 if (p->partition[i] != constraintPartition[i])
2749 {
2750 MrBayesPrint ("%s Lock %d is set for the wrong node [this is a bug]\n", spacer, a);
2751 free (constraintPartition);
2752 FreeTreePartitions(t);
2753 return (ERROR);
2754 }
2755 }
2756 }
2757
2758 FreeTreePartitions (t);
2759 free (constraintPartition);
2760 return (NO_ERROR);
2761 }
2762
2763
2764 /*----------------------------------------------------------------
2765 |
2766 | CheckSetConstraints: Check and set tree constraints
2767 |
2768 ----------------------------------------------------------------*/
CheckSetConstraints(Tree * t)2769 int CheckSetConstraints (Tree *t)
2770 {
2771 int a, i, j, k, nLongsNeeded, foundIt, numLocks;
2772 BitsLong *constraintPartition, *mask;
2773 TreeNode *p;
2774
2775 if (t->checkConstraints == NO)
2776 return (NO_ERROR);
2777
2778 /* reset all existing locks, if any */
2779 for (i=0; i<t->nNodes; i++)
2780 {
2781 p = t->allDownPass[i];
2782 p->isLocked = NO;
2783 p->lockID = -1;
2784 if (p->left != NULL)
2785 {
2786 p->calibration = NULL;
2787 p->isDated = NO;
2788 p->age = -1.0;
2789 }
2790 }
2791
2792 /* allocate space */
2793 if (AllocateTreePartitions (t) == ERROR)
2794 {
2795 MrBayesPrint ("%s Problems allocating tree bitsets", spacer);
2796 return ERROR;
2797 }
2798
2799 nLongsNeeded = ((numLocalTaxa - 1) / nBitsInALong) + 1;
2800 constraintPartition = (BitsLong *) SafeCalloc (2*nLongsNeeded, sizeof(BitsLong));
2801 if (!constraintPartition)
2802 {
2803 MrBayesPrint ("%s Problems allocating constraintPartition", spacer);
2804 FreeTreePartitions(t);
2805 return ERROR;
2806 }
2807 mask = constraintPartition + nLongsNeeded;
2808
2809 /* set mask (needed to take care of unused bits when flipping partitions) */
2810 for (i=0; i<numLocalTaxa; i++)
2811 SetBit (i, mask);
2812
2813 numLocks = 0;
2814 for (a=0; a<numDefinedConstraints; a++)
2815 {
2816 if (modelParams[t->relParts[0]].activeConstraints[a] == NO || definedConstraintsType[a] != HARD)
2817 continue;
2818
2819 /* set bits in partition to add */
2820 ClearBits(constraintPartition, nLongsNeeded);
2821 for (i=j=0; i<numTaxa; i++)
2822 {
2823 if (taxaInfo[i].isDeleted == YES)
2824 continue;
2825 if (IsBitSet(i, definedConstraint[a]) == YES)
2826 SetBit(j, constraintPartition);
2827 j++;
2828 }
2829
2830 /* make sure outgroup is outside constrained partition (marked 0) */
2831 if (t->isRooted == NO && IsBitSet(localOutGroup, constraintPartition) == YES)
2832 FlipBits(constraintPartition, nLongsNeeded, mask);
2833
2834 /* skip partition if uninformative */
2835 k = NumBits(constraintPartition, nLongsNeeded);
2836 if (k == 0 || k == 1)
2837 continue;
2838
2839 /* find the node that should be locked */
2840 foundIt = NO;
2841 for (i=0; i<t->nIntNodes; i++)
2842 {
2843 p = t->intDownPass[i];
2844 for (j=0; j<nLongsNeeded; j++)
2845 {
2846 if (p->partition[j] != constraintPartition[j])
2847 break;
2848 }
2849
2850 if (j == nLongsNeeded)
2851 {
2852 foundIt = YES;
2853 p->isLocked = YES;
2854 p->lockID = a;
2855 if (nodeCalibration[a].prior != unconstrained)
2856 {
2857 p->isDated = YES;
2858 p->calibration = &nodeCalibration[a];
2859 }
2860 numLocks++;
2861 break;
2862 }
2863 }
2864
2865 if (foundIt == NO)
2866 {
2867 MrBayesPrint ("%s Tree breaks constraint '%s'\n", spacer, constraintNames[a]);
2868 FreeTreePartitions (t);
2869 free (constraintPartition);
2870 return (ERROR);
2871 }
2872 }
2873
2874 if (numLocks != t->nLocks)
2875 {
2876 MrBayesPrint ("%s Inconsistent lock settings. This is a bug, please report it.\n", spacer);
2877 FreeTreePartitions (t);
2878 free (constraintPartition);
2879 return (ERROR);
2880 }
2881
2882 /* exit */
2883 FreeTreePartitions(t);
2884 free (constraintPartition);
2885 return (NO_ERROR);
2886 }
2887
2888
2889 /*-----------------------------------------------------------------------
2890 |
2891 | ColorClusters: Recursive function to color the clusters in a tree by
2892 | assigning numbers to them in their variable x
2893 |
2894 ------------------------------------------------------------------------*/
ColorClusters(TreeNode * p,int * index)2895 void ColorClusters (TreeNode *p, int *index)
2896 {
2897 if (p!=NULL)
2898 {
2899 if (p->isLocked == YES || p->anc == NULL || p->anc->anc == NULL)
2900 p->x = (++(*index));
2901 else
2902 p->x = p->anc->x;
2903 ColorClusters(p->left, index);
2904 ColorClusters(p->right, index);
2905 }
2906 }
2907
2908
2909 /* CopyPolyNodes: Copies everything except pointers and memoryIndex */
CopyPolyNodes(PolyNode * p,PolyNode * q,int nLongsNeeded)2910 void CopyPolyNodes (PolyNode *p, PolyNode *q, int nLongsNeeded)
2911 {
2912 p->index = q->index;
2913 p->mark = q->mark;
2914 p->length = q->length;
2915 p->x = q->x;
2916 p->y = q->y;
2917 p->isDated = q->isDated;
2918 p->calibration = q->calibration;
2919 p->age = q->age;
2920 p->isLocked = q->isLocked;
2921 p->lockID = q->lockID;
2922 strcpy (p->label, q->label);
2923 if (nLongsNeeded!=0)
2924 {
2925 assert (p->partition);
2926 assert (q->partition);
2927 memcpy (p->partition,q->partition, nLongsNeeded*sizeof(BitsLong));
2928 }
2929 p->support = q->support;
2930 p->f = q->f;
2931 }
2932
2933
CopySubtreeToTree(Tree * subtree,Tree * t)2934 void CopySubtreeToTree (Tree *subtree, Tree *t)
2935 {
2936 int i, /*j,*/ k;
2937 TreeNode *p, *q=NULL, *r;
2938
2939 for (i=/*j=*/0; i<subtree->nNodes - 1; i++)
2940 {
2941 p = subtree->allDownPass[i];
2942
2943 for (k=0; k<t->nNodes; k++)
2944 {
2945 q = t->allDownPass[k];
2946 if (q->index == p->index)
2947 break;
2948 }
2949 q->length = p->length;
2950 q->marked = YES;
2951 if (p->left != NULL && p->right != NULL)
2952 {
2953 for (k=0; k<t->nNodes; k++)
2954 {
2955 r = t->allDownPass[k];
2956 if (r->index == p->left->index)
2957 {
2958 q->left = r;
2959 r->anc = q;
2960 }
2961 else if (r->index == p->right->index)
2962 {
2963 q->right = r;
2964 r->anc = q;
2965 }
2966 }
2967 }
2968 }
2969
2970 p = subtree->root;
2971
2972 for (k=0; k<t->nNodes; k++)
2973 {
2974 q = t->allDownPass[k];
2975 if (q->index == p->index)
2976 break;
2977 }
2978
2979 if (q->left->marked == YES)
2980 {
2981 for (k=0; k<t->nIntNodes; k++)
2982 {
2983 r = t->intDownPass[k];
2984 if (r->index == p->left->index)
2985 {
2986 q->left = r;
2987 r->anc = q;
2988 }
2989 }
2990 }
2991 else if (q->right->marked == YES)
2992 {
2993 for (k=0; k<t->nIntNodes; k++)
2994 {
2995 r = t->intDownPass[k];
2996 if (r->index == p->left->index)
2997 {
2998 q->right = r;
2999 r->anc = q;
3000 }
3001 }
3002 }
3003 }
3004
3005
3006 /*-----------------------------------------------------------------
3007 |
3008 | CopyToPolyTreeFromPolyTree: copies second tree to first tree
3009 |
3010 -----------------------------------------------------------------*/
CopyToPolyTreeFromPolyTree(PolyTree * to,PolyTree * from)3011 int CopyToPolyTreeFromPolyTree (PolyTree *to, PolyTree *from)
3012 {
3013 int i, j, k, nLongsNeeded;
3014 PolyNode *p, *q;
3015
3016 /* check we have enough memory */
3017 assert (to->memNodes >= from->nNodes);
3018 if (from->bitsets==NULL || to->bitsets==NULL)
3019 {
3020 nLongsNeeded=0;
3021 }
3022 else
3023 {
3024 assert (to->memNodes >= from->memNodes);/*Otherwise partition length woould not be long enough for nodes in "to" */
3025 nLongsNeeded = (from->memNodes/2 - 1) / nBitsInALong + 1;
3026 }
3027
3028 /* copy nodes */
3029 for (i=0; i<from->nNodes; i++)
3030 {
3031 /* copy pointers */
3032 p = from->nodes + i;
3033 q = to->nodes + i;
3034
3035 if (p->anc != NULL)
3036 q->anc = to->nodes + p->anc->memoryIndex;
3037 else
3038 {
3039 q->anc = NULL;
3040 to->root = q;
3041 }
3042
3043 if (p->left != NULL)
3044 q->left = to->nodes + p->left->memoryIndex;
3045 else
3046 q->left = NULL;
3047
3048 if (p->sib != NULL)
3049 q->sib = to->nodes + p->sib->memoryIndex;
3050 else
3051 q->sib = NULL;
3052
3053 /* Copy everything else except memoryIndex */
3054 CopyPolyNodes (q, p, nLongsNeeded);
3055 }
3056
3057 /* fill node arrays */
3058 /* copy tree properties */
3059 to->nNodes = from->nNodes;
3060 to->nIntNodes = from->nIntNodes;
3061 to->isRooted = from->isRooted;
3062 to->isClock = from->isClock;
3063 to->isRelaxed = from->isRelaxed;
3064 to->clockRate = from->clockRate;
3065 strcpy (to->name, from->name);
3066
3067 GetPolyDownPass (to);
3068
3069 /* copy partitions */
3070 if (from->bitsets)
3071 {
3072 if (!to->bitsets)
3073 AllocatePolyTreePartitions(to);
3074 else
3075 ResetPolyTreePartitions(to);
3076 }
3077
3078 /* copy relaxed clock parameters */
3079 FreePolyTreeRelClockParams (to);
3080
3081 if (from->nBSets + from->nESets > 0)
3082 AllocatePolyTreeRelClockParams (to, from->nBSets, from->nESets);
3083
3084 for (i=0; i<to->nBSets; i++)
3085 {
3086 to->bSetName[i] = (char *) SafeCalloc (strlen(from->bSetName[i])+2, sizeof(char));
3087 strcpy (to->bSetName[i], from->bSetName[i]);
3088 for (j=0; j<from->nNodes; j++)
3089 to->effectiveBrLen[i][j] = from->effectiveBrLen[i][j];
3090 }
3091
3092 for (i=0; i<to->nESets; i++)
3093 {
3094 to->eSetName[i] = (char *) SafeCalloc (strlen(from->eSetName[i])+2, sizeof(char));
3095 strcpy (to->eSetName[i], from->eSetName[i]);
3096 for (j=0; j<from->nNodes; j++)
3097 {
3098 to->nEvents[i][j] = from->nEvents[i][j];
3099 if (to->nEvents[i][j] > 0)
3100 {
3101 to->position[i][j] = (MrBFlt *) SafeCalloc (to->nEvents[i][j], sizeof (MrBFlt));
3102 to->rateMult[i][j] = (MrBFlt *) SafeCalloc (to->nEvents[i][j], sizeof (MrBFlt));
3103 for (k=0; k<to->nEvents[i][j]; k++)
3104 {
3105 to->position[i][j][k] = from->position[i][j][k];
3106 to->rateMult[i][j][k] = from->rateMult[i][j][k];
3107 }
3108 }
3109 }
3110 }
3111
3112 /* copy population size parameters */
3113 FreePolyTreePopSizeParams(to);
3114 to->popSizeSet = from->popSizeSet;
3115 if (to->popSizeSet == YES)
3116 {
3117 to->popSize = (MrBFlt *) SafeCalloc (to->nNodes, sizeof(MrBFlt));
3118 for (i=0; i<to->nNodes; i++)
3119 to->popSize[i] = from->popSize[i];
3120 to->popSizeSetName = (char *) SafeCalloc (strlen(from->popSizeSetName) + 1, sizeof(char));
3121 strcpy (to->popSizeSetName, from->popSizeSetName);
3122 }
3123
3124 return (NO_ERROR);
3125 }
3126
3127
3128 /*-----------------------------------------------------------------
3129 |
3130 | CopyToSpeciesTreeFromPolyTree: copies second tree (polytomous) to
3131 | first tree, which is a species tree. The species tree needs to
3132 | be allocated enough space first to hold the resulting tree.
3133 |
3134 -----------------------------------------------------------------*/
CopyToSpeciesTreeFromPolyTree(Tree * to,PolyTree * from)3135 int CopyToSpeciesTreeFromPolyTree (Tree *to, PolyTree *from)
3136 {
3137 int i;
3138 PolyNode *p;
3139 TreeNode *q, *q1;
3140 # if defined (DEBUG_SPECIESTREE)
3141 int j;
3142 # endif
3143
3144 /* make sure assumptions are correct */
3145 assert (from->isRooted == YES);
3146 assert (from->isClock == YES);
3147 assert (from->nNodes - from->nIntNodes == numSpecies);
3148 assert (to->memNodes == 2*numSpecies);
3149 assert (to->nIntNodes == from->nIntNodes);
3150 assert (to->nNodes == from->nNodes + 1);
3151
3152 /* make sure indices are set correctly for from nodes */
3153 # if defined (DEBUG_SPECIESTREE)
3154 for (i=0; i<from->nNodes; i++)
3155 {
3156 for (j=0; j<from->nNodes; j++)
3157 {
3158 p = from->allDownPass[j];
3159 if (p->index == i)
3160 break;
3161 }
3162 assert (j != from->nNodes);
3163 assert (!(p->left == NULL && p->index >= numSpecies));
3164 }
3165 # endif
3166
3167 /* copy nodes */
3168 for (i=0; i<from->nNodes; i++)
3169 {
3170 /* copy pointers */
3171 p = from->allDownPass[i];
3172 q = to->nodes + p->index;
3173
3174 if (p->anc != NULL)
3175 q->anc = to->nodes + p->anc->index;
3176 else
3177 q->anc = NULL;
3178
3179 if (p->left != NULL)
3180 q->left = to->nodes + p->left->index;
3181 else
3182 q->left = NULL;
3183
3184 if (p->left != NULL)
3185 q->right = to->nodes + p->left->sib->index;
3186 else
3187 q->right = NULL;
3188
3189 q->nodeDepth = p->depth;
3190 q->age = p->age;
3191 q->length = p->length;
3192 q->index = p->index;
3193 if (q->index < numSpecies)
3194 q->label = speciesNameSets[speciespartitionNum].names[q->index];
3195 else
3196 q->label = noLabel;
3197 }
3198
3199 /* fix root */
3200 p = from->root;
3201 q = to->nodes + p->index;
3202 q1 = to->nodes + from->nNodes; /* get the 'extra' root node that polytomous trees do not use */
3203 q->anc = q1;
3204 q1->index = from->nNodes;
3205 q1->left = q;
3206 q1->right = q1->anc = NULL;
3207 q1->isLocked = NO;
3208 q1->lockID = -1;
3209 q1->isDated = NO;
3210 q1->calibration = NULL;
3211 q1->age = -1.0;
3212 to->root = q1;
3213
3214 /* get downpass */
3215 GetDownPass (to);
3216
3217 /* a user tree might not come with node depths set */
3218 if (to->root->left->nodeDepth == 0.0)
3219 SetNodeDepths(to);
3220
3221 /* set partitions */
3222 if (to->bitsets)
3223 ResetTreePartitions(to);
3224
3225 return (NO_ERROR);
3226 }
3227
3228
3229 /*-----------------------------------------------------------------
3230 |
3231 | CopyToTreeFromPolyTree: copies second tree (polytomous) to first
3232 | tree (used to initialize constrained starting trees, e.g.).
3233 | An unrooted source tree will be rooted on outgroup
3234 | An unrooted source tree that needs to be copied to
3235 | a rooted target tree will be randomly rooted on a node below
3236 | all defined constraints. The to tree needs to be allocated
3237 | enough space first to hold the resulting tree.
3238 |
3239 -----------------------------------------------------------------*/
CopyToTreeFromPolyTree(Tree * to,PolyTree * from)3240 int CopyToTreeFromPolyTree (Tree *to, PolyTree *from)
3241 {
3242 int i, j;
3243 PolyNode *p=NULL;
3244 TreeNode *q, *q1;
3245
3246 /* refuse to arbitrarily root an input tree */
3247 assert (!(from->isRooted == NO && to->isRooted == YES));
3248 if ((from->isRooted == NO) && (to->isRooted == YES))
3249 {
3250 MrBayesPrint ("%s Failed to copy trees due to difference in rootedness of source and destination. \n", spacer);
3251 return (ERROR);
3252 }
3253
3254 /* make sure assumptions are in order */
3255 assert (to->memNodes >= from->nNodes + (to->isRooted == NO ? 0 : 1));
3256 assert (localOutGroup >= 0 && localOutGroup < numLocalTaxa);
3257 assert (numLocalTaxa == from->nNodes - from->nIntNodes);
3258 assert (!(from->isRooted == YES && from->nNodes != 2*from->nIntNodes + 1));
3259 assert (!(from->isRooted == NO && from->nNodes != 2*from->nIntNodes + 2));
3260
3261 /* make sure indices are set correctly for from nodes */
3262 for (i=0; i<from->nNodes; i++)
3263 {
3264 for (j=0; j<from->nNodes; j++)
3265 {
3266 p = from->allDownPass[j];
3267 if (p->index == i)
3268 break;
3269 }
3270 assert (j != from->nNodes);
3271 assert (!(p->left == NULL && p->index >= numLocalTaxa));
3272 }
3273
3274 /* deal with root */
3275 if (to->isRooted == NO && from->isRooted == YES)
3276 Deroot(from);
3277
3278 /* make sure calculation root is set correctly */
3279 if (to->isRooted == NO && MovePolyCalculationRoot (from, localOutGroup) == ERROR)
3280 return ERROR;
3281
3282 /* copy nodes */
3283 for (i=0; i<from->nNodes; i++)
3284 {
3285 /* copy pointers */
3286 p = from->allDownPass[i];
3287 q = to->nodes + p->index;
3288
3289 if (p->anc != NULL)
3290 q->anc = to->nodes + p->anc->index;
3291 else
3292 q->anc = NULL;
3293
3294 if (p->left != NULL)
3295 q->left = to->nodes + p->left->index;
3296 else
3297 q->left = NULL;
3298
3299 if (p->left != NULL)
3300 q->right = to->nodes + p->left->sib->index;
3301 else
3302 q->right = NULL;
3303
3304 q->isLocked = p->isLocked;
3305 q->lockID = p->lockID;
3306 q->isDated = p->isDated;
3307 q->calibration = p->calibration;
3308 q->age = p->age;
3309 q->nodeDepth = p->depth;
3310 q->length = p->length;
3311 q->index = p->index;
3312 if (q->index < numLocalTaxa)
3313 q->label = localTaxonNames[q->index];
3314 else
3315 q->label = noLabel;
3316 }
3317
3318 /* fix root */
3319 if (to->isRooted == NO)
3320 {
3321 p = from->root;
3322 q = to->nodes + p->index;
3323 q->anc = to->root = to->nodes + p->left->sib->sib->index;
3324 q->length = to->root->length;
3325 to->root->length = 0.0;
3326 to->root->left = q;
3327 to->root->right = to->root->anc = NULL;
3328 }
3329 else
3330 {
3331 p = from->root;
3332 q = to->nodes + p->index;
3333 q1 = to->nodes + from->nNodes; /* get the 'extra' root node that polytomous trees do not use */
3334 q->anc = q1;
3335 q1->index = from->nNodes;
3336 q1->left = q;
3337 q1->right = q1->anc = NULL;
3338 q1->isLocked = NO;
3339 q1->lockID = -1;
3340 q1->isDated = NO;
3341 q1->calibration = NULL;
3342 q1->age = -1.0;
3343 to->root = q1;
3344 }
3345
3346 /* get downpass */
3347 GetDownPass (to);
3348
3349 /* set node depths */
3350 if (to->isRooted == YES && to->root->left->nodeDepth == 0.0)
3351 SetNodeDepths(to);
3352
3353 /* set partitions */
3354 if (to->bitsets)
3355 ResetTreePartitions(to);
3356
3357 /* relaxed clock parameters are not stored in binary trees but in separate parameters */
3358
3359 return (NO_ERROR);
3360 }
3361
3362
3363 /*-----------------------------------------------------------------
3364 |
3365 | CopyToTreeFromTree: copies second tree to first tree
3366 | (used to initialize brlen sets for same topology)
3367 | Note: partition information of nodes are not copied if
3368 | either "from" or "to" tree does not have bitsets allocated
3369 |
3370 -----------------------------------------------------------------*/
CopyToTreeFromTree(Tree * to,Tree * from)3371 int CopyToTreeFromTree (Tree *to, Tree *from)
3372 {
3373 int i, numTaxa, nLongsNeeded;
3374 TreeNode *p, *q;
3375
3376 numTaxa = from->nNodes - from->nIntNodes - (from->isRooted == YES ? 1 : 0);
3377 nLongsNeeded = (numTaxa - 1) / nBitsInALong + 1;
3378 if (from->bitsets==NULL || to->bitsets==NULL)
3379 nLongsNeeded=0;
3380
3381 /* check that there is enough memory */
3382 assert (to->memNodes >= from->nNodes);
3383
3384 /* copy nodes (use index of p as memoryIndex for q) */
3385 for (i=0; i<from->nNodes; i++)
3386 {
3387 /* copy pointers */
3388 p = from->nodes + i;
3389 q = to->nodes + p->index;
3390
3391 if (p->anc != NULL)
3392 q->anc = to->nodes + p->anc->index;
3393 else
3394 {
3395 q->anc = NULL;
3396 to->root = q;
3397 }
3398
3399 if (p->left != NULL)
3400 q->left = to->nodes + p->left->index;
3401 else
3402 q->left = NULL;
3403
3404 if (p->right != NULL)
3405 q->right = to->nodes + p->right->index;
3406 else
3407 q->right = NULL;
3408
3409 CopyTreeNodes (q, p, nLongsNeeded);
3410 }
3411
3412 /* create new node arrays */
3413 to->nNodes = from->nNodes;
3414 to->nIntNodes = from->nIntNodes;
3415 GetDownPass (to);
3416
3417 /* copy tree properties (these should be constant most of them) */
3418 strcpy (to->name, from->name);
3419 to->isRooted = from->isRooted;
3420 to->isClock = from->isClock;
3421 to->isCalibrated = from->isCalibrated;
3422 to->checkConstraints = from->checkConstraints;
3423 to->nConstraints = from->nConstraints;
3424 to->constraints = from->constraints;
3425 to->nLocks = from->nLocks;
3426 to->nRelParts = from->nRelParts;
3427 to->relParts = from->relParts;
3428
3429 /* copy partitions */
3430 if (from->bitsets)
3431 {
3432 if (!to->bitsets)
3433 AllocateTreePartitions(to);
3434 else
3435 ResetTreePartitions(to);
3436 }
3437
3438 return (NO_ERROR);
3439 }
3440
3441
3442 /* Copy node q to node p */
CopyTreeNodes(TreeNode * p,TreeNode * q,int nLongsNeeded)3443 void CopyTreeNodes (TreeNode *p, TreeNode *q, int nLongsNeeded)
3444 {
3445 /* copies everything except pointers and memoryIndex */
3446 p->label = q->label;
3447 p->index = q->index;
3448 p->upDateCl = q->upDateCl;
3449 p->upDateTi = q->upDateTi;
3450 p->isLocked = q->isLocked;
3451 p->lockID = q->lockID;
3452 p->isDated = q->isDated;
3453 p->marked = q->marked;
3454 p->x = q->x;
3455 p->y = q->y;
3456 p->d = q->d;
3457 p->length = q->length;
3458 p->nodeDepth = q->nodeDepth;
3459 p->calibration = q->calibration;
3460 p->age = q->age;
3461 if (nLongsNeeded != 0)
3462 {
3463 assert (p->partition);
3464 assert (q->partition);
3465 memcpy (p->partition, q->partition, nLongsNeeded*sizeof(BitsLong));
3466 }
3467 }
3468
3469
CopyTreeToSubtree(Tree * t,Tree * subtree)3470 void CopyTreeToSubtree (Tree *t, Tree *subtree)
3471 {
3472 int i, j, k;
3473 TreeNode *p, *q, *r;
3474
3475 for (i=j=0; i<t->nNodes; i++)
3476 {
3477 p = t->allDownPass[i];
3478 if (p->marked == NO)
3479 continue;
3480
3481 q = &subtree->nodes[j++];
3482 q->index = p->index;
3483 q->length = p->length;
3484 if (p->left == NULL || p->left->marked == NO)
3485 q->left = q->right = NULL;
3486 else
3487 {
3488 for (k=0; k<j-1; k++)
3489 {
3490 r = &subtree->nodes[k];
3491 if (r->index == p->left->index)
3492 {
3493 q->left = r;
3494 r->anc = q;
3495 }
3496 else if (r->index == p->right->index)
3497 {
3498 q->right = r;
3499 r->anc = q;
3500 }
3501 }
3502 }
3503
3504 if (p->anc->marked == NO)
3505 {
3506 r = &subtree->nodes[j++];
3507 subtree->root = r;
3508 r->anc = r->right = NULL;
3509 r->left = q;
3510 q->anc = r;
3511 r->length = 0.0;
3512 r->index = p->anc->index;
3513 }
3514
3515 }
3516
3517 GetDownPass (subtree);
3518
3519 subtree->isRooted = t->isRooted;
3520 subtree->nRelParts = t->nRelParts;
3521 subtree->relParts = t->relParts;
3522 }
3523
3524
3525 /* DatedNodeDepths: Recursive function to get node depths */
DatedNodeDepths(TreeNode * p,MrBFlt * nodeDepths,int * index)3526 void DatedNodeDepths (TreeNode *p, MrBFlt *nodeDepths, int *index)
3527 {
3528 if (p != NULL)
3529 {
3530 if (p->left == NULL || p->isDated == YES)
3531 nodeDepths[(*index)++] = p->nodeDepth;
3532 else
3533 {
3534 DatedNodeDepths (p->left, nodeDepths, index);
3535 DatedNodeDepths (p->right, nodeDepths, index);
3536 }
3537 }
3538 }
3539
3540
3541 /* DatedNodes: Recursive function to get dated tips or interior nodes */
DatedNodes(TreeNode * p,TreeNode ** datedNodes,int * index)3542 void DatedNodes (TreeNode *p, TreeNode **datedNodes, int *index)
3543 {
3544 if (p != NULL)
3545 {
3546 if (p->left != NULL && p->isDated == NO)
3547 {
3548 DatedNodes (p->left, datedNodes, index);
3549 DatedNodes (p->right, datedNodes, index);
3550 }
3551 datedNodes[(*index)++] = p;
3552 }
3553 }
3554
3555
3556 /* Deroot: Deroot a rooted polytomous tree with branch lengths */
Deroot(PolyTree * pt)3557 int Deroot (PolyTree *pt)
3558 {
3559 PolyNode *p, *q, *r, tempNode;
3560 int i;
3561
3562 p = pt->root;
3563
3564 if (p->left->sib->sib != NULL)
3565 return (ERROR); /* tree is not rooted or it is polytomous */
3566
3567 if (p != &pt->nodes[pt->nNodes-1])
3568 {
3569 q = &pt->nodes[pt->nNodes-1];
3570 /* now swap content of p and q including pointers */
3571 tempNode = *q;
3572 *q = *p;
3573 *p = tempNode;
3574 /* swap back memoryindex */
3575 p->memoryIndex = q->memoryIndex;
3576 q->memoryIndex = tempNode.memoryIndex;
3577 /* all pointers to q should be pointers to p */
3578 for (i=0; i<pt->nNodes; i++)
3579 {
3580 r = &pt->nodes[i];
3581 if (r->left == q)
3582 r->left = p;
3583 if (r->anc == q)
3584 r->anc = p;
3585 if (r->sib == q)
3586 r->sib = p;
3587 }
3588 /* all pointers to p should be pointers to q; all these are anc pointers from the descendants of the root */
3589 pt->root = q;
3590 for (r=q->left; r!=NULL; r=r->sib)
3591 r->anc = q;
3592 /* finally set p to the new root */
3593 p = pt->root;
3594 }
3595
3596 /* make sure the left of the old root is interior and can be used as new root */
3597 if (p->left->left == NULL)
3598 {
3599 q = p->left;
3600 r = q->sib;
3601 p->left = r;
3602 r->sib = q;
3603 q->sib = NULL;
3604 }
3605
3606 pt->root = p->left;
3607 pt->root->left->sib->sib = p->left->sib;
3608 p->left->sib->length += pt->root->length;
3609 pt->root->length = 0.0;
3610 pt->root->sib = NULL;
3611 pt->root->anc = NULL;
3612
3613 pt->nNodes--;
3614 pt->nIntNodes--;
3615
3616 GetPolyDownPass(pt);
3617
3618 return (NO_ERROR);
3619 }
3620
3621
3622 /* EraseTreeList: Erase all trees in treeList */
EraseTreeList(TreeList * treeList)3623 void EraseTreeList (TreeList *treeList)
3624 {
3625 TreeListElement *listElement;
3626 TreeListElement *previous;
3627
3628 listElement = treeList->first;
3629 if (listElement != NULL)
3630 do
3631 {
3632 free (listElement->order);
3633 previous = listElement;
3634 listElement = listElement->next;
3635 free (previous);
3636 }
3637 while (listElement != NULL);
3638
3639 treeList->first = treeList->last = NULL;
3640 }
3641
3642
UpdateTreeWithClockrate(Tree * t,MrBFlt clockRate)3643 void UpdateTreeWithClockrate (Tree *t, MrBFlt clockRate)
3644 {
3645 int i;
3646 TreeNode *p;
3647
3648 if (t->fromUserTree == NO)
3649 {
3650 /*Set nodeDepth*/
3651 for (i=0; i<t->nNodes; i++)
3652 {
3653 p = t->allDownPass[i];
3654 p->nodeDepth = p->age * clockRate;
3655 }
3656
3657 /* calculate branch lengths */
3658 for (i=0; i<t->nNodes; i++)
3659 {
3660 p = t->allDownPass[i];
3661 if (p->anc != NULL)
3662 {
3663 if (p->anc->anc != NULL)
3664 {
3665 p->length = p->anc->nodeDepth - p->nodeDepth;
3666 }
3667 else
3668 p->length = 0.0; //not a problem for root node.
3669 }
3670 }
3671 }
3672 else
3673 {
3674 for (i=0; i<t->nNodes-1; i++)
3675 {
3676 p = t->allDownPass[i];
3677 p->age = p->nodeDepth / clockRate;
3678 }
3679 }
3680 }
3681
3682
3683 /*----------------------------------------------------------------
3684 |
3685 | findAllowedClockrate: Finds the range of clock rates allowed for the tree.
3686 |
3687 | @param t - tree to check (IN)
3688 | @minClockRate - address where minimum allowed clock rate is stored (OUT)
3689 | @maxClockRate - address where maximum allowed clock rate is stored (OUT)
3690 |
3691 ----------------------------------------------------------------*/
findAllowedClockrate(Tree * t,MrBFlt * minClockRate,MrBFlt * maxClockRate)3692 void findAllowedClockrate (Tree *t, MrBFlt *minClockRate, MrBFlt *maxClockRate)
3693 {
3694 int i;
3695 TreeNode *p;
3696 MrBFlt min, max, tmp;
3697
3698 min=0.0;
3699 max=MRBFLT_MAX;
3700
3701 *minClockRate = 2.0;
3702 *maxClockRate = 1.0;
3703
3704 if (t->fromUserTree == NO)
3705 {
3706 for (i=0; i<t->nNodes-1; i++)
3707 {
3708 p = t->allDownPass[i];
3709 if (p->anc->anc != NULL)
3710 {
3711 tmp = BRLENS_MIN/(p->anc->age - p->age);
3712 assert (tmp > 0);
3713 if (tmp > min)
3714 min = tmp;
3715
3716 tmp = BRLENS_MAX/(p->anc->age - p->age);
3717 assert (tmp > 0);
3718 if (tmp > max)
3719 max = tmp;
3720 }
3721 }
3722 *minClockRate= min;
3723 *maxClockRate= max;
3724 }
3725 else
3726 {
3727 IsCalibratedClockSatisfied (t,minClockRate,maxClockRate, 0.001);
3728 }
3729 }
3730
3731
3732 /* FreePolyTree: Free memory space for a polytomous tree (unrooted or rooted) */
FreePolyTree(PolyTree * pt)3733 void FreePolyTree (PolyTree *pt)
3734 {
3735 if (pt != NULL)
3736 {
3737 FreePolyTreePartitions(pt);
3738 FreePolyTreeRelClockParams(pt);
3739 FreePolyTreePopSizeParams(pt);
3740 free (pt->allDownPass);
3741 free (pt->nodes);
3742 free (pt);
3743 }
3744 }
3745
3746
3747 /* FreePolyTreePartitions: Free memory space for polytomous tree partitions */
FreePolyTreePartitions(PolyTree * pt)3748 void FreePolyTreePartitions (PolyTree *pt)
3749 {
3750 int i;
3751 if (pt != NULL && pt->bitsets != NULL)
3752 {
3753 for (i=0; i<pt->memNodes; i++)
3754 pt->nodes[i].partition = NULL;
3755 free (pt->bitsets);
3756 pt->bitsets = NULL;
3757 }
3758 }
3759
3760
3761 /* FreePolyTreePopSizeParams: Free population size set parameters of polytree */
FreePolyTreePopSizeParams(PolyTree * pt)3762 void FreePolyTreePopSizeParams (PolyTree *pt)
3763 {
3764 if (pt->popSizeSet == YES)
3765 {
3766 free (pt->popSize);
3767 free (pt->popSizeSetName);
3768 }
3769 pt->popSizeSet = NO;
3770 pt->popSize = NULL;
3771 pt->popSizeSetName = NULL;
3772 }
3773
3774
3775 /* FreePolyTreeRelClockParams: Free relaxed clock parameters of polytree */
FreePolyTreeRelClockParams(PolyTree * pt)3776 void FreePolyTreeRelClockParams (PolyTree *pt)
3777 {
3778 int i, j;
3779
3780 /* free breakpoint clock parameters */
3781 for (i=0; i<pt->nESets; i++)
3782 {
3783 for (j=0; j<pt->memNodes; j++)
3784 {
3785 if (pt->nEvents[i][j] > 0)
3786 {
3787 free (pt->position[i][j]);
3788 free (pt->rateMult[i][j]);
3789 }
3790 }
3791 free (pt->eSetName[i]);
3792 free (pt->nEvents[i]);
3793 free (pt->position[i]);
3794 free (pt->rateMult[i]);
3795 }
3796 free (pt->nEvents);
3797 free (pt->position);
3798 free (pt->rateMult);
3799 free (pt->eSetName);
3800 pt->nESets = 0;
3801 pt->nEvents = NULL;
3802 pt->position = NULL;
3803 pt->rateMult = NULL;
3804 pt->eSetName = NULL;
3805
3806 /* free branch clock parameters */
3807 for (i=0; i<pt->nBSets; i++)
3808 {
3809 free (pt->bSetName[i]);
3810 free (pt->effectiveBrLen[i]);
3811 }
3812 free (pt->effectiveBrLen);
3813 free (pt->bSetName);
3814 pt->nBSets = 0;
3815 pt->effectiveBrLen = NULL;
3816 pt->bSetName = NULL;
3817 }
3818
3819
3820 /* FreeTree: Free memory space for a tree (unrooted or rooted) */
FreeTree(Tree * t)3821 void FreeTree (Tree *t)
3822 {
3823 if (t != NULL)
3824 {
3825 free (t->bitsets);
3826 free (t->flags);
3827 free (t->allDownPass);
3828 #if defined (BEAGLE_V3_ENABLED)
3829 free (t->intDownPassLevel);
3830 #endif
3831 free (t->nodes);
3832 free (t);
3833 }
3834 }
3835
3836
3837 /* FreeTreePartitions: Free memory space for tree partitions */
FreeTreePartitions(Tree * t)3838 void FreeTreePartitions (Tree *t)
3839 {
3840 int i;
3841
3842 if (t != NULL && t->bitsets != NULL)
3843 {
3844 free (t->bitsets);
3845 t->bitsets = NULL;
3846 for (i=0; i<t->memNodes; i++)
3847 t->nodes[i].partition = NULL;
3848 }
3849 }
3850
3851
3852 /*-------------------------------------------------------------------------------------------
3853 |
3854 | GetDatedNodeDepths: Get an array containing the node depths of the dated tips,
3855 | internal or external, plus dated root
3856 |
3857 ---------------------------------------------------------------------------------------------*/
GetDatedNodeDepths(TreeNode * p,MrBFlt * nodeDepths)3858 void GetDatedNodeDepths (TreeNode *p, MrBFlt *nodeDepths)
3859 {
3860 int index = 0;
3861
3862 assert (p != NULL);
3863
3864 nodeDepths[index++] = p->nodeDepth; /* include root node depth */
3865 if (p->left != NULL)
3866 {
3867 DatedNodeDepths (p->left, nodeDepths, &index);
3868 DatedNodeDepths (p->right, nodeDepths, &index);
3869 }
3870 }
3871
3872
3873 /*-------------------------------------------------------------------------------------------
3874 |
3875 | GetDatedNodes: Get an array containing the dated tips,
3876 | internal or external, and all interior nodes in the same subtree
3877 |
3878 ---------------------------------------------------------------------------------------------*/
GetDatedNodes(TreeNode * p,TreeNode ** datedNodes)3879 void GetDatedNodes (TreeNode *p, TreeNode **datedNodes)
3880 {
3881 int index = 0;
3882
3883 assert (p != NULL);
3884
3885 if (p->left!= NULL)
3886 {
3887 DatedNodes (p->left, datedNodes, &index);
3888 DatedNodes (p->right, datedNodes, &index);
3889 }
3890 }
3891
3892
3893 /* get down pass for tree t (wrapper function) */
GetDownPass(Tree * t)3894 void GetDownPass (Tree *t)
3895 {
3896 int i, j;
3897
3898 i = j = 0;
3899 GetNodeDownPass (t, t->root, &i, &j);
3900 #if defined (BEAGLE_V3_ENABLED)
3901 if (t->levelPassEnabled)
3902 {
3903 i = 0;
3904 ReverseLevelOrder (t, t->root, &i);
3905 }
3906 #endif
3907 }
3908
3909
3910 /* get the actual down pass sequences */
GetNodeDownPass(Tree * t,TreeNode * p,int * i,int * j)3911 void GetNodeDownPass (Tree *t, TreeNode *p, int *i, int *j)
3912 {
3913 if (p != NULL)
3914 {
3915 GetNodeDownPass (t, p->left, i, j);
3916 GetNodeDownPass (t, p->right, i, j);
3917 if (p->left != NULL && p->right != NULL && p->anc != NULL)
3918 {
3919 t->intDownPass[(*i)++] = p;
3920 t->allDownPass[(*j)++] = p;
3921 }
3922 else if (p->left == NULL && p->right == NULL && p->anc != NULL)
3923 {
3924 t->allDownPass[(*j)++] = p;
3925 }
3926 else if (p->left != NULL && p->right == NULL && p->anc == NULL)
3927 {
3928 t->allDownPass[(*j)++] = p;
3929 }
3930 }
3931 }
3932
3933 #if defined (BEAGLE_V3_ENABLED)
3934 /* Compute the "height" of a tree -- the number of
3935 nodes along the longest path from the root node
3936 down to the farthest leaf node.*/
Height(TreeNode * p)3937 int Height(TreeNode *p)
3938 {
3939 if (p==NULL)
3940 return 0;
3941 else
3942 {
3943 /* compute the height of each subtree */
3944 int lheight = Height(p->left);
3945 int rheight = Height(p->right);
3946
3947 /* use the larger one */
3948 if (lheight > rheight)
3949 return(lheight+1);
3950 else
3951 return(rheight+1);
3952 }
3953 }
3954 /* Function to perform reverse level order traversal a tree*/
ReverseLevelOrder(Tree * t,TreeNode * p,int * i)3955 void ReverseLevelOrder(Tree *t, TreeNode *p, int *i)
3956 {
3957 int h = Height(p);
3958 int l;
3959 for (l=h; l>=1; l--)
3960 StoreGivenLevel(t, p, l, i);
3961 }
3962 /* Store nodes at a given level */
StoreGivenLevel(Tree * t,TreeNode * p,int level,int * i)3963 void StoreGivenLevel(Tree *t, TreeNode *p, int level, int *i)
3964 {
3965 if (p == NULL)
3966 return;
3967 if (level == 1)
3968 {
3969 if (p->left != NULL && p->right != NULL && p->anc != NULL)
3970 {
3971 t->intDownPassLevel[(*i)++] = p;
3972 }
3973 }
3974 else if (level > 1)
3975 {
3976 StoreGivenLevel(t, p->left, level-1, i);
3977 StoreGivenLevel(t, p->right, level-1, i);
3978 }
3979 }
3980 #endif
3981
3982 /* GetPolyAges: Get PolyTree node ages */
GetPolyAges(PolyTree * t)3983 void GetPolyAges (PolyTree *t)
3984 {
3985 int i;
3986 PolyNode *p;
3987
3988 GetPolyDepths (t); /* just to make sure... */
3989
3990 for (i=0; i<t->nNodes; i++)
3991 {
3992 p = t->allDownPass[i];
3993 p->age = p->depth / t->clockRate;
3994 }
3995 }
3996
3997
3998 /* GetPolyDepths: Get PolyTree node depths */
GetPolyDepths(PolyTree * t)3999 void GetPolyDepths (PolyTree *t)
4000 {
4001 int i;
4002 MrBFlt maxDepth;
4003 PolyNode *p;
4004
4005 maxDepth = t->root->depth = 0.0;
4006
4007 for (i=t->nNodes-2; i>=0; i--)
4008 {
4009 p = t->allDownPass[i];
4010 p->depth = p->anc->depth + p->length;
4011 if (p->depth > maxDepth)
4012 maxDepth = p->depth;
4013 }
4014
4015 for (i=0; i<t->nNodes; i++)
4016 {
4017 p = t->allDownPass[i];
4018 p->depth = maxDepth - p->depth;
4019 }
4020 }
4021
4022
4023 /* get down pass for polytomous tree t (wrapper function) */
GetPolyDownPass(PolyTree * t)4024 void GetPolyDownPass (PolyTree *t)
4025 {
4026 int i, j;
4027
4028 i = j = 0;
4029 GetPolyNodeDownPass (t, t->root, &i, &j);
4030 assert (t->nIntNodes==j);
4031 }
4032
4033
4034 /* get the actual down pass sequences for a polytomous tree */
GetPolyNodeDownPass(PolyTree * t,PolyNode * p,int * i,int * j)4035 void GetPolyNodeDownPass (PolyTree *t, PolyNode *p, int *i, int *j)
4036 {
4037 PolyNode *q;
4038
4039 if (p->left != NULL)
4040 {
4041 for (q=p->left; q!=NULL; q=q->sib)
4042 GetPolyNodeDownPass(t, q, i, j);
4043 }
4044
4045 t->allDownPass[(*i)++] = p;
4046 if (p->left != NULL)
4047 t->intDownPass[(*j)++] = p;
4048 }
4049
4050
4051 /* GetFromTreeList: Get first tree from a tree list and remove it from the list*/
GetFromTreeList(TreeList * treeList,Tree * tree)4052 int GetFromTreeList (TreeList *treeList, Tree *tree)
4053 {
4054 TreeListElement *listElement;
4055
4056 if (treeList->first == NULL)
4057 {
4058 MrBayesPrint ("%s Tree list empty\n", spacer);
4059 return (ERROR);
4060 }
4061 if (tree->isRooted == YES)
4062 RetrieveRTopology (tree, treeList->first->order);
4063 else
4064 {
4065 RetrieveUTopology (tree, treeList->first->order);
4066 if (localOutGroup != 0)
4067 MoveCalculationRoot (tree, localOutGroup);
4068 }
4069
4070 listElement = treeList->first;
4071 treeList->first = listElement->next;
4072
4073 free (listElement->order);
4074 free (listElement);
4075
4076 return (NO_ERROR);
4077 }
4078
4079
4080 /*------------------------------------------------------------------
4081 |
4082 | InitBrlens: This routine will set all branch lengths of a
4083 | nonclock tree to the value given by 'v'.
4084 |
4085 ------------------------------------------------------------------*/
InitBrlens(Tree * t,MrBFlt v)4086 int InitBrlens (Tree *t, MrBFlt v)
4087 {
4088 int i;
4089 TreeNode *p;
4090
4091 for (i=0; i<t->nNodes; i++)
4092 {
4093 p = t->allDownPass[i];
4094 if (p->anc != NULL && !(t->isRooted == YES && p->anc->anc == NULL))
4095 p->length = v;
4096 else
4097 p->length = 0.0;
4098 }
4099
4100 return (NO_ERROR);
4101 }
4102
4103
4104 /*
4105 @param levUp is the number of edges between the "node" and the most resent calibrated predecessor +1,
4106 for the calibrated nodes it should be 1
4107 @param calibrUp is the age of the most resent calibrated predecessor
4108 @return age of the node
4109 */
SetNodeCalibratedAge(TreeNode * node,unsigned levUp,MrBFlt calibrUp)4110 MrBFlt SetNodeCalibratedAge(TreeNode *node, unsigned levUp, MrBFlt calibrUp)
4111 {
4112 MrBFlt r,l;
4113
4114 if (node->age != -1.0)
4115 {
4116 if (node->right != NULL)
4117 SetNodeCalibratedAge (node->right, 2, node->age);
4118 if (node->left != NULL)
4119 SetNodeCalibratedAge (node->left, 2, node->age);
4120 return node->age;
4121 }
4122
4123 r = SetNodeCalibratedAge (node->right, levUp+1, calibrUp);
4124 l = SetNodeCalibratedAge (node->left, levUp+1, calibrUp);
4125
4126 if (r > l)
4127 {
4128 assert (calibrUp - r > 0.0);
4129 return node->age = r + (calibrUp - r)/levUp;
4130 }
4131 else
4132 {
4133 assert (calibrUp - l > 0.0);
4134 return node->age = l + (calibrUp - l)/levUp;
4135 }
4136 }
4137
4138
4139 /*-------------------------------------------------------------------
4140 |
4141 | InitCalibratedBrlens: This routine will build a clock tree
4142 | consistent with calibration constraints on terminal
4143 | taxa and/or constrained interior nodes. At least one
4144 | node should be calibrated.
4145 | If not possible to build such a tree, ERROR
4146 | is returned.
4147 |
4148 --------------------------------------------------------------------*/
InitCalibratedBrlens(Tree * t,MrBFlt clockRate,RandLong * seed)4149 int InitCalibratedBrlens (Tree *t, MrBFlt clockRate, RandLong *seed)
4150 {
4151 int i;
4152 TreeNode *p;
4153 Model *mp;
4154 MrBFlt treeAgeMin, treeAgeMax;
4155 Calibration *calibrationPtr;
4156
4157 # ifdef DEBUG_CALIBRATION
4158 printf ("Before initializing calibrated brlens\n");
4159 ShowNodes(t->root, 0, YES);
4160 # endif
4161
4162 if (t->isRooted == NO)
4163 {
4164 MrBayesPrint ("%s Tree is unrooted\n", spacer);
4165 return (ERROR);
4166 }
4167
4168 /* Check whether root has age constraints */
4169 mp = &modelParams[t->relParts[0]];
4170 treeAgeMin = 0.0;
4171 treeAgeMax = POS_INFINITY;
4172 if (t->root->left->isDated == YES)
4173 {
4174 treeAgeMin = t->root->left->calibration->min; /* FIXME: Not used (from clang static analyzer) */
4175 treeAgeMax = t->root->left->calibration->max;
4176 }
4177 else if (!strcmp(mp->clockPr, "Uniform") ||
4178 !strcmp(mp->clockPr, "Birthdeath") ||
4179 !strcmp(mp->clockPr, "Fossilization"))
4180 {
4181 if (mp->treeAgePr.min > treeAgeMin)
4182 treeAgeMin = mp->treeAgePr.min; /* FIXME: Not used (from clang static analyzer) */
4183 if (mp->treeAgePr.max < treeAgeMax)
4184 treeAgeMax = mp->treeAgePr.max;
4185 }
4186
4187 /* date all nodes from top to bottom with min. age as nodeDepth*/
4188 for (i=0; i<t->nNodes; i++)
4189 {
4190 p = t->allDownPass[i];
4191 if (p->anc != NULL)
4192 {
4193 if (p->left == NULL && p->right == NULL)
4194 {
4195 if (p->isDated == NO)
4196 {
4197 p->nodeDepth = 0.0;
4198 p->age = 0.0;
4199 }
4200 else
4201 {
4202 if (p->calibration->prior == fixed)
4203 p->nodeDepth = p->age = p->calibration->priorParams[0];
4204 else
4205 p->nodeDepth = p->age = p->calibration->min;
4206 }
4207 }
4208 else
4209 {
4210 if (p->left->nodeDepth > p->right->nodeDepth)
4211 p->nodeDepth = p->left->nodeDepth;
4212 else
4213 p->nodeDepth = p->right->nodeDepth;
4214 if (p->isDated == YES || (p->anc->anc == NULL && (!strcmp(mp->clockPr, "Uniform") ||
4215 !strcmp(mp->clockPr, "Birthdeath") ||
4216 !strcmp(mp->clockPr, "Fossilization"))))
4217 {
4218 if (p->isDated == NO)
4219 calibrationPtr = &mp->treeAgePr;
4220 else
4221 calibrationPtr = p->calibration;
4222
4223 if (calibrationPtr->max <= p->nodeDepth)
4224 {
4225 if (p->isDated == NO)
4226 MrBayesPrint ("%s Calibration inconsistency for root node\n", spacer);
4227 else
4228 MrBayesPrint ("%s Calibration inconsistency for node '%s'\n", spacer, constraintNames[p->lockID]);
4229 MrBayesPrint ("%s Cannot make a tree where the node is %s\n", spacer, calibrationPtr->name);
4230 return (ERROR);
4231 }
4232 else
4233 {
4234 if (calibrationPtr->min < p->nodeDepth)
4235 p->age = p->nodeDepth;
4236 else
4237 p->age = p->nodeDepth = calibrationPtr->min;
4238 }
4239 }
4240 else
4241 p->age = -1.0;
4242 }
4243 }
4244 }
4245
4246 /* try to make root node deeper than minimum age */
4247 p = t->root->left;
4248 if (p->nodeDepth==0.0) p->nodeDepth = 1.0;
4249 if (p->nodeDepth * 1.5 < treeAgeMax)
4250 p->nodeDepth = p->age = 1.5 * p->nodeDepth;
4251 else
4252 p->nodeDepth = p->age = treeAgeMax;
4253
4254 SetNodeCalibratedAge (p, 1, p->age);
4255
4256 /* Setup node depths */
4257 for (i=0; i<t->nNodes; i++)
4258 {
4259 p = t->allDownPass[i];
4260 p->nodeDepth = p->age * clockRate;
4261 assert (!(p->left == NULL && p->calibration == NULL && p->nodeDepth != 0.0));
4262 }
4263
4264 /* calculate branch lengths */
4265 for (i=0; i<t->nNodes; i++)
4266 {
4267 p = t->allDownPass[i];
4268 if (p->anc != NULL)
4269 {
4270 if (p->anc->anc != NULL)
4271 {
4272 p->length = p->anc->nodeDepth - p->nodeDepth;
4273 if (p->length < BRLENS_MIN)
4274 {
4275 //MrBayesPrint ("%s Restrictions of node calibration and clockrate makes some branch lengths too small.\n", spacer);
4276 //return (ERROR);
4277 }
4278 if (p->length > BRLENS_MAX)
4279 {
4280 //MrBayesPrint ("%s Restrictions of node calibration and clockrate makes some branch lengths too long.\n", spacer);
4281 //return (ERROR);
4282 }
4283 }
4284 else
4285 p->length = 0.0; //not a problem for root node.
4286 }
4287 }
4288
4289 # ifdef DEBUG_CALIBRATION
4290 printf ("after\n");
4291 ShowNodes (t->root, 0, YES);
4292 getchar();
4293 # endif
4294
4295 return (NO_ERROR);
4296 }
4297
4298
4299 /*-------------------------------------------------------
4300 |
4301 | InitClockBrlens: This routine will initialize
4302 | a clock tree by setting the root to depth 1.0
4303 | and then assigning node depths according to
4304 | the relative node depth measured in terms of the
4305 | maximum number of branches to the tip from each
4306 | node.
4307 |
4308 --------------------------------------------------------*/
InitClockBrlens(Tree * t)4309 int InitClockBrlens (Tree *t)
4310 {
4311 int i, maxBrSegments=0;
4312 TreeNode *p;
4313
4314 if (t->isRooted == NO)
4315 {
4316 MrBayesPrint ("%s Tree is unrooted\n", spacer);
4317 return (ERROR);
4318 }
4319
4320 /* calculate maximum number of branch segments above root */
4321 for (i=0; i<t->nNodes; i++)
4322 {
4323 p = t->allDownPass[i];
4324 if (p->anc != NULL)
4325 {
4326 if (p->left == NULL && p->right == NULL)
4327 {
4328 p->x = 0;
4329 }
4330 else
4331 {
4332 if (p->left->x > p->right->x)
4333 p->x = p->left->x + 1;
4334 else
4335 p->x = p->right->x + 1;
4336 }
4337 if (p->anc->anc == NULL)
4338 maxBrSegments = p->x;
4339 }
4340 }
4341
4342 /* assign node depths */
4343 for (i=0; i<t->nNodes; i++)
4344 {
4345 p = t->allDownPass[i];
4346 if (p->anc != NULL)
4347 p->nodeDepth = (MrBFlt) (p->x) / (MrBFlt) maxBrSegments;
4348 else
4349 p->nodeDepth = 0.0;
4350 }
4351
4352 /* calculate branch lengths */
4353 for (i=0; i<t->nNodes; i++)
4354 {
4355 p = t->allDownPass[i];
4356 if (p->anc != NULL)
4357 {
4358 if (p->anc->anc != NULL)
4359 p->length = p->anc->nodeDepth - p->nodeDepth;
4360 else
4361 p->length = 0.0;
4362 }
4363 }
4364
4365 return (NO_ERROR);
4366 }
4367
4368
GetRandomEmbeddedSubtree(Tree * t,int nTerminals,RandLong * seed,int * nEmbeddedTrees)4369 int GetRandomEmbeddedSubtree (Tree *t, int nTerminals, RandLong *seed, int *nEmbeddedTrees)
4370 {
4371 int i, j, k, n, ran, *pP, *pL, *pR, nLeaves, *nSubTrees;
4372 TreeNode *p=NULL, **leaf;
4373
4374 /* Calculate number of leaves in subtree (number of terminals minus the root) */
4375 nLeaves = nTerminals - 1;
4376
4377 /* Initialize all flags */
4378 for (i=0; i<t->nNodes; i++)
4379 {
4380 p = t->allDownPass[i];
4381 p->marked = NO;
4382 p->x = 0;
4383 p->y = 0;
4384 }
4385
4386 /* Allocate memory */
4387 nSubTrees = (int *) SafeCalloc (nTerminals * t->nNodes, sizeof(int));
4388 if (!nSubTrees)
4389 return (ERROR);
4390 leaf = (TreeNode **) SafeMalloc (nLeaves * sizeof (TreeNode *));
4391 if (!leaf)
4392 {
4393 free (nSubTrees);
4394 return (ERROR);
4395 }
4396
4397 /* Calculate how many embedded trees rooted at each node */
4398 (*nEmbeddedTrees) = 0;
4399 for (i=0; i<t->nNodes-1; i++)
4400 {
4401 p = t->allDownPass[i];
4402 if (p->left == NULL)
4403 {
4404 p->x = 0;
4405 nSubTrees[p->index*nTerminals + 1] = 1;
4406 }
4407 else
4408 {
4409 pL = nSubTrees + p->left->index*nTerminals;
4410 pR = nSubTrees + p->right->index*nTerminals;
4411 pP = nSubTrees + p->index*nTerminals;
4412 pP[1] = 1;
4413 for (j=2; j<=nLeaves; j++)
4414 {
4415 for (k=1; k<j; k++)
4416 {
4417 pP[j] += pL[k] * pR[j-k];
4418 }
4419 }
4420 p->x = pP[nLeaves];
4421 (*nEmbeddedTrees) += p->x;
4422 }
4423 }
4424
4425 /* Randomly select one embedded tree of the right size */
4426 ran = (int) (RandomNumber(seed) * (*nEmbeddedTrees));
4427
4428 /* Find the interior root corresponding to this tree */
4429 for (i=j=0; i<t->nIntNodes; i++)
4430 {
4431 p = t->intDownPass[i];
4432 j += p->x;
4433 if (j>ran)
4434 break;
4435 }
4436
4437 /* Find one random embedded tree with this root */
4438 p->y = nLeaves;
4439 p->marked = YES;
4440 leaf[0] = p;
4441 n = 1;
4442 while (n < nLeaves)
4443 {
4444 /* select a node with more than one descendant */
4445 for (i=0; i<n; i++)
4446 {
4447 p = leaf[i];
4448 if (p->y > 1)
4449 break;
4450 }
4451
4452 /* break it into descendants */
4453 pL = nSubTrees + p->left->index*nTerminals;
4454 pR = nSubTrees + p->right->index*nTerminals;
4455 pP = nSubTrees + p->index*nTerminals;
4456 ran = (int) (RandomNumber(seed) * pP[p->y]);
4457 k = 0;
4458 for (j=1; j<p->y; j++)
4459 {
4460 k += pL[j] * pR[p->y-j];
4461 if (k > ran)
4462 break;
4463 }
4464
4465 p->left->y = j;
4466 p->right->y = p->y - j;
4467 p->left->marked = YES;
4468 p->right->marked = YES;
4469 leaf[i] = p->left;
4470 leaf[n++] = p->right;
4471 }
4472
4473 free (nSubTrees);
4474 free (leaf);
4475
4476 return (NO_ERROR);
4477 }
4478
4479
4480 /*-----------------------------------------------------------------------------
4481 |
4482 | IsCalibratedClockSatisfied: This routine SETS (not just checks as name suggested) calibrated clock tree nodes age, depth. based on branch lengths
4483 | and checks that user defined brlens satisfy the specified calibration(s) up to tolerance tol
4484 | TODO: clock rate is devived here and used to set ages but clockrate parameter is not updated here (make sure that it does not produce inconsistancy)
4485 |
4486 |------------------------------------------------------------------------------*/
IsCalibratedClockSatisfied(Tree * t,MrBFlt * minClockRate,MrBFlt * maxClockRate,MrBFlt tol)4487 int IsCalibratedClockSatisfied (Tree *t,MrBFlt *minClockRate,MrBFlt *maxClockRate , MrBFlt tol)
4488 {
4489 int i, j, maxRateConstrained, minRateConstrained, isViolated;
4490 MrBFlt f, maxHeight, minRate=0, maxRate=0, ageToAdd, *x, *y, clockRate;
4491 TreeNode *p, *q, *r, *s;
4492
4493 /* By defauult assume the tree does not have allowed range of clockrate */
4494 *minClockRate = 2.0;
4495 *maxClockRate = 1.0;
4496
4497 if (t->isRooted == NO)
4498 return (NO);
4499
4500 x = (MrBFlt *) SafeCalloc (2*t->nNodes, sizeof (MrBFlt));
4501 if (x == NULL)
4502 {
4503 MrBayesPrint ("%s Out of memory in IsCalibratedClockSatisfied\n", spacer);
4504 free (x);
4505 return (NO);
4506 }
4507 y = x + t->nNodes;
4508
4509 /* reset node depth and age, and set minimum (x) and maximum (y) age of each node */
4510 for (i=0; i<t->nNodes; i++)
4511 {
4512 p = t->allDownPass[i];
4513 p->age = -1.0;
4514 p->nodeDepth = -1.0;
4515 if (p->isDated == YES)
4516 {
4517 assert (p->calibration->prior != unconstrained);
4518 x[p->index] = p->calibration->min;
4519 y[p->index] = p->calibration->max;
4520 }
4521 else if (p->left == NULL && p->right == NULL)
4522 x[p->index] = y[p->index] = 0.0;
4523 else
4524 {
4525 x[p->index] = y[p->index] = -1.0;
4526 }
4527 }
4528
4529 /* calculate node heights in branch length units */
4530 /* node depth will be set from the root for now */
4531 p = t->root->left;
4532 p->nodeDepth = 0.0;
4533 for (i=t->nNodes-3; i>=0; i--)
4534 {
4535 p = t->allDownPass[i];
4536 p->nodeDepth = p->anc->nodeDepth + p->length;
4537 }
4538
4539 /* find maximum height of tree */
4540 maxHeight = -1.0;
4541 for (i=0; i<t->nNodes-1; i++)
4542 {
4543 p = t->allDownPass[i];
4544 if (p->left == NULL && p->right == NULL)
4545 {
4546 if (p->nodeDepth > maxHeight)
4547 {
4548 maxHeight = p->nodeDepth;
4549 }
4550 }
4551 }
4552
4553 /* calculate node depth from tip of tree */
4554 for (i=0; i<t->nNodes-1; i++)
4555 {
4556 p = t->allDownPass[i];
4557 p->nodeDepth = maxHeight - p->nodeDepth;
4558 }
4559
4560 /* check potentially constraining calibrations */
4561 /* and find minimum and maximum possible rate */
4562 maxRateConstrained = NO;
4563 minRateConstrained = NO;
4564 isViolated = NO;
4565 for (i=0; i<t->nNodes-1; i++)
4566 {
4567 p = t->allDownPass[i];
4568 if (x[p->index] < 0.0 && y[p->index] < 0.0)
4569 continue;
4570 for (j=i+1; j<t->nNodes-1; j++)
4571 {
4572 q = t->allDownPass[j];
4573 if (x[q->index] < 0.0 && y[q->index] < 0.0)
4574 continue;
4575 if (p->nodeDepth == q->nodeDepth) // becouse clock rate could be as low as possible we can not take approximate equality.
4576 {
4577 /* same depth so they must share a possible age */
4578 if ((x[p->index] != -1.0 && y[q->index] !=-1.0 && AreDoublesEqual (x[p->index], y[q->index], tol) == NO && x[p->index] > y[q->index]) ||
4579 (y[p->index] != -1.0 && x[q->index] !=-1.0 && AreDoublesEqual (y[p->index], x[q->index], tol) == NO && y[p->index] < x[q->index]))
4580 {
4581 isViolated = YES;
4582 break;
4583 }
4584 }
4585 else
4586 {
4587 if (p->nodeDepth > q->nodeDepth)
4588 {
4589 r = p;
4590 s = q;
4591 }
4592 else
4593 {
4594 r = q;
4595 s = p;
4596 }
4597 if (x[r->index] >= 0.0 && y[s->index] >= 0.0)
4598 {
4599 f = (r->nodeDepth - s->nodeDepth) / (x[r->index] - y[s->index]);
4600 if (f <= 0.0 || x[r->index] == y[s->index])
4601 {
4602 if (AreDoublesEqual (r->nodeDepth, s->nodeDepth, tol*0.1) == YES)
4603 continue;
4604 if ((r->calibration != NULL && r->calibration->prior != fixed) || (s->calibration != NULL && s->calibration->prior != fixed))
4605 continue;
4606 isViolated = YES;
4607 break;
4608 }
4609 if (maxRateConstrained == NO)
4610 {
4611 maxRateConstrained = YES;
4612 maxRate = f;
4613 }
4614 else if (f < maxRate)
4615 maxRate = f;
4616 }
4617 if (y[r->index] >= 0.0 && x[s->index] >= 0.0)
4618 {
4619 f = (r->nodeDepth - s->nodeDepth) / (y[r->index] - x[s->index]);
4620 if (f <= 0.0 || y[r->index] == x[s->index])
4621 {
4622 if (AreDoublesEqual (r->nodeDepth, s->nodeDepth, tol*0.1) == YES)
4623 continue;
4624 isViolated = YES;
4625 break;
4626 }
4627 if (minRateConstrained == NO)
4628 {
4629 minRateConstrained = YES;
4630 minRate = f;
4631 }
4632 else if (f > minRate)
4633 minRate = f;
4634 }
4635 }
4636 }
4637 if (isViolated == YES)
4638 break;
4639 }
4640
4641 /* check if outright violation */
4642 if (isViolated == YES)
4643 {
4644 MrBayesPrint ("%s Branch lengths do not satisfy the calibration(s)\n", spacer);
4645 free (x);
4646 return (NO);
4647 }
4648
4649 /* Allow tollerance */
4650 if (minRateConstrained == YES && maxRateConstrained == YES && AreDoublesEqual (minRate, maxRate, tol) == YES && minRate > maxRate)
4651 {
4652 maxRate = minRate;
4653 }
4654
4655 if (minRateConstrained == YES)
4656 *minClockRate = minRate;
4657 else
4658 *minClockRate = 0.0;
4659
4660 if (maxRateConstrained == YES)
4661 *maxClockRate = maxRate;
4662 else
4663 *maxClockRate = MRBFLT_MAX;
4664
4665 /* check that minimum and maximum rates are consistent */
4666 if (minRateConstrained == YES && maxRateConstrained == YES && minRate > maxRate)
4667 {
4668 MrBayesPrint ("%s Branch lengths do not satisfy the calibration(s)\n", spacer);
4669 free (x);
4670 return (NO);
4671 }
4672
4673 /* date all nodes based on a suitable rate */
4674 if (minRateConstrained == YES)
4675 clockRate = minRate;
4676 else if (maxRateConstrained == YES)
4677 clockRate = 0.5 * maxRate;
4678 else
4679 clockRate = 1.0;
4680 for (i=0; i<t->nNodes-1; i++)
4681 {
4682 p = t->allDownPass[i];
4683 p->age = p->nodeDepth / clockRate;
4684 }
4685
4686 /* check if there is an age to add (I guess this is here because when max rate is close to minrate and we have numerical precision inacuracy) */
4687 ageToAdd = 0.0;
4688 for (i=0; i<t->nNodes-1; i++)
4689 {
4690 p = t->allDownPass[i];
4691 if (x[p->index] > 0.0 && x[p->index] > p->age)
4692 {
4693 f = x[p->index] - p->age;
4694 if (f > ageToAdd)
4695 ageToAdd = f;
4696 }
4697 }
4698
4699 /* add extra length if any */
4700 if (AreDoublesEqual (ageToAdd, 0.0, 0.00000001) == NO)
4701 {
4702 for (i=0; i<t->nNodes-1; i++)
4703 {
4704 p = t->allDownPass[i];
4705 p->age += ageToAdd;
4706 }
4707 }
4708
4709 free (x);
4710
4711 /* reset node depths to ensure that non-dated tips have node depth 0.0 */
4712 SetNodeDepths(t);
4713
4714 return (YES);
4715 }
4716
4717
IsClockSatisfied(Tree * t,MrBFlt tol)4718 int IsClockSatisfied (Tree *t, MrBFlt tol)
4719 {
4720 int i, foundFirstLength, isClockLike;
4721 MrBFlt firstLength=0.0, length;
4722 TreeNode *p, *q;
4723
4724 if (t->isRooted == NO)
4725 return (NO);
4726
4727 foundFirstLength = NO;
4728 isClockLike = YES;
4729 for (i=0; i<t->nNodes; i++)
4730 {
4731 p = t->allDownPass[i];
4732 if (p->left == NULL && p->right == NULL)
4733 {
4734 if (p->isDated == YES)
4735 {
4736 //continue;
4737 length = p->nodeDepth;
4738 }
4739 else
4740 length = 0.0;
4741 q = p;
4742 while (q->anc != NULL)
4743 {
4744 if (q->anc->anc != NULL)
4745 length += q->length;
4746 q = q->anc;
4747 }
4748 if (foundFirstLength == NO)
4749 {
4750 firstLength = length;
4751 foundFirstLength = YES;
4752 }
4753 else
4754 {
4755 if (AreDoublesEqual (firstLength, length, tol) == NO)
4756 {
4757 MrBayesPrint ("%s Node (%s) is not at the same depth as some other tip taking colibration into account. \n", spacer, p->label);
4758 isClockLike = NO;
4759 }
4760 }
4761 }
4762 }
4763 if (firstLength < BRLENS_MIN)
4764 isClockLike = NO;
4765
4766 return (isClockLike);
4767 }
4768
4769
4770 /* Check that tree obeys topology constraints and that node depths and ages are consistent */
IsTreeConsistent(Param * param,int chain,int state)4771 int IsTreeConsistent (Param *param, int chain, int state)
4772 {
4773 Tree *tree;
4774 TreeNode *p;
4775 int i, j;
4776 MrBFlt b, r, rAnc, clockRate;
4777 Param *subParm;
4778
4779 if (param->paramType != P_TOPOLOGY && param->paramType != P_BRLENS && param->paramType != P_SPECIESTREE)
4780 return YES;
4781
4782 tree = GetTree(param, chain, state);
4783 if (modelSettings[param->relParts[0]].clockRate != NULL)
4784 clockRate = *GetParamVals(modelSettings[param->relParts[0]].clockRate, chain, state);
4785 else
4786 clockRate = 1.0;
4787
4788 if (CheckConstraints(tree)==ERROR) {
4789 printf ("Tree does not obey constraints\n");
4790 return NO;
4791 }
4792
4793 /* check that the last few indices are not taken in a rooted tree */
4794 if (tree->isRooted == YES && tree->root->index != tree->nNodes - 1)
4795 {
4796 printf ("Problem with root index\n");
4797 return NO;
4798 }
4799 if (tree->isRooted == YES && tree->root->left->index != tree->nNodes - 2)
4800 {
4801 printf ("Problem with interior root index\n");
4802 return NO;
4803 }
4804
4805 if (tree->isClock == NO)
4806 {
4807 for (i=0; i<tree->nNodes-1; i++)
4808 {
4809 p = tree->allDownPass[i];
4810 if (p->length <= 0.0)
4811 {
4812 if (p->length == 0.0)
4813 printf ("Node %d has zero branch length %f\n", p->index, p->length);
4814 else
4815 printf ("Node %d has negative branch length %f\n", p->index, p->length);
4816 return NO;
4817 }
4818 }
4819 return YES;
4820 }
4821
4822 /* Clock trees */
4823
4824 /* Check that lengths and depths are consistent */
4825 for (i=0; i<tree->nNodes-2; i++) {
4826 p = tree->allDownPass[i];
4827 if (p->length < 0.0) {
4828 printf ("Node %d has negative branch length %f\n", p->index, p->length);
4829 return NO;
4830 }
4831 if (fabs(p->anc->nodeDepth - p->nodeDepth - p->length) > 0.000001) {
4832 printf ("Node %d has length %f but nodeDepth %f and ancNodeDepth %f\n",
4833 p->index, p->length, p->nodeDepth, p->anc->nodeDepth);
4834 return NO;
4835 }
4836 if (p->left == NULL && p->isDated == NO && p->nodeDepth != 0.0) {
4837 printf ("Node %d is an autodated tip (0.0) but has node depth %lf\n",
4838 p->index, p->nodeDepth);
4839 return NO;
4840 }
4841 }
4842
4843 /* Check that ages and calibrations are consistent */
4844 if (tree->isCalibrated == YES)
4845 {
4846 for (i=0; i<tree->nNodes-1; i++)
4847 {
4848 p = tree->allDownPass[i];
4849 if (p->isDated == YES) {
4850 if (fabs((p->age - p->nodeDepth/clockRate)/p->age) > 0.000001)
4851 {
4852 printf ("Node %d has age %f but nodeDepth %f when clock rate is %f\n",
4853 p->index, p->age, p->nodeDepth, clockRate);
4854 return NO;
4855 }
4856 if (p->calibration->prior == fixed && fabs((p->age - p->calibration->priorParams[0])/p->age) > 0.000001)
4857 {
4858 printf ("Node %d has age %f but should be fixed to age %f\n",
4859 p->index, p->age, p->calibration->priorParams[0]);
4860 return NO;
4861 }
4862 else if (p->calibration->prior == uniform &&
4863 ((p->age - p->calibration->min)/p->age < -0.000001 || (p->age - p->calibration->max)/p->age > 0.000001))
4864 {
4865 printf ("Node %d has age %f but should be in the interval [%f,%f]\n",
4866 p->index, p->age, p->calibration->min, p->calibration->max);
4867 return NO;
4868 }
4869 else if ((p->age - p->calibration->min)/p->age < -0.000001)
4870 {
4871 printf ("Node %d has age %f but should be at least of age %f\n",
4872 p->index, p->age, p->calibration->min);
4873 return NO;
4874 }
4875 else if ((p->age - p->calibration->max)/p->age > 0.000001)
4876 {
4877 printf ("Node %d has age %f but should be no older than %f\n",
4878 p->index, p->age, p->calibration->max);
4879 return NO;
4880 }
4881 }
4882 }
4883 }
4884
4885 for (i=0; i<param->nSubParams; i++)
4886 {
4887 subParm = param->subParams[i];
4888 if (subParm->paramId == TK02BRANCHRATES || (subParm->paramId == MIXEDBRCHRATES && *GetParamIntVals(subParm, chain, state) == RCL_TK02))
4889 {
4890 rAnc = GetParamVals(subParm, chain, state)[tree->root->left->index];
4891 if (fabs(rAnc - 1.0) > 1E-6)
4892 {
4893 printf ("%s TK02 relaxed clock mismatch in root rate, which is %e\n", spacer, rAnc);
4894 return NO;
4895 }
4896 for (j=0; j<tree->nNodes-2; j++)
4897 {
4898 p = tree->allDownPass[j];
4899 b = GetParamSubVals(subParm, chain, state)[p->index];
4900 r = GetParamVals(subParm, chain, state)[p->index];
4901 rAnc = GetParamVals(subParm, chain, state)[p->anc->index];
4902 if (fabs(p->length * (r + rAnc) / 2.0 - b) > 0.000001)
4903 {
4904 printf ("%s TK02 relaxed clock mismatch in branch %d\n", spacer, p->index);
4905 return NO;
4906 }
4907 }
4908 }
4909 else if (subParm->paramId == IGRBRANCHRATES || (subParm->paramId == MIXEDBRCHRATES && *GetParamIntVals(subParm, chain, state) == RCL_IGR))
4910 {
4911 for (j=0; j<tree->nNodes-2; j++)
4912 {
4913 p = tree->allDownPass[j];
4914 b = GetParamSubVals(subParm, chain, state)[p->index];
4915 r = GetParamVals(subParm, chain, state)[p->index];
4916 if (fabs(p->length * r - b) > 0.000001)
4917 {
4918 printf ("%s Igr relaxed clock mismatch in branch %d\n", spacer, p->index);
4919 return NO;
4920 }
4921 }
4922 }
4923 }
4924
4925 if (param->paramType == P_SPECIESTREE)
4926 return (IsSpeciesTreeConsistent(GetTree(param, chain, state), chain));
4927
4928 return YES;
4929 }
4930
4931
4932 /* LabelTree: Label tree; remove previous labels if any */
LabelTree(Tree * t,char ** taxonNames)4933 int LabelTree (Tree *t, char **taxonNames)
4934 {
4935 int i, nTaxa;
4936 TreeNode *p = NULL;
4937
4938 nTaxa = t->nNodes - t->nIntNodes;
4939 if (t->isRooted == YES)
4940 nTaxa--;
4941
4942 /* erase previous labels, if any */
4943 for (i=0; i<t->nNodes; i++)
4944 {
4945 p = t->allDownPass[i];
4946 p->marked = NO;
4947 t->nodes[i].label = noLabel;
4948 }
4949
4950 /* add labels */
4951 for (i=0; i<t->nNodes; i++)
4952 {
4953 p = &t->nodes[i];
4954 if (p->left == NULL || (t->isRooted == NO && p->anc == NULL))
4955 {
4956 if (p->marked == YES || p->index < 0 || p->index >= nTaxa)
4957 {
4958 MrBayesPrint ("%s Taxon node index repeated or out of range\n", spacer);
4959 return (ERROR);
4960 }
4961 else
4962 p->label = taxonNames[p->index];
4963 p->marked = YES;
4964 }
4965 else if (p->index > 0 && p->index < nTaxa)
4966 {
4967 MrBayesPrint ("%s Terminal taxon index set for interior node\n", spacer);
4968 return (ERROR);
4969 }
4970 }
4971
4972 return (NO_ERROR);
4973 }
4974
4975
4976 /*-------------------------------------------------------------------------------------------
4977 |
4978 | Mark: This routine will mark up a subtree rooted at p
4979 |
4980 ---------------------------------------------------------------------------------------------*/
Mark(TreeNode * p)4981 void Mark (TreeNode *p)
4982 {
4983 if (p != NULL)
4984 {
4985 p->marked = YES;
4986 Mark (p->left);
4987 Mark (p->right);
4988 }
4989 }
4990
4991
4992 /*-------------------------------------------------------------------------------------------
4993 |
4994 | MarkDistance: This routine will mark up an unconstrained subtree rooted at p within dist
4995 | The distance will be positive in the crown part and negative in the root part.
4996 |
4997 ---------------------------------------------------------------------------------------------*/
MarkDistance(TreeNode * p,int YESorNO,int dist,int * n)4998 void MarkDistance (TreeNode *p, int YESorNO, int dist, int *n)
4999 {
5000 if (p == NULL || p->anc == NULL)
5001 return;
5002
5003 p->marked = YES;
5004 if (YESorNO == YES) // in root part
5005 p->x = p->anc->x -1;
5006 else // in crown part
5007 p->x = p->anc->x +1;
5008 (*n)++;
5009
5010 if (p->isLocked == NO && abs(p->x) < dist)
5011 {
5012 MarkDistance (p->left, YESorNO, dist, n);
5013 MarkDistance (p->right,YESorNO, dist, n);
5014 }
5015 }
5016
5017
5018 /*-------------------------------------------------------------------------------------------
5019 |
5020 | MarkUnconstrained: This routine will mark up an unconstrained subtree rooted at p
5021 |
5022 ---------------------------------------------------------------------------------------------*/
MarkUnconstrained(TreeNode * p)5023 void MarkUnconstrained (TreeNode *p)
5024 {
5025 if (p != NULL)
5026 {
5027 p->marked = YES;
5028 if (p->isLocked == NO)
5029 {
5030 MarkUnconstrained (p->left);
5031 MarkUnconstrained (p->right);
5032 }
5033 }
5034 }
5035
5036
5037 /*-------------------------------------------------------------------------------------------
5038 |
5039 | MoveCalculationRoot: This routine will move the calculation root to the terminal with
5040 | index outgroup
5041 |
5042 ---------------------------------------------------------------------------------------------*/
MoveCalculationRoot(Tree * t,int outgroup)5043 int MoveCalculationRoot (Tree *t, int outgroup)
5044 {
5045 int i;
5046 TreeNode *p, *q, *r;
5047
5048 if (t->isRooted == YES || outgroup < 0 || outgroup > t->nNodes - t->nIntNodes - (t->isRooted == YES ? 1 : 0))
5049 {
5050 MrBayesPrint ("%s Problem moving calculation root\n", spacer);
5051 return (ERROR);
5052 }
5053
5054 if (t->root->index == outgroup)
5055 return (NO_ERROR); /* nothing to do */
5056
5057 /* mark the path to the new calculation root */
5058 for (i=0; i<t->nNodes; i++)
5059 {
5060 p = t->allDownPass[i];
5061 if (p->left == NULL && p->right == NULL)
5062 {
5063 if (p->index == outgroup)
5064 p->marked = YES;
5065 else
5066 p->marked = NO;
5067 }
5068 else
5069 {
5070 if (p->left->marked == YES || p->right->marked == YES)
5071 p->marked = YES;
5072 else
5073 p->marked = NO;
5074 }
5075 }
5076
5077 /* rotate the tree to use the specified calculation root */
5078 p = t->root->left;
5079 q = t->root;
5080 q->anc = p;
5081 q->left = q->right = NULL;
5082 q->length = p->length;
5083 while (p->left != NULL && p->right != NULL)
5084 {
5085 if (p->left->marked == YES)
5086 {
5087 r = p->left;
5088 p->anc = r;
5089 p->left = q;
5090 p->length = r->length;
5091 q = p;
5092 p = r;
5093 }
5094 else /* if (p->right->marked == YES) */
5095 {
5096 r = p->right;
5097 p->anc = r;
5098 p->right = q;
5099 p->length = r->length;
5100 q = p;
5101 p = r;
5102 }
5103 }
5104 p->left = p->anc;
5105 p->right = p->anc = NULL;
5106 t->root = p;
5107 p->length = 0.0;
5108
5109 GetDownPass (t);
5110
5111 return (NO_ERROR);
5112 }
5113
5114
5115 /*-------------------------------------------------------------------------------------------
5116 |
5117 | MovePolyCalculationRoot: This routine will move the calculation root to the terminal with
5118 | index outgroup and place it as the right-most descendant of the root node
5119 |
5120 ---------------------------------------------------------------------------------------------*/
MovePolyCalculationRoot(PolyTree * t,int outgroup)5121 int MovePolyCalculationRoot (PolyTree *t, int outgroup)
5122 {
5123 int i;
5124 PolyNode *p = NULL, *q, *r;
5125
5126 /* check if tree is rooted, in which case calculation root is irrelevant */
5127 if (t->root->left->sib->sib == NULL)
5128 return (NO_ERROR);
5129
5130 if (outgroup < 0 || outgroup > t->nNodes - t->nIntNodes)
5131 {
5132 MrBayesPrint ("%s Outgroup index is out of range\n", spacer);
5133 return (ERROR);
5134 }
5135
5136 if (t->root->left->sib->sib->sib != NULL)
5137 {
5138 MrBayesPrint ("%s Root has more than three descendants\n", spacer);
5139 return (ERROR);
5140 }
5141
5142 /* check if rerooting actually necessary */
5143 if (t->root->left->sib->sib->index == outgroup)
5144 return (NO_ERROR);
5145
5146 /* mark the path to the new calculation root */
5147 for (i=0; i<t->nNodes; i++)
5148 {
5149 p = t->allDownPass[i];
5150 if (p->index == outgroup)
5151 break;
5152 }
5153 if (p->left != NULL)
5154 {
5155 MrBayesPrint ("%s Outgroup index set for internal node\n", spacer);
5156 for (i=0; i<t->nNodes; i++)
5157 printf ("%d -- %d\n", i, t->allDownPass[i]->index);
5158 getchar();
5159 return (ERROR);
5160 }
5161
5162 /* mark path to current root */
5163 for (i=0; i<t->nNodes; i++)
5164 t->allDownPass[i]->mark = NO;
5165 q = p;
5166 while (q != NULL)
5167 {
5168 q->mark = YES;
5169 q = q->anc;
5170 }
5171
5172 /* rotate the tree to use the specified calculation root */
5173 p = t->root;
5174 for (;;)
5175 {
5176 /* find marked descendant */
5177 for (q=p->left; q->mark == NO; q=q->sib)
5178 ;
5179 if (q->index == outgroup)
5180 break;
5181 /* add old root to descendants of that node */
5182 for (r=q->left; r->sib!=NULL; r=r->sib)
5183 ;
5184 r->sib = p;
5185 p->sib = NULL; /* should not be needed */
5186 p->anc = q;
5187 p->length = q->length;
5188 /* remove that node from descendants of old root node */
5189 if (p->left == q)
5190 p->left = q->sib;
5191 else
5192 {
5193 for (r=p->left; r->sib!=q; r=r->sib)
5194 ;
5195 r->sib = r->sib->sib;
5196 }
5197 /* make new node root */
5198 q->sib = NULL;
5199 q->anc = NULL;
5200 q->length = 0.0;
5201 p = q;
5202 }
5203
5204 /* p is now the new root */
5205 t->root = p;
5206
5207 /* finally make sure calculation root is last node among root's descendants */
5208 for (q=p->left; q->sib!=NULL; q=q->sib)
5209 ;
5210 if (q->index != outgroup)
5211 {
5212 if (p->left->index == outgroup)
5213 {
5214 q->sib = p->left;
5215 p->left = p->left->sib;
5216 q->sib->sib = NULL;
5217 }
5218 else
5219 {
5220 for (r=p->left; r->sib->index!=outgroup; r=r->sib)
5221 ;
5222 q->sib = r->sib;
5223 r->sib = r->sib->sib;
5224 q->sib->sib = NULL;
5225 }
5226 }
5227
5228 GetPolyDownPass (t);
5229
5230 return (NO_ERROR);
5231 }
5232
5233
5234 /*
5235 @return the number of levels for the tree rooted at the "node"
5236 */
NrSubTreeLevels(TreeNode * node)5237 int NrSubTreeLevels(TreeNode *node)
5238 {
5239 int r,l;
5240
5241 if (node == NULL)
5242 {
5243 return -1;
5244 }
5245
5246 r = NrSubTreeLevels (node->right);
5247 l = NrSubTreeLevels (node->left);
5248
5249 return ((r>l)?(r):(l))+1;
5250 }
5251
5252
5253 /*-------------------------------------------------------------------------------------------
5254 |
5255 | NumConstrainedTips: This routine will return the number of constrained tips, internal or external
5256 |
5257 ---------------------------------------------------------------------------------------------*/
NumConstrainedTips(TreeNode * p)5258 int NumConstrainedTips (TreeNode *p)
5259 {
5260 int i = 0;
5261
5262 if (p == NULL)
5263 return i;
5264 if (p->left == NULL)
5265 return 1;
5266
5267 i += NConstrainedTips (p->left);
5268 i += NConstrainedTips (p->right);
5269
5270 return i;
5271 }
5272
5273
5274 /* NConstrainedTips: Recursive function to get the number of constrained tips */
NConstrainedTips(TreeNode * p)5275 int NConstrainedTips (TreeNode *p)
5276 {
5277 int i=0;
5278
5279 if (p!=NULL)
5280 {
5281 if (p->left == NULL || p->isLocked == YES)
5282 return 1;
5283 else
5284 {
5285 i += NConstrainedTips (p->left);
5286 i += NConstrainedTips (p->right);
5287 }
5288 }
5289 return i;
5290 }
5291
5292
5293 /*-------------------------------------------------------------------------------------------
5294 |
5295 | NumDatedTips: This routine will return the number of dated tips, internal or external
5296 |
5297 ---------------------------------------------------------------------------------------------*/
NumDatedTips(TreeNode * p)5298 int NumDatedTips (TreeNode *p)
5299 {
5300 int i = 0;
5301
5302 assert (p != NULL && p->left != NULL);
5303
5304 i += NDatedTips (p->left);
5305 i += NDatedTips (p->right);
5306
5307 return i;
5308 }
5309
5310
5311 /* NDatedTips: recursive function to get the number of dated tips */
NDatedTips(TreeNode * p)5312 int NDatedTips (TreeNode *p)
5313 {
5314 int i=0;
5315
5316 assert (p!=NULL);
5317
5318 if (p->left == NULL || p->isDated == YES)
5319 return 1;
5320 else
5321 {
5322 i += NDatedTips (p->left);
5323 i += NDatedTips (p->right);
5324 return i;
5325 }
5326 }
5327
5328
5329 /* OrderTips: Order tips in a polytomous tree */
OrderTips(PolyTree * t)5330 void OrderTips (PolyTree *t)
5331 {
5332 int i, j;
5333 PolyNode *p, *q, *r, *pl, *ql, *rl;
5334
5335 /* label by minimum index */
5336 for (i=0; i<t->nNodes; i++)
5337 {
5338 p = t->allDownPass[i];
5339 if (p->left == NULL)
5340 {
5341 if (t->isRooted == NO && p->index == localOutGroup)
5342 p->x = -1;
5343 else
5344 p->x = p->index;
5345 }
5346 else
5347 {
5348 j = t->nNodes;
5349 for (q=p->left; q!=NULL; q=q->sib)
5350 {
5351 if (q->x < j)
5352 j = q->x;
5353 }
5354 p->x = j;
5355 }
5356 }
5357
5358 /* and rearrange */
5359 for (i=0; i<t->nNodes; i++)
5360 {
5361 p = t->allDownPass[i];
5362 if (p->left == NULL || p->anc == NULL)
5363 continue;
5364 for (ql=NULL, q=p->left; q->sib!=NULL; ql=q, q=q->sib)
5365 {
5366 for (rl=q, r=q->sib; r!=NULL; rl=r, r=r->sib)
5367 {
5368 if (r->x < q->x)
5369 {
5370 if (ql == NULL)
5371 p->left = r;
5372 if (r == q->sib) /* swap adjacent q and r */
5373 {
5374 if (ql != NULL)
5375 ql->sib = r;
5376 pl = r->sib;
5377 r->sib = q;
5378 q->sib = pl;
5379 }
5380 else /* swap separated q and r */
5381 {
5382 if (ql != NULL)
5383 ql->sib = r;
5384 pl = r->sib;
5385 r->sib = q->sib;
5386 rl->sib = q;
5387 q->sib = pl;
5388 }
5389 pl = q;
5390 q = r;
5391 r = pl;
5392 }
5393 }
5394 }
5395 }
5396 GetPolyDownPass(t);
5397 }
5398
5399
5400 /* PrintNodes: Print a list of tree nodes, pointers and length */
PrintNodes(Tree * t)5401 void PrintNodes (Tree *t)
5402 {
5403 int i;
5404 TreeNode *p;
5405
5406 printf ("Node\tleft\tright\tanc\tlength\n");
5407 for (i=0; i<t->nNodes; i++)
5408 {
5409 p = &t->nodes[i];
5410 printf ("%d\t%d\t%d\t%d\t%f\t%f\n",
5411 p->index,
5412 p->left == NULL ? -1 : p->left->index,
5413 p->right == NULL ? -1 : p->right->index,
5414 p->anc == NULL ? -1 : p->anc->index,
5415 p->length,
5416 p->nodeDepth);
5417 }
5418
5419 if (t->root == NULL)
5420 printf ("root: NULL\n");
5421 else
5422 printf ("root: %d\n", t->root->index);
5423
5424 printf ("allDownPass:");
5425 for (i=0; i<t->nNodes; i++)
5426 {
5427 p = t->allDownPass[i];
5428 if (p!=NULL)
5429 printf (" %d", p->index);
5430 else
5431 printf (" NULL");
5432 }
5433 printf ("\nintDownPass: ");
5434 for (i=0; i<t->nIntNodes; i++)
5435 {
5436 p = t->intDownPass[i];
5437 if (p!=NULL)
5438 printf (" %d\t", p->index);
5439 else
5440 printf (" NULL\t");
5441 }
5442 printf ("\n");
5443 }
5444
5445
5446 /* PrintPolyNodes: Print a list of polytomous tree nodes, pointers and length */
PrintPolyNodes(PolyTree * pt)5447 void PrintPolyNodes (PolyTree *pt)
5448 {
5449 int i, j, k;
5450 PolyNode *p;
5451
5452 printf ("Node\tleft\tsib\tanc\tlength\tlabel\n");
5453 for (i=0; i<pt->memNodes; i++)
5454 {
5455 p = &pt->nodes[i];
5456 printf ("%d\t%d\t%d\t%d\t%f\t%s\n",
5457 p->index,
5458 p->left == NULL ? -1 : p->left->index,
5459 p->sib == NULL ? -1 : p->sib->index,
5460 p->anc == NULL ? -1 : p->anc->index,
5461 p->length,
5462 p->label);
5463 }
5464 printf ("root: %d\n", pt->root->index);
5465 fflush(stdout);
5466
5467 if (pt->nBSets > 0)
5468 {
5469 for (i=0; i<pt->nBSets; i++)
5470 {
5471 printf ("Effective branch length set '%s'\n", pt->bSetName[i]);
5472 for (j=0; j<pt->nNodes; j++)
5473 {
5474 printf ("%d:%f", j, pt->effectiveBrLen[pt->nBSets][j]);
5475 if (j != pt->nNodes-1)
5476 printf (", ");
5477 }
5478 printf ("\n");
5479 }
5480 }
5481
5482 if (pt->nESets > 0)
5483 {
5484 for (i=0; i<pt->nESets; i++)
5485 {
5486 printf ("Cpp event set '%s'\n", pt->eSetName[i]);
5487 for (j=0; j<pt->nNodes; j++)
5488 {
5489 if (pt->nEvents[i][j] > 0)
5490 {
5491 printf ("\tNode %d -- %d:(", j, pt->nEvents[i][j]);
5492 for (k=0; k<pt->nEvents[i][j]; k++)
5493 {
5494 printf ("%f %f", pt->position[i][j][k], pt->rateMult[i][j][k]);
5495 if (k != pt->nEvents[i][j]-1)
5496 printf (", ");
5497 }
5498 printf (")\n");
5499 }
5500 }
5501 printf ("\n");
5502 }
5503 }
5504
5505 fflush(stdout);
5506 }
5507
5508
5509 /* PrintTranslateBlock: Print a translate block to file fp for tree t */
PrintTranslateBlock(FILE * fp,Tree * t)5510 void PrintTranslateBlock (FILE *fp, Tree *t)
5511 {
5512 int i, j, nTaxa;
5513
5514 if (t->isRooted == NO)
5515 nTaxa = t->nNodes - t->nIntNodes;
5516 else
5517 nTaxa = t->nNodes - t->nIntNodes - 1;
5518
5519 fprintf (fp, "\ttranslate\n");
5520
5521 for (i=0; i<nTaxa; i++)
5522 {
5523 for (j=0; j<t->nNodes; j++)
5524 if (t->allDownPass[j]->index == i)
5525 break;
5526 if (i == nTaxa-1)
5527 fprintf (fp, "\t\t%d\t%s;\n", i+1, t->allDownPass[j]->label);
5528 else
5529 fprintf (fp, "\t\t%d\t%s,\n", i+1, t->allDownPass[j]->label);
5530 }
5531 }
5532
5533
5534 /**
5535 Update relaxed clock parameter of the branch of a node with index "b" after node with index "a" is removed.
5536 i.e. make branch of node with index "b" be a concatenation of its original branch and the branch of node with index "a"
5537 Relaxed clock parameter of node with index "a" become invalid in the process.
5538 Note: For Non-clock models the routine has no effect.
5539
5540 | |
5541 | |
5542 a |
5543 | -> |
5544 | |
5545 | b
5546 b */
AppendRelaxedBranch(int a,int b,PolyTree * t)5547 void AppendRelaxedBranch (int a,int b,PolyTree *t)
5548 {
5549 int i,len;
5550
5551 for (i=0; i<t->nBSets; i++)
5552 {
5553 t->effectiveBrLen[i][b] += t->effectiveBrLen[i][a];
5554 }
5555
5556 for (i=0; i<t->nESets; i++)
5557 {
5558 len=t->nEvents[i][a]+t->nEvents[i][b];
5559 t->position[i][a] = (MrBFlt *) SafeRealloc ((void *)t->position[i][a], len*sizeof(MrBFlt));
5560 t->rateMult[i][a] = (MrBFlt *) SafeRealloc ((void *)t->rateMult[i][a], len*sizeof(MrBFlt));
5561 memcpy (t->position[i][a]+t->nEvents[i][a], t->position[i][b], t->nEvents[i][b]*sizeof(MrBFlt));
5562 memcpy (t->rateMult[i][a]+t->nEvents[i][a], t->rateMult[i][b], t->nEvents[i][b]*sizeof(MrBFlt));
5563 free(t->position[i][b]);
5564 free(t->rateMult[i][b]);
5565 t->position[i][b] = t->position[i][a];
5566 t->rateMult[i][b] = t->rateMult[i][a];
5567 t->position[i][a] = NULL;
5568 t->rateMult[i][a] = NULL;
5569 t->nEvents[i][a] = 0;
5570 t->nEvents[i][b] = len;
5571 }
5572
5573 }
5574
5575
5576 /**
5577 Swap relaxed clock paramiters of the branch of nodes with index "a" and "b".
5578 */
SwapRelaxedBranchInfo(int a,int b,PolyTree * t)5579 void SwapRelaxedBranchInfo (int a,int b,PolyTree *t)
5580 {
5581 int i,j;
5582 MrBFlt tmp, *tmpp;
5583
5584 for (i=0; i<t->nBSets; i++)
5585 {
5586 tmp = t->effectiveBrLen[i][a];
5587 t->effectiveBrLen[i][a] = t->effectiveBrLen[i][b];
5588 t->effectiveBrLen[i][b] = tmp;
5589 }
5590 if (t->popSizeSet == YES)
5591 {
5592 tmp = t->popSize[a];
5593 t->popSize[a]=t->popSize[b];
5594 t->popSize[b] = tmp;
5595 }
5596
5597 for (i=0; i<t->nESets; i++)
5598 {
5599 tmpp = t->position[i][a];
5600 t->position[i][a] = t->position[i][b];
5601 t->position[i][b] = tmpp;
5602 tmpp = t->rateMult[i][a];
5603 t->rateMult[i][a] = t->rateMult[i][b];
5604 t->rateMult[i][b] = tmpp;
5605 j = t->nEvents[i][a];
5606 t->nEvents[i][a] = t->nEvents[i][b];
5607 t->nEvents[i][b] = j;
5608 }
5609 }
5610
5611
5612 /*-------------------------------------------------------------------------------------------
5613 |
5614 | PrunePolyTree: This routine will prune a polytomous tree according to the currently
5615 | included taxa. NB! All tree nodes cannot be accessed by cycling over the
5616 | pt->nodes array after the deletion, because some spaces will be occupied by deleted
5617 | nodes and pt->nNodes is no longer the length of this array
5618 | (if proper re-arangment of pt->nodes needed then remove "#if 0" and make changes to p->x, see below).
5619 |
5620 ---------------------------------------------------------------------------------------------*/
PrunePolyTree(PolyTree * pt)5621 int PrunePolyTree (PolyTree *pt)
5622 {
5623 int i, j, numDeleted, numTermPruned, numIntPruned, index;
5624 PolyNode *p = NULL, *q=NULL, *r=NULL, *qa;
5625
5626 numDeleted = 0;
5627 for (i=0; i<pt->nNodes; i++)
5628 {
5629 p = pt->allDownPass[i];
5630 CheckString (taxaNames, numTaxa, p->label, &index);
5631 if (p->left == NULL && taxaInfo[index].isDeleted == YES)
5632 numDeleted++;
5633 }
5634
5635 if (numDeleted == 0)
5636 {
5637 /* nothing to do */
5638 return (NO_ERROR);
5639 }
5640 if (pt->nNodes - pt->nIntNodes - numDeleted < 3)
5641 {
5642 MrBayesPrint ("%s Pruned tree has less than three taxa in it\n", spacer);
5643 return (ERROR);
5644 }
5645 if (pt->nNodes - pt->nIntNodes < numLocalTaxa)
5646 {
5647 MrBayesPrint ("%s Tree to be pruned does not include all taxa\n", spacer);
5648 return (ERROR);
5649 }
5650
5651 /* prune away one node at a time */
5652 numIntPruned = 0;
5653 numTermPruned = 0;
5654 for (i=0; i<pt->nNodes; i++)
5655 {
5656 p = pt->allDownPass[i];
5657 if (p->left != NULL)
5658 continue;
5659 CheckString (taxaNames, numTaxa, p->label, &index);
5660 if (taxaInfo[index].isDeleted == YES)
5661 {
5662 numTermPruned++;
5663 for (q=p->anc->left; q!=NULL; q=q->sib)
5664 {
5665 if (q->sib == p)
5666 break;
5667 }
5668 if (q == NULL)
5669 {
5670 /* p is the left of its ancestor */
5671 assert (p->anc->left == p);
5672 p->anc->left = p->sib;
5673 }
5674 else
5675 {
5676 /* p is q->sib; this also works if p->sib is NULL */
5677 q->sib = p->sib;
5678 }
5679 /* if only one child left, delete ancestral node */
5680 j = 0;
5681 for (q=p->anc->left; q!=NULL; q=q->sib)
5682 j++;
5683 if (j == 1)
5684 {
5685 /* p->anc->left is only child left; make p->anc be p->anc->left and accommodate its length */
5686 numIntPruned++;
5687 qa= p->anc;
5688 q = qa->left;
5689 if (q->left == NULL)
5690 {
5691 AppendRelaxedBranch (qa->index, q->index, pt);
5692 qa->index = q->index;
5693 qa->length += q->length;
5694 strcpy(qa->label, q->label);
5695 qa->left = NULL;
5696 /* To make sure that q is not treated as the representer of the tip it represented before. i.e. make condition if (p->left != NULL) true */
5697 q->left = (struct pNode*)1;
5698 }
5699 else
5700 {
5701 if (qa->anc != NULL)
5702 {
5703 AppendRelaxedBranch (qa->index, q->index, pt);
5704 qa->length += q->length;
5705 }
5706 qa->index = q->index;
5707 qa->left = q->left;
5708 for (r=q->left; r!= NULL; r=r->sib)
5709 r->anc = qa;
5710 }
5711 }
5712 /* if unrooted, then root node has to have more then 2 children, thus the following check */
5713 if (j == 2 && pt->isRooted == NO && p->anc->anc == NULL)
5714 {
5715 numIntPruned++;
5716 r=p->anc; /*r is the root with only 2 children*/
5717 if (r->left->left != NULL)
5718 {/* Make r->left new root by attaching "right" child of r to children of r->left */
5719 for (q=r->left->left; q->sib!=NULL; q=q->sib)
5720 ;
5721 q->sib = r->left->sib;
5722 r->left->sib->anc = q->anc;
5723 r->left->sib->length += q->anc->length;
5724 r->left->sib = NULL;
5725 r->left->anc = NULL;
5726 pt->root = r->left;
5727 }
5728 else
5729 {/* Make "right" child of r (r->left->sib) the new root by attaching r->left to children of r->"right" */
5730 for (q=r->left->sib->left; q->sib!=NULL; q=q->sib)
5731 ;
5732 q->sib = r->left;
5733 r->left->anc = q->anc;
5734 r->left->length += q->anc->length;
5735 r->left->sib = NULL;
5736 q->anc->anc = NULL;
5737 pt->root = q->anc;
5738 }
5739 }
5740 }
5741 }
5742
5743 #if 0
5744 /* place unused space at the end of pt->nodes array. If activated this code p->x has to be set to non 0 value for all p that are deleted. */
5745 for (i=0; i<pt->nNodes; i++)
5746 {
5747 p = &pt->nodes[i];
5748 if (p->x != 0)
5749 {
5750 for (j=i+1; j<pt->nNodes; j++)
5751 {
5752 q = &pt->nodes[j];
5753 if (q->x == 0)
5754 break;
5755 }
5756 if (j != pt->nNodes)
5757 {
5758 /* swap nodes; quite difficult! */
5759 CopyPolyNodes (p, q, nLongsNeeded);
5760 p->left = q->left;
5761 p->sib = q->sib;
5762 p->anc = q->anc;
5763 for (k=0; k<pt->nNodes; k++)
5764 {
5765 r = &pt->nodes[k];
5766 if (r->left == q)
5767 r->left = p;
5768 if (r->sib == q)
5769 r->sib = p;
5770 if (r->anc == q)
5771 r->anc = p;
5772 }
5773 }
5774 }
5775 }
5776 #endif
5777
5778 /* correct number of nodes */
5779 pt->nNodes -= (numTermPruned + numIntPruned);
5780 pt->nIntNodes -= numIntPruned;
5781
5782 /* get downpass; note that the deletion procedure does not change the root in rooted case */
5783 i=j=0;
5784 GetPolyNodeDownPass (pt, pt->root, &i, &j);
5785 assert (i==pt->nNodes);
5786 assert (j==pt->nIntNodes);
5787
5788 return (NO_ERROR);
5789 }
5790
5791
5792 /*--------------------------------------------------------------------
5793 |
5794 | RandPerturb: Randomly perturb a tree by nPert NNIs
5795 |
5796 ---------------------------------------------------------------------*/
RandPerturb(Tree * t,int nPert,RandLong * seed)5797 int RandPerturb (Tree *t, int nPert, RandLong *seed)
5798 {
5799 int i, whichNode;
5800 TreeNode *p, *q, *a, *b, *c;
5801
5802 if (t->nConstraints >= t->nIntNodes)
5803 {
5804 MrBayesPrint ("%s User tree cannot be perturbed because all nodes are locked\n", spacer);
5805 return (ERROR);
5806 }
5807
5808 for (i=0; i<nPert; i++)
5809 {
5810 do
5811 {
5812 whichNode = (int)(RandomNumber(seed) * (t->nIntNodes - 1));
5813 p = t->intDownPass[whichNode];
5814 } while (p->isLocked == YES);
5815
5816 q = p->anc;
5817 a = p->left;
5818 b = p->right;
5819 if (q->left == p)
5820 c = q->right;
5821 else
5822 c = q->left;
5823
5824 if (RandomNumber(seed) < 0.5)
5825 {
5826 /* swap b and c */
5827 p->right = c;
5828 c->anc = p;
5829
5830 if (q->left == c)
5831 q->left = b;
5832 else
5833 q->right = b;
5834 b->anc = q;
5835 }
5836 else
5837 {
5838 /* swap a and c */
5839 p->left = c;
5840 c->anc = p;
5841
5842 if (q->left == c)
5843 q->left = a;
5844 else
5845 q->right = a;
5846 a->anc = q;
5847 }
5848
5849 if (t->isCalibrated == YES)
5850 InitCalibratedBrlens (t, 0.0001, seed);
5851 else if (t->isClock == YES)
5852 InitClockBrlens (t);
5853 }
5854
5855 GetDownPass (t);
5856
5857 if (t->checkConstraints == YES && CheckConstraints (t) == NO_ERROR)
5858 {
5859 MrBayesPrint ("%s Broke constraints when perturbing tree\n", spacer);
5860 return (ERROR);
5861 }
5862
5863 return (NO_ERROR);
5864 }
5865
5866
5867 /*
5868 | Reorder array of nodes "nodeArray" such that first nodes in it could be paired with "w" to create imediat common ancestor and this ancesor node would not vialate any constraint.
5869 |
5870 | @param w Reference node as described
5871 | @param nodeArray A set of node to order as described
5872 | @param activeConstraints Array containing indeces of active constraints in the set of defined constraints
5873 | @param nLongsNeeded Length of partition information (in BitsLong) in a node and constraint deffinition.
5874 | @param isRooted Do constraints apply to rootet tree YES or NO
5875 |
5876 | @return Number of nodes in "nodeArray" that could be paired with "w" to create imediat common ancestor and this ancesor node would not vialate any constraint
5877 */
ConstraintAllowedSet(PolyNode * w,PolyNode ** nodeArray,int nodeArraySize,int * activeConstraints,int activeConstraintsSize,int nLongsNeeded,int isRooted)5878 int ConstraintAllowedSet(PolyNode *w, PolyNode **nodeArray, int nodeArraySize, int *activeConstraints, int activeConstraintsSize, int nLongsNeeded, int isRooted)
5879 {
5880 int i, j, k, FirstEmpty;
5881 BitsLong **constraintPartition;
5882 PolyNode *tmp;
5883
5884 for (j=0; j<activeConstraintsSize; j++)
5885 {
5886 k=activeConstraints[j];
5887
5888 if (definedConstraintsType[k] == PARTIAL)
5889 {
5890 if ((IsPartNested(definedConstraintPruned[k], w->partition, nLongsNeeded) == YES) ||
5891 (isRooted == NO && IsPartNested(definedConstraintTwoPruned[k], w->partition, nLongsNeeded) == YES))
5892 continue;/* all nodes are compartable because condition of the constraint has to be sutsfied in the subtree rooted at w*/
5893
5894 FirstEmpty = IsSectionEmpty(definedConstraintPruned[k], w->partition, nLongsNeeded);
5895 if (FirstEmpty == YES && IsSectionEmpty(definedConstraintTwoPruned[k], w->partition, nLongsNeeded) == YES)
5896 continue; /* all nodes are compartable becouse w does not contain any constraint taxa*/
5897
5898 assert (FirstEmpty^IsSectionEmpty(definedConstraintTwoPruned[k], w->partition, nLongsNeeded));
5899
5900 if (FirstEmpty == YES)
5901 {/*w->partition has intersection with definedConstraintTwoPruned[k], thus remove all nodes from nodeArray that intersect with definedConstraintPruned[k]*/
5902 constraintPartition=definedConstraintPruned;
5903 }
5904 else
5905 {/*w->partition has intersection with definedConstraintPruned[k], thus remove all nodes from nodeArray that intersect with definedConstraintTwoPruned[k]*/
5906 constraintPartition=definedConstraintTwoPruned;
5907 }
5908
5909 for (i=0;i<nodeArraySize;i++)
5910 {
5911 if (IsSectionEmpty(constraintPartition[k], nodeArray[i]->partition, nLongsNeeded) == NO &&
5912 ((FirstEmpty == NO && isRooted== YES) || IsPartNested(constraintPartition[k], nodeArray[i]->partition, nLongsNeeded) == NO))
5913 /*second part of if statment is to bail out "nodeArray[i]" when "w" contains nodes for example from definedConstraintPruned and "nodeArray[i]" have definedConstraintTwoPruned fully nested in it
5914 This bail out not applicable if t->isRooted== YES Since we should create a rooting node for the first set of taxa in the constraint.
5915 Note that such case possible because we may have hard constraint node that fully nest definedConstraintTwoPruned but also having taxa from definedConstraintPruned keeping constraint active.*/
5916 {
5917 tmp = nodeArray[i];
5918 nodeArray[i]=nodeArray[--nodeArraySize];
5919 nodeArray[nodeArraySize]=tmp;
5920 i--;
5921 }
5922 }
5923 }/*end if PARTIAL*/
5924 else
5925 {
5926 assert (definedConstraintsType[k] == NEGATIVE);
5927 if (isRooted == YES || IsBitSet(localOutGroup, definedConstraintPruned[k])==NO)
5928 constraintPartition=definedConstraintPruned;
5929 else
5930 constraintPartition=definedConstraintTwoPruned;
5931
5932 if (IsSectionEmpty(constraintPartition[k], w->partition, nLongsNeeded)==YES)
5933 continue;
5934
5935 for (i=0;i<nodeArraySize;i++)
5936 {
5937 if (IsUnionEqThird (w->partition, nodeArray[i]->partition, constraintPartition[k], nLongsNeeded) == YES)
5938 {
5939 tmp = nodeArray[i];
5940 nodeArray[i]=nodeArray[--nodeArraySize];
5941 nodeArray[nodeArraySize]=tmp;
5942 i--;
5943 }
5944 }
5945
5946 }/*end if NEGATIVE*/
5947 }
5948
5949 return nodeArraySize;
5950 }
5951
5952
5953 /*
5954 | Check if "partition" violate any constraint.
5955 |
5956 | @param partiton Partition to check
5957 | @param activeConstraints Array containing indeces of active constraints in the set of defined constraints
5958 | @param nLongsNeeded Length of partition information (in BitsLong) in a node and constraint deffinition
5959 | @param isRooted Do constraints apply to rootet tree YES or NO
5960 |
5961 | @return Index of first violated constraint in activeConstraints array, -1 if no constraint is violated.
5962 */
ViolatedConstraint(BitsLong * partition,int * activeConstraints,int activeConstraintsSize,int nLongsNeeded,int isRooted)5963 int ViolatedConstraint(BitsLong *partition, int *activeConstraints, int activeConstraintsSize, int nLongsNeeded, int isRooted)
5964 {
5965 int j, k;
5966 BitsLong **constraintPartition;
5967
5968 for (j=0; j<activeConstraintsSize; j++)
5969 {
5970 k=activeConstraints[j];
5971 assert (definedConstraintsType[k] != HARD);
5972
5973 if (definedConstraintsType[k] == PARTIAL)
5974 {
5975 if ((IsSectionEmpty(definedConstraintPruned[k], partition, nLongsNeeded) == NO) &&
5976 (IsSectionEmpty(definedConstraintTwoPruned[k], partition, nLongsNeeded) == NO) &&
5977 (IsPartNested(definedConstraintPruned[k], partition, nLongsNeeded) == NO) &&
5978 !(isRooted == NO && IsPartNested(definedConstraintTwoPruned[k], partition, nLongsNeeded) == YES))
5979 return j;
5980 }/*end if PARTIAL*/
5981 else
5982 {
5983 assert (definedConstraintsType[k] == NEGATIVE);
5984 if (isRooted == YES || IsBitSet(localOutGroup, definedConstraintPruned[k])==NO)
5985 constraintPartition=definedConstraintPruned;
5986 else
5987 constraintPartition=definedConstraintTwoPruned;
5988
5989 if (IsUnionEqThird (partition, partition, constraintPartition[k], nLongsNeeded) == YES)
5990 return j;
5991 }/*end if NEGATIVE*/
5992 }
5993
5994 return -1;
5995 }
5996
5997
5998 /*
5999 | Remove from activeConstraints references to constraints that become satisfied if PolyNode "w" exist, i.e. they do not need to be checked furter thus become not active
6000 |
6001 | @param activeConstraints Array containing indeces of active constraints in the set of defined constraints
6002 | @param nLongsNeeded Length of partition information (in BitsLong) in a node and constraint deffinition.
6003 | @param isRooted Do constraints apply to rootet tree YES or NO
6004 |
6005 | @return Size of pruned "activeConstraints" array
6006 */
PruneActiveConstraints(PolyNode * w,int * activeConstraints,int activeConstraintsSize,int nLongsNeeded,int isRooted)6007 int PruneActiveConstraints (PolyNode *w, int *activeConstraints, int activeConstraintsSize, int nLongsNeeded, int isRooted)
6008 {
6009 int j, k;
6010 BitsLong **constraintPartition;
6011 //PolyNode *tmp;
6012
6013 for (j=0; j<activeConstraintsSize; j++)
6014 {
6015 k=activeConstraints[j];
6016
6017 if (definedConstraintsType[k] == PARTIAL)
6018 {
6019 if ((IsPartNested(definedConstraintPruned[k], w->partition, nLongsNeeded) == YES && IsSectionEmpty(definedConstraintTwoPruned[k], w->partition, nLongsNeeded)) ||
6020 (isRooted == NO && IsPartNested(definedConstraintTwoPruned[k], w->partition, nLongsNeeded) == YES && IsSectionEmpty(definedConstraintPruned[k], w->partition, nLongsNeeded)))
6021 {
6022 //tmp = activeConstraints[j];
6023 activeConstraints[j]=activeConstraints[--activeConstraintsSize];
6024 //activeConstraints[activeConstraintsSize]=tmp;
6025 j--;
6026 }
6027 }/*end if PARTIAL*/
6028 else
6029 {
6030 assert (definedConstraintsType[k] == NEGATIVE);
6031 if (isRooted == YES || IsBitSet(localOutGroup, definedConstraintPruned[k])==NO)
6032 constraintPartition=definedConstraintPruned;
6033 else
6034 constraintPartition=definedConstraintTwoPruned;
6035
6036 if (IsPartNested(constraintPartition[k], w->partition, nLongsNeeded)==NO && IsSectionEmpty(constraintPartition[k], w->partition, nLongsNeeded)==NO)
6037 {
6038 //tmp = activeConstraints[j];
6039 activeConstraints[j]=activeConstraints[--activeConstraintsSize];
6040 //activeConstraints[activeConstraintsSize]=tmp;
6041 j--;
6042 }
6043 }/*end if NEGATIVE*/
6044 }
6045
6046 return activeConstraintsSize;
6047 }
6048
6049
6050 /*--------------------------------------------------------------------
6051 |
6052 | RandResolve: Randomly resolve a polytomous tree
6053 |
6054 | @param tt is a tree which contains information about applicable constraints. If it is set to NULL then no constraints will be used.
6055 | If t!=NULL then partitions of nodes of polytree should be allocated for example by AllocatePolyTreePartitions (t);
6056 | @return NO_ERROR on succes, ABORT if could not resolve a tree without vialating some consraint, ERROR if any other error occur
6057 ---------------------------------------------------------------------*/
RandResolve(Tree * tt,PolyTree * t,RandLong * seed,int destinationIsRooted)6058 int RandResolve (Tree *tt, PolyTree *t, RandLong *seed, int destinationIsRooted)
6059 {
6060 int i, j, k, nextNode, stopNode, rand1, rand2, nTaxa, nLongsNeeded, tmp;
6061 PolyNode *p=NULL, *q, *r, *u, *w1, *w2;
6062 int nodeArrayAllowedSize, nodeArraySize, activeConstraintsSize;
6063 PolyNode **nodeArray;
6064 int *activeConstraints;
6065
6066 assert (tt==NULL || t->bitsets!=NULL); /* partition fields of t nodes need to be allocated if constraints are used*/
6067 nTaxa = t->nNodes - t->nIntNodes; /* different from numLocalTaxa potentially if a species tree */
6068 assert (nTaxa <= t->memNodes/2); /* allocated tree has to be big enough*/
6069 nLongsNeeded = (nTaxa - 1) / nBitsInALong + 1; /* allocated length of partitions is t->memNodes/2 bits but only first nTaxa bits are used */
6070
6071 nodeArray = t->allDownPass; /*temporary use t->allDownPass for different purpose. It get properly reset at the end. */
6072 activeConstraints = tempActiveConstraints;
6073 activeConstraintsSize = 0;
6074
6075 /* collect constraints to consider if applicable*/
6076 if (tt!=NULL && tt->constraints!=NULL)
6077 {
6078 for (k=0; k<numDefinedConstraints; k++)
6079 {
6080 if (tt->constraints[k] == YES && definedConstraintsType[k] != HARD)
6081 activeConstraints[activeConstraintsSize++]=k;
6082 }
6083 }
6084
6085 /* count immediate descendants */
6086 GetPolyDownPass(t);
6087 for (i=0; i<t->nIntNodes; i++)
6088 {
6089 p = t->intDownPass[i];
6090 tmp=ViolatedConstraint(p->partition, activeConstraints, activeConstraintsSize, nLongsNeeded, t->isRooted);
6091 if (tmp != -1)
6092 {
6093 assert (p->isLocked == YES);
6094 MrBayesPrint ("%s Could not build a constraint tree since hard constraint \"%s\" and constraint \"%s\" are incompatible\n", spacer, constraintNames[p->lockID], constraintNames[activeConstraints[tmp]]);
6095 return (ERROR);
6096 }
6097 activeConstraintsSize = PruneActiveConstraints (p, activeConstraints, activeConstraintsSize, nLongsNeeded, t->isRooted);
6098 j = 0;
6099 for (q=p->left; q!=NULL; q=q->sib)
6100 j++;
6101 p->x = j;
6102 }
6103
6104 /* add one node at a time */
6105 if (destinationIsRooted == NO)
6106 stopNode = 2*nTaxa - 2;
6107 else
6108 stopNode = 2*nTaxa - 1;
6109 for (nextNode=t->nNodes; nextNode < stopNode; nextNode++)
6110 {
6111 /* find a polytomy to break */
6112 for (i=0; i<t->nIntNodes; i++)
6113 {
6114 p = t->intDownPass[i];
6115 if (destinationIsRooted == YES && p->x > 2)
6116 break;
6117 if (destinationIsRooted == NO && ((p->anc != NULL && p->x > 2) || (p->anc == NULL && p->x > 3)))
6118 break;
6119 }
6120
6121 /* if we can't find one, there's an error */
6122 if (i == t->nIntNodes)
6123 {
6124 return ERROR;
6125 }
6126
6127 nodeArraySize=0;
6128 /*Collect initial list of candidate nodes to join*/
6129 for (q = p->left; q!= NULL; q = q->sib)
6130 {
6131 nodeArray[nodeArraySize++]=q;
6132 }
6133 assert (nodeArraySize==p->x);
6134
6135 /* identify two descendants randomly */
6136 /* make sure we do not select outgroup if it is an unrooted tree */
6137 if (p->anc == NULL && destinationIsRooted == NO)
6138 nodeArraySize--;
6139
6140 do
6141 {
6142 /* Pick first node */
6143 rand1 = (int) (RandomNumber(seed) * nodeArraySize);
6144 w1 = nodeArray[rand1];
6145 nodeArray[rand1] = nodeArray[--nodeArraySize];
6146
6147 if (nodeArraySize==0)
6148 return ABORT; /* Potentaily here we could instead revert by removing last added node and try again. */
6149
6150 /* Move all nodes in nodeArray which can be paired with w to the beginning of array */
6151 nodeArrayAllowedSize=ConstraintAllowedSet(w1, nodeArray, nodeArraySize, activeConstraints, activeConstraintsSize, nLongsNeeded, t->isRooted);
6152 /* TODO optimization for Maxim (if not Maxim remove it if you still see it): if nodeArrayAllowedSize==0 then set w1->y */
6153 } while (nodeArrayAllowedSize == 0);
6154
6155 rand2 = (int) (RandomNumber(seed) *nodeArrayAllowedSize);
6156 w2 = nodeArray[rand2];
6157
6158 /* create a new node */
6159 u = &t->nodes[nextNode];
6160 u->anc = p;
6161 u->x = 2;
6162 p->x--;
6163
6164 if (tt != NULL) {
6165 for (j=0; j<nLongsNeeded; j++)
6166 u->partition[j] = w1->partition[j] | w2->partition[j] ;
6167 activeConstraintsSize = PruneActiveConstraints (u, activeConstraints, activeConstraintsSize, nLongsNeeded, t->isRooted);
6168 }
6169
6170 u->left = w1;
6171 t->nNodes++;
6172 t->nIntNodes++;
6173
6174 /* connect tree together */
6175 r = u;
6176 for (q = p->left; q!= NULL; q = q->sib)
6177 {
6178 if (q != w1 && q != w2)
6179 {
6180 r->sib=q;
6181 r = q;
6182 }
6183 }
6184 r->sib = NULL;
6185 w1->sib = w2;
6186 w2->sib = NULL;
6187 w1->anc = u;
6188 w2->anc = u;
6189 p->left = u;
6190
6191 /* update tree */
6192 GetPolyDownPass (t);
6193 }
6194
6195 /* relabel interior nodes (important that last indices are at the bottom!) */
6196 for (i=0; i<t->nIntNodes; i++)
6197 {
6198 p = t->intDownPass[i];
6199 p->index = nTaxa + i;
6200 }
6201 return NO_ERROR;
6202 }
6203
6204
6205 /* ResetTreeNode: Reset tree node except for memory index */
ResetTreeNode(TreeNode * p)6206 void ResetTreeNode (TreeNode *p)
6207 {
6208 /* do not change memoryIndex; that is set once and for all when tree is allocated */
6209 p->index = 0;
6210 p->upDateCl = NO;
6211 p->upDateTi = NO;
6212 p->marked = NO;
6213 p->length = 0.0;
6214 p->nodeDepth = 0.0;
6215 p->x = 0;
6216 p->y = 0;
6217 p->index = 0;
6218 p->isDated = NO;
6219 p->calibration = NULL;
6220 p->age = -1.0;
6221 p->isLocked = NO;
6222 p->lockID = -1;
6223 p->label = noLabel;
6224 p->d = 0.0;
6225 p->partition = NULL;
6226 }
6227
6228
6229 /* ResetPolyNode: Reset all values of one node in a polytree */
ResetPolyNode(PolyNode * p)6230 void ResetPolyNode (PolyNode *p)
6231 {
6232 /* we reset everything here except memoryIndex, which should be immutable */
6233 p->length = 0.0;
6234 p->depth = 0.0;
6235 p->age = 0.0;
6236 p->anc = p->left = p->sib = NULL;
6237 p->calibration = NULL;
6238 p->f = 0.0;
6239 p->index = 0;
6240 p->isDated = NO;
6241 p->isLocked = NO;
6242 strcpy (p->label,"");
6243 p->lockID = 0;
6244 p->partition = NULL;
6245 p->partitionIndex = 0;
6246 p->support = 0.0;
6247 p->x = p->y = 0;
6248 }
6249
6250
6251 /* ResetPolyTree: Reset polytomous tree to pristine state but keep relevant memory. */
ResetPolyTree(PolyTree * pt)6252 void ResetPolyTree (PolyTree *pt)
6253 {
6254 int i, maxTaxa, nLongsNeeded;
6255
6256 /* clear nodes */
6257 for (i=0; i<pt->memNodes; i++)
6258 ResetPolyNode (&pt->nodes[i]);
6259
6260 /* empty node arrays and tree properties but keep space */
6261 for (i=0; i<pt->nNodes; i++)
6262 pt->allDownPass[i] = NULL;
6263 for (i=0; i<pt->nIntNodes; i++)
6264 pt->intDownPass[i] = NULL;
6265 pt->nNodes = 0;
6266 pt->nIntNodes = 0;
6267 pt->root = NULL;
6268 pt->brlensDef = NO;
6269 pt->isRooted = NO;
6270 pt->isClock = NO;
6271 pt->isRelaxed = NO;
6272 pt->clockRate = 0.0;
6273
6274 /* empty bitsets but keep space and pointers */
6275 if (pt->bitsets)
6276 {
6277 maxTaxa = pt->memNodes / 2;
6278 nLongsNeeded = (maxTaxa - 1) / nBitsInALong + 1;
6279 for (i=0; i<pt->memNodes*nLongsNeeded; i++)
6280 pt->bitsets[i] = 0;
6281 for (i=0; i<pt->memNodes; i++)
6282 pt->nodes[i].partition = pt->bitsets + i*nLongsNeeded;
6283 }
6284
6285 /* empty relaxed clock parameters */
6286 FreePolyTreeRelClockParams (pt);
6287
6288 /* empty population size set parameters */
6289 FreePolyTreePopSizeParams (pt);
6290 }
6291
6292
6293 /* ResetPolyTreePartitions: Reset and set bit patterns describing partitions */
ResetPolyTreePartitions(PolyTree * pt)6294 void ResetPolyTreePartitions (PolyTree *pt)
6295 {
6296 int i, j, numTaxa, nLongsNeeded;
6297 PolyNode *pp;
6298
6299 /* get some handy numbers */
6300 numTaxa = pt->memNodes/2;
6301 nLongsNeeded = (numTaxa - 1) / nBitsInALong + 1;
6302
6303 /* reset bits describing partitions */
6304 for (i=0; i<pt->memNodes*nLongsNeeded; i++)
6305 {
6306 pt->bitsets[i] = 0;
6307 }
6308
6309 /* set bits describing partitions */
6310 for (i=0; i<pt->nNodes; i++)
6311 {
6312 assert (pt->allDownPass != NULL && pt->allDownPass[i] != NULL);
6313 assert (pt->allDownPass[i]->partition != NULL);
6314
6315 pp = pt->allDownPass[i];
6316 if (pp->left == NULL)
6317 {
6318 SetBit (pp->index, pp->partition);
6319 }
6320 if (pp->anc != NULL)
6321 {
6322 for (j=0; j<nLongsNeeded; j++)
6323 pp->anc->partition[j] |= pp->partition[j];
6324 }
6325 }
6326 }
6327
6328
6329 /*----------------------------------------------
6330 |
6331 | ResetRootHeight: Reset node heights in a clock
6332 | tree to fit a new root height. Assumes
6333 | node depths and lengths set correctly.
6334 |
6335 -----------------------------------------------*/
ResetRootHeight(Tree * t,MrBFlt rootHeight)6336 int ResetRootHeight (Tree *t, MrBFlt rootHeight)
6337 {
6338 int i;
6339 TreeNode *p;
6340 MrBFlt factor, x, y;
6341
6342 if (t->isClock == NO)
6343 return ERROR;
6344
6345 /* make sure node depths are set */
6346 for (i=0; i<t->nNodes-1; i++)
6347 {
6348 p = t->allDownPass[i];
6349 if (p->left == NULL)
6350 p->nodeDepth = 0.0;
6351 else
6352 {
6353 x = p->left->nodeDepth + p->left->length;
6354 y = p->right->nodeDepth + p->right->length;
6355 if (x > y)
6356 p->nodeDepth = x;
6357 else
6358 p->nodeDepth = y;
6359 }
6360 }
6361 for (i=t->nNodes-3; i>=0; i--)
6362 {
6363 p = t->allDownPass[i];
6364 p->nodeDepth = p->anc->nodeDepth - p->length;
6365 }
6366
6367 /* now reset node depths and branch lengths */
6368 factor = rootHeight / t->root->left->nodeDepth;
6369 t->root->left->nodeDepth = rootHeight;
6370 for (i=t->nNodes-2; i>=0; i--)
6371 {
6372 p = t->allDownPass[i];
6373 p->nodeDepth *= factor;
6374 p->length *= factor;
6375 }
6376
6377 return NO_ERROR;
6378 }
6379
6380
6381 /*----------------------------------------------
6382 |
6383 | ResetTipIndices: reset tip indices to be from
6384 | 0 to number of included taxa, in same order
6385 | as in the original taxon set.
6386 |
6387 -----------------------------------------------*/
ResetTipIndices(PolyTree * pt)6388 void ResetTipIndices(PolyTree *pt)
6389 {
6390 int i, j, k, m;
6391 PolyNode *p = NULL;
6392
6393 for (i=j=0; i<numTaxa; i++)
6394 {
6395 for (k=0; k<pt->nNodes; k++)
6396 {
6397 p = pt->allDownPass[k];
6398 if (StrCmpCaseInsensitive(p->label,taxaNames[i]) == 0)
6399 break;
6400 }
6401 if (k < pt->nNodes)
6402 {
6403 assert (p->left == NULL);
6404 if (p->index!=j) {
6405 SwapRelaxedBranchInfo (p->index, j, pt);
6406 for (m=0; m<pt->nNodes; m++)
6407 {
6408 if (pt->allDownPass[m]->index==j)
6409 {
6410 pt->allDownPass[m]->index=p->index;
6411 break;
6412 }
6413 }
6414 p->index = j;
6415 }
6416 j++;
6417 }
6418 }
6419 }
6420
6421
6422 /*----------------------------------------------
6423 |
6424 | ResetTopology: rebuild the tree t to fit the
6425 | Newick string s. Everyting except topology
6426 | is left in the same state in t.
6427 |
6428 -----------------------------------------------*/
ResetTopology(Tree * t,char * s)6429 int ResetTopology (Tree *t, char *s)
6430 {
6431 TreeNode *p, *q;
6432 int i, j, k, inLength;
6433 char temp[30];
6434
6435 /* set all pointers to NULL */
6436 for (i=0; i<t->memNodes; i++)
6437 {
6438 p = &t->nodes[i];
6439 p->anc = p->right = p->left = NULL;
6440 p->index = -1;
6441 }
6442 p = &t->nodes[0];
6443
6444 /* start out assuming that the tree is rooted; we will detect below if it is not */
6445 t->isRooted = YES;
6446 inLength = NO;
6447 for (i=0, j=1; *s!='\0'; s++)
6448 {
6449 if (*s == ',' || *s == ')' || *s == ':')
6450 {
6451 if (p->right == NULL && inLength == NO)
6452 {
6453 temp[i] = '\0';
6454 k = atoi (temp);
6455 p->index = k-1;
6456 i = 0;
6457 }
6458 else
6459 inLength = NO;
6460 }
6461 if (*s == '(')
6462 {
6463 q = p;
6464 p = &t->nodes[j++];
6465 q->left = p;
6466 p->anc = q;
6467 }
6468 else if (*s == ',')
6469 {
6470 if (p->anc->right == NULL)
6471 {
6472 q = p->anc;
6473 p = &t->nodes[j++];
6474 p->anc = q;
6475 q->right = p;
6476 }
6477 else /* if p->anc->right == p (near 'root' of unrooted trees) */
6478 {
6479 q = p->anc;
6480 p = &t->nodes[j++];
6481 q->anc = p;
6482 p->left = q;
6483 t->isRooted = NO;
6484 }
6485 }
6486 else if (*s == ')')
6487 {
6488 p = p->anc;
6489 }
6490 else if (*s == ':')
6491 {
6492 inLength = YES;
6493 }
6494 else if (inLength == NO)
6495 {
6496 temp[i++] = *s;
6497 }
6498 }
6499
6500 /* attach root to rooted tree */
6501 if (t->isRooted == YES)
6502 {
6503 p = &t->nodes[0];
6504 q = &t->nodes[j++];
6505 q->left = p;
6506 p->anc = q;
6507 }
6508
6509 /* relabel interior nodes, find number of nodes and root */
6510 t->nNodes = j;
6511 t->nIntNodes = t->nNodes/2 - 1;
6512
6513 if (t->isRooted == NO)
6514 j = t->nNodes - t->nIntNodes;
6515 else
6516 j = t->nNodes - t->nIntNodes - 1;
6517
6518 for (i=0; i<t->nNodes; i++)
6519 {
6520 p = &t->nodes[i];
6521 if (p->index == -1)
6522 p->index = j++;
6523 if (p->anc == NULL)
6524 t->root = p;
6525 }
6526
6527 GetDownPass (t);
6528
6529 return NO_ERROR;
6530 }
6531
6532
6533 /*-----------------------------------------------------------------
6534 |
6535 | ResetBrlensFromTree: copies brlens and depths from second tree (vTree) to
6536 | first tree (used to initialize brlen sets for same topology)
6537 |
6538 -----------------------------------------------------------------*/
ResetBrlensFromTree(Tree * tree,Tree * vTree)6539 int ResetBrlensFromTree (Tree *tree, Tree *vTree)
6540 {
6541 int i, j, k, nLongsNeeded, numTips;
6542 MrBFlt d1, d2;
6543 TreeNode *p, *q;
6544
6545 if (tree->isRooted != vTree->isRooted)
6546 return (ERROR);
6547
6548 if (AreTopologiesSame (tree, vTree) == NO)
6549 return (ERROR);
6550
6551 /* allocate and set up partitions */
6552 AllocateTreePartitions (vTree);
6553 AllocateTreePartitions (tree);
6554 numTips = tree->nNodes - tree->nIntNodes - (tree->isRooted == YES ? 1 : 0);
6555 nLongsNeeded = (int) ((numTips - 1) / nBitsInALong) + 1;
6556
6557 /*copy lengths and nodeDepthes*/
6558 for (i=0; i<vTree->nNodes; i++)
6559 {
6560 p = vTree->allDownPass[i];
6561 for (j=0; j<tree->nNodes; j++)
6562 {
6563 q = tree->allDownPass[j];
6564 for (k=0; k<nLongsNeeded; k++)
6565 if (p->partition[k] != q->partition[k])
6566 break;
6567 if (k==nLongsNeeded)
6568 {
6569 q->length = p->length;
6570 if (tree->isRooted == YES)
6571 q->nodeDepth = p->nodeDepth;
6572 }
6573 }
6574 }
6575
6576 if (tree->isRooted == YES)
6577 {
6578 /*Next compute height for the root. */
6579 for (i=0; i<tree->nNodes-1; i++)
6580 {
6581 p = tree->allDownPass[i];
6582 if (p->left == NULL)
6583 p->nodeDepth = 0.0;
6584 else
6585 {
6586 d1 = p->left->nodeDepth + p->left->length;
6587 d2 = p->right->nodeDepth + p->right->length;
6588 if (d1 > d2)
6589 p->nodeDepth = d1;
6590 else
6591 p->nodeDepth = d2;
6592 }
6593 }
6594 for (i=tree->nNodes-3; i>=0; i--)
6595 {
6596 p = tree->allDownPass[i];
6597 if (p->left==NULL && p->calibration==NULL)
6598 continue; /* leave at 0.0 */
6599 p->nodeDepth = p->anc->nodeDepth - p->length;
6600 }
6601 }
6602
6603 FreeTreePartitions(tree);
6604 FreeTreePartitions(vTree);
6605
6606 return (NO_ERROR);
6607 }
6608
6609
6610 /* ResetIntNodeIndices: Set int node indices in downpass order from numTaxa to 2*numTaxa-2 */
ResetIntNodeIndices(PolyTree * t)6611 void ResetIntNodeIndices (PolyTree *t)
6612 {
6613 int i, m, index;
6614
6615 index = t->nNodes - t->nIntNodes;
6616
6617 for (i=0; i<t->nIntNodes; i++)
6618 {
6619 if (t->intDownPass[i]->index != index)
6620 {
6621 SwapRelaxedBranchInfo (t->intDownPass[i]->index, index, t);
6622 for (m=0; m<t->nIntNodes; m++)
6623 {
6624 if (t->intDownPass[m]->index==index)
6625 {
6626 t->intDownPass[m]->index=t->intDownPass[i]->index;
6627 break;
6628 }
6629 }
6630 t->intDownPass[i]->index = index;
6631 }
6632 index++;
6633 }
6634 }
6635
6636
6637 /* ResetTopologyFromTree: use top to set topology in tree */
ResetTopologyFromTree(Tree * tree,Tree * top)6638 int ResetTopologyFromTree (Tree *tree, Tree *top)
6639 {
6640 int i, j, k;
6641 TreeNode *p, *q, *r, *p1;
6642
6643 /* adopt rooting */
6644 tree->isRooted = top->isRooted;
6645 tree->nNodes = top->nNodes;
6646 tree->nIntNodes = top->nIntNodes;
6647
6648 /* set all pointers to NULL */
6649 for (i=0; i<tree->nNodes; i++)
6650 {
6651 p = &tree->nodes[i];
6652 p->anc = p->right = p->left = NULL;
6653 }
6654
6655 /* now copy topology */
6656 for (i=0; i<top->nIntNodes; i++)
6657 {
6658 p1 = top->intDownPass[i];
6659
6660 k = p1->index;
6661 for (j=0; j<tree->nNodes; j++)
6662 if (tree->nodes[j].index == k)
6663 break;
6664 p = &tree->nodes[j];
6665
6666 k = p1->left->index;
6667 for (j=0; j<tree->nNodes; j++)
6668 if (tree->nodes[j].index == k)
6669 break;
6670 q = &tree->nodes[j];
6671
6672 k = p1->right->index;
6673 for (j=0; j<tree->nNodes; j++)
6674 if (tree->nodes[j].index == k)
6675 break;
6676 r = &tree->nodes[j];
6677
6678 p->left = q;
6679 p->right= r;
6680 q->anc = r->anc = p;
6681 }
6682
6683 /* arrange the root */
6684 k = top->root->index;
6685 for (j=0; j<tree->nNodes; j++)
6686 if (tree->nodes[j].index == k)
6687 break;
6688 p = &tree->nodes[j];
6689
6690 k = top->root->left->index;
6691 for (j=0; j<tree->nNodes; j++)
6692 if (tree->nodes[j].index == k)
6693 break;
6694 q = &tree->nodes[j];
6695 p->left = q;
6696 q->anc = p;
6697 p->right = p->anc = NULL;
6698 tree->root = p;
6699
6700 GetDownPass (tree);
6701
6702 return (NO_ERROR);
6703 }
6704
6705
6706 /* ResetTopologyFromPolyTree: use polytree top to set topology in tree */
ResetTopologyFromPolyTree(Tree * tree,PolyTree * top)6707 int ResetTopologyFromPolyTree (Tree *tree, PolyTree *top)
6708 {
6709 int i, j, k;
6710 TreeNode *p, *q, *r;
6711 PolyNode *p1;
6712
6713 if (tree->isRooted != top->isRooted)
6714 return (ERROR);
6715
6716 /* set all pointers to NULL */
6717 for (i=0; i<tree->nNodes; i++)
6718 {
6719 p = &tree->nodes[i];
6720 p->anc = p->right = p->left = NULL;
6721 }
6722
6723 /* now copy topology */
6724 for (i=0; i<top->nIntNodes; i++)
6725 {
6726 p1 = top->intDownPass[i];
6727
6728 k = p1->index;
6729 for (j=0; j<tree->nNodes; j++)
6730 if (tree->nodes[j].index == k)
6731 break;
6732 p = &tree->nodes[j];
6733
6734 k = p1->left->index;
6735 for (j=0; j<tree->nNodes; j++)
6736 if (tree->nodes[j].index == k)
6737 break;
6738 q = &tree->nodes[j];
6739
6740 k = p1->left->sib->index;
6741 for (j=0; j<tree->nNodes; j++)
6742 if (tree->nodes[j].index == k)
6743 break;
6744 r = &tree->nodes[j];
6745
6746 p->left = q;
6747 p->right= r;
6748 q->anc = r->anc = p;
6749 }
6750
6751 /* arrange the root */
6752 if (top->isRooted == YES)
6753 {
6754 k = top->root->index;
6755 for (j=0; j<tree->nNodes; j++)
6756 if (tree->nodes[j].index == k)
6757 break;
6758 p = &tree->nodes[j];
6759
6760 k = top->nNodes;
6761 for (j=0; j<tree->nNodes; j++)
6762 if (tree->nodes[j].index == k)
6763 break;
6764 q = &tree->nodes[j];
6765
6766 q->left = p;
6767 q->anc = NULL;
6768 q->right = NULL;
6769 tree->root = q;
6770 }
6771 else /* if (top->isRooted == NO) */
6772 {
6773 k = top->root->index;
6774 for (j=0; j<tree->nNodes; j++)
6775 if (tree->nodes[j].index == k)
6776 break;
6777 p = &tree->nodes[j];
6778
6779 k = localOutGroup;
6780 for (p1=top->root->left; p1!=NULL; p1=p1->sib)
6781 if (p1->index == k)
6782 break;
6783
6784 assert (p1 != NULL);
6785 if (p1 == NULL)
6786 return (ERROR);
6787
6788 q = &tree->nodes[p1->index];
6789 k = p1->anc->left->sib->sib->index; /* index of missing child */
6790 if (p->left == q)
6791 p->left = &tree->nodes[k];
6792 else if (p->right == q)
6793 p->right = &tree->nodes[k];
6794
6795 q->anc = q->right = NULL;
6796 p->anc = q;
6797 q->left = p;
6798 }
6799
6800 GetDownPass (tree);
6801
6802 return (NO_ERROR);
6803 }
6804
6805
6806 /* ResetTreePartitions: Reset bitsets describing tree partitions */
ResetTreePartitions(Tree * t)6807 void ResetTreePartitions (Tree *t)
6808 {
6809 int i, j, numTaxa, nLongsNeeded;
6810 TreeNode *p;
6811
6812 /* get some handy numbers */
6813 numTaxa = t->nNodes - t->nIntNodes - (t->isRooted == YES ? 1 : 0);
6814 nLongsNeeded = (numTaxa - 1) / nBitsInALong + 1;
6815
6816 /* reset bits describing partitions */
6817 for (i=0; i<t->nNodes; i++)
6818 {
6819 assert (t->allDownPass != NULL && t->allDownPass[i] != NULL);
6820 assert (t->allDownPass[i]->partition != NULL);
6821
6822 p = t->allDownPass[i];
6823 for (j=0; j<nLongsNeeded; j++)
6824 p->partition[j] = 0;
6825 }
6826
6827 /* set bits describing partitions */
6828 for (i=0; i<t->nNodes; i++)
6829 {
6830 p = t->allDownPass[i];
6831 if (p->left == NULL || (p->anc == NULL && t->isRooted == NO))
6832 SetBit (p->index, p->partition);
6833 else if (p->anc != NULL)
6834 {
6835 for (j=0; j<nLongsNeeded; j++)
6836 p->partition[j] = p->left->partition[j] | p->right->partition[j];
6837 }
6838 }
6839 }
6840
6841
6842 /*-------------------------------------------------------
6843 |
6844 | RetrieveRTopology: This routine will rebuild a rooted
6845 | tree from the order array created by StoreRTopology.
6846 | All tree information except the structure will
6847 | remain unaltered.
6848 |
6849 --------------------------------------------------------*/
RetrieveRTopology(Tree * t,int * order)6850 int RetrieveRTopology (Tree *t, int *order)
6851 {
6852 int i, numTaxa;
6853 TreeNode *p, *q, *r;
6854
6855 numTaxa = t->nNodes - t->nIntNodes - 1;
6856
6857 /* sort the tips in the t->allDownPass array */
6858 p = t->nodes;
6859 for (i=0; i<t->nNodes; i++, p++)
6860 t->allDownPass[p->index] = p;
6861
6862 /* make sure the root has index 2*numTaxa-1 */
6863 q = t->allDownPass[t->nNodes-1];
6864 q->anc = q->right = NULL;
6865 t->root = q;
6866
6867 /* connect the first two tips */
6868 p = t->allDownPass[numTaxa];
6869 p->anc = q;
6870 q->left = p;
6871 p->length = 0.0;
6872 q = t->allDownPass[0];
6873 r = t->allDownPass[1];
6874 p->left = q;
6875 p->right = r;
6876 q->anc = r->anc = p;
6877
6878 /* add one tip at a time */
6879 for (i=2; i<numTaxa; i++)
6880 {
6881 p = t->allDownPass[i];
6882 q = t->allDownPass[numTaxa-1+i];
6883 r = t->allDownPass[*(order++)];
6884 p->anc = q;
6885 q->left = p;
6886 q->right = r;
6887 q->anc = r->anc;
6888 if (r->anc->left == r)
6889 r->anc->left = q;
6890 else
6891 r->anc->right = q;
6892 r->anc = q;
6893 }
6894
6895 /* get downpass */
6896 GetDownPass (t);
6897
6898 /* relabel interior nodes (root is correctly labeled already) */
6899 for (i=0; i<t->nIntNodes; i++)
6900 t->intDownPass[i]->index = i+numTaxa;
6901
6902 return (NO_ERROR);
6903 }
6904
6905
6906 /*-------------------------------------------------------
6907 |
6908 | RetrieveRTree: This routine will rebuild a rooted
6909 | tree from the arrays created by StoreRTree.
6910 | All tree information except the structure and
6911 | branch lengths will remain unaltered.
6912 |
6913 --------------------------------------------------------*/
RetrieveRTree(Tree * t,int * order,MrBFlt * brlens)6914 int RetrieveRTree (Tree *t, int *order, MrBFlt *brlens)
6915 {
6916 int i, numTaxa;
6917 TreeNode *p, *q, *r;
6918
6919 numTaxa = t->nNodes - t->nIntNodes - 1;
6920
6921 /* sort the tips in the t->allDownPass array */
6922 p = t->nodes;
6923 for (i=0; i<t->nNodes; i++, p++)
6924 t->allDownPass[p->index] = p;
6925
6926 /* make sure that root has index 2*numTaxa-1 */
6927 q = t->allDownPass[t->nNodes-1];
6928 q->anc = q->right = NULL;
6929 q->length = 0.0;
6930 t->root = q;
6931
6932 /* connect the first three tips */
6933 p = t->allDownPass[numTaxa];
6934 p->anc = q;
6935 q->left = p;
6936 p->length = 0.0;
6937 q = t->allDownPass[0];
6938 r = t->allDownPass[1];
6939 p->left = q;
6940 p->right = r;
6941 q->anc = r->anc = p;
6942 q->length = *(brlens++);
6943 r->length = *(brlens++);
6944
6945 /* add one tip at a time */
6946 for (i=2; i<numTaxa; i++)
6947 {
6948 p = t->allDownPass[i];
6949 q = t->allDownPass[numTaxa-1+i];
6950 r = t->allDownPass[*(order++)];
6951 p->anc = q;
6952 q->left = p;
6953 q->right = r;
6954 q->anc = r->anc;
6955 if (r->anc->left == r)
6956 r->anc->left = q;
6957 else
6958 r->anc->right = q;
6959 r->anc = q;
6960 if (q->anc->anc != NULL)
6961 q->length = *(brlens++);
6962 else
6963 {
6964 r->length = *(brlens++);
6965 q->length = 0.0;
6966 }
6967 p->length = *(brlens++);
6968 }
6969
6970 /* get downpass */
6971 GetDownPass (t);
6972
6973 /* relabel interior nodes (root is correctly labeled already) */
6974 for (i=0; i<t->nIntNodes; i++)
6975 t->intDownPass[i]->index = i+numTaxa;
6976
6977 /* set the node depths */
6978 SetNodeDepths (t);
6979
6980 return (NO_ERROR);
6981 }
6982
6983
6984 /*-------------------------------------------------------
6985 |
6986 | RetrieveRTreeWithIndices: This routine will rebuild a rooted
6987 | tree from the arrays created by StoreRTreeWithIndices.
6988 | All tree information except the structure, branch lengths
6989 | and node indices will remain unaltered.
6990 |
6991 --------------------------------------------------------*/
RetrieveRTreeWithIndices(Tree * t,int * order,MrBFlt * brlens)6992 int RetrieveRTreeWithIndices (Tree *t, int *order, MrBFlt *brlens)
6993 {
6994 int i, numTaxa;
6995 TreeNode *p, *q, *r;
6996
6997 extern void ShowNodes (TreeNode *, int, int);
6998
6999 numTaxa = t->nNodes - t->nIntNodes - 1;
7000
7001 /* sort the tips in the t->allDownPass array */
7002 p = t->nodes;
7003 for (i=0; i<t->nNodes; i++, p++)
7004 t->allDownPass[p->index] = p;
7005
7006 /* make sure that root has index 2*numTaxa-1 */
7007 q = t->allDownPass[t->nNodes-1];
7008 q->anc = q->right = NULL;
7009 q->length = 0.0;
7010 t->root = q;
7011
7012 /* connect the first three 'tips' with interior node, index from order array */
7013 p = t->allDownPass[numTaxa];
7014 p->x = *(order++);
7015 p->anc = q;
7016 q->left = p;
7017 p->length = 0.0;
7018 q = t->allDownPass[0];
7019 r = t->allDownPass[1];
7020 p->left = q;
7021 p->right = r;
7022 q->anc = r->anc = p;
7023 q->length = *(brlens++);
7024 r->length = *(brlens++);
7025
7026 /* add one tip at a time */
7027 for (i=2; i<numTaxa; i++)
7028 {
7029 p = t->allDownPass[i];
7030 assert (*order >= numTaxa && *order < 2*numTaxa - 1);
7031 q = t->allDownPass[numTaxa-1+i];
7032 q->x = *(order++);
7033 r = t->allDownPass[*(order++)];
7034 p->anc = q;
7035 q->left = p;
7036 q->right = r;
7037 q->anc = r->anc;
7038 if (r->anc->left == r)
7039 r->anc->left = q;
7040 else
7041 r->anc->right = q;
7042 r->anc = q;
7043 if (q->anc->anc != NULL)
7044 q->length = *(brlens++);
7045 else
7046 {
7047 r->length = *(brlens++);
7048 q->length = 0.0;
7049 }
7050 p->length = *(brlens++);
7051 }
7052
7053 /* get downpass */
7054 GetDownPass (t);
7055
7056 /* relabel interior nodes using labels in scratch variable x */
7057 for (i=0; i<t->nIntNodes; i++)
7058 {
7059 p = t->intDownPass[i];
7060 p->index = p->x;
7061 }
7062
7063 /* set the node depths */
7064 SetNodeDepths (t);
7065
7066 return (NO_ERROR);
7067 }
7068
7069
7070 /*-------------------------------------------------------
7071 |
7072 | RetrieveUTopology: This routine will rebuild an unrooted
7073 | tree from the order array created by StoreUTopology.
7074 | All tree information except the structure
7075 | will remain unaltered.
7076 |
7077 --------------------------------------------------------*/
RetrieveUTopology(Tree * t,int * order)7078 int RetrieveUTopology (Tree *t, int *order)
7079 {
7080 int i, numTips;
7081 TreeNode *p, *q, *r;
7082
7083 /* preliminaries */
7084 numTips = t->nNodes - t->nIntNodes;
7085 for (i=0; i<t->nNodes; i++)
7086 t->nodes[i].left = t->nodes[i].right = t->nodes[i].anc = NULL;
7087
7088 /* sort the tips in the t->allDownPass array */
7089 p = t->nodes;
7090 for (i=0; i<t->nNodes; i++, p++)
7091 t->allDownPass[p->index] = p;
7092
7093 /* make sure root has index 0 */
7094 q = t->allDownPass[0];
7095 q->anc = q->right = NULL;
7096 t->root = q;
7097
7098 /* connect the first three tips */
7099 p = t->allDownPass[numTips];
7100 p->anc = q;
7101 q->left = p;
7102 q = t->allDownPass[1];
7103 r = t->allDownPass[2];
7104 p->left = q;
7105 p->right = r;
7106 q->anc = r->anc = p;
7107
7108 /* add one tip at a time */
7109 for (i=3; i<numTips; i++)
7110 {
7111 p = t->allDownPass[i];
7112 q = t->allDownPass[numTips-2+i];
7113 r = t->allDownPass[order[i-3]];
7114 p->anc = q;
7115 q->left = p;
7116 q->right = r;
7117 q->anc = r->anc;
7118 if (r->anc->left == r)
7119 r->anc->left = q;
7120 else
7121 r->anc->right = q;
7122 r->anc = q;
7123 }
7124
7125 /* get downpass */
7126 GetDownPass (t);
7127
7128 /* relabel interior nodes (root is correctly labeled already) */
7129 for (i=0; i<t->nIntNodes; i++)
7130 t->intDownPass[i]->index = i+numTips;
7131
7132 return (NO_ERROR);
7133 }
7134
7135
7136 /*-------------------------------------------------------
7137 |
7138 | RetrieveUTree: This routine will rebuild an unrooted
7139 | tree from the arrays created by StoreUTree.
7140 | All tree information except the structure and
7141 | branch lengths will remain unaltered.
7142 |
7143 --------------------------------------------------------*/
RetrieveUTree(Tree * t,int * order,MrBFlt * brlens)7144 int RetrieveUTree (Tree *t, int *order, MrBFlt *brlens)
7145 {
7146 int i, numTips;
7147 TreeNode *p, *q, *r;
7148
7149 /* preliminaries */
7150 numTips = t->nNodes - t->nIntNodes;
7151 for (i=0; i<t->nNodes; i++)
7152 t->nodes[i].left = t->nodes[i].right = t->nodes[i].anc = NULL;
7153
7154 /* sort the tips in the t->allDownPass array */
7155 p = t->nodes;
7156 for (i=0; i<t->nNodes; i++, p++)
7157 t->allDownPass[p->index] = p;
7158
7159 /* make sure that root has index 0 */
7160 q = t->allDownPass[0];
7161 q->anc = q->right = NULL;
7162 t->root = q;
7163
7164 /* connect the first three tips */
7165 p = t->allDownPass[numTips];
7166 p->anc = q;
7167 q->left = p;
7168 p->length = *(brlens++);
7169 q = t->allDownPass[1];
7170 r = t->allDownPass[2];
7171 p->left = q;
7172 p->right = r;
7173 q->anc = r->anc = p;
7174 q->length = *(brlens++);
7175 r->length = *(brlens++);
7176
7177 /* add one tip at a time */
7178 for (i=3; i<numTips; i++)
7179 {
7180 p = t->allDownPass[i];
7181 q = t->allDownPass[numTips-2+i];
7182 r = t->allDownPass[order[i-3]];
7183 p->anc = q;
7184 q->left = p;
7185 q->right = r;
7186 q->anc = r->anc;
7187 if (r->anc->left == r)
7188 r->anc->left = q;
7189 else
7190 r->anc->right = q;
7191 r->anc = q;
7192 q->length = *(brlens++);
7193 p->length = *(brlens++);
7194 }
7195
7196 /* get downpass */
7197 GetDownPass (t);
7198
7199 /* relabel interior nodes (root is correctly labeled already) */
7200 for (i=0; i<t->nIntNodes; i++)
7201 t->intDownPass[i]->index = i+numTips;
7202
7203 return (NO_ERROR);
7204 }
7205
7206
SetDatedNodeAges(Param * param,int chain,int state)7207 void SetDatedNodeAges (Param *param, int chain, int state)
7208 {
7209 int i;
7210 MrBFlt clockRate;
7211 ModelInfo *m;
7212 TreeNode *p;
7213 Tree *t;
7214
7215 extern void ShowNodes(TreeNode *,int,int);
7216
7217 t = GetTree (param, chain, state);
7218 m = &modelSettings[t->relParts[0]];
7219
7220 if (m->clockRate == NULL)
7221 clockRate = 1.0;
7222 else
7223 clockRate = *GetParamVals(m->clockRate, chain, state);
7224
7225 for (i=0; i<t->nNodes-1; i++)
7226 {
7227 p = t->allDownPass[i];
7228 if (p->isDated == YES)
7229 p->age = p->nodeDepth / clockRate;
7230 else
7231 p->age = -1.0;
7232 }
7233 }
7234
7235
SetNodeDepths(Tree * t)7236 void SetNodeDepths (Tree *t)
7237 {
7238 int i;
7239 MrBFlt d1, d2;
7240 TreeNode *p;
7241
7242 extern void ShowNodes(TreeNode *,int,int);
7243
7244 for (i=0; i<t->nNodes-1; i++)
7245 {
7246 p = t->allDownPass[i];
7247 if (p->left == NULL)
7248 p->nodeDepth = 0.0;
7249 else
7250 {
7251 d1 = p->left->nodeDepth + p->left->length;
7252 d2 = p->right->nodeDepth + p->right->length;
7253 //assert (!(t->isCalibrated == NO && AreDoublesEqual(d1,d2,0.00001)==NO)); // may not work if we set startval topology of strict clock tree by non clock tree.
7254 if (d1 > d2)
7255 p->nodeDepth = d1;
7256 else
7257 p->nodeDepth = d2;
7258 }
7259 }
7260
7261 for (i=t->nNodes-3; i>=0; i--)
7262 {
7263 p = t->allDownPass[i];
7264 if (p->left == NULL && p->calibration == NULL)
7265 p->nodeDepth = 0.0;
7266 else
7267 p->nodeDepth = p->anc->nodeDepth - p->length;
7268 }
7269 }
7270
7271
7272 /* Set ages of a clock tree according to depth and clockrate. Check that resulting ages are consistant with calibration.
7273 | return YES if tree is age consistent, No otherwise.
7274 */
SetTreeNodeAges(Param * param,int chain,int state)7275 int SetTreeNodeAges (Param *param, int chain, int state)
7276 {
7277 Tree *tree;
7278 TreeNode *p;
7279 int i;
7280 MrBFlt clockRate;
7281
7282 if (param->paramType != P_TOPOLOGY && param->paramType != P_BRLENS && param->paramType != P_SPECIESTREE)
7283 return YES;
7284
7285 tree = GetTree(param, chain, state);
7286 if (modelSettings[param->relParts[0]].clockRate != NULL)
7287 clockRate = *GetParamVals(modelSettings[param->relParts[0]].clockRate, chain, state);
7288 else
7289 return YES;
7290
7291 /* Clock trees */
7292
7293 /* Check that lengths and depths are consistant. That would work for the case when we set up branch length from starting tree */
7294 for (i=0; i<tree->nNodes-1; i++) {
7295 p = tree->allDownPass[i];
7296 p->age = p->nodeDepth / clockRate;
7297 }
7298
7299 /* Check that ages and calibrations are consistent */
7300 if (tree->isCalibrated == YES)
7301 {
7302 for (i=0; i<tree->nNodes-1; i++)
7303 {
7304 p = tree->allDownPass[i];
7305 if (p->isDated == YES) {
7306 if (p->calibration->prior == fixed && fabs((p->age - p->calibration->priorParams[0])/p->age) > 0.000001)
7307 {
7308 printf ("Node %d has age %f but should be fixed to age %f\n",
7309 p->index, p->age, p->calibration->priorParams[0]);
7310 return NO;
7311 }
7312 else if (p->calibration->prior == uniform && (p->age < p->calibration->min || p->age > p->calibration->max))
7313 {
7314 printf ("Node %d has age %f but should be in the interval [%f,%f]\n",
7315 p->index, p->age, p->calibration->min, p->calibration->max);
7316 return NO;
7317 }
7318 else if (p->age < p->calibration->min)
7319 {
7320 printf ("Node %d has age %f but should be minimally of age %f\n",
7321 p->index, p->age, p->calibration->min);
7322 return NO;
7323 }
7324 else if (p->age > p->calibration->max)
7325 {
7326 printf ("Node %d has age %f but should be maximally of age %f\n",
7327 p->index, p->age, p->calibration->max);
7328 return NO;
7329 }
7330 }
7331 }
7332 }
7333
7334 return YES;
7335 }
7336
7337
ShowPolyNodes(PolyTree * pt)7338 int ShowPolyNodes (PolyTree *pt)
7339 {
7340 int i;
7341 PolyNode *p;
7342
7343 /* this is the tree, on a node-by-node basis */
7344 printf (" memnodes = %d nNodes = %d nIntNodes = %d root = %d\n", pt->memNodes, pt->nNodes, pt->nIntNodes, pt->root->index);
7345 printf (" isRooted = %d\n", pt->isRooted);
7346 printf (" no. index (left sib anc) -- locked/free -- label (p->x)\n");
7347 for (i=0; i<pt->memNodes; i++)
7348 {
7349 p = &pt->nodes[i];
7350 if (!(p->left == NULL && p->sib == NULL && p->anc == NULL))
7351 {
7352 printf ("%4d -- %4d ", i, p->index);
7353 if (p->left != NULL)
7354 printf ("(%4d ", p->left->index);
7355 else
7356 printf ("(null ");
7357
7358 if (p->sib != NULL)
7359 printf ("%4d ", p->sib->index);
7360 else
7361 printf ("null ");
7362
7363 if (p->anc != NULL)
7364 printf ("%4d)", p->anc->index);
7365 else
7366 printf ("null)");
7367
7368 if (p->isLocked == YES)
7369 printf ("-- locked -- ");
7370 else
7371 printf ("-- free --");
7372
7373 if (p->left == NULL && p->anc != NULL)
7374 printf (" \"%s\" (%d)\n", p->label, p->x);
7375 else
7376 printf (" \"\" (%d)\n", p->x);
7377 }
7378 }
7379
7380 return NO_ERROR;
7381 }
7382
7383
7384 /* ShowTree: Show tree on screen */
ShowTree(Tree * t)7385 int ShowTree (Tree *t)
7386 {
7387 int i, j, k, x, nLines, nLevels, levelDepth, from, to;
7388 char treeLine[SCREENWIDTH2], labelLine[100];
7389 TreeNode *p;
7390
7391 /* get coordinates */
7392 x = 0;
7393 nLines = 0;
7394 for (i=0; i<t->nNodes; i++)
7395 {
7396 p = t->allDownPass[i];
7397 if (p->left == NULL && p->right == NULL)
7398 {
7399 p->x = x;
7400 x += 2;
7401 p->y = 0;
7402 nLines += 2;
7403 }
7404 else if (p->left != NULL && p->right != NULL && p->anc != NULL)
7405 {
7406 p->x = p->left->x + (p->right->x - p->left->x) / 2;
7407 if (p->left->y > p->right->y)
7408 p->y = p->left->y + 1;
7409 else
7410 p->y = p->right->y + 1;
7411 }
7412 else
7413 {
7414 p->x = x;
7415 x += 2;
7416 p->y = 0;
7417 }
7418 }
7419
7420 /* print tree out, line-by-line */
7421 levelDepth = SCREENWIDTH / t->root->left->y;
7422 nLevels = t->root->left->y;
7423 for (j=0; j<=nLines-2; j++)
7424 {
7425 for (i=0; i<SCREENWIDTH2-2; i++)
7426 treeLine[i] = ' ';
7427 treeLine[SCREENWIDTH-1] = '\n';
7428 if (j % 2 == 0)
7429 {
7430 for (i=0; i<t->nNodes; i++)
7431 {
7432 p = t->allDownPass[i];
7433 if (p->left == NULL && p->x == j)
7434 {
7435 strcpy (labelLine, p->label);
7436 }
7437 }
7438 }
7439 for (i=0; i<t->nNodes; i++)
7440 {
7441 p = t->allDownPass[i];
7442 if (p->anc != NULL)
7443 {
7444 if (p->anc->anc != NULL)
7445 {
7446 if (p->x == j)
7447 {
7448 from = (nLevels - p->anc->y) * levelDepth;
7449 to = (nLevels - p->y) * levelDepth;
7450 if (p->y == 0)
7451 to = SCREENWIDTH-1;
7452 if (to >= SCREENWIDTH)
7453 to = SCREENWIDTH-1;
7454
7455 for (k=from; k<to; k++)
7456 treeLine[k] = '-';
7457 if (p->anc->left == p)
7458 treeLine[from] = '/';
7459 else
7460 treeLine[from] = '\\';
7461 if (p->left != NULL)
7462 {
7463 treeLine[to] = '+';
7464 }
7465 if (p->anc->anc == t->root && p->anc->right == p)
7466 {
7467 if (t->isRooted == NO)
7468 treeLine[to] = '+';
7469 else
7470 treeLine[from] = '\\';
7471 }
7472 }
7473 else
7474 {
7475 if (p->left != NULL && p->right != NULL)
7476 {
7477 if (j < p->x && j > p->left->x)
7478 {
7479 from = (nLevels - p->y) * levelDepth;
7480 treeLine[from] = '|';
7481 }
7482 else if (j > p->x && j < p->right->x && p->left != NULL)
7483 {
7484 from = (nLevels - p->y) * levelDepth;
7485 treeLine[from] = '|';
7486 }
7487 }
7488 }
7489 }
7490 else
7491 {
7492 if (p->x == j)
7493 {
7494 treeLine[0] = '|'; /* temp */
7495 }
7496 else if (j < p->x && j > p->left->x)
7497 {
7498 treeLine[0] = '|';
7499 }
7500 else if (j > p->x && j < p->right->x)
7501 {
7502 treeLine[0] = '|';
7503 }
7504 if (t->isRooted == NO)
7505 {
7506 if (j > p->x && j <= nLines-2)
7507 treeLine[0] = '|';
7508 if (j == p->right->x)
7509 treeLine[0] = '+';
7510 }
7511 else
7512 {
7513 if (j == p->x)
7514 treeLine[0] = '+';
7515 }
7516 }
7517 }
7518 }
7519 treeLine[SCREENWIDTH-1] = '\0';
7520 if (j % 2 == 0)
7521 MrBayesPrint (" %s %s\n", treeLine, labelLine);
7522 else
7523 MrBayesPrint (" %s \n", treeLine);
7524 }
7525
7526 if (t->isRooted == NO)
7527 {
7528 for (i=0; i<SCREENWIDTH; i++)
7529 treeLine[i] = ' ';
7530 treeLine[SCREENWIDTH-1] = '\0';
7531 MrBayesPrint (" |\n");
7532 for (k=0; k<SCREENWIDTH; k++)
7533 treeLine[k] = '-';
7534 treeLine[SCREENWIDTH-1] = '\0';
7535 treeLine[0] = '\\';
7536 strcpy (labelLine, t->root->label);
7537 labelLine[19] = '\0';
7538 MrBayesPrint (" %s %s\n", treeLine, labelLine);
7539 }
7540
7541 # if defined (DEBUG_CONSTRAINTS)
7542 for (i=0; i<t->nNodes; i++)
7543 printf ("%d -- %s\n", t->allDownPass[i]->index + 1, t->allDownPass[i]->isLocked == YES ? "locked" : "free");
7544 # endif
7545
7546 return (NO_ERROR);
7547 }
7548
7549
7550 /*-------------------------------------------------------
7551 |
7552 | StoreRPolyTopology: Same as StoreRTopology but for
7553 | binary polytree source trees.
7554 |
7555 --------------------------------------------------------*/
StoreRPolyTopology(PolyTree * t,int * order)7556 int StoreRPolyTopology (PolyTree *t, int *order)
7557 {
7558 int i, numTaxa;
7559 PolyNode *p, *q;
7560
7561 /* find number of taxa */
7562 numTaxa = t->nNodes - t->nIntNodes;
7563
7564 /* first get the terminal taxon positions and store
7565 them in the order array. */
7566 for (i=0; i<t->nNodes; i++)
7567 {
7568 p = t->allDownPass[i];
7569 /* we do not need to worry about the first two taxa */
7570 if (p->index > 1 && p->index < numTaxa)
7571 order[p->index-2] = i;
7572 }
7573
7574 /* label the interior nodes with the correct index */
7575 for (i=0; i<t->nNodes; i++)
7576 {
7577 p = t->allDownPass[i];
7578 if (p->left == NULL)
7579 p->x = p->y = p->index;
7580 else
7581 {
7582 if (p->left->y < p->left->sib->y)
7583 {
7584 p->y = p->left->y;
7585 p->x = p->left->sib->y + numTaxa - 1;
7586 }
7587 else
7588 {
7589 p->y = p->left->sib->y;
7590 p->x = p->left->y + numTaxa - 1;
7591 }
7592 }
7593 }
7594
7595 /* break the tree into pieces */
7596 for (i=0; i<numTaxa-2; i++)
7597 {
7598 /* find the next node to remove */
7599 p = t->allDownPass[order[numTaxa-3-i]];
7600 q = p->anc;
7601 if (q->left == p)
7602 {
7603 order[numTaxa-3-i] = q->left->sib->x;
7604 p->sib->anc = q->anc;
7605 if (q->anc == NULL)
7606 {
7607 p->sib->left->sib->sib = p->sib->sib;
7608 p->sib->sib = NULL;
7609 }
7610 else if (q->anc->left == q)
7611 {
7612 q->anc->left = q->left->sib;
7613 p->sib->sib = q->sib;
7614 }
7615 else
7616 q->anc->left->sib = q->left->sib;
7617 }
7618 else
7619 {
7620 order[numTaxa-3-i] = q->left->x;
7621 q->left->anc = q->anc;
7622 if (q->anc == NULL)
7623 {
7624 q->left->left->sib->sib = p->sib;
7625 q->left->sib = NULL;
7626 }
7627 else if (q->anc->left == q)
7628 {
7629 q->anc->left = q->left;
7630 q->anc->left->sib = q->sib;
7631 }
7632 else
7633 {
7634 q->anc->left->sib = q->left;
7635 q->left->sib = NULL;
7636 }
7637 }
7638 }
7639
7640 return (NO_ERROR);
7641 }
7642
7643
7644 /*-------------------------------------------------------
7645 |
7646 | StoreRPolyTree: Same as StoreRTree but for
7647 | binary rooted polytree source trees.
7648 |
7649 --------------------------------------------------------*/
StoreRPolyTree(PolyTree * t,int * order,MrBFlt * brlens)7650 int StoreRPolyTree (PolyTree *t, int *order, MrBFlt *brlens)
7651 {
7652 int i, j, numTaxa;
7653 PolyNode *p, *q;
7654
7655 /* find number of taxa */
7656 numTaxa = t->nNodes - t->nIntNodes;
7657
7658 /* first get the terminal taxon positions and store
7659 them in the order array. */
7660 for (i=0; i<t->nNodes; i++)
7661 {
7662 p = t->allDownPass[i];
7663 /* we do not need to worry about the first two taxa */
7664 if (p->index > 1 && p->index < numTaxa)
7665 order[p->index-2] = i;
7666 }
7667
7668 /* label the interior nodes with the correct index */
7669 for (i=0; i<t->nNodes; i++)
7670 {
7671 p = t->allDownPass[i];
7672 if (p->left == NULL)
7673 p->x = p->y = p->index;
7674 else
7675 {
7676 if (p->left->y < p->left->sib->y)
7677 {
7678 p->y = p->left->y;
7679 p->x = p->left->sib->y + numTaxa - 1;
7680 }
7681 else
7682 {
7683 p->y = p->left->sib->y;
7684 p->x = p->left->y + numTaxa - 1;
7685 }
7686 }
7687 }
7688
7689 /* break the tree into pieces */
7690 j = t->nNodes - 2; /* index of first branch length */
7691 for (i=0; i<numTaxa-2; i++)
7692 {
7693 /* find the next node to remove */
7694 p = t->allDownPass[order[numTaxa-3-i]];
7695 q = p->anc;
7696 brlens[j--] = p->length;
7697 brlens[j--] = q->length;
7698 if (q->left == p)
7699 {
7700 order[numTaxa-3-i] = q->left->sib->x;
7701 p->sib->anc = q->anc;
7702 if (q->anc == NULL)
7703 {
7704 p->sib->left->sib->sib = p->sib->sib;
7705 p->sib->sib = NULL;
7706 }
7707 else if (q->anc->left == q)
7708 {
7709 q->anc->left = q->left->sib;
7710 p->sib->sib = q->sib;
7711 }
7712 else
7713 q->anc->left->sib = q->left->sib;
7714 }
7715 else
7716 {
7717 order[numTaxa-3-i] = q->left->x;
7718 q->left->anc = q->anc;
7719 if (q->anc == NULL)
7720 {
7721 q->left->left->sib->sib = p->sib;
7722 q->left->sib = NULL;
7723 }
7724 else if (q->anc->left == q)
7725 {
7726 q->anc->left = q->left;
7727 q->anc->left->sib = q->sib;
7728 }
7729 else
7730 {
7731 q->anc->left->sib = q->left;
7732 q->left->sib = NULL;
7733 }
7734 }
7735 }
7736
7737 /* store the last two lengths; index 0 and 1 */
7738 p = t->root;
7739 brlens[p->left->index] = p->left->length;
7740 brlens[p->left->sib->index] = p->left->sib->length;
7741
7742 return (NO_ERROR);
7743 }
7744
7745
7746 /*-------------------------------------------------------
7747 |
7748 | StoreRTopology: This routine will break a rooted tree
7749 | into an array of ints describing the structure
7750 | of the tree. The tree will be destroyed
7751 | in the process (the node pointers, that is).
7752 | However, the tree is not deleted.
7753 |
7754 --------------------------------------------------------*/
StoreRTopology(Tree * t,int * order)7755 int StoreRTopology (Tree *t, int *order)
7756 {
7757 int i, numTaxa;
7758 TreeNode *p, *q;
7759
7760 /* find number of taxa */
7761 numTaxa = t->nNodes - t->nIntNodes - 1;
7762
7763 /* first get the terminal taxon positions and store
7764 them in the order array. */
7765 for (i=0; i<t->nNodes; i++)
7766 {
7767 p = t->allDownPass[i];
7768 /* we do not need to worry about the first two taxa */
7769 if (p->index > 1 && p->index < numTaxa)
7770 order[p->index-2] = i;
7771 }
7772
7773 /* label the interior nodes with the correct index */
7774 for (i=0; i<t->nNodes; i++)
7775 {
7776 p = t->allDownPass[i];
7777 if (p->left == NULL)
7778 p->x = p->y = p->index;
7779 else if (p->right != NULL)
7780 {
7781 if (p->left->y < p->right->y)
7782 {
7783 p->y = p->left->y;
7784 p->x = p->right->y + numTaxa - 1;
7785 }
7786 else
7787 {
7788 p->y = p->right->y;
7789 p->x = p->left->y + numTaxa - 1;
7790 }
7791 }
7792 }
7793
7794 /* break the tree into pieces */
7795 for (i=0; i<numTaxa-2; i++)
7796 {
7797 /* find the next node to remove */
7798 p = t->allDownPass[order[numTaxa-3-i]];
7799 q = p->anc;
7800 if (q->left == p)
7801 {
7802 order[numTaxa-3-i] = q->right->x;
7803 q->right->anc = q->anc;
7804 if (q->anc->left == q)
7805 q->anc->left = q->right;
7806 else
7807 q->anc->right = q->right;
7808 }
7809 else
7810 {
7811 order[numTaxa-3-i] = q->left->x;
7812 q->left->anc = q->anc;
7813 if (q->anc->left == q)
7814 q->anc->left = q->left;
7815 else
7816 q->anc->right = q->left;
7817 }
7818 }
7819
7820 return (NO_ERROR);
7821 }
7822
7823
7824 /*-------------------------------------------------------
7825 |
7826 | StoreRTree: This routine will break a rooted tree
7827 | into an array of ints describing the structure
7828 | of the tree and an array of doubles storing
7829 | the branch lengths. The tree will be
7830 | destroyed in the process (the node pointers,
7831 | that is). However, the tree is not deleted.
7832 |
7833 --------------------------------------------------------*/
StoreRTree(Tree * t,int * order,MrBFlt * brlens)7834 int StoreRTree (Tree *t, int *order, MrBFlt *brlens)
7835 {
7836 int i, j, numTaxa;
7837 TreeNode *p, *q;
7838
7839 extern void ShowNodes (TreeNode *p, int indent, int isRooted);
7840
7841 /* find number of taxa */
7842 numTaxa = t->nNodes - t->nIntNodes - 1;
7843
7844 /* first get the terminal taxon positions and store
7845 them in the order array. */
7846 for (i=0; i<t->nNodes; i++)
7847 {
7848 p = t->allDownPass[i];
7849 /* we do not need to worry about the first two taxa */
7850 if (p->index > 1 && p->index < numTaxa)
7851 order[p->index-2] = i;
7852 }
7853
7854 /* label the interior nodes with the correct index */
7855 for (i=0; i<t->nNodes; i++)
7856 {
7857 p = t->allDownPass[i];
7858 if (p->left == NULL)
7859 p->x = p->y = p->index;
7860 else if (p->right != NULL)
7861 {
7862 if (p->left->y < p->right->y)
7863 {
7864 p->y = p->left->y;
7865 p->x = p->right->y + numTaxa - 1;
7866 }
7867 else
7868 {
7869 p->y = p->right->y;
7870 p->x = p->left->y + numTaxa - 1;
7871 }
7872 }
7873 }
7874
7875 /* break the tree into pieces */
7876 j = 2 * numTaxa - 3;
7877 for (i=0; i<numTaxa-2; i++)
7878 {
7879 /* find the next node to remove */
7880 p = t->allDownPass[order[numTaxa-3-i]];
7881 q = p->anc;
7882 brlens[j--] = p->length;
7883 if (q->left == p)
7884 {
7885 if (q->anc->anc != NULL)
7886 brlens[j--] = q->length;
7887 else
7888 brlens[j--] = q->right->length;
7889 order[numTaxa-3-i] = q->right->x;
7890 q->right->anc = q->anc;
7891 if (q->anc->left == q)
7892 q->anc->left = q->right;
7893 else
7894 q->anc->right = q->right;
7895 }
7896 else
7897 {
7898 if (q->anc->anc != NULL)
7899 brlens[j--] = q->length;
7900 else
7901 brlens[j--] = q->left->length;
7902 order[numTaxa-3-i] = q->left->x;
7903 q->left->anc = q->anc;
7904 if (q->anc->left == q)
7905 q->anc->left = q->left;
7906 else
7907 q->anc->right = q->left;
7908 }
7909 }
7910
7911 /* store the final two branch lengths in the right order; they have indices 0 and 1 */
7912 p = t->root->left;
7913 brlens[p->left->index] = p->left->length;
7914 brlens[p->right->index] = p->right->length;
7915
7916 return (NO_ERROR);
7917 }
7918
7919
7920 /*-------------------------------------------------------
7921 |
7922 | StoreRTreeWithIndices: This routine will break a rooted
7923 | tree into an array of ints describing the structure
7924 | of the tree and the interior node indices, and an array
7925 | of doubles storing the branch lengths. The tree will be
7926 | destroyed in the process (the node pointers,
7927 | that is). However, the tree is not deleted.
7928 |
7929 --------------------------------------------------------*/
StoreRTreeWithIndices(Tree * t,int * order,MrBFlt * brlens)7930 int StoreRTreeWithIndices (Tree *t, int *order, MrBFlt *brlens)
7931 {
7932 int i, j, k, numTaxa;
7933 TreeNode *p, *q;
7934
7935 extern void ShowNodes (TreeNode *p, int indent, int isRooted);
7936
7937 /* find number of taxa */
7938 numTaxa = t->nNodes - t->nIntNodes - 1;
7939
7940 /* first get the terminal taxon positions and store
7941 them in the order array. */
7942 for (i=0; i<t->nNodes; i++)
7943 {
7944 p = t->allDownPass[i];
7945 /* we do not need to worry about the first two taxa */
7946 if (p->index > 1 && p->index < numTaxa)
7947 order[p->index-2] = i;
7948 }
7949
7950 /* label the interior nodes with the correct index */
7951 for (i=0; i<t->nNodes; i++)
7952 {
7953 p = t->allDownPass[i];
7954 if (p->left == NULL)
7955 p->x = p->y = p->index;
7956 else if (p->right != NULL)
7957 {
7958 if (p->left->y < p->right->y)
7959 {
7960 p->y = p->left->y;
7961 p->x = p->right->y + numTaxa - 1;
7962 }
7963 else
7964 {
7965 p->y = p->right->y;
7966 p->x = p->left->y + numTaxa - 1;
7967 }
7968 }
7969 }
7970
7971 /* break the tree into pieces */
7972 j = 2 * numTaxa - 3;
7973 k = 2*(numTaxa - 2);
7974 for (i=0; i<numTaxa-2; i++)
7975 {
7976 /* find the next node to remove */
7977 p = t->allDownPass[order[numTaxa-3-i]];
7978 q = p->anc;
7979 brlens[j--] = p->length;
7980 if (q->left == p)
7981 {
7982 if (q->anc->anc != NULL)
7983 brlens[j--] = q->length;
7984 else
7985 brlens[j--] = q->right->length;
7986 order[k--] = q->right->x;
7987 order[k--] = q->index;
7988 q->right->anc = q->anc;
7989 if (q->anc->left == q)
7990 q->anc->left = q->right;
7991 else
7992 q->anc->right = q->right;
7993 }
7994 else
7995 {
7996 if (q->anc->anc != NULL)
7997 brlens[j--] = q->length;
7998 else
7999 brlens[j--] = q->left->length;
8000 order[k--] = q->left->x;
8001 order[k--] = q->index;
8002 q->left->anc = q->anc;
8003 if (q->anc->left == q)
8004 q->anc->left = q->left;
8005 else
8006 q->anc->right = q->left;
8007 }
8008 }
8009
8010 /* store the final two branch lengths in the right order; they have indices 0 and 1 */
8011 p = t->root->left;
8012 order[k] = p->index;
8013 brlens[p->left->index] = p->left->length;
8014 brlens[p->right->index] = p->right->length;
8015
8016 return (NO_ERROR);
8017 }
8018
8019
8020 /*-------------------------------------------------------
8021 |
8022 | StoreUPolyTopology: Same as StoreUTopology but for
8023 | binary polytree source.
8024 |
8025 --------------------------------------------------------*/
StoreUPolyTopology(PolyTree * t,int * order)8026 int StoreUPolyTopology (PolyTree *t, int *order)
8027 {
8028 int i, numTips;
8029 PolyNode *p, *q;
8030
8031 /* check if the tree is rooted on taxon 0 */
8032 if (t->root->left->sib->sib->index != 0)
8033 MovePolyCalculationRoot (t, 0);
8034
8035 /* rearrange the root */
8036 t->root->anc = t->root->left->sib->sib;
8037 t->root->left->sib->sib = NULL;
8038 t->root->anc->left = t->root;
8039 t->root->anc->sib = NULL;
8040 t->root->anc->anc = NULL;
8041 t->root = t->root->anc;
8042
8043 /* find number of tips */
8044 numTips = t->nNodes - t->nIntNodes;
8045
8046 /* first get the terminal taxon positions and store
8047 them in the order array. */
8048 for (i=0; i<t->nNodes; i++)
8049 {
8050 p = t->allDownPass[i];
8051 /* we do not need to worry about the first three taxa */
8052 if (p->index > 2 && p->index < numTips)
8053 order[p->index-3] = i;
8054 }
8055
8056 /* label the interior nodes with the correct index */
8057 for (i=0; i<t->nNodes; i++)
8058 {
8059 p = t->allDownPass[i];
8060 if (p->left == NULL || p->anc == NULL)
8061 p->x = p->y = p->index;
8062 else
8063 {
8064 if (p->left->y < p->left->sib->y)
8065 {
8066 p->y = p->left->y;
8067 p->x = p->left->sib->y + numTips - 2;
8068 }
8069 else
8070 {
8071 p->y = p->left->sib->y;
8072 p->x = p->left->y + numTips - 2;
8073 }
8074 }
8075 }
8076
8077 /* break the tree into pieces */
8078 for (i=0; i<numTips-3; i++)
8079 {
8080 /* find the next node to remove */
8081 p = t->allDownPass[order[numTips-4-i]];
8082 q = p->anc;
8083 if (q->left == p)
8084 {
8085 order[numTips-4-i] = q->left->sib->x;
8086 p->sib->anc = q->anc;
8087 if (q->anc->left == q)
8088 {
8089 q->anc->left = p->sib;
8090 p->sib->sib = q->sib;
8091 }
8092 else
8093 {
8094 q->anc->left->sib = p->sib;
8095 p->sib->sib = q->sib;
8096 }
8097 }
8098 else
8099 {
8100 order[numTips-4-i] = q->left->x;
8101 q->left->anc = q->anc;
8102 if (q->anc->left == q)
8103 {
8104 q->anc->left = q->left;
8105 q->left->sib = q->sib;
8106 }
8107 else
8108 {
8109 q->anc->left->sib = q->left;
8110 q->left->sib = q->sib;
8111 }
8112 }
8113 }
8114
8115 return (NO_ERROR);
8116 }
8117
8118
8119 /*-------------------------------------------------------
8120 |
8121 | StoreUPolyTree: Same as StoreUTopology but for
8122 | binary polytree source.
8123 |
8124 --------------------------------------------------------*/
StoreUPolyTree(PolyTree * t,int * order,MrBFlt * brlens)8125 int StoreUPolyTree (PolyTree *t, int *order, MrBFlt *brlens)
8126 {
8127 int i, j, numTips;
8128 PolyNode *p, *q;
8129
8130 /* check if the tree is rooted on taxon 0 */
8131 if (t->root->left->sib->sib->index != 0)
8132 MovePolyCalculationRoot (t, 0);
8133
8134 /* rearrange the root */
8135 t->root->anc = t->root->left->sib->sib;
8136 t->root->left->sib->sib = NULL;
8137 t->root->anc->left = t->root;
8138 t->root->anc->sib = NULL;
8139 t->root->anc->anc = NULL;
8140 t->root = t->root->anc;
8141
8142 /* find number of tips */
8143 numTips = t->nNodes - t->nIntNodes;
8144
8145 /* first get the terminal taxon positions and store
8146 them in the order array. */
8147 for (i=0; i<t->nNodes; i++)
8148 {
8149 p = t->allDownPass[i];
8150 /* we do not need to worry about the first three taxa */
8151 if (p->index > 2 && p->index < numTips)
8152 order[p->index-3] = i;
8153 }
8154
8155 /* label the interior nodes with the correct index */
8156 for (i=0; i<t->nNodes; i++)
8157 {
8158 p = t->allDownPass[i];
8159 if (p->left == NULL || p->anc == NULL)
8160 p->x = p->y = p->index;
8161 else
8162 {
8163 if (p->left->y < p->left->sib->y)
8164 {
8165 p->y = p->left->y;
8166 p->x = p->left->sib->y + numTips - 2;
8167 }
8168 else
8169 {
8170 p->y = p->left->sib->y;
8171 p->x = p->left->y + numTips - 2;
8172 }
8173 }
8174 }
8175
8176 /* break the tree into pieces */
8177 j = 2*numTips - 4;
8178 for (i=0; i<numTips-3; i++)
8179 {
8180 /* find the next node to remove */
8181 p = t->allDownPass[order[numTips-4-i]];
8182 assert (p->index > 2 && p->index < numTips);
8183 assert (p->anc->anc != NULL);
8184 q = p->anc;
8185 brlens[j--] = p->length;
8186 brlens[j--] = q->length;
8187 if (q->left == p)
8188 {
8189 order[numTips-4-i] = q->left->sib->x;
8190 p->sib->anc = q->anc;
8191 if (q->anc->left == q)
8192 {
8193 q->anc->left = p->sib;
8194 p->sib->sib = q->sib;
8195 }
8196 else
8197 {
8198 q->anc->left->sib = p->sib;
8199 p->sib->sib = q->sib;
8200 }
8201 }
8202 else
8203 {
8204 order[numTips-4-i] = q->left->x;
8205 q->left->anc = q->anc;
8206 if (q->anc->left == q)
8207 {
8208 q->anc->left = q->left;
8209 q->left->sib = q->sib;
8210 }
8211 else
8212 {
8213 q->anc->left->sib = q->left;
8214 q->left->sib = q->sib;
8215 }
8216 }
8217 }
8218
8219 /* store last three branch lengths, index 0, 1, 2 */
8220 q = t->root;
8221 assert (q->index == 0);
8222 brlens[q->index] = q->length;
8223 q = q->left->left;
8224 assert (q->index == 1 || q->index == 2);
8225 brlens[q->index] = q->length;
8226 q = q->sib;
8227 assert (q->index == 1 || q->index == 2);
8228 brlens[q->index] = q->length;
8229
8230 return (NO_ERROR);
8231 }
8232
8233
8234 /*-------------------------------------------------------
8235 |
8236 | StoreUTopology: This routine will break an unrooted tree
8237 | into an array of ints describing the structure
8238 | of the tree. The tree will be destroyed
8239 | in the process (the node pointers, that is).
8240 | However, the tree is not deleted.
8241 |
8242 --------------------------------------------------------*/
StoreUTopology(Tree * t,int * order)8243 int StoreUTopology (Tree *t, int *order)
8244 {
8245 int i, numTips;
8246 TreeNode *p, *q;
8247
8248 /* check if the tree is rooted on taxon 0 */
8249 if (t->root->index != 0)
8250 MoveCalculationRoot (t, 0);
8251
8252 /* find number of tips */
8253 numTips = t->nNodes - t->nIntNodes;
8254
8255 /* first get the terminal taxon positions and store
8256 them in the order array. */
8257 for (i=0; i<t->nNodes; i++)
8258 {
8259 p = t->allDownPass[i];
8260 /* we do not need to worry about the first three taxa */
8261 if (p->index > 2 && p->index < numTips)
8262 order[p->index-3] = i;
8263 }
8264
8265 /* label the interior nodes with the correct index */
8266 for (i=0; i<t->nNodes; i++)
8267 {
8268 p = t->allDownPass[i];
8269 if (p->left == NULL)
8270 p->x = p->y = p->index;
8271 else if (p->right != NULL)
8272 {
8273 if (p->left->y < p->right->y)
8274 {
8275 p->y = p->left->y;
8276 p->x = p->right->y + numTips - 2;
8277 }
8278 else
8279 {
8280 p->y = p->right->y;
8281 p->x = p->left->y + numTips - 2;
8282 }
8283 }
8284 }
8285
8286 /* break the tree into pieces */
8287 for (i=0; i<numTips-3; i++)
8288 {
8289 /* find the next node to remove */
8290 p = t->allDownPass[order[numTips-4-i]];
8291 q = p->anc;
8292 if (q->left == p)
8293 {
8294 order[numTips-4-i] = q->right->x;
8295 q->right->anc = q->anc;
8296 if (q->anc->left == q)
8297 q->anc->left = q->right;
8298 else
8299 q->anc->right = q->right;
8300 }
8301 else
8302 {
8303 order[numTips-4-i] = q->left->x;
8304 q->left->anc = q->anc;
8305 if (q->anc->left == q)
8306 q->anc->left = q->left;
8307 else
8308 q->anc->right = q->left;
8309 }
8310 }
8311
8312 return (NO_ERROR);
8313 }
8314
8315
8316 /*-------------------------------------------------------
8317 |
8318 | StoreUTree: This routine will break an unrooted tree
8319 | into an array of ints describing the structure
8320 | of the tree and an array of doubles storing
8321 | the branch lengths. The tree will be
8322 | destroyed in the process (the node pointers,
8323 | that is). However, the tree is not deleted.
8324 |
8325 --------------------------------------------------------*/
StoreUTree(Tree * t,int * order,MrBFlt * brlens)8326 int StoreUTree (Tree *t, int *order, MrBFlt *brlens)
8327 {
8328 int i, j, numTips;
8329 TreeNode *p, *q;
8330
8331 /* check if the tree is rooted on taxon 0 */
8332 if (t->root->index != 0)
8333 MoveCalculationRoot(t, 0);
8334
8335 /* find number of tips */
8336 numTips = t->nNodes - t->nIntNodes;
8337
8338 /* first get the terminal taxon positions and store
8339 them in the order array. */
8340 for (i=0; i<t->nNodes; i++)
8341 {
8342 p = t->allDownPass[i];
8343 /* we do not need to worry about the first three taxa */
8344 if (p->index > 2 && p->index < numTips)
8345 order[p->index-3] = i;
8346 }
8347
8348 /* label the interior nodes with the correct index */
8349 for (i=0; i<t->nNodes; i++)
8350 {
8351 p = t->allDownPass[i];
8352 if (p->left == NULL)
8353 p->x = p->y = p->index;
8354 else if (p->right != NULL)
8355 {
8356 if (p->left->y < p->right->y)
8357 {
8358 p->y = p->left->y;
8359 p->x = p->right->y + numTips - 2;
8360 }
8361 else
8362 {
8363 p->y = p->right->y;
8364 p->x = p->left->y + numTips - 2;
8365 }
8366 }
8367 }
8368
8369 /* break the tree into pieces */
8370 j = 2 * numTips - 4;
8371 for (i=0; i<numTips-3; i++)
8372 {
8373 /* find the next node to remove */
8374 p = t->allDownPass[order[numTips-4-i]];
8375 q = p->anc;
8376 brlens[j--] = p->length;
8377 brlens[j--] = q->length;
8378 if (q->left == p)
8379 {
8380 order[numTips-4-i] = q->right->x;
8381 q->right->anc = q->anc;
8382 if (q->anc->left == q)
8383 q->anc->left = q->right;
8384 else
8385 q->anc->right = q->right;
8386 }
8387 else
8388 {
8389 order[numTips-4-i] = q->left->x;
8390 q->left->anc = q->anc;
8391 if (q->anc->left == q)
8392 q->anc->left = q->left;
8393 else
8394 q->anc->right = q->left;
8395 }
8396 }
8397
8398 /* store the final three branch lengths */
8399 /* we need to check the rotation of the tree to
8400 store the brlens in the right order (after node index) */
8401 p = t->root->left;
8402 if (p->right->index == 2)
8403 {
8404 brlens[j--] = p->right->length;
8405 brlens[j--] = p->left->length;
8406 }
8407 else
8408 {
8409 brlens[j--] = p->left->length;
8410 brlens[j--] = p->right->length;
8411 }
8412 brlens[j--] = p->length;
8413
8414 return (NO_ERROR);
8415 }
8416
8417
8418 /* TreeLength: Calculate tree length */
TreeLen(Tree * t)8419 MrBFlt TreeLen (Tree *t)
8420 {
8421 int i, numLenNodes;
8422 MrBFlt len = 0.0;
8423
8424 if (t->isRooted == NO)
8425 numLenNodes = t->nNodes - 1;
8426 else
8427 numLenNodes = t->nNodes - 2;
8428
8429 for (i=0; i<numLenNodes; i++)
8430 len += t->allDownPass[i]->length;
8431
8432 return len;
8433 }
8434
8435
8436 /*-------------------------------------------------------------------------------------------
8437 |
8438 | Unmark: This routine will unmark a subtree rooted at p
8439 |
8440 ---------------------------------------------------------------------------------------------*/
Unmark(TreeNode * p)8441 void Unmark (TreeNode *p)
8442 {
8443 if (p != NULL)
8444 {
8445 p->marked = NO;
8446 Unmark (p->left);
8447 Unmark (p->right);
8448 }
8449 }
8450
8451
WriteEventTree(TreeNode * p,int chain,Param * param)8452 void WriteEventTree (TreeNode *p, int chain, Param *param)
8453 {
8454 int j, nEvents;
8455 MrBFlt brlen, *position, *rateMult;
8456
8457 if (p != NULL)
8458 {
8459 if (p->left == NULL && p->right == NULL)
8460 {
8461 printf ("%d:%s", p->index + 1, MbPrintNum(p->length));
8462 if (param->paramType == P_CPPEVENTS)
8463 {
8464 nEvents = param->nEvents[2*chain+state[chain]][p->index];
8465 if (nEvents > 0)
8466 {
8467 printf ("[&E %s %d: (", param->name, nEvents);
8468 position = param->position[2*chain+state[chain]][p->index];
8469 rateMult = param->rateMult[2*chain+state[chain]][p->index];
8470 for (j=0; j<nEvents; j++)
8471 {
8472 printf ("%s ", MbPrintNum(position[j]));
8473 printf ("%s", MbPrintNum(rateMult[j]));
8474 if (j != nEvents-1)
8475 printf (", ");
8476 }
8477 printf (")]");
8478 }
8479 else
8480 printf ("[&E %s 0]", param->name);
8481 }
8482 brlen = GetParamSubVals (param, chain, state[chain])[p->index];
8483 // brlen = (GetParamSubVals (param, chain, state[chain])[p->index] + GetParamVals (param, chain, state[chain])[p->anc->index]) / 2.0;
8484 printf ("[&B %s %s]", param->name, MbPrintNum(brlen));
8485 }
8486 else
8487 {
8488 if (p->anc != NULL)
8489 printf ("(");
8490 WriteEventTree(p->left, chain, param);
8491 printf (",");
8492 WriteEventTree(p->right, chain, param);
8493 if (p->anc != NULL)
8494 {
8495 if (p->anc->anc != NULL)
8496 {
8497 printf ("):%s", MbPrintNum(p->length));
8498 if (param->paramType == P_CPPEVENTS)
8499 {
8500 nEvents = param->nEvents[2*chain+state[chain]][p->index];
8501 if (nEvents > 0)
8502 {
8503 printf ("[&E %s %d: (", param->name, nEvents);
8504 position = param->position[2*chain+state[chain]][p->index];
8505 rateMult = param->rateMult[2*chain+state[chain]][p->index];
8506 for (j=0; j<nEvents; j++)
8507 {
8508 printf ("%s %s", MbPrintNum(position[j]), MbPrintNum(rateMult[j]));
8509 if (j != nEvents-1)
8510 printf (", ");
8511 }
8512 printf (")]");
8513 }
8514 else
8515 printf ("[&E %s 0]", param->name);
8516 }
8517 brlen = GetParamSubVals (param, chain, state[chain])[p->index];
8518 // brlen = (GetParamSubVals (param, chain, state[chain])[p->index] + GetParamVals (param, chain, state[chain])[p->anc->index]) / 2.0;
8519 printf ("[&B %s %s]", param->name, MbPrintNum(brlen));
8520 }
8521 else
8522 printf (")");
8523 }
8524 }
8525 }
8526 }
8527
8528
WriteEventTreeToPrintString(TreeNode * p,int chain,Param * param,int printAll)8529 void WriteEventTreeToPrintString (TreeNode *p, int chain, Param *param, int printAll)
8530 {
8531 char *tempStr;
8532 int i, j, nEvents, tempStrSize = TEMPSTRSIZE;
8533 MrBFlt brlen, *position, *rateMult;
8534
8535 tempStr = (char *) SafeMalloc((size_t)tempStrSize * sizeof(char));
8536 if (!tempStr)
8537 MrBayesPrint ("%s Problem allocating tempString (%d)\n", spacer, tempStrSize * sizeof(char));
8538
8539 if (p != NULL)
8540 {
8541 if (p->left == NULL && p->right == NULL)
8542 {
8543 SafeSprintf (&tempStr, &tempStrSize, "%d:%s", p->index + 1, MbPrintNum(p->length));
8544 AddToPrintString (tempStr);
8545 for (i=0; i<param->nSubParams; i++)
8546 {
8547 if (param->subParams[i]->paramType == P_CPPEVENTS)
8548 {
8549 nEvents = param->subParams[i]->nEvents[2*chain+state[chain]][p->index];
8550 if (nEvents > 0)
8551 {
8552 SafeSprintf (&tempStr, &tempStrSize, "[&E %s %d", param->subParams[i]->name, nEvents);
8553 AddToPrintString (tempStr);
8554 position = param->subParams[i]->position[2*chain+state[chain]][p->index];
8555 rateMult = param->subParams[i]->rateMult[2*chain+state[chain]][p->index];
8556 if (printAll == YES)
8557 {
8558 SafeSprintf (&tempStr, &tempStrSize, ": (");
8559 AddToPrintString (tempStr);
8560 for (j=0; j<nEvents; j++)
8561 {
8562 SafeSprintf (&tempStr, &tempStrSize, "%s", MbPrintNum(position[j]));
8563 AddToPrintString (tempStr);
8564 SafeSprintf (&tempStr, &tempStrSize, " %s", MbPrintNum(rateMult[j]));
8565 AddToPrintString (tempStr);
8566 if (j != nEvents-1)
8567 AddToPrintString (",");
8568 else
8569 AddToPrintString (")");
8570 }
8571 }
8572 AddToPrintString ("]");
8573 }
8574 else
8575 {
8576 SafeSprintf (&tempStr, &tempStrSize, "[&E %s 0]", param->subParams[i]->name);
8577 AddToPrintString (tempStr);
8578 }
8579 }
8580 else if (param->subParams[i]->paramType != P_CPPEVENTS)
8581 {
8582 /* other relaxed clock models */
8583 brlen = GetParamSubVals (param->subParams[i], chain, state[chain])[p->index];
8584 SafeSprintf (&tempStr, &tempStrSize, "[&B %s %s]", param->subParams[i]->name, MbPrintNum(brlen));
8585 AddToPrintString (tempStr);
8586 }
8587 }
8588 }
8589 else
8590 {
8591 if (p->anc != NULL)
8592 AddToPrintString ("(");
8593 WriteEventTreeToPrintString (p->left, chain, param, printAll);
8594 AddToPrintString (",");
8595 WriteEventTreeToPrintString (p->right, chain, param, printAll);
8596 if (p->anc != NULL)
8597 {
8598 if (p->anc->anc != NULL)
8599 {
8600 SafeSprintf (&tempStr, &tempStrSize, "):%s", MbPrintNum(p->length));
8601 AddToPrintString (tempStr);
8602 for (i=0; i<param->nSubParams; i++)
8603 {
8604 if (param->subParams[i]->paramType == P_CPPEVENTS)
8605 {
8606 nEvents = param->subParams[i]->nEvents[2*chain+state[chain]][p->index];
8607 if (nEvents > 0)
8608 {
8609 SafeSprintf (&tempStr, &tempStrSize, "[&E %s %d", param->subParams[i]->name, nEvents);
8610 AddToPrintString (tempStr);
8611 position = param->subParams[i]->position[2*chain+state[chain]][p->index];
8612 rateMult = param->subParams[i]->rateMult[2*chain+state[chain]][p->index];
8613 if (printAll == YES)
8614 {
8615 SafeSprintf (&tempStr, &tempStrSize, ": (");
8616 AddToPrintString (tempStr);
8617 for (j=0; j<nEvents; j++)
8618 {
8619 SafeSprintf (&tempStr, &tempStrSize, "%s", MbPrintNum(position[j]));
8620 AddToPrintString (tempStr);
8621 SafeSprintf (&tempStr, &tempStrSize, " %s", MbPrintNum(rateMult[j]));
8622 AddToPrintString (tempStr);
8623 if (j != nEvents-1)
8624 AddToPrintString (",");
8625 else
8626 AddToPrintString (")");
8627 }
8628 }
8629 AddToPrintString ("]");
8630 }
8631 else
8632 {
8633 SafeSprintf (&tempStr, &tempStrSize, "[&E %s 0]", param->subParams[i]->name);
8634 AddToPrintString (tempStr);
8635 }
8636 }
8637 else if (param->subParams[i]->paramType != P_CPPEVENTS)
8638 {
8639 /* other relaxed clock models */
8640 brlen = GetParamSubVals (param->subParams[i], chain, state[chain])[p->index];
8641 SafeSprintf (&tempStr, &tempStrSize, "[&B %s %s]", param->subParams[i]->name, MbPrintNum(brlen));
8642 AddToPrintString (tempStr);
8643 }
8644 }
8645 }
8646 else
8647 AddToPrintString(")");
8648 }
8649 }
8650 }
8651 free (tempStr);
8652 }
8653
8654
WriteEvolTree(TreeNode * p,int chain,Param * param)8655 void WriteEvolTree (TreeNode *p, int chain, Param *param)
8656 {
8657 MrBFlt *length;
8658
8659 if (p != NULL)
8660 {
8661 length = GetParamSubVals(param, chain, state[chain]);
8662 if (p->left == NULL && p->right == NULL)
8663 {
8664 printf ("%d:%s", p->index + 1, MbPrintNum(length[p->index]));
8665 }
8666 else
8667 {
8668 if (p->anc != NULL)
8669 printf ("(");
8670 WriteEvolTree(p->left, chain, param);
8671 printf (",");
8672 WriteEvolTree(p->right, chain, param);
8673 if (p->anc != NULL)
8674 {
8675 if (p->anc->anc != NULL)
8676 printf ("):%s", MbPrintNum(length[p->index]));
8677 else
8678 printf (")");
8679 }
8680 }
8681 }
8682 }
8683
8684
WriteNoEvtTreeToPrintString(TreeNode * p,int chain,Param * param,int showBrlens,int isRooted)8685 void WriteNoEvtTreeToPrintString (TreeNode *p, int chain, Param *param, int showBrlens, int isRooted)
8686 {
8687 char *tempStr;
8688 int i, tempStrSize = TEMPSTRSIZE, nEvents;
8689 MrBFlt brlen, N;
8690
8691 tempStr = (char *) SafeMalloc((size_t)tempStrSize * sizeof(char));
8692 if (!tempStr)
8693 MrBayesPrint ("%s Problem allocating tempString (%d)\n", spacer, tempStrSize * sizeof(char));
8694
8695 if (p != NULL)
8696 {
8697 if (p->left == NULL && p->right == NULL)
8698 {
8699 if (showBrlens == YES)
8700 {
8701 SafeSprintf (&tempStr, &tempStrSize, "%d:%s", p->index + 1, MbPrintNum(p->length));
8702 }
8703 else
8704 SafeSprintf (&tempStr, &tempStrSize, "%d", p->index + 1);
8705 AddToPrintString (tempStr);
8706 if (param->paramType == P_BRLENS)
8707 {
8708 for (i=0; i<param->nSubParams; i++)
8709 {
8710 if (param->subParams[i]->paramType == P_CPPEVENTS)
8711 {
8712 nEvents = param->subParams[i]->nEvents[2*chain+state[chain]][p->index];
8713 SafeSprintf (&tempStr, &tempStrSize, "[&E %s %d]", param->subParams[i]->name, nEvents);
8714 AddToPrintString (tempStr);
8715 }
8716 brlen = GetParamSubVals (param->subParams[i], chain, state[chain])[p->index];
8717 SafeSprintf (&tempStr, &tempStrSize, "[&B %s %s]", param->subParams[i]->name, MbPrintNum(brlen));
8718 AddToPrintString (tempStr);
8719 }
8720 }
8721 else if (param->paramType == P_SPECIESTREE && modelSettings[param->relParts[0]].popSize->nValues > 1)
8722 {
8723 N = GetParamVals (modelSettings[param->relParts[0]].popSize, chain, state[chain])[p->index];
8724 SafeSprintf (&tempStr, &tempStrSize, "[&N %s %s]", modelSettings[param->relParts[0]].popSize->name, MbPrintNum(N));
8725 AddToPrintString (tempStr);
8726 }
8727 }
8728 else
8729 {
8730 if (p->anc != NULL)
8731 AddToPrintString ("(");
8732 WriteNoEvtTreeToPrintString (p->left, chain, param, showBrlens, isRooted);
8733 if (p->anc != NULL)
8734 AddToPrintString (",");
8735 WriteNoEvtTreeToPrintString (p->right, chain, param, showBrlens, isRooted);
8736 if (p->anc != NULL)
8737 {
8738 if (p->anc->anc == NULL && isRooted == NO)
8739 {
8740 if (showBrlens == YES)
8741 SafeSprintf (&tempStr, &tempStrSize, ",%d:%s)", p->anc->index + 1, MbPrintNum(p->length));
8742 else
8743 SafeSprintf (&tempStr, &tempStrSize, ",%d)", p->anc->index + 1);
8744 AddToPrintString (tempStr);
8745 }
8746 else if (p->anc->anc != NULL)
8747 {
8748 if (showBrlens == YES)
8749 SafeSprintf (&tempStr, &tempStrSize, "):%s", MbPrintNum(p->length));
8750 else
8751 SafeSprintf (&tempStr, &tempStrSize, ")");
8752 AddToPrintString (tempStr);
8753 if (param->paramType == P_BRLENS)
8754 {
8755 for (i=0; i<param->nSubParams; i++)
8756 {
8757 if (param->subParams[i]->paramType == P_CPPEVENTS)
8758 {
8759 nEvents = param->subParams[i]->nEvents[2*chain+state[chain]][p->index];
8760 SafeSprintf (&tempStr, &tempStrSize, "[&E %s %d]", param->subParams[i]->name, nEvents);
8761 AddToPrintString (tempStr);
8762 }
8763 brlen = GetParamSubVals (param->subParams[i], chain, state[chain])[p->index];
8764 SafeSprintf (&tempStr, &tempStrSize, "[&B %s %s]", param->subParams[i]->name, MbPrintNum(brlen));
8765 AddToPrintString (tempStr);
8766 }
8767 }
8768 else if (param->paramType == P_SPECIESTREE && modelSettings[param->relParts[0]].popSize->nValues > 1)
8769 {
8770 N = GetParamVals (modelSettings[param->relParts[0]].popSize, chain, state[chain])[p->index];
8771 SafeSprintf (&tempStr, &tempStrSize, "[&N %s %s]", modelSettings[param->relParts[0]].popSize->name, MbPrintNum(N));
8772 AddToPrintString (tempStr);
8773 }
8774 }
8775 else if (param->paramType == P_SPECIESTREE && modelSettings[param->relParts[0]].popSize->nValues > 1)
8776 {
8777 N = GetParamVals (modelSettings[param->relParts[0]].popSize, chain, state[chain])[p->index];
8778 SafeSprintf (&tempStr, &tempStrSize, ")[&N %s %s]", modelSettings[param->relParts[0]].popSize->name, MbPrintNum(N));
8779 AddToPrintString (tempStr);
8780 }
8781 else
8782 AddToPrintString(")");
8783 }
8784 }
8785 }
8786 free (tempStr);
8787 }
8788
8789
8790 /* WriteTopologyToFile: Simply write topology to file */
WriteTopologyToFile(FILE * fp,TreeNode * p,int isRooted)8791 void WriteTopologyToFile (FILE *fp, TreeNode *p, int isRooted)
8792 {
8793 if (p != NULL)
8794 {
8795 if (p->left == NULL && p->right == NULL)
8796 fprintf (fp, "%d", p->index + 1);
8797 else
8798 {
8799 if (p->anc != NULL)
8800 fprintf (fp, "(");
8801 WriteTopologyToFile (fp, p->left, isRooted);
8802 if (p->anc != NULL)
8803 fprintf (fp, ",");
8804 WriteTopologyToFile (fp, p->right, isRooted);
8805 if (p->anc != NULL)
8806 {
8807 if (p->anc->anc == NULL && isRooted == NO)
8808 fprintf (fp, ",%d", p->anc->index + 1);
8809 fprintf (fp, ")");
8810 }
8811 }
8812 }
8813 }
8814
8815
8816 /* the following are moved from mbmath.c */
8817 /*---------------------------------------------------------------------------------
8818 |
8819 | AddTwoMatrices
8820 |
8821 | Takes the sum of two matrices, "a" and "b", and puts the results in a matrix
8822 | called "result".
8823 |
8824 ---------------------------------------------------------------------------------*/
AddTwoMatrices(int dim,MrBFlt ** a,MrBFlt ** b,MrBFlt ** result)8825 void AddTwoMatrices (int dim, MrBFlt **a, MrBFlt **b, MrBFlt **result)
8826 {
8827 int row, col;
8828
8829 for (row=0; row<dim; row++)
8830 {
8831 for (col=0; col<dim; col++)
8832 {
8833 result[row][col] = a[row][col] + b[row][col];
8834 }
8835 }
8836 }
8837
8838
8839 /*---------------------------------------------------------------------------------
8840 |
8841 | AllocateSquareComplexMatrix
8842 |
8843 | Allocate memory for a square (dim X dim) complex matrix.
8844 |
8845 ---------------------------------------------------------------------------------*/
AllocateSquareComplexMatrix(int dim)8846 MrBComplex **AllocateSquareComplexMatrix (int dim)
8847 {
8848 int i;
8849 MrBComplex **m;
8850
8851 m = (MrBComplex **) SafeMalloc ((size_t)dim * sizeof(MrBComplex*));
8852 if (!m)
8853 {
8854 MrBayesPrint ("%s Error: Problem allocating a square complex matrix.\n", spacer);
8855 exit (0);
8856 }
8857 m[0]=(MrBComplex *) SafeMalloc ((size_t)dim * (size_t)dim *sizeof(MrBComplex));
8858 if (!m[0])
8859 {
8860 MrBayesPrint ("%s Error: Problem allocating a square complex matrix.\n", spacer);
8861 exit (0);
8862 }
8863 for (i=1;i<dim;i++)
8864 {
8865 m[i] = m[i-1] + dim;
8866 }
8867
8868 return (m);
8869 }
8870
8871
8872 /*---------------------------------------------------------------------------------
8873 |
8874 | AllocateSquareDoubleMatrix
8875 |
8876 | Allocate memory for a square (dim X dim) matrix of doubles.
8877 |
8878 ---------------------------------------------------------------------------------*/
AllocateSquareDoubleMatrix(int dim)8879 MrBFlt **AllocateSquareDoubleMatrix (int dim)
8880 {
8881 int i;
8882 MrBFlt **m;
8883
8884 m = (MrBFlt **) SafeMalloc ((size_t)dim * sizeof(MrBFlt*));
8885 if (!m)
8886 {
8887 MrBayesPrint ("%s Error: Problem allocating a square matrix of doubles.\n", spacer);
8888 exit(1);
8889 }
8890 m[0] = (MrBFlt *) SafeMalloc ((size_t)dim * (size_t)dim * sizeof(MrBFlt));
8891 if (!m[0])
8892 {
8893 MrBayesPrint ("%s Error: Problem allocating a square matrix of doubles.\n", spacer);
8894 exit(1);
8895 }
8896 for (i=1; i<dim; i++)
8897 {
8898 m[i] = m[i-1] + dim;
8899 }
8900
8901 return (m);
8902 }
8903
8904
8905 /*---------------------------------------------------------------------------------
8906 |
8907 | AllocateSquareIntegerMatrix
8908 |
8909 | Allocate memory for a square (dim X dim) matrix of integers.
8910 |
8911 ---------------------------------------------------------------------------------*/
AllocateSquareIntegerMatrix(int dim)8912 int **AllocateSquareIntegerMatrix (int dim)
8913 {
8914 int i, **m;
8915
8916 m = (int **) SafeMalloc ((size_t)dim * sizeof(int*));
8917 if (!m)
8918 {
8919 MrBayesPrint ("%s Error: Problem allocating a square matrix of integers.\n", spacer);
8920 exit(1);
8921 }
8922 m[0] = (int *) SafeMalloc ((size_t)dim * (size_t)dim * sizeof(int));
8923 if (!m[0])
8924 {
8925 MrBayesPrint ("%s Error: Problem allocating a square matrix of integers.\n", spacer);
8926 exit(1);
8927 }
8928 for (i=1; i<dim; i++)
8929 {
8930 m[i] = m[i-1] + dim;
8931 }
8932
8933 return (m);
8934 }
8935
8936
8937 /*---------------------------------------------------------------------------------
8938 |
8939 | AutodGamma
8940 |
8941 | Auto-discrete-gamma distribution of rates over sites, K equal-probable
8942 | categories, with the mean for each category used.
8943 | This routine calculates M[], using rho and K (numGammaCats)
8944 |
8945 ---------------------------------------------------------------------------------*/
AutodGamma(MrBFlt * M,MrBFlt rho,int K)8946 int AutodGamma (MrBFlt *M, MrBFlt rho, int K)
8947 {
8948 int i, j, i1, i2;
8949 MrBFlt point[MAX_RATE_CATS], x, y, large = 20.0, sum;
8950
8951 for (i=0; i<K-1; i++)
8952 point[i] = PointNormal ((i + 1.0) / K);
8953 for (i=0; i<K; i++)
8954 {
8955 for (j=0; j<K; j++)
8956 {
8957 x = (i < K-1 ? point[i]:large);
8958 y = (j < K-1 ? point[j]:large);
8959 M[i * K + j] = CdfBinormal (x, y, rho);
8960 }
8961 }
8962 for (i1=0; i1<2*K-1; i1++)
8963 {
8964 for (i2=0; i2<K*K; i2++)
8965 {
8966 i = i2 / K;
8967 j = i2 % K;
8968 if (AreDoublesEqual(i+j, 2*(K-1.0)-i1, ETA)==NO)
8969 continue;
8970 y = 0;
8971 if (i > 0)
8972 y -= M[(i-1)*K+j];
8973 if (j > 0)
8974 y -= M[i*K+(j-1)];
8975 if (i > 0 && j > 0)
8976 y += M[(i-1)*K+(j-1)];
8977 M[i*K+j] = (M[i*K+j] + y) * K;
8978 }
8979 }
8980 for (i=0; i<K; i++)
8981 {
8982 sum = 0.0;
8983 for (j=0; j<K; j++)
8984 {
8985 if (M[i*K+j] < 0.0)
8986 M[i*K+j] = 0.0;
8987 sum += M[i*K+j];
8988 }
8989 for (j=0; j<K; j++)
8990 M[i*K+j] /= sum;
8991 }
8992
8993 // MrBayesPrint ("rho = %lf\n", rho);
8994 // for (i=0; i<K; i++)
8995 // {
8996 // for (j=0; j<K; j++)
8997 // MrBayesPrint ("%lf ", M[i*K + j]);
8998 // MrBayesPrint ("\n");
8999 // }
9000
9001 return (NO_ERROR);
9002 }
9003
9004
9005 /*---------------------------------------------------------------------------------
9006 |
9007 | BackSubstitutionRow
9008 |
9009 ---------------------------------------------------------------------------------*/
BackSubstitutionRow(int dim,MrBFlt ** u,MrBFlt * b)9010 void BackSubstitutionRow (int dim, MrBFlt **u, MrBFlt *b)
9011 {
9012 int i, j;
9013 MrBFlt dotProduct;
9014
9015 b[dim-1] /= u[dim-1][dim-1];
9016 for (i=dim-2; i>=0; i--)
9017 {
9018 dotProduct = 0.0;
9019 for (j=i+1; j<dim; j++)
9020 dotProduct += u[i][j] * b[j];
9021 b[i] = (b[i] - dotProduct) / u[i][i];
9022 }
9023 }
9024
9025
9026 /*---------------------------------------------------------------------------------
9027 |
9028 | Balanc
9029 |
9030 | This subroutine balances a real matrix and isolates
9031 | eigenvalues whenever possible.
9032 |
9033 | On input:
9034 |
9035 | * dim is the order of the matrix
9036 |
9037 | * a contains the input matrix to be balanced
9038 |
9039 | On output:
9040 |
9041 | * a contains the balanced matrix.
9042 |
9043 | * low and high are two integers such that a(i,j)
9044 | is equal to zero if
9045 | (1) i is greater than j and
9046 | (2) j=1,...,low-1 or i=igh+1,...,n.
9047 |
9048 | * scale contains information determining the
9049 | permutations and scaling factors used.
9050 |
9051 | Suppose that the principal submatrix in rows pLow through pHigh
9052 | has been balanced, that p(j) denotes the index interchanged
9053 | with j during the permutation step, and that the elements
9054 | of the diagonal matrix used are denoted by d(i,j). Then
9055 | scale(j) = p(j), for j = 1,...,pLow-1
9056 | = d(j,j), j = pLow,...,pHigh
9057 | = p(j) j = pHigh+1,...,dim.
9058 | The order in which the interchanges are made is dim to pHigh+1,
9059 | then 1 to pLow-1.
9060 |
9061 | Note that 1 is returned for pHigh if pHigh is zero formally.
9062 |
9063 | The algol procedure exc contained in balance appears in
9064 | balanc in line. (Note that the algol roles of identifiers
9065 | k,l have been reversed.)
9066 |
9067 | This routine is a translation of the Algol procedure from
9068 | Handbook for Automatic Computation, vol. II, Linear Algebra,
9069 | by Wilkinson and Reinsch, Springer-Verlag.
9070 |
9071 | This function was converted from FORTRAN by D. L. Swofford.
9072 |
9073 ---------------------------------------------------------------------------------*/
Balanc(int dim,MrBFlt ** a,int * low,int * high,MrBFlt * scale)9074 void Balanc (int dim, MrBFlt **a, int *low, int *high, MrBFlt *scale)
9075 {
9076 int i, j, k, l, m, noconv;
9077 MrBFlt c, f, g, r, s, b2;
9078
9079 b2 = FLT_RADIX * FLT_RADIX;
9080 k = 0;
9081 l = dim - 1;
9082
9083 for (j=l; j>=0; j--)
9084 {
9085 for (i=0; i<=l; i++)
9086 {
9087 if (i != j)
9088 {
9089 if (AreDoublesEqual(a[j][i],0.0, ETA)==NO)
9090 goto next_j1;
9091 }
9092 }
9093
9094 /* bug that DLS caught */
9095 /*m = l;
9096 Exchange(j, k, l, m, dim, a, scale);
9097 if (l < 0)
9098 goto leave;
9099 else
9100 j = --l;*/
9101 m = l;
9102 Exchange(j, k, l, m, dim, a, scale);
9103 if (--l < 0)
9104 goto leave;
9105 next_j1:
9106 ;
9107 }
9108
9109 for (j=k; j<=l; j++)
9110 {
9111 for (i=k; i<=l; i++)
9112 {
9113 if (i != j)
9114 {
9115 if (AreDoublesEqual(a[i][j], 0.0, ETA)==NO)
9116 goto next_j;
9117 }
9118 }
9119 m = k;
9120 Exchange(j, k, l, m, dim, a, scale);
9121 k++;
9122 next_j:
9123 ;
9124 }
9125
9126 for (i=k; i<=l; i++)
9127 scale[i] = 1.0;
9128
9129 do {
9130 noconv = FALSE;
9131 for (i=k; i<=l; i++)
9132 {
9133 c = 0.0;
9134 r = 0.0;
9135 for (j=k; j<=l; j++)
9136 {
9137 if (j != i)
9138 {
9139 c += fabs(a[j][i]);
9140 r += fabs(a[i][j]);
9141 }
9142 }
9143 if (AreDoublesEqual(c,0.0,ETA)==NO && AreDoublesEqual(r,0.0,ETA)==NO)
9144 {
9145 g = r / FLT_RADIX;
9146 f = 1.0;
9147 s = c + r;
9148 while (c < g)
9149 {
9150 f *= FLT_RADIX;
9151 c *= b2;
9152 }
9153 g = r * FLT_RADIX;
9154 while (c >= g)
9155 {
9156 f /= FLT_RADIX;
9157 c /= b2;
9158 }
9159 if ((c + r) / f < s * .95)
9160 {
9161 g = 1.0 / f;
9162 scale[i] *= f;
9163 noconv = TRUE;
9164 for (j=k; j<dim; j++)
9165 a[i][j] *= g;
9166 for (j=0; j<=l; j++)
9167 a[j][i] *= f;
9168 }
9169 }
9170 }
9171 }
9172 while (noconv);
9173 leave:
9174 *low = k;
9175 *high = l;
9176
9177 # if 0
9178 /* begin f2c version of code:
9179 balanc.f -- translated by f2c (version 19971204) */
9180 int balanc (int *nm, int *n, MrBFlt *a, int *low, int *igh, MrBFlt *scale)
9181
9182 {
9183
9184 /* System generated locals */
9185 int a_dim1, a_offset, i__1, i__2;
9186 MrBFlt d__1;
9187
9188 /* Local variables */
9189 static MrBFlt iexc;
9190 static MrBFlt c__, f, g;
9191 static MrBFlt i__, j, k, l, m;
9192 static MrBFlt r__, s, radix, b2;
9193 static MrBFlt jj;
9194 static logical noconv;
9195
9196 /* parameter adjustments */
9197 --scale;
9198 a_dim1 = *nm;
9199 a_offset = a_dim1 + 1;
9200 a -= a_offset;
9201
9202 /* function Body */
9203 radix = 16.0;
9204
9205 b2 = radix * radix;
9206 k = 1;
9207 l = *n;
9208 goto L100;
9209
9210 /* .......... in-line procedure for row and column exchange .......... */
9211 L20:
9212 scale[m] = (MrBFlt) j;
9213 if (j == m)
9214 goto L50;
9215
9216 i__1 = l;
9217 for (i__ = 1; i__ <= i__1; ++i__)
9218 {
9219 f = a[i__ + j * a_dim1];
9220 a[i__ + j * a_dim1] = a[i__ + m * a_dim1];
9221 a[i__ + m * a_dim1] = f;
9222 /* L30: */
9223 }
9224
9225 i__1 = *n;
9226 for (i__ = k; i__ <= i__1; ++i__)
9227 {
9228 f = a[j + i__ * a_dim1];
9229 a[j + i__ * a_dim1] = a[m + i__ * a_dim1];
9230 a[m + i__ * a_dim1] = f;
9231 /* L40: */
9232 }
9233
9234 L50:
9235 switch (iexc)
9236 {
9237 case 1:
9238 goto L80;
9239 case 2:
9240 goto L130;
9241 }
9242
9243 /* .......... search for rows isolating an eigenvalue and push them down .......... */
9244 L80:
9245 if (l == 1)
9246 goto L280;
9247 --l;
9248
9249 /* .......... for j=l step -1 until 1 do -- .......... */
9250 L100:
9251 i__1 = l;
9252 for (jj = 1; jj <= i__1; ++jj)
9253 {
9254 j = l + 1 - jj;
9255 i__2 = l;
9256 for (i__ = 1; i__ <= i__2; ++i__)
9257 {
9258 if (i__ == j)
9259 goto L110;
9260 if (a[j + i__ * a_dim1] != 0.)
9261 goto L120;
9262 L110:
9263 ;
9264 }
9265 m = l;
9266 iexc = 1;
9267 goto L20;
9268 L120:
9269 ;
9270 }
9271
9272 goto L140;
9273 /* .......... search for columns isolating an eigenvalue and push them left .......... */
9274 L130:
9275 ++k;
9276
9277 L140:
9278 i__1 = l;
9279 for (j = k; j <= i__1; ++j)
9280 {
9281 i__2 = l;
9282 for (i__ = k; i__ <= i__2; ++i__)
9283 {
9284 if (i__ == j)
9285 goto L150;
9286 if (a[i__ + j * a_dim1] != 0.)
9287 goto L170;
9288 L150:
9289 ;
9290 }
9291 m = k;
9292 iexc = 2;
9293 goto L20;
9294 L170:
9295 ;
9296 }
9297
9298 /* .......... now balance the submatrix in rows k to l .......... */
9299 i__1 = l;
9300 for (i__ = k; i__ <= i__1; ++i__)
9301 {
9302 /* L180: */
9303 scale[i__] = 1.0;
9304 }
9305 /* .......... iterative loop for norm reduction .......... */
9306 L190:
9307 noconv = FALSE;
9308
9309 i__1 = l;
9310 for (i__ = k; i__ <= i__1; ++i__)
9311 {
9312 c__ = 0.0;
9313 r__ = 0.0;
9314 i__2 = l;
9315 for (j = k; j <= i__2; ++j)
9316 {
9317 if (j == i__)
9318 goto L200;
9319 c__ += (d__1 = a[j + i__ * a_dim1], abs(d__1));
9320 r__ += (d__1 = a[i__ + j * a_dim1], abs(d__1));
9321 L200:
9322 ;
9323 }
9324
9325 /* .......... guard against zero c or r due to underflow .......... */
9326 if (c__ == 0. || r__ == 0.)
9327 goto L270;
9328 g = r__ / radix;
9329 f = 1.0;
9330 s = c__ + r__;
9331 L210:
9332 if (c__ >= g)
9333 goto L220;
9334 f *= radix;
9335 c__ *= b2;
9336 goto L210;
9337 L220:
9338 g = r__ * radix;
9339 L230:
9340 if (c__ < g)
9341 goto L240;
9342 f /= radix;
9343 c__ /= b2;
9344 goto L230;
9345
9346 /* .......... now balance .......... */
9347 L240:
9348 if ((c__ + r__) / f >= s * .95)
9349 goto L270;
9350 g = 1.0 / f;
9351 scale[i__] *= f;
9352 noconv = TRUE;
9353
9354 i__2 = *n;
9355 for (j = k; j <= i__2; ++j)
9356 {
9357 /* L250: */
9358 a[i__ + j * a_dim1] *= g;
9359 }
9360
9361 i__2 = l;
9362 for (j = 1; j <= i__2; ++j)
9363 {
9364 /* L260: */
9365 a[j + i__ * a_dim1] *= f;
9366 }
9367
9368 L270:
9369 ;
9370 }
9371
9372 if (noconv)
9373 goto L190;
9374
9375 L280:
9376 *low = k;
9377 *igh = l;
9378 return 0;
9379
9380 }
9381 /* end f2c version of code */
9382 # endif
9383
9384 }
9385
9386
9387 /*---------------------------------------------------------------------------------
9388 |
9389 | BalBak
9390 |
9391 | This subroutine forms the eigenvectors of a real general
9392 | matrix by back transforming those of the corresponding
9393 | balanced matrix determined by balance.
9394 |
9395 | On input:
9396 |
9397 | * dim is the order of the matrix
9398 |
9399 | * low and high are integers determined by balance
9400 |
9401 | * scale contains information determining the permutations
9402 | and scaling factors used by balance
9403 |
9404 | * m is the number of columns of z to be back transformed
9405 |
9406 | * z contains the real and imaginary parts of the eigen-
9407 | vectors to be back transformed in its first m columns
9408 |
9409 | On output:
9410 |
9411 | * z contains the real and imaginary parts of the
9412 | transformed eigenvectors in its first m columns
9413 |
9414 | This routine is a translation of the Algol procedure from
9415 | Handbook for Automatic Computation, vol. II, Linear Algebra,
9416 | by Wilkinson and Reinsch, Springer-Verlag.
9417 |
9418 ---------------------------------------------------------------------------------*/
BalBak(int dim,int low,int high,MrBFlt * scale,int m,MrBFlt ** z)9419 void BalBak (int dim, int low, int high, MrBFlt *scale, int m, MrBFlt **z)
9420 {
9421 int i, j, k, ii;
9422 MrBFlt s;
9423
9424 if (m != 0) /* change "==" to "!=" to eliminate a goto statement */
9425 {
9426 if (high != low) /* change "==" to "!=" to eliminate a goto statement */
9427 {
9428 for (i=low; i<=high; i++)
9429 {
9430 s = scale[i];
9431 for (j=0; j<m; j++)
9432 z[i][j] *= s;
9433 }
9434 }
9435 for (ii=0; ii<dim; ii++)
9436 {
9437 i = ii;
9438 if ((i < low) || (i > high)) /* was (i >= lo) && (i<= hi) but this */
9439 { /* eliminates a goto statement */
9440 if (i < low)
9441 i = low - ii;
9442 k = (int)scale[i];
9443 if (k != i) /* change "==" to "!=" to eliminate a goto statement */
9444 {
9445 for (j = 0; j < m; j++)
9446 {
9447 s = z[i][j];
9448 z[i][j] = z[k][j];
9449 z[k][j] = s;
9450 }
9451 }
9452 }
9453 }
9454 }
9455
9456 #if 0
9457 /* begin f2c version of code:
9458 balbak.f -- translated by f2c (version 19971204) */
9459 int balbak (int *nm, int *n, int *low, int *igh, MrBFlt *scale, int *m, MrBFlt *z__)
9460
9461 {
9462
9463 /* system generated locals */
9464 int z_dim1, z_offset, i__1, i__2;
9465
9466 /* Local variables */
9467 static int i__, j, k;
9468 static MrBFlt s;
9469 static int ii;
9470
9471 /* parameter adjustments */
9472 --scale;
9473 z_dim1 = *nm;
9474 z_offset = z_dim1 + 1;
9475 z__ -= z_offset;
9476
9477 /* function Body */
9478 if (*m == 0)
9479 goto L200;
9480 if (*igh == *low)
9481 goto L120;
9482
9483 i__1 = *igh;
9484 for (i__ = *low; i__ <= i__1; ++i__)
9485 {
9486 s = scale[i__];
9487 /* .......... left hand eigenvectors are back transformed */
9488 /* if the foregoing statement is replaced by */
9489 /* s=1.0d0/scale(i) ........... */
9490 i__2 = *m;
9491 for (j = 1; j <= i__2; ++j)
9492 {
9493 /* L100: */
9494 z__[i__ + j * z_dim1] *= s;
9495 }
9496
9497 /* L110: */
9498 }
9499
9500 /* .........for i=low-1 step -1 until 1, igh+1 step 1 until n do -- .......... */
9501 L120:
9502 i__1 = *n;
9503 for (ii = 1; ii <= i__1; ++ii)
9504 {
9505 i__ = ii;
9506 if (i__ >= *low && i__ <= *igh)
9507 goto L140;
9508 if (i__ < *low)
9509 i__ = *low - ii;
9510 k = (integer) scale[i__];
9511 if (k == i__)
9512 goto L140;
9513
9514 i__2 = *m;
9515 for (j = 1; j <= i__2; ++j)
9516 {
9517 s = z__[i__ + j * z_dim1];
9518 z__[i__ + j * z_dim1] = z__[k + j * z_dim1];
9519 z__[k + j * z_dim1] = s;
9520 /* L130: */
9521 }
9522 L140:
9523 ;
9524 }
9525
9526 L200:
9527 return 0;
9528
9529 }
9530 /* end f2c version of code */
9531 #endif
9532
9533 }
9534
9535
BetaBreaks(MrBFlt alpha,MrBFlt beta,MrBFlt * values,int K)9536 void BetaBreaks (MrBFlt alpha, MrBFlt beta, MrBFlt *values, int K)
9537 {
9538 int i;
9539 MrBFlt r, quantile, lower, upper;
9540
9541 lower = 0.0;
9542 upper = (1.0 / K);
9543 r = (upper - lower) * 0.5 + lower;
9544 for (i=0; i<K; i++)
9545 {
9546 quantile = BetaQuantile (alpha, beta, r);
9547 values[i] = quantile;
9548 lower += (1.0/K);
9549 upper += (1.0/K);
9550 r += (1.0/K);
9551 }
9552
9553 # if 0
9554 for (i=0; i<K; i++)
9555 {
9556 MrBayesPrint ("%4d %lf %lf\n", i, values[i]);
9557 }
9558 # endif
9559 }
9560
9561
BetaCf(MrBFlt a,MrBFlt b,MrBFlt x)9562 MrBFlt BetaCf (MrBFlt a, MrBFlt b, MrBFlt x)
9563 {
9564 int m, m2;
9565 MrBFlt aa, c, d, del, h, qab, qam, qap;
9566
9567 qab = a + b;
9568 qap = a + 1.0;
9569 qam = a - 1.0;
9570 c = 1.0;
9571 d = 1.0 - qab * x / qap;
9572 if (fabs(d) < (1.0e-30))
9573 d = (1.0e-30);
9574 d = 1.0 / d;
9575 h = d;
9576 for (m=1; m<=100; m++)
9577 {
9578 m2 = 2 * m;
9579 aa = m * (b-m) * x / ((qam+m2) * (a+m2));
9580 d = 1.0 + aa * d;
9581 if (fabs(d) < (1.0e-30))
9582 d = (1.0e-30);
9583 c = 1.0 + aa / c;
9584 if (fabs(c) < (1.0e-30))
9585 c = (1.0e-30);
9586 d = 1.0 / d;
9587 h *= d * c;
9588 aa = -(a+m) * (qab+m) * x / ((a+m2) * (qap+m2));
9589 d = 1.0 + aa * d;
9590 if (fabs(d) < (1.0e-30))
9591 d = (1.0e-30);
9592 c = 1.0 + aa / c;
9593 if (fabs(c) < (1.0e-30))
9594 c = (1.0e-30);
9595 d = 1.0 / d;
9596 del = d * c;
9597 h *= del;
9598 if (fabs(del - 1.0) < (3.0e-7))
9599 break;
9600 }
9601 if (m > 100)
9602 {
9603 MrBayesPrint ("%s Error in BetaCf.\n", spacer);
9604 exit(0);
9605 }
9606 return (h);
9607 }
9608
9609
BetaQuantile(MrBFlt alpha,MrBFlt beta,MrBFlt x)9610 MrBFlt BetaQuantile (MrBFlt alpha, MrBFlt beta, MrBFlt x)
9611 {
9612 int i, stopIter, direction, nswitches;
9613 MrBFlt curPos, curFraction, increment;
9614
9615 i = nswitches = 0;
9616 curPos = 0.5;
9617 stopIter = NO;
9618 increment = 0.25;
9619 curFraction = IncompleteBetaFunction (alpha, beta, curPos);
9620 if (curFraction > x)
9621 direction = DOWN;
9622 else
9623 direction = UP;
9624
9625 while (stopIter == NO)
9626 {
9627 curFraction = IncompleteBetaFunction (alpha, beta, curPos);
9628 if (curFraction > x && direction == DOWN)
9629 {
9630 /* continue going down */
9631 while (curPos - increment <= 0.0)
9632 {
9633 increment /= 2.0;
9634 }
9635 curPos -= increment;
9636 }
9637 else if (curFraction > x && direction == UP)
9638 {
9639 /* switch directions, and go down */
9640 nswitches++;
9641 direction = DOWN;
9642 while (curPos - increment <= 0.0)
9643 {
9644 increment /= 2.0;
9645 }
9646 increment /= 2.0;
9647 curPos -= increment;
9648 }
9649 else if (curFraction < x && direction == UP)
9650 {
9651 /* continue going up */
9652 while (curPos + increment >= 1.0)
9653 {
9654 increment /= 2.0;
9655 }
9656 curPos += increment;
9657 }
9658 else if (curFraction < x && direction == DOWN)
9659 {
9660 /* switch directions, and go up */
9661 nswitches++;
9662 direction = UP;
9663 while (curPos + increment >= 1.0)
9664 {
9665 increment /= 2.0;
9666 }
9667 increment /= 2.0;
9668 curPos += increment;
9669 }
9670 else
9671 {
9672 stopIter = YES;
9673 }
9674 if (i > 1000 || nswitches > 20)
9675 stopIter = YES;
9676 i++;
9677 }
9678
9679 return (curPos);
9680 }
9681
9682
9683 /*---------------------------------------------------------------------------------
9684 |
9685 | CalcCijk
9686 |
9687 | This function precalculates the product of the eigenvectors and their
9688 | inverse for faster calculation of transition probabilities. The output
9689 | is a vector of precalculated values. The input is the eigenvectors (u) and
9690 | the inverse of the eigenvector matrix (v).
9691 |
9692 ---------------------------------------------------------------------------------*/
CalcCijk(int dim,MrBFlt * c_ijk,MrBFlt ** u,MrBFlt ** v)9693 void CalcCijk (int dim, MrBFlt *c_ijk, MrBFlt **u, MrBFlt **v)
9694 {
9695 register int i, j, k;
9696 MrBFlt *pc;
9697
9698 pc = c_ijk;
9699 for (i=0; i<dim; i++)
9700 for (j=0; j<dim; j++)
9701 for (k=0; k<dim; k++)
9702 *pc++ = u[i][k] * v[k][j];
9703 }
9704
9705
9706 /*---------------------------------------------------------------------------------
9707 |
9708 | CdfBinormal
9709 |
9710 | F(h1,h2,r) = prob(x<h1, y<h2), where x and y are standard binormal.
9711 |
9712 ---------------------------------------------------------------------------------*/
CdfBinormal(MrBFlt h1,MrBFlt h2,MrBFlt r)9713 MrBFlt CdfBinormal (MrBFlt h1, MrBFlt h2, MrBFlt r)
9714 {
9715 return (LBinormal(h1, h2, r) + CdfNormal(h1) + CdfNormal(h2) - 1.0);
9716 }
9717
9718
9719 /*---------------------------------------------------------------------------------
9720 |
9721 | CdfNormal
9722 |
9723 | Calculates the cumulative density distribution (CDF) for the normal using:
9724 |
9725 | Hill, I. D. 1973. The normal integral. Applied Statistics, 22:424-427.
9726 | (AS66)
9727 |
9728 ---------------------------------------------------------------------------------*/
CdfNormal(MrBFlt x)9729 MrBFlt CdfNormal (MrBFlt x)
9730 {
9731 int invers = 0;
9732 MrBFlt p, limit = 10.0, t = 1.28, y = x*x/2.0;
9733
9734 if (x < 0.0)
9735 {
9736 invers = 1;
9737 x *= -1.0;
9738 }
9739 if (x > limit)
9740 return (invers ? 0 : 1);
9741 if (x < t)
9742 p = 0.5 - x * (0.398942280444 - 0.399903438504 * y /
9743 (y + 5.75885480458 - 29.8213557808 /
9744 (y + 2.62433121679 + 48.6959930692 /
9745 (y + 5.92885724438))));
9746 else
9747 p = 0.398942280385 * exp(-y) /
9748 (x - 3.8052e-8 + 1.00000615302 /
9749 (x + 3.98064794e-4 + 1.98615381364 /
9750 (x - 0.151679116635 + 5.29330324926 /
9751 (x + 4.8385912808 - 15.1508972451 /
9752 (x + 0.742380924027 + 30.789933034 /
9753 (x + 3.99019417011))))));
9754
9755 return (invers ? p : 1-p);
9756 }
9757
9758
9759 /*---------------------------------------------------------------------------------
9760 |
9761 | Complex
9762 |
9763 | Returns a complex number with specified real and imaginary parts.
9764 |
9765 ---------------------------------------------------------------------------------*/
Complex(MrBFlt a,MrBFlt b)9766 MrBComplex Complex (MrBFlt a, MrBFlt b)
9767 {
9768 MrBComplex c;
9769
9770 c.re = a;
9771 c.im = b;
9772
9773 return (c);
9774 }
9775
9776
9777 /*---------------------------------------------------------------------------------
9778 |
9779 | ComplexAbsoluteValue
9780 |
9781 | Returns the complex absolute value (modulus) of a complex number.
9782 |
9783 ---------------------------------------------------------------------------------*/
ComplexAbsoluteValue(MrBComplex a)9784 MrBFlt ComplexAbsoluteValue (MrBComplex a)
9785 {
9786 MrBFlt x, y, answer, temp;
9787
9788 x = fabs(a.re);
9789 y = fabs(a.im);
9790 if (AreDoublesEqual(x, 0.0, ETA)==YES) /* x == 0.0 */
9791 answer = y;
9792 else if (AreDoublesEqual(y, 0.0, ETA)==YES) /* y == 0.0 */
9793 answer = x;
9794 else if (x > y)
9795 {
9796 temp = y / x;
9797 answer = x * sqrt(1.0 + temp * temp);
9798 }
9799 else
9800 {
9801 temp = x / y;
9802 answer = y * sqrt(1.0 + temp * temp);
9803 }
9804
9805 return (answer);
9806 }
9807
9808
9809 /*---------------------------------------------------------------------------------
9810 |
9811 | ComplexAddition
9812 |
9813 | Returns the complex sum of two complex numbers.
9814 |
9815 ---------------------------------------------------------------------------------*/
ComplexAddition(MrBComplex a,MrBComplex b)9816 MrBComplex ComplexAddition (MrBComplex a, MrBComplex b)
9817 {
9818 MrBComplex c;
9819
9820 c.re = a.re + b.re;
9821 c.im = a.im + b.im;
9822
9823 return (c);
9824 }
9825
9826
9827 /*---------------------------------------------------------------------------------
9828 |
9829 | ComplexConjugate
9830 |
9831 | Returns the complex conjugate of a complex number.
9832 |
9833 ---------------------------------------------------------------------------------*/
ComplexConjugate(MrBComplex a)9834 MrBComplex ComplexConjugate (MrBComplex a)
9835 {
9836 MrBComplex c;
9837
9838 c.re = a.re;
9839 c.im = -a.im;
9840
9841 return (c);
9842 }
9843
9844
9845 /*---------------------------------------------------------------------------------
9846 |
9847 | ComplexDivision
9848 |
9849 | Returns the complex quotient of two complex numbers.
9850 |
9851 ---------------------------------------------------------------------------------*/
ComplexDivision(MrBComplex a,MrBComplex b)9852 MrBComplex ComplexDivision (MrBComplex a, MrBComplex b)
9853 {
9854 MrBComplex c;
9855 MrBFlt r, den;
9856
9857 if (fabs(b.re) >= fabs(b.im))
9858 {
9859 r = b.im / b.re;
9860 den = b.re + r * b.im;
9861 c.re = (a.re + r * a.im) / den;
9862 c.im = (a.im - r * a.re) / den;
9863 }
9864 else
9865 {
9866 r = b.re / b.im;
9867 den = b.im + r * b.re;
9868 c.re = (a.re * r + a.im) / den;
9869 c.im = (a.im * r - a.re) / den;
9870 }
9871
9872 return (c);
9873 }
9874
9875
9876 /*---------------------------------------------------------------------------------
9877 |
9878 | ComplexDivision2
9879 |
9880 | Returns the complex quotient of two complex numbers. It does not require that
9881 | the numbers be in a complex structure.
9882 |
9883 ---------------------------------------------------------------------------------*/
ComplexDivision2(MrBFlt ar,MrBFlt ai,MrBFlt br,MrBFlt bi,MrBFlt * cr,MrBFlt * ci)9884 void ComplexDivision2 (MrBFlt ar, MrBFlt ai, MrBFlt br, MrBFlt bi, MrBFlt *cr, MrBFlt *ci)
9885 {
9886 MrBFlt s, ais, bis, ars, brs;
9887
9888 s = fabs(br) + fabs(bi);
9889 ars = ar / s;
9890 ais = ai / s;
9891 brs = br / s;
9892 bis = bi / s;
9893 s = brs*brs + bis*bis;
9894 *cr = (ars*brs + ais*bis) / s;
9895 *ci = (ais*brs - ars*bis) / s;
9896 }
9897
9898
9899 /*---------------------------------------------------------------------------------
9900 |
9901 | ComplexExponentiation
9902 |
9903 | Returns the complex exponential of a complex number.
9904 |
9905 ---------------------------------------------------------------------------------*/
ComplexExponentiation(MrBComplex a)9906 MrBComplex ComplexExponentiation (MrBComplex a)
9907 {
9908 MrBComplex c;
9909
9910 c.re = exp(a.re);
9911 if (AreDoublesEqual(a.im,0.0, ETA)==YES) /* == 0 */
9912 c.im = 0;
9913 else
9914 {
9915 c.im = c.re*sin(a.im);
9916 c.re *= cos(a.im);
9917 }
9918
9919 return (c);
9920 }
9921
9922
9923 /*---------------------------------------------------------------------------------
9924 |
9925 | ComplexInvertMatrix
9926 |
9927 | Inverts a matrix of complex numbers using the LU-decomposition method.
9928 | The program has the following variables:
9929 |
9930 | a -- the matrix to be inverted
9931 | aInverse -- the results of the matrix inversion
9932 | dim -- the dimension of the square matrix a and its inverse
9933 | dwork -- a work vector of doubles
9934 | indx -- a work vector of integers
9935 | col -- carries the results of the back substitution
9936 |
9937 | The function returns YES (1) or NO (0) if the results are singular.
9938 |
9939 ---------------------------------------------------------------------------------*/
ComplexInvertMatrix(int dim,MrBComplex ** a,MrBFlt * dwork,int * indx,MrBComplex ** aInverse,MrBComplex * col)9940 int ComplexInvertMatrix (int dim, MrBComplex **a, MrBFlt *dwork, int *indx, MrBComplex **aInverse, MrBComplex *col)
9941 {
9942 int isSingular, i, j;
9943
9944 isSingular = ComplexLUDecompose (dim, a, dwork, indx, (MrBFlt *)NULL);
9945
9946 if (isSingular == 0)
9947 {
9948 for (j=0; j<dim; j++)
9949 {
9950 for (i=0; i<dim; i++)
9951 col[i] = Complex (0.0, 0.0);
9952 col[j] = Complex (1.0, 0.0);
9953 ComplexLUBackSubstitution (dim, a, indx, col);
9954 for (i=0; i<dim; i++)
9955 aInverse[i][j] = col[i];
9956 }
9957 }
9958
9959 return (isSingular);
9960 }
9961
9962
9963 /*---------------------------------------------------------------------------------
9964 |
9965 | ComplexExponentiation
9966 |
9967 | Returns the complex exponential of a complex number.
9968 |
9969 ---------------------------------------------------------------------------------*/
ComplexLog(MrBComplex a)9970 MrBComplex ComplexLog (MrBComplex a)
9971 {
9972 MrBComplex c;
9973
9974 c.re = log(ComplexAbsoluteValue(a));
9975 if (AreDoublesEqual(a.re,0.0,ETA)==YES) /* == 0.0 */
9976 {
9977 c.im = M_PI_2;
9978 }
9979 else
9980 {
9981 c.im = atan2(a.im, a.re);
9982 }
9983
9984 return (c);
9985 }
9986
9987
9988 /*---------------------------------------------------------------------------------
9989 |
9990 | ComplexLUBackSubstitution
9991 |
9992 | Perform back-substitution into a LU-decomposed matrix to obtain
9993 | the inverse.
9994 |
9995 ---------------------------------------------------------------------------------*/
ComplexLUBackSubstitution(int dim,MrBComplex ** a,int * indx,MrBComplex * b)9996 void ComplexLUBackSubstitution (int dim, MrBComplex **a, int *indx, MrBComplex *b)
9997 {
9998 int i, ip, j, ii = -1;
9999 MrBComplex sum;
10000
10001 for (i = 0; i < dim; i++)
10002 {
10003 ip = indx[i];
10004 sum = b[ip];
10005 b[ip] = b[i];
10006 if (ii >= 0)
10007 {
10008 for (j = ii; j <= i - 1; j++)
10009 sum = ComplexSubtraction (sum, ComplexMultiplication (a[i][j], b[j]));
10010 }
10011 else if (AreDoublesEqual(sum.re,0.0,ETA)==NO || AreDoublesEqual(sum.im, 0.0, ETA)==NO) /* 2x != 0.0 */
10012 ii = i;
10013 b[i] = sum;
10014 }
10015 for (i = dim - 1; i >= 0; i--)
10016 {
10017 sum = b[i];
10018 for (j = i + 1; j < dim; j++)
10019 sum = ComplexSubtraction (sum, ComplexMultiplication (a[i][j], b[j]));
10020 b[i] = ComplexDivision (sum, a[i][i]);
10021 }
10022 }
10023
10024
10025 /*---------------------------------------------------------------------------------
10026 |
10027 | ComplexLUDecompose
10028 |
10029 | Replaces the matrix a with its LU-decomposition.
10030 | The program has the following variables:
10031 |
10032 | a -- the matrix
10033 | dim -- the dimension of the square matrix a and its inverse
10034 | vv -- a work vector of doubles
10035 | indx -- row permutation according to partitial pivoting sequence
10036 | pd -- 1 if number of row interchanges was even, -1 if number of
10037 | row interchanges was odd. Can be NULL.
10038 |
10039 | The function returns YES (1) or NO (0) if the results are singular.
10040 |
10041 ---------------------------------------------------------------------------------*/
ComplexLUDecompose(int dim,MrBComplex ** a,MrBFlt * vv,int * indx,MrBFlt * pd)10042 int ComplexLUDecompose (int dim, MrBComplex **a, MrBFlt *vv, int *indx, MrBFlt *pd)
10043 {
10044 int i, imax, j, k;
10045 MrBFlt big, dum, temp, d;
10046 MrBComplex sum, cdum;
10047
10048 d = 1.0;
10049 imax = 0;
10050
10051 for (i = 0; i < dim; i++)
10052 {
10053 big = 0.0;
10054 for (j = 0; j < dim; j++)
10055 {
10056 if ((temp = ComplexAbsoluteValue (a[i][j])) > big)
10057 big = temp;
10058 }
10059 if (AreDoublesEqual(big, 0.0, ETA)==YES) /* == 0.0 */
10060 {
10061 MrBayesPrint ("%s Error: Problem in ComplexLUDecompose\n", spacer);
10062 return (1);
10063 }
10064 vv[i] = 1.0 / big;
10065 }
10066
10067 for (j = 0; j < dim; j++)
10068 {
10069 for (i = 0; i < j; i++)
10070 {
10071 sum = a[i][j];
10072 for (k = 0; k < i; k++)
10073 sum = ComplexSubtraction (sum, ComplexMultiplication (a[i][k], a[k][j]));
10074 a[i][j] = sum;
10075 }
10076 big = 0.0;
10077 for (i = j; i < dim; i++)
10078 {
10079 sum = a[i][j];
10080 for (k = 0; k < j; k++)
10081 sum = ComplexSubtraction (sum, ComplexMultiplication (a[i][k], a[k][j]));
10082 a[i][j] = sum;
10083 dum = vv[i] * ComplexAbsoluteValue (sum);
10084 if (dum >= big)
10085 {
10086 big = dum;
10087 imax = i;
10088 }
10089 }
10090 if (j != imax)
10091 {
10092 for (k = 0; k < dim; k++)
10093 {
10094 cdum = a[imax][k];
10095 a[imax][k] = a[j][k];
10096 a[j][k] = cdum;
10097 }
10098 d = -d;
10099 vv[imax] = vv[j];
10100 }
10101 indx[j] = imax;
10102 if (AreDoublesEqual(a[j][j].re, 0.0, ETA)==YES && AreDoublesEqual(a[j][j].im, 0.0, ETA)==YES) /* 2x == 0.0 */
10103 a[j][j] = Complex (1.0e-20, 1.0e-20);
10104 if (j != dim - 1)
10105 {
10106 cdum = ComplexDivision (Complex(1.0, 0.0), a[j][j]);
10107 for (i = j + 1; i < dim; i++)
10108 a[i][j] = ComplexMultiplication (a[i][j], cdum);
10109 }
10110 }
10111
10112 if (pd != NULL)
10113 *pd = d;
10114
10115 return (0);
10116 }
10117
10118
10119 /*---------------------------------------------------------------------------------
10120 |
10121 | ComplexMultiplication
10122 |
10123 | Returns the complex product of two complex numbers.
10124 |
10125 ---------------------------------------------------------------------------------*/
ComplexMultiplication(MrBComplex a,MrBComplex b)10126 MrBComplex ComplexMultiplication (MrBComplex a, MrBComplex b)
10127 {
10128 MrBComplex c;
10129
10130 c.re = a.re * b.re - a.im * b.im;
10131 c.im = a.im * b.re + a.re * b.im;
10132
10133 return (c);
10134 }
10135
10136
10137 /*---------------------------------------------------------------------------------
10138 |
10139 | ComplexSquareRoot
10140 |
10141 | Returns the complex square root of a complex number.
10142 |
10143 ---------------------------------------------------------------------------------*/
ComplexSquareRoot(MrBComplex a)10144 MrBComplex ComplexSquareRoot (MrBComplex a)
10145 {
10146 MrBComplex c;
10147 MrBFlt x, y, w, r;
10148
10149 if (AreDoublesEqual(a.re, 0.0, ETA)==YES && AreDoublesEqual(a.im, 0.0, ETA)==YES) /* 2x == 0.0 */
10150 {
10151 c.re = 0.0;
10152 c.im = 0.0;
10153 return (c);
10154 }
10155 else
10156 {
10157 x = fabs(a.re);
10158 y = fabs(a.im);
10159 if (x >= y)
10160 {
10161 r = y / x;
10162 w = sqrt(x) * sqrt(0.5 * (1.0 + sqrt(1.0 + r * r)));
10163 }
10164 else
10165 {
10166 r = x / y;
10167 w = sqrt(y) * sqrt(0.5 * (r + sqrt(1.0 + r * r)));
10168 }
10169 if (a.re >= 0.0)
10170 {
10171 c.re = w;
10172 c.im = a.im / (2.0 * w);
10173 }
10174 else
10175 {
10176 c.im = (a.im >= 0.0) ? w : -w;
10177 c.re = a.im / (2.0 * c.im);
10178 }
10179 return (c);
10180 }
10181 }
10182
10183
10184 /*---------------------------------------------------------------------------------
10185 |
10186 | ComplexSubtraction
10187 |
10188 | Returns the complex difference of two complex numbers.
10189 |
10190 ---------------------------------------------------------------------------------*/
ComplexSubtraction(MrBComplex a,MrBComplex b)10191 MrBComplex ComplexSubtraction (MrBComplex a, MrBComplex b)
10192 {
10193 MrBComplex c;
10194
10195 c.re = a.re - b.re;
10196 c.im = a.im - b.im;
10197
10198 return (c);
10199 }
10200
10201
10202 /*---------------------------------------------------------------------------------
10203 |
10204 | ComputeEigenSystem
10205 |
10206 | Calculates the eigenvalues, eigenvectors, and the inverse of the eigenvectors
10207 | for a matrix of real numbers.
10208 |
10209 ---------------------------------------------------------------------------------*/
ComputeEigenSystem(int dim,MrBFlt ** a,MrBFlt * v,MrBFlt * vi,MrBFlt ** u,int * iwork,MrBFlt * dwork)10210 int ComputeEigenSystem (int dim, MrBFlt **a, MrBFlt *v, MrBFlt *vi, MrBFlt **u, int *iwork, MrBFlt *dwork)
10211 {
10212 int i, rc;
10213
10214 rc = EigensForRealMatrix (dim, a, v, vi, u, iwork, dwork);
10215 if (rc != NO_ERROR)
10216 {
10217 MrBayesPrint ("%s Error in ComputeEigenSystem.\n", spacer);
10218 return (ERROR);
10219 }
10220 for (i=0; i<dim; i++)
10221 {
10222 if (AreDoublesEqual(vi[i], 0.0, ETA)==NO) /* != 0.0 */
10223 return (EVALUATE_COMPLEX_NUMBERS);
10224 }
10225
10226 return (NO_ERROR);
10227 }
10228
10229
10230 /*---------------------------------------------------------------------------------
10231 |
10232 | ComputeLandU
10233 |
10234 | This function computes the L and U decomposition of a matrix. Basically,
10235 | we find matrices lMat and uMat such that
10236 |
10237 | lMat * uMat = aMat
10238 |
10239 ---------------------------------------------------------------------------------*/
ComputeLandU(int dim,MrBFlt ** aMat,MrBFlt ** lMat,MrBFlt ** uMat)10240 void ComputeLandU (int dim, MrBFlt **aMat, MrBFlt **lMat, MrBFlt **uMat)
10241 {
10242 int i, j, k, m, row, col;
10243
10244 for (j=0; j<dim; j++)
10245 {
10246 for (k=0; k<j; k++)
10247 for (i=k+1; i<j; i++)
10248 aMat[i][j] = aMat[i][j] - aMat[i][k] * aMat[k][j];
10249
10250 for (k=0; k<j; k++)
10251 for (i=j; i<dim; i++)
10252 aMat[i][j] = aMat[i][j] - aMat[i][k]*aMat[k][j];
10253
10254 for (m=j+1; m<dim; m++)
10255 aMat[m][j] /= aMat[j][j];
10256 }
10257
10258 for (row=0; row<dim; row++)
10259 {
10260 for (col=0; col<dim; col++)
10261 {
10262 if (row <= col)
10263 {
10264 uMat[row][col] = aMat[row][col];
10265 lMat[row][col] = (row == col ? 1.0 : 0.0);
10266 }
10267 else
10268 {
10269 lMat[row][col] = aMat[row][col];
10270 uMat[row][col] = 0.0;
10271 }
10272 }
10273 }
10274 }
10275
10276
10277 /*---------------------------------------------------------------------------------
10278 |
10279 | ComputeMatrixExponential
10280 |
10281 | The method approximates the matrix exponential, f = e^a, using
10282 | the algorithm 11.3.1, described in:
10283 |
10284 | Golub, G. H., and C. F. Van Loan. 1996. Matrix Computations, Third Edition.
10285 | The Johns Hopkins University Press, Baltimore, Maryland.
10286 |
10287 | The method has the advantage of error control. The error is controlled by
10288 | setting qValue appropriately (using the function SetQValue).
10289 |
10290 ---------------------------------------------------------------------------------*/
ComputeMatrixExponential(int dim,MrBFlt ** a,int qValue,MrBFlt ** f)10291 void ComputeMatrixExponential (int dim, MrBFlt **a, int qValue, MrBFlt **f)
10292 {
10293 int i, j, k, negativeFactor;
10294 MrBFlt maxAValue, c, **d, **n, **x, **cX;
10295
10296 d = AllocateSquareDoubleMatrix (dim);
10297 n = AllocateSquareDoubleMatrix (dim);
10298 x = AllocateSquareDoubleMatrix (dim);
10299 cX = AllocateSquareDoubleMatrix (dim);
10300
10301 SetToIdentity (dim, d);
10302 SetToIdentity (dim, n);
10303 SetToIdentity (dim, x);
10304
10305 maxAValue = 0;
10306 for (i=0; i<dim; i++)
10307 maxAValue = MAX (maxAValue, a[i][i]);
10308
10309 j = MAX (0, LogBase2Plus1 (maxAValue));
10310
10311 DivideByTwos (dim, a, j);
10312
10313 c = 1;
10314 for (k=1; k<=qValue; k++)
10315 {
10316 c = c * (qValue - k + 1.0) / ((2.0 * qValue - k + 1.0) * k);
10317
10318 /* X = AX */
10319 MultiplyMatrices (dim, a, x, x);
10320
10321 /* N = N + cX */
10322 MultiplyMatrixByScalar (dim, x, c, cX);
10323 AddTwoMatrices (dim, n, cX, n);
10324
10325 /* D = D + (-1)^k*cX */
10326 negativeFactor = (k % 2 == 0 ? 1 : -1);
10327 if (negativeFactor == -1)
10328 MultiplyMatrixByScalar (dim, cX, negativeFactor, cX);
10329 AddTwoMatrices (dim, d, cX, d);
10330 }
10331
10332 GaussianElimination (dim, d, n, f);
10333
10334 for (k = 0; k < j; k++)
10335 MultiplyMatrices (dim, f, f, f);
10336
10337 for (i=0; i<dim; i++)
10338 {
10339 for (j=0; j<dim; j++)
10340 {
10341 if (f[i][j] < 0.0)
10342 f[i][j] = fabs(f[i][j]);
10343 }
10344 }
10345
10346 FreeSquareDoubleMatrix (d);
10347 FreeSquareDoubleMatrix (n);
10348 FreeSquareDoubleMatrix (x);
10349 FreeSquareDoubleMatrix (cX);
10350 }
10351
10352
10353 /*---------------------------------------------------------------------------------
10354 |
10355 | CopyComplexMatrices
10356 |
10357 | Copies the contents of one matrix of complex numbers to another matrix.
10358 |
10359 ---------------------------------------------------------------------------------*/
CopyComplexMatrices(int dim,MrBComplex ** from,MrBComplex ** to)10360 void CopyComplexMatrices (int dim, MrBComplex **from, MrBComplex **to)
10361 {
10362 int i, j;
10363
10364 for (i=0; i<dim; i++)
10365 {
10366 for (j=0; j<dim; j++)
10367 {
10368 to[i][j].re = from[i][j].re;
10369 to[i][j].im = from[i][j].im;
10370 }
10371 }
10372 }
10373
10374
10375 /*---------------------------------------------------------------------------------
10376 |
10377 | CopyDoubleMatrices
10378 |
10379 | Copies the contents of one matrix of doubles to another matrix.
10380 |
10381 ---------------------------------------------------------------------------------*/
CopyDoubleMatrices(int dim,MrBFlt ** from,MrBFlt ** to)10382 void CopyDoubleMatrices (int dim, MrBFlt **from, MrBFlt **to)
10383 {
10384 int i, j;
10385
10386 for (i=0; i<dim; i++)
10387 {
10388 for (j=0; j<dim; j++)
10389 {
10390 to[i][j] = from[i][j];
10391 }
10392 }
10393 }
10394
10395
10396 /*---------------------------------------------------------------------------------
10397 |
10398 | DirichletRandomVariable
10399 |
10400 | Generate a Dirichlet-distributed random variable. The parameter of the
10401 | Dirichlet is contained in the vector alp. The random variable is contained
10402 | in the vector z.
10403 |
10404 ---------------------------------------------------------------------------------*/
DirichletRandomVariable(MrBFlt * alp,MrBFlt * z,int n,RandLong * seed)10405 void DirichletRandomVariable (MrBFlt *alp, MrBFlt *z, int n, RandLong *seed)
10406 {
10407 int i;
10408 MrBFlt sum;
10409
10410 sum = 0.0;
10411 for (i=0; i<n; i++)
10412 {
10413 z[i] = RndGamma (alp[i], seed) / 1.0;
10414 sum += z[i];
10415 }
10416 for (i=0; i<n; i++)
10417 z[i] /= sum;
10418 }
10419
10420
10421 /*---------------------------------------------------------------------------------
10422 |
10423 | DiscreteGamma
10424 |
10425 | Discretization of gamma distribution with equal proportions in each
10426 | category.
10427 |
10428 ---------------------------------------------------------------------------------*/
DiscreteGamma(MrBFlt * rK,MrBFlt alfa,MrBFlt beta,int K,int median)10429 int DiscreteGamma (MrBFlt *rK, MrBFlt alfa, MrBFlt beta, int K, int median)
10430 {
10431 int i;
10432 MrBFlt gap05 = 1.0/(2.0*K), t, factor = alfa/beta*K, lnga1;
10433
10434 if (median)
10435 {
10436 for (i=0; i<K; i++)
10437 rK[i] = POINTGAMMA((i*2.0+1.0)*gap05, alfa, beta);
10438 for (i=0,t=0; i<K; i++)
10439 t += rK[i];
10440 for (i=0; i<K; i++)
10441 rK[i] *= factor / t;
10442 }
10443 else
10444 {
10445 lnga1 = LnGamma(alfa+1);
10446 /* calculate the points in the gamma distribution */
10447 for (i=0; i<K-1; i++)
10448 rK[i] = POINTGAMMA((i+1.0)/K, alfa, beta);
10449 /* calculate the cumulative values */
10450 for (i=0; i<K-1; i++)
10451 rK[i] = IncompleteGamma(rK[i] * beta, alfa + 1.0, lnga1);
10452 rK[K-1] = 1.0;
10453 /* calculate the relative values and rescale */
10454 for (i=K-1; i>0; i--)
10455 {
10456 rK[i] -= rK[i-1];
10457 rK[i] *= factor;
10458 }
10459 rK[0] *= factor;
10460 }
10461
10462 return (NO_ERROR);
10463 }
10464
10465
10466 /*---------------------------------------------------------------------------------
10467 |
10468 | DiscreteLogNormal
10469 |
10470 | Discretization of lognormal distribution with equal proportions in each
10471 | category.
10472 |
10473 | LBH Notes: K = # of rate classes
10474 | *rK = pointer to output rate class matrix
10475 | alfa = alpha param
10476 | beta = beta param
10477 | median = flag to use media or not (1 = use median, 0 = mean?)
10478 |
10479 ---------------------------------------------------------------------------------*/
DiscreteLogNormal(MrBFlt * rK,MrBFlt sigma,int K,int median)10480 int DiscreteLogNormal (MrBFlt *rK, MrBFlt sigma, int K, int median)
10481 {
10482 int i;
10483 MrBFlt t, factor;
10484 MrBFlt sigmaL = sqrt(sigma);
10485 MrBFlt mu = -0.5*sigmaL*sigmaL;
10486 if (median)
10487 {
10488 for (i=0; i<K; i++) {
10489 rK[i] = QuantileLogNormal( ((2.0*i + 1) / (2.0 * K)), mu, sigmaL);
10490 }
10491 for (i=0,t=0.0; i<K; i++) {
10492 t = t+rK[i];
10493 }
10494 t /= K;
10495 for (i=0; i<K; i++)
10496 rK[i] /= t;
10497 }
10498 else
10499 {
10500 mu = -0.5*sigmaL*sigmaL;
10501 /* Mean set to 1.0 so factor = K */
10502 factor = 1.0*K;
10503 for (i=0; i<K-1; i++) {
10504 rK[i] = QuantileLogNormal(((i + 1.0) / (K)), mu, sigmaL);
10505 }
10506 for (i=0; i<K-1; i++) {
10507 //rK[i] = LogNormalPoint(rK[i], mu, sigma);
10508 //rK[i] = QuantileLogNormal(rK[i], mu, sigma);
10509 //rK[i] = CdfNormal((log(rK[i])-mu)/sigma);
10510 rK[i] = 1 - (1.0 * CdfNormal((mu + sigmaL*sigmaL - log(rK[i]))/sigmaL));
10511 }
10512 rK[K-1] = 1.0;
10513 for (i=K-1; i>0; i--) {
10514 rK[i] -= rK[i-1];
10515 rK[i] *= factor;
10516 }
10517 rK[0] *= factor;
10518 }
10519
10520 return (NO_ERROR);
10521 }
10522
10523
10524 /* LogNormal Quantile Function */
QuantileLogNormal(MrBFlt prob,MrBFlt mu,MrBFlt sigma)10525 MrBFlt QuantileLogNormal (MrBFlt prob, MrBFlt mu, MrBFlt sigma)
10526 {
10527 MrBFlt a = 0.0, b = 0.0;
10528 a = PointNormal((0.5*(2.0*prob-1.0))+0.5) / sqrt(2.0);
10529 b = mu+(sqrt(2.0)* sigma * a);
10530 return exp(b);
10531 }
10532
10533
10534 /* LogNormal Point Function */
LogNormalPoint(MrBFlt x,MrBFlt mu,MrBFlt sigma)10535 MrBFlt LogNormalPoint (MrBFlt x, MrBFlt mu, MrBFlt sigma)
10536 {
10537 if(x <= 0.0) return(0.0);
10538 MrBFlt a = LnProbLogNormal(mu, sigma, x);
10539 return exp(a);
10540 }
10541
10542
10543 /*---------------------------------------------------------------------------------
10544 |
10545 | DivideByTwos
10546 |
10547 | Divides all of the elements of the matrix a by 2^power.
10548 |
10549 ---------------------------------------------------------------------------------*/
DivideByTwos(int dim,MrBFlt ** a,int power)10550 void DivideByTwos (int dim, MrBFlt **a, int power)
10551 {
10552 int divisor = 1, i, row, col;
10553
10554 for (i=0; i<power; i++)
10555 divisor = divisor * 2;
10556
10557 for (row=0; row<dim; row++)
10558 for (col=0; col<dim; col++)
10559 a[row][col] /= divisor;
10560 }
10561
10562
10563 /*---------------------------------------------------------------------------------
10564 |
10565 | D_sign
10566 |
10567 | This function is called from "Hqr2".
10568 |
10569 ---------------------------------------------------------------------------------*/
D_sign(MrBFlt a,MrBFlt b)10570 MrBFlt D_sign (MrBFlt a, MrBFlt b)
10571 {
10572 MrBFlt x;
10573
10574 x = (a >= 0 ? a : -a);
10575
10576 return (b >= 0 ? x : -x);
10577 }
10578
10579
10580 /*---------------------------------------------------------------------------------
10581 |
10582 | Eigens
10583 |
10584 | The matrix of interest is a. The ouptut is the real and imaginary parts of the
10585 | eigenvalues (wr and wi). z contains the real and imaginary parts of the
10586 | eigenvectors. iv2 and fv1 are working vectors.
10587 |
10588 ---------------------------------------------------------------------------------*/
EigensForRealMatrix(int dim,MrBFlt ** a,MrBFlt * wr,MrBFlt * wi,MrBFlt ** z,int * iv1,MrBFlt * fv1)10589 int EigensForRealMatrix (int dim, MrBFlt **a, MrBFlt *wr, MrBFlt *wi, MrBFlt **z, int *iv1, MrBFlt *fv1)
10590 {
10591 static int is1, is2;
10592 int ierr;
10593
10594 Balanc (dim, a, &is1, &is2, fv1);
10595 ElmHes (dim, is1, is2, a, iv1);
10596 ElTran (dim, is1, is2, a, iv1, z);
10597 ierr = Hqr2 (dim, is1, is2, a, wr, wi, z);
10598 if (ierr == 0)
10599 BalBak (dim, is1, is2, fv1, dim, z);
10600
10601 return (ierr);
10602 }
10603
10604
10605 /*---------------------------------------------------------------------------------
10606 |
10607 | ElmHes
10608 |
10609 | Given a real general matrix, this subroutine
10610 | reduces a submatrix situated in rows and columns
10611 | low through high to upper Hessenberg form by
10612 | stabilized elementary similarity transformations.
10613 |
10614 | On input:
10615 |
10616 | * dim is the order of the matrix
10617 |
10618 | * low and high are integers determined by the balancing
10619 | subroutine balanc. if balanc has not been used,
10620 | set low=1, high=dim.
10621 |
10622 | * a contains the input matrix.
10623 |
10624 | On output:
10625 |
10626 | * a contains the hessenberg matrix. The multipliers
10627 | which were used in the reduction are stored in the
10628 | remaining triangle under the hessenberg matrix.
10629 |
10630 | * interchanged contains information on the rows and columns
10631 | interchanged in the reduction.
10632 |
10633 | Only elements low through high are used.
10634 |
10635 ---------------------------------------------------------------------------------*/
ElmHes(int dim,int low,int high,MrBFlt ** a,int * interchanged)10636 void ElmHes (int dim, int low, int high, MrBFlt **a, int *interchanged)
10637 {
10638 int i, j, m, la, mm1, kp1, mp1;
10639 MrBFlt x, y;
10640
10641 la = high - 1;
10642 kp1 = low + 1;
10643 if (la < kp1)
10644 return; /* remove goto statement, which exits at bottom of function */
10645
10646 for (m=kp1; m<=la; m++)
10647 {
10648 mm1 = m - 1;
10649 x = 0.0;
10650 i = m;
10651
10652 for (j=m; j<=high; j++)
10653 {
10654 if (fabs(a[j][mm1]) > fabs(x)) /* change direction of inequality */
10655 { /* remove goto statement */
10656 x = a[j][mm1];
10657 i = j;
10658 }
10659 }
10660
10661 interchanged[m] = i;
10662 if (i != m) /* change "==" to "!=", eliminating goto statement */
10663 {
10664 /* interchange rows and columns of a */
10665 for (j=mm1; j<dim; j++)
10666 {
10667 y = a[i][j];
10668 a[i][j] = a[m][j];
10669 a[m][j] = y;
10670 }
10671 for (j=0; j<=high; j++)
10672 {
10673 y = a[j][i];
10674 a[j][i] = a[j][m];
10675 a[j][m] = y;
10676 }
10677 }
10678
10679 if (AreDoublesEqual(x, 0.0, ETA)==NO) /* change "==" to "!=", eliminating goto statement */
10680 {
10681 mp1 = m + 1;
10682
10683 for (i=mp1; i<=high; i++)
10684 {
10685 y = a[i][mm1];
10686 if (AreDoublesEqual(y, 0.0, ETA)==NO) /* != 0.0 */
10687 {
10688 y /= x;
10689 a[i][mm1] = y;
10690 for (j = m; j < dim; j++)
10691 a[i][j] -= y * a[m][j];
10692 for (j = 0; j <= high; j++)
10693 a[j][m] += y * a[j][i];
10694 }
10695 }
10696 }
10697 }
10698
10699 #if 0
10700 /* begin f2c version of code:
10701 elmhes.f -- translated by f2c (version 19971204) */
10702 int elmhes (int *nm, int *n, int *low, int *igh, MrBFlt *a, int *int__)
10703
10704 {
10705
10706 /*system generated locals */
10707 int a_dim1, a_offset, i__1, i__2, i__3;
10708 MrBFlt d__1;
10709
10710 /* local variables */
10711 static int i__, j, m;
10712 static MrBFlt x, y;
10713 static int la, mm1, kp1, mp1;
10714
10715 /* parameter adjustments */
10716 a_dim1 = *nm;
10717 a_offset = a_dim1 + 1;
10718 a -= a_offset;
10719 --int__;
10720
10721 /* function body */
10722 la = *igh - 1;
10723 kp1 = *low + 1;
10724 if (la < kp1)
10725 goto L200;
10726
10727 i__1 = la;
10728 for (m = kp1; m <= i__1; ++m)
10729 {
10730 mm1 = m - 1;
10731 x = 0.;
10732 i__ = m;
10733 i__2 = *igh;
10734 for (j = m; j <= i__2; ++j)
10735 {
10736 if ((d__1 = a[j + mm1 * a_dim1], abs(d__1)) <= abs(x))
10737 goto L100;
10738 x = a[j + mm1 * a_dim1];
10739 i__ = j;
10740 L100:
10741 ;
10742 }
10743
10744 int__[m] = i__;
10745 if (i__ == m)
10746 goto L130;
10747
10748 /* .......... interchange rows and columns of a.......... */
10749 i__2 = *n;
10750 for (j = mm1; j <= i__2; ++j)
10751 {
10752 y = a[i__ + j * a_dim1];
10753 a[i__ + j * a_dim1] = a[m + j * a_dim1];
10754 a[m + j * a_dim1] = y;
10755 /* L110: */
10756 }
10757
10758 i__2 = *igh;
10759 for (j = 1; j <= i__2; ++j)
10760 {
10761 y = a[j + i__ * a_dim1];
10762 a[j + i__ * a_dim1] = a[j + m * a_dim1];
10763 a[j + m * a_dim1] = y;
10764 /* L120: */
10765 }
10766
10767 /* .......... end interchange .......... */
10768 L130:
10769 if (x == 0.)
10770 goto L180;
10771 mp1 = m + 1;
10772
10773 i__2 = *igh;
10774 for (i__ = mp1; i__ <= i__2; ++i__)
10775 {
10776 y = a[i__ + mm1 * a_dim1];
10777 if (y == 0.)
10778 goto L160;
10779 y /= x;
10780 a[i__ + mm1 * a_dim1] = y;
10781
10782 i__3 = *n;
10783 for (j = m; j <= i__3; ++j)
10784 {
10785 /* L140: */
10786 a[i__ + j * a_dim1] -= y * a[m + j * a_dim1];
10787 }
10788
10789 i__3 = *igh;
10790 for (j = 1; j <= i__3; ++j)
10791 {
10792 /* L150: */
10793 a[j + m * a_dim1] += y * a[j + i__ * a_dim1];
10794 }
10795
10796 L160:
10797 ;
10798 }
10799
10800 L180:
10801 ;
10802 }
10803
10804 L200:
10805 return 0;
10806
10807 }
10808 /* end f2c version of code */
10809 #endif
10810
10811 }
10812
10813
10814 /*---------------------------------------------------------------------------------
10815 |
10816 | ElTran
10817 |
10818 | This subroutine accumulates the stabilized elementary
10819 | similarity transformations used in the reduction of a
10820 | real general matrix to upper Hessenberg form by ElmHes.
10821 |
10822 | On input:
10823 |
10824 | * dim is the order of the matrix.
10825 |
10826 | * low and high are integers determined by the balancing
10827 | subroutine balanc. If Balanc has not been used,
10828 | set low=0, high=dim-1.
10829 |
10830 | * a contains the multipliers which were used in the
10831 | reduction by ElmHes in its lower triangle
10832 | below the subdiagonal.
10833 |
10834 | * interchanged contains information on the rows and columns
10835 | interchanged in the reduction by ElmHes.
10836 | only elements low through high are used.
10837 |
10838 | On output:
10839 |
10840 | * z contains the transformation matrix produced in the
10841 | reduction by ElmHes.
10842 |
10843 | This routine is a translation of the Algol procedure from
10844 | Handbook for Automatic Computation, vol. II, Linear Algebra,
10845 | by Wilkinson and Reinsch, Springer-Verlag.
10846 |
10847 ---------------------------------------------------------------------------------*/
ElTran(int dim,int low,int high,MrBFlt ** a,int * interchanged,MrBFlt ** z)10848 void ElTran (int dim, int low, int high, MrBFlt **a, int *interchanged, MrBFlt **z)
10849 {
10850 int i, j, mp;
10851
10852 /* initialize z to identity matrix */
10853 for (j=0; j<dim; j++)
10854 {
10855 for (i=0; i<dim; i++)
10856 z[i][j] = 0.0;
10857 z[j][j] = 1.0;
10858 }
10859 for (mp=high-1; mp>=low+1; mp--) /* there were a number of additional */
10860 { /* variables (kl, la, m, mm, mp1) that */
10861 for (i=mp+1; i<=high; i++) /* have been eliminated here simply by */
10862 z[i][mp] = a[i][mp-1]; /* initializing variables appropriately */
10863 i = interchanged[mp]; /* in the loops */
10864 if (i != mp) /* change "==" to "!=" to eliminate a goto statement */
10865 {
10866 for (j=mp; j<=high; j++)
10867 {
10868 z[mp][j] = z[i][j];
10869 z[i][j] = 0.0;
10870 }
10871 z[i][mp] = 1.0;
10872 }
10873 }
10874
10875 #if 0
10876 /* begin f2c version of code:
10877 eltran.f -- translated by f2c (version 19971204) */
10878 int eltran (int *nm, int *n, int *low, int *igh, MrBFlt *a, int *int__, MrBFlt *z__)
10879
10880 {
10881
10882 /* system generated locals */
10883 int a_dim1, a_offset, z_dim1, z_offset, i__1, i__2;
10884
10885 /* local variables */
10886 static int i__, j, kl, mm, mp, mp1;
10887
10888 /* .......... initialize z to identity matrix .......... */
10889
10890 /* parameter adjustments */
10891 z_dim1 = *nm;
10892 z_offset = z_dim1 + 1;
10893 z__ -= z_offset;
10894 --int__;
10895 a_dim1 = *nm;
10896 a_offset = a_dim1 + 1;
10897 a -= a_offset;
10898
10899 /* function Body */
10900 i__1 = *n;
10901 for (j = 1; j <= i__1; ++j)
10902 {
10903 i__2 = *n;
10904 for (i__ = 1; i__ <= i__2; ++i__)
10905 {
10906 /* L60: */
10907 z__[i__ + j * z_dim1] = 0.0;
10908 }
10909 z__[j + j * z_dim1] = 1.0;
10910 /* L80: */
10911 }
10912
10913 kl = *igh - *low - 1;
10914 if (kl < 1)
10915 goto L200;
10916
10917 /* .......... for mp=igh-1 step -1 until low+1 do -- .......... */
10918 i__1 = kl;
10919 for (mm = 1; mm <= i__1; ++mm)
10920 {
10921 mp = *igh - mm;
10922 mp1 = mp + 1;
10923 i__2 = *igh;
10924 for (i__ = mp1; i__ <= i__2; ++i__)
10925 {
10926 /* L100: */
10927 z__[i__ + mp * z_dim1] = a[i__ + (mp - 1) * a_dim1];
10928 }
10929 i__ = int__[mp];
10930 if (i__ == mp)
10931 goto L140;
10932 i__2 = *igh;
10933 for (j = mp; j <= i__2; ++j)
10934 {
10935 z__[mp + j * z_dim1] = z__[i__ + j * z_dim1];
10936 z__[i__ + j * z_dim1] = 0.;
10937 /* L130: */
10938 }
10939 z__[i__ + mp * z_dim1] = 1.;
10940 L140:
10941 ;
10942 }
10943
10944 L200:
10945 return 0;
10946
10947 }
10948 /* end f2c version of code */
10949 #endif
10950
10951 }
10952
10953
10954 /*---------------------------------------------------------------------------------
10955 |
10956 | Exchange
10957 |
10958 ---------------------------------------------------------------------------------*/
Exchange(int j,int k,int l,int m,int n,MrBFlt ** a,MrBFlt * scale)10959 void Exchange (int j, int k, int l, int m, int n, MrBFlt **a, MrBFlt *scale)
10960 {
10961 int i;
10962 MrBFlt f;
10963
10964 scale[m] = (MrBFlt)j;
10965 if (j != m)
10966 {
10967 for (i = 0; i <= l; i++)
10968 {
10969 f = a[i][j];
10970 a[i][j] = a[i][m];
10971 a[i][m] = f;
10972 }
10973 for (i = k; i < n; i++)
10974 {
10975 f = a[j][i];
10976 a[j][i] = a[m][i];
10977 a[m][i] = f;
10978 }
10979 }
10980 }
10981
10982
10983 /*---------------------------------------------------------------------------------
10984 |
10985 | Factorial
10986 |
10987 | Returns x!
10988 |
10989 ---------------------------------------------------------------------------------*/
Factorial(int x)10990 MrBFlt Factorial (int x)
10991 {
10992 int i;
10993 MrBFlt fac;
10994
10995 fac = 1.0;
10996 for (i=0; i<x; i++)
10997 {
10998 fac *= (i+1);
10999 }
11000
11001 return (fac);
11002 }
11003
11004
11005 /*---------------------------------------------------------------------------------
11006 |
11007 | ForwardSubstitutionRow
11008 |
11009 ---------------------------------------------------------------------------------*/
ForwardSubstitutionRow(int dim,MrBFlt ** L,MrBFlt * b)11010 void ForwardSubstitutionRow (int dim, MrBFlt **L, MrBFlt *b)
11011 {
11012 int i, j;
11013 MrBFlt dotProduct;
11014
11015 b[0] = b[0] / L[0][0];
11016 for (i=1; i<dim; i++)
11017 {
11018 dotProduct = 0.0;
11019 for (j=0; j<i; j++)
11020 dotProduct += L[i][j] * b[j];
11021 b[i] = (b[i] - dotProduct) / L[i][i];
11022 }
11023 }
11024
11025
11026 /*---------------------------------------------------------------------------------
11027 |
11028 | FreeSquareComplexMatrix
11029 |
11030 | Frees a matrix of complex numbers.
11031 |
11032 ---------------------------------------------------------------------------------*/
FreeSquareComplexMatrix(MrBComplex ** m)11033 void FreeSquareComplexMatrix (MrBComplex **m)
11034 {
11035 free((char *) (m[0]));
11036 free((char *) (m));
11037 }
11038
11039
11040 /*---------------------------------------------------------------------------------
11041 |
11042 | FreeSquareDoubleMatrix
11043 |
11044 | Frees a matrix of doubles.
11045 |
11046 ---------------------------------------------------------------------------------*/
FreeSquareDoubleMatrix(MrBFlt ** m)11047 void FreeSquareDoubleMatrix (MrBFlt **m)
11048 {
11049 free((char *) (m[0]));
11050 free((char *) (m));
11051 }
11052
11053
11054 /*---------------------------------------------------------------------------------
11055 |
11056 | FreeSquareIntegerMatrix
11057 |
11058 | Frees a matrix of integers.
11059 |
11060 ---------------------------------------------------------------------------------*/
FreeSquareIntegerMatrix(int ** m)11061 void FreeSquareIntegerMatrix (int **m)
11062 {
11063 free((char *) (m[0]));
11064 free((char *) (m));
11065 }
11066
11067
11068 /*---------------------------------------------------------------------------------
11069 |
11070 | GammaRandomVariable
11071 |
11072 | This function generates a gamma-distributed random variable with parameters
11073 | a and b. The mean is E(X) = a / b and the variance is Var(X) = a / b^2.
11074 |
11075 ---------------------------------------------------------------------------------*/
GammaRandomVariable(MrBFlt a,MrBFlt b,RandLong * seed)11076 MrBFlt GammaRandomVariable (MrBFlt a, MrBFlt b, RandLong *seed)
11077 {
11078 return (RndGamma (a, seed) / b);
11079 }
11080
11081
11082 /*---------------------------------------------------------------------------------
11083 |
11084 | GaussianElimination
11085 |
11086 ---------------------------------------------------------------------------------*/
GaussianElimination(int dim,MrBFlt ** a,MrBFlt ** bMat,MrBFlt ** xMat)11087 void GaussianElimination (int dim, MrBFlt **a, MrBFlt **bMat, MrBFlt **xMat)
11088 {
11089 int i, k;
11090 MrBFlt *bVec, **lMat, **uMat;
11091
11092 lMat = AllocateSquareDoubleMatrix (dim);
11093 uMat = AllocateSquareDoubleMatrix (dim);
11094 bVec = (MrBFlt *) SafeMalloc ((size_t)dim * sizeof(MrBFlt));
11095 if (!bVec)
11096 {
11097 MrBayesPrint ("%s Error: Problem allocating bVec\n", spacer);
11098 exit (0);
11099 }
11100
11101 ComputeLandU (dim, a, lMat, uMat);
11102
11103 for (k=0; k<dim; k++)
11104 {
11105
11106 for (i=0; i<dim; i++)
11107 bVec[i] = bMat[i][k];
11108
11109 /* Answer of Ly = b (which is solving for y) is copied into b. */
11110 ForwardSubstitutionRow (dim, lMat, bVec);
11111
11112 /* Answer of Ux = y (solving for x and the y was copied into b above)
11113 is also copied into b. */
11114 BackSubstitutionRow (dim, uMat, bVec);
11115
11116 for (i=0; i<dim; i++)
11117 xMat[i][k] = bVec[i];
11118
11119 }
11120
11121 FreeSquareDoubleMatrix (lMat);
11122 FreeSquareDoubleMatrix (uMat);
11123 free (bVec);
11124 }
11125
11126
11127 /*---------------------------------------------------------------------------------
11128 |
11129 | GetEigens
11130 |
11131 | returns NO if non complex eigendecomposition, YES if complex eigendecomposition, ABORT if an error has occured
11132 |
11133 ---------------------------------------------------------------------------------*/
GetEigens(int dim,MrBFlt ** q,MrBFlt * eigenValues,MrBFlt * eigvalsImag,MrBFlt ** eigvecs,MrBFlt ** inverseEigvecs,MrBComplex ** Ceigvecs,MrBComplex ** CinverseEigvecs)11134 int GetEigens (int dim, MrBFlt **q, MrBFlt *eigenValues, MrBFlt *eigvalsImag, MrBFlt **eigvecs, MrBFlt **inverseEigvecs, MrBComplex **Ceigvecs, MrBComplex **CinverseEigvecs)
11135 {
11136 int i, j, rc, *iWork, isComplex;
11137 MrBFlt **tempWork, *dWork;
11138 MrBComplex **cWork, *Ccol;
11139
11140 /* allocate memory */
11141 dWork = (MrBFlt *) SafeMalloc ((size_t)dim * sizeof(MrBFlt));
11142 iWork = (int *) SafeMalloc ((size_t)dim * sizeof(int));
11143 if (!dWork || !iWork)
11144 {
11145 MrBayesPrint ("%s Error: Problem in GetEigens\n", spacer);
11146 exit (0);
11147 }
11148
11149 /* calculate eigenvalues and eigenvectors */
11150 isComplex = NO;
11151 rc = ComputeEigenSystem (dim, q, eigenValues, eigvalsImag, eigvecs, iWork, dWork);
11152 if (rc != NO_ERROR)
11153 {
11154 if (rc == EVALUATE_COMPLEX_NUMBERS)
11155 isComplex = YES;
11156 else
11157 isComplex = ABORT;
11158 }
11159
11160 /* invert eigenvectors */
11161 if (isComplex == NO)
11162 {
11163 tempWork = AllocateSquareDoubleMatrix (dim);
11164 CopyDoubleMatrices (dim, eigvecs, tempWork);
11165 InvertMatrix (dim, tempWork, dWork, iWork, inverseEigvecs);
11166 FreeSquareDoubleMatrix (tempWork);
11167 }
11168 else if (isComplex == YES)
11169 {
11170 for (i=0; i<dim; i++)
11171 {
11172 if (fabs(eigvalsImag[i])<1E-20) /* == 0.0 */
11173 {
11174 for (j=0; j<dim; j++)
11175 {
11176 Ceigvecs[j][i].re = eigvecs[j][i];
11177 Ceigvecs[j][i].im = 0.0;
11178 }
11179 }
11180 else if (eigvalsImag[i] > 0)
11181 {
11182 for (j=0; j<dim; j++)
11183 {
11184 Ceigvecs[j][i].re = eigvecs[j][i];
11185 Ceigvecs[j][i].im = eigvecs[j][i + 1];
11186 }
11187 }
11188 else if (eigvalsImag[i] < 0)
11189 {
11190 for (j=0; j<dim; j++)
11191 {
11192 Ceigvecs[j][i].re = eigvecs[j][i-1];
11193 Ceigvecs[j][i].im = -eigvecs[j][i];
11194 }
11195 }
11196 }
11197 Ccol = (MrBComplex *) SafeMalloc ((size_t)dim * sizeof(MrBComplex));
11198 if (!Ccol)
11199 {
11200 MrBayesPrint ("%s Error: Problem in GetEigens\n", spacer);
11201 exit (0);
11202 }
11203 cWork = AllocateSquareComplexMatrix (dim);
11204 CopyComplexMatrices (dim, Ceigvecs, cWork);
11205 ComplexInvertMatrix (dim, cWork, dWork, iWork, CinverseEigvecs, Ccol);
11206 free (Ccol);
11207 FreeSquareComplexMatrix (cWork);
11208 }
11209
11210 free (dWork);
11211 free (iWork);
11212
11213 return (isComplex);
11214 }
11215
11216
11217 /*---------------------------------------------------------------------------------
11218 |
11219 | Hqr2
11220 |
11221 | This subroutine finds the eigenvalues and eigenvectors
11222 | of a real upper Hessenberg matrix by the QR method. The
11223 | eigenvectors of a real general matrix can also be found
11224 | if ElmHes and ElTran or OrtHes and OrTran have
11225 | been used to reduce this general matrix to Hessenberg form
11226 | and to accumulate the similarity transformations.
11227 |
11228 | On input:
11229 |
11230 | * dim is the order of the matrix.
11231 |
11232 | * low and high are integers determined by the balancing
11233 | subroutine balanc. If balanc has not been used,
11234 | set low=0, high=dim-1.
11235 |
11236 | * h contains the upper hessenberg matrix. Information about
11237 | the transformations used in the reduction to Hessenberg
11238 | form by ElmHes or OrtHes, if performed, is stored
11239 | in the remaining triangle under the Hessenberg matrix.
11240 |
11241 | On output:
11242 |
11243 | * h has been destroyed.
11244 |
11245 | * wr and wi contain the real and imaginary parts,
11246 | respectively, of the eigenvalues. The eigenvalues
11247 | are unordered except that complex conjugate pairs
11248 | of values appear consecutively with the eigenvalue
11249 | having the positive imaginary part first. If an
11250 | error exit is made, the eigenvalues should be correct
11251 | for indices j,...,dim-1.
11252 |
11253 | * z contains the transformation matrix produced by ElTran
11254 | after the reduction by ElmHes, or by OrTran after the
11255 | reduction by OrtHes, if performed. If the eigenvectors
11256 | of the Hessenberg matrix are desired, z must contain the
11257 | identity matrix.
11258 |
11259 | Calls ComplexDivision2 for complex division.
11260 |
11261 | This function returns:
11262 | zero for normal return,
11263 | j if the limit of 30*n iterations is exhausted
11264 | while the j-th eigenvalue is being sought.
11265 |
11266 | This subroutine is a translation of the ALGOL procedure HQR2,
11267 | Num. Math. 14, 219,231(1970) by Martin, Peters, and Wilkinson.
11268 | Handbook for Automatic Computation, vol. II - Linear Algebra,
11269 | pp. 357-391 (1971).
11270 |
11271 ---------------------------------------------------------------------------------*/
Hqr2(int dim,int low,int high,MrBFlt ** h,MrBFlt * wr,MrBFlt * wi,MrBFlt ** z)11272 int Hqr2 (int dim, int low, int high, MrBFlt **h, MrBFlt *wr, MrBFlt *wi, MrBFlt **z)
11273 {
11274 int i, j, k, l, m, na, en, notlas, mp2, itn, its, enm2, twoRoots;
11275 MrBFlt norm, p=0.0, q=0.0, r=0.0, s=0.0, t, w=0.0, x, y=0.0, ra, sa, vi, vr, zz=0.0, tst1, tst2;
11276
11277 norm = 0.0;
11278 k = 0; /* used for array indexing. FORTRAN version: k = 1 */
11279
11280 /* store roots isolated by balance, and compute matrix norm */
11281 for (i=0; i<dim; i++)
11282 {
11283 for (j=k; j<dim; j++)
11284 norm += fabs(h[i][j]);
11285
11286 k = i;
11287 if ((i < low) || (i > high))
11288 {
11289 wr[i] = h[i][i];
11290 wi[i] = 0.0;
11291 }
11292 }
11293 en = high;
11294 t = 0.0;
11295 itn = dim * 30;
11296
11297 /* search for next eigenvalues */
11298 while (en >= low) /* changed from an "if (en < lo)" to eliminate a goto statement */
11299 {
11300 its = 0;
11301 na = en - 1;
11302 enm2 = na - 1;
11303 twoRoots = FALSE;
11304
11305 for (;;)
11306 {
11307 for (l=en; l>low; l--) /* changed indexing, got rid of lo, ll */
11308 {
11309 s = fabs(h[l-1][l-1]) + fabs(h[l][l]);
11310 if (AreDoublesEqual(s, 0.0, ETA)==YES) /* == 0.0 */
11311 s = norm;
11312 tst1 = s;
11313 tst2 = tst1 + fabs(h[l][l-1]);
11314 if (fabs(tst2 - tst1) < ETA) /* tst2 == tst1 */
11315 break; /* changed to break to remove a goto statement */
11316 }
11317
11318 /* form shift */
11319 x = h[en][en];
11320 if (l == en) /* changed to break to remove a goto statement */
11321 break;
11322 y = h[na][na];
11323 w = h[en][na] * h[na][en];
11324 if (l == na) /* used to return to other parts of the code */
11325 {
11326 twoRoots = TRUE;
11327 break;
11328 }
11329 if (itn == 0)
11330 return (en);
11331
11332 /* form exceptional shift */
11333 if ((its == 10) || (its == 20)) /* changed to remove a goto statement */
11334 {
11335 t += x;
11336 for (i = low; i <= en; i++)
11337 h[i][i] -= x;
11338 s = fabs(h[en][na]) + fabs(h[na][enm2]);
11339 x = 0.75 * s;
11340 y = x;
11341 w = -0.4375 * s * s;
11342 }
11343 its++;
11344 itn--;
11345
11346 /* look for two consecutive small sub-diagonal elements */
11347 for (m=enm2; m>=l; m--)
11348 {
11349 /* removed m = enm2 + l - mm and above loop to remove variables */
11350 zz = h[m][m];
11351 r = x - zz;
11352 s = y - zz;
11353 p = (r * s - w) / h[m+1][m] + h[m][m+1];
11354 q = h[m+1][m+1] - zz - r - s;
11355 r = h[m+2][m+1];
11356 s = fabs(p) + fabs(q) + fabs(r);
11357 p /= s;
11358 q /= s;
11359 r /= s;
11360 if (m == l)
11361 break; /* changed to break to remove a goto statement */
11362 tst1 = fabs(p) * (fabs(h[m-1][m-1]) + fabs(zz) + fabs(h[m+1][m+1]));
11363 tst2 = tst1 + fabs(h[m][m-1]) * (fabs(q) + fabs(r));
11364 if (fabs(tst2 - tst1) < ETA) /* tst2 == tst1 */
11365 break; /* changed to break to remove a goto statement */
11366 }
11367
11368 mp2 = m + 2;
11369 for (i = mp2; i <= en; i++)
11370 {
11371 h[i][i-2] = 0.0;
11372 if (i != mp2) /* changed "==" to "!=" to remove a goto statement */
11373 h[i][i-3] = 0.0;
11374 }
11375
11376 /* MrBFlt QR step involving rows l to en and columns m to en */
11377 for (k=m; k<=na; k++)
11378 {
11379 notlas = (k != na);
11380 if (k != m) /* changed "==" to "!=" to remove a goto statement */
11381 {
11382 p = h[k][k-1];
11383 q = h[k+1][k-1];
11384 r = 0.0;
11385 if (notlas)
11386 r = h[k+2][k-1];
11387 x = fabs(p) + fabs(q) + fabs(r);
11388 if (x < ETA) /* == 0.0 */
11389 continue; /* changed to continue remove a goto statement */
11390 p /= x;
11391 q /= x;
11392 r /= x;
11393 }
11394
11395 /*s = sqrt(p*p+q*q+r*r);
11396 sgn = (p<0)?-1:(p>0);
11397 s = sgn*sqrt(p*p+q*q+r*r);*/
11398 s = D_sign(sqrt(p*p + q*q + r*r), p);
11399 if (k != m) /* changed "==" to "!=" to remove a goto statement */
11400 h[k][k-1] = -s * x;
11401 else if (l != m) /* else if gets rid of another goto statement */
11402 h[k][k-1] = -h[k][k-1];
11403 p += s;
11404 x = p / s;
11405 y = q / s;
11406 zz = r / s;
11407 q /= p;
11408 r /= p;
11409 if (!notlas) /* changed to !notlas to remove goto statement (see **) */
11410 {
11411 /* row modification */
11412 for (j=k; j<dim; j++)
11413 {
11414 p = h[k][j] + q * h[k+1][j];
11415 h[k][j] -= p * x;
11416 h[k+1][j] -= p * y;
11417 }
11418 j = MIN(en, k + 3);
11419
11420 /* column modification */
11421 for (i=0; i<=j; i++)
11422 {
11423 p = x * h[i][k] + y * h[i][k+1];
11424 h[i][k] -= p;
11425 h[i][k+1] -= p * q;
11426 }
11427
11428 /* accumulate transformations */
11429 for (i=low; i<=high; i++)
11430 {
11431 p = x * z[i][k] + y * z[i][k+1];
11432 z[i][k] -= p;
11433 z[i][k+1] -= p * q;
11434 }
11435 }
11436 else /* (**) also put in else */
11437 {
11438 /* row modification */
11439 for (j=k; j<dim; j++)
11440 {
11441 p = h[k][j] + q * h[k+1][j] + r * h[k+2][j];
11442 h[k][j] -= p * x;
11443 h[k+1][j] -= p * y;
11444 h[k+2][j] -= p * zz;
11445 }
11446 j = MIN(en, k + 3);
11447
11448 /* column modification */
11449 for (i = 0; i <= j; i++)
11450 {
11451 p = x * h[i][k] + y * h[i][k+1] + zz * h[i][k+2];
11452 h[i][k] -= p;
11453 h[i][k+1] -= p * q;
11454 h[i][k+2] -= p * r;
11455 }
11456
11457 /* accumulate transformations */
11458 for (i = low; i <= high; i++)
11459 {
11460 p = x * z[i][k] + y * z[i][k+1] + zz * z[i][k+2];
11461 z[i][k] -= p;
11462 z[i][k+1] -= p * q;
11463 z[i][k+2] -= p * r;
11464 }
11465 }
11466 }
11467 }
11468
11469 if (twoRoots)
11470 {
11471 /* two roots found */
11472 p = (y - x) / 2.0;
11473 q = p * p + w;
11474 zz = sqrt(fabs(q));
11475 h[en][en] = x + t;
11476 x = h[en][en];
11477 h[na][na] = y + t;
11478 if (q >= -1e-12) /* change "<" to ">=", and also change "0.0" to */
11479 { /* a small number (Swofford's change) */
11480 /* real pair */
11481 zz = p + D_sign(zz, p);
11482 wr[na] = x + zz;
11483 wr[en] = wr[na];
11484 if (fabs(zz) > ETA) /* != 0.0 */
11485 wr[en] = x - w/zz;
11486 wi[na] = 0.0;
11487 wi[en] = 0.0;
11488 x = h[en][na];
11489 s = fabs(x) + fabs(zz);
11490 p = x / s;
11491 q = zz / s;
11492 r = sqrt(p*p + q*q);
11493 p /= r;
11494 q /= r;
11495
11496 /* row modification */
11497 for (j=na; j<dim; j++)
11498 {
11499 zz = h[na][j];
11500 h[na][j] = q * zz + p * h[en][j];
11501 h[en][j] = q * h[en][j] - p * zz;
11502 }
11503
11504 /* column modification */
11505 for (i = 0; i <= en; i++)
11506 {
11507 zz = h[i][na];
11508 h[i][na] = q * zz + p * h[i][en];
11509 h[i][en] = q * h[i][en] - p * zz;
11510 }
11511
11512 /* accumulate transformations */
11513 for (i = low; i <= high; i++)
11514 {
11515 zz = z[i][na];
11516 z[i][na] = q * zz + p * z[i][en];
11517 z[i][en] = q * z[i][en] - p * zz;
11518 }
11519 }
11520 else
11521 {
11522 /* complex pair */
11523 wr[na] = x + p;
11524 wr[en] = x + p;
11525 wi[na] = zz;
11526 wi[en] = -zz;
11527 }
11528 en = enm2;
11529 }
11530 else
11531 {
11532 /* one root found */
11533 h[en][en] = x + t;
11534 wr[en] = h[en][en];
11535 wi[en] = 0.0;
11536 en = na;
11537 }
11538 }
11539
11540 if (fabs(norm) < ETA) /* == 0.0 */
11541 return (0); /* was a goto end of function */
11542
11543 for (en=dim-1; en>=0; en--)
11544 {
11545 /*en = n - nn - 1; and change for loop */
11546 p = wr[en];
11547 q = wi[en];
11548 na = en - 1;
11549
11550 if (q < -1e-12)
11551 {
11552 /* last vector component chosen imaginary so that eigenvector
11553 matrix is triangular */
11554 m = na;
11555 if (fabs(h[en][na]) > fabs(h[na][en]))
11556 {
11557 h[na][na] = q / h[en][na];
11558 h[na][en] = -(h[en][en] - p) / h[en][na];
11559 }
11560 else
11561 ComplexDivision2 (0.0, -h[na][en], h[na][na] - p, q, &h[na][na], &h[na][en]);
11562
11563 h[en][na] = 0.0;
11564 h[en][en] = 1.0;
11565 enm2 = na - 1;
11566 if (enm2 >= 0) /* changed direction to remove goto statement */
11567 {
11568 for (i=enm2; i>=0; i--)
11569 {
11570 w = h[i][i] - p;
11571 ra = 0.0;
11572 sa = 0.0;
11573
11574 for (j=m; j<=en; j++)
11575 {
11576 ra += h[i][j] * h[j][na];
11577 sa += h[i][j] * h[j][en];
11578 }
11579
11580 if (wi[i] < 0.0) /* changed direction to remove goto statement */
11581 {
11582 zz = w;
11583 r = ra;
11584 s = sa;
11585 }
11586 else
11587 {
11588 m = i;
11589 if (fabs(wi[i])<ETA) /* == 0.0 */ /* changed direction to remove goto statement */
11590 ComplexDivision2 (-ra, -sa, w, q, &h[i][na], &h[i][en]);
11591 else
11592 {
11593 /* solve complex equations */
11594 x = h[i][i+1];
11595 y = h[i+1][i];
11596 vr = (wr[i] - p) * (wr[i] - p) + wi[i] * wi[i] - q * q;
11597 vi = (wr[i] - p) * 2.0 * q;
11598 if ((fabs(vr)<ETA) && (fabs(vi)<ETA))
11599 {
11600 tst1 = norm * (fabs(w) + fabs(q) + fabs(x) + fabs(y) + fabs(zz));
11601 vr = tst1;
11602 do {
11603 vr *= .01;
11604 tst2 = tst1 + vr;
11605 }
11606 while (tst2 > tst1); /* made into a do/while loop */
11607 }
11608 ComplexDivision2 (x * r - zz * ra + q * sa, x * s - zz * sa - q * ra, vr, vi, &h[i][na], &h[i][en]);
11609 if (fabs(x) > fabs(zz) + fabs(q)) /* changed direction to remove goto statement */
11610 {
11611 h[i+1][na] = (-ra - w * h[i][na] + q * h[i][en]) / x;
11612 h[i+1][en] = (-sa - w * h[i][en] - q * h[i][na]) / x;
11613 }
11614 else
11615 ComplexDivision2 (-r - y * h[i][na], -s - y * h[i][en], zz, q, &h[i+1][na], &h[i+1][en]);
11616 }
11617
11618 /* overflow control */
11619 tst1 = fabs(h[i][na]);
11620 tst2 = fabs(h[i][en]);
11621 t = MAX(tst1, tst2);
11622 if (t > ETA) /* t != 0.0 */
11623 {
11624 tst1 = t;
11625 tst2 = tst1 + 1.0 / tst1;
11626 if (tst2 <= tst1)
11627 {
11628 for (j = i; j <= en; j++)
11629 {
11630 h[j][na] /= t;
11631 h[j][en] /= t;
11632 }
11633 }
11634 }
11635 }
11636 }
11637 }
11638 }
11639 else if (fabs(q)<ETA)
11640 {
11641 /* real vector */
11642 m = en;
11643 h[en][en] = 1.0;
11644 if (na >= 0)
11645 {
11646 for (i=na; i>=0; i--)
11647 {
11648 w = h[i][i] - p;
11649 r = 0.0;
11650 for (j = m; j <= en; j++)
11651 r += h[i][j] * h[j][en];
11652 if (wi[i] < 0.0) /* changed direction to remove goto statement */
11653 {
11654 zz = w;
11655 s = r;
11656 continue; /* changed to continue to remove goto statement */
11657 }
11658 else
11659 {
11660 m = i;
11661 if (fabs(wi[i])<ETA) /* changed to remove goto statement */
11662 {
11663 t = w;
11664 if (fabs(t)<ETA) /* changed to remove goto statement */
11665 {
11666 tst1 = norm;
11667 t = tst1;
11668 do {
11669 t *= .01;
11670 tst2 = norm + t;
11671 }
11672 while (tst2 > tst1);
11673 }
11674 h[i][en] = -r / t;
11675 }
11676 else
11677 {
11678 /* solve real equations */
11679 x = h[i][i+1];
11680 y = h[i+1][i];
11681 q = (wr[i] - p) * (wr[i] - p) + wi[i] * wi[i];
11682 t = (x * s - zz * r) / q;
11683 h[i][en] = t;
11684 if (fabs(x) > fabs(zz)) /* changed direction to remove goto statement */
11685 h[i+1][en] = (-r - w * t) / x;
11686 else
11687 h[i+1][en] = (-s - y * t) / zz;
11688 }
11689
11690 /* overflow control */
11691 t = fabs(h[i][en]);
11692 if (t > ETA)
11693 {
11694 tst1 = t;
11695 tst2 = tst1 + 1. / tst1;
11696 if (tst2 <= tst1)
11697 {
11698 for (j = i; j <= en; j++)
11699 h[j][en] /= t;
11700 }
11701 }
11702 }
11703 }
11704 }
11705 }
11706 }
11707
11708 for (i=0; i<dim; i++)
11709 {
11710 if ((i < low) || (i > high)) /* changed to rid goto statement */
11711 {
11712 for (j=i; j<dim; j++)
11713 z[i][j] = h[i][j];
11714 }
11715 }
11716
11717 /* multiply by transformation matrix to give vectors of original
11718 full matrix */
11719 for (j=dim-1; j>=low; j--)
11720 {
11721 m = MIN(j, high);
11722 for (i=low; i<=high; i++)
11723 {
11724 zz = 0.0;
11725 for (k = low; k <= m; k++)
11726 zz += z[i][k] * h[k][j];
11727 z[i][j] = zz;
11728 }
11729 }
11730
11731 return (0);
11732
11733 #if 0
11734 int hqr2 (int *nm, int *n, int *low, int *igh, MrBFlt *h__, MrBFlt *wr, MrBFlt *wi, MrBFlt *z__, int *ierr)
11735
11736 {
11737
11738 /* system generated locals */
11739 int h_dim1, h_offset, z_dim1, z_offset, i__1, i__2, i__3;
11740 MrBFlt d__1, d__2, d__3, d__4;
11741
11742 /* builtin functions */
11743 MrBFlt sqrt(doublereal), d_sign(doublereal *, doublereal *);
11744
11745 /* Local variables */
11746 static MrBFlt norm;
11747 static int i__, j, k, l, m;
11748 static MrBFlt p, q, r__, s, t, w, x, y;
11749 static int na, ii, en, jj;
11750 static MrBFlt ra, sa;
11751 static int ll, mm, nn;
11752 static MrBFlt vi, vr, zz;
11753 static logical notlas;
11754 static int mp2, itn, its, enm2;
11755 static MrBFlt tst1, tst2;
11756
11757 /* parameter adjustments */
11758 z_dim1 = *nm;
11759 z_offset = z_dim1 + 1;
11760 z__ -= z_offset;
11761 --wi;
11762 --wr;
11763 h_dim1 = *nm;
11764 h_offset = h_dim1 + 1;
11765 h__ -= h_offset;
11766
11767 /* function Body */
11768 *ierr = 0;
11769 norm = 0.;
11770 k = 1;
11771
11772 /* .......... store roots isolated by balanc and compute matrix norm .......... */
11773 i__1 = *n;
11774 for (i__ = 1; i__ <= i__1; ++i__)
11775 {
11776 i__2 = *n;
11777 for (j = k; j <= i__2; ++j)
11778 {
11779 /* L40: */
11780 norm += (d__1 = h__[i__ + j * h_dim1], abs(d__1));
11781 }
11782 k = i__;
11783 if (i__ >= *low && i__ <= *igh)
11784 goto L50;
11785 wr[i__] = h__[i__ + i__ * h_dim1];
11786 wi[i__] = 0.;
11787 L50:
11788 ;
11789 }
11790
11791 en = *igh;
11792 t = 0.;
11793 itn = *n * 30;
11794
11795 /* ..........search for next eigenvalues.......... */
11796 L60:
11797 if (en < *low)
11798 goto L340;
11799 its = 0;
11800 na = en - 1;
11801 enm2 = na - 1;
11802
11803 /* ..........look for single small sub-diagonal element for l=en step -1 until low do -- .......... */
11804 L70:
11805 i__1 = en;
11806 for (ll = *low; ll <= i__1; ++ll)
11807 {
11808 l = en + *low - ll;
11809 if (l == *low)
11810 goto L100;
11811 s = (d__1 = h__[l - 1 + (l - 1) * h_dim1], abs(d__1)) + (d__2 = h__[l + l * h_dim1], abs(d__2));
11812 if (s == 0.0)
11813 s = norm;
11814 tst1 = s;
11815 tst2 = tst1 + (d__1 = h__[l + (l - 1) * h_dim1], abs(d__1));
11816 if (tst2 == tst1)
11817 goto L100;
11818 /* L80: */
11819 }
11820
11821 /* .......... form shift .......... */
11822 L100:
11823 x = h__[en + en * h_dim1];
11824 if (l == en)
11825 goto L270;
11826 y = h__[na + na * h_dim1];
11827 w = h__[en + na * h_dim1] * h__[na + en * h_dim1];
11828 if (l == na)
11829 goto L280;
11830 if (itn == 0)
11831 goto L1000;
11832 if (its != 10 && its != 20)
11833 goto L130;
11834
11835 /* .......... form exceptional shift .......... */
11836 t += x;
11837
11838 i__1 = en;
11839 for (i__ = *low; i__ <= i__1; ++i__)
11840 {
11841 /* L120: */
11842 h__[i__ + i__ * h_dim1] -= x;
11843 }
11844
11845 s = (d__1 = h__[en + na * h_dim1], abs(d__1)) + (d__2 = h__[na + enm2 * h_dim1], abs(d__2));
11846 x = s * 0.75;
11847 y = x;
11848 w = s * -0.4375 * s;
11849 L130:
11850 ++its;
11851 --itn;
11852
11853 /* .......... look for two consecutive small sub-diagonal elements for m=en-2 step -1 until l do -- .......... */
11854 i__1 = enm2;
11855 for (mm = l; mm <= i__1; ++mm)
11856 {
11857 m = enm2 + l - mm;
11858 zz = h__[m + m * h_dim1];
11859 r__ = x - zz;
11860 s = y - zz;
11861 p = (r__ * s - w) / h__[m + 1 + m * h_dim1] + h__[m + (m + 1) * h_dim1];
11862 q = h__[m + 1 + (m + 1) * h_dim1] - zz - r__ - s;
11863 r__ = h__[m + 2 + (m + 1) * h_dim1];
11864 s = abs(p) + abs(q) + abs(r__);
11865 p /= s;
11866 q /= s;
11867 r__ /= s;
11868 if (m == l)
11869 goto L150;
11870 tst1 = abs(p) * ((d__1 = h__[m - 1 + (m - 1) * h_dim1], abs(d__1)) +
11871 abs(zz) + (d__2 = h__[m + 1 + (m + 1) * h_dim1], abs(d__2)));
11872 tst2 = tst1 + (d__1 = h__[m + (m - 1) * h_dim1], abs(d__1)) * (abs(q) + abs(r__));
11873 if (tst2 == tst1)
11874 goto L150;
11875 /* L140: */
11876 }
11877 L150:
11878 mp2 = m + 2;
11879
11880 i__1 = en;
11881 for (i__ = mp2; i__ <= i__1; ++i__)
11882 {
11883 h__[i__ + (i__ - 2) * h_dim1] = 0.0;
11884 if (i__ == mp2)
11885 goto L160;
11886 h__[i__ + (i__ - 3) * h_dim1] = 0.;
11887 L160:
11888 ;
11889 }
11890
11891 /* .......... MrBFlt qr step involving rows l to en and columns m to en .......... */
11892 i__1 = na;
11893 for (k = m; k <= i__1; ++k)
11894 {
11895 notlas = k != na;
11896 if (k == m)
11897 goto L170;
11898 p = h__[k + (k - 1) * h_dim1];
11899 q = h__[k + 1 + (k - 1) * h_dim1];
11900 r__ = 0.;
11901 if (notlas)
11902 r__ = h__[k + 2 + (k - 1) * h_dim1];
11903 x = abs(p) + abs(q) + abs(r__);
11904 if (x == 0.)
11905 goto L260;
11906 p /= x;
11907 q /= x;
11908 r__ /= x;
11909 L170:
11910 d__1 = sqrt(p * p + q * q + r__ * r__);
11911 s = d_sign(&d__1, &p);
11912 if (k == m)
11913 goto L180;
11914 h__[k + (k - 1) * h_dim1] = -s * x;
11915 goto L190;
11916 L180:
11917 if (l != m)
11918 {
11919 h__[k + (k - 1) * h_dim1] = -h__[k + (k - 1) * h_dim1];
11920 }
11921 L190:
11922 p += s;
11923 x = p / s;
11924 y = q / s;
11925 zz = r__ / s;
11926 q /= p;
11927 r__ /= p;
11928 if (notlas)
11929 goto L225;
11930
11931 /* .......... row modification .......... */
11932 i__2 = *n;
11933 for (j = k; j <= i__2; ++j)
11934 {
11935 p = h__[k + j * h_dim1] + q * h__[k + 1 + j * h_dim1];
11936 h__[k + j * h_dim1] -= p * x;
11937 h__[k + 1 + j * h_dim1] -= p * y;
11938 /* L200: */
11939 }
11940
11941 /* computing MIN */
11942 i__2 = en, i__3 = k + 3;
11943 j = min(i__2,i__3);
11944
11945 /* .......... column modification .......... */
11946 i__2 = j;
11947 for (i__ = 1; i__ <= i__2; ++i__)
11948 {
11949 p = x * h__[i__ + k * h_dim1] + y * h__[i__ + (k + 1) * h_dim1];
11950 h__[i__ + k * h_dim1] -= p;
11951 h__[i__ + (k + 1) * h_dim1] -= p * q;
11952 /* L210: */
11953 }
11954
11955 /* .......... accumulate transformations .......... */
11956 i__2 = *igh;
11957 for (i__ = *low; i__ <= i__2; ++i__)
11958 {
11959 p = x * z__[i__ + k * z_dim1] + y * z__[i__ + (k + 1) * z_dim1];
11960 z__[i__ + k * z_dim1] -= p;
11961 z__[i__ + (k + 1) * z_dim1] -= p * q;
11962 /* L220: */
11963 }
11964 goto L255;
11965 L225:
11966
11967 /* .......... row modification .......... */
11968 i__2 = *n;
11969 for (j = k; j <= i__2; ++j)
11970 {
11971 p = h__[k + j * h_dim1] + q * h__[k + 1 + j * h_dim1] + r__ * h__[k + 2 + j * h_dim1];
11972 h__[k + j * h_dim1] -= p * x;
11973 h__[k + 1 + j * h_dim1] -= p * y;
11974 h__[k + 2 + j * h_dim1] -= p * zz;
11975 /* L230: */
11976 }
11977
11978 /* computing MIN */
11979 i__2 = en, i__3 = k + 3;
11980 j = min(i__2,i__3);
11981
11982 /* .......... column modification .......... */
11983 i__2 = j;
11984 for (i__ = 1; i__ <= i__2; ++i__)
11985 {
11986 p = x * h__[i__ + k * h_dim1] + y * h__[i__ + (k + 1) * h_dim1] +
11987 zz * h__[i__ + (k + 2) * h_dim1];
11988 h__[i__ + k * h_dim1] -= p;
11989 h__[i__ + (k + 1) * h_dim1] -= p * q;
11990 h__[i__ + (k + 2) * h_dim1] -= p * r__;
11991 /* L240: */
11992 }
11993
11994 /* .......... accumulate transformations .......... */
11995 i__2 = *igh;
11996 for (i__ = *low; i__ <= i__2; ++i__)
11997 {
11998 p = x * z__[i__ + k * z_dim1] + y * z__[i__ + (k + 1) * z_dim1] + zz * z__[i__ + (k + 2) * z_dim1];
11999 z__[i__ + k * z_dim1] -= p;
12000 z__[i__ + (k + 1) * z_dim1] -= p * q;
12001 z__[i__ + (k + 2) * z_dim1] -= p * r__;
12002 /* L250: */
12003 }
12004 L255:
12005 L260:
12006 ;
12007 }
12008 goto L70;
12009
12010 /* .......... one root found .......... */
12011 L270:
12012 h__[en + en * h_dim1] = x + t;
12013 wr[en] = h__[en + en * h_dim1];
12014 wi[en] = 0.;
12015 en = na;
12016 goto L60;
12017
12018 /* .......... two roots found .......... */
12019 L280:
12020 p = (y - x) / 2.;
12021 q = p * p + w;
12022 zz = sqrt((abs(q)));
12023 h__[en + en * h_dim1] = x + t;
12024 x = h__[en + en * h_dim1];
12025 h__[na + na * h_dim1] = y + t;
12026 if (q < 0.)
12027 goto L320;
12028
12029 /* .......... real pair .......... */
12030 zz = p + d_sign(&zz, &p);
12031 wr[na] = x + zz;
12032 wr[en] = wr[na];
12033 if (zz != 0.)
12034 {
12035 wr[en] = x - w / zz;
12036 }
12037 wi[na] = 0.0;
12038 wi[en] = 0.0;
12039 x = h__[en + na * h_dim1];
12040 s = abs(x) + abs(zz);
12041 p = x / s;
12042 q = zz / s;
12043 r__ = sqrt(p * p + q * q);
12044 p /= r__;
12045 q /= r__;
12046
12047 /* .......... row modification .......... */
12048 i__1 = *n;
12049 for (j = na; j <= i__1; ++j)
12050 {
12051 zz = h__[na + j * h_dim1];
12052 h__[na + j * h_dim1] = q * zz + p * h__[en + j * h_dim1];
12053 h__[en + j * h_dim1] = q * h__[en + j * h_dim1] - p * zz;
12054 /* L290: */
12055 }
12056
12057 /* .......... column modification .......... */
12058 i__1 = en;
12059 for (i__ = 1; i__ <= i__1; ++i__)
12060 {
12061 zz = h__[i__ + na * h_dim1];
12062 h__[i__ + na * h_dim1] = q * zz + p * h__[i__ + en * h_dim1];
12063 h__[i__ + en * h_dim1] = q * h__[i__ + en * h_dim1] - p * zz;
12064 /* L300: */
12065 }
12066
12067 /* .......... accumulate transformations .......... */
12068 i__1 = *igh;
12069 for (i__ = *low; i__ <= i__1; ++i__)
12070 {
12071 zz = z__[i__ + na * z_dim1];
12072 z__[i__ + na * z_dim1] = q * zz + p * z__[i__ + en * z_dim1];
12073 z__[i__ + en * z_dim1] = q * z__[i__ + en * z_dim1] - p * zz;
12074 /* L310: */
12075 }
12076 goto L330;
12077
12078 /* .......... complex pair .......... */
12079 L320:
12080 wr[na] = x + p;
12081 wr[en] = x + p;
12082 wi[na] = zz;
12083 wi[en] = -zz;
12084 L330:
12085 en = enm2;
12086 goto L60;
12087
12088 /* .......... all roots found. backsubstitute to find vectors of upper triangular form .......... */
12089 L340:
12090 if (norm == 0.0)
12091 goto L1001;
12092
12093 /* .......... for en=n step -1 until 1 do -- .......... */
12094 i__1 = *n;
12095 for (nn = 1; nn <= i__1; ++nn)
12096 {
12097 en = *n + 1 - nn;
12098 p = wr[en];
12099 q = wi[en];
12100 na = en - 1;
12101 if (q < 0.)
12102 goto L710;
12103 else if (q == 0)
12104 goto L600;
12105 else
12106 goto L800;
12107
12108 /* .......... real vector .......... */
12109 L600:
12110 m = en;
12111 h__[en + en * h_dim1] = 1.0;
12112 if (na == 0)
12113 goto L800;
12114
12115 /* .......... for i=en-1 step -1 until 1 do -- .......... */
12116 i__2 = na;
12117 for (ii = 1; ii <= i__2; ++ii)
12118 {
12119 i__ = en - ii;
12120 w = h__[i__ + i__ * h_dim1] - p;
12121 r__ = 0.0;
12122
12123 i__3 = en;
12124 for (j = m; j <= i__3; ++j)
12125 {
12126 /* L610: */
12127 r__ += h__[i__ + j * h_dim1] * h__[j + en * h_dim1];
12128 }
12129
12130 if (wi[i__] >= 0.0)
12131 goto L630;
12132 zz = w;
12133 s = r__;
12134 goto L700;
12135 L630:
12136 m = i__;
12137 if (wi[i__] != 0.0)
12138 goto L640;
12139 t = w;
12140 if (t != 0.0)
12141 goto L635;
12142 tst1 = norm;
12143 t = tst1;
12144 L632:
12145 t *= 0.01;
12146 tst2 = norm + t;
12147 if (tst2 > tst1)
12148 goto L632;
12149 L635:
12150 h__[i__ + en * h_dim1] = -r__ / t;
12151 goto L680;
12152
12153 /* .......... solve real equations .......... */
12154 L640:
12155 x = h__[i__ + (i__ + 1) * h_dim1];
12156 y = h__[i__ + 1 + i__ * h_dim1];
12157 q = (wr[i__] - p) * (wr[i__] - p) + wi[i__] * wi[i__];
12158 t = (x * s - zz * r__) / q;
12159 h__[i__ + en * h_dim1] = t;
12160 if (abs(x) <= abs(zz))
12161 goto L650;
12162 h__[i__ + 1 + en * h_dim1] = (-r__ - w * t) / x;
12163 goto L680;
12164 L650:
12165 h__[i__ + 1 + en * h_dim1] = (-s - y * t) / zz;
12166
12167 /* .......... overflow control .......... */
12168 L680:
12169 t = (d__1 = h__[i__ + en * h_dim1], abs(d__1));
12170 if (t == 0.0)
12171 goto L700;
12172 tst1 = t;
12173 tst2 = tst1 + 1.0 / tst1;
12174 if (tst2 > tst1)
12175 goto L700;
12176 i__3 = en;
12177 for (j = i__; j <= i__3; ++j)
12178 {
12179 h__[j + en * h_dim1] /= t;
12180 /* L690: */
12181 }
12182
12183 L700:
12184 ;
12185 }
12186
12187 /* .......... end real vector .......... */
12188 goto L800;
12189
12190 /* .......... complex vector .......... */
12191 L710:
12192 m = na;
12193
12194 /* .......... last vector component chosen imaginary so that eigenvector matrix is triangular .......... */
12195 if ((d__1 = h__[en + na * h_dim1], abs(d__1)) <= (d__2 = h__[na + en *
12196 h_dim1], abs(d__2)))
12197 goto L720;
12198 h__[na + na * h_dim1] = q / h__[en + na * h_dim1];
12199 h__[na + en * h_dim1] = -(h__[en + en * h_dim1] - p) / h__[en + na * h_dim1];
12200 goto L730;
12201 L720:
12202 d__1 = -h__[na + en * h_dim1];
12203 d__2 = h__[na + na * h_dim1] - p;
12204 cdiv_(&c_b49, &d__1, &d__2, &q, &h__[na + na * h_dim1], &h__[na + en *
12205 h_dim1]);
12206 L730:
12207 h__[en + na * h_dim1] = 0.0;
12208 h__[en + en * h_dim1] = 1.0;
12209 enm2 = na - 1;
12210 if (enm2 == 0)
12211 goto L800;
12212
12213 /* .......... for i=en-2 step -1 until 1 do -- .......... */
12214 i__2 = enm2;
12215 for (ii = 1; ii <= i__2; ++ii)
12216 {
12217 i__ = na - ii;
12218 w = h__[i__ + i__ * h_dim1] - p;
12219 ra = 0.0;
12220 sa = 0.0;
12221
12222 i__3 = en;
12223 for (j = m; j <= i__3; ++j)
12224 {
12225 ra += h__[i__ + j * h_dim1] * h__[j + na * h_dim1];
12226 sa += h__[i__ + j * h_dim1] * h__[j + en * h_dim1];
12227 /* L760: */
12228 }
12229
12230 if (wi[i__] >= 0.0)
12231 goto L770;
12232 zz = w;
12233 r__ = ra;
12234 s = sa;
12235 goto L795;
12236 L770:
12237 m = i__;
12238 if (wi[i__] != 0.0)
12239 goto L780;
12240 d__1 = -ra;
12241 d__2 = -sa;
12242 cdiv_(&d__1, &d__2, &w, &q, &h__[i__ + na * h_dim1], &h__[i__ + en * h_dim1]);
12243 goto L790;
12244
12245 /* .......... solve complex equations .......... */
12246 L780:
12247 x = h__[i__ + (i__ + 1) * h_dim1];
12248 y = h__[i__ + 1 + i__ * h_dim1];
12249 vr = (wr[i__] - p) * (wr[i__] - p) + wi[i__] * wi[i__] - q * q;
12250 vi = (wr[i__] - p) * 2.0 * q;
12251 if (vr != 0.0 || vi != 0.0)
12252 goto L784;
12253 tst1 = norm * (abs(w) + abs(q) + abs(x) + abs(y) + abs(zz));
12254 vr = tst1;
12255 L783:
12256 vr *= 0.01;
12257 tst2 = tst1 + vr;
12258 if (tst2 > tst1)
12259 goto L783;
12260 L784:
12261 d__1 = x * r__ - zz * ra + q * sa;
12262 d__2 = x * s - zz * sa - q * ra;
12263 cdiv_(&d__1, &d__2, &vr, &vi, &h__[i__ + na * h_dim1], &h__[i__ + en * h_dim1]);
12264 if (abs(x) <= abs(zz) + abs(q))
12265 goto L785;
12266 h__[i__ + 1 + na * h_dim1] = (-ra - w * h__[i__ + na * h_dim1] + q * h__[i__ + en * h_dim1]) / x;
12267 h__[i__ + 1 + en * h_dim1] = (-sa - w * h__[i__ + en * h_dim1] - q * h__[i__ + na * h_dim1]) / x;
12268 goto L790;
12269 L785:
12270 d__1 = -r__ - y * h__[i__ + na * h_dim1];
12271 d__2 = -s - y * h__[i__ + en * h_dim1];
12272 cdiv_(&d__1, &d__2, &zz, &q, &h__[i__ + 1 + na * h_dim1], &h__[i__ + 1 + en * h_dim1]);
12273
12274 /* .......... overflow control .......... */
12275 L790:
12276 /* Computing MAX */
12277 d__3 = (d__1 = h__[i__ + na * h_dim1], abs(d__1)), d__4 = (d__2 = h__[i__ + en * h_dim1], abs(d__2));
12278 t = max(d__3,d__4);
12279 if (t == 0.0)
12280 goto L795;
12281 tst1 = t;
12282 tst2 = tst1 + 1.0 / tst1;
12283 if (tst2 > tst1)
12284 goto L795;
12285 i__3 = en;
12286 for (j = i__; j <= i__3; ++j)
12287 {
12288 h__[j + na * h_dim1] /= t;
12289 h__[j + en * h_dim1] /= t;
12290 /* L792: */
12291 }
12292 L795:
12293 ;
12294 }
12295 /* .......... end complex vector .......... */
12296 L800:
12297 ;
12298 }
12299 /* .......... end back substitution vectors of isolated roots .......... */
12300 i__1 = *n;
12301 for (i__ = 1; i__ <= i__1; ++i__)
12302 {
12303 if (i__ >= *low && i__ <= *igh)
12304 goto L840;
12305 i__2 = *n;
12306 for (j = i__; j <= i__2; ++j)
12307 {
12308 /* L820: */
12309 z__[i__ + j * z_dim1] = h__[i__ + j * h_dim1];
12310 }
12311 L840:
12312 ;
12313 }
12314
12315 /* .......... multiply by transformation matrix to give vectors of original full matrix. */
12316 /* for j=n step -1 until low do -- .......... */
12317 i__1 = *n;
12318 for (jj = *low; jj <= i__1; ++jj)
12319 {
12320 j = *n + *low - jj;
12321 m = min(j,*igh);
12322
12323 i__2 = *igh;
12324 for (i__ = *low; i__ <= i__2; ++i__)
12325 {
12326 zz = 0.0;
12327 i__3 = m;
12328 for (k = *low; k <= i__3; ++k)
12329 {
12330 /* L860: */
12331 zz += z__[i__ + k * z_dim1] * h__[k + j * h_dim1];
12332 }
12333
12334 z__[i__ + j * z_dim1] = zz;
12335 /* L880: */
12336 }
12337 }
12338
12339 goto L1001;
12340 /* .......... set error -- all eigenvalues have not converged after 30*n iterations .......... */
12341 L1000:
12342 *ierr = en;
12343 L1001:
12344 return 0;
12345
12346 }
12347 /* end f2c version of code */
12348 #endif
12349
12350 }
12351
12352
IncompleteBetaFunction(MrBFlt alpha,MrBFlt beta,MrBFlt x)12353 MrBFlt IncompleteBetaFunction (MrBFlt alpha, MrBFlt beta, MrBFlt x)
12354 {
12355 MrBFlt bt, gm1, gm2, gm3, temp;
12356
12357 if (x < 0.0 || x > 1.0)
12358 {
12359 MrBayesPrint ("%s Error: Problem in IncompleteBetaFunction.\n", spacer);
12360 exit (0);
12361 }
12362 if (fabs(x) < ETA || fabs(x-1.0)<ETA) /* x == 0.0 || x == 1.0 */
12363 {
12364 bt = 0.0;
12365 }
12366 else
12367 {
12368 gm1 = LnGamma (alpha + beta);
12369 gm2 = LnGamma (alpha);
12370 gm3 = LnGamma (beta);
12371 temp = gm1 - gm2 - gm3 + (alpha) * log(x) + (beta) * log(1.0 - x);
12372 bt = exp(temp);
12373 }
12374 if (x < (alpha + 1.0)/(alpha + beta + 2.0))
12375 return (bt * BetaCf(alpha, beta, x) / alpha);
12376 else
12377 return (1.0 - bt * BetaCf(beta, alpha, 1.0-x) / beta);
12378 }
12379
12380
12381 /*---------------------------------------------------------------------------------
12382 |
12383 | IncompleteGamma
12384 |
12385 | Returns the incomplete gamma ratio I(x,alpha) where x is the upper
12386 | limit of the integration and alpha is the shape parameter. Returns (-1)
12387 | if in error.
12388 |
12389 | Bhattacharjee, G. P. 1970. The incomplete gamma integral. Applied
12390 | Statistics, 19:285-287 (AS32)
12391 |
12392 ---------------------------------------------------------------------------------*/
IncompleteGamma(MrBFlt x,MrBFlt alpha,MrBFlt LnGamma_alpha)12393 MrBFlt IncompleteGamma (MrBFlt x, MrBFlt alpha, MrBFlt LnGamma_alpha)
12394 {
12395 int i;
12396 MrBFlt p = alpha, g = LnGamma_alpha,
12397 accurate = 1e-8, overflow = 1e30,
12398 factor, gin = 0.0, rn = 0.0, a = 0.0, b = 0.0, an = 0.0,
12399 dif = 0.0, term = 0.0, pn[6];
12400
12401 if (fabs(x) < ETA)
12402 return (0.0);
12403 if (x < 0 || p <= 0)
12404 return (-1.0);
12405
12406 factor = exp(p*log(x)-x-g);
12407 if (x>1 && x>=p)
12408 goto l30;
12409 gin = 1.0;
12410 term = 1.0;
12411 rn = p;
12412 l20:
12413 rn++;
12414 term *= x/rn;
12415 gin += term;
12416 if (term > accurate)
12417 goto l20;
12418 gin *= factor/p;
12419 goto l50;
12420 l30:
12421 a = 1.0-p;
12422 b = a+x+1.0;
12423 term = 0.0;
12424 pn[0] = 1.0;
12425 pn[1] = x;
12426 pn[2] = x+1;
12427 pn[3] = x*b;
12428 gin = pn[2]/pn[3];
12429 l32:
12430 a++;
12431 b += 2.0;
12432 term++;
12433 an = a*term;
12434 for (i=0; i<2; i++)
12435 pn[i+4] = b*pn[i+2]-an*pn[i];
12436 if (fabs(pn[5]) < ETA)
12437 goto l35;
12438 rn = pn[4]/pn[5];
12439 dif = fabs(gin-rn);
12440 if (dif>accurate)
12441 goto l34;
12442 if (dif<=accurate*rn)
12443 goto l42;
12444 l34:
12445 gin = rn;
12446 l35:
12447 for (i=0; i<4; i++)
12448 pn[i] = pn[i+2];
12449 if (fabs(pn[4]) < overflow)
12450 goto l32;
12451 for (i=0; i<4; i++)
12452 pn[i] /= overflow;
12453 goto l32;
12454 l42:
12455 gin = 1.0-factor*gin;
12456 l50:
12457 return (gin);
12458 }
12459
12460
12461 /*---------------------------------------------------------------------------------
12462 |
12463 | InvertMatrix
12464 |
12465 | Calculates aInv = a^{-1} using LU-decomposition. The input matrix a is
12466 | destroyed in the process. The program returns an error if the matrix is
12467 | singular. col and indx are work vectors.
12468 |
12469 ---------------------------------------------------------------------------------*/
InvertMatrix(int dim,MrBFlt ** a,MrBFlt * col,int * indx,MrBFlt ** aInv)12470 int InvertMatrix (int dim, MrBFlt **a, MrBFlt *col, int *indx, MrBFlt **aInv)
12471 {
12472 int rc, i, j;
12473
12474 rc = LUDecompose (dim, a, col, indx, (MrBFlt *)NULL);
12475 if (rc == FALSE)
12476 {
12477 for (j = 0; j < dim; j++)
12478 {
12479 for (i = 0; i < dim; i++)
12480 col[i] = 0.0;
12481 col[j] = 1.0;
12482 LUBackSubstitution (dim, a, indx, col);
12483 for (i = 0; i < dim; i++)
12484 aInv[i][j] = col[i];
12485 }
12486 }
12487
12488 return (rc);
12489 }
12490
12491
12492 /*---------------------------------------------------------------------------------
12493 |
12494 | LBinormal
12495 |
12496 | L(h1,h2,r) = prob(x>h1, y>h2), where x and y are standard binormal,
12497 | with r=corr(x,y), error < 2e-7.
12498 |
12499 | Drezner Z., and G.O. Wesolowsky (1990) On the computation of the
12500 | bivariate normal integral. J. Statist. Comput. Simul. 35:101-107.
12501 |
12502 ---------------------------------------------------------------------------------*/
LBinormal(MrBFlt h1,MrBFlt h2,MrBFlt r)12503 MrBFlt LBinormal (MrBFlt h1, MrBFlt h2, MrBFlt r)
12504 {
12505 int i;
12506 MrBFlt x[]={0.04691008, 0.23076534, 0.5, 0.76923466, 0.95308992};
12507 MrBFlt w[]={0.018854042, 0.038088059, 0.0452707394,0.038088059,0.018854042};
12508 MrBFlt Lh=0.0, r1, r2, r3, rr, aa, ab, h3, h5, h6, h7, h12, temp1, temp2, exp1, exp2;
12509
12510 h12 = (h1 * h1 + h2 * h2) / 2.0;
12511 if (fabs(r) >= 0.7)
12512 {
12513 r2 = 1.0 - r * r;
12514 r3 = sqrt(r2);
12515 if (r < 0)
12516 h2 *= -1;
12517 h3 = h1 * h2;
12518 h7 = exp(-h3 / 2.0);
12519 if (fabs(r-1.0)>ETA) /* fabs(r) != 1.0 */
12520 {
12521 h6 = fabs(h1-h2);
12522 h5 = h6 * h6 / 2.0;
12523 h6 /= r3;
12524 aa = 0.5 - h3 / 8;
12525 ab = 3.0 - 2.0 * aa * h5;
12526 temp1 = -h5 / r2;
12527 if (temp1 < -100.0)
12528 exp1 = 0.0;
12529 else
12530 exp1 = exp(temp1);
12531 Lh = 0.13298076 * h6 * ab * (1.0 - CdfNormal(h6)) - exp1 * (ab + aa * r2) * 0.053051647;
12532 for (i=0; i<5; i++)
12533 {
12534 r1 = r3 * x[i];
12535 rr = r1 * r1;
12536 r2 = sqrt(1.0 - rr);
12537 temp1 = -h5 / rr;
12538 if (temp1 < -100.0)
12539 exp1 = 0.0;
12540 else
12541 exp1 = exp(temp1);
12542 temp2 = -h3 / (1.0 + r2);
12543 if (temp2 < -100.0)
12544 exp2 = 0.0;
12545 else
12546 exp2 = exp(temp2);
12547 Lh -= w[i] * exp1 * (exp2 / r2 / h7 - 1.0 - aa * rr);
12548 }
12549 }
12550 if (r > 0)
12551 Lh = Lh * r3 * h7 + (1.0 - CdfNormal(MAX(h1, h2)));
12552 else if (r<0)
12553 Lh = (h1 < h2 ? CdfNormal(h2) - CdfNormal(h1) : 0) - Lh * r3 * h7;
12554 }
12555 else
12556 {
12557 h3 = h1 * h2;
12558 if (fabs(r)>ETA)
12559 {
12560 for (i=0; i<5; i++)
12561 {
12562 r1 = r * x[i];
12563 r2 = 1.0 - r1 * r1;
12564 temp1 = (r1 * h3 - h12) / r2;
12565 if (temp1 < -100.0)
12566 exp1 = 0.0;
12567 else
12568 exp1 = exp(temp1);
12569 Lh += w[i] * exp1 / sqrt(r2);
12570 }
12571 }
12572 Lh = (1.0 - CdfNormal(h1)) * (1.0 - CdfNormal(h2)) + r * Lh;
12573 }
12574 return (Lh);
12575 }
12576
12577
12578 /*---------------------------------------------------------------------------------
12579 |
12580 | LnFactorial: Calculates the log of the factorial for an integer
12581 |
12582 ---------------------------------------------------------------------------------*/
LnFactorial(int value)12583 MrBFlt LnFactorial (int value)
12584 {
12585 int i;
12586 MrBFlt result;
12587
12588 result = 0.0;
12589
12590 for (i = 2; i<=value; i++)
12591 result += log(i);
12592
12593 return result;
12594 }
12595
12596
12597 /*---------------------------------------------------------------------------------
12598 |
12599 | LnGamma
12600 |
12601 | Calculates the log of the gamma function. The Gamma function is equal
12602 | to:
12603 |
12604 | Gamma(alp) = {integral from 0 to infinity} t^{alp-1} e^-t dt
12605 |
12606 | The result is accurate to 10 decimal places. Stirling's formula is used
12607 | for the central polynomial part of the procedure.
12608 |
12609 | Pike, M. C. and I. D. Hill. 1966. Algorithm 291: Logarithm of the gamma
12610 | function. Communications of the Association for Computing
12611 | Machinery, 9:684.
12612 |
12613 ---------------------------------------------------------------------------------*/
LnGamma(MrBFlt alp)12614 MrBFlt LnGamma (MrBFlt alp)
12615 {
12616 MrBFlt x = alp, f = 0.0, z;
12617
12618 if (x < 7)
12619 {
12620 f = 1.0;
12621 z = x-1.0;
12622 while (++z < 7.0)
12623 f *= z;
12624 x = z;
12625 f = -log(f);
12626 }
12627 z = 1.0 / (x*x);
12628 return (f + (x-0.5)*log(x) - x + 0.918938533204673 +
12629 (((-0.000595238095238*z+0.000793650793651)*z-0.002777777777778)*z +0.083333333333333)/x);
12630 }
12631
12632
12633 /* Calculate probability of a realization for exponential random variable */
LnPriorProbExponential(MrBFlt val,MrBFlt * params)12634 MrBFlt LnPriorProbExponential (MrBFlt val, MrBFlt *params)
12635 {
12636 return log(params[0]) - params[0] * val;
12637 }
12638
12639
12640 /* Calculate probability of a realization for exponential random variable; parameter mean and not rate */
LnPriorProbExponential_Param_Mean(MrBFlt val,MrBFlt * params)12641 MrBFlt LnPriorProbExponential_Param_Mean (MrBFlt val, MrBFlt *params)
12642 {
12643 return - log(params[0]) - val / params[0];
12644 }
12645
12646
12647 /* Calculate probability of a realization for a fixed variable */
LnPriorProbFix(MrBFlt val,MrBFlt * params)12648 MrBFlt LnPriorProbFix (MrBFlt val, MrBFlt *params)
12649 {
12650 if (fabs((val - params[0])/val) < 1E-5)
12651 return 0.0;
12652 else
12653 return NEG_INFINITY;
12654 }
12655
12656
12657 /* Calculate probability of a realization for gamma random variable */
LnPriorProbGamma(MrBFlt val,MrBFlt * params)12658 MrBFlt LnPriorProbGamma (MrBFlt val, MrBFlt *params)
12659 {
12660 return (params[0] - 1) * log(val) + params[0] * log(params[1]) - params[1] * val - LnGamma(params[0]);
12661 }
12662
12663
12664 /* Calculate probability of a realization for gamma random variable; parameters mean and sd */
LnPriorProbGamma_Param_Mean_Sd(MrBFlt val,MrBFlt * params)12665 MrBFlt LnPriorProbGamma_Param_Mean_Sd (MrBFlt val, MrBFlt *params)
12666 {
12667 MrBFlt alpha, beta;
12668
12669 beta = params[0] / (params[1]*params[1]);
12670 alpha = params[0] * beta;
12671
12672 return (alpha - 1) * log(val) + alpha * log(beta) - beta * val - LnGamma(alpha);
12673 }
12674
12675
12676 /* Calculate probability of a realization for lognormal random variable */
LnPriorProbLognormal(MrBFlt val,MrBFlt * params)12677 MrBFlt LnPriorProbLognormal (MrBFlt val, MrBFlt *params)
12678 {
12679 MrBFlt z;
12680
12681 z = (log(val) - params[0]) / params[1];
12682
12683 return - log(params[1] * val * sqrt(2.0 * M_PI)) - z * z / 2.0;
12684 }
12685
12686
12687 /* Calculate probability of a realization for lognormal random variable; parameters mean and sd on linear scale */
LnPriorProbLognormal_Param_Mean_Sd(MrBFlt val,MrBFlt * params)12688 MrBFlt LnPriorProbLognormal_Param_Mean_Sd (MrBFlt val, MrBFlt *params)
12689 {
12690 MrBFlt z, mean_log, sd_log;
12691
12692 sd_log = sqrt (log((params[1]*params[1])/(params[0]*params[0]) + 1));
12693 mean_log = log(params[0]) - sd_log * sd_log / 2.0;
12694
12695 z= (log(val) - mean_log) / sd_log;
12696
12697 return - log(sd_log * val * sqrt(2.0 * M_PI)) - z * z / 2.0;
12698 }
12699
12700
12701 /* Calculate probability of a realization for normal random variable */
LnPriorProbNormal(MrBFlt val,MrBFlt * params)12702 MrBFlt LnPriorProbNormal (MrBFlt val, MrBFlt *params)
12703 {
12704 MrBFlt z;
12705
12706 z = (val - params[0]) / params[1];
12707
12708 return - log(params[1] * sqrt(2.0 * M_PI)) - z * z / 2.0;
12709 }
12710
12711
12712 /* Calculate probability of a realization for an offset exponential random variable */
LnPriorProbOffsetExponential(MrBFlt val,MrBFlt * params)12713 MrBFlt LnPriorProbOffsetExponential (MrBFlt val, MrBFlt *params)
12714 {
12715 return log(params[1]) - params[1] * (val - params[0]);
12716 }
12717
12718
12719 /* Calculate probability of a realization for an offset exponential random variable; parameters offset and mean */
LnPriorProbOffsetExponential_Param_Offset_Mean(MrBFlt val,MrBFlt * params)12720 MrBFlt LnPriorProbOffsetExponential_Param_Offset_Mean (MrBFlt val, MrBFlt *params)
12721 {
12722 MrBFlt x, rate;
12723
12724 x = val - params[0];
12725 rate = 1.0 / (params[1] - params[0]);
12726
12727 return log(rate) - rate * x;
12728 }
12729
12730
12731 /* Calculate probability of a realization for an offset gamma random variable */
LnPriorProbOffsetGamma(MrBFlt val,MrBFlt * params)12732 MrBFlt LnPriorProbOffsetGamma (MrBFlt val, MrBFlt *params)
12733 {
12734 MrBFlt x, alpha, beta;
12735
12736 x = val - params[0];
12737 alpha = params[1];
12738 beta = params[2];
12739
12740 return (alpha - 1) * log(x) + alpha * log(beta) - beta * x - LnGamma(alpha);
12741 }
12742
12743
12744 /* Calculate probability of a realization for an offset gamma random variable; parameters offset, mean and sd */
LnPriorProbOffsetGamma_Param_Offset_Mean_Sd(MrBFlt val,MrBFlt * params)12745 MrBFlt LnPriorProbOffsetGamma_Param_Offset_Mean_Sd (MrBFlt val, MrBFlt *params)
12746 {
12747 MrBFlt x, mean, sd, alpha, beta;
12748
12749 x = val - params[0];
12750 mean = params[1] - params[0];
12751 sd = params[2];
12752
12753 beta = mean / (sd*sd);
12754 alpha = mean * beta;
12755
12756 return (alpha - 1) * log(x) + alpha * log(beta) - beta * x - LnGamma(alpha);
12757 }
12758
12759
12760 /* Calculate probability of a realization for an offset lognormal random variable */
LnPriorProbOffsetLognormal(MrBFlt val,MrBFlt * params)12761 MrBFlt LnPriorProbOffsetLognormal (MrBFlt val, MrBFlt *params)
12762 {
12763 MrBFlt x, mean_log, sd_log, z;
12764
12765 x = val - params[0];
12766 mean_log = params[1] - params[0];
12767 sd_log = params[2];
12768
12769 z = (log(x) - mean_log) / sd_log;
12770
12771 return - log(sd_log * x * sqrt(2.0 * M_PI)) - z * z / 2.0;
12772 }
12773
12774
12775 /* Calculate probability of a realization for an offset lognormal random variable; parameters offset, mean and sd */
LnPriorProbOffsetLognormal_Param_Offset_Mean_Sd(MrBFlt val,MrBFlt * params)12776 MrBFlt LnPriorProbOffsetLognormal_Param_Offset_Mean_Sd (MrBFlt val, MrBFlt *params)
12777 {
12778 MrBFlt x, mean, sd, mean_log, sd_log, z;
12779
12780 x = val - params[0];
12781 mean = params[1] - params[0];
12782 sd = params[2];
12783 sd_log = sqrt (log((sd*sd)/(mean*mean) + 1));
12784 mean_log = log(mean) - sd_log * sd_log / 2.0;
12785
12786 z = (log(x) - mean_log) / sd_log;
12787
12788 return - log(sd_log * x * sqrt(2.0 * M_PI)) - z * z / 2.0;
12789 }
12790
12791
12792 /* Calculate probability of a realization for truncated (only positive values) normal random variable */
LnPriorProbTruncatedNormal(MrBFlt val,MrBFlt * params)12793 MrBFlt LnPriorProbTruncatedNormal (MrBFlt val, MrBFlt *params)
12794 {
12795 MrBFlt z, z_0, normConst;
12796
12797 z = (val - params[0]) / params[1];
12798 z_0 = (0.0 - params[0]) / params[1];
12799 normConst = CdfNormal(z_0);
12800
12801 return - log(params[1] * sqrt(2.0 * M_PI)) - z * z / 2.0 - log(1.0 - normConst);
12802 }
12803
12804
12805 /* Calculate probability of a realization for arbitrarily truncated normal random variable; parameters truncation point, mean and sd */
LnPriorProbTruncatedNormal_Param_Trunc_Mean_Sd(MrBFlt val,MrBFlt * params)12806 MrBFlt LnPriorProbTruncatedNormal_Param_Trunc_Mean_Sd (MrBFlt val, MrBFlt *params)
12807 {
12808 MrBFlt z, z_trunc, normConst;
12809
12810 z = (val - params[1]) / params[2];
12811 z_trunc = (params[0] - params[1]) / params[2];
12812 normConst = CdfNormal(z_trunc);
12813
12814 return - log(params[2] * sqrt(2.0 * M_PI)) - z * z / 2.0 - log(1.0 - normConst);
12815 }
12816
12817
12818 /* Calculate probability of a realization for uniform random variable */
LnPriorProbUniform(MrBFlt val,MrBFlt * params)12819 MrBFlt LnPriorProbUniform (MrBFlt val, MrBFlt *params)
12820 {
12821 return - log(params[1] - params[0]);
12822 }
12823
12824
12825 /* Calculate probability ratio of realizations for exponential random variable */
LnProbRatioExponential(MrBFlt newX,MrBFlt oldX,MrBFlt * params)12826 MrBFlt LnProbRatioExponential (MrBFlt newX, MrBFlt oldX, MrBFlt *params)
12827 {
12828 return params[0] * (oldX - newX);
12829 }
12830
12831
12832 /* Calculate probability ratio of realizations for exponential random variable; parameter mean and not rate */
LnProbRatioExponential_Param_Mean(MrBFlt newX,MrBFlt oldX,MrBFlt * params)12833 MrBFlt LnProbRatioExponential_Param_Mean (MrBFlt newX, MrBFlt oldX, MrBFlt *params)
12834 {
12835 return (oldX - newX) / params[0];
12836 }
12837
12838
12839 /* Calculate probability of a realization for a fixed variable */
LnProbRatioFix(MrBFlt newX,MrBFlt oldX,MrBFlt * params)12840 MrBFlt LnProbRatioFix (MrBFlt newX, MrBFlt oldX, MrBFlt *params)
12841 {
12842 if (fabs((newX - params[0])/newX) < 1E-5 && fabs((oldX - params[0])/oldX) < 1E-5)
12843 return 0.0;
12844 else
12845 return NEG_INFINITY;
12846 }
12847
12848
12849 /* Calculate probability ratio of realizations for gamma random variable */
LnProbRatioGamma(MrBFlt newX,MrBFlt oldX,MrBFlt * params)12850 MrBFlt LnProbRatioGamma (MrBFlt newX, MrBFlt oldX, MrBFlt *params)
12851 {
12852 MrBFlt alpha, beta;
12853
12854 alpha = params[0];
12855 beta = params[1];
12856
12857 return (alpha - 1.0) * (log(newX) - log(oldX)) - beta * (newX - oldX);
12858 }
12859
12860
12861 /* Calculate probability ratio of realizations for gamma random variable; parameters mean and sd */
LnProbRatioGamma_Param_Mean_Sd(MrBFlt newX,MrBFlt oldX,MrBFlt * params)12862 MrBFlt LnProbRatioGamma_Param_Mean_Sd (MrBFlt newX, MrBFlt oldX, MrBFlt *params)
12863 {
12864 MrBFlt alpha, beta;
12865
12866 beta = params[0] / (params[1]*params[1]);
12867 alpha = params[0] * beta;
12868
12869 return (alpha - 1.0) * (log(newX) - log(oldX)) - beta * (newX - oldX);
12870 }
12871
12872
12873 /* Calculate probability ratio of realizations for log normal random variable */
LnProbRatioLognormal(MrBFlt newX,MrBFlt oldX,MrBFlt * params)12874 MrBFlt LnProbRatioLognormal (MrBFlt newX, MrBFlt oldX, MrBFlt *params)
12875 {
12876 MrBFlt newZ, oldZ;
12877
12878 newZ = (log(newX) - params[0]) / params[1];
12879 oldZ = (log(oldX) - params[0]) / params[1];
12880
12881 return (oldZ * oldZ - newZ * newZ) / 2.0 + log(oldX) - log(newX);
12882 }
12883
12884
12885 /* Calculate probability ratio of realizations for log normal random variable; parameters mean and sd */
LnProbRatioLognormal_Param_Mean_Sd(MrBFlt newX,MrBFlt oldX,MrBFlt * params)12886 MrBFlt LnProbRatioLognormal_Param_Mean_Sd (MrBFlt newX, MrBFlt oldX, MrBFlt *params)
12887 {
12888 MrBFlt newZ, oldZ, mean_log, sd_log;
12889
12890 sd_log = sqrt (log((params[1]*params[1])/(params[0]*params[0]) + 1));
12891 mean_log = log(params[0]) - sd_log * sd_log / 2.0;
12892
12893 newZ = (log(newX) - mean_log) / sd_log;
12894 oldZ = (log(oldX) - mean_log) / sd_log;
12895
12896 return (oldZ * oldZ - newZ * newZ) / 2.0 + log(oldX) - log(newX);
12897 }
12898
12899
12900 /* Calculate probability ratio of realizations for normal random variable */
LnProbRatioNormal(MrBFlt newX,MrBFlt oldX,MrBFlt * params)12901 MrBFlt LnProbRatioNormal (MrBFlt newX, MrBFlt oldX, MrBFlt *params)
12902 {
12903 MrBFlt newZ, oldZ;
12904
12905 newZ = (newX - params[0]) / params[1];
12906 oldZ = (oldX - params[0]) / params[1];
12907
12908 return (oldZ * oldZ - newZ * newZ) / 2.0;
12909 }
12910
12911
12912 /* Calculate probability ratio of realizations for offset exponential random variable */
LnProbRatioOffsetExponential(MrBFlt newX,MrBFlt oldX,MrBFlt * params)12913 MrBFlt LnProbRatioOffsetExponential (MrBFlt newX, MrBFlt oldX, MrBFlt *params)
12914 {
12915 return params[1] * (oldX - newX);
12916 }
12917
12918
12919 /* Calculate probability ratio of realizations for offset exponential random variable; parameters offset and mean */
LnProbRatioOffsetExponential_Param_Offset_Mean(MrBFlt newX,MrBFlt oldX,MrBFlt * params)12920 MrBFlt LnProbRatioOffsetExponential_Param_Offset_Mean (MrBFlt newX, MrBFlt oldX, MrBFlt *params)
12921 {
12922 return (oldX - newX) / (params[1] - params[0]);
12923 }
12924
12925
12926 /* Calculate probability ratio of realizations for offset gamma random variable */
LnProbRatioOffsetGamma(MrBFlt newX,MrBFlt oldX,MrBFlt * params)12927 MrBFlt LnProbRatioOffsetGamma (MrBFlt newX, MrBFlt oldX, MrBFlt *params)
12928 {
12929 MrBFlt alpha, beta, newZ, oldZ;
12930
12931 alpha = params[1];
12932 beta = params[2];
12933 newZ = newX - params[0];
12934 oldZ = oldX - params[0];
12935
12936 return (alpha - 1.0) * (log(newZ) - log(oldZ)) - beta * (newZ - oldZ);
12937 }
12938
12939
12940 /* Calculate probability ratio of realizations for offset gamma random variable; parameters offset, mean and sd */
LnProbRatioOffsetGamma_Param_Offset_Mean_Sd(MrBFlt newX,MrBFlt oldX,MrBFlt * params)12941 MrBFlt LnProbRatioOffsetGamma_Param_Offset_Mean_Sd (MrBFlt newX, MrBFlt oldX, MrBFlt *params)
12942 {
12943 MrBFlt mean, sd, alpha, beta;
12944
12945 mean = params[1] - params[0];
12946 sd = params[2];
12947
12948 beta = mean / (sd*sd);
12949 alpha = mean * beta;
12950
12951 newX -= params[0];
12952 oldX -= params[0];
12953
12954 return (alpha - 1.0) * (log(newX) - log(oldX)) - beta * (newX - oldX);
12955 }
12956
12957
12958 /* Calculate probability ratio of realizations for offset lognormal random variable */
LnProbRatioOffsetLognormal(MrBFlt newX,MrBFlt oldX,MrBFlt * params)12959 MrBFlt LnProbRatioOffsetLognormal (MrBFlt newX, MrBFlt oldX, MrBFlt *params)
12960 {
12961 MrBFlt newZ, oldZ, mean_log, sd_log;
12962
12963 sd_log = params[2];
12964 mean_log = params[1];
12965
12966 newZ = (log(newX-params[0]) - mean_log) / sd_log;
12967 oldZ = (log(oldX-params[0]) - mean_log) / sd_log;
12968
12969 return (oldZ * oldZ - newZ * newZ) / 2.0 + log(oldX-params[0]) - log(newX-params[0]);
12970 }
12971
12972
12973 /* Calculate probability ratio of realizations for offset lognormal random variable; parameters offset, mean and sd */
LnProbRatioOffsetLognormal_Param_Offset_Mean_Sd(MrBFlt newX,MrBFlt oldX,MrBFlt * params)12974 MrBFlt LnProbRatioOffsetLognormal_Param_Offset_Mean_Sd (MrBFlt newX, MrBFlt oldX, MrBFlt *params)
12975 {
12976 MrBFlt newZ, oldZ, mean, sd, mean_log, sd_log;
12977
12978 mean = params[1] - params[0];
12979 sd = params[2];
12980 sd_log = sqrt (log((sd*sd)/(mean*mean) + 1));
12981 mean_log = log(mean) - sd_log * sd_log / 2.0;
12982
12983 newX -= params[0];
12984 oldX -= params[0];
12985 newZ = (log(newX) - mean_log) / sd_log;
12986 oldZ = (log(oldX) - mean_log) / sd_log;
12987
12988 return (oldZ * oldZ - newZ * newZ) / 2.0 - log(newX / oldX);
12989 }
12990
12991
12992 /* Calculate probability ratio of realizations for truncated normal random variable */
LnProbRatioTruncatedNormal(MrBFlt newX,MrBFlt oldX,MrBFlt * params)12993 MrBFlt LnProbRatioTruncatedNormal (MrBFlt newX, MrBFlt oldX, MrBFlt *params)
12994 {
12995 MrBFlt newZ, oldZ;
12996
12997 newZ = (newX - params[0]) / params[1];
12998 oldZ = (oldX - params[0]) / params[1];
12999
13000 return (oldZ * oldZ - newZ * newZ) / 2.0;
13001 }
13002
13003
13004 /* Calculate probability ratio of realizations for arbitrarily truncated normal random variable; parameters truncation point, mean and sd */
LnProbRatioTruncatedNormal_Param_Trunc_Mean_Sd(MrBFlt newX,MrBFlt oldX,MrBFlt * params)13005 MrBFlt LnProbRatioTruncatedNormal_Param_Trunc_Mean_Sd (MrBFlt newX, MrBFlt oldX, MrBFlt *params)
13006 {
13007 MrBFlt newZ, oldZ;
13008
13009 newZ = (newX - params[1]) / params[2];
13010 oldZ = (oldX - params[1]) / params[2];
13011
13012 return (oldZ * oldZ - newZ * newZ) / 2.0;
13013 }
13014
13015
13016 /* Calculate probability ratio of realizations for uniform random variable */
LnProbRatioUniform(MrBFlt newX,MrBFlt oldX,MrBFlt * params)13017 MrBFlt LnProbRatioUniform (MrBFlt newX, MrBFlt oldX, MrBFlt *params)
13018 {
13019 return 0.0;
13020 }
13021
13022
13023 /* Log probability for a value drawn from a gamma distribution */
LnProbGamma(MrBFlt alpha,MrBFlt beta,MrBFlt x)13024 MrBFlt LnProbGamma (MrBFlt alpha, MrBFlt beta, MrBFlt x)
13025 {
13026 MrBFlt lnProb;
13027
13028 lnProb = (alpha-1.0)*log(x) + alpha*log(beta) - x*beta - LnGamma(alpha);
13029
13030 return lnProb;
13031 }
13032
13033
13034 /* Log probability for a value drawn from a truncated gamma distribution */
LnProbTruncGamma(MrBFlt alpha,MrBFlt beta,MrBFlt x,MrBFlt min,MrBFlt max)13035 MrBFlt LnProbTruncGamma (MrBFlt alpha, MrBFlt beta, MrBFlt x, MrBFlt min, MrBFlt max)
13036 {
13037 MrBFlt lnProb;
13038
13039 lnProb = (alpha-1.0)*log(x) + alpha*log(beta) - x*beta - LnGamma(alpha);
13040
13041 lnProb -= log (IncompleteGamma (max*beta, alpha, LnGamma(alpha)) - IncompleteGamma (min*beta, alpha, LnGamma(alpha)));
13042
13043 return lnProb;
13044 }
13045
13046
13047 /* Log probability for a value drawn from a lognormal distribution */
LnProbLogNormal(MrBFlt exp,MrBFlt sd,MrBFlt x)13048 MrBFlt LnProbLogNormal (MrBFlt exp, MrBFlt sd, MrBFlt x)
13049 {
13050 MrBFlt lnProb, z;
13051
13052 z = (log(x) - exp) / sd;
13053
13054 lnProb = - log (x * sd * sqrt (2.0 * M_PI)) - (z * z / 2.0);
13055
13056 return lnProb;
13057 }
13058
13059
13060 /* Log ratio for two values drawn from a lognormal distribution */
LnRatioLogNormal(MrBFlt exp,MrBFlt sd,MrBFlt xNew,MrBFlt xOld)13061 MrBFlt LnRatioLogNormal (MrBFlt exp, MrBFlt sd, MrBFlt xNew, MrBFlt xOld)
13062 {
13063 MrBFlt newZ, oldZ;
13064
13065 newZ = (log(xNew) - exp) / sd;
13066 oldZ = (log(xOld) - exp) / sd;
13067
13068 return (oldZ * oldZ - newZ * newZ) / 2.0 + log(xOld) - log(xNew);
13069 }
13070
13071
13072 /* Log probability for a value drawn from a lognormal distribution;
13073 parameters are mean and variance of value (not of log value) */
LnProbTK02LogNormal(MrBFlt mean,MrBFlt var,MrBFlt x)13074 MrBFlt LnProbTK02LogNormal (MrBFlt mean, MrBFlt var, MrBFlt x)
13075 {
13076 MrBFlt z, lnProb, mu, sigma;
13077
13078 sigma = sqrt(log(1.0 + (var / (mean*mean))));
13079 mu = log(mean) - sigma * sigma / 2.0;
13080
13081 z = (log(x) - mu) / sigma;
13082
13083 lnProb = - log (x * sigma * sqrt (2.0 * M_PI)) - (z * z / 2.0);
13084
13085 return lnProb;
13086 }
13087
13088
13089 /* Log ratio for two values drawn from a lognormal distribution */
LnRatioTK02LogNormal(MrBFlt mean,MrBFlt var,MrBFlt xNew,MrBFlt xOld)13090 MrBFlt LnRatioTK02LogNormal (MrBFlt mean, MrBFlt var, MrBFlt xNew, MrBFlt xOld)
13091 {
13092 MrBFlt newZ, oldZ, mu, sigma;
13093
13094 sigma = sqrt(log(1.0 + (var / (mean*mean))));
13095 mu = log(mean) - sigma * sigma / 2.0;
13096
13097 newZ = (log(xNew) - mu) / sigma;
13098 oldZ = (log(xOld) - mu) / sigma;
13099
13100 return (oldZ * oldZ - newZ * newZ) / 2.0 + log(xOld) - log(xNew);
13101 }
13102
13103
13104 /*---------------------------------------------------------------------------------
13105 |
13106 | LogBase2Plus1
13107 |
13108 | This function is called from ComputeMatrixExponential.
13109 |
13110 ---------------------------------------------------------------------------------*/
LogBase2Plus1(MrBFlt x)13111 int LogBase2Plus1 (MrBFlt x)
13112 {
13113 int j = 0;
13114
13115 while (x > 1.0 - 1.0e-07)
13116 {
13117 x /= 2.0;
13118 j++;
13119 }
13120
13121 return (j);
13122 }
13123
13124
13125 /*---------------------------------------------------------------------------------
13126 |
13127 | LogNormalRandomVariable
13128 |
13129 | Draw a random variable from a lognormal distribution.
13130 |
13131 ---------------------------------------------------------------------------------*/
LogNormalRandomVariable(MrBFlt mean,MrBFlt sd,RandLong * seed)13132 MrBFlt LogNormalRandomVariable (MrBFlt mean, MrBFlt sd, RandLong *seed)
13133 {
13134 MrBFlt x;
13135
13136 x = PointNormal(RandomNumber(seed));
13137
13138 x*= sd;
13139 x += mean;
13140
13141 return exp(x);
13142 }
13143
13144
13145 /*---------------------------------------------------------------------------------
13146 |
13147 | LUBackSubstitution
13148 |
13149 | Back substitute into an LU-decomposed matrix.
13150 |
13151 ---------------------------------------------------------------------------------*/
LUBackSubstitution(int dim,MrBFlt ** a,int * indx,MrBFlt * b)13152 void LUBackSubstitution (int dim, MrBFlt **a, int *indx, MrBFlt *b)
13153 {
13154 int i, ip, j, ii = -1;
13155 MrBFlt sum;
13156
13157 for (i=0; i<dim; i++)
13158 {
13159 ip = indx[i];
13160 sum = b[ip];
13161 b[ip] = b[i];
13162 if (ii >= 0)
13163 {
13164 for (j=ii; j<=i-1; j++)
13165 sum -= a[i][j] * b[j];
13166 }
13167 else if (fabs(sum)>ETA)
13168 ii = i;
13169 b[i] = sum;
13170 }
13171 for (i=dim-1; i>=0; i--)
13172 {
13173 sum = b[i];
13174 for (j=i+1; j<dim; j++)
13175 sum -= a[i][j] * b[j];
13176 b[i] = sum / a[i][i];
13177 }
13178 }
13179
13180
13181 /*---------------------------------------------------------------------------------
13182 |
13183 | LUDecompose
13184 |
13185 | Calculate the LU-decomposition of the matrix a. The matrix a is replaced.
13186 |
13187 ---------------------------------------------------------------------------------*/
LUDecompose(int dim,MrBFlt ** a,MrBFlt * vv,int * indx,MrBFlt * pd)13188 int LUDecompose (int dim, MrBFlt **a, MrBFlt *vv, int *indx, MrBFlt *pd)
13189 {
13190 int i, imax=0, j, k;
13191 MrBFlt big, dum, sum, temp, d;
13192
13193 d = 1.0;
13194 for (i=0; i<dim; i++)
13195 {
13196 big = 0.0;
13197 for (j = 0; j < dim; j++)
13198 {
13199 if ((temp = fabs(a[i][j])) > big)
13200 big = temp;
13201 }
13202 if (fabs(big)<ETA)
13203 {
13204 MrBayesPrint ("%s Error: Problem in LUDecompose\n", spacer);
13205 return (ERROR);
13206 }
13207 vv[i] = 1.0 / big;
13208 }
13209 for (j=0; j<dim; j++)
13210 {
13211 for (i = 0; i < j; i++)
13212 {
13213 sum = a[i][j];
13214 for (k = 0; k < i; k++)
13215 sum -= a[i][k] * a[k][j];
13216 a[i][j] = sum;
13217 }
13218 big = 0.0;
13219 for (i=j; i<dim; i++)
13220 {
13221 sum = a[i][j];
13222 for (k = 0; k < j; k++)
13223 sum -= a[i][k] * a[k][j];
13224 a[i][j] = sum;
13225 dum = vv[i] * fabs(sum);
13226 if (dum >= big)
13227 {
13228 big = dum;
13229 imax = i;
13230 }
13231 }
13232 if (j != imax)
13233 {
13234 for (k=0; k<dim; k++)
13235 {
13236 dum = a[imax][k];
13237 a[imax][k] = a[j][k];
13238 a[j][k] = dum;
13239 }
13240 d = -d;
13241 vv[imax] = vv[j];
13242 }
13243 indx[j] = imax;
13244 if (fabs(a[j][j])<ETA)
13245 a[j][j] = TINY;
13246 if (j != dim - 1)
13247 {
13248 dum = 1.0 / (a[j][j]);
13249 for (i=j+1; i<dim; i++)
13250 a[i][j] *= dum;
13251 }
13252 }
13253 if (pd != NULL)
13254 *pd = d;
13255
13256 return (NO_ERROR);
13257 }
13258
13259
13260 /*---------------------------------------------------------------------------------
13261 |
13262 | MultiplyMatrices
13263 |
13264 | Multiply matrix a by matrix b and put the results in matrix result.
13265 |
13266 ---------------------------------------------------------------------------------*/
MultiplyMatrices(int dim,MrBFlt ** a,MrBFlt ** b,MrBFlt ** result)13267 void MultiplyMatrices (int dim, MrBFlt **a, MrBFlt **b, MrBFlt **result)
13268 {
13269 register int i, j, k;
13270 MrBFlt **temp;
13271
13272 temp = AllocateSquareDoubleMatrix (dim);
13273
13274 for (i=0; i<dim; i++)
13275 {
13276 for (j=0; j<dim; j++)
13277 {
13278 temp[i][j] = 0.0;
13279 for (k=0; k<dim; k++)
13280 {
13281 temp[i][j] += a[i][k] * b[k][j];
13282 }
13283 }
13284 }
13285 for (i=0; i<dim; i++)
13286 {
13287 for (j=0; j<dim; j++)
13288 {
13289 result[i][j] = temp[i][j];
13290 }
13291 }
13292
13293 FreeSquareDoubleMatrix (temp);
13294 }
13295
13296
13297 /*---------------------------------------------------------------------------------
13298 |
13299 | MultiplyMatrixByScalar
13300 |
13301 | Multiply the elements of matrix a by a scalar.
13302 |
13303 ---------------------------------------------------------------------------------*/
MultiplyMatrixByScalar(int dim,MrBFlt ** a,MrBFlt scalar,MrBFlt ** result)13304 void MultiplyMatrixByScalar (int dim, MrBFlt **a, MrBFlt scalar, MrBFlt **result)
13305 {
13306 int row, col;
13307
13308 for (row=0; row<dim; row++)
13309 for (col=0; col<dim; col++)
13310 result[row][col] = a[row][col] * scalar;
13311 }
13312
13313
13314 /*---------------------------------------------------------------------------------
13315 |
13316 | MultiplyMatrixNTimes
13317 |
13318 ---------------------------------------------------------------------------------*/
MultiplyMatrixNTimes(int dim,MrBFlt ** Mat,int power,MrBFlt ** Result)13319 int MultiplyMatrixNTimes (int dim, MrBFlt **Mat, int power, MrBFlt **Result)
13320 {
13321 register int i, j;
13322 int k, numSquares, numRemaining;
13323 MrBFlt **TempIn, **TempOut;
13324
13325 if (power < 0)
13326 {
13327 MrBayesPrint ("%s Error: Power cannot be a negative number.\n", spacer);
13328 return (ERROR);
13329 }
13330 else if (power == 0)
13331 {
13332 for (i=0; i<dim; i++)
13333 for (j=0; j<dim; j++)
13334 Result[i][j] = 1.0;
13335 }
13336 else
13337 {
13338 TempIn = AllocateSquareDoubleMatrix (dim);
13339 TempOut = AllocateSquareDoubleMatrix (dim);
13340
13341 /* how many times can I multiply the matrices together */
13342 numSquares = 0;
13343 while ((1 << numSquares) < power)
13344 numSquares++;
13345 numRemaining = power - (1 << numSquares);
13346
13347 /* now, multiply matrix by power of 2's */
13348 CopyDoubleMatrices (dim, Mat, TempIn);
13349 for (k=0; k<numSquares; k++)
13350 {
13351 MultiplyMatrices (dim, TempIn, TempIn, TempOut);
13352 CopyDoubleMatrices (dim, TempOut, TempIn);
13353 }
13354
13355 /* TempIn is Mat^numSquares. Now, multiply it by Mat numRemaining times */
13356 for (k=0; k<numRemaining; k++)
13357 {
13358 MultiplyMatrices (dim, TempIn, Mat, TempOut);
13359 CopyDoubleMatrices (dim, TempOut, TempIn);
13360 }
13361
13362 /* copy result */
13363 CopyDoubleMatrices (dim, TempIn, Result);
13364
13365 FreeSquareDoubleMatrix (TempIn);
13366 FreeSquareDoubleMatrix (TempOut);
13367 }
13368
13369 return (NO_ERROR);
13370 }
13371
13372
13373 /*---------------------------------------------------------------------------------
13374 |
13375 | PointChi2
13376 |
13377 | Returns z so that Prob(x < z) = prob where x is Chi2 distributed with df=v.
13378 | Returns -1 if in error. 0.000002 < prob < 0.999998.
13379 |
13380 ---------------------------------------------------------------------------------*/
PointChi2(MrBFlt prob,MrBFlt v)13381 MrBFlt PointChi2 (MrBFlt prob, MrBFlt v)
13382 {
13383 MrBFlt e = 0.5e-6, aa = 0.6931471805, p = prob, g,
13384 xx, c, ch, a = 0.0, q = 0.0, p1 = 0.0, p2 = 0.0, t = 0.0,
13385 x = 0.0, b = 0.0, s1, s2, s3, s4, s5, s6,
13386 tmp;
13387
13388 if (p < 0.000002 || p > 0.999998 || v <= 0.0)
13389 return (-1.0);
13390 g = LnGamma (v/2.0);
13391 xx = v/2.0;
13392 c = xx - 1.0;
13393 if (v >= -1.24*log(p))
13394 goto l1;
13395 ch = pow((p*xx*exp(g+xx*aa)), 1.0/xx);
13396 if (ch-e<0)
13397 return (ch);
13398 goto l4;
13399 l1:
13400 if (v > 0.32)
13401 goto l3;
13402 ch = 0.4;
13403 a = log(1.0-p);
13404 l2:
13405 q = ch;
13406 p1 = 1.0+ch*(4.67+ch);
13407 p2 = ch*(6.73+ch*(6.66+ch));
13408 t = -0.5+(4.67+2.0*ch)/p1 - (6.73+ch*(13.32+3.0*ch))/p2;
13409 ch -= (1.0-exp(a+g+0.5*ch+c*aa)*p2/p1)/t;
13410 if (fabs(q/ch-1.0)-0.01 <= 0.0)
13411 goto l4;
13412 else
13413 goto l2;
13414 l3:
13415 x = PointNormal (p);
13416 p1 = 0.222222/v;
13417 tmp = (x*sqrt(p1)+1.0-p1);
13418 ch = v*tmp*tmp*tmp;
13419 if (ch > 2.2*v+6.0)
13420 ch = -2.0*(log(1.0-p)-c*log(0.5*ch)+g);
13421 l4:
13422 q = ch;
13423 p1 = 0.5*ch;
13424 if ((t = IncompleteGamma (p1, xx, g)) < 0.0)
13425 {
13426 MrBayesPrint ("%s Error: Problem in PointChi2", spacer);
13427 return (-1.0);
13428 }
13429 p2 = p-t;
13430 t = p2*exp(xx*aa+g+p1-c*log(ch));
13431 b = t/ch;
13432 a = 0.5*t-b*c;
13433 s1 = (210.0+a*(140.0+a*(105.0+a*(84.0+a*(70.0+60.0*a))))) / 420.0;
13434 s2 = (420.0+a*(735.0+a*(966.0+a*(1141.0+1278.0*a))))/2520.0;
13435 s3 = (210.0+a*(462.0+a*(707.0+932.0*a)))/2520.0;
13436 s4 = (252.0+a*(672.0+1182.0*a)+c*(294.0+a*(889.0+1740.0*a)))/5040.0;
13437 s5 = (84.0+264.0*a+c*(175.0+606.0*a)) / 2520.0;
13438 s6 = (120.0+c*(346.0+127.0*c)) / 5040.0;
13439 ch += t*(1+0.5*t*s1-b*c*(s1-b*(s2-b*(s3-b*(s4-b*(s5-b*s6))))));
13440 if (fabs(q/ch-1.0) > e)
13441 goto l4;
13442 return (ch);
13443 }
13444
13445
13446 /*---------------------------------------------------------------------------------
13447 |
13448 | PointNormal
13449 |
13450 | Returns z so That Prob{x<z} = prob where x ~ N(0,1) and
13451 | (1e-12) < prob < 1-(1e-12). Returns (-9999) if in error.
13452 |
13453 | Odeh, R. E. and J. O. Evans. 1974. The percentage points of the normal
13454 | distribution. Applied Statistics, 22:96-97 (AS70).
13455 |
13456 | Newer methods:
13457 |
13458 | Wichura, M. J. 1988. Algorithm AS 241: The percentage points of the
13459 | normal distribution. 37:477-484.
13460 | Beasley, JD & S. G. Springer. 1977. Algorithm AS 111: The percentage
13461 | points of the normal distribution. 26:118-121.
13462 |
13463 ---------------------------------------------------------------------------------*/
PointNormal(MrBFlt prob)13464 MrBFlt PointNormal (MrBFlt prob)
13465 {
13466 MrBFlt a0 = -0.322232431088, a1 = -1.0, a2 = -0.342242088547, a3 = -0.0204231210245,
13467 a4 = -0.453642210148e-4, b0 = 0.0993484626060, b1 = 0.588581570495,
13468 b2 = 0.531103462366, b3 = 0.103537752850, b4 = 0.0038560700634,
13469 y, z = 0, p = prob, p1;
13470
13471 p1 = (p<0.5 ? p : 1-p);
13472 if (p1<1e-20)
13473 return (-9999);
13474 y = sqrt (log(1/(p1*p1)));
13475 z = y + ((((y*a4+a3)*y+a2)*y+a1)*y+a0) / ((((y*b4+b3)*y+b2)*y+b1)*y+b0);
13476
13477 return (p<0.5 ? -z : z);
13478 }
13479
13480
13481 /*---------------------------------------------------------------------------------
13482 |
13483 | PrintComplexVector
13484 |
13485 | Prints a vector of dim complex numbers.
13486 |
13487 ---------------------------------------------------------------------------------*/
PrintComplexVector(int dim,MrBComplex * vec)13488 void PrintComplexVector (int dim, MrBComplex *vec)
13489 {
13490 int i;
13491
13492 MrBayesPrint ("{");
13493 for (i = 0; i < (dim - 1); i++)
13494 {
13495 MrBayesPrint ("%lf + %lfi, ", vec[i].re, vec[i].im);
13496 if (i == 1)
13497 MrBayesPrint("\n ");
13498 }
13499 MrBayesPrint ("%lf + %lfi}\n", vec[dim - 1].re, vec[dim - 1].im);
13500 }
13501
13502
13503 /*---------------------------------------------------------------------------------
13504 |
13505 | PrintSquareComplexMatrix
13506 |
13507 | Prints a square matrix of complex numbers.
13508 |
13509 ---------------------------------------------------------------------------------*/
PrintSquareComplexMatrix(int dim,MrBComplex ** m)13510 void PrintSquareComplexMatrix (int dim, MrBComplex **m)
13511 {
13512 int row, col;
13513
13514 MrBayesPrint ("{");
13515 for (row = 0; row < (dim - 1); row++)
13516 {
13517 MrBayesPrint ("{");
13518 for (col = 0; col < (dim - 1); col++)
13519 {
13520 MrBayesPrint ("%lf + %lfi, ", m[row][col].re, m[row][col].im);
13521 if (col == 1)
13522 MrBayesPrint ("\n ");
13523 }
13524 MrBayesPrint ("%lf + %lfi},\n",
13525 m[row][dim - 1].re, m[row][dim - 1].im);
13526 }
13527 MrBayesPrint ("{");
13528 for (col = 0; col < (dim - 1); col++)
13529 {
13530 MrBayesPrint ("%lf + %lfi, ", m[dim - 1][col].re, m[dim - 1][col].im);
13531 if (col == 1)
13532 MrBayesPrint ("\n ");
13533 }
13534 MrBayesPrint ("%lf + %lfi}}", m[dim - 1][dim - 1].re, m[dim - 1][dim - 1].im);
13535 MrBayesPrint ("\n");
13536 }
13537
13538
13539 /*---------------------------------------------------------------------------------
13540 |
13541 | PrintSquareDoubleMatrix
13542 |
13543 | Prints a square matrix of doubles.
13544 |
13545 ---------------------------------------------------------------------------------*/
PrintSquareDoubleMatrix(int dim,MrBFlt ** matrix)13546 void PrintSquareDoubleMatrix (int dim, MrBFlt **matrix)
13547 {
13548 int i, j;
13549
13550 for (i=0; i<dim; i++)
13551 {
13552 for (j=0; j<dim; j++)
13553 MrBayesPrint ("%1.6lf ", matrix[i][j]);
13554 MrBayesPrint ("\n");
13555 }
13556 }
13557
13558
13559 /*---------------------------------------------------------------------------------
13560 |
13561 | PrintSquareIntegerMatrix
13562 |
13563 | Prints a square matrix of integers.
13564 |
13565 ---------------------------------------------------------------------------------*/
PrintSquareIntegerMatrix(int dim,int ** matrix)13566 void PrintSquareIntegerMatrix (int dim, int **matrix)
13567 {
13568 int i, j;
13569
13570 for (i=0; i<dim; i++)
13571 {
13572 for (j=0; j<dim; j++)
13573 MrBayesPrint ("%d ", matrix[i][j]);
13574 MrBayesPrint ("\n");
13575 }
13576 }
13577
13578
13579 /*---------------------------------------------------------------------------------
13580 |
13581 | ProductOfRealAndComplex
13582 |
13583 | Returns the complex product of a real and complex number.
13584 |
13585 ---------------------------------------------------------------------------------*/
ProductOfRealAndComplex(MrBFlt a,MrBComplex b)13586 MrBComplex ProductOfRealAndComplex (MrBFlt a, MrBComplex b)
13587 {
13588 MrBComplex c;
13589
13590 c.re = a * b.re;
13591 c.im = a * b.im;
13592
13593 return (c);
13594 }
13595
13596
13597 /*---------------------------------------------------------------------------------
13598 |
13599 | PsiExp: Returns psi (also called digamma) exponentiated
13600 | Algorithm from http://lib.stat.cmu.edu/apstat/103
13601 |
13602 ---------------------------------------------------------------------------------*/
PsiExp(MrBFlt alpha)13603 MrBFlt PsiExp (MrBFlt alpha)
13604 {
13605 MrBFlt digamma, y, r, s, c, s3, s4, s5, d1;
13606
13607 s = 1.0e-05;
13608 c = 8.5;
13609 s3 = 8.333333333333333333333333e-02;
13610 s4 = 8.333333333333333333333333e-03;
13611 s5 = 3.968253968e-03;
13612 d1 = -0.577215664901532860606512; /* negative of Euler's constant */
13613
13614 digamma = 0.0;
13615 y = alpha;
13616 if (y <= 0.0)
13617 return (0.0);
13618
13619 if (y <= s)
13620 {
13621 digamma = d1 - 1.0 / y;
13622 return (exp (digamma));
13623 }
13624
13625 while (y < c)
13626 {
13627 digamma -= 1.0 / y;
13628 y += 1.0;
13629 }
13630
13631 r = 1.0 / y;
13632 digamma += (log (y) - 0.5 * r);
13633 r *= r;
13634 digamma -= r * (s3 - r * (s4 - r * s5));
13635
13636 return (exp (digamma));
13637 }
13638
13639
13640 /*---------------------------------------------------------------------------------
13641 |
13642 | PsiGammaLnProb: Calculates the log probability of a PsiGamma distributed
13643 | variable
13644 |
13645 ---------------------------------------------------------------------------------*/
PsiGammaLnProb(MrBFlt alpha,MrBFlt value)13646 MrBFlt PsiGammaLnProb (MrBFlt alpha, MrBFlt value)
13647 {
13648 MrBFlt beta, lnProb;
13649
13650 beta = PsiExp (alpha);
13651
13652 lnProb = alpha * log (beta) - LnGamma (alpha) + (alpha - 1.0) * log (value) - beta * value;
13653
13654 return lnProb;
13655 }
13656
13657
13658 /*---------------------------------------------------------------------------------
13659 |
13660 | PsiGammaLnRatio: Calculates the log prob ratio of two PsiGamma distributed
13661 | variables
13662 |
13663 ---------------------------------------------------------------------------------*/
PsiGammaLnRatio(MrBFlt alpha,MrBFlt numerator,MrBFlt denominator)13664 MrBFlt PsiGammaLnRatio (MrBFlt alpha, MrBFlt numerator, MrBFlt denominator)
13665 {
13666 MrBFlt beta, lnRatio;
13667
13668 beta = PsiExp (alpha);
13669
13670 lnRatio = (alpha - 1.0) * (log (numerator) - log (denominator)) - beta * (numerator - denominator);
13671
13672 return (lnRatio);
13673 }
13674
13675
13676 /*---------------------------------------------------------------------------------
13677 |
13678 | PsiGammaRandomVariable: Returns a random draw from the PsiGamma
13679 |
13680 ---------------------------------------------------------------------------------*/
PsiGammaRandomVariable(MrBFlt alpha,RandLong * seed)13681 MrBFlt PsiGammaRandomVariable (MrBFlt alpha, RandLong *seed)
13682 {
13683 return GammaRandomVariable (alpha, PsiExp(alpha), seed);
13684 }
13685
13686
13687 /*---------------------------------------------------------------------------------
13688 |
13689 | QuantileGamma
13690 |
13691 ---------------------------------------------------------------------------------*/
QuantileGamma(MrBFlt x,MrBFlt alfa,MrBFlt beta)13692 MrBFlt QuantileGamma (MrBFlt x, MrBFlt alfa, MrBFlt beta)
13693 {
13694 MrBFlt quantile;
13695
13696 quantile = POINTGAMMA(x, alfa, beta);
13697
13698 return (quantile);
13699 }
13700
13701
13702 /*---------------------------------------------------------------------------------
13703 |
13704 | RandomNumber
13705 |
13706 | This pseudorandom number generator is described in:
13707 | Park, S. K. and K. W. Miller. 1988. Random number generators: good
13708 | ones are hard to find. Communications of the ACM, 31(10):1192-1201.
13709 |
13710 ---------------------------------------------------------------------------------*/
RandomNumber(RandLong * seed)13711 MrBFlt RandomNumber (RandLong *seed)
13712 {
13713 RandLong lo, hi, test;
13714
13715 hi = (*seed) / 127773;
13716 lo = (*seed) % 127773;
13717 test = 16807 * lo - 2836 * hi;
13718 if (test > 0)
13719 *seed = test;
13720 else
13721 *seed = test + 2147483647;
13722 return ((MrBFlt)(*seed) / (MrBFlt)2147483647);
13723 }
13724
13725
13726 /*---------------------------------------------------------------------------------
13727 |
13728 | RndGamma
13729 |
13730 ---------------------------------------------------------------------------------*/
RndGamma(MrBFlt s,RandLong * seed)13731 MrBFlt RndGamma (MrBFlt s, RandLong *seed)
13732 {
13733 MrBFlt r=0.0;
13734
13735 if (s <= 0.0)
13736 puts ("Gamma parameter less than zero\n");
13737
13738 else if (s < 1.0)
13739 r = RndGamma1 (s, seed);
13740 else if (s > 1.0)
13741 r = RndGamma2 (s, seed);
13742 else /* 0-log() == -1 * log(), but =- looks confusing */
13743 r -= log(RandomNumber(seed));
13744
13745 return (r);
13746 }
13747
13748
13749 /*---------------------------------------------------------------------------------
13750 |
13751 | RndGamma1
13752 |
13753 ---------------------------------------------------------------------------------*/
RndGamma1(MrBFlt s,RandLong * seed)13754 MrBFlt RndGamma1 (MrBFlt s, RandLong *seed)
13755 {
13756 MrBFlt r, x=0.0, tiny=1e-37, w;
13757 static MrBFlt a, p, uf, ss=10.0, d;
13758
13759 if (fabs(s-ss)>ETA) /* s != ss */
13760 {
13761 a = 1.0 - s;
13762 p = a / (a + s * exp(-a));
13763 uf = p * pow(tiny / a, s);
13764 d = a * log(a);
13765 ss = s;
13766 }
13767 for (;;)
13768 {
13769 r = RandomNumber(seed);
13770 if (r > p)
13771 {
13772 x = a - log((1.0 - r) / (1.0 - p));
13773 w = a * log(x) - d;
13774 }
13775 else if (r > uf)
13776 {
13777 x = a * pow(r / p, 1.0 / s);
13778 w = x;
13779 }
13780 else
13781 return (0.0);
13782 r = RandomNumber(seed);
13783 if (1.0 - r <= w && r > 0.0)
13784 if (r*(w + 1.0) >= 1.0 || -log(r) <= w)
13785 continue;
13786 break;
13787 }
13788
13789 return (x);
13790 }
13791
13792
13793 /*---------------------------------------------------------------------------------
13794 |
13795 | RndGamma2
13796 |
13797 ---------------------------------------------------------------------------------*/
RndGamma2(MrBFlt s,RandLong * seed)13798 MrBFlt RndGamma2 (MrBFlt s, RandLong *seed)
13799 {
13800 MrBFlt r , d, f, g, x;
13801 static MrBFlt b, h, ss=0.0;
13802
13803 if (fabs(s-ss)>ETA) /* s != ss */
13804 {
13805 b = s - 1.0;
13806 h = sqrt(3.0 * s - 0.75);
13807 ss = s;
13808 }
13809 for (;;)
13810 {
13811 r = RandomNumber(seed);
13812 g = r - r * r;
13813 f = (r - 0.5) * h / sqrt(g);
13814 x = b + f;
13815 if (x <= 0.0)
13816 continue;
13817 r = RandomNumber(seed);
13818 d = 64 * r * r * g * g * g;
13819 if (d * x < x - 2.0 * f * f || log(d) < 2.0 * (b * log(x / b) - f))
13820 break;
13821 }
13822
13823 return (x);
13824 }
13825
13826
13827 /*---------------------------------------------------------------------------------
13828 |
13829 | SetQvalue
13830 |
13831 | The Pade method for calculating the matrix exponential, tMat = e^{qMat * v},
13832 | has an error, e(p,q), that can be controlled by setting p and q to appropriate
13833 | values. The error is:
13834 |
13835 | e(p,q) = 2^(3-(p+q)) * ((p!*q!) / (p+q)! * (p+q+1)!)
13836 |
13837 | Setting p = q will minimize the error for a given amount of work. This function
13838 | assumes that p = q. The function takes in as a parameter the desired tolerance
13839 | for the accuracy of the matrix exponentiation, and returns qV = p = q, that
13840 | will achieve the tolerance. The Pade approximation method is described in:
13841 |
13842 | Golub, G. H., and C. F. Van Loan. 1996. Matrix Computations, Third Edition.
13843 | The Johns Hopkins University Press, Baltimore, Maryland.
13844 |
13845 | The function is called from TiProbsUsingPadeApprox.
13846 |
13847 ---------------------------------------------------------------------------------*/
SetQvalue(MrBFlt tol)13848 int SetQvalue (MrBFlt tol)
13849 {
13850 int qV;
13851 MrBFlt x;
13852
13853 /*
13854 x = pow(2.0, 3.0 - (0 + 0)) * Factorial(0) * Factorial (0) / (Factorial(0+0) * Factorial (0+0+1));
13855 */
13856 x = 8.0;
13857 qV = 0;
13858 while (x > tol)
13859 {
13860 qV++;
13861 x = pow(2.0, 3.0 - (qV + qV)) * Factorial(qV) * Factorial (qV) / (Factorial(qV+qV) * Factorial (qV+qV+1));
13862 }
13863
13864 return (qV);
13865 }
13866
13867
13868 /*---------------------------------------------------------------------------------
13869 |
13870 | SetToIdentity
13871 |
13872 | Make a dim X dim identity matrix.
13873 |
13874 ---------------------------------------------------------------------------------*/
SetToIdentity(int dim,MrBFlt ** matrix)13875 void SetToIdentity (int dim, MrBFlt **matrix)
13876 {
13877 int row, col;
13878
13879 for (row=0; row<dim; row++)
13880 for (col=0; col<dim; col++)
13881 matrix[row][col] = (row == col ? 1.0 : 0.0);
13882 }
13883
13884
13885 /*---------------------------------------------------------------------------------
13886 |
13887 | Tha
13888 |
13889 | Calculate Owen's (1956) T(h,a) function, -inf <= h, a <= inf,
13890 | where h = h1/h2, a = a1/a2, from the program of:
13891 |
13892 | Young, J. C. and C. E. Minder. 1974. Algorithm AS 76. An integral
13893 | useful in calculating non-central t and bivariate normal
13894 | probabilities. Appl. Statist., 23:455-457. [Correction: Appl.
13895 | Statist., 28:113 (1979). Remarks: Appl. Statist. 27:379 (1978),
13896 | 28: 113 (1979), 34:100-101 (1985), 38:580-582 (1988)]
13897 |
13898 | See also:
13899 |
13900 | Johnson, N. L. and S. Kotz. 1972. Distributions in statistics:
13901 | multivariate distributions. Wiley and Sons. New York. pp. 93-100.
13902 |
13903 ---------------------------------------------------------------------------------*/
Tha(MrBFlt h1,MrBFlt h2,MrBFlt a1,MrBFlt a2)13904 MrBFlt Tha (MrBFlt h1, MrBFlt h2, MrBFlt a1, MrBFlt a2)
13905 {
13906 int ng = 5, i;
13907 MrBFlt U[] = {0.0744372, 0.2166977, 0.3397048, 0.4325317, 0.4869533},
13908 R[] = {0.1477621, 0.1346334, 0.1095432, 0.0747257, 0.0333357},
13909 pai2 = 6.283185307, tv1 = 1e-35, tv2 = 15.0, tv3 = 15.0, tv4 = 1e-5,
13910 a, h, rt, t, x1, x2, r1, r2, s, k, sign = 1.0;
13911
13912 if (fabs(h2) < tv1)
13913 return (0.0);
13914 h = h1 / h2;
13915 if (fabs(a2) < tv1)
13916 {
13917 t = CdfNormal(h);
13918 if (h >= 0.0)
13919 t = (1.0 - t) / 2.0;
13920 else
13921 t /= 2.0;
13922 return (t*(a1 >= 0.0 ? 1.0 : -1.0));
13923 }
13924 a = a1 / a2;
13925 if (a < 0.0)
13926 sign = -1.0;
13927 a = fabs(a);
13928 h = fabs(h);
13929 k = h*a;
13930 if (h > tv2 || a < tv1)
13931 return (0.0);
13932 if (h < tv1)
13933 return (atan(a)/pai2*sign);
13934 if (h < 0.3 && a > 7.0) /* (Boys RJ, 1989) */
13935 {
13936 x1 = exp(-k*k/2.0)/k;
13937 x2 = (CdfNormal(k)-0.5)*sqrt(pai2);
13938 t = 0.25 - (x1+x2)/pai2*h + ((1.0+2.0/(k*k))*x1+x2)/(6.0*pai2)*h*h*h;
13939 return (MAX(t,0)*sign);
13940 }
13941 t = -h*h / 2.0;
13942 x2 = a;
13943 s = a*a;
13944 if (log(1.0+s)-t*s >= tv3)
13945 {
13946 x1 = a/2;
13947 s /= 4.0;
13948 for (;;) /* truncation point by Newton iteration */
13949 {
13950 x2 = x1 + (t*s+tv3-log(s+1.0)) / (2.0*x1*(1.0/(s+1.0)-t));
13951 s = x2*x2;
13952 if (fabs(x2-x1) < tv4)
13953 break;
13954 x1 = x2;
13955 }
13956 }
13957 for (i=0,rt=0; i<ng; i++) /* Gauss quadrature */
13958 {
13959 r1 = 1.0+s*SQUARE(0.5+U[i]);
13960 r2 = 1.0+s*SQUARE(0.5-U[i]);
13961 rt+= R[i]*(exp(t*r1)/r1 + exp(t*r2)/r2);
13962 }
13963
13964 return (MAX(rt*x2/pai2,0)*sign);
13965 }
13966
13967
13968 /*---------------------------------------------------------------------------------
13969 |
13970 | TiProbsUsingEigens
13971 |
13972 ---------------------------------------------------------------------------------*/
TiProbsUsingEigens(int dim,MrBFlt * cijk,MrBFlt * eigenVals,MrBFlt v,MrBFlt r,MrBFlt ** tMat,MrBFlt ** fMat,MrBFlt ** sMat)13973 void TiProbsUsingEigens (int dim, MrBFlt *cijk, MrBFlt *eigenVals, MrBFlt v, MrBFlt r, MrBFlt **tMat, MrBFlt **fMat, MrBFlt **sMat)
13974 {
13975 int i, j, s;
13976 MrBFlt sum, sumF, sumS, *ptr, EigValexp[192];
13977
13978 for (s=0; s<dim; s++)
13979 EigValexp[s] = exp(eigenVals[s] * v * r);
13980
13981 ptr = cijk;
13982 for (i=0; i<dim; i++)
13983 {
13984 for (j=0; j<dim; j++)
13985 {
13986 sum = 0.0;
13987 for (s=0; s<dim; s++)
13988 sum += (*ptr++) * EigValexp[s];
13989 tMat[i][j] = (sum < 0.0) ? 0.0 : sum;
13990 }
13991 }
13992
13993 # if 0
13994 for (i=0; i<dim; i++)
13995 {
13996 sum = 0.0;
13997 for (j=0; j<dim; j++)
13998 {
13999 sum += tMat[i][j];
14000 }
14001 if (sum > 1.0001 || sum < 0.9999)
14002 {
14003 MrBayesPrint ("%s Warning: Transition probabilities do not sum to 1.0 (%lf)\n", spacer, sum);
14004 }
14005 }
14006 # endif
14007
14008 if (fMat != NULL && sMat != NULL)
14009 {
14010 ptr = cijk;
14011 for (i=0; i<dim; i++)
14012 {
14013 for (j=0; j<dim; j++)
14014 {
14015 sumF = sumS = 0.0;
14016 for (s=0; s<dim; s++)
14017 {
14018 sumF += (*ptr) * eigenVals[s] * r * EigValexp[s];
14019 sumS += (*ptr++) * eigenVals[s] * eigenVals[s] * r * r * EigValexp[s];
14020 }
14021 fMat[i][j] = sumF;
14022 sMat[i][j] = sumS;
14023 }
14024 }
14025 }
14026 }
14027
14028
14029 /*---------------------------------------------------------------------------------
14030 |
14031 | TiProbsUsingPadeApprox
14032 |
14033 | The method approximates the matrix exponential, tMat = e^{qMat * v}, using
14034 | the Pade approximation method, described in:
14035 |
14036 | Golub, G. H., and C. F. Van Loan. 1996. Matrix Computations, Third Edition.
14037 | The Johns Hopkins University Press, Baltimore, Maryland.
14038 |
14039 | The method approximates the matrix exponential with accuracy tol.
14040 |
14041 ---------------------------------------------------------------------------------*/
TiProbsUsingPadeApprox(int dim,MrBFlt ** qMat,MrBFlt v,MrBFlt r,MrBFlt ** tMat,MrBFlt ** fMat,MrBFlt ** sMat)14042 void TiProbsUsingPadeApprox (int dim, MrBFlt **qMat, MrBFlt v, MrBFlt r, MrBFlt **tMat, MrBFlt **fMat, MrBFlt **sMat)
14043 {
14044 int qValue;
14045 MrBFlt **a, tol;
14046
14047 tol = 0.0000001;
14048
14049 a = AllocateSquareDoubleMatrix (dim);
14050
14051 MultiplyMatrixByScalar (dim, qMat, v * r, a);
14052
14053 qValue = SetQvalue (tol);
14054
14055 ComputeMatrixExponential (dim, a, qValue, tMat);
14056
14057 FreeSquareDoubleMatrix (a);
14058
14059 if (fMat != NULL && sMat != NULL)
14060 {
14061 MultiplyMatrices (dim, qMat, tMat, fMat);
14062 MultiplyMatrices (dim, qMat, fMat, sMat);
14063 }
14064 }
14065
14066