src/utils.c

   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 (maxim.teslenko@nrm.se)
  22  *
  23  *  and by many users (run 'acknowledgments' to see more info)
  24  *
  25  * This program is free software; you can redistribute it and/or
  26  * modify it under the terms of the GNU General Public License
  27  * as published by the Free Software Foundation; either version 2
  28  * of the License, or (at your option) any later version.
  29  *
  30  * This program is distributed in the hope that it will be useful,
  31  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  32  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  33  * GNU General Public License for more details (www.gnu.org).
  34  *
  35  */
  36
  37 #include "bayes.h"
  38 #include "best.h"
  39 #include "command.h"
  40 #include "mcmc.h"
  41 #include "model.h"
  42 #include "utils.h"
  43
  44 const char* const svnRevisionUtilsC = "$Rev: 1062 $";   /* Revision keyword which is expended/updated by svn on each commit/update */
  45
  46 #define MAX_GAMMA_CATS                      20
  47 #define PI                                  3.14159265358979324
  48 #define PIOVER2                             1.57079632679489662
  49 #define POINTGAMMA(prob,alpha,beta)         PointChi2(prob,2.0*(alpha))/(2.0*(beta))
  50 #define PAI2                                6.283185307
  51 #define TINY                                1.0e-20
  52 #define EVALUATE_COMPLEX_NUMBERS            2
  53 #if !defined(MAX)
  54 #define MAX(a,b)                            (((a) > (b)) ? (a) : (b))
  55 #endif
  56 #if !defined(MIN)
  57 #define MIN(a,b)                            (((a) < (b)) ? (a) : (b))
  58 #endif
  59 #define SQUARE(a)                           ((a)*(a))
  60
  61 /* local global variable */
  62 char    noLabel[] = "";
  63
  64 /* local prototypes */
  65 void    DatedNodeDepths (TreeNode *p, MrBFlt *nodeDepths, int *index);
  66 void    DatedNodes (TreeNode *p, TreeNode **datedTips, int *index);
  67 int     NConstrainedTips (TreeNode *p);
  68 int     NDatedTips (TreeNode *p);
  69 void    PrintNode (char **s, int *len, TreeNode *p, int isRooted);
  70 void    ResetPolyNode (PolyNode *p);
  71 void    ResetTreeNode (TreeNode *p);
  72 void    SetNodeDepths (Tree *t);
  73
  74 void    AddTwoMatrices (int dim, MrBFlt **a, MrBFlt **b, MrBFlt **result);
  75 void    BackSubstitutionRow (int dim, MrBFlt **u, MrBFlt *b);
  76 void    Balanc (int dim, MrBFlt **a, int *low, int *high, MrBFlt *scale);
  77 void    BalBak (int dim, int low, int high, MrBFlt *scale, int m, MrBFlt **z);
  78 MrBFlt  BetaCf (MrBFlt a, MrBFlt b, MrBFlt x);
  79 MrBFlt  BetaQuantile (MrBFlt alpha, MrBFlt beta, MrBFlt x);
  80 MrBFlt  CdfBinormal (MrBFlt h1, MrBFlt h2, MrBFlt r);
  81 MrBFlt  CdfNormal (MrBFlt x);
  82 complex Complex (MrBFlt a, MrBFlt b);
  83 MrBFlt  ComplexAbsoluteValue (complex a);
  84 complex ComplexAddition (complex a, complex b);
  85 complex ComplexConjugate (complex a);
  86 complex ComplexDivision (complex a, complex b);
  87 void    ComplexDivision2 (MrBFlt ar, MrBFlt ai, MrBFlt br, MrBFlt bi, MrBFlt *cr, MrBFlt *ci);
  88 complex ComplexExponentiation (complex a);
  89 int     ComplexInvertMatrix (int dim, complex **a, MrBFlt *dwork, int *indx, complex **aInverse, complex *col);
  90 complex ComplexLog (complex a);
  91 void    ComplexLUBackSubstitution (int dim, complex **a, int *indx, complex *b);
  92 int     ComplexLUDecompose (int dim, complex **a, MrBFlt *vv, int *indx, MrBFlt *pd);
  93 complex ComplexMultiplication (complex a, complex b);
  94 complex ComplexSquareRoot (complex a);
  95 complex ComplexSubtraction (complex a, complex b);
  96 int     ComputeEigenSystem (int dim, MrBFlt **a, MrBFlt *v, MrBFlt *vi, MrBFlt **u, int *iwork, MrBFlt *dwork);
  97 void    ComputeLandU (int dim, MrBFlt **aMat, MrBFlt **lMat, MrBFlt **uMat);
  98 void    ComputeMatrixExponential (int dim, MrBFlt **a, int qValue, MrBFlt **f);
  99 void    DivideByTwos (int dim, MrBFlt **a, int power);
 100 MrBFlt  D_sign (MrBFlt a, MrBFlt b);
 101 int     EigensForRealMatrix (int dim, MrBFlt **a, MrBFlt *wr, MrBFlt *wi, MrBFlt **z, int *iv1, MrBFlt *fv1);
 102 void    ElmHes (int dim, int low, int high, MrBFlt **a, int *interchanged);
 103 void    ElTran (int dim, int low, int high, MrBFlt **a, int *interchanged, MrBFlt **z);
 104 void    Exchange (int j, int k, int l, int m, int n, MrBFlt **a, MrBFlt *scale);
 105 MrBFlt  Factorial (int x);
 106 void    ForwardSubstitutionRow (int dim, MrBFlt **L, MrBFlt *b);
 107 MrBFlt  GammaRandomVariable (MrBFlt a, MrBFlt b, RandLong *seed);
 108 void    GaussianElimination (int dim, MrBFlt **a, MrBFlt **bMat, MrBFlt **xMat);
 109 int     Hqr2 (int dim, int low, int high, MrBFlt **h, MrBFlt *wr, MrBFlt *wi, MrBFlt **z);
 110 MrBFlt  IncompleteBetaFunction (MrBFlt alpha, MrBFlt beta, MrBFlt x);
 111 MrBFlt  IncompleteGamma (MrBFlt x, MrBFlt alpha, MrBFlt LnGamma_alpha);
 112 int     InvertMatrix (int dim, MrBFlt **a, MrBFlt *col, int *indx, MrBFlt **aInv);
 113 MrBFlt  LBinormal (MrBFlt h1, MrBFlt h2, MrBFlt r);
 114 int     LogBase2Plus1 (MrBFlt x);
 115 void    LUBackSubstitution (int dim, MrBFlt **a, int *indx, MrBFlt *b);
 116 int     LUDecompose (int dim, MrBFlt **a, MrBFlt *vv, int *indx, MrBFlt *pd);
 117 void    MultiplyMatrixByScalar (int dim, MrBFlt **a, MrBFlt scalar, MrBFlt **result);
 118 MrBFlt  PointChi2 (MrBFlt prob, MrBFlt v);
 119 void    PrintComplexVector (int dim, complex *vec);
 120 void    PrintSquareComplexMatrix (int dim, complex **m);
 121 void    PrintSquareDoubleMatrix (int dim, MrBFlt **matrix);
 122 void    PrintSquareIntegerMatrix (int dim, int **matrix);
 123 complex ProductOfRealAndComplex (MrBFlt a, complex b);
 124 MrBFlt  RndGamma (MrBFlt s, RandLong *seed);
 125 MrBFlt  RndGamma1 (MrBFlt s, RandLong *seed);
 126 MrBFlt  RndGamma2 (MrBFlt s, RandLong *seed);
 127 int     SetQvalue (MrBFlt tol);
 128 void    SetToIdentity (int dim, MrBFlt **matrix);
 129 MrBFlt  Tha (MrBFlt h1, MrBFlt h2, MrBFlt a1, MrBFlt a2);
 130 void    TiProbsUsingEigens (int dim, MrBFlt *cijk, MrBFlt *eigenVals, MrBFlt v, MrBFlt r, MrBFlt **tMat, MrBFlt **fMat, MrBFlt **sMat);
 131 void    TiProbsUsingPadeApprox (int dim, MrBFlt **qMat, MrBFlt v, MrBFlt r, MrBFlt **tMat, MrBFlt **fMat, MrBFlt **sMat);
 132
 133 MrBFlt  QuantileLogNormal (MrBFlt prob, MrBFlt mu, MrBFlt sigma);
 134 int     DiscreteLogNormal (MrBFlt *rK, MrBFlt sigma, int K, int median);
 135 MrBFlt  LogNormalPoint (MrBFlt x, MrBFlt mu, MrBFlt sigma);
 136
 137 /* AddBitfield: Add bitfield to list of bitfields. The function uses global variable nLongsNeeded. */
 138 int AddBitfield (BitsLong ***list, int listLen, int *set, int setLen)
 139 {
 140     int     i, nLongsNeeded;
 141
 142     nLongsNeeded = (setLen - 1) / nBitsInALong + 1;
 143
 144     (*list) = (BitsLong **) SafeRealloc ((void *)(*list), ((size_t)listLen+1)*sizeof(BitsLong *));
 145     if (!(*list))
 146         return ERROR;
 147
 148     (*list)[listLen] = (BitsLong *) SafeMalloc ((size_t)nLongsNeeded*sizeof(BitsLong));
 149     if (!(*list)[listLen])
 150         return ERROR;
 151
 152     ClearBits ((*list)[listLen], nLongsNeeded);
 153     for (i=0; i<setLen; i++)
 154         if (set[i] == YES)
 155             SetBit(i, (*list)[listLen]);
 156
 157     return NO_ERROR;
 158 }
 159
 160
 161 #if defined (SSE_ENABLED)
 162 void * AlignedMalloc (size_t size, size_t alignment)
 163 {
 164     void *mem;
 165
 166     #if defined GCC_SSE     /* gcc compiler */
 167     if (posix_memalign (&mem, alignment, size))
 168         return 0;
 169     #elif defined ICC_SSE   /* icc compiler */
 170     mem = _mm_malloc (size, alignment);
 171     #elif defined MS_VCPP_SSE  /* ms visual */
 172     mem = _aligned_malloc (size, alignment);
 173     #else
 174     mem = malloc (size);
 175     #endif
 176
 177     return mem;
 178 }
 179
 180
 181 void AlignedSafeFree (void **ptr)
 182 {
 183
 184     #if defined ICC_SSE     /* icc compiler */
 185     _mm_free (*ptr);
 186     #elif defined MS_VCPP_SSE  /* ms visual */
 187     _aligned_free (*ptr);
 188     #else
 189     free (*ptr);
 190     #endif
 191
 192     (*ptr) = NULL;
 193 }
 194 #endif
 195
 196
 197 int AreBitfieldsEqual (BitsLong *p, BitsLong *q, int length)
 198 {
 199     int i;
 200
 201     for (i=0; i<length; i++)
 202         {
 203         if (p[i] != q[i])
 204             return NO;
 205         }
 206
 207     return YES;
 208 }
 209
 210
 211 /*----------------------------------------------------------------
 212 |
 213 |   Bit: return 1 if bit n is set in BitsLong *p
 214 |       else return 0
 215 |
 216 -----------------------------------------------------------------*/
 217 int Bit (int n, BitsLong *p)
 218 {
 219     BitsLong        x, bitsLongOne;
 220
 221     bitsLongOne = 1;
 222
 223     p += n / nBitsInALong;
 224     x = bitsLongOne << (n % nBitsInALong);
 225
 226     if ((x & (*p)) == 0)
 227         return 0;
 228     else
 229         return 1;
 230
 231 }
 232
 233
 234 /* ClearBit: Clear one bit in a bitfield */
 235 void ClearBit (int i, BitsLong *bits)
 236 {
 237     BitsLong        x, bitsLongOne=1;
 238
 239     bits += i / nBitsInALong;
 240
 241     x = bitsLongOne << (i % nBitsInALong);
 242     x ^= bitsLongWithAllBitsSet;
 243
 244     (*bits) &= x;
 245 }
 246
 247
 248 /* ClearBits: Clear all bits in a bitfield */
 249 void ClearBits (BitsLong *bits, int nLongs)
 250 {
 251     int     i;
 252
 253     for (i=0; i<nLongs; i++)
 254         bits[i] = 0;
 255 }
 256
 257
 258 /* Copy bitfields */
 259 void CopyBits (BitsLong *dest, BitsLong *source, int length)
 260 {
 261     int     i;
 262
 263     for (i=0; i<length; i++)
 264         dest[i] = source[i];
 265 }
 266
 267
 268 /* CopyResults: copy results from one file to another up to lastGen*/
 269 int CopyResults (FILE *toFile, char *fromFileName, int lastGen)
 270 {
 271     int     longestLine;
 272     char    *strBuf, *strCpy, *word;
 273     FILE    *fromFile;
 274
 275     if ((fromFile = OpenBinaryFileR(fromFileName)) == NULL)
 276         return ERROR;
 277
 278     longestLine = LongestLine(fromFile)+10;
 279     SafeFclose(&fromFile);
 280     strBuf = (char *) SafeCalloc (2*(longestLine+2),sizeof(char));
 281     strCpy = strBuf + longestLine + 2;
 282
 283     if ((fromFile = OpenTextFileR(fromFileName)) == NULL)
 284         return ERROR;
 285
 286     while (fgets(strBuf,longestLine,fromFile)!=NULL)
 287         {
 288         strncpy (strCpy,strBuf,longestLine);
 289         word = strtok(strCpy," ");
 290         /* atoi returns 0 when word is not integer number */
 291         if (atoi(word)>lastGen)
 292             break;
 293         fprintf (toFile,"%s",strBuf);
 294         fflush (toFile);
 295         }
 296
 297     SafeFclose(&fromFile);
 298     free(strBuf);
 299     return (NO_ERROR);
 300 }
 301
 302
 303 /* CopyProcessSsFile: copy results from one file to another up to lastStep. Also marginalLnLSS is collected for processed steps*/
 304 int CopyProcessSsFile (FILE *toFile, char *fromFileName, int lastStep, MrBFlt *marginalLnLSS, MrBFlt * splitfreqSS)
 305 {
 306     int     longestLine, run, curStep, i;
 307     double  tmp;
 308     char    *strBuf, *strCpy, *word, *tmpcp;
 309     FILE    *fromFile;
 310
 311     if ((fromFile = OpenBinaryFileR(fromFileName)) == NULL)
 312         return ERROR;
 313
 314     longestLine = LongestLine(fromFile)+10;
 315     SafeFclose(&fromFile);
 316     strBuf = (char *) SafeCalloc (2*(longestLine+2),sizeof(char));
 317     strCpy = strBuf + longestLine + 2;
 318
 319     if ((fromFile = OpenTextFileR(fromFileName)) == NULL)
 320         return ERROR;
 321
 322     while (fgets(strBuf,longestLine,fromFile)!=NULL)
 323         {
 324         strncpy (strCpy,strBuf,longestLine);
 325         word = strtok(strCpy," \t\n");
 326         /* atoi returns 0 when word is not integer number */
 327         if (atoi(word)>lastStep)
 328             break;
 329         fprintf (toFile,"%s",strBuf);
 330         fflush (toFile);
 331         curStep = atoi(word);
 332         if (curStep > 0)
 333             {
 334             strtok(NULL,"\t\n"); /*skip power*/
 335             for (run=0; run<chainParams.numRuns; run++)
 336                 {
 337                 tmpcp = strtok(NULL,"\t\n");
 338                 if (tmpcp == NULL)
 339                     {
 340                     MrBayesPrint ("%s   Error: In .ss file not enough ellements on the string :%s        \n", spacer, strBuf);
 341                     return ERROR;
 342                     }
 343                 tmp = atof(tmpcp);
 344                 if (tmp == 0.0)
 345                     {
 346                     MrBayesPrint ("%s   Error: Value of some step contribution is 0.0 or not a number in .ss file. Sting:%s        \n", spacer, strBuf);
 347                     return ERROR;
 348                     }
 349                 marginalLnLSS[run]+=tmp;
 350                 }
 351             for (i=0; i<numTopologies; i++)
 352                 {
 353                 tmpcp = strtok(NULL,"\t\n");
 354                 if (tmpcp == NULL)
 355                     {
 356                     MrBayesPrint ("%s   Error: In .ss file not enough ellements on the string :%s        \n", spacer, strBuf);
 357                     return ERROR;
 358                     }
 359                 tmp = atof(tmpcp);
 360                 splitfreqSS[i*chainParams.numStepsSS + curStep-1] = tmp;
 361                 }
 362             }
 363         }
 364
 365     SafeFclose(&fromFile);
 366     free(strBuf);
 367     return (NO_ERROR);
 368 }
 369
 370
 371 /* CopyTreeResults: copy tree results upto lastGen from one file to another. numTrees is return containing number of trees that were copied. */
 372 int CopyTreeResults (FILE *toFile, char *fromFileName, int lastGen, int *numTrees)
 373 {
 374     int     longestLine;
 375     char    *strBuf, *strCpy, *word;
 376     FILE    *fromFile;
 377
 378     (*numTrees) = 0;
 379
 380     if ((fromFile = OpenBinaryFileR(fromFileName)) == NULL)
 381         return ERROR;
 382
 383     longestLine = LongestLine(fromFile)+10;
 384     SafeFclose(&fromFile);
 385     strBuf = (char *) SafeCalloc (2*(longestLine+2),sizeof(char));
 386     strCpy = strBuf + longestLine + 2;
 387
 388     if ((fromFile = OpenTextFileR(fromFileName)) == NULL)
 389         return ERROR;
 390
 391     while (fgets(strBuf,longestLine,fromFile)!=NULL)
 392         {
 393         strncpy (strCpy,strBuf,longestLine);
 394         word = strtok(strCpy," ");
 395         if (strcmp(word,"tree")==0)
 396             {
 397             word = strtok(NULL," ");
 398             /* atoi returns 0 when word is not integer number,
 399                4 is offset to get rid of "rep." in tree name */
 400             if (atoi(word+4)>lastGen)
 401                 break;
 402             (*numTrees)++;
 403             fprintf (toFile,"%s",strBuf);
 404             }
 405         else if (*numTrees == 0)   /* do not print the end statement */
 406             fprintf (toFile,"%s",strBuf);
 407         fflush (toFile);
 408         }
 409
 410     SafeFclose(&fromFile);
 411     free(strBuf);
 412     return (NO_ERROR);
 413 }
 414
 415
 416 /* FirstTaxonInPartition: Find index of first taxon in partition */
 417 int FirstTaxonInPartition (BitsLong *partition, int length)
 418 {
 419     int         i, j, nBits, taxon;
 420     BitsLong    x, bitsLongOne=1;
 421
 422     nBits = sizeof(BitsLong) * 8;
 423
 424     taxon = 0;
 425     for (i=0; i<length; i++)
 426         {
 427         x = bitsLongOne;
 428         for (j=0; j<nBits; j++)
 429             {
 430             if (partition[i] & x)
 431                 return taxon;
 432             taxon++;
 433             x <<= 1;
 434             }
 435         }
 436
 437     return taxon;
 438 }
 439
 440
 441 /* FirstTree: Return file position of first tree after current position */
 442 long FirstTree (FILE *fp, char *lineBuf, int longestLine)
 443 {
 444     long    firstTree;
 445     char    *word;
 446
 447     do {
 448         firstTree = ftell(fp);
 449         if ((fgets (lineBuf, longestLine, fp)) == NULL)
 450             return 0;
 451         word = strtok (lineBuf, " ");
 452         } while (strcmp(word,"tree")!=0);
 453
 454     return (firstTree);
 455 }
 456
 457
 458 int Flip01 (int x)
 459 {
 460     if (x == 0)
 461         return (1);
 462     else
 463         return (0);
 464 }
 465
 466
 467 void FlipBits (BitsLong *partition, int length, BitsLong *mask)
 468 {
 469     int         i;
 470
 471     for (i=0; i<length; i++)
 472         {
 473         partition[i] ^= mask[i];
 474         }
 475 }
 476
 477
 478 /*-----------------------------------------------------------------
 479 |
 480 |   FlipOneBit: flip bit n in BitsLong *p
 481 |
 482 ------------------------------------------------------------------*/
 483 void FlipOneBit (int n, BitsLong *p)
 484 {
 485     BitsLong        x, bitsLongOne=1;
 486
 487     p += n/nBitsInALong;
 488     x = bitsLongOne << (n % nBitsInALong);
 489     (*p) ^= x;
 490 }
 491
 492
 493 /* Convert from 0-based growth function over six states to model index */
 494 int FromGrowthFxnToIndex(int *growthFxn)
 495 {
 496     int     i, j, k, max, fxn[6];
 497
 498     /* set local growth fxn to lexicographical max */
 499     for (i=0; i<6; i++)
 500         fxn[i] = i;
 501
 502     /* decrease until we reach growthFxn */
 503     for (k=202; k>=0; k--)
 504         {
 505         for (i=0; i<6; i++)
 506             {
 507             if (fxn[i] != growthFxn[i])
 508                 break;
 509             }
 510         if (i == 6)
 511             break;
 512
 513         /* get next growth fxn */
 514         for (i=5; i>=0; i--)
 515             {
 516             fxn[i]--;
 517             if (fxn[i] >= 0)
 518                 break;
 519             }
 520
 521         if (i < 0)
 522             return -1;  /* error */
 523         else if (i < 5)
 524             {
 525             max = 0;
 526             for (j=0; j<=i; j++)
 527                 {
 528                 if (fxn[j] > max)
 529                     max = fxn[j];
 530                 }
 531             fxn[++i] = max + 1;
 532             for (++i; i<6; i++)
 533                 fxn[i] = fxn[i-1] + 1;
 534             }
 535         }
 536
 537     return k;
 538 }
 539
 540
 541 /* Convert from model index to 0-based growth function over six states */
 542 void FromIndexToGrowthFxn(int index, int *growthFxn)
 543 {
 544     int     i, j, max, k;
 545
 546     /* set growth fxn to lexicographical max */
 547     for (i=0; i<6; i++)
 548         growthFxn[i] = i;
 549
 550     /* decrease until we reach index */
 551     for (k=202; k>index; k--)
 552         {
 553         for (i=5; i>=0; i--)
 554             {
 555             growthFxn[i]--;
 556             if (growthFxn[i] >= 0)
 557                 break;
 558             }
 559
 560         if (i < 0)
 561             return; /* ERROR */
 562         else if (i < 5)
 563             {
 564             max = 0;
 565             for (j=0; j<=i; j++)
 566                 {
 567                 if (growthFxn[j] > max)
 568                     max = growthFxn[j];
 569                 }
 570             growthFxn[++i] = max + 1;
 571             for (++i; i<6; i++)
 572                 growthFxn[i] = growthFxn[i-1] + 1;
 573             }
 574         }
 575 }
 576
 577
 578 /* GetIntSummary: Get summary statistics for a number of runs (int version) */
 579 void GetIntSummary (int **vals, int nRows, int *rowCount, Stat *theStats, int HPD)
 580 {
 581     int     i, j, nVals;
 582     MrBFlt  *theValues, *p;
 583
 584     nVals = 0;
 585     for (i=0; i<nRows; i++)
 586         nVals += rowCount[i];
 587
 588     theValues = (MrBFlt *) SafeCalloc (nVals, sizeof(MrBFlt));
 589
 590     /* extract values */
 591     p = theValues;
 592     for (i=0; i<nRows; i++)
 593         {
 594         for (j=0; j<rowCount[i]; j++)
 595             {
 596             (*p++) = (MrBFlt) (vals[i][j]);
 597             }
 598         }
 599
 600     /* get statistics */
 601     MeanVariance (theValues, nVals, &(theStats->mean), &(theStats->var));
 602     if (HPD == YES)
 603         LowerUpperMedian (theValues, nVals, &(theStats->lower), &(theStats->upper), &(theStats->median));
 604     else
 605         LowerUpperMedian (theValues, nVals, &(theStats->lower), &(theStats->upper), &(theStats->median));
 606
 607     free (theValues);
 608 }
 609
 610
 611 /* Get k from 0-based growth function */
 612 int GetKFromGrowthFxn(int *growthFxn)
 613 {
 614     int i, k=0;
 615
 616     for (i=0; i<6; i++)
 617         if (growthFxn[i] > k)
 618             k = growthFxn[i];
 619
 620     return k+1;
 621 }
 622
 623
 624 /* GetSummary: Get summary statistics for a number of runs */
 625 void GetSummary (MrBFlt **vals, int nRows, int *rowCount, Stat *theStats, int HPD)
 626 {
 627     int     i, nVals;
 628     MrBFlt  *theValues, *p, *ESS;
 629
 630     nVals = 0;
 631     for (i=0; i<nRows; i++)
 632         nVals += rowCount[i];
 633
 634     theValues = (MrBFlt *) SafeMalloc ((size_t)nVals * sizeof(MrBFlt));
 635
 636     /* extract values */
 637     p = theValues;
 638     for (i=0; i<nRows; i++)
 639         {
 640         memcpy ((void *)(p), (void *)(vals[i]), (size_t)rowCount[i] * sizeof(MrBFlt));
 641         p += rowCount[i];
 642         }
 643
 644     /* get statistics */
 645     MeanVariance (theValues, nVals, &(theStats->mean), &(theStats->var));
 646     if (HPD == YES)
 647         LowerUpperMedianHPD (theValues, nVals, &(theStats->lower), &(theStats->upper), &(theStats->median));
 648     else
 649         LowerUpperMedian (theValues, nVals, &(theStats->lower), &(theStats->upper), &(theStats->median));
 650     if (nRows > 1)
 651         theStats->PSRF = PotentialScaleReduction (vals, nRows, rowCount);
 652
 653     ESS = (MrBFlt *) SafeMalloc ((size_t)nRows * sizeof(MrBFlt));
 654
 655     EstimatedSampleSize (vals, nRows, rowCount, ESS);
 656     theStats->avrESS = theStats->minESS = ESS[0];
 657     for (i=1; i<nRows; i++)
 658         {
 659         theStats->avrESS += ESS[i];
 660         if (theStats->minESS > ESS[i])
 661             {
 662             theStats->minESS = ESS[i];
 663             }
 664         }
 665     theStats->avrESS /=nRows;
 666
 667     free (ESS);
 668     free (theValues);
 669 }
 670
 671
 672 /* HarmonicArithmeticMean: Calculate harmonic and arithmetic mean from log values */
 673 int HarmonicArithmeticMeanOnLogs (MrBFlt *vals, int nVals, MrBFlt *mean, MrBFlt *harm_mean)
 674 {
 675     int             i, reliable;
 676     MrBFlt          a, x, y, scaler, n;
 677
 678     reliable = YES;
 679
 680     scaler = vals[nVals-1];
 681     a  = n = 0.0;
 682     for (i=0; i<nVals; i++)
 683         {
 684         y = vals[i];
 685         y -= scaler;
 686         if (y > 400.0)
 687             {
 688             if (y > 5000.0)
 689                 {
 690                 reliable = NO;
 691                 continue;
 692                 }
 693             a /= exp(y - 100.0);
 694             scaler += y - 100.0;
 695             y = 100.0;
 696             }
 697
 698         x = (MrBFlt) exp(y);
 699
 700         if (n < 0.5)
 701             a = x;
 702         else
 703             {
 704             a += x;
 705             }
 706         n += 1.0;
 707         }
 708
 709     /* arithmetic mean */
 710     (*mean) = (MrBFlt) log(a/n) + scaler;
 711
 712     scaler = (MrBFlt) (0.0 - vals[nVals-1]);
 713     a  = n = 0.0;
 714     for (i=0; i<nVals; i++)
 715         {
 716         y = (MrBFlt) (0.0 - vals[i]);
 717         y -= scaler;
 718         if (y > 400.0)
 719             {
 720             if (y > 5000.0)
 721                 {
 722                 reliable = NO;
 723                 continue;
 724                 }
 725             a /= exp(y - 100.0);
 726             scaler += y - 100.0;
 727             y = 100.0;
 728             }
 729
 730         x = (MrBFlt) exp(y);
 731
 732         if (n < 0.5)
 733             a = x;
 734         else
 735             {
 736             a += x;
 737             }
 738         n += (MrBFlt) 1.0;
 739         }
 740
 741     /* harmonic mean */
 742     (*harm_mean) = - (MrBFlt) log(a/n) - scaler;
 743
 744     if (reliable == YES)
 745         return (NO_ERROR);
 746     else
 747         return (ERROR);
 748 }
 749
 750
 751 /* IsBitSet: Is bit i set in BitsLong *bits ? */
 752 int IsBitSet (int i, BitsLong *bits)
 753 {
 754     BitsLong        x, bitsLongOne=1;
 755
 756     bits += i / nBitsInALong;
 757
 758     x = bitsLongOne << (i % nBitsInALong);
 759
 760     if ((*bits) & x)
 761         return (YES);
 762     else
 763         return (NO);
 764 }
 765
 766
 767 /* IsConsistentWith: Is token consistent with expected word, case insensitive ? */
 768 int IsConsistentWith (const char *token, const char *expected)
 769 {
 770     int     i, len;
 771
 772     if (strlen(token) > strlen(expected))
 773         return NO;
 774
 775     len = (int) strlen (token);
 776
 777     for (i=0; i<len; i++)
 778         {
 779         if (tolower(token[i]) != tolower(expected[i]))
 780             return NO;
 781         }
 782
 783     return YES;
 784 }
 785
 786
 787 /* IsPartCompatible: Determine whether two partitions are nonoverlapping or nested (compatible) or
 788         incompatible (partially overlapping) */
 789 int IsPartCompatible (BitsLong *smaller, BitsLong *larger, int length)
 790 {
 791     int i;
 792
 793     /* test first if they overlap */
 794     for (i=0; i<length; i++)
 795         if ((smaller[i]&larger[i]) != 0)
 796             break;
 797
 798     /* if they overlap, they must be nested */
 799     if (i != length)    /* potentially incompatible */
 800         {
 801         for (i=0; i<length; i++)
 802             if ((smaller[i]|larger[i]) != larger[i])
 803                 break;
 804         }
 805
 806     if (i == length)    /* passed either one of the tests */
 807         return YES;
 808     else
 809         return NO;
 810 }
 811
 812
 813 /* IsPartNested: Test whether smaller partition is nested in larger partition */
 814 int IsPartNested (BitsLong *smaller, BitsLong *larger, int length)
 815 {
 816     int i;
 817
 818     for (i=0; i<length; i++)
 819         if ((smaller[i] | larger[i]) != larger[i])
 820             break;
 821
 822     if (i == length)
 823         return YES;
 824     else
 825         return NO;
 826 }
 827
 828
 829 /* IsSectionEmpty: Test whether section of two bitfields is empty */
 830 int IsSectionEmpty (BitsLong *bitField1, BitsLong *bitField2, int length)
 831 {
 832     int i;
 833
 834     for (i=0; i<length; i++)
 835         if ((bitField1[i] & bitField2[i]) != 0)
 836             return NO;
 837
 838     return YES;
 839 }
 840
 841
 842 /* IsSectionEmpty: Test whether union of bitField1 and bitField2 equal to bitField3*/
 843 int IsUnionEqThird (BitsLong *bitField1, BitsLong *bitField2, BitsLong *bitField3, int length)
 844 {
 845     int i;
 846
 847     for (i=0; i<length; i++)
 848         if ((bitField1[i] | bitField2[i]) != bitField3[i])
 849             return NO;
 850
 851     return YES;
 852 }
 853
 854
 855 /* LastBlock: Return file position of last block in file */
 856 long LastBlock (FILE *fp, char *lineBuf, int longestLine)
 857 {
 858     long    lastBlock;
 859     char    *word;
 860
 861     lastBlock = 0L;
 862     rewind (fp);
 863
 864     while ((fgets (lineBuf, longestLine, fp)) != NULL)
 865         {
 866         word = strtok (lineBuf, " ");
 867         if (strcmp (word, "begin") == 0)
 868             lastBlock = ftell (fp);
 869         }
 870
 871     return lastBlock;
 872 }
 873
 874
 875 int LineTermType (FILE *fp)
 876 {
 877     int         ch, nextCh, term;
 878
 879     term = LINETERM_UNIX;   /* default if no line endings are found */
 880     while ((ch = getc(fp)) != EOF)
 881         {
 882         if ((ch == '\n') || (ch == '\r'))
 883             {
 884             if (ch == '\n')
 885                 term = LINETERM_UNIX;
 886             else /* ch = '\r' */
 887                 {
 888                 /* First test below handles one-line MAC file */
 889                 if (((nextCh = getc(fp)) == EOF) || (nextCh != '\n'))
 890                     term = LINETERM_MAC;
 891                 else
 892                     term = LINETERM_DOS;
 893                 }
 894             break;
 895             }
 896         }
 897     (void)fseek(fp, 0L, 0);     /* rewind */
 898
 899     return (term);
 900 }
 901
 902
 903 /*The longest line in a file including line terminating characters present in binary mode.*/
 904 int LongestLine (FILE *fp)
 905 {
 906     int         ch, lineLength, longest;
 907
 908     longest = 0;
 909     lineLength = 0;
 910     ch = fgetc(fp);
 911     while (ch != EOF)
 912         {
 913         if ((ch != '\n') && (ch != '\r'))
 914             {
 915             ch = fgetc(fp);
 916             lineLength++;
 917             continue;
 918             }
 919         if (ch == '\r')
 920             {
 921             if ((ch = fgetc(fp)) == '\n')
 922                 {
 923                 /* windows \r\n */
 924                 lineLength++;
 925                 ch = fgetc(fp);
 926                 }
 927             else
 928                 {
 929                 /* old mac \r */
 930                 }
 931             }
 932         else  /*unix, linux,new mac or text mode read \n*/
 933             {
 934                 ch = fgetc(fp);
 935             }
 936
 937         if (lineLength > longest)
 938                 longest = lineLength;
 939             lineLength = 0;
 940         /*
 941         if ((ch == '\n') || (ch == '\r'))
 942             {
 943             if (lineLength > longest)
 944                 longest = lineLength;
 945             lineLength = 0;
 946             }
 947         else
 948             lineLength++;
 949             */
 950         }
 951     rewind (fp);        /* rewind */
 952
 953     return (longest+1); /*+1 to accommodate last character*/
 954 }
 955
 956
 957 /* LowerUpperMedian: Determine median and 95 % credible interval */
 958 void LowerUpperMedian (MrBFlt *vals, int nVals, MrBFlt *lower, MrBFlt *upper, MrBFlt *median)
 959
 960 {
 961     SortMrBFlt (vals, 0, nVals-1);
 962
 963     *lower  = vals[(int)(0.025*nVals)];
 964     *upper  = vals[(int)(0.975*nVals)];
 965     *median = vals[nVals/2];
 966
 967 }
 968
 969
 970 /* LowerUpperMedianHPD: Use a simple way to determine HPD */
 971 void LowerUpperMedianHPD (MrBFlt *vals, int nVals, MrBFlt *lower, MrBFlt *upper, MrBFlt *median)
 972 {
 973     int     i, width, theStart;
 974     MrBFlt  f, g, interval;
 975
 976     SortMrBFlt (vals, 0, nVals-1);
 977
 978     width = (int)(nVals * 0.95 + 0.5);
 979     theStart = 0;
 980     interval = vals[width-1] - vals[0];
 981     for (i=1; i<nVals-width; i++)
 982     {
 983         f = vals[i];
 984         g = vals[i+width];
 985         if (g - f < interval)
 986         {
 987             interval = g - f;
 988             theStart = i;
 989         }
 990     }
 991
 992     *lower  = vals[theStart];
 993     *upper  = vals[theStart+width-1];
 994     *median = vals[nVals/2];
 995 }
 996
 997
 998 MrBFlt MaximumValue (MrBFlt x, MrBFlt y)
 999 {
1000     if (x > y)
1001         return (x);
1002     else
1003         return (y);
1004 }
1005
1006
1007 MrBFlt MinimumValue (MrBFlt x, MrBFlt y)
1008 {
1009     if (x < y)
1010         return (x);
1011     else
1012         return (y);
1013 }
1014
1015
1016 /* NOTE!!!! The result of this function should be used before consequtive call to it again.
1017    It means NEVER use it like this:  printf ("%s %s", MbPrintNum (a),MbPrintNum (b)) */
1018 char *MbPrintNum (MrBFlt num)
1019 {
1020     static char s[40];
1021
1022     if (scientific == YES)
1023         sprintf (s,"%.*le", precision, num);
1024     else
1025         sprintf (s,"%.*lf", precision, num);
1026
1027     return s;
1028 }
1029
1030
1031 void MeanVariance (MrBFlt *vals, int nVals, MrBFlt *mean, MrBFlt *var)
1032 {
1033     int             i;
1034     MrBFlt          a, aOld, s, x;
1035
1036     a = s = 0.0;
1037     for (i=0; i<nVals; i++)
1038         {
1039         x = vals[i];
1040         aOld = a;
1041         a += (x - a) / (MrBFlt) (i + 1);
1042         s += (x - a) * (x - aOld);
1043         }
1044
1045     /* mean */
1046     (*mean) = a;
1047
1048     /* variance */
1049     if (nVals <= 1)
1050         (*var) = 0.0;
1051     else
1052         (*var) = s / (nVals - 1);
1053 }
1054
1055
1056 /*  Compute mean and variance of log scaled values.
1057 @param vals    pointer to values in log scale
1058 @param nVals   number of "vals", minimum 1
1059 @param mean    adress of variable where computed mean is returned by the function
1060 @param var     adress of variable where computed variance is returned by the function. Could be set to NULL if this value need not to be returened.
1061 @param varEst  adress of variable where computed estimate of the population variance is returned, could be set to NULL if this value need not to be returened.
1062                Could be set to NULL if this value need not to be returened.
1063 Note: We devide by nVals or by (nVals-1) when var and varEst is calculated from the sum of square differences. */
1064 void MeanVarianceLog (MrBFlt *vals, int nVals, MrBFlt *mean, MrBFlt *var, MrBFlt *varEst)
1065 {
1066     int             i;
1067     MrBFlt          a, aOld, s, x, y, scaler;
1068
1069     a = s = 0.0;
1070     scaler = vals[nVals-1];
1071     for (i=0; i<nVals; i++)
1072         {
1073         y = vals[i];
1074         y -= scaler;
1075         if (y > 200.0)
1076             {
1077             a /= exp(y - 100.0);
1078             s /= exp(2*(y - 100));
1079             scaler += y - 100.0;
1080             y = 100.0;
1081             }
1082
1083         x=(MrBFlt)exp(y);
1084
1085         aOld = a;
1086         a += (x - a) / (MrBFlt) (i + 1);
1087         s += (x - a) * (x - aOld);
1088         }
1089
1090     /* mean */
1091     (*mean) = log(a) + scaler;
1092
1093     /* variance */
1094     if (var!=NULL)
1095         {
1096         if (nVals <= 1)
1097             (*var) = 0.0;
1098         else
1099             (*var) = log(s / nVals) + 2*scaler;
1100         }
1101
1102     /* variance */
1103     if (varEst!=NULL)
1104         {
1105         if (nVals <= 1)
1106             (*varEst) = 0.0;
1107         else
1108             (*varEst) = log(s / (nVals+1)) + 2*scaler;
1109         }
1110 }
1111
1112
1113 void MrBayesPrint (char *format, ...)
1114 {
1115     va_list ptr;
1116
1117 #   if defined (MPI_ENABLED)
1118     if (proc_id == 0)
1119         {
1120         if (echoMB == YES)
1121             {
1122             va_start (ptr, format);
1123             vprintf (format, ptr);
1124             va_end(ptr);
1125             fflush (stdout);
1126             }
1127         if (logToFile == YES)
1128             {
1129             if (logFileFp == NULL)
1130                 printf ("%s   Could not print log output to file\n", spacer);
1131             else
1132                 {
1133                 va_start (ptr, format);
1134                 vfprintf (logFileFp, format, ptr);
1135                 va_end(ptr);
1136                 fflush (logFileFp);
1137                 }
1138             }
1139         }
1140 #   else
1141     if (chainParams.redirect == NO)
1142         {
1143         if (echoMB == YES)
1144             {
1145             va_start (ptr, format);
1146             vprintf (format, ptr);
1147             va_end(ptr);
1148             fflush (stdout);
1149             }
1150         if (logToFile == YES)
1151             {
1152             if (logFileFp == NULL)
1153                 {
1154                 printf ("%s   Could not print log output to file\n", spacer);
1155                 logToFile = NO;
1156                 }
1157             else
1158                 {
1159                 va_start (ptr, format);
1160                 vfprintf (logFileFp, format, ptr);
1161                 va_end(ptr);
1162                 fflush (logFileFp);
1163                 }
1164             }
1165         }
1166 #   endif
1167 }
1168
1169
1170 void MrBayesPrintf (FILE *f, char *format, ...)
1171 {
1172     va_list                 ptr;
1173
1174 #   if defined (MPI_ENABLED)
1175     if (proc_id == 0)
1176         {
1177         va_start (ptr, format);
1178         vfprintf (f, format, ptr);
1179         va_end(ptr);
1180         fflush(f);
1181         }
1182 #   else
1183     va_start (ptr, format);
1184     vfprintf (f, format, ptr);
1185     va_end(ptr);
1186     fflush(f);
1187 #   endif
1188 }
1189
1190
1191 /** Next taxon in partition, for cycling over set bits in bit fields */
1192 int NextTaxonInPartition(int currentTaxon, BitsLong *partition, int length)
1193 {
1194     int         i, j, taxon;
1195     BitsLong    x, bitsLongOne=1;
1196
1197     taxon = currentTaxon + 1;
1198     i = taxon / nBitsInALong;
1199     x = (bitsLongOne << taxon % nBitsInALong);
1200     for (j=taxon%nBitsInALong; j<nBitsInALong; j++)
1201         {
1202         if (partition[i] & x)
1203             return taxon;
1204         taxon++;
1205         x <<= 1;
1206         }
1207
1208     for (i++; i<length; i++)
1209         {
1210         x = 1;
1211         for (j=0; j<nBitsInALong; j++)
1212             {
1213             if (partition[i] & x)
1214                 return taxon;
1215             taxon++;
1216             x <<= 1;
1217             }
1218         }
1219
1220     return taxon;
1221 }
1222
1223
1224 /* NBits: count bits in an int */
1225 int NBits (int x)
1226 {
1227     int n=0;
1228
1229     for (n=0; x != 0; n++)
1230         x &= (x-1);
1231
1232     return n;
1233 }
1234
1235
1236 /* NumBits: Count bits in a bitfield */
1237 int NumBits (BitsLong *x, int len)
1238 {
1239     int         i, n=0;
1240     BitsLong    y;
1241
1242     for (i=0; i<len; i++)
1243         {
1244         y = x[i];
1245         while (y != 0)
1246             {
1247             y &= (y-1);
1248             n++;
1249             }
1250         }
1251     return n;
1252 }
1253
1254
1255 FILE *OpenBinaryFileR (char *name)
1256 {
1257     FILE        *fp;
1258     char        fileName[200];
1259
1260     strcpy(fileName, workingDir);
1261     strncat(fileName, name, 199 - strlen(fileName));
1262
1263     if ((fp = fopen (fileName, "rb")) == NULL)
1264         {
1265         MrBayesPrint ("%s   Could not open file \"%s\"\n", spacer, name);
1266         return (NULL);
1267         }
1268     else
1269         return (fp);
1270 }
1271
1272
1273 FILE *OpenTextFileR (char *name)
1274 {
1275     FILE        *fp;
1276     char        fileName[200];
1277
1278     strcpy(fileName, workingDir);
1279     strncat(fileName, name, 199 - strlen(fileName));
1280
1281     if ((fp = fopen (fileName, "r")) == NULL)
1282         {
1283         MrBayesPrint ("%s   Could not open file \"%s\"\n", spacer, fileName);
1284         return (NULL);
1285         }
1286     else
1287         return (fp);
1288 }
1289
1290
1291 FILE *OpenTextFileRQuait (char *name)
1292 {
1293     FILE        *fp;
1294     char        fileName[200];
1295
1296     strcpy(fileName, workingDir);
1297     strncat(fileName, name, 199 - strlen(fileName));
1298
1299     if ((fp = fopen (fileName, "r")) == NULL)
1300         {
1301         return (NULL);
1302         }
1303     else
1304         return (fp);
1305 }
1306
1307
1308 FILE *OpenTextFileA (char *name)
1309 {
1310     FILE        *fp;
1311     char        fileName[200];
1312
1313     strcpy(fileName, workingDir);
1314     strncat(fileName, name, 199 - strlen(fileName));
1315
1316     if ((fp = fopen (fileName, "a+")) == NULL)
1317         {
1318         MrBayesPrint ("%s   Could not open file \"%s\"\n", spacer, name);
1319         return (NULL);
1320         }
1321     else
1322         return (fp);
1323 }
1324
1325
1326 FILE *OpenTextFileW (char *name)
1327 {
1328     FILE        *fp;
1329     char        fileName[200];
1330
1331     strcpy(fileName, workingDir);
1332     strncat(fileName, name, 199 - strlen(fileName));
1333
1334     if ((fp = fopen (fileName, "w+")) == NULL)
1335         {
1336         MrBayesPrint ("%s   Could not open file \"%s\"\n", spacer, name);
1337         return (NULL);
1338         }
1339     else
1340         return (fp);
1341 }
1342
1343
1344 /*!
1345 \param vals[0..nRuns][count[]]   All records for all runs
1346 \param nRuns                     Number of runs
1347 \param count[0..nRuns]           Number of records in each run
1348 \return PSRF
1349 */
1350 MrBFlt PotentialScaleReduction (MrBFlt **vals, int nRuns, int *count)
1351 {
1352     int             i, j, nVals;
1353     MrBFlt          aW, aOldW, sW, sWj, aB, aOldB, sB, x, R2, weight;
1354
1355     aB = sB = sW = sWj = 0.0;
1356     nVals = 0;
1357     for (j=0; j<nRuns; j++)
1358         {
1359         if (count[j]==0)
1360             {
1361             return -1.0;
1362             }
1363         nVals += count[j];
1364         aW = vals[j][0];
1365         for (i=1; i<count[j]; i++)
1366             {
1367             x = vals[j][i];
1368             aOldW = aW;
1369             aW += (x - aW) / (MrBFlt) (i + 1);
1370             sWj += (x - aW) * (x - aOldW);
1371             }
1372         sW += sWj / (MrBFlt)(count[j] - 1);
1373         x = aW;
1374         aOldB = aB;
1375         aB += (x - aB) / (MrBFlt) (j + 1);
1376         if (j!=0)
1377             sB += (x - aB) * (x - aOldB);
1378         }
1379
1380     sB = sB / (MrBFlt) (nRuns - 1);
1381     sW = sW / (MrBFlt) (nRuns);
1382
1383     weight = (MrBFlt) nVals / (MrBFlt) nRuns;
1384     if (sW > 0.0)
1385         {
1386         R2 = ((weight - 1.0) / weight) + ((MrBFlt)(nRuns + 1) / (MrBFlt) (nRuns)) * (sB / sW);
1387         return sqrt(R2);
1388         }
1389     else
1390         return -1.0;
1391 }
1392
1393
1394 /*!
1395 \param vals[0..nRuns][count[]]   All records for all runs
1396 \param nRuns                     Number of runs
1397 \param count[0..nRuns]           Number of records in each run
1398 \param returnESS[0..nRuns]       Is an arry in which the routine returns ESS values for each run.
1399 */
1400 void EstimatedSampleSize (MrBFlt **vals, int nRuns, int *count, MrBFlt *returnESS)
1401 {
1402     int         i, j, lag, maxLag, samples;
1403     MrBFlt      *values, mean, del1, del2, varStat=0.0;
1404     MrBFlt      gammaStat[2000];
1405
1406     for (i=0; i<nRuns; i++)
1407         {
1408         samples=count[i];
1409         values=vals[i];
1410         mean=0.0;
1411         for (j=0; j<samples; j++)
1412             {
1413             mean+=values[j];
1414             }
1415         mean /=samples;
1416
1417         maxLag = ((samples - 1) > 2000)?2000:(samples - 1);
1418
1419         for (lag = 0; lag < maxLag; lag++)
1420             {
1421             gammaStat[lag]=0;
1422             for (j = 0; j < samples - lag; j++)
1423                 {
1424                 del1 = values[j] - mean;
1425                 del2 = values[j + lag] - mean;
1426                 gammaStat[lag] += (del1 * del2);
1427                 }
1428
1429             gammaStat[lag] /= ((MrBFlt) (samples - lag));
1430
1431             if (lag == 0)
1432                 {
1433                 varStat = gammaStat[0];
1434                 }
1435             else if (lag % 2 == 0)
1436                 {
1437                 if (gammaStat[lag - 1] + gammaStat[lag] > 0)
1438                     {
1439                     varStat += 2.0 * (gammaStat[lag - 1] + gammaStat[lag]);
1440                     }
1441                 else
1442                     maxLag = lag;
1443                 }
1444             }
1445         returnESS[i] = (gammaStat[0] * samples) / varStat;
1446         }
1447 }
1448
1449
1450 /* SafeCalloc: Print error if out of memory */
1451 void *SafeCalloc(size_t n, size_t s) {
1452
1453     void *ptr;
1454
1455     if (s*n == 0)
1456         {
1457         //return NULL;
1458         }
1459
1460     ptr= calloc(n, s);
1461
1462     if (ptr==NULL)
1463         {
1464         MrBayesPrint ("%s   Out of memory. Most probable course for the problem is that MrBayes reached\n", spacer);
1465         MrBayesPrint ("%s   the limit of allowed memory for a process in your Operating System. Consult\n", spacer);
1466         MrBayesPrint ("%s   documentation of your OS how to extend the limit, or use 64 bit version OS \n", spacer);
1467         MrBayesPrint ("%s   and compile 64 bit version of MrBayes.                                     \n", spacer);
1468         MrBayesPrint ("%s   Segmentation fault may follow.                                             \n", spacer);
1469         return NULL;
1470         }
1471
1472     return ptr;
1473 }
1474
1475
1476 int SafeFclose(FILE **fp) {
1477     int retval=-1;
1478 #   if defined MPI_ENABLED
1479     if (proc_id == 0) {
1480 #   endif
1481     if (fp!=NULL && (*fp)!=NULL)
1482         retval=fclose(*fp);
1483     *fp = NULL;
1484 #   if defined MPI_ENABLED
1485     }
1486 #   endif
1487     return retval;
1488 }
1489
1490
1491 /* SafeFree: Set pointer to freed space to NULL */
1492 void SafeFree (void **ptr)
1493 {
1494     free (*ptr);
1495
1496     (*ptr) = NULL;
1497 }
1498
1499
1500 /* SafeMalloc: Print error if out of memory; clear memory */
1501 void *SafeMalloc (size_t s)
1502 {
1503     void *ptr;
1504
1505     if (s == 0)
1506         {
1507         return NULL;
1508         }
1509
1510     ptr= malloc(s);
1511
1512     if (ptr==NULL)
1513         {
1514         MrBayesPrint ("%s   Out of memory. Most probable course for the problem is that MrBayes reached\n", spacer);
1515         MrBayesPrint ("%s   the limit of allowed memory for a process in your Operating System. Consult\n", spacer);
1516         MrBayesPrint ("%s   documentation of your OS how to extend the limit, or use 64 bit version OS \n", spacer);
1517         MrBayesPrint ("%s   and compile 64 bit version of MrBayes.                                     \n", spacer);
1518         MrBayesPrint ("%s   Segmentation fault may follow.                                             \n", spacer);
1519         return NULL;
1520         }
1521
1522     return memset(ptr,0,s);
1523 }
1524
1525
1526 /* SafeRealloc: Print error if out of memory */
1527 void *SafeRealloc (void *ptr, size_t s)
1528 {
1529     if (s == 0)
1530         {
1531         free(ptr);
1532         return NULL;
1533         }
1534
1535     if (ptr == NULL)
1536         {
1537         ptr = malloc (s);
1538         memset(ptr, 0, s);
1539         }
1540     else
1541         ptr = realloc (ptr, s);
1542
1543     if (ptr==NULL)
1544         {
1545         MrBayesPrint ("%s   Out of memory. Most probable course for the problem is that MrBayes reached\n", spacer);
1546         MrBayesPrint ("%s   the limit of allowed memory for a process in your Operating System. Consult\n", spacer);
1547         MrBayesPrint ("%s   documentation of your OS how to extend the limit, or use 64 bit version OS \n", spacer);
1548         MrBayesPrint ("%s   and compile 64 bit version of MrBayes.                                     \n", spacer);
1549         MrBayesPrint ("%s   Segmentation fault may follow.                                             \n", spacer);
1550         return NULL;
1551         }
1552
1553     return ptr;
1554 }
1555
1556
1557 /* SafeStrcat: Allocate or reallocate target to fit result; assumes ptr is NULL if not allocated */
1558 char *SafeStrcat (char **target, const char *source)
1559 {
1560     if (*target == NULL)
1561         *target = (char *) SafeCalloc (strlen(source)+1, sizeof(char));
1562     else
1563         *target = (char *) SafeRealloc ((void *)*target, (strlen(source)+strlen(*target)+1)*sizeof(char));
1564
1565     if (*target)
1566         strcat(*target, source);
1567
1568     return (*target);
1569 }
1570
1571
1572 /* SafeStrcpy: Allocate or reallocate target to fit result; assumes ptr is NULL if not allocated */
1573 char *SafeStrcpy (char **target, const char *source)
1574 {
1575     *target = (char *) SafeRealloc ((void *)*target, (strlen(source)+1)*sizeof(char));
1576
1577     if (*target)
1578         strcpy(*target,source);
1579
1580     return (*target);
1581 }
1582
1583
1584 /* SetBit: Set a particular bit in a series of longs */
1585 void SetBit (int i, BitsLong *bits)
1586 {
1587     BitsLong        x, bitsLongOne=1;
1588
1589     bits += i / nBitsInALong;
1590
1591     x = bitsLongOne << (i % nBitsInALong);
1592
1593     (*bits) |= x;
1594 }
1595
1596
1597 void SortInts (int *item, int *assoc, int count, int descendingOrder)
1598 {
1599     SortInts2 (item, assoc, 0, count-1, descendingOrder);
1600 }
1601
1602
1603 void SortInts2 (int *item, int *assoc, int left, int right, int descendingOrder)
1604 {
1605     register int    i, j, x, y;
1606
1607     if (descendingOrder == YES)
1608         {
1609         i = left;
1610         j = right;
1611         x = item[(left+right)/2];
1612         do
1613             {
1614             while (item[i] > x && i < right)
1615                 i++;
1616             while (x > item[j] && j > left)
1617                 j--;
1618             if (i <= j)
1619                 {
1620                 y = item[i];
1621                 item[i] = item[j];
1622                 item[j] = y;
1623
1624                 if (assoc)
1625                     {
1626                     y = assoc[i];
1627                     assoc[i] = assoc[j];
1628                     assoc[j] = y;
1629                     }
1630                 i++;
1631                 j--;
1632                 }
1633             } while (i <= j);
1634         if (left < j)
1635             SortInts2 (item, assoc, left, j, descendingOrder);
1636         if (i < right)
1637             SortInts2 (item, assoc, i, right, descendingOrder);
1638         }
1639     else
1640         {
1641         i = left;
1642         j = right;
1643         x = item[(left+right)/2];
1644         do
1645             {
1646             while (item[i] < x && i < right)
1647                 i++;
1648             while (x < item[j] && j > left)
1649                 j--;
1650             if (i <= j)
1651                 {
1652                 y = item[i];
1653                 item[i] = item[j];
1654                 item[j] = y;
1655
1656                 if (assoc)
1657                     {
1658                     y = assoc[i];
1659                     assoc[i] = assoc[j];
1660                     assoc[j] = y;
1661                     }
1662                 i++;
1663                 j--;
1664                 }
1665             } while (i <= j);
1666         if (left < j)
1667             SortInts2 (item, assoc, left, j, descendingOrder);
1668         if (i < right)
1669             SortInts2 (item, assoc, i, right, descendingOrder);
1670         }
1671 }
1672
1673
1674 /* SortMrBFlt: Sort in increasing order */
1675 void SortMrBFlt (MrBFlt *item, int left, int right)
1676 {
1677     register int    i, j;
1678     MrBFlt          x, temp;
1679
1680     i = left;
1681     j = right;
1682     x = item[(left+right)/2];
1683     do
1684         {
1685         while (item[i] < x && i < right)
1686             i++;
1687         while (x < item[j] && j > left)
1688             j--;
1689         if (i <= j)
1690             {
1691             temp = item[i];
1692             item[i] = item[j];
1693             item[j] = temp;
1694
1695             i++;
1696             j--;
1697             }
1698         } while (i <= j);
1699     if (left < j)
1700         SortMrBFlt (item, left, j);
1701     if (i < right)
1702         SortMrBFlt (item, i, right);
1703 }
1704
1705
1706 /* StrCmpCaseInsensitive: Case insensitive string comparison */
1707 int StrCmpCaseInsensitive (char *s, char *t)
1708 {
1709     int i, minLen;
1710
1711     if (strlen(s) < strlen(t))
1712         minLen = (int) strlen(s);
1713     else
1714         minLen = (int) strlen(t);
1715
1716     for (i=0; i<minLen; i++)
1717         if (tolower(s[i])!= tolower(t[i]))
1718             break;
1719
1720     if (s[i] == '\0' && t[i] == '\0')
1721         return 0;
1722     else if (tolower(s[i]) > tolower(t[i]))
1723         return 1;
1724     else
1725         return -1;
1726 }
1727
1728
1729 /* StripComments: Strip possibly nested comments from the string s.
1730     Example: s="text1[text2[text3]]"-> s="text1" */
1731 void StripComments (char *s)
1732 {
1733     char    *t;
1734     int     inComment;
1735
1736     inComment = 0;
1737     for (t=s; *s != '\0'; s++)
1738         {
1739         if (inComment == 0)
1740             {
1741             if (*s == '[')
1742                 inComment++;
1743             else
1744                 *t++ = *s;
1745             }
1746         else
1747             {
1748             if (*s == ']')
1749                 inComment--;
1750             else if (*s == '[')
1751                 inComment++;
1752             }
1753         }
1754     *t = '\0';
1755 }
1756
1757
1758 FILE *TestOpenTextFileR (char *name)
1759 {
1760     char        fileName[100];
1761
1762     strcpy(fileName, workingDir);
1763     strncat(fileName, name, 99 - strlen(fileName));
1764
1765     return fopen (fileName, "r");
1766 }
1767
1768
1769 /*---------
1770 |
1771 |   UpdateGrowthFxn: We expect a set of unique indexes from 0 to 5
1772 |      indicating a partition of 6 rates into sets. We make sure
1773 |      the indices correspond to a restricted growth function here.
1774 |
1775 -----------------------*/
1776 void UpdateGrowthFxn(int *growthFxn)
1777 {
1778     int     i, j, max, fxn[6];
1779
1780     for (i=0; i<6; i++)
1781         fxn[i] = -1;
1782
1783     max = 0;
1784     for (i=0; i<6; i++)
1785         {
1786         if (fxn[i] != -1)
1787             continue;
1788         for (j=i; j<6; j++)
1789             {
1790             if (growthFxn[j] == growthFxn[i])
1791                 fxn[j] = max;
1792             }
1793         max++;
1794         }
1795
1796     for (i=0; i<6; i++)
1797         growthFxn[i] = fxn[i];
1798 }
1799
1800
1801 int UpperTriangIndex(int i, int j, int size)
1802 {
1803     if (i < j)
1804         return (2*size - i - 3) * i / 2 + j - 1;
1805     else
1806         return (2*size - j - 3) * j / 2 + i - 1;
1807 }
1808
1809
1810 int WantTo (const char *msg)
1811 {
1812     char    s[100];
1813     int     i;
1814
1815     MrBayesPrint ("%s   %s? (yes/no): ", spacer, msg);
1816
1817     for (i=0; i<10; i++)
1818         {
1819         if (fgets (s, 98, stdin) == NULL)
1820             {
1821             MrBayesPrint ("%s   Failed to retrieve answer; will take that as a no\n", spacer);
1822             return NO;
1823             }
1824
1825         /* Strip away the newline */
1826         s[strlen(s)-1] = '\0';
1827
1828         /* Check answer */
1829         if (IsConsistentWith (s, "yes") == YES)
1830             return YES;
1831         else if (IsConsistentWith (s, "no") == YES)
1832             return NO;
1833
1834         MrBayesPrint ("%s   Enter yes or no: ", spacer);
1835         }
1836
1837     MrBayesPrint ("%s   MrBayes does not understand; will take that as a no\n", spacer);
1838
1839     return NO;
1840 }
1841
1842
1843 /* the following are moved from tree.c */
1844 /* AddToTreeList: Add tree at end of tree list */
1845 int AddToTreeList (TreeList *treeList, Tree *tree)
1846 {
1847     TreeListElement     *listElement = (TreeListElement *) SafeCalloc (1, sizeof(TreeListElement));
1848     if (!listElement)
1849         return (ERROR);
1850
1851     listElement->order = (int *) SafeCalloc (tree->nIntNodes-1, sizeof(int));
1852     if (!listElement->order)
1853         return (ERROR);
1854     listElement->next = NULL;
1855
1856     if (treeList->last == NULL)
1857         treeList->last = treeList->first = listElement;
1858     else
1859         {
1860         treeList->last->next = listElement;
1861         treeList->last = listElement;
1862         }
1863
1864     if (tree->isRooted)
1865         StoreRTopology (tree, listElement->order);
1866     else
1867         StoreUTopology (tree, listElement->order);
1868
1869     return (NO_ERROR);
1870 }
1871
1872
1873 /* AllocatePolyTree: Allocate memory space for a polytomous tree */
1874 PolyTree *AllocatePolyTree (int numTaxa)
1875 {
1876     int         i;
1877     PolyTree    *pt;
1878
1879     pt = (PolyTree *) SafeCalloc (1, sizeof (PolyTree));
1880     if (!pt)
1881         return (NULL);
1882
1883     pt->memNodes = 2*numTaxa;
1884     pt->nodes = (PolyNode *) SafeCalloc (2*numTaxa, sizeof(PolyNode));
1885     pt->allDownPass = (PolyNode **) SafeCalloc (3*numTaxa, sizeof (PolyNode *));
1886     pt->intDownPass = pt->allDownPass + 2*numTaxa;
1887     if (pt->nodes == NULL || pt->allDownPass == NULL)
1888         {
1889         free (pt->nodes);
1890         free (pt->allDownPass);
1891         free (pt);
1892         return (NULL);
1893         }
1894
1895     /* initialize nodes and set index and memoryIndex */
1896     for (i=0; i<2*numTaxa; i++)
1897         {
1898         ResetPolyNode(&pt->nodes[i]);
1899         pt->nodes[i].memoryIndex = i;
1900         pt->nodes[i].index = i;
1901         }
1902
1903     /* initialize tree properties */
1904     pt->nNodes = pt->nIntNodes = 0;
1905     pt->root = NULL;
1906     pt->brlensDef = NO;
1907     pt->isRooted = NO;
1908     pt->isClock = NO;
1909     pt->isCalibrated = NO;
1910     pt->isRelaxed = NO;
1911     pt->clockRate = 0.0;
1912     strcpy(pt->name,"");
1913
1914     /* initialize bitsets */
1915     pt->bitsets = NULL;
1916
1917     /* initialize relaxed clock parameters */
1918     pt->nESets = 0;
1919     pt->nEvents = NULL;
1920     pt->position = NULL;
1921     pt->rateMult = NULL;
1922     pt->eSetName = NULL;
1923
1924     pt->nBSets = 0;
1925     pt->effectiveBrLen = NULL;
1926     pt->bSetName = NULL;
1927
1928     /* initialize population size set parameters */
1929     pt->popSizeSet = NO;
1930     pt->popSize = NULL;
1931     pt->popSizeSetName = NULL;
1932
1933     return (pt);
1934 }
1935
1936
1937 /* AllocatePolyTreeRelClockParams: Allocate space for relaxed clock parameters */
1938 int AllocatePolyTreeRelClockParams (PolyTree *pt, int nBSets, int nESets)
1939 {
1940     int     i;
1941
1942     /* free previous clock params if any */
1943     FreePolyTreeRelClockParams (pt);
1944
1945     /* set number of sets */
1946     pt->nBSets = nBSets;
1947     pt->nESets = nESets;
1948
1949     /* we do not allocate space for the actual names here; these will be NULL pointers */
1950
1951     /* take care of branch params */
1952     if (pt->nBSets > 0)
1953         {
1954         pt->bSetName = (char **) SafeCalloc (pt->nBSets, sizeof (char *));
1955         pt->effectiveBrLen = (MrBFlt **) SafeCalloc (pt->nBSets, sizeof (MrBFlt *));
1956         for (i=0; i<pt->nBSets; i++)
1957             pt->effectiveBrLen[i] = (MrBFlt *) SafeCalloc (pt->memNodes, sizeof(MrBFlt));
1958         }
1959
1960     /* take care of breakpoint params */
1961     if (pt->nESets > 0)
1962         {
1963         pt->eSetName = (char **) SafeCalloc (pt->nESets, sizeof(char *));
1964         pt->nEvents = (int **) SafeCalloc (pt->nESets, sizeof(int *));
1965         pt->position = (MrBFlt ***) SafeCalloc (pt->nESets, sizeof(MrBFlt **));
1966         pt->rateMult = (MrBFlt ***) SafeCalloc (pt->nESets, sizeof(MrBFlt **));
1967         for (i=0; i<pt->nESets; i++)
1968             {
1969             pt->nEvents[i] = (int *) SafeCalloc (pt->memNodes, sizeof(int));
1970             pt->position[i] = (MrBFlt **) SafeCalloc (pt->memNodes, sizeof(MrBFlt *));
1971             pt->rateMult[i] = (MrBFlt **) SafeCalloc (pt->memNodes, sizeof(MrBFlt *));
1972             }
1973         }
1974
1975     return (NO_ERROR);
1976 }
1977
1978
1979 /* AllocatePolyTreePartitions: Allocate space for and set partitions for polytomous tree */
1980 int AllocatePolyTreePartitions (PolyTree *pt)
1981 {
1982     int         i, nLongsNeeded, numTaxa;
1983
1984     /* get some handy numbers */
1985     numTaxa = pt->memNodes/2;
1986     nLongsNeeded = (numTaxa -1) / nBitsInALong + 1;
1987
1988     /* allocate space */
1989     pt->bitsets = (BitsLong *) SafeRealloc ((void *)pt->bitsets, pt->memNodes*nLongsNeeded*sizeof(BitsLong));
1990     if (pt->bitsets == NULL)
1991         return (ERROR);
1992     for (i=0; i<pt->memNodes*nLongsNeeded; i++)
1993         pt->bitsets[i] = 0;
1994
1995     /* set node partition pointers */
1996     for (i=0; i<pt->memNodes; i++)
1997         pt->nodes[i].partition = pt->bitsets + i*nLongsNeeded;
1998
1999     /* clear and set partitions; if the tree is empty, nothing is set */
2000     ResetPolyTreePartitions(pt);
2001
2002     return (NO_ERROR);
2003 }
2004
2005
2006 /* AllocateTree: Allocate memory space for a tree (unrooted or rooted) */
2007 Tree *AllocateTree (int numTaxa)
2008 {
2009     int     i;
2010     Tree    *t;
2011
2012     t = (Tree *) SafeCalloc (1, sizeof (Tree));
2013     if (t == NULL)
2014         return NULL;
2015
2016     /* initialize basic tree properties */
2017     t->memNodes = 2*numTaxa;
2018     strcpy (t->name, "");
2019
2020     t->isRooted = NO;
2021     t->isClock = NO;
2022
2023     t->checkConstraints = NO;
2024     t->nConstraints = 0;
2025     t->nLocks = 0;
2026     t->isCalibrated = NO;
2027     t->nNodes = t->nIntNodes = 0;
2028     t->nRelParts = 0;
2029     t->relParts = NULL;
2030
2031     /* initialize pointers */
2032     t->bitsets = NULL;
2033     t->flags = NULL;
2034     t->constraints = NULL;
2035
2036     /* allocate and initialize nodes and node arrays (enough for both rooted and unrooted trees) */
2037     t->nNodes = 0;
2038     t->nIntNodes = 0;
2039     if ((t->nodes = (TreeNode *) SafeCalloc (2*numTaxa, sizeof (TreeNode))) == NULL)
2040         {
2041         free (t);
2042         return NULL;
2043         }
2044     if ((t->allDownPass = (TreeNode **) SafeCalloc (3*numTaxa, sizeof (TreeNode *))) == NULL)
2045         {
2046         free (t->nodes);
2047         free (t);
2048         return NULL;
2049         }
2050     t->intDownPass = t->allDownPass + t->memNodes;
2051
2052     /* initialize nodes and set index and memoryIndex */
2053     for (i=0; i<t->memNodes; i++)
2054         {
2055         ResetTreeNode(&t->nodes[i]);
2056         t->nodes[i].memoryIndex = i;
2057         t->nodes[i].index = i;
2058         }
2059
2060     return t;
2061 }
2062
2063
2064 /* AllocateFixedTree: Allocate memory space for a fixed unrooted or rooted tree */
2065 Tree *AllocateFixedTree (int numTaxa, int isRooted)
2066 {
2067     int     i;
2068     Tree    *t;
2069
2070     t = (Tree *) SafeCalloc (1, sizeof (Tree));
2071     if (t == NULL)
2072         return NULL;
2073
2074     /* initialize basic tree properties */
2075     if (isRooted == YES)
2076         t->memNodes = 2*numTaxa;
2077     else
2078         t->memNodes = 2*numTaxa - 2;
2079     strcpy (t->name, "");
2080
2081     t->isRooted = isRooted;
2082     t->isClock = NO;
2083
2084     t->checkConstraints = NO;
2085     t->nConstraints = 0;
2086     t->nLocks = 0;
2087     t->isCalibrated = NO;
2088     t->nNodes = t->nIntNodes = 0;
2089     t->nRelParts = 0;
2090     t->relParts = NULL;
2091
2092     /* initialize pointers */
2093     t->bitsets = NULL;
2094     t->flags = NULL;
2095     t->constraints = NULL;
2096
2097     /* allocate and initialize nodes and node arrays (enough for both rooted and unrooted trees) */
2098     if (t->isRooted)
2099         {
2100         t->nNodes = 2*numTaxa;
2101         t->nIntNodes = numTaxa - 1;
2102         }
2103     else
2104         {
2105         t->nNodes = 2*numTaxa - 2;
2106         t->nIntNodes = numTaxa - 2;
2107         }
2108     if ((t->nodes = (TreeNode *) SafeCalloc (t->nNodes, sizeof (TreeNode))) == NULL)
2109         {
2110         free (t);
2111         return NULL;
2112         }
2113     if ((t->allDownPass = (TreeNode **) SafeCalloc (t->nNodes + t->nIntNodes, sizeof (TreeNode *))) == NULL)
2114         {
2115         free (t->nodes);
2116         free (t);
2117         return NULL;
2118         }
2119     t->intDownPass = t->allDownPass + t->nNodes;
2120
2121     /* initialize nodes and set index and memoryIndex */
2122     for (i=0; i<t->memNodes; i++)
2123         {
2124         ResetTreeNode(&t->nodes[i]);
2125         t->nodes[i].memoryIndex = i;
2126         t->nodes[i].index = i;
2127         }
2128
2129     return t;
2130 }
2131
2132
2133 /* AllocateTreePartitions: Allocate space for and set partitions for tree */
2134 int AllocateTreePartitions (Tree *t)
2135 {
2136     int         i, nLongsNeeded, numTaxa;
2137     TreeNode    *p;
2138
2139     /* get some handy numbers */
2140     if (t->isRooted == YES)
2141         numTaxa = t->nNodes - t->nIntNodes - 1;
2142     else
2143         numTaxa = t->nNodes - t->nIntNodes;
2144     nLongsNeeded = (numTaxa - 1) / nBitsInALong + 1;
2145
2146     /* reallocate space */
2147     t->bitsets = (BitsLong *) SafeRealloc ((void *)(t->bitsets), (size_t)(t->nNodes) * (size_t)nLongsNeeded * sizeof(BitsLong));
2148     if (!t->bitsets)
2149         return (ERROR);
2150
2151     /* clear bit fields */
2152     for (i=0; i<t->nNodes*nLongsNeeded; i++)
2153         t->bitsets[i] = 0;
2154
2155     /* set node pointers to bit fields */
2156     for (i=0; i<t->nNodes; i++)
2157         {
2158         p = t->allDownPass[i];
2159         p->partition = t->bitsets + i*nLongsNeeded;
2160         }
2161
2162     /* set partition specifiers for terminals */
2163     ResetTreePartitions(t);
2164
2165     return (NO_ERROR);
2166 }
2167
2168
2169 int AreTopologiesSame (Tree *t1, Tree *t2)
2170 {
2171     int         i, j, k, nLongsNeeded, nTaxa;
2172     BitsLong    *mask;
2173     TreeNode    *p, *q;
2174
2175     if (t1->nNodes != t2->nNodes)
2176         return (NO);
2177     if (t1->nIntNodes != t2->nIntNodes)
2178         return (NO);
2179
2180     if (t1->isRooted == YES)
2181         nTaxa = t1->nNodes - t1->nIntNodes - 1;
2182     else
2183         nTaxa = t1->nNodes - t1->nIntNodes;
2184
2185     /* allocate space for mask */
2186     nLongsNeeded = (nTaxa - 1) / nBitsInALong + 1;
2187     mask = (BitsLong *) SafeCalloc (nLongsNeeded, sizeof(BitsLong));
2188
2189     /* set mask */
2190     for (i=0; i<nTaxa; i++)
2191         SetBit(i, mask);
2192
2193     /* allocate and set partition pointers */
2194     AllocateTreePartitions (t1);
2195     AllocateTreePartitions (t2);
2196
2197     /* check for congruence */
2198     for (i=0; i<t1->nIntNodes; i++)
2199         {
2200         p = t1->intDownPass[i];
2201         if (t1->isRooted == NO && IsBitSet(t2->root->index,p->partition))
2202                     FlipBits(p->partition,nLongsNeeded, mask);
2203         for (j=0; j<t2->nIntNodes; j++)
2204             {
2205             q = t2->intDownPass[j];
2206             for (k=0; k<nLongsNeeded; k++)
2207                 {
2208                 if (p->partition[k] != q->partition[k])
2209                     break;
2210                 }
2211             if (k == nLongsNeeded)
2212                 break;
2213             }
2214         if (j == t2->nIntNodes)
2215             {
2216             FreeTreePartitions (t1);
2217             FreeTreePartitions (t2);
2218             free (mask);
2219             return (NO);
2220             }
2221         }
2222
2223     FreeTreePartitions (t1);
2224     FreeTreePartitions (t2);
2225     free (mask);
2226     return (YES);
2227 }
2228
2229
2230 int AreTreesSame (Tree *t1, Tree *t2)
2231 {
2232     int         i, j, k, nLongsNeeded, nTaxa;
2233     BitsLong    *mask;
2234     TreeNode    *p, *q;
2235
2236     extern void ShowNodes(TreeNode*, int, int);
2237
2238     if (t1->nNodes != t2->nNodes)
2239         return (NO);
2240     if (t1->nIntNodes != t2->nIntNodes)
2241         return (NO);
2242
2243     if (t1->isRooted == YES)
2244         nTaxa = t1->nNodes - t1->nIntNodes - 1;
2245     else
2246         nTaxa = t1->nNodes - t1->nIntNodes;
2247
2248     /* allocate space for mask */
2249     nLongsNeeded = (nTaxa - 1) / nBitsInALong + 1;
2250     mask = (BitsLong *) SafeCalloc (nLongsNeeded, sizeof(BitsLong));
2251
2252     /* set mask */
2253     for (i=0; i<nTaxa; i++)
2254         SetBit(i, mask);
2255
2256     /* allocate and set partition pointers */
2257     AllocateTreePartitions (t1);
2258     AllocateTreePartitions (t2);
2259
2260     /* check for congruence */
2261     for (i=0; i<t1->nNodes; i++)
2262         {
2263         p = t1->allDownPass[i];
2264         if (p->anc == NULL && t1->isRooted == YES)
2265             continue;
2266         if (t1->isRooted == NO && IsBitSet(t2->root->index,p->partition))
2267             FlipBits(p->partition,nLongsNeeded, mask);
2268         for (j=0; j<t2->nNodes; j++)
2269             {
2270             q = t2->allDownPass[j];
2271             for (k=0; k<nLongsNeeded; k++)
2272                 {
2273                 if (p->partition[k] != q->partition[k])
2274                     break;
2275                 }
2276             if (k == nLongsNeeded && AreDoublesEqual (p->length, q->length, 0.000001) == YES)
2277                 break;
2278             else if (k == nLongsNeeded)
2279                 {
2280                 FreeTreePartitions (t1);
2281                 FreeTreePartitions (t2);
2282                 free (mask);
2283                 return (NO);
2284                 }
2285             }
2286         if (j == t2->nNodes)
2287             {
2288             FreeTreePartitions (t1);
2289             FreeTreePartitions (t2);
2290             free (mask);
2291             return (NO);
2292             }
2293         }
2294
2295     FreeTreePartitions (t1);
2296     FreeTreePartitions (t2);
2297     free (mask);
2298     return (YES);
2299 }
2300
2301
2302 /*----------------------------------------------------------------
2303 |
2304 |   BuildConstraintTree: Build constraint tree. The tree t is
2305 |      needed only to hold information about constraints and
2306 |      included taxa.
2307 |
2308 ----------------------------------------------------------------*/
2309 int BuildConstraintTree (Tree *t, PolyTree *pt, char **localTaxonNames)
2310 {
2311     int             i, j, k, constraintId, nLongsNeeded, nextNode;
2312     BitsLong        *constraintPartition, *mask;
2313     PolyNode        *pp, *qq, *rr, *ss, *tt;
2314
2315     pt->isRooted = t->isRooted;
2316
2317     nLongsNeeded = (numLocalTaxa - 1) / nBitsInALong + 1;
2318     constraintPartition = (BitsLong *) SafeCalloc (2*nLongsNeeded, sizeof(BitsLong));
2319     if (!constraintPartition)
2320         {
2321         MrBayesPrint ("%s   Problems allocating constraintPartition in BuildConstraintTree", spacer);
2322         return (ERROR);
2323         }
2324     mask = constraintPartition + nLongsNeeded;
2325
2326     /* calculate mask (needed to take care of unused bits when flipping partitions) */
2327     for (i=0; i<numLocalTaxa; i++)
2328         SetBit (i, mask);
2329
2330     /* reset all nodes */
2331     for (i=0; i<2*numLocalTaxa; i++)
2332         {
2333         pp = &pt->nodes[i];
2334         pp->isDated = NO;
2335         pp->calibration = NULL;
2336         pp->age = -1.0;
2337         pp->isLocked = NO;
2338         pp->lockID = -1;
2339         pp->index = i;
2340         }
2341
2342     /* build a bush */
2343     pt->root = &pt->nodes[numLocalTaxa];
2344     for (i=0; i<numLocalTaxa; i++)
2345         {
2346         pp = &pt->nodes[i];
2347         pp->index = i;
2348         pp->left = NULL;
2349         if (i == numLocalTaxa - 1)
2350             pp->sib = NULL;
2351         else
2352             pp->sib = &pt->nodes[i+1];
2353         pp->anc = pt->root;
2354         }
2355     pp = pt->root;
2356     pp->left = &pt->nodes[0];
2357     pp->anc = pp->sib = NULL;
2358     pt->nNodes = numLocalTaxa + 1;
2359     pt->nIntNodes = 1;
2360
2361     /* make sure the outgroup is the right-most node */
2362     pt->nodes[localOutGroup].index = numLocalTaxa - 1;
2363     pt->nodes[numLocalTaxa - 1].index = localOutGroup;
2364
2365     /* allocate and set partition specifiers in bush */
2366     GetPolyDownPass(pt);
2367     AllocatePolyTreePartitions(pt);
2368
2369     /* set terminal taxon labels */
2370     for (i=0; i<pt->nNodes; i++)
2371         {
2372         pp = pt->allDownPass[i];
2373         if (pp->index < numLocalTaxa)
2374             strcpy (pp->label, localTaxonNames[pp->index]);
2375         }
2376
2377     /* resolve the bush according to constraints */
2378     /* for now, satisfy all constraints */
2379     /* for now, bail out if constraints are not compatible */
2380     /* Eventually, we might want to be build a parsimony (WAB) or compatibility (WIB) matrix and
2381        draw a starting tree from the universe according to the score of the tree. A simple way of accomplishing
2382        approximately this is to use sequential addition, with probabilities in each step determined
2383        by the parsimony or compatibility score of the different possibilities. */
2384     nextNode = numLocalTaxa + 1;
2385     t->nLocks=0;
2386     for (constraintId=0; constraintId<numDefinedConstraints; constraintId++)
2387         {
2388         if (t->constraints[constraintId] == NO || definedConstraintsType[constraintId] != HARD)
2389             continue;
2390
2391         /* initialize bits in partition to add; get rid of deleted taxa in the process */
2392         ClearBits(constraintPartition, nLongsNeeded);
2393         for (i=j=0; i<numTaxa; i++)
2394             {
2395             if (taxaInfo[i].isDeleted == YES)
2396                 continue;
2397             if (IsBitSet(i, definedConstraint[constraintId]) == YES)
2398                 SetBit(j, constraintPartition);
2399             j++;
2400             }
2401         assert (j == numLocalTaxa);
2402
2403         /* make sure outgroup is outside constrained partition if the tree is unrooted */
2404         if (t->isRooted == NO && IsBitSet(localOutGroup, constraintPartition))
2405             FlipBits(constraintPartition, nLongsNeeded, mask);
2406
2407         /* check that partition should be included */
2408         k = NumBits(constraintPartition, nLongsNeeded);
2409         if (k == 0)
2410             {
2411             MrBayesPrint ("%s   WARNING: Constraint '%s' refers only to deleted taxa\n", spacer, constraintNames[constraintId]);
2412             MrBayesPrint ("%s            and will be disregarded\n", spacer);
2413             t->constraints[constraintId] = NO;
2414             continue;
2415             }
2416         if (k == 1)
2417             {
2418             MrBayesPrint ("%s   WARNING: Constraint '%s' refers to a single tip and\n", spacer, constraintNames[constraintId]);
2419             MrBayesPrint ("%s            will be disregarded\n", spacer);
2420             t->constraints[constraintId] = NO;
2421             continue;
2422             }
2423
2424         /* check if root in rooted tree (we allow this to enable inference of ancestral states) */
2425         if (k == numLocalTaxa && t->isRooted == YES)
2426             {
2427             if (pt->root->isLocked == YES) {
2428                 MrBayesPrint ("%s   WARNING: Constraint '%s' is a duplicate of another constraint\n", spacer, constraintNames[constraintId]);
2429                 MrBayesPrint ("%s            and will be ignored\n", spacer);
2430                 t->constraints[constraintId] = NO;
2431                 continue;
2432                 }
2433             pt->root->isLocked = YES;
2434             pt->root->lockID = constraintId;
2435             t->nLocks++;
2436             continue;
2437             }
2438
2439         /* check if interior root in unrooted tree (we allow this to enable inference of ancestral states) */
2440         if ((k == numLocalTaxa - 1 || k == numLocalTaxa) && t->isRooted == NO)
2441             {
2442             if (pt->root->isLocked == YES) {
2443                 MrBayesPrint ("%s   WARNING: Constraint '%s' is a duplicate of another constraint\n", spacer, constraintNames[constraintId]);
2444                 MrBayesPrint ("%s            and will be ignored\n", spacer);
2445                 t->constraints[constraintId] = NO;
2446                 continue;
2447                 }
2448             pt->root->isLocked = YES;
2449             pt->root->lockID = constraintId;
2450             t->nLocks++;
2451             continue;
2452             }
2453
2454         /* find first included terminal */
2455         k = FirstTaxonInPartition (constraintPartition, nLongsNeeded);
2456         for (i=0; pt->nodes[i].index != k; i++)
2457             ;
2458         pp = &pt->nodes[i];
2459
2460         /* go down until node is not included in constraint */
2461         do {
2462             qq = pp;
2463             pp = pp->anc;
2464         } while (IsPartNested(pp->partition, constraintPartition, nLongsNeeded));
2465
2466         /* check that the node has not yet been included */
2467         for (i=0; i<nLongsNeeded; i++)
2468             {
2469             if (qq->partition[i] != constraintPartition[i])
2470                 break;
2471             }
2472         if (i==nLongsNeeded)
2473             {
2474             MrBayesPrint ("%s   WARNING: Constraint '%s' is a duplicate of another constraint\n", spacer, constraintNames[constraintId]);
2475             MrBayesPrint ("%s            and will be ignored\n", spacer);
2476             t->constraints[constraintId] = NO;
2477             continue;
2478             }
2479
2480         /* create a new node */
2481         tt = &pt->nodes[nextNode++];
2482         tt->anc = pp;
2483         tt->isLocked = YES;
2484         tt->lockID = constraintId;
2485         t->nLocks++;
2486         for (i=0; i<nLongsNeeded; i++)
2487             tt->partition[i] = constraintPartition[i];
2488         pt->nIntNodes++;
2489         pt->nNodes++;
2490
2491         /* sort descendant nodes in two connected groups: included and excluded */
2492         /* if there is a descendant that overlaps (incompatible) then return error */
2493         rr = ss = NULL;
2494         qq = pp->left;
2495         do {
2496             if (IsPartNested(qq->partition, constraintPartition, nLongsNeeded))
2497                 {
2498                 if (ss != NULL)
2499                     ss->sib = qq;
2500                 else
2501                     tt->left = qq;
2502                 ss = qq;
2503                 qq->anc = tt;
2504                 }
2505             else if (IsPartCompatible(qq->partition, constraintPartition, nLongsNeeded))
2506                 {
2507                 if (rr != NULL)
2508                     rr->sib = qq;
2509                 else
2510                     tt->sib = qq;
2511                 rr = qq;
2512                 }
2513             else
2514                 {
2515                 free (constraintPartition);
2516                 return (ERROR);
2517                 }
2518             qq = qq->sib;
2519             } while (qq != NULL);
2520         pp->left = tt;
2521         rr->sib = ss->sib = NULL;
2522         }
2523
2524     /* relabel interior nodes */
2525     GetPolyDownPass(pt);
2526     for (i=0; i<pt->nIntNodes; i++)
2527         pt->intDownPass[i]->index = i + numLocalTaxa;
2528
2529     /* exit */
2530     free (constraintPartition);
2531     FreePolyTreePartitions(pt);
2532     return (NO_ERROR);
2533 }
2534
2535
2536 /*----------------------------------------------
2537 |
2538 |   BuildRandomRTopology: Builds a random rooted
2539 |      topology. Will set indices in t->nodes
2540 |      such that they are from 0 to n-1 for the n tips
2541 |      and from n to 2n-2 for the n-1 interior
2542 |      nodes. Last is root. Does not touch labels
2543 |      of tips.
2544 |
2545 ----------------------------------------------*/
2546 int BuildRandomRTopology (Tree *t, RandLong *seed)
2547 {
2548     int         i, j, nTips;
2549     TreeNode    *p, *q, *r;
2550
2551     nTips = t->nNodes - t->nIntNodes - 1;
2552
2553     for (i=0; i<t->nNodes; i++)
2554         {
2555         p = &t->nodes[i];
2556         p->index = i;
2557         p->left = p->right = p->anc = NULL;
2558         }
2559
2560     /* connect the first two tip nodes */
2561     q = &t->nodes[0];
2562     r = &t->nodes[1];
2563     p = &t->nodes[nTips];
2564     q->anc = r->anc = p;
2565     p->left = q;
2566     p->right = r;
2567     q = &t->nodes[2*nTips-1];
2568     p->anc = q;
2569     q->left = p;
2570
2571     for (i=2; i<nTips; i++)
2572         {
2573         q = &t->nodes[i];
2574         r = &t->nodes[i-2+nTips+1];
2575         q->anc = r;
2576         r->left = q;
2577         j = (int) (RandomNumber(seed) * (2 * i - 1));
2578         if (j < i)
2579             p = &t->nodes[j];
2580         else
2581             p = &t->nodes[j-i + nTips];
2582         r->right = p;
2583         r->anc = p->anc;
2584         if (p->anc != NULL)
2585             {
2586             if (p->anc->left == p)
2587                 p->anc->left = r;
2588             else
2589                 p->anc->right = r;
2590             }
2591         p->anc = r;
2592         }
2593
2594     /* set root and get downpass */
2595     t->root = &t->nodes[2*nTips-1];
2596     GetDownPass (t);
2597
2598     /* relabel interior nodes */
2599     for (i=0; i<t->nIntNodes; i++)
2600         t->intDownPass[i]->index = i+nTips;
2601
2602     return (NO_ERROR);
2603 }
2604
2605
2606 /*----------------------------------------------
2607 |
2608 |   BuildRandomUTopology: Builds a random unrooted
2609 |      topology. Assumes that indices are set
2610 |      in t->nodes from 0 to n-1 for the n tips
2611 |      and from n to 2n-3 for the n-2 interior
2612 |      nodes. Move the calculation root after
2613 |      this routine to get the right root.
2614 |
2615 ----------------------------------------------*/
2616 int BuildRandomUTopology (Tree *t, RandLong *seed)
2617 {
2618     int         i, j, nTips;
2619     TreeNode    *p, *q, *r;
2620
2621     nTips = t->nNodes - t->nIntNodes;
2622
2623     for (i=0; i<t->nNodes; i++)
2624         {
2625         p = &t->nodes[i];
2626         p->index = i;
2627         p->left = p->right = p->anc = NULL;
2628         }
2629
2630     /* connect the first three nodes, assuming 0 is calc root */
2631     q = &t->nodes[1];
2632     r = &t->nodes[2];
2633     p = &t->nodes[nTips];
2634     q->anc = r->anc = p;
2635     p->left = q;
2636     p->right = r;
2637     q = &t->nodes[0];
2638     p->anc = q;
2639     q->left = p;
2640
2641     for (i=3; i<nTips; i++)
2642         {
2643         q = &t->nodes[i];
2644         r = &t->nodes[i - 3 + nTips + 1];
2645         q->anc = r;
2646         r->left = q;
2647         j = (int) (RandomNumber(seed) * (2 * i - 3));
2648         if (j < i - 1)
2649             p = &t->nodes[j+1];
2650         else
2651             p = &t->nodes[j+1-i + nTips];
2652         r->right = p;
2653         r->anc = p->anc;
2654         if (p->anc->left == p)
2655             p->anc->left = r;
2656         else
2657             p->anc->right = r;
2658         p->anc = r;
2659         }
2660
2661     t->root = &t->nodes[0];
2662
2663     /* get downpass */
2664     GetDownPass (t);
2665
2666     /* relabel interior nodes */
2667     for (i=0; i<t->nIntNodes; i++)
2668         t->intDownPass[i]->index = i+nTips;
2669
2670     return (NO_ERROR);
2671 }
2672
2673
2674 /*----------------------------------------------------------------
2675 |
2676 |   CheckConstraints: Check that tree complies with constraints
2677 |
2678 ----------------------------------------------------------------*/
2679 int CheckConstraints (Tree *t)
2680 {
2681     int             a, i, j, k, nLongsNeeded;
2682     BitsLong        *constraintPartition, *mask;
2683     TreeNode        *p=NULL;
2684
2685     if (t->checkConstraints == NO)
2686         return (NO_ERROR);
2687
2688     /* allocate space */
2689     nLongsNeeded = (numLocalTaxa - 1) / nBitsInALong + 1;
2690     constraintPartition = (BitsLong *) SafeCalloc (2*nLongsNeeded, sizeof(BitsLong));
2691     if (!constraintPartition)
2692         {
2693         MrBayesPrint ("%s   Problems allocating constraintPartition in CheckConstraints", spacer);
2694         return (ERROR);
2695         }
2696     mask = constraintPartition + nLongsNeeded;
2697
2698     /* set mask (needed to reset unused bits when flipping partitions) */
2699     for (i=0; i<numLocalTaxa; i++)
2700       SetBit (i, mask);
2701
2702     if (AllocateTreePartitions(t) == ERROR)
2703         {
2704         MrBayesPrint ("%s   Problems allocating tree partitions in CheckConstraints", spacer);
2705         return (ERROR);
2706         }
2707
2708     for (a=0; a<numDefinedConstraints; a++)
2709         {
2710         if (t->constraints[a] == NO  || definedConstraintsType[a] != HARD)
2711             continue;
2712
2713         /* set bits in partition to check */
2714         ClearBits(constraintPartition, nLongsNeeded);
2715         for (j=k=0; j<numTaxa; j++)
2716             {
2717             if (taxaInfo[j].isDeleted == YES)
2718                 continue;
2719             if (IsBitSet(j, definedConstraint[a]) == YES)
2720                 SetBit(k, constraintPartition);
2721             k++;
2722             }
2723
2724         /* make sure outgroup is outside constrained partition if unrooted tree */
2725         if (t->isRooted == NO && IsBitSet(localOutGroup, constraintPartition))
2726             FlipBits(constraintPartition, nLongsNeeded, mask);
2727
2728         /* find the locked node */
2729         for (i=j=0; i<t->nNodes; i++)
2730             {
2731             if (t->allDownPass[i]->isLocked == YES && t->allDownPass[i]->lockID == a)
2732                 {
2733                 p = t->allDownPass[i];
2734                 j++;
2735                 }
2736             }
2737
2738         if (j != 1)
2739             {
2740             MrBayesPrint ("%s   Tree has %d locks with id %d identifying constraint '%s'\n", spacer, j, a, constraintNames[a]);
2741             free (constraintPartition);
2742             FreeTreePartitions(t);
2743             return (ERROR);
2744             }
2745
2746         /* check that locked node is correct */
2747         for (i=0; i<nLongsNeeded; i++)
2748             {
2749             if (p->partition[i] != constraintPartition[i])
2750                 {
2751                 MrBayesPrint ("%s   Lock %d is set for the wrong node [this is a bug]\n", spacer, a);
2752                 free (constraintPartition);
2753                 FreeTreePartitions(t);
2754                 return (ERROR);
2755                 }
2756             }
2757         }
2758
2759     FreeTreePartitions (t);
2760     free (constraintPartition);
2761     return (NO_ERROR);
2762 }
2763
2764
2765 /*----------------------------------------------------------------
2766 |
2767 |   CheckSetConstraints: Check and set tree constraints
2768 |
2769 ----------------------------------------------------------------*/
2770 int CheckSetConstraints (Tree *t)
2771 {
2772     int             a, i, j, k, nLongsNeeded, foundIt, numLocks;
2773     BitsLong        *constraintPartition, *mask;
2774     TreeNode        *p;
2775
2776     if (t->checkConstraints == NO)
2777         return (NO_ERROR);
2778
2779     /* reset all existing locks, if any */
2780     for (i=0; i<t->nNodes; i++)
2781         {
2782         p = t->allDownPass[i];
2783         p->isLocked = NO;
2784         p->lockID = -1;
2785         if (p->left != NULL)
2786             {
2787             p->calibration = NULL;
2788             p->isDated = NO;
2789             p->age = -1.0;
2790             }
2791         }
2792
2793     /* allocate space */
2794     if (AllocateTreePartitions (t) == ERROR)
2795         {
2796         MrBayesPrint ("%s   Problems allocating tree bitsets", spacer);
2797         return ERROR;
2798         }
2799
2800     nLongsNeeded = ((numLocalTaxa - 1) / nBitsInALong) + 1;
2801     constraintPartition = (BitsLong *) SafeCalloc (2*nLongsNeeded, sizeof(BitsLong));
2802     if (!constraintPartition)
2803         {
2804         MrBayesPrint ("%s   Problems allocating constraintPartition", spacer);
2805         FreeTreePartitions(t);
2806         return ERROR;
2807         }
2808     mask = constraintPartition + nLongsNeeded;
2809
2810     /* set mask (needed to take care of unused bits when flipping partitions) */
2811     for (i=0; i<numLocalTaxa; i++)
2812         SetBit (i, mask);
2813
2814     numLocks = 0;
2815     for (a=0; a<numDefinedConstraints; a++)
2816         {
2817         if (modelParams[t->relParts[0]].activeConstraints[a] == NO || definedConstraintsType[a] != HARD)
2818             continue;
2819
2820         /* set bits in partition to add */
2821         ClearBits(constraintPartition, nLongsNeeded);
2822         for (i=j=0; i<numTaxa; i++)
2823             {
2824             if (taxaInfo[i].isDeleted == YES)
2825                 continue;
2826             if (IsBitSet(i, definedConstraint[a]) == YES)
2827                 SetBit(j, constraintPartition);
2828             j++;
2829             }
2830
2831         /* make sure outgroup is outside constrained partition (marked 0) */
2832         if (t->isRooted == NO && IsBitSet(localOutGroup, constraintPartition) == YES)
2833             FlipBits(constraintPartition, nLongsNeeded, mask);
2834
2835         /* skip partition if uninformative */
2836         k = NumBits(constraintPartition, nLongsNeeded);
2837         if (k == 0 || k == 1)
2838             continue;
2839
2840         /* find the node that should be locked */
2841         foundIt = NO;
2842         for (i=0; i<t->nIntNodes; i++)
2843             {
2844             p = t->intDownPass[i];
2845             for (j=0; j<nLongsNeeded; j++)
2846                 {
2847                 if (p->partition[j] != constraintPartition[j])
2848                     break;
2849                 }
2850
2851             if (j == nLongsNeeded)
2852                 {
2853                 foundIt = YES;
2854                 p->isLocked = YES;
2855                 p->lockID = a;
2856                 if (nodeCalibration[a].prior != unconstrained)
2857                     {
2858                     p->isDated = YES;
2859                     p->calibration = &nodeCalibration[a];
2860                     }
2861                 numLocks++;
2862                 break;
2863                 }
2864             }
2865
2866         if (foundIt == NO)
2867             {
2868             MrBayesPrint ("%s   Tree breaks constraint '%s'\n", spacer, constraintNames[a]);
2869             FreeTreePartitions (t);
2870             free (constraintPartition);
2871             return (ERROR);
2872             }
2873         }
2874
2875     if (numLocks != t->nLocks)
2876         {
2877         MrBayesPrint ("%s   Inconsistent lock settings. This is a bug, please report it.\n", spacer);
2878         FreeTreePartitions (t);
2879         free (constraintPartition);
2880         return (ERROR);
2881         }
2882
2883     /* exit */
2884     FreeTreePartitions(t);
2885     free (constraintPartition);
2886     return (NO_ERROR);
2887 }
2888
2889
2890 /*-----------------------------------------------------------------------
2891 |
2892 |   ColorClusters: Recursive function to color the clusters in a tree by
2893 |      assigning numbers to them in their variable x
2894 |
2895 ------------------------------------------------------------------------*/
2896 void ColorClusters (TreeNode *p, int *index)
2897 {
2898     if (p!=NULL)
2899         {
2900         if (p->isLocked == YES || p->anc == NULL || p->anc->anc == NULL)
2901             p->x = (++(*index));
2902         else
2903             p->x = p->anc->x;
2904         ColorClusters(p->left, index);
2905         ColorClusters(p->right, index);
2906         }
2907 }
2908
2909
2910 /* CopyPolyNodes: Copies everything except pointers and memoryIndex */
2911 void CopyPolyNodes (PolyNode *p, PolyNode *q, int nLongsNeeded)
2912 {
2913     p->index                  = q->index;
2914     p->mark                   = q->mark;
2915     p->length                 = q->length;
2916     p->x                      = q->x;
2917     p->y                      = q->y;
2918     p->isDated                = q->isDated;
2919     p->calibration            = q->calibration;
2920     p->age                    = q->age;
2921     p->isLocked               = q->isLocked;
2922     p->lockID                 = q->lockID;
2923     strcpy (p->label, q->label);
2924     if (nLongsNeeded!=0)
2925         {
2926         assert (p->partition);
2927         assert (q->partition);
2928         memcpy (p->partition,q->partition, nLongsNeeded*sizeof(BitsLong));
2929         }
2930     p->support                = q->support;
2931     p->f                      = q->f;
2932 }
2933
2934
2935 void CopySubtreeToTree (Tree *subtree, Tree *t)
2936 {
2937     int         i, /*j,*/ k;
2938     TreeNode    *p, *q=NULL, *r;
2939
2940     for (i=/*j=*/0; i<subtree->nNodes - 1; i++)
2941         {
2942         p = subtree->allDownPass[i];
2943
2944         for (k=0; k<t->nNodes; k++)
2945             {
2946             q = t->allDownPass[k];
2947             if (q->index == p->index)
2948                 break;
2949             }
2950         q->length = p->length;
2951         q->marked = YES;
2952         if (p->left != NULL && p->right != NULL)
2953             {
2954             for (k=0; k<t->nNodes; k++)
2955                 {
2956                 r = t->allDownPass[k];
2957                 if (r->index == p->left->index)
2958                     {
2959                     q->left = r;
2960                     r->anc = q;
2961                     }
2962                 else if (r->index == p->right->index)
2963                     {
2964                     q->right = r;
2965                     r->anc = q;
2966                     }
2967                 }
2968             }
2969         }
2970
2971     p = subtree->root;
2972
2973     for (k=0; k<t->nNodes; k++)
2974         {
2975         q = t->allDownPass[k];
2976         if (q->index == p->index)
2977             break;
2978         }
2979
2980     if (q->left->marked == YES)
2981         {
2982         for (k=0; k<t->nIntNodes; k++)
2983             {
2984             r = t->intDownPass[k];
2985             if (r->index == p->left->index)
2986                 {
2987                 q->left = r;
2988                 r->anc = q;
2989                 }
2990             }
2991         }
2992     else if (q->right->marked == YES)
2993         {
2994         for (k=0; k<t->nIntNodes; k++)
2995             {
2996             r = t->intDownPass[k];
2997             if (r->index == p->left->index)
2998                 {
2999                 q->right = r;
3000                 r->anc = q;
3001                 }
3002             }
3003         }
3004 }
3005
3006
3007 /*-----------------------------------------------------------------
3008 |
3009 |   CopyToPolyTreeFromPolyTree: copies second tree to first tree
3010 |
3011 -----------------------------------------------------------------*/
3012 int CopyToPolyTreeFromPolyTree (PolyTree *to, PolyTree *from)
3013 {
3014     int         i, j, k, nLongsNeeded;
3015     PolyNode    *p, *q;
3016
3017     /* check we have enough memory */
3018     assert (to->memNodes >= from->nNodes);
3019     if (from->bitsets==NULL || to->bitsets==NULL)
3020         {
3021         nLongsNeeded=0;
3022         }
3023     else
3024         {
3025         assert (to->memNodes >= from->memNodes);/*Otherwise partition length woould not be long enough for nodes in "to" */
3026         nLongsNeeded = (from->memNodes/2 - 1) / nBitsInALong + 1;
3027         }
3028
3029     /* copy nodes */
3030     for (i=0; i<from->nNodes; i++)
3031         {
3032         /* copy pointers */
3033         p  = from->nodes + i;
3034         q  = to->nodes + i;
3035
3036         if (p->anc != NULL)
3037             q->anc = to->nodes + p->anc->memoryIndex;
3038         else
3039             {
3040             q->anc = NULL;
3041             to->root = q;
3042             }
3043
3044         if (p->left != NULL)
3045             q->left = to->nodes + p->left->memoryIndex;
3046         else
3047             q->left = NULL;
3048
3049         if (p->sib != NULL)
3050             q->sib = to->nodes + p->sib->memoryIndex;
3051         else
3052             q->sib = NULL;
3053
3054         /* Copy everything else except memoryIndex */
3055         CopyPolyNodes (q, p, nLongsNeeded);
3056         }
3057
3058     /* fill node arrays */
3059     /* copy tree properties */
3060     to->nNodes = from->nNodes;
3061     to->nIntNodes = from->nIntNodes;
3062     to->isRooted = from->isRooted;
3063     to->isClock = from->isClock;
3064     to->isRelaxed = from->isRelaxed;
3065     to->clockRate = from->clockRate;
3066     strcpy (to->name, from->name);
3067
3068     GetPolyDownPass (to);
3069
3070     /* copy partitions */
3071     if (from->bitsets)
3072         {
3073         if (!to->bitsets)
3074             AllocatePolyTreePartitions(to);
3075         else
3076             ResetPolyTreePartitions(to);
3077         }
3078
3079     /* copy relaxed clock parameters */
3080     FreePolyTreeRelClockParams (to);
3081
3082     if (from->nBSets + from->nESets > 0)
3083         AllocatePolyTreeRelClockParams (to, from->nBSets, from->nESets);
3084
3085     for (i=0; i<to->nBSets; i++)
3086         {
3087         to->bSetName[i] = (char *) SafeCalloc (strlen(from->bSetName[i])+2, sizeof(char));
3088         strcpy (to->bSetName[i], from->bSetName[i]);
3089         for (j=0; j<from->nNodes; j++)
3090             to->effectiveBrLen[i][j] = from->effectiveBrLen[i][j];
3091         }
3092
3093     for (i=0; i<to->nESets; i++)
3094         {
3095         to->eSetName[i] = (char *) SafeCalloc (strlen(from->eSetName[i])+2, sizeof(char));
3096         strcpy (to->eSetName[i], from->eSetName[i]);
3097         for (j=0; j<from->nNodes; j++)
3098             {
3099             to->nEvents[i][j] = from->nEvents[i][j];
3100             if (to->nEvents[i][j] > 0)
3101                 {
3102                 to->position[i][j] = (MrBFlt *) SafeCalloc (to->nEvents[i][j], sizeof (MrBFlt));
3103                 to->rateMult[i][j] = (MrBFlt *) SafeCalloc (to->nEvents[i][j], sizeof (MrBFlt));
3104                 for (k=0; k<to->nEvents[i][j]; k++)
3105                     {
3106                     to->position[i][j][k] = from->position[i][j][k];
3107                     to->rateMult[i][j][k] = from->rateMult[i][j][k];
3108                     }
3109                 }
3110             }
3111         }
3112
3113     /* copy population size parameters */
3114     FreePolyTreePopSizeParams(to);
3115     to->popSizeSet = from->popSizeSet;
3116     if (to->popSizeSet == YES)
3117         {
3118         to->popSize = (MrBFlt *) SafeCalloc (to->nNodes, sizeof(MrBFlt));
3119         for (i=0; i<to->nNodes; i++)
3120             to->popSize[i] = from->popSize[i];
3121         to->popSizeSetName = (char *) SafeCalloc (strlen(from->popSizeSetName) + 1, sizeof(char));
3122         strcpy (to->popSizeSetName, from->popSizeSetName);
3123         }
3124
3125     return (NO_ERROR);
3126 }
3127
3128
3129 /*-----------------------------------------------------------------
3130 |
3131 |   CopyToSpeciesTreeFromPolyTree: copies second tree (polytomous) to
3132 |       first tree, which is a species tree. The species tree needs to
3133 |       be allocated enough space first to hold the resulting tree.
3134 |
3135 -----------------------------------------------------------------*/
3136 int CopyToSpeciesTreeFromPolyTree (Tree *to, PolyTree *from)
3137 {
3138     int         i;
3139     PolyNode    *p;
3140     TreeNode    *q, *q1;
3141 #   if defined (DEBUG_SPECIESTREE)
3142     int         j;
3143 #   endif
3144
3145     /* make sure assumptions are correct */
3146     assert (from->isRooted == YES);
3147     assert (from->isClock == YES);
3148     assert (from->nNodes - from->nIntNodes == numSpecies);
3149     assert (to->memNodes == 2*numSpecies);
3150     assert (to->nIntNodes == from->nIntNodes);
3151     assert (to->nNodes == from->nNodes + 1);
3152
3153     /* make sure indices are set correctly for from nodes */
3154 #   if defined (DEBUG_SPECIESTREE)
3155     for (i=0; i<from->nNodes; i++)
3156         {
3157         for (j=0; j<from->nNodes; j++)
3158             {
3159             p = from->allDownPass[j];
3160             if (p->index == i)
3161                 break;
3162             }
3163         assert (j != from->nNodes);
3164         assert (!(p->left == NULL && p->index >= numSpecies));
3165         }
3166 #   endif
3167
3168     /* copy nodes */
3169     for (i=0; i<from->nNodes; i++)
3170         {
3171         /* copy pointers */
3172         p  = from->allDownPass[i];
3173         q  = to->nodes + p->index;
3174
3175         if (p->anc != NULL)
3176             q->anc = to->nodes + p->anc->index;
3177         else
3178             q->anc = NULL;
3179
3180         if (p->left != NULL)
3181             q->left = to->nodes + p->left->index;
3182         else
3183             q->left = NULL;
3184
3185         if (p->left != NULL)
3186             q->right = to->nodes + p->left->sib->index;
3187         else
3188             q->right = NULL;
3189
3190         q->nodeDepth              = p->depth;
3191         q->age                    = p->age;
3192         q->length                 = p->length;
3193         q->index                  = p->index;
3194         if (q->index < numSpecies)
3195             q->label = speciesNameSets[speciespartitionNum].names[q->index];
3196         else
3197             q->label = noLabel;
3198         }
3199
3200     /* fix root */
3201     p = from->root;
3202     q = to->nodes + p->index;
3203     q1 = to->nodes + from->nNodes;      /* get the 'extra' root node that polytomous trees do not use */
3204     q->anc = q1;
3205     q1->index = from->nNodes;
3206     q1->left = q;
3207     q1->right = q1->anc = NULL;
3208     q1->isLocked = NO;
3209     q1->lockID = -1;
3210     q1->isDated = NO;
3211     q1->calibration = NULL;
3212     q1->age = -1.0;
3213     to->root = q1;
3214
3215     /* get downpass */
3216     GetDownPass (to);
3217
3218     /* a user tree might not come with node depths set */
3219     if (to->root->left->nodeDepth == 0.0)
3220         SetNodeDepths(to);
3221
3222     /* set partitions */
3223     if (to->bitsets)
3224         ResetTreePartitions(to);
3225
3226     return (NO_ERROR);
3227 }
3228
3229
3230 /*-----------------------------------------------------------------
3231 |
3232 |   CopyToTreeFromPolyTree: copies second tree (polytomous) to first
3233 |       tree (used to initialize constrained starting trees, e.g.).
3234 |       An unrooted source tree will be rooted on outgroup
3235 |       An unrooted source tree that needs to be copied to
3236 |       a rooted target tree will be randomly rooted on a node below
3237 |       all defined constraints. The to tree needs to be allocated
3238 |       enough space first to hold the resulting tree.
3239 |
3240 -----------------------------------------------------------------*/
3241 int CopyToTreeFromPolyTree (Tree *to, PolyTree *from)
3242 {
3243     int         i, j;
3244     PolyNode    *p=NULL;
3245     TreeNode    *q, *q1;
3246
3247     /* refuse to arbitrarily root an input tree */
3248     assert (!(from->isRooted == NO && to->isRooted == YES));
3249     if ((from->isRooted == NO) && (to->isRooted == YES))
3250         {
3251         MrBayesPrint ("%s   Failed to copy trees due to difference in rootedness of source and destination. \n", spacer);
3252         return (ERROR);
3253         }
3254
3255     /* make sure assumptions are in order */
3256     assert (to->memNodes >= from->nNodes + (to->isRooted == NO ? 0 : 1));
3257     assert (localOutGroup >= 0 && localOutGroup < numLocalTaxa);
3258     assert (numLocalTaxa == from->nNodes - from->nIntNodes);
3259     assert (!(from->isRooted == YES && from->nNodes != 2*from->nIntNodes + 1));
3260     assert (!(from->isRooted == NO  && from->nNodes != 2*from->nIntNodes + 2));
3261
3262     /* make sure indices are set correctly for from nodes */
3263     for (i=0; i<from->nNodes; i++)
3264         {
3265         for (j=0; j<from->nNodes; j++)
3266             {
3267             p = from->allDownPass[j];
3268             if (p->index == i)
3269                 break;
3270             }
3271         assert (j != from->nNodes);
3272         assert (!(p->left == NULL && p->index >= numLocalTaxa));
3273         }
3274
3275     /* deal with root */
3276     if (to->isRooted == NO && from->isRooted == YES)
3277         Deroot(from);
3278
3279     /* make sure calculation root is set correctly */
3280     if (to->isRooted == NO && MovePolyCalculationRoot (from, localOutGroup) == ERROR)
3281         return ERROR;
3282
3283     /* copy nodes */
3284     for (i=0; i<from->nNodes; i++)
3285         {
3286         /* copy pointers */
3287         p  = from->allDownPass[i];
3288         q  = to->nodes + p->index;
3289
3290         if (p->anc != NULL)
3291             q->anc = to->nodes + p->anc->index;
3292         else
3293             q->anc = NULL;
3294
3295         if (p->left != NULL)
3296             q->left = to->nodes + p->left->index;
3297         else
3298             q->left = NULL;
3299
3300         if (p->left != NULL)
3301             q->right = to->nodes + p->left->sib->index;
3302         else
3303             q->right = NULL;
3304
3305         q->isLocked               = p->isLocked;
3306         q->lockID                 = p->lockID;
3307         q->isDated                = p->isDated;
3308         q->calibration            = p->calibration;
3309         q->age                    = p->age;
3310         q->nodeDepth              = p->depth;
3311         q->length                 = p->length;
3312         q->index                  = p->index;
3313         if (q->index < numLocalTaxa)
3314             q->label = localTaxonNames[q->index];
3315         else
3316             q->label = noLabel;
3317         }
3318
3319     /* fix root */
3320     if (to->isRooted == NO)
3321         {
3322         p = from->root;
3323         q = to->nodes + p->index;
3324         q->anc = to->root = to->nodes + p->left->sib->sib->index;
3325         q->length = to->root->length;
3326         to->root->length = 0.0;
3327         to->root->left = q;
3328         to->root->right = to->root->anc = NULL;
3329         }
3330     else
3331         {
3332         p = from->root;
3333         q = to->nodes + p->index;
3334         q1 = to->nodes + from->nNodes;      /* get the 'extra' root node that polytomous trees do not use */
3335         q->anc = q1;
3336         q1->index = from->nNodes;
3337         q1->left = q;
3338         q1->right = q1->anc = NULL;
3339         q1->isLocked = NO;
3340         q1->lockID = -1;
3341         q1->isDated = NO;
3342         q1->calibration = NULL;
3343         q1->age = -1.0;
3344         to->root = q1;
3345         }
3346
3347     /* get downpass */
3348     GetDownPass (to);
3349
3350     /* set node depths */
3351     if (to->isRooted == YES && to->root->left->nodeDepth == 0.0)
3352         SetNodeDepths(to);
3353
3354     /* set partitions */
3355     if (to->bitsets)
3356         ResetTreePartitions(to);
3357
3358     /* relaxed clock parameters are not stored in binary trees but in separate parameters */
3359
3360     return (NO_ERROR);
3361 }
3362
3363
3364 /*-----------------------------------------------------------------
3365 |
3366 |   CopyToTreeFromTree: copies second tree to first tree
3367 |       (used to initialize brlen sets for same topology)
3368 |       Note: partition information of nodes are not copied if
3369 |       either "from" or "to" tree does not have bitsets allocated
3370 |
3371 -----------------------------------------------------------------*/
3372 int CopyToTreeFromTree (Tree *to, Tree *from)
3373 {
3374     int         i, numTaxa, nLongsNeeded;
3375     TreeNode    *p, *q;
3376
3377     numTaxa = from->nNodes - from->nIntNodes - (from->isRooted == YES ? 1 : 0);
3378     nLongsNeeded = (numTaxa - 1) / nBitsInALong + 1;
3379     if (from->bitsets==NULL || to->bitsets==NULL)
3380         nLongsNeeded=0;
3381
3382     /* check that there is enough memory */
3383     assert (to->memNodes >= from->nNodes);
3384
3385     /* copy nodes (use index of p as memoryIndex for q) */
3386     for (i=0; i<from->nNodes; i++)
3387         {
3388         /* copy pointers */
3389         p  = from->nodes + i;
3390         q  = to->nodes + p->index;
3391
3392         if (p->anc != NULL)
3393             q->anc = to->nodes + p->anc->index;
3394         else
3395             {
3396             q->anc = NULL;
3397             to->root = q;
3398             }
3399
3400         if (p->left != NULL)
3401             q->left = to->nodes + p->left->index;
3402         else
3403             q->left = NULL;
3404
3405         if (p->right != NULL)
3406             q->right = to->nodes + p->right->index;
3407         else
3408             q->right = NULL;
3409
3410         CopyTreeNodes (q, p, nLongsNeeded);
3411         }
3412
3413     /* create new node arrays */
3414     to->nNodes = from->nNodes;
3415     to->nIntNodes = from->nIntNodes;
3416     GetDownPass (to);
3417
3418     /* copy tree properties (these should be constant most of them) */
3419     strcpy (to->name, from->name);
3420     to->isRooted = from->isRooted;
3421     to->isClock = from->isClock;
3422     to->isCalibrated = from->isCalibrated;
3423     to->checkConstraints = from->checkConstraints;
3424     to->nConstraints = from->nConstraints;
3425     to->constraints = from->constraints;
3426     to->nLocks = from->nLocks;
3427     to->nRelParts = from->nRelParts;
3428     to->relParts = from->relParts;
3429
3430     /* copy partitions */
3431     if (from->bitsets)
3432         {
3433         if (!to->bitsets)
3434             AllocateTreePartitions(to);
3435         else
3436             ResetTreePartitions(to);
3437         }
3438
3439     return (NO_ERROR);
3440 }
3441
3442
3443 /* Copy node q to node p */
3444 void CopyTreeNodes (TreeNode *p, TreeNode *q, int nLongsNeeded)
3445 {
3446     /* copies everything except pointers and memoryIndex */
3447     p->label                  = q->label;
3448     p->index                  = q->index;
3449     p->upDateCl               = q->upDateCl;
3450     p->upDateTi               = q->upDateTi;
3451     p->scalerNode             = q->scalerNode;
3452     p->isLocked               = q->isLocked;
3453     p->lockID                 = q->lockID;
3454     p->isDated                = q->isDated;
3455     p->marked                 = q->marked;
3456     p->x                      = q->x;
3457     p->y                      = q->y;
3458     p->d                      = q->d;
3459     p->length                 = q->length;
3460     p->nodeDepth              = q->nodeDepth;
3461     p->calibration            = q->calibration;
3462     p->age                    = q->age;
3463     if (nLongsNeeded != 0)
3464         {
3465         assert (p->partition);
3466         assert (q->partition);
3467         memcpy (p->partition, q->partition, nLongsNeeded*sizeof(BitsLong));
3468         }
3469 }
3470
3471
3472 void CopyTreeToSubtree (Tree *t, Tree *subtree)
3473 {
3474     int         i, j, k;
3475     TreeNode    *p, *q, *r;
3476
3477     for (i=j=0; i<t->nNodes; i++)
3478         {
3479         p = t->allDownPass[i];
3480         if (p->marked == NO)
3481             continue;
3482
3483         q = &subtree->nodes[j++];
3484         q->index = p->index;
3485         q->length = p->length;
3486         if (p->left == NULL || p->left->marked == NO)
3487             q->left = q->right = NULL;
3488         else
3489             {
3490             for (k=0; k<j-1; k++)
3491                 {
3492                 r = &subtree->nodes[k];
3493                 if (r->index == p->left->index)
3494                     {
3495                     q->left = r;
3496                     r->anc = q;
3497                     }
3498                 else if (r->index == p->right->index)
3499                     {
3500                     q->right = r;
3501                     r->anc = q;
3502                     }
3503                 }
3504             }
3505
3506         if (p->anc->marked == NO)
3507             {
3508             r = &subtree->nodes[j++];
3509             subtree->root = r;
3510             r->anc = r->right = NULL;
3511             r->left = q;
3512             q->anc = r;
3513             r->length = 0.0;
3514             r->index = p->anc->index;
3515             }
3516
3517         }
3518
3519     GetDownPass (subtree);
3520
3521     subtree->isRooted = t->isRooted;
3522     subtree->nRelParts = t->nRelParts;
3523     subtree->relParts = t->relParts;
3524 }
3525
3526
3527 /* DatedNodeDepths: Recursive function to get node depths */
3528 void DatedNodeDepths (TreeNode *p, MrBFlt *nodeDepths, int *index)
3529 {
3530     if (p != NULL)
3531         {
3532         if (p->left == NULL || p->isDated == YES)
3533             nodeDepths[(*index)++] = p->nodeDepth;
3534         else
3535             {
3536             DatedNodeDepths (p->left,  nodeDepths, index);
3537             DatedNodeDepths (p->right, nodeDepths, index);
3538             }
3539         }
3540 }
3541
3542
3543 /* DatedNodes: Recursive function to get dated tips or interior nodes */
3544 void DatedNodes (TreeNode *p, TreeNode **datedNodes, int *index)
3545 {
3546     if (p != NULL)
3547         {
3548         if (p->left != NULL && p->isDated == NO)
3549             {
3550             DatedNodes (p->left,  datedNodes, index);
3551             DatedNodes (p->right, datedNodes, index);
3552             }
3553         datedNodes[(*index)++] = p;
3554         }
3555 }
3556
3557
3558 /* Deroot: Deroot a rooted polytomous tree with branch lengths */
3559 int Deroot (PolyTree *pt)
3560 {
3561     PolyNode    *p, *q, *r, tempNode;
3562     int         i;
3563
3564     p = pt->root;
3565
3566     if (p->left->sib->sib != NULL)
3567         return (ERROR);      /* tree is not rooted or it is polytomous */
3568
3569     if (p != &pt->nodes[pt->nNodes-1])
3570         {
3571         q = &pt->nodes[pt->nNodes-1];
3572         /* now swap content of p and q including pointers */
3573         tempNode = *q;
3574         *q = *p;
3575         *p = tempNode;
3576         /* swap back memoryindex */
3577         p->memoryIndex = q->memoryIndex;
3578         q->memoryIndex = tempNode.memoryIndex;
3579         /* all pointers to q should be pointers to p */
3580         for (i=0; i<pt->nNodes; i++)
3581             {
3582             r = &pt->nodes[i];
3583             if (r->left == q)
3584                 r->left = p;
3585             if (r->anc == q)
3586                 r->anc = p;
3587             if (r->sib == q)
3588                 r->sib = p;
3589             }
3590         /* all pointers to p should be pointers to q; all these are anc pointers from the descendants of the root */
3591         pt->root = q;
3592         for (r=q->left; r!=NULL; r=r->sib)
3593             r->anc = q;
3594         /* finally set p to the new root */
3595         p = pt->root;
3596         }
3597
3598     /* make sure the left of the old root is interior and can be used as new root */
3599     if (p->left->left == NULL)
3600         {
3601         q = p->left;
3602         r = q->sib;
3603         p->left = r;
3604         r->sib = q;
3605         q->sib = NULL;
3606         }
3607
3608     pt->root = p->left;
3609     pt->root->left->sib->sib = p->left->sib;
3610     p->left->sib->length += pt->root->length;
3611     pt->root->length = 0.0;
3612     pt->root->sib = NULL;
3613     pt->root->anc = NULL;
3614
3615     pt->nNodes--;
3616     pt->nIntNodes--;
3617
3618     GetPolyDownPass(pt);
3619
3620     return (NO_ERROR);
3621 }
3622
3623
3624 /* EraseTreeList: Erase all trees in treeList */
3625 void EraseTreeList (TreeList *treeList)
3626 {
3627     TreeListElement *listElement;
3628     TreeListElement *previous;
3629
3630     listElement = treeList->first;
3631     if (listElement != NULL)
3632         do
3633             {
3634             free (listElement->order);
3635             previous = listElement;
3636             listElement = listElement->next;
3637             free (previous);
3638             }
3639         while (listElement != NULL);
3640
3641     treeList->first = treeList->last = NULL;
3642 }
3643
3644
3645 void UpdateTreeWithClockrate (Tree *t, MrBFlt clockRate)
3646 {
3647     int i;
3648     TreeNode *p;
3649
3650     if (t->fromUserTree == NO)
3651         {
3652         /*Set nodeDepth*/
3653         for (i=0; i<t->nNodes; i++)
3654             {
3655             p = t->allDownPass[i];
3656             p->nodeDepth = p->age * clockRate;
3657             }
3658
3659         /* calculate branch lengths */
3660         for (i=0; i<t->nNodes; i++)
3661             {
3662             p = t->allDownPass[i];
3663             if (p->anc != NULL)
3664                 {
3665                 if (p->anc->anc != NULL)
3666                     {
3667                     p->length = p->anc->nodeDepth - p->nodeDepth;
3668                     }
3669                 else
3670                     p->length = 0.0; //not a problem for root node.
3671                 }
3672             }
3673         }
3674     else
3675         {
3676         for (i=0; i<t->nNodes-1; i++)
3677             {
3678             p = t->allDownPass[i];
3679             p->age = p->nodeDepth / clockRate;
3680             }
3681         }
3682 }
3683
3684
3685 /*----------------------------------------------------------------
3686 |
3687 |   findAllowedClockrate: Finds the range of clock rates allowed for the tree.
3688 |
3689 |   @param t        - tree to check (IN)
3690 |   @minClockRate   - adress where minimum allowed clock rate is stored (OUT)
3691 |   @maxClockRate   - adress where maximum allowed clock rate is stored (OUT)
3692 |
3693 ----------------------------------------------------------------*/
3694 void findAllowedClockrate (Tree *t, MrBFlt *minClockRate, MrBFlt *maxClockRate)
3695 {
3696     int i;
3697     TreeNode *p;
3698     MrBFlt min, max, tmp;
3699
3700     min=0.0;
3701     max=MRBFLT_MAX;
3702
3703     *minClockRate = 2.0;
3704     *maxClockRate = 1.0;
3705
3706     if (t->fromUserTree == NO)
3707         {
3708         for (i=0; i<t->nNodes-1; i++)
3709             {
3710             p = t->allDownPass[i];
3711             if (p->anc->anc != NULL)
3712                 {
3713                 tmp = BRLENS_MIN/(p->anc->age - p->age);
3714                 assert (tmp > 0);
3715                 if (tmp > min)
3716                     min = tmp;
3717
3718                 tmp = BRLENS_MAX/(p->anc->age - p->age);
3719                 assert (tmp > 0);
3720                 if (tmp > max)
3721                     max = tmp;
3722                 }
3723             }
3724         *minClockRate= min;
3725         *maxClockRate= max;
3726         }
3727     else
3728         {
3729         IsCalibratedClockSatisfied (t,minClockRate,maxClockRate, 0.001);
3730         }
3731 }
3732
3733
3734 /* FreePolyTree: Free memory space for a polytomous tree (unrooted or rooted) */
3735 void FreePolyTree (PolyTree *pt)
3736 {
3737     if (pt != NULL)
3738         {
3739         FreePolyTreePartitions(pt);
3740         FreePolyTreeRelClockParams(pt);
3741         FreePolyTreePopSizeParams(pt);
3742         free (pt->allDownPass);
3743         free (pt->nodes);
3744         free (pt);
3745         }
3746 }
3747
3748
3749 /* FreePolyTreePartitions: Free memory space for polytomous tree partitions */
3750 void FreePolyTreePartitions (PolyTree *pt)
3751 {
3752     int i;
3753     if (pt != NULL && pt->bitsets != NULL)
3754         {
3755         for (i=0; i<pt->memNodes; i++)
3756             pt->nodes[i].partition = NULL;
3757         free (pt->bitsets);
3758         pt->bitsets = NULL;
3759         }
3760 }
3761
3762
3763 /* FreePolyTreePopSizeParams: Free population size set parameters of polytree */
3764 void FreePolyTreePopSizeParams (PolyTree *pt)
3765 {
3766     if (pt->popSizeSet == YES)
3767         {
3768         free (pt->popSize);
3769         free (pt->popSizeSetName);
3770         }
3771     pt->popSizeSet = NO;
3772     pt->popSize = NULL;
3773     pt->popSizeSetName = NULL;
3774 }
3775
3776
3777 /* FreePolyTreeRelClockParams: Free relaxed clock parameters of polytree */
3778 void FreePolyTreeRelClockParams (PolyTree *pt)
3779 {
3780     int i, j;
3781
3782     /* free breakpoint clock parameters */
3783     for (i=0; i<pt->nESets; i++)
3784         {
3785         for (j=0; j<pt->memNodes; j++)
3786             {
3787             if (pt->nEvents[i][j] > 0)
3788                 {
3789                 free (pt->position[i][j]);
3790                 free (pt->rateMult[i][j]);
3791                 }
3792             }
3793         free (pt->eSetName[i]);
3794         free (pt->nEvents[i]);
3795         free (pt->position[i]);
3796         free (pt->rateMult[i]);
3797         }
3798     free (pt->nEvents);
3799     free (pt->position);
3800     free (pt->rateMult);
3801     free (pt->eSetName);
3802     pt->nESets = 0;
3803     pt->nEvents = NULL;
3804     pt->position = NULL;
3805     pt->rateMult = NULL;
3806     pt->eSetName = NULL;
3807
3808     /* free branch clock parameters */
3809     for (i=0; i<pt->nBSets; i++)
3810         {
3811         free (pt->bSetName[i]);
3812         free (pt->effectiveBrLen[i]);
3813         }
3814     free (pt->effectiveBrLen);
3815     free (pt->bSetName);
3816     pt->nBSets = 0;
3817     pt->effectiveBrLen = NULL;
3818     pt->bSetName = NULL;
3819 }
3820
3821
3822 /* FreeTree: Free memory space for a tree (unrooted or rooted) */
3823 void FreeTree (Tree *t)
3824 {
3825     if (t != NULL)
3826         {
3827         free (t->bitsets);
3828         free (t->flags);
3829         free (t->allDownPass);
3830         free (t->nodes);
3831         free (t);
3832         }
3833 }
3834
3835
3836 /* FreeTreePartitions: Free memory space for tree partitions */
3837 void FreeTreePartitions (Tree *t)
3838 {
3839     int     i;
3840
3841     if (t != NULL && t->bitsets != NULL)
3842         {
3843         free (t->bitsets);
3844         t->bitsets = NULL;
3845         for (i=0; i<t->memNodes; i++)
3846             t->nodes[i].partition = NULL;
3847         }
3848 }
3849
3850
3851 /*-------------------------------------------------------------------------------------------
3852 |
3853 |   GetDatedNodeDepths: Get an array containing the node depths of the dated tips,
3854 |       internal or external, plus dated root
3855 |
3856 ---------------------------------------------------------------------------------------------*/
3857 void GetDatedNodeDepths (TreeNode *p, MrBFlt *nodeDepths)
3858 {
3859     int index = 0;
3860
3861     assert (p != NULL);
3862
3863     nodeDepths[index++] = p->nodeDepth;     /* include root node depth */
3864     if (p->left != NULL)
3865         {
3866         DatedNodeDepths (p->left, nodeDepths, &index);
3867         DatedNodeDepths (p->right, nodeDepths, &index);
3868         }
3869 }
3870
3871
3872 /*-------------------------------------------------------------------------------------------
3873 |
3874 |   GetDatedNodes: Get an array containing the dated tips,
3875 |       internal or external, and all interior nodes in the same subtree
3876 |
3877 ---------------------------------------------------------------------------------------------*/
3878 void GetDatedNodes (TreeNode *p, TreeNode **datedNodes)
3879 {
3880     int     index = 0;
3881
3882     assert (p != NULL);
3883
3884     if (p->left!= NULL)
3885         {
3886         DatedNodes (p->left,  datedNodes, &index);
3887         DatedNodes (p->right, datedNodes, &index);
3888         }
3889 }
3890
3891
3892 /* get down pass for tree t (wrapper function) */
3893 void GetDownPass (Tree *t)
3894 {
3895     int i, j;
3896
3897     i = j = 0;
3898     GetNodeDownPass (t, t->root, &i, &j);
3899 }
3900
3901
3902 /* get the actual down pass sequences */
3903 void GetNodeDownPass (Tree *t, TreeNode *p, int *i, int *j)
3904 {
3905     if (p != NULL)
3906         {
3907         GetNodeDownPass (t, p->left,  i, j);
3908         GetNodeDownPass (t, p->right, i, j);
3909         if (p->left != NULL && p->right != NULL && p->anc != NULL)
3910             {
3911             t->intDownPass[(*i)++] = p;
3912             t->allDownPass[(*j)++] = p;
3913             }
3914         else if (p->left == NULL && p->right == NULL && p->anc != NULL)
3915             {
3916             t->allDownPass[(*j)++] = p;
3917             }
3918         else if (p->left != NULL && p->right == NULL && p->anc == NULL)
3919             {
3920             t->allDownPass[(*j)++] = p;
3921             }
3922         }
3923 }
3924
3925
3926 /* GetPolyAges: Get PolyTree node ages */
3927 void GetPolyAges (PolyTree *t)
3928 {
3929     int         i;
3930     PolyNode    *p;
3931
3932     GetPolyDepths (t); /* just to make sure... */
3933
3934     for (i=0; i<t->nNodes; i++)
3935         {
3936         p = t->allDownPass[i];
3937         p->age = p->depth / t->clockRate;
3938         }
3939 }
3940
3941
3942 /* GetPolyDepths: Get PolyTree node depths */
3943 void GetPolyDepths (PolyTree *t)
3944 {
3945     int         i;
3946     MrBFlt      maxDepth;
3947     PolyNode    *p;
3948
3949     maxDepth = t->root->depth = 0.0;
3950
3951     for (i=t->nNodes-2; i>=0; i--)
3952         {
3953         p = t->allDownPass[i];
3954         p->depth = p->anc->depth + p->length;
3955         if (p->depth > maxDepth)
3956             maxDepth = p->depth;
3957         }
3958
3959     for (i=0; i<t->nNodes; i++)
3960         {
3961         p = t->allDownPass[i];
3962         p->depth = maxDepth - p->depth;
3963         }
3964 }
3965
3966
3967 /* get down pass for polytomous tree t (wrapper function) */
3968 void GetPolyDownPass (PolyTree *t)
3969 {
3970     int i, j;
3971
3972     i = j = 0;
3973     GetPolyNodeDownPass (t, t->root, &i, &j);
3974     assert (t->nIntNodes==j);
3975 }
3976
3977
3978 /* get the actual down pass sequences for a polytomous tree */
3979 void GetPolyNodeDownPass (PolyTree *t, PolyNode *p, int *i, int *j)
3980 {
3981     PolyNode    *q;
3982
3983     if (p->left != NULL)
3984         {
3985         for (q=p->left; q!=NULL; q=q->sib)
3986             GetPolyNodeDownPass(t, q, i, j);
3987         }
3988
3989     t->allDownPass[(*i)++] = p;
3990     if (p->left != NULL)
3991         t->intDownPass[(*j)++] = p;
3992 }
3993
3994
3995 /* GetFromTreeList: Get first tree from a tree list and remove it from the list*/
3996 int GetFromTreeList (TreeList *treeList, Tree *tree)
3997 {
3998     TreeListElement *listElement;
3999
4000     if (treeList->first == NULL)
4001         {
4002         MrBayesPrint ("%s   Tree list empty\n", spacer);
4003         return (ERROR);
4004         }
4005     if (tree->isRooted == YES)
4006         RetrieveRTopology (tree, treeList->first->order);
4007     else
4008         {
4009         RetrieveUTopology (tree, treeList->first->order);
4010         if (localOutGroup != 0)
4011             MoveCalculationRoot (tree, localOutGroup);
4012         }
4013
4014     listElement = treeList->first;
4015     treeList->first = listElement->next;
4016
4017     free (listElement->order);
4018     free (listElement);
4019
4020     return (NO_ERROR);
4021 }
4022
4023
4024 /*------------------------------------------------------------------
4025 |
4026 |   InitBrlens: This routine will set all branch lengths of a
4027 |      nonclock tree to the value given by 'v'.
4028 |
4029 ------------------------------------------------------------------*/
4030 int InitBrlens (Tree *t, MrBFlt v)
4031 {
4032     int         i;
4033     TreeNode    *p;
4034
4035     for (i=0; i<t->nNodes; i++)
4036         {
4037         p = t->allDownPass[i];
4038         if (p->anc != NULL && !(t->isRooted == YES && p->anc->anc == NULL))
4039             p->length = v;
4040         else
4041             p->length = 0.0;
4042         }
4043
4044     return (NO_ERROR);
4045 }
4046
4047
4048 /*
4049 @param levUp        is the number of edges between the "node" and the most resent calibrated predecessor +1,
4050                     for the calibrated nodes it should be 1
4051 @param calibrUp     is the age of the most resent calibrated predecessor
4052 @return             age of the node
4053 */
4054 MrBFlt SetNodeCalibratedAge(TreeNode *node, unsigned levUp, MrBFlt calibrUp)
4055 {
4056     MrBFlt r,l;
4057
4058     if (node->age != -1.0)
4059         {
4060         if (node->right != NULL)
4061             SetNodeCalibratedAge (node->right, 2, node->age);
4062         if (node->left != NULL)
4063             SetNodeCalibratedAge (node->left,  2, node->age);
4064         return node->age;
4065         }
4066
4067     r = SetNodeCalibratedAge (node->right, levUp+1, calibrUp);
4068     l = SetNodeCalibratedAge (node->left,  levUp+1, calibrUp);
4069
4070     if (r > l)
4071         {
4072         assert (calibrUp - r > 0.0);
4073         return node->age = r + (calibrUp - r)/levUp;
4074         }
4075     else
4076         {
4077         assert (calibrUp - l > 0.0);
4078         return node->age = l + (calibrUp - l)/levUp;
4079         }
4080 }
4081
4082
4083 /*-------------------------------------------------------------------
4084 |
4085 |   InitCalibratedBrlens: This routine will build a clock tree
4086 |       consistent with calibration constraints on terminal
4087 |       taxa and/or constrained interior nodes. At least one
4088 |       node should be calibrated.
4089 |       If not possible to build such a tree, ERROR
4090 |       is returned.
4091 |
4092 --------------------------------------------------------------------*/
4093 int InitCalibratedBrlens (Tree *t, MrBFlt clockRate, RandLong *seed)
4094 {
4095     int             i;
4096     TreeNode        *p;
4097     Model           *mp;
4098     MrBFlt          treeAgeMin, treeAgeMax;
4099     Calibration     *calibrationPtr;
4100
4101 #   ifdef DEBUG_CALIBRATION
4102     printf ("Before initializing calibrated brlens\n");
4103     ShowNodes(t->root, 0, YES);
4104 #   endif
4105
4106     if (t->isRooted == NO)
4107         {
4108         MrBayesPrint ("%s   Tree is unrooted\n", spacer);
4109         return (ERROR);
4110         }
4111
4112     /* Check whether root has age constraints */
4113     mp = &modelParams[t->relParts[0]];
4114     treeAgeMin = 0.0;
4115     treeAgeMax = POS_INFINITY;
4116     if (t->root->left->isDated == YES)
4117         {
4118         treeAgeMin = t->root->left->calibration->min;
4119         treeAgeMax = t->root->left->calibration->max;
4120         }
4121     else if (!strcmp(mp->clockPr, "Uniform") || !strcmp(mp->clockPr, "Fossilization"))
4122         {
4123         if (mp->treeAgePr.min > treeAgeMin)
4124             treeAgeMin = mp->treeAgePr.min;
4125         if (mp->treeAgePr.max < treeAgeMax)
4126             treeAgeMax = mp->treeAgePr.max;
4127         }
4128
4129     /* date all nodes from top to bottom with min. age as nodeDepth*/
4130     for (i=0; i<t->nNodes; i++)
4131         {
4132         p = t->allDownPass[i];
4133         if (p->anc != NULL)
4134             {
4135             if (p->left == NULL && p->right == NULL)
4136                 {
4137                 if (p->isDated == NO)
4138                     {
4139                     p->nodeDepth = 0.0;
4140                     p->age = 0.0;
4141                     }
4142                 else
4143                     {
4144                     if (p->calibration->prior == fixed)
4145                         p->nodeDepth = p->age = p->calibration->priorParams[0];
4146                     else
4147                         p->nodeDepth = p->age = p->calibration->min;
4148                     }
4149                 }
4150             else
4151                 {
4152                 if (p->left->nodeDepth > p->right->nodeDepth)
4153                     p->nodeDepth = p->left->nodeDepth;
4154                 else
4155                     p->nodeDepth = p->right->nodeDepth;
4156                 if (p->isDated == YES || (p->anc->anc == NULL && (!strcmp(mp->clockPr,"Uniform") || !strcmp(mp->clockPr,"Fossilization"))))
4157                     {
4158                     if (p->isDated == NO)
4159                         calibrationPtr = &mp->treeAgePr;
4160                     else
4161                         calibrationPtr = p->calibration;
4162
4163                     if (calibrationPtr->max <= p->nodeDepth)
4164                         {
4165                         if (p->isDated == NO)
4166                             MrBayesPrint ("%s   Calibration inconsistency for root node\n", spacer);
4167                         else
4168                             MrBayesPrint ("%s   Calibration inconsistency for node '%s'\n", spacer, constraintNames[p->lockID]);
4169                         MrBayesPrint ("%s   Cannot make a tree where the node is %s\n", spacer, calibrationPtr->name);
4170                         return (ERROR);
4171                         }
4172                     else
4173                         {
4174                         if (calibrationPtr->min < p->nodeDepth)
4175                             p->age = p->nodeDepth;
4176                         else
4177                             p->age = p->nodeDepth = calibrationPtr->min;
4178                         }
4179                     }
4180                 else
4181                     p->age = -1.0;
4182                 }
4183             }
4184         }
4185
4186     /* try to make root node deeper than minimum age */
4187     p = t->root->left;
4188     if (p->nodeDepth==0.0)  p->nodeDepth = 1.0;
4189     if (p->nodeDepth * 1.5 < treeAgeMax)
4190         p->nodeDepth = p->age = 1.5 * p->nodeDepth;
4191     else
4192         p->nodeDepth = p->age = treeAgeMax;
4193
4194     SetNodeCalibratedAge (p, 1, p->age);
4195
4196     /* Setup node depths */
4197     for (i=0; i<t->nNodes; i++)
4198         {
4199         p = t->allDownPass[i];
4200         p->nodeDepth = p->age * clockRate;
4201         assert (!(p->left == NULL && p->calibration == NULL && p->nodeDepth != 0.0));
4202         }
4203
4204     /* calculate branch lengths */
4205     for (i=0; i<t->nNodes; i++)
4206         {
4207         p = t->allDownPass[i];
4208         if (p->anc != NULL)
4209             {
4210             if (p->anc->anc != NULL)
4211                 {
4212                 p->length = p->anc->nodeDepth - p->nodeDepth;
4213                 if (p->length < BRLENS_MIN)
4214                     {
4215                     //MrBayesPrint ("%s   Restrictions of node calibration and clockrate makes some branch lenghts too small.\n", spacer);
4216                     //return (ERROR);
4217                     }
4218                 if (p->length > BRLENS_MAX)
4219                     {
4220                     //MrBayesPrint ("%s   Restrictions of node calibration and clockrate makes some branch lenghts too long.\n", spacer);
4221                     //return (ERROR);
4222                     }
4223                 }
4224             else
4225                 p->length = 0.0; //not a problem for root node.
4226             }
4227         }
4228
4229 #   ifdef DEBUG_CALIBRATION
4230     printf ("after\n");
4231     ShowNodes (t->root, 0, YES);
4232     getchar();
4233 #   endif
4234
4235     return (NO_ERROR);
4236     MrBayesPrint ("%lf", *seed); /* just because I am tired of seeing the unused parameter error msg */
4237 }
4238
4239
4240 /*-------------------------------------------------------
4241 |
4242 |   InitClockBrlens: This routine will initialize
4243 |      a clock tree by setting the root to depth 1.0
4244 |      and then assigning node depths according to
4245 |      the relative node depth measured in terms of the
4246 |      maximum number of branches to the tip from each
4247 |      node.
4248 |
4249 --------------------------------------------------------*/
4250 int InitClockBrlens (Tree *t)
4251 {
4252     int             i, maxBrSegments=0;
4253     TreeNode        *p;
4254
4255     if (t->isRooted == NO)
4256         {
4257         MrBayesPrint ("%s   Tree is unrooted\n", spacer);
4258         return (ERROR);
4259         }
4260
4261     /* calculate maximum number of branch segments above root */
4262     for (i=0; i<t->nNodes; i++)
4263         {
4264         p = t->allDownPass[i];
4265         if (p->anc != NULL)
4266             {
4267             if (p->left == NULL && p->right == NULL)
4268                 {
4269                 p->x = 0;
4270                 }
4271             else
4272                 {
4273                 if (p->left->x > p->right->x)
4274                     p->x = p->left->x + 1;
4275                 else
4276                     p->x = p->right->x + 1;
4277                 }
4278             if (p->anc->anc == NULL)
4279                 maxBrSegments = p->x;
4280             }
4281         }
4282
4283     /* assign node depths */
4284     for (i=0; i<t->nNodes; i++)
4285         {
4286         p = t->allDownPass[i];
4287         if (p->anc != NULL)
4288             p->nodeDepth = (MrBFlt) (p->x) / (MrBFlt) maxBrSegments;
4289         else
4290             p->nodeDepth = 0.0;
4291         }
4292
4293     /* calculate branch lengths */
4294     for (i=0; i<t->nNodes; i++)
4295         {
4296         p = t->allDownPass[i];
4297         if (p->anc != NULL)
4298             {
4299             if (p->anc->anc != NULL)
4300                 p->length = p->anc->nodeDepth - p->nodeDepth;
4301             else
4302                 p->length = 0.0;
4303             }
4304         }
4305
4306     return (NO_ERROR);
4307 }
4308
4309
4310 int GetRandomEmbeddedSubtree (Tree *t, int nTerminals, RandLong *seed, int *nEmbeddedTrees)
4311 {
4312     int         i, j, k, n, ran, *pP, *pL, *pR, nLeaves, *nSubTrees;
4313     TreeNode    *p=NULL, **leaf;
4314
4315     /* Calculate number of leaves in subtree (number of terminals minus the root) */
4316     nLeaves = nTerminals - 1;
4317
4318     /* Initialize all flags */
4319     for (i=0; i<t->nNodes; i++)
4320         {
4321         p = t->allDownPass[i];
4322         p->marked = NO;
4323         p->x = 0;
4324         p->y = 0;
4325         }
4326
4327     /* Allocate memory */
4328     nSubTrees = (int *) SafeCalloc (nTerminals * t->nNodes, sizeof(int));
4329     if (!nSubTrees)
4330         return (ERROR);
4331     leaf = (TreeNode **) SafeMalloc (nLeaves * sizeof (TreeNode *));
4332     if (!leaf)
4333         {
4334         free (nSubTrees);
4335         return (ERROR);
4336         }
4337
4338     /* Calculate how many embedded trees rooted at each node */
4339     (*nEmbeddedTrees) = 0;
4340     for (i=0; i<t->nNodes-1; i++)
4341         {
4342         p = t->allDownPass[i];
4343         if (p->left == NULL)
4344             {
4345             p->x = 0;
4346             nSubTrees[p->index*nTerminals + 1] = 1;
4347             }
4348         else
4349             {
4350             pL = nSubTrees + p->left->index*nTerminals;
4351             pR = nSubTrees + p->right->index*nTerminals;
4352             pP = nSubTrees + p->index*nTerminals;
4353             pP[1] = 1;
4354             for (j=2; j<=nLeaves; j++)
4355                 {
4356                 for (k=1; k<j; k++)
4357                     {
4358                     pP[j] += pL[k] * pR[j-k];
4359                     }
4360                 }
4361             p->x = pP[nLeaves];
4362             (*nEmbeddedTrees) += p->x;
4363             }
4364         }
4365
4366     /* Randomly select one embedded tree of the right size */
4367     ran = (int) (RandomNumber(seed) * (*nEmbeddedTrees));
4368
4369     /* Find the interior root corresponding to this tree */
4370     for (i=j=0; i<t->nIntNodes; i++)
4371         {
4372         p = t->intDownPass[i];
4373         j += p->x;
4374         if (j>ran)
4375             break;
4376         }
4377
4378     /* Find one random embedded tree with this root */
4379     p->y = nLeaves;
4380     p->marked = YES;
4381     leaf[0] = p;
4382     n = 1;
4383     while (n < nLeaves)
4384         {
4385         /* select a node with more than one descendant */
4386         for (i=0; i<n; i++)
4387             {
4388             p = leaf[i];
4389             if (p->y > 1)
4390                 break;
4391             }
4392
4393         /* break it into descendants */
4394         pL = nSubTrees + p->left->index*nTerminals;
4395         pR = nSubTrees + p->right->index*nTerminals;
4396         pP = nSubTrees + p->index*nTerminals;
4397         ran = (int) (RandomNumber(seed) * pP[p->y]);
4398         k = 0;
4399         for (j=1; j<p->y; j++)
4400             {
4401             k += pL[j] * pR[p->y-j];
4402             if (k > ran)
4403                 break;
4404             }
4405
4406             p->left->y = j;
4407         p->right->y = p->y - j;
4408         p->left->marked = YES;
4409         p->right->marked = YES;
4410         leaf[i] = p->left;
4411         leaf[n++] = p->right;
4412         }
4413
4414     free (nSubTrees);
4415     free (leaf);
4416
4417     return (NO_ERROR);
4418 }
4419
4420
4421 /*-----------------------------------------------------------------------------
4422 |
4423 | IsCalibratedClockSatisfied: This routine SETS (not just checks as name suggested) calibrated clock tree nodes age, depth. based on branch lengthes
4424 |     and checks that user defined brlens satisfy the specified calibration(s) up to tolerance tol
4425 | 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)
4426 |
4427 |------------------------------------------------------------------------------*/
4428 int IsCalibratedClockSatisfied (Tree *t,MrBFlt *minClockRate,MrBFlt *maxClockRate , MrBFlt tol)
4429 {
4430     int             i, j, maxRateConstrained, minRateConstrained, isViolated;
4431     MrBFlt          f, maxHeight, minRate=0, maxRate=0, ageToAdd, *x, *y, clockRate;
4432     TreeNode        *p, *q, *r, *s;
4433
4434     /* By defauult assume the tree does not have allowed range of clockrate */
4435     *minClockRate = 2.0;
4436     *maxClockRate = 1.0;
4437
4438     if (t->isRooted == NO)
4439         return (NO);
4440
4441     x = (MrBFlt *) SafeCalloc (2*t->nNodes, sizeof (MrBFlt));
4442     if (x == NULL)
4443         {
4444         MrBayesPrint ("%s   Out of memory in IsCalibratedClockSatisfied\n", spacer);
4445         free (x);
4446         return (NO);
4447         }
4448     y = x + t->nNodes;
4449
4450     /* reset node depth and age, and set minimum (x) and maximum (y) age of each node */
4451     for (i=0; i<t->nNodes; i++)
4452         {
4453         p = t->allDownPass[i];
4454         p->age = -1.0;
4455         p->nodeDepth = -1.0;
4456         if (p->isDated == YES)
4457             {
4458             assert (p->calibration->prior != unconstrained);
4459             x[p->index] = p->calibration->min;
4460             y[p->index] = p->calibration->max;
4461             }
4462         else if (p->left == NULL && p->right == NULL)
4463             x[p->index] = y[p->index] = 0.0;
4464         else
4465             {
4466             x[p->index] = y[p->index] = -1.0;
4467             }
4468         }
4469
4470     /* calculate node heights in branch length units */
4471     /* node depth will be set from the root for now  */
4472     p = t->root->left;
4473     p->nodeDepth = 0.0;
4474     for (i=t->nNodes-3; i>=0; i--)
4475         {
4476         p = t->allDownPass[i];
4477         p->nodeDepth = p->anc->nodeDepth + p->length;
4478         }
4479
4480     /* find maximum height of tree */
4481     maxHeight = -1.0;
4482     for (i=0; i<t->nNodes-1; i++)
4483         {
4484         p = t->allDownPass[i];
4485         if (p->left == NULL && p->right == NULL)
4486             {
4487             if (p->nodeDepth > maxHeight)
4488                 {
4489                 maxHeight = p->nodeDepth;
4490                 }
4491             }
4492         }
4493
4494     /* calculate node depth from tip of tree */
4495     for (i=0; i<t->nNodes-1; i++)
4496         {
4497         p = t->allDownPass[i];
4498         p->nodeDepth = maxHeight - p->nodeDepth;
4499         }
4500
4501     /* check potentially constraining calibrations */
4502     /* and find minimum and maximum possible rate */
4503     maxRateConstrained = NO;
4504     minRateConstrained = NO;
4505     isViolated = NO;
4506     for (i=0; i<t->nNodes-1; i++)
4507         {
4508         p = t->allDownPass[i];
4509         if (x[p->index] < 0.0 && y[p->index] < 0.0)
4510             continue;
4511         for (j=i+1; j<t->nNodes-1; j++)
4512             {
4513             q = t->allDownPass[j];
4514             if (x[q->index] < 0.0 && y[q->index] < 0.0)
4515                 continue;
4516             if (p->nodeDepth == q->nodeDepth) // becouse clock rate could be as low as possible we can not take approximate equality.
4517                 {
4518                 /* same depth so they must share a possible age */
4519                 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]) ||
4520                     (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]))
4521                     {
4522                     isViolated = YES;
4523                     break;
4524                     }
4525                 }
4526             else
4527                 {
4528                 if (p->nodeDepth > q->nodeDepth)
4529                     {
4530                     r = p;
4531                     s = q;
4532                     }
4533                 else
4534                     {
4535                     r = q;
4536                     s = p;
4537                     }
4538                 if (x[r->index] >= 0.0 && y[s->index] >= 0.0)
4539                     {
4540                     f = (r->nodeDepth - s->nodeDepth) / (x[r->index] - y[s->index]);
4541                     if (f <= 0.0 || x[r->index] == y[s->index])
4542                         {
4543                         if (AreDoublesEqual (r->nodeDepth, s->nodeDepth, tol*0.1) == YES)
4544                             continue;
4545                         if ((r->calibration != NULL && r->calibration->prior != fixed) || (s->calibration != NULL && s->calibration->prior != fixed))
4546                             continue;
4547                         isViolated = YES;
4548                         break;
4549                         }
4550                     if (maxRateConstrained == NO)
4551                         {
4552                         maxRateConstrained = YES;
4553                         maxRate = f;
4554                         }
4555                     else if (f < maxRate)
4556                         maxRate = f;
4557                     }
4558                 if (y[r->index] >= 0.0 && x[s->index] >= 0.0)
4559                     {
4560                     f = (r->nodeDepth - s->nodeDepth) / (y[r->index] - x[s->index]);
4561                     if (f <= 0.0 || y[r->index] == x[s->index])
4562                         {
4563                         if (AreDoublesEqual (r->nodeDepth, s->nodeDepth, tol*0.1) == YES)
4564                             continue;
4565                         isViolated = YES;
4566                         break;
4567                         }
4568                     if (minRateConstrained == NO)
4569                         {
4570                         minRateConstrained = YES;
4571                         minRate = f;
4572                         }
4573                     else if (f > minRate)
4574                         minRate = f;
4575                     }
4576                 }
4577             }
4578         if (isViolated == YES)
4579             break;
4580         }
4581
4582     /* check if outright violation */
4583     if (isViolated == YES)
4584         {
4585         MrBayesPrint ("%s   Branch lengths do not satisfy the calibration(s)\n", spacer);
4586         free (x);
4587         return (NO);
4588         }
4589
4590     /* Allow tollerance */
4591     if (minRateConstrained == YES && maxRateConstrained == YES && AreDoublesEqual (minRate, maxRate, tol) == YES && minRate > maxRate)
4592         {
4593         maxRate = minRate;
4594         }
4595
4596     if (minRateConstrained == YES)
4597         *minClockRate = minRate;
4598     else
4599         *minClockRate = 0.0;
4600
4601     if (maxRateConstrained == YES)
4602         *maxClockRate = maxRate;
4603     else
4604         *maxClockRate = MRBFLT_MAX;
4605
4606     /* check that minimum and maximum rates are consistent */
4607     if (minRateConstrained == YES && maxRateConstrained == YES && minRate > maxRate)
4608         {
4609         MrBayesPrint ("%s   Branch lengths do not satisfy the calibration(s)\n", spacer);
4610         free (x);
4611         return (NO);
4612         }
4613
4614     /* date all nodes based on a suitable rate */
4615     if (minRateConstrained == YES)
4616         clockRate = minRate;
4617     else if (maxRateConstrained == YES)
4618         clockRate = 0.5 * maxRate;
4619     else
4620         clockRate = 1.0;
4621     for (i=0; i<t->nNodes-1; i++)
4622         {
4623         p = t->allDownPass[i];
4624         p->age = p->nodeDepth / clockRate;
4625         }
4626
4627     /* 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) */
4628     ageToAdd = 0.0;
4629     for (i=0; i<t->nNodes-1; i++)
4630         {
4631         p = t->allDownPass[i];
4632         if (x[p->index] > 0.0 && x[p->index] > p->age)
4633             {
4634             f = x[p->index] - p->age;
4635             if (f > ageToAdd)
4636                 ageToAdd = f;
4637             }
4638         }
4639
4640     /* add extra length if any */
4641     if (AreDoublesEqual (ageToAdd, 0.0, 0.00000001) == NO)
4642         {
4643         for (i=0; i<t->nNodes-1; i++)
4644             {
4645             p = t->allDownPass[i];
4646             p->age += ageToAdd;
4647             }
4648         }
4649
4650     free (x);
4651
4652     /* reset node depths to ensure that non-dated tips have node depth 0.0 */
4653     SetNodeDepths(t);
4654
4655     return (YES);
4656 }
4657
4658
4659 int IsClockSatisfied (Tree *t, MrBFlt tol)
4660 {
4661     int             i, foundFirstLength, isClockLike;
4662     MrBFlt          firstLength=0.0, length;
4663     TreeNode        *p, *q;
4664
4665     if (t->isRooted == NO)
4666         return (NO);
4667
4668     foundFirstLength = NO;
4669     isClockLike = YES;
4670     for (i=0; i<t->nNodes; i++)
4671         {
4672         p = t->allDownPass[i];
4673         if (p->left == NULL && p->right == NULL)
4674             {
4675             if (p->isDated == YES)
4676                 {
4677                 //continue;
4678                 length = p->nodeDepth;
4679                 }
4680             else
4681                 length = 0.0;
4682             q = p;
4683             while (q->anc != NULL)
4684                 {
4685                 if (q->anc->anc != NULL)
4686                     length += q->length;
4687                 q = q->anc;
4688                 }
4689             if (foundFirstLength == NO)
4690                 {
4691                 firstLength = length;
4692                 foundFirstLength = YES;
4693                 }
4694             else
4695                 {
4696                 if (AreDoublesEqual (firstLength, length, tol) == NO)
4697                     {
4698                     MrBayesPrint ("%s   Node (%s) is not at the same depth as some other tip taking colibration into account. \n", spacer, p->label);
4699                     isClockLike = NO;
4700                     }
4701                 }
4702             }
4703         }
4704     if (firstLength < BRLENS_MIN)
4705         isClockLike = NO;
4706
4707     return (isClockLike);
4708 }
4709
4710
4711 /* Check that tree obeys topology constraints and that node depths and ages are consistent */
4712 int IsTreeConsistent (Param *param, int chain, int state)
4713 {
4714     Tree        *tree;
4715     TreeNode    *p;
4716     int         i, j;
4717     MrBFlt      b, r, rAnc, clockRate;
4718     Param       *subParm;
4719
4720     if (param->paramType != P_TOPOLOGY && param->paramType != P_BRLENS && param->paramType != P_SPECIESTREE)
4721         return YES;
4722
4723     tree      = GetTree(param, chain, state);
4724     if (modelSettings[param->relParts[0]].clockRate != NULL)
4725         clockRate = *GetParamVals(modelSettings[param->relParts[0]].clockRate, chain, state);
4726     else
4727         clockRate = 1.0;
4728
4729     if (CheckConstraints(tree)==ERROR) {
4730         printf ("Tree does not obey constraints\n");
4731         return NO;
4732     }
4733
4734     /* check that the last few indices are not taken in a rooted tree */
4735     if (tree->isRooted == YES && tree->root->index != tree->nNodes - 1)
4736         {
4737         printf ("Problem with root index\n");
4738         return NO;
4739         }
4740     if (tree->isRooted == YES && tree->root->left->index != tree->nNodes - 2)
4741         {
4742         printf ("Problem with interior root index\n");
4743         return NO;
4744         }
4745
4746     if (tree->isClock == NO)
4747         {
4748         for (i=0; i<tree->nNodes-1; i++)
4749             {
4750             p = tree->allDownPass[i];
4751             if (p->length <= 0.0)
4752                 {
4753                 if (p->length == 0.0)
4754                     printf ("Node %d has zero branch length %f\n", p->index, p->length);
4755                 else
4756                     printf ("Node %d has negative branch length %f\n", p->index, p->length);
4757                 return NO;
4758                 }
4759             }
4760         return YES;
4761         }
4762
4763     /* Clock trees */
4764
4765     /* Check that lengths and depths are consistent */
4766     for (i=0; i<tree->nNodes-2; i++) {
4767         p = tree->allDownPass[i];
4768         if (p->length < 0.0) {
4769             printf ("Node %d has negative branch length %f\n", p->index, p->length);
4770             return NO;
4771         }
4772         if (fabs(p->anc->nodeDepth - p->nodeDepth - p->length) > 0.000001) {
4773             printf ("Node %d has length %f but nodeDepth %f and ancNodeDepth %f\n",
4774                 p->index, p->length, p->nodeDepth, p->anc->nodeDepth);
4775             return NO;
4776         }
4777         if (p->left == NULL && p->isDated == NO && p->nodeDepth != 0.0) {
4778                 printf ("Node %d is an autodated tip (0.0) but has node depth %lf\n",
4779                     p->index, p->nodeDepth);
4780                 return NO;
4781         }
4782     }
4783
4784     /* Check that ages and calibrations are consistent */
4785     if (tree->isCalibrated == YES)
4786         {
4787         for (i=0; i<tree->nNodes-1; i++)
4788             {
4789             p = tree->allDownPass[i];
4790             if (p->isDated == YES) {
4791                 if (fabs((p->age - p->nodeDepth/clockRate)/p->age) > 0.000001)
4792                     {
4793                     printf ("Node %d has age %f but nodeDepth %f when clock rate is %f\n",
4794                         p->index, p->age, p->nodeDepth, clockRate);
4795                     return NO;
4796                     }
4797                 if (p->calibration->prior == fixed && fabs((p->age - p->calibration->priorParams[0])/p->age) > 0.000001)
4798                     {
4799                     printf ("Node %d has age %f but should be fixed to age %f\n",
4800                         p->index, p->age, p->calibration->priorParams[0]);
4801                     return NO;
4802                     }
4803                 else if (p->calibration->prior == uniform &&
4804                         ((p->age - p->calibration->min)/p->age < -0.000001 || (p->age - p->calibration->max)/p->age > 0.000001))
4805                     {
4806                     printf ("Node %d has age %f but should be in the interval [%f,%f]\n",
4807                         p->index, p->age, p->calibration->min, p->calibration->max);
4808                     return NO;
4809                     }
4810                 else if ((p->age - p->calibration->min)/p->age < -0.000001)
4811                     {
4812                     printf ("Node %d has age %f but should be at least of age %f\n",
4813                         p->index, p->age, p->calibration->min);
4814                     return NO;
4815                     }
4816                 else if ((p->age - p->calibration->max)/p->age > 0.000001)
4817                     {
4818                     printf ("Node %d has age %f but should be no older than %f\n",
4819                         p->index, p->age, p->calibration->max);
4820                     return NO;
4821                     }
4822                 }
4823             }
4824         }
4825
4826     for (i=0; i<param->nSubParams; i++)
4827         {
4828         subParm = param->subParams[i];
4829         if (subParm->paramId == TK02BRANCHRATES || (subParm->paramId == MIXEDBRCHRATES && *GetParamIntVals(subParm, chain, state) == RCL_TK02))
4830             {
4831             rAnc = GetParamVals(subParm, chain, state)[tree->root->left->index];
4832             if (fabs(rAnc - 1.0) > 1E-6)
4833                 {
4834                 printf ("%s   TK02 relaxed clock mismatch in root rate, which is %e\n", spacer, rAnc);
4835                 return NO;
4836                 }
4837             for (j=0; j<tree->nNodes-2; j++)
4838                 {
4839                 p = tree->allDownPass[j];
4840                 b = GetParamSubVals(subParm, chain, state)[p->index];
4841                 r = GetParamVals(subParm, chain, state)[p->index];
4842                 rAnc = GetParamVals(subParm, chain, state)[p->anc->index];
4843                 if (fabs(p->length * (r + rAnc) / 2.0 - b) > 0.000001)
4844                     {
4845                     printf ("%s   TK02 relaxed clock mismatch in branch %d\n", spacer, p->index);
4846                     return NO;
4847                     }
4848                 }
4849             }
4850         else if (subParm->paramId == IGRBRANCHRATES || (subParm->paramId == MIXEDBRCHRATES && *GetParamIntVals(subParm, chain, state) == RCL_IGR))
4851             {
4852             for (j=0; j<tree->nNodes-2; j++)
4853                 {
4854                 p = tree->allDownPass[j];
4855                 b = GetParamSubVals(subParm, chain, state)[p->index];
4856                 r = GetParamVals(subParm, chain, state)[p->index];
4857                 if (fabs(p->length * r - b) > 0.000001)
4858                     {
4859                     printf ("%s   Igr relaxed clock mismatch in branch %d\n", spacer, p->index);
4860                     return NO;
4861                     }
4862                 }
4863             }
4864         }
4865
4866     if (param->paramType == P_SPECIESTREE)
4867         return (IsSpeciesTreeConsistent(GetTree(param, chain, state), chain));
4868
4869     return YES;
4870 }
4871
4872
4873 /* LabelTree: Label tree; remove previous labels if any */
4874 int LabelTree (Tree *t, char **taxonNames)
4875 {
4876     int         i, nTaxa;
4877     TreeNode    *p = NULL;
4878
4879     nTaxa = t->nNodes - t->nIntNodes;
4880     if (t->isRooted == YES)
4881         nTaxa--;
4882
4883     /* erase previous labels, if any */
4884     for (i=0; i<t->nNodes; i++)
4885         {
4886         p = t->allDownPass[i];
4887         p->marked = NO;
4888         t->nodes[i].label = noLabel;
4889         }
4890
4891     /* add labels */
4892     for (i=0; i<t->nNodes; i++)
4893         {
4894         p = &t->nodes[i];
4895         if (p->left == NULL || (t->isRooted == NO && p->anc == NULL))
4896             {
4897             if (p->marked == YES || p->index < 0 || p->index >= nTaxa)
4898                 {
4899                 MrBayesPrint ("%s   Taxon node index repeated or out of range\n", spacer);
4900                 return (ERROR);
4901                 }
4902             else
4903                 p->label = taxonNames[p->index];
4904             p->marked = YES;
4905             }
4906         else if (p->index > 0 && p->index < nTaxa)
4907             {
4908             MrBayesPrint ("%s   Terminal taxon index set for interior node\n", spacer);
4909             return (ERROR);
4910             }
4911         }
4912
4913     return (NO_ERROR);
4914 }
4915
4916
4917 /*-------------------------------------------------------------------------------------------
4918 |
4919 |   Mark: This routine will mark up a subtree rooted at p
4920 |
4921 ---------------------------------------------------------------------------------------------*/
4922 void Mark (TreeNode *p)
4923 {
4924     if (p != NULL)
4925         {
4926         p->marked = YES;
4927         Mark (p->left);
4928         Mark (p->right);
4929         }
4930 }
4931
4932
4933 /*-------------------------------------------------------------------------------------------
4934  |
4935  |   MarkDistance: This routine will mark up an unconstrained subtree rooted at p within dist
4936  |      The distance will be positive in the crown part and negative in the root part.
4937  |
4938  ---------------------------------------------------------------------------------------------*/
4939 void MarkDistance (TreeNode *p, int YESorNO, int dist, int *n)
4940 {
4941     if (p == NULL || p->anc == NULL)
4942         return;
4943
4944     p->marked = YES;
4945     if (YESorNO == YES) // in root part
4946         p->x = p->anc->x -1;
4947     else               // in crown part
4948         p->x = p->anc->x +1;
4949     (*n)++;
4950
4951     if (p->isLocked == NO && abs(p->x) < dist)
4952         {
4953         MarkDistance (p->left, YESorNO, dist, n);
4954         MarkDistance (p->right,YESorNO, dist, n);
4955         }
4956 }
4957
4958
4959 /*-------------------------------------------------------------------------------------------
4960  |
4961  |   MarkUnconstrained: This routine will mark up an unconstrained subtree rooted at p
4962  |
4963  ---------------------------------------------------------------------------------------------*/
4964 void MarkUnconstrained (TreeNode *p)
4965 {
4966     if (p != NULL)
4967         {
4968         p->marked = YES;
4969         if (p->isLocked == NO)
4970             {
4971             MarkUnconstrained (p->left);
4972             MarkUnconstrained (p->right);
4973             }
4974         }
4975 }
4976
4977
4978 /*-------------------------------------------------------------------------------------------
4979 |
4980 |   MoveCalculationRoot: This routine will move the calculation root to the terminal with
4981 |      index outgroup
4982 |
4983 ---------------------------------------------------------------------------------------------*/
4984 int MoveCalculationRoot (Tree *t, int outgroup)
4985 {
4986     int             i;
4987     TreeNode        *p, *q, *r;
4988
4989     if (t->isRooted == YES || outgroup < 0 || outgroup > t->nNodes - t->nIntNodes - (t->isRooted == YES ? 1 : 0))
4990         {
4991         MrBayesPrint ("%s   Problem moving calculation root\n", spacer);
4992         return (ERROR);
4993         }
4994
4995     if (t->root->index == outgroup)
4996         return (NO_ERROR);    /* nothing to do */
4997
4998     /* mark the path to the new calculation root */
4999     for (i=0; i<t->nNodes; i++)
5000         {
5001         p = t->allDownPass[i];
5002         if (p->left == NULL && p->right == NULL)
5003             {
5004             if (p->index == outgroup)
5005                 p->marked = YES;
5006             else
5007                 p->marked = NO;
5008             }
5009         else
5010             {
5011             if (p->left->marked == YES || p->right->marked == YES)
5012                 p->marked = YES;
5013             else
5014                 p->marked = NO;
5015             }
5016         }
5017
5018     /* rotate the tree to use the specified calculation root */
5019     p = t->root->left;
5020     q = t->root;
5021     q->anc = p;
5022     q->left = q->right = NULL;
5023     q->length = p->length;
5024     while (p->left != NULL && p->right != NULL)
5025         {
5026         if (p->left->marked == YES)
5027             {
5028             r = p->left;
5029             p->anc = r;
5030             p->left = q;
5031             p->length = r->length;
5032             q = p;
5033             p = r;
5034             }
5035         else /* if (p->right->marked == YES) */
5036             {
5037             r = p->right;
5038             p->anc = r;
5039             p->right = q;
5040             p->length = r->length;
5041             q = p;
5042             p = r;
5043             }
5044         }
5045     p->left = p->anc;
5046     p->right = p->anc = NULL;
5047     t->root = p;
5048     p->length = 0.0;
5049
5050     GetDownPass (t);
5051
5052     return (NO_ERROR);
5053 }
5054
5055
5056 /*-------------------------------------------------------------------------------------------
5057 |
5058 |   MovePolyCalculationRoot: This routine will move the calculation root to the terminal with
5059 |      index outgroup and place it as the right-most descendant of the root node
5060 |
5061 ---------------------------------------------------------------------------------------------*/
5062 int MovePolyCalculationRoot (PolyTree *t, int outgroup)
5063 {
5064     int             i;
5065     PolyNode        *p = NULL, *q, *r;
5066
5067     /* check if tree is rooted, in which case calculation root is irrelevant */
5068     if (t->root->left->sib->sib == NULL)
5069         return (NO_ERROR);
5070
5071     if (outgroup < 0 || outgroup > t->nNodes - t->nIntNodes)
5072         {
5073         MrBayesPrint ("%s   Outgroup index is out of range\n", spacer);
5074         return (ERROR);
5075         }
5076
5077     if (t->root->left->sib->sib->sib != NULL)
5078         {
5079         MrBayesPrint ("%s   Root has more than three descendants\n", spacer);
5080         return (ERROR);
5081         }
5082
5083     /* check if rerooting actually necessary */
5084     if (t->root->left->sib->sib->index == outgroup)
5085         return (NO_ERROR);
5086
5087     /* mark the path to the new calculation root */
5088     for (i=0; i<t->nNodes; i++)
5089         {
5090         p = t->allDownPass[i];
5091         if (p->index == outgroup)
5092             break;
5093         }
5094     if (p->left != NULL)
5095         {
5096         MrBayesPrint ("%s   Outgroup index set for internal node\n", spacer);
5097         for (i=0; i<t->nNodes; i++)
5098             printf ("%d -- %d\n", i, t->allDownPass[i]->index);
5099         getchar();
5100         return (ERROR);
5101         }
5102
5103     /* mark path to current root */
5104     for (i=0; i<t->nNodes; i++)
5105         t->allDownPass[i]->mark = NO;
5106     q = p;
5107     while (q != NULL)
5108         {
5109         q->mark = YES;
5110         q = q->anc;
5111         }
5112
5113     /* rotate the tree to use the specified calculation root */
5114     p = t->root;
5115     for (;;)
5116         {
5117         /* find marked descendant */
5118         for (q=p->left; q->mark == NO; q=q->sib)
5119             ;
5120         if (q->index == outgroup)
5121             break;
5122         /* add old root to descendants of that node */
5123         for (r=q->left; r->sib!=NULL; r=r->sib)
5124             ;
5125         r->sib = p;
5126         p->sib = NULL;   /* should not be needed */
5127         p->anc = q;
5128         p->length = q->length;
5129         /* remove that node from descendants of old root node */
5130         if (p->left == q)
5131             p->left = q->sib;
5132         else
5133             {
5134             for (r=p->left; r->sib!=q; r=r->sib)
5135                 ;
5136             r->sib = r->sib->sib;
5137             }
5138         /* make new node root */
5139         q->sib = NULL;
5140         q->anc = NULL;
5141         q->length = 0.0;
5142         p = q;
5143         }
5144
5145     /* p is now the new root */
5146     t->root = p;
5147
5148     /* finally make sure calculation root is last node among root's descendants */
5149     for (q=p->left; q->sib!=NULL; q=q->sib)
5150         ;
5151     if (q->index != outgroup)
5152         {
5153         if (p->left->index == outgroup)
5154             {
5155             q->sib = p->left;
5156             p->left = p->left->sib;
5157             q->sib->sib = NULL;
5158             }
5159         else
5160             {
5161             for (r=p->left; r->sib->index!=outgroup; r=r->sib)
5162                 ;
5163             q->sib = r->sib;
5164             r->sib = r->sib->sib;
5165             q->sib->sib = NULL;
5166             }
5167         }
5168
5169     GetPolyDownPass (t);
5170
5171     return (NO_ERROR);
5172 }
5173
5174
5175 /*
5176 @return the number of levels for the tree rooted at the "node"
5177 */
5178 int NrSubTreeLevels(TreeNode *node)
5179 {
5180     int r,l;
5181
5182     if (node == NULL)
5183         {
5184         return -1;
5185         }
5186
5187     r = NrSubTreeLevels (node->right);
5188     l = NrSubTreeLevels (node->left);
5189
5190     return ((r>l)?(r):(l))+1;
5191 }
5192
5193
5194 /*-------------------------------------------------------------------------------------------
5195 |
5196 |   NumConstrainedTips: This routine will return the number of constrained tips, internal or external
5197 |
5198 ---------------------------------------------------------------------------------------------*/
5199 int NumConstrainedTips (TreeNode *p)
5200 {
5201     int     i = 0;
5202
5203     if (p == NULL)
5204         return i;
5205     if (p->left == NULL)
5206         return 1;
5207
5208     i += NConstrainedTips (p->left);
5209     i += NConstrainedTips (p->right);
5210
5211     return i;
5212 }
5213
5214
5215 /* NConstrainedTips: Recursive function to get the number of constrained tips */
5216 int NConstrainedTips (TreeNode *p)
5217 {
5218     int     i=0;
5219
5220     if (p!=NULL)
5221         {
5222         if (p->left == NULL || p->isLocked == YES)
5223             return 1;
5224         else
5225             {
5226             i += NConstrainedTips (p->left);
5227             i += NConstrainedTips (p->right);
5228             }
5229         }
5230     return i;
5231 }
5232
5233
5234 /*-------------------------------------------------------------------------------------------
5235 |
5236 |   NumDatedTips: This routine will return the number of dated tips, internal or external
5237 |
5238 ---------------------------------------------------------------------------------------------*/
5239 int NumDatedTips (TreeNode *p)
5240 {
5241     int     i = 0;
5242
5243     assert (p != NULL && p->left != NULL);
5244
5245     i += NDatedTips (p->left);
5246     i += NDatedTips (p->right);
5247
5248     return i;
5249 }
5250
5251
5252 /* NDatedTips: recursive function to get the number of dated tips */
5253 int NDatedTips (TreeNode *p)
5254 {
5255     int     i=0;
5256
5257     assert (p!=NULL);
5258
5259     if (p->left == NULL || p->isDated == YES)
5260         return 1;
5261     else
5262         {
5263         i += NDatedTips (p->left);
5264         i += NDatedTips (p->right);
5265         return i;
5266         }
5267 }
5268
5269
5270 /* OrderTips: Order tips in a polytomous tree */
5271 void OrderTips (PolyTree *t)
5272 {
5273     int         i, j;
5274     PolyNode    *p, *q, *r, *pl, *ql, *rl;
5275
5276     /* label by minimum index */
5277     for (i=0; i<t->nNodes; i++)
5278         {
5279         p = t->allDownPass[i];
5280         if (p->left == NULL)
5281             {
5282             if (t->isRooted == NO && p->index == localOutGroup)
5283                 p->x = -1;
5284             else
5285                 p->x = p->index;
5286             }
5287         else
5288             {
5289             j = t->nNodes;
5290             for (q=p->left; q!=NULL; q=q->sib)
5291                 {
5292                 if (q->x < j)
5293                     j = q->x;
5294                 }
5295             p->x = j;
5296             }
5297         }
5298
5299     /* and rearrange */
5300     for (i=0; i<t->nNodes; i++)
5301         {
5302         p = t->allDownPass[i];
5303         if (p->left == NULL || p->anc == NULL)
5304             continue;
5305         for (ql=NULL, q=p->left; q->sib!=NULL; ql=q, q=q->sib)
5306             {
5307             for (rl=q, r=q->sib; r!=NULL; rl=r, r=r->sib)
5308                 {
5309                 if (r->x < q->x)
5310                     {
5311                     if (ql == NULL)
5312                         p->left = r;
5313                     if (r == q->sib) /* swap adjacent q and r */
5314                         {
5315                         if (ql != NULL)
5316                             ql->sib = r;
5317                         pl = r->sib;
5318                         r->sib = q;
5319                         q->sib = pl;
5320                         }
5321                     else    /* swap separated q and r */
5322                         {
5323                         if (ql != NULL)
5324                             ql->sib = r;
5325                         pl = r->sib;
5326                         r->sib = q->sib;
5327                         rl->sib = q;
5328                         q->sib = pl;
5329                         }
5330                     pl = q;
5331                     q = r;
5332                     r = pl;
5333                     }
5334                 }
5335             }
5336         }
5337     GetPolyDownPass(t);
5338 }
5339
5340
5341 /* PrintNodes: Print a list of tree nodes, pointers and length */
5342 void PrintNodes (Tree *t)
5343 {
5344     int         i;
5345     TreeNode    *p;
5346
5347     printf ("Node\tleft\tright\tanc\tlength\n");
5348     for (i=0; i<t->nNodes; i++)
5349         {
5350         p = &t->nodes[i];
5351         printf ("%d\t%d\t%d\t%d\t%f\t%f\n",
5352             p->index,
5353             p->left == NULL ? -1 : p->left->index,
5354             p->right == NULL ? -1 : p->right->index,
5355             p->anc == NULL ? -1 : p->anc->index,
5356             p->length,
5357             p->nodeDepth);
5358         }
5359
5360     if (t->root == NULL)
5361         printf ("root: NULL\n");
5362     else
5363         printf ("root: %d\n", t->root->index);
5364
5365     printf ("allDownPass:");
5366     for (i=0; i<t->nNodes; i++)
5367         {
5368         p = t->allDownPass[i];
5369         if (p!=NULL)
5370             printf ("  %d", p->index);
5371         else
5372             printf ("  NULL");
5373         }
5374     printf ("\nintDownPass:  ");
5375     for (i=0; i<t->nIntNodes; i++)
5376         {
5377         p = t->intDownPass[i];
5378         if (p!=NULL)
5379             printf ("  %d\t", p->index);
5380         else
5381             printf ("  NULL\t");
5382         }
5383     printf ("\n");
5384 }
5385
5386
5387 /* PrintPolyNodes: Print a list of polytomous tree nodes, pointers and length */
5388 void PrintPolyNodes (PolyTree *pt)
5389 {
5390     int         i, j, k;
5391     PolyNode    *p;
5392
5393     printf ("Node\tleft\tsib\tanc\tlength\tlabel\n");
5394     for (i=0; i<pt->memNodes; i++)
5395         {
5396         p = &pt->nodes[i];
5397         printf ("%d\t%d\t%d\t%d\t%f\t%s\n",
5398             p->index,
5399             p->left == NULL ? -1 : p->left->index,
5400             p->sib == NULL ? -1 : p->sib->index,
5401             p->anc == NULL ? -1 : p->anc->index,
5402             p->length,
5403             p->label);
5404         }
5405     printf ("root: %d\n", pt->root->index);
5406     fflush(stdout);
5407
5408     if (pt->nBSets > 0)
5409         {
5410         for (i=0; i<pt->nBSets; i++)
5411             {
5412             printf ("Effective branch length set '%s'\n", pt->bSetName[i]);
5413             for (j=0; j<pt->nNodes; j++)
5414                 {
5415                 printf ("%d:%f", j, pt->effectiveBrLen[pt->nBSets][j]);
5416                 if (j != pt->nNodes-1)
5417                     printf (", ");
5418                 }
5419             printf ("\n");
5420             }
5421         }
5422
5423     if (pt->nESets > 0)
5424         {
5425         for (i=0; i<pt->nESets; i++)
5426             {
5427             printf ("Cpp event set '%s'\n", pt->eSetName[i]);
5428             for (j=0; j<pt->nNodes; j++)
5429                 {
5430                 if (pt->nEvents[i*pt->nNodes+j] > 0)
5431                     {
5432                     printf ("\tNode %d -- %d:(", j, pt->nEvents[i][j]);
5433                     for (k=0; k<pt->nEvents[i][j]; k++)
5434                         {
5435                         printf ("%f %f", pt->position[i][j][k], pt->rateMult[i][j][k]);
5436                         if (k != pt->nEvents[i][j]-1)
5437                             printf (", ");
5438                         }
5439                     printf (")\n");
5440                     }
5441                 }
5442             printf ("\n");
5443             }
5444         }
5445
5446     fflush(stdout);
5447 }
5448
5449
5450 /* PrintTranslateBlock: Print a translate block to file fp for tree t */
5451 void PrintTranslateBlock (FILE *fp, Tree *t)
5452 {
5453     int     i, j, nTaxa;
5454
5455     if (t->isRooted == NO)
5456         nTaxa = t->nNodes - t->nIntNodes;
5457     else
5458         nTaxa = t->nNodes - t->nIntNodes - 1;
5459
5460     fprintf (fp, "\ttranslate\n");
5461
5462     for (i=0; i<nTaxa; i++)
5463         {
5464         for (j=0; j<t->nNodes; j++)
5465             if (t->allDownPass[j]->index == i)
5466                 break;
5467         if (i == nTaxa-1)
5468             fprintf (fp, "\t\t%d\t%s;\n", i+1, t->allDownPass[j]->label);
5469         else
5470             fprintf (fp, "\t\t%d\t%s,\n", i+1, t->allDownPass[j]->label);
5471         }
5472 }
5473
5474
5475 /**
5476 Update relaxed clock parameter of the branch of a node with index "b" after node with index "a" is removed.
5477 i.e. make branch of node with index "b" be a concatenation of its original branch and the branch of node with index "a"
5478 Relaxed clock parameter of node with index "a" become invalid in the process.
5479 Note: For Non-clock models the routine has no effect.
5480
5481 |       |
5482 |       |
5483 a       |
5484 |   ->  |
5485 |       |
5486 |       b
5487 b                */
5488 void AppendRelaxedBranch (int a,int b,PolyTree *t)
5489 {
5490     int i,len;
5491
5492     for (i=0; i<t->nBSets; i++)
5493         {
5494         t->effectiveBrLen[i][b] += t->effectiveBrLen[i][a];
5495         }
5496
5497     for (i=0; i<t->nESets; i++)
5498         {
5499         len=t->nEvents[i][a]+t->nEvents[i][b];
5500         t->position[i][a] = (MrBFlt *) SafeRealloc ((void *)t->position[i][a], len*sizeof(MrBFlt));
5501         t->rateMult[i][a] = (MrBFlt *) SafeRealloc ((void *)t->rateMult[i][a], len*sizeof(MrBFlt));
5502         memcpy (t->position[i][a]+t->nEvents[i][a], t->position[i][b], t->nEvents[i][b]*sizeof(MrBFlt));
5503         memcpy (t->rateMult[i][a]+t->nEvents[i][a], t->rateMult[i][b], t->nEvents[i][b]*sizeof(MrBFlt));
5504         free(t->position[i][b]);
5505         free(t->rateMult[i][b]);
5506         t->position[i][b] = t->position[i][a];
5507         t->rateMult[i][b] = t->rateMult[i][a];
5508         t->position[i][a] = NULL;
5509         t->rateMult[i][a] = NULL;
5510         t->nEvents[i][a] = 0;
5511         t->nEvents[i][b] = len;
5512         }
5513
5514 }
5515
5516
5517 /**
5518 Swap relaxed clock paramiters of the branch of nodes with index "a" and "b".
5519 */
5520 void SwapRelaxedBranchInfo (int a,int b,PolyTree *t)
5521 {
5522     int i,j;
5523     MrBFlt tmp, *tmpp;
5524
5525     for (i=0; i<t->nBSets; i++)
5526         {
5527         tmp = t->effectiveBrLen[i][a];
5528         t->effectiveBrLen[i][a] = t->effectiveBrLen[i][b];
5529         t->effectiveBrLen[i][b] = tmp;
5530         }
5531     if (t->popSizeSet == YES)
5532         {
5533         tmp = t->popSize[a];
5534         t->popSize[a]=t->popSize[b];
5535         t->popSize[b] = tmp;
5536         }
5537
5538     for (i=0; i<t->nESets; i++)
5539         {
5540         tmpp = t->position[i][a];
5541         t->position[i][a] = t->position[i][b];
5542         t->position[i][b] = tmpp;
5543         tmpp = t->rateMult[i][a];
5544         t->rateMult[i][a] = t->rateMult[i][b];
5545         t->rateMult[i][b] = tmpp;
5546         j = t->nEvents[i][a];
5547         t->nEvents[i][a] = t->nEvents[i][b];
5548         t->nEvents[i][b] = j;
5549         }
5550 }
5551
5552
5553 /*-------------------------------------------------------------------------------------------
5554 |
5555 |   PrunePolyTree: This routine will prune a polytomous tree according to the currently
5556 |      included taxa.  NB! All tree nodes cannot be accessed by cycling over the
5557 |      pt->nodes array after the deletion, because some spaces will be occupied by deleted
5558 |      nodes and pt->nNodes is no longer the length of this array
5559 |      (if proper re-arangment of pt->nodes needed then remove "#if 0" and make changes to p->x, see below).
5560 |
5561 ---------------------------------------------------------------------------------------------*/
5562 int PrunePolyTree (PolyTree *pt)
5563 {
5564     int             i, j, numDeleted, numTermPruned, numIntPruned, index;
5565     PolyNode        *p = NULL, *q=NULL, *r=NULL, *qa;
5566
5567     numDeleted = 0;
5568     for (i=0; i<pt->nNodes; i++)
5569         {
5570         p = pt->allDownPass[i];
5571         CheckString (taxaNames, numTaxa, p->label, &index);
5572         if (p->left == NULL && taxaInfo[index].isDeleted == YES)
5573             numDeleted++;
5574         }
5575
5576     if (numDeleted == 0)
5577         {
5578         /* nothing to do */
5579         return (NO_ERROR);
5580         }
5581     if (pt->nNodes - pt->nIntNodes - numDeleted < 3)
5582         {
5583         MrBayesPrint ("%s   Pruned tree has less than three taxa in it\n", spacer);
5584         return (ERROR);
5585         }
5586     if (pt->nNodes - pt->nIntNodes < numLocalTaxa)
5587         {
5588         MrBayesPrint ("%s   Tree to be pruned does not include all taxa\n", spacer);
5589         return (ERROR);
5590         }
5591
5592     /* prune away one node at a time */
5593     numIntPruned = 0;
5594     numTermPruned = 0;
5595     for (i=0; i<pt->nNodes; i++)
5596         {
5597         p = pt->allDownPass[i];
5598         if (p->left != NULL)
5599             continue;
5600         CheckString (taxaNames, numTaxa, p->label, &index);
5601         if (taxaInfo[index].isDeleted == YES)
5602             {
5603             numTermPruned++;
5604             for (q=p->anc->left; q!=NULL; q=q->sib)
5605                 {
5606                 if (q->sib == p)
5607                     break;
5608                 }
5609             if (q == NULL)
5610                 {
5611                 /* p is the left of its ancestor */
5612                 assert (p->anc->left == p);
5613                 p->anc->left = p->sib;
5614                 }
5615             else
5616                 {
5617                 /* p is q->sib; this also works if p->sib is NULL */
5618                 q->sib = p->sib;
5619                 }
5620             /* if only one child left, delete ancestral node */
5621             j = 0;
5622             for (q=p->anc->left; q!=NULL; q=q->sib)
5623                 j++;
5624             if (j == 1)
5625                 {
5626                 /* p->anc->left is only child left; make p->anc be p->anc->left and accommodate its length */
5627                 numIntPruned++;
5628                 qa= p->anc;
5629                 q = qa->left;
5630                 if (q->left == NULL)
5631                     {
5632                     AppendRelaxedBranch (qa->index, q->index, pt);
5633                     qa->index = q->index;
5634                     qa->length += q->length;
5635                     strcpy(qa->label, q->label);
5636                     qa->left = NULL;
5637                     /* 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 */
5638                     q->left = (struct pNode*)1;
5639                     }
5640                 else
5641                     {
5642                     if (qa->anc != NULL)
5643                         {
5644                         AppendRelaxedBranch (qa->index, q->index, pt);
5645                         qa->length += q->length;
5646                         }
5647                     qa->index   = q->index;
5648                     qa->left = q->left;
5649                     for (r=q->left; r!= NULL; r=r->sib)
5650                         r->anc = qa;
5651                     }
5652                 }
5653             /* if unrooted, then root node has to have more then 2 children, thus the following check */
5654             if (j == 2 && pt->isRooted == NO && p->anc->anc == NULL)
5655                 {
5656                 numIntPruned++;
5657                 r=p->anc; /*r is the root with only 2 children*/
5658                 if (r->left->left != NULL)
5659                     {/* Make r->left new root by attaching "right" child of r to children of r->left */
5660                     for (q=r->left->left; q->sib!=NULL; q=q->sib)
5661                         ;
5662                     q->sib = r->left->sib;
5663                     r->left->sib->anc = q->anc;
5664                     r->left->sib->length += q->anc->length;
5665                     r->left->sib = NULL;
5666                     r->left->anc = NULL;
5667                     pt->root = r->left;
5668                     }
5669                 else
5670                     {/* Make "right" child of r (r->left->sib) the new root by attaching r->left to children of r->"right" */
5671                     for (q=r->left->sib->left; q->sib!=NULL; q=q->sib)
5672                         ;
5673                     q->sib = r->left;
5674                     r->left->anc = q->anc;
5675                     r->left->length += q->anc->length;
5676                     r->left->sib = NULL;
5677                     q->anc->anc = NULL;
5678                     pt->root = q->anc;
5679                     }
5680                 }
5681             }
5682         }
5683
5684 #if 0
5685     /* 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. */
5686     for (i=0; i<pt->nNodes; i++)
5687         {
5688         p = &pt->nodes[i];
5689         if (p->x != 0)
5690             {
5691             for (j=i+1; j<pt->nNodes; j++)
5692                 {
5693                 q = &pt->nodes[j];
5694                 if (q->x == 0)
5695                     break;
5696                 }
5697             if (j != pt->nNodes)
5698                 {
5699                 /* swap nodes; quite difficult! */
5700                 CopyPolyNodes (p, q, nLongsNeeded);
5701                 p->left = q->left;
5702                 p->sib = q->sib;
5703                 p->anc = q->anc;
5704                 for (k=0; k<pt->nNodes; k++)
5705                     {
5706                     r = &pt->nodes[k];
5707                     if (r->left == q)
5708                         r->left = p;
5709                     if (r->sib == q)
5710                         r->sib = p;
5711                     if (r->anc == q)
5712                         r->anc = p;
5713                     }
5714                 }
5715             }
5716         }
5717 #endif
5718
5719     /* correct number of nodes */
5720     pt->nNodes -= (numTermPruned + numIntPruned);
5721     pt->nIntNodes -= numIntPruned;
5722
5723     /* get downpass; note that the deletion procedure does not change the root in rooted case */
5724     i=j=0;
5725     GetPolyNodeDownPass (pt, pt->root, &i, &j);
5726     assert (i==pt->nNodes);
5727     assert (j==pt->nIntNodes);
5728
5729     return (NO_ERROR);
5730 }
5731
5732
5733 /*--------------------------------------------------------------------
5734 |
5735 |       RandPerturb: Randomly perturb a tree by nPert NNIs
5736 |
5737 ---------------------------------------------------------------------*/
5738 int RandPerturb (Tree *t, int nPert, RandLong *seed)
5739 {
5740     int         i, whichNode;
5741     TreeNode    *p, *q, *a, *b, *c;
5742
5743     if (t->nConstraints >= t->nIntNodes)
5744         {
5745         MrBayesPrint ("%s   User tree cannot be perturbed because all nodes are locked\n", spacer);
5746         return (ERROR);
5747         }
5748
5749     for (i=0; i<nPert; i++)
5750         {
5751         do
5752             {
5753             whichNode = (int)(RandomNumber(seed) * (t->nIntNodes - 1));
5754             p = t->intDownPass[whichNode];
5755             } while (p->isLocked == YES);
5756
5757         q = p->anc;
5758         a  = p->left;
5759         b  = p->right;
5760         if (q->left == p)
5761             c  = q->right;
5762         else
5763             c  = q->left;
5764
5765         if (RandomNumber(seed) < 0.5)
5766             {
5767             /* swap b and c */
5768             p->right = c;
5769             c->anc  = p;
5770
5771             if (q->left == c)
5772                 q->left = b;
5773             else
5774                 q->right = b;
5775             b->anc = q;
5776             }
5777         else
5778             {
5779             /* swap a and c */
5780             p->left = c;
5781             c->anc  = p;
5782
5783             if (q->left == c)
5784                 q->left = a;
5785             else
5786                 q->right = a;
5787             a->anc = q;
5788             }
5789
5790         if (t->isCalibrated == YES)
5791             InitCalibratedBrlens (t, 0.0001, seed);
5792         else if (t->isClock == YES)
5793             InitClockBrlens (t);
5794         }
5795
5796     GetDownPass (t);
5797
5798     if (t->checkConstraints == YES && CheckConstraints (t) == NO_ERROR)
5799         {
5800         MrBayesPrint ("%s   Broke constraints when perturbing tree\n", spacer);
5801         return (ERROR);
5802         }
5803
5804     return (NO_ERROR);
5805 }
5806
5807
5808 /*
5809 |       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.
5810 |
5811 | @param w                      Reference node as described
5812 | @param nodeArray              A set of node to order as described
5813 | @param activeConstraints      Array containing indeces of active constraints in the set of defined constraints
5814 | @param nLongsNeeded           Length of partition information (in BitsLong) in a node and constraint deffinition.
5815 | @param isRooted               Do constraints apply to rootet tree YES or NO
5816 |
5817 | @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
5818 */
5819 int ConstraintAllowedSet(PolyNode *w, PolyNode **nodeArray, int nodeArraySize, int *activeConstraints, int activeConstraintsSize, int nLongsNeeded, int isRooted)
5820 {
5821     int             i, j,  k, FirstEmpty;
5822     BitsLong        **constraintPartition;
5823     PolyNode        *tmp;
5824
5825     for (j=0; j<activeConstraintsSize; j++)
5826         {
5827         k=activeConstraints[j];
5828
5829         if (definedConstraintsType[k] == PARTIAL)
5830             {
5831             if ((IsPartNested(definedConstraintPruned[k], w->partition, nLongsNeeded) == YES) ||
5832                 (isRooted == NO && IsPartNested(definedConstraintTwoPruned[k], w->partition, nLongsNeeded) == YES))
5833                 continue;/* all nodes are compartable because condition of the constraint has to be sutsfied in the subtree rooted at w*/
5834
5835             FirstEmpty = IsSectionEmpty(definedConstraintPruned[k], w->partition, nLongsNeeded);
5836             if (FirstEmpty == YES &&  IsSectionEmpty(definedConstraintTwoPruned[k], w->partition, nLongsNeeded) == YES)
5837                 continue; /* all nodes are compartable becouse w does not contain any constraint taxa*/
5838
5839             assert (FirstEmpty^IsSectionEmpty(definedConstraintTwoPruned[k], w->partition, nLongsNeeded));
5840
5841             if (FirstEmpty == YES)
5842                 {/*w->partition has intersection with definedConstraintTwoPruned[k], thus remove all nodes from nodeArray that intersect with definedConstraintPruned[k]*/
5843                 constraintPartition=definedConstraintPruned;
5844                 }
5845             else
5846                 {/*w->partition has intersection with definedConstraintPruned[k], thus remove all nodes from nodeArray that intersect with definedConstraintTwoPruned[k]*/
5847                 constraintPartition=definedConstraintTwoPruned;
5848                 }
5849
5850             for (i=0;i<nodeArraySize;i++)
5851                 {
5852                 if (IsSectionEmpty(constraintPartition[k], nodeArray[i]->partition, nLongsNeeded) == NO &&
5853                     ((FirstEmpty == NO && isRooted== YES) ||  IsPartNested(constraintPartition[k], nodeArray[i]->partition, nLongsNeeded) == NO))
5854                   /*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
5855                   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.
5856                   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.*/
5857                     {
5858                     tmp = nodeArray[i];
5859                     nodeArray[i]=nodeArray[--nodeArraySize];
5860                     nodeArray[nodeArraySize]=tmp;
5861                     i--;
5862                     }
5863                 }
5864             }/*end if PARTIAL*/
5865         else
5866             {
5867             assert (definedConstraintsType[k] == NEGATIVE);
5868             if (isRooted == YES || IsBitSet(localOutGroup, definedConstraintPruned[k])==NO)
5869                 constraintPartition=definedConstraintPruned;
5870             else
5871                 constraintPartition=definedConstraintTwoPruned;
5872
5873             if (IsSectionEmpty(constraintPartition[k], w->partition, nLongsNeeded)==YES)
5874                 continue;
5875
5876             for (i=0;i<nodeArraySize;i++)
5877                 {
5878                 if (IsUnionEqThird (w->partition, nodeArray[i]->partition, constraintPartition[k], nLongsNeeded) == YES)
5879                     {
5880                     tmp = nodeArray[i];
5881                     nodeArray[i]=nodeArray[--nodeArraySize];
5882                     nodeArray[nodeArraySize]=tmp;
5883                     i--;
5884                     }
5885                 }
5886
5887             }/*end if NEGATIVE*/
5888         }
5889
5890    return nodeArraySize;
5891 }
5892
5893
5894 /*
5895 |               Check if "partition" violate any constraint.
5896 |
5897 | @param partiton               Partition to check
5898 | @param activeConstraints      Array containing indeces of active constraints in the set of defined constraints
5899 | @param nLongsNeeded           Length of partition information (in BitsLong) in a node and constraint deffinition
5900 | @param isRooted               Do constraints apply to rootet tree YES or NO
5901 |
5902 | @return                       Index of first violated constraint in activeConstraints array, -1 if no constraint is violated.
5903 */
5904 int ViolatedConstraint(BitsLong *partition, int *activeConstraints, int activeConstraintsSize, int nLongsNeeded, int isRooted)
5905 {
5906     int             j, k;
5907     BitsLong        **constraintPartition;
5908
5909     for (j=0; j<activeConstraintsSize; j++)
5910         {
5911         k=activeConstraints[j];
5912         assert (definedConstraintsType[k] != HARD);
5913
5914         if (definedConstraintsType[k] == PARTIAL)
5915             {
5916             if ((IsSectionEmpty(definedConstraintPruned[k], partition, nLongsNeeded) == NO) &&
5917                 (IsSectionEmpty(definedConstraintTwoPruned[k], partition, nLongsNeeded) == NO) &&
5918                 (IsPartNested(definedConstraintPruned[k], partition, nLongsNeeded) == NO) &&
5919                 !(isRooted == NO && IsPartNested(definedConstraintTwoPruned[k], partition, nLongsNeeded) == YES))
5920                 return j;
5921             }/*end if PARTIAL*/
5922         else
5923             {
5924             assert (definedConstraintsType[k] == NEGATIVE);
5925             if (isRooted == YES || IsBitSet(localOutGroup, definedConstraintPruned[k])==NO)
5926                 constraintPartition=definedConstraintPruned;
5927             else
5928                 constraintPartition=definedConstraintTwoPruned;
5929
5930             if (IsUnionEqThird (partition, partition, constraintPartition[k], nLongsNeeded) == YES)
5931                 return j;
5932             }/*end if NEGATIVE*/
5933         }
5934
5935    return -1;
5936 }
5937
5938
5939 /*
5940 |         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
5941 |
5942 | @param activeConstraints      Array containing indeces of active constraints in the set of defined constraints
5943 | @param nLongsNeeded           Length of partition information (in BitsLong) in a node and constraint deffinition.
5944 | @param isRooted               Do constraints apply to rootet tree YES or NO
5945 |
5946 | @return                       Size of pruned "activeConstraints" array
5947 */
5948 int PruneActiveConstraints (PolyNode *w, int *activeConstraints, int activeConstraintsSize, int nLongsNeeded, int isRooted)
5949 {
5950     int             j,  k;
5951     BitsLong        **constraintPartition;
5952     //PolyNode        *tmp;
5953
5954     for (j=0; j<activeConstraintsSize; j++)
5955         {
5956         k=activeConstraints[j];
5957
5958         if (definedConstraintsType[k] == PARTIAL)
5959             {
5960             if ((IsPartNested(definedConstraintPruned[k], w->partition, nLongsNeeded) == YES && IsSectionEmpty(definedConstraintTwoPruned[k], w->partition, nLongsNeeded)) ||
5961                (isRooted == NO && IsPartNested(definedConstraintTwoPruned[k], w->partition, nLongsNeeded) == YES && IsSectionEmpty(definedConstraintPruned[k], w->partition, nLongsNeeded)))
5962                 {
5963                 //tmp = activeConstraints[j];
5964                 activeConstraints[j]=activeConstraints[--activeConstraintsSize];
5965                 //activeConstraints[activeConstraintsSize]=tmp;
5966                 j--;
5967                 }
5968             }/*end if PARTIAL*/
5969         else
5970             {
5971             assert (definedConstraintsType[k] == NEGATIVE);
5972             if (isRooted == YES || IsBitSet(localOutGroup, definedConstraintPruned[k])==NO)
5973                 constraintPartition=definedConstraintPruned;
5974             else
5975                 constraintPartition=definedConstraintTwoPruned;
5976
5977             if (IsPartNested(constraintPartition[k], w->partition, nLongsNeeded)==NO && IsSectionEmpty(constraintPartition[k], w->partition, nLongsNeeded)==NO)
5978                 {
5979                 //tmp = activeConstraints[j];
5980                 activeConstraints[j]=activeConstraints[--activeConstraintsSize];
5981                 //activeConstraints[activeConstraintsSize]=tmp;
5982                 j--;
5983                 }
5984             }/*end if NEGATIVE*/
5985         }
5986
5987    return activeConstraintsSize;
5988 }
5989
5990
5991 /*--------------------------------------------------------------------
5992 |
5993 |           RandResolve: Randomly resolve a polytomous tree
5994 |
5995 | @param    tt is a tree which contains information about applicable constraints. If it is set to NULL then no constraints will be used.
5996 |           If t!=NULL then partitions of nodes of polytree should be allocated for example by AllocatePolyTreePartitions (t);
5997 | @return   NO_ERROR on succes, ABORT if could not resolve a tree without vialating some consraint, ERROR if any other error occur
5998 ---------------------------------------------------------------------*/
5999 int RandResolve (Tree *tt, PolyTree *t, RandLong *seed, int destinationIsRooted)
6000 {
6001     int         i, j, k, nextNode, stopNode, rand1, rand2, nTaxa, nLongsNeeded, tmp;
6002     PolyNode    *p=NULL, *q, *r, *u, *w1, *w2;
6003     int         nodeArrayAllowedSize, nodeArraySize, activeConstraintsSize;
6004     PolyNode    **nodeArray;
6005     int         *activeConstraints;
6006
6007     assert (tt==NULL || t->bitsets!=NULL); /* partition fields of t nodes need to be allocated if constraints are used*/
6008     nTaxa = t->nNodes - t->nIntNodes;     /* different from numLocalTaxa potentially if a species tree */
6009     assert (nTaxa <= t->memNodes/2); /* allocated tree has to be big enough*/
6010     nLongsNeeded = (nTaxa - 1) / nBitsInALong + 1; /* allocated lenght of partitions is t->memNodes/2 bits but only first nTaxa bits are used */
6011
6012     nodeArray = t->allDownPass; /*temporary use t->allDownPass for different purpose. It get properly reset at the end. */
6013     activeConstraints = tempActiveConstraints;
6014     activeConstraintsSize = 0;
6015
6016     /* collect constraints to consider if applicable*/
6017     if (tt!=NULL && tt->constraints!=NULL)
6018         {
6019         for (k=0; k<numDefinedConstraints; k++)
6020             {
6021             if (tt->constraints[k] == YES && definedConstraintsType[k] != HARD)
6022                 activeConstraints[activeConstraintsSize++]=k;
6023             }
6024         }
6025
6026     /* count immediate descendants */
6027     GetPolyDownPass(t);
6028     for (i=0; i<t->nIntNodes; i++)
6029         {
6030         p = t->intDownPass[i];
6031         tmp=ViolatedConstraint(p->partition, activeConstraints, activeConstraintsSize, nLongsNeeded, t->isRooted);
6032         if (tmp != -1)
6033             {
6034             assert (p->isLocked == YES);
6035             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]]);
6036             return (ERROR);
6037             }
6038         activeConstraintsSize = PruneActiveConstraints (p, activeConstraints, activeConstraintsSize, nLongsNeeded, t->isRooted);
6039         j = 0;
6040         for (q=p->left; q!=NULL; q=q->sib)
6041             j++;
6042         p->x = j;
6043         }
6044
6045     /* add one node at a time */
6046     if (destinationIsRooted == NO)
6047         stopNode = 2*nTaxa - 2;
6048     else
6049         stopNode = 2*nTaxa - 1;
6050     for (nextNode=t->nNodes; nextNode < stopNode; nextNode++)
6051         {
6052         /* find a polytomy to break */
6053         for (i=0; i<t->nIntNodes; i++)
6054             {
6055             p = t->intDownPass[i];
6056             if (destinationIsRooted == YES && p->x > 2)
6057                 break;
6058             if (destinationIsRooted == NO && ((p->anc != NULL && p->x > 2) || (p->anc == NULL && p->x > 3)))
6059                 break;
6060             }
6061
6062         /* if we can't find one, there's an error */
6063         if (i == t->nIntNodes)
6064             {
6065             return  ERROR;
6066             }
6067
6068         nodeArraySize=0;
6069         /*Collect initial list of candidate nodes to join*/
6070         for (q = p->left; q!= NULL; q = q->sib)
6071             {
6072             nodeArray[nodeArraySize++]=q;
6073             }
6074         assert (nodeArraySize==p->x);
6075
6076         /* identify two descendants randomly */
6077         /* make sure we do not select outgroup if it is an unrooted tree */
6078         if (p->anc == NULL && destinationIsRooted == NO)
6079             nodeArraySize--;
6080
6081         do
6082             {
6083             /* Pick first node */
6084             rand1 = (int) (RandomNumber(seed) * nodeArraySize);
6085             w1 = nodeArray[rand1];
6086             nodeArray[rand1] = nodeArray[--nodeArraySize];
6087
6088             if (nodeArraySize==0)
6089                 return ABORT; /* Potentaily here we could instead revert by removing last added node and try again. */
6090
6091             /* Move all nodes in nodeArray which can be paired with w to the begining of array */
6092             nodeArrayAllowedSize=ConstraintAllowedSet(w1, nodeArray, nodeArraySize, activeConstraints, activeConstraintsSize, nLongsNeeded, t->isRooted);
6093             /* TODO optimization for Maxim (if not Maxim remove it if you still see it): if nodeArrayAllowedSize==0 then set w1->y */
6094             } while (nodeArrayAllowedSize == 0);
6095
6096         rand2 = (int) (RandomNumber(seed) *nodeArrayAllowedSize);
6097         w2 = nodeArray[rand2];
6098
6099         /* create a new node */
6100         u = &t->nodes[nextNode];
6101         u->anc = p;
6102         u->x = 2;
6103         p->x--;
6104
6105         if (tt != NULL) {
6106             for (j=0; j<nLongsNeeded; j++)
6107                 u->partition[j] = w1->partition[j] | w2->partition[j] ;
6108             activeConstraintsSize = PruneActiveConstraints (u, activeConstraints, activeConstraintsSize, nLongsNeeded, t->isRooted);
6109         }
6110
6111         u->left = w1;
6112         t->nNodes++;
6113         t->nIntNodes++;
6114
6115         /* connect tree together */
6116         r = u;
6117         for (q = p->left; q!= NULL; q = q->sib)
6118             {
6119             if (q != w1 && q != w2)
6120                 {
6121                 r->sib=q;
6122                 r = q;
6123                 }
6124             }
6125         r->sib = NULL;
6126         w1->sib = w2;
6127         w2->sib = NULL;
6128         w1->anc = u;
6129         w2->anc = u;
6130         p->left = u;
6131
6132         /* update tree */
6133         GetPolyDownPass (t);
6134         }
6135
6136     /* relabel interior nodes (important that last indices are at the bottom!) */
6137     for (i=0; i<t->nIntNodes; i++)
6138         {
6139         p = t->intDownPass[i];
6140         p->index = nTaxa + i;
6141         }
6142     return NO_ERROR;
6143 }
6144
6145
6146 /* ResetTreeNode: Reset tree node except for memory index */
6147 void ResetTreeNode (TreeNode *p)
6148 {
6149     /* do not change memoryIndex; that is set once and for all when tree is allocated */
6150     p->index                  = 0;
6151     p->scalerNode             = NO;
6152     p->upDateCl               = NO;
6153     p->upDateTi               = NO;
6154     p->marked                 = NO;
6155     p->length                 = 0.0;
6156     p->nodeDepth              = 0.0;
6157     p->x                      = 0;
6158     p->y                      = 0;
6159     p->index                  = 0;
6160     p->isDated                = NO;
6161     p->calibration            = NULL;
6162     p->age                    = -1.0;
6163     p->isLocked               = NO;
6164     p->lockID                 = -1;
6165     p->label                  = noLabel;
6166     p->d                      = 0.0;
6167     p->partition              = NULL;
6168 }
6169
6170
6171 /* ResetPolyNode: Reset all values of one node in a polytree */
6172 void ResetPolyNode (PolyNode *p)
6173 {
6174     /* we reset everything here except memoryIndex, which should be immutable */
6175     p->length = 0.0;
6176     p->depth = 0.0;
6177     p->age = 0.0;
6178     p->anc = p->left = p->sib = NULL;
6179     p->calibration = NULL;
6180     p->f = 0.0;
6181     p->index = 0;
6182     p->isDated = NO;
6183     p->isLocked = NO;
6184     strcpy (p->label,"");
6185     p->lockID = 0;
6186     p->partition = NULL;
6187     p->partitionIndex = 0;
6188     p->support = 0.0;
6189     p->x = p->y = 0;
6190 }
6191
6192
6193 /* ResetPolyTree: Reset polytomous tree to pristine state but keep relevant memory. */
6194 void ResetPolyTree (PolyTree *pt)
6195 {
6196     int     i, maxTaxa, nLongsNeeded;
6197
6198     /* clear nodes */
6199     for (i=0; i<pt->memNodes; i++)
6200         ResetPolyNode (&pt->nodes[i]);
6201
6202     /* empty node arrays and tree properties but keep space */
6203     for (i=0; i<pt->nNodes; i++)
6204         pt->allDownPass[i] = NULL;
6205     for (i=0; i<pt->nIntNodes; i++)
6206         pt->intDownPass[i] = NULL;
6207     pt->nNodes = 0;
6208     pt->nIntNodes = 0;
6209     pt->root = NULL;
6210     pt->brlensDef = NO;
6211     pt->isRooted = NO;
6212     pt->isClock = NO;
6213     pt->isRelaxed = NO;
6214     pt->clockRate = 0.0;
6215
6216     /* empty bitsets but keep space and pointers */
6217     if (pt->bitsets)
6218         {
6219         maxTaxa = pt->memNodes / 2;
6220         nLongsNeeded = (maxTaxa - 1) / nBitsInALong + 1;
6221         for (i=0; i<pt->memNodes*nLongsNeeded; i++)
6222             pt->bitsets[i] = 0;
6223         for (i=0; i<pt->memNodes; i++)
6224             pt->nodes[i].partition = pt->bitsets + i*nLongsNeeded;
6225         }
6226
6227     /* empty relaxed clock parameters */
6228     FreePolyTreeRelClockParams (pt);
6229
6230     /* empty population size set parameters */
6231     FreePolyTreePopSizeParams (pt);
6232 }
6233
6234
6235 /* ResetPolyTreePartitions: Reset and set bit patterns describing partitions */
6236 void ResetPolyTreePartitions (PolyTree *pt)
6237 {
6238     int         i, j, numTaxa, nLongsNeeded;
6239     PolyNode    *pp;
6240
6241     /* get some handy numbers */
6242     numTaxa = pt->memNodes/2;
6243     nLongsNeeded = (numTaxa - 1) / nBitsInALong + 1;
6244
6245     /* reset bits describing partitions */
6246     for (i=0; i<pt->memNodes*nLongsNeeded; i++)
6247         {
6248         pt->bitsets[i] = 0;
6249         }
6250
6251     /* set bits describing partitions */
6252     for (i=0; i<pt->nNodes; i++)
6253         {
6254         assert (pt->allDownPass != NULL && pt->allDownPass[i] != NULL);
6255         assert (pt->allDownPass[i]->partition != NULL);
6256
6257         pp = pt->allDownPass[i];
6258         if (pp->left == NULL)
6259             {
6260             SetBit (pp->index, pp->partition);
6261             }
6262         if (pp->anc != NULL)
6263             {
6264             for (j=0; j<nLongsNeeded; j++)
6265                 pp->anc->partition[j] |= pp->partition[j];
6266             }
6267         }
6268 }
6269
6270
6271 /*----------------------------------------------
6272 |
6273 |   ResetRootHeight: Reset node heights in a clock
6274 |      tree to fit a new root height. Assumes
6275 |      node depths and lengths set correctly.
6276 |
6277 -----------------------------------------------*/
6278 int ResetRootHeight (Tree *t, MrBFlt rootHeight)
6279 {
6280     int         i;
6281     TreeNode    *p;
6282     MrBFlt      factor, x, y;
6283
6284     if (t->isClock == NO)
6285         return ERROR;
6286
6287     /* make sure node depths are set */
6288     for (i=0; i<t->nNodes-1; i++)
6289         {
6290         p = t->allDownPass[i];
6291         if (p->left == NULL)
6292             p->nodeDepth = 0.0;
6293         else
6294             {
6295             x = p->left->nodeDepth + p->left->length;
6296             y = p->right->nodeDepth + p->right->length;
6297             if (x > y)
6298                 p->nodeDepth = x;
6299             else
6300                 p->nodeDepth = y;
6301             }
6302         }
6303     for (i=t->nNodes-3; i>=0; i--)
6304         {
6305         p = t->allDownPass[i];
6306         p->nodeDepth = p->anc->nodeDepth - p->length;
6307         }
6308
6309     /* now reset node depths and branch lengths */
6310     factor = rootHeight / t->root->left->nodeDepth;
6311     t->root->left->nodeDepth = rootHeight;
6312     for (i=t->nNodes-2; i>=0; i--)
6313         {
6314         p = t->allDownPass[i];
6315         p->nodeDepth *= factor;
6316         p->length *= factor;
6317         }
6318
6319     return NO_ERROR;
6320 }
6321
6322
6323 /*----------------------------------------------
6324 |
6325 |   ResetTipIndices: reset tip indices to be from
6326 |      0 to number of included taxa, in same order
6327 |      as in the original taxon set.
6328 |
6329 -----------------------------------------------*/
6330 void ResetTipIndices(PolyTree *pt)
6331 {
6332     int         i, j, k, m;
6333     PolyNode    *p = NULL;
6334
6335     for (i=j=0; i<numTaxa; i++)
6336         {
6337         for (k=0; k<pt->nNodes; k++)
6338             {
6339             p = pt->allDownPass[k];
6340             if (StrCmpCaseInsensitive(p->label,taxaNames[i]) == 0)
6341                 break;
6342             }
6343         if (k < pt->nNodes)
6344             {
6345             assert (p->left == NULL);
6346             if (p->index!=j) {
6347                 SwapRelaxedBranchInfo (p->index, j, pt);
6348                 for (m=0; m<pt->nNodes; m++)
6349                     {
6350                     if (pt->allDownPass[m]->index==j)
6351                         {
6352                         pt->allDownPass[m]->index=p->index;
6353                         break;
6354                         }
6355                     }
6356                 p->index = j;
6357                 }
6358             j++;
6359             }
6360         }
6361 }
6362
6363
6364 /*----------------------------------------------
6365 |
6366 |   ResetTopology: rebuild the tree t to fit the
6367 |      Newick string s. Everyting except topology
6368 |      is left in the same state in t.
6369 |
6370 -----------------------------------------------*/
6371 int ResetTopology (Tree *t, char *s)
6372 {
6373     TreeNode    *p, *q;
6374     int         i, j, k, inLength;
6375     char        temp[30];
6376
6377     /* set all pointers to NULL */
6378     for (i=0; i<t->memNodes; i++)
6379         {
6380         p = &t->nodes[i];
6381         p->anc = p->right = p->left = NULL;
6382         p->index = -1;
6383         }
6384     p = &t->nodes[0];
6385
6386     /* start out assuming that the tree is rooted; we will detect below if it is not */
6387     t->isRooted = YES;
6388     inLength = NO;
6389     for (i=0, j=1; *s!='\0'; s++)
6390         {
6391         if (*s == ',' || *s == ')' || *s == ':')
6392             {
6393             if (p->right == NULL && inLength == NO)
6394                 {
6395                 temp[i] = '\0';
6396                 k = atoi (temp);
6397                 p->index = k-1;
6398                 i = 0;
6399                 }
6400             else
6401                 inLength = NO;
6402             }
6403         if (*s == '(')
6404             {
6405             q = p;
6406             p = &t->nodes[j++];
6407             q->left = p;
6408             p->anc = q;
6409             }
6410         else if (*s == ',')
6411             {
6412             if (p->anc->right == NULL)
6413                 {
6414                 q = p->anc;
6415                 p = &t->nodes[j++];
6416                 p->anc = q;
6417                 q->right = p;
6418                 }
6419             else /* if p->anc->right == p (near 'root' of unrooted trees) */
6420                 {
6421                 q = p->anc;
6422                 p = &t->nodes[j++];
6423                 q->anc = p;
6424                 p->left = q;
6425                 t->isRooted = NO;
6426                 }
6427             }
6428         else if (*s == ')')
6429             {
6430             p = p->anc;
6431             }
6432         else if (*s == ':')
6433             {
6434             inLength = YES;
6435             }
6436         else if (inLength == NO)
6437             {
6438             temp[i++] = *s;
6439             }
6440         }
6441
6442     /* attach root to rooted tree */
6443     if (t->isRooted == YES)
6444         {
6445         p = &t->nodes[0];
6446         q = &t->nodes[j++];
6447         q->left = p;
6448         p->anc = q;
6449         }
6450
6451     /* relabel interior nodes, find number of nodes and root */
6452     t->nNodes = j;
6453     t->nIntNodes = t->nNodes/2 - 1;
6454
6455     if (t->isRooted == NO)
6456         j = t->nNodes - t->nIntNodes;
6457     else
6458         j = t->nNodes - t->nIntNodes - 1;
6459
6460     for (i=0; i<t->nNodes; i++)
6461         {
6462         p = &t->nodes[i];
6463         if (p->index == -1)
6464             p->index = j++;
6465         if (p->anc == NULL)
6466             t->root = p;
6467         }
6468
6469     GetDownPass (t);
6470
6471     return NO_ERROR;
6472 }
6473
6474
6475 /*-----------------------------------------------------------------
6476 |
6477 |   ResetBrlensFromTree: copies brlens and depths from second tree (vTree) to
6478 |       first tree (used to initialize brlen sets for same topology)
6479 |
6480 -----------------------------------------------------------------*/
6481 int ResetBrlensFromTree (Tree *tree, Tree *vTree)
6482 {
6483     int         i, j, k, nLongsNeeded, numTips;
6484     MrBFlt      d1, d2;
6485     TreeNode    *p, *q;
6486
6487     if (tree->isRooted != vTree->isRooted)
6488         return (ERROR);
6489
6490     if (AreTopologiesSame (tree, vTree) == NO)
6491         return (ERROR);
6492
6493     /* allocate and set up partitions */
6494     AllocateTreePartitions (vTree);
6495     AllocateTreePartitions (tree);
6496     numTips = tree->nNodes - tree->nIntNodes - (tree->isRooted == YES ? 1 : 0);
6497     nLongsNeeded = (int) ((numTips - 1) / nBitsInALong) + 1;
6498
6499     /*copy lengths and nodeDepthes*/
6500     for (i=0; i<vTree->nNodes; i++)
6501         {
6502         p  = vTree->allDownPass[i];
6503         for (j=0; j<tree->nNodes; j++)
6504             {
6505             q  = tree->allDownPass[j];
6506             for (k=0; k<nLongsNeeded; k++)
6507                 if (p->partition[k] != q->partition[k])
6508                     break;
6509             if (k==nLongsNeeded)
6510                 {
6511                 q->length = p->length;
6512                 if (tree->isRooted == YES)
6513                     q->nodeDepth = p->nodeDepth;
6514                 }
6515             }
6516         }
6517
6518     if (tree->isRooted == YES)
6519         {
6520         /*Next compute height for the root. */
6521         for (i=0; i<tree->nNodes-1; i++)
6522             {
6523             p  = tree->allDownPass[i];
6524             if (p->left == NULL)
6525                 p->nodeDepth = 0.0;
6526             else
6527                 {
6528                 d1 = p->left->nodeDepth + p->left->length;
6529                 d2 = p->right->nodeDepth + p->right->length;
6530                 if (d1 > d2)
6531                     p->nodeDepth = d1;
6532                 else
6533                     p->nodeDepth = d2;
6534                 }
6535             }
6536         for (i=tree->nNodes-3; i>=0; i--)
6537             {
6538             p = tree->allDownPass[i];
6539             if (p->left==NULL && p->calibration==NULL)
6540                 continue;    /* leave at 0.0 */
6541             p->nodeDepth = p->anc->nodeDepth - p->length;
6542             }
6543         }
6544
6545     FreeTreePartitions(tree);
6546     FreeTreePartitions(vTree);
6547
6548     return (NO_ERROR);
6549 }
6550
6551
6552 /* ResetIntNodeIndices: Set int node indices in downpass order from numTaxa to 2*numTaxa-2 */
6553 void ResetIntNodeIndices (PolyTree *t)
6554 {
6555     int i, m, index;
6556
6557     index = t->nNodes - t->nIntNodes;
6558
6559     for (i=0; i<t->nIntNodes; i++)
6560         {
6561         if (t->intDownPass[i]->index != index)
6562             {
6563             SwapRelaxedBranchInfo (t->intDownPass[i]->index, index, t);
6564             for (m=0; m<t->nIntNodes; m++)
6565                 {
6566                 if (t->intDownPass[m]->index==index)
6567                     {
6568                     t->intDownPass[m]->index=t->intDownPass[i]->index;
6569                     break;
6570                     }
6571                 }
6572             t->intDownPass[i]->index = index;
6573             }
6574         index++;
6575         }
6576 }
6577
6578
6579 /* ResetTopologyFromTree: use top to set topology in tree */
6580 int ResetTopologyFromTree (Tree *tree, Tree *top)
6581 {
6582     int         i, j, k;
6583     TreeNode    *p, *q, *r, *p1;
6584
6585     /* adopt rooting */
6586     tree->isRooted = top->isRooted;
6587     tree->nNodes = top->nNodes;
6588     tree->nIntNodes = top->nIntNodes;
6589
6590     /* set all pointers to NULL */
6591     for (i=0; i<tree->nNodes; i++)
6592         {
6593         p = &tree->nodes[i];
6594         p->anc = p->right = p->left = NULL;
6595         }
6596
6597     /* now copy topology */
6598     for (i=0; i<top->nIntNodes; i++)
6599         {
6600         p1 = top->intDownPass[i];
6601
6602         k = p1->index;
6603         for (j=0; j<tree->nNodes; j++)
6604             if (tree->nodes[j].index == k)
6605                 break;
6606         p = &tree->nodes[j];
6607
6608         k = p1->left->index;
6609         for (j=0; j<tree->nNodes; j++)
6610             if (tree->nodes[j].index == k)
6611                 break;
6612         q = &tree->nodes[j];
6613
6614         k = p1->right->index;
6615         for (j=0; j<tree->nNodes; j++)
6616             if (tree->nodes[j].index == k)
6617                 break;
6618         r = &tree->nodes[j];
6619
6620         p->left = q;
6621         p->right= r;
6622         q->anc = r->anc = p;
6623         }
6624
6625     /* arrange the root */
6626     k = top->root->index;
6627     for (j=0; j<tree->nNodes; j++)
6628         if (tree->nodes[j].index == k)
6629             break;
6630     p = &tree->nodes[j];
6631
6632     k = top->root->left->index;
6633     for (j=0; j<tree->nNodes; j++)
6634         if (tree->nodes[j].index == k)
6635             break;
6636     q = &tree->nodes[j];
6637     p->left = q;
6638     q->anc = p;
6639     p->right = p->anc = NULL;
6640     tree->root = p;
6641
6642     GetDownPass (tree);
6643
6644     return (NO_ERROR);
6645 }
6646
6647
6648 /* ResetTopologyFromPolyTree: use polytree top to set topology in tree */
6649 int ResetTopologyFromPolyTree (Tree *tree, PolyTree *top)
6650 {
6651     int         i, j, k;
6652     TreeNode    *p, *q, *r;
6653     PolyNode    *p1;
6654
6655     if (tree->isRooted != top->isRooted)
6656         return (ERROR);
6657
6658     /* set all pointers to NULL */
6659     for (i=0; i<tree->nNodes; i++)
6660         {
6661         p = &tree->nodes[i];
6662         p->anc = p->right = p->left = NULL;
6663         }
6664
6665     /* now copy topology */
6666     for (i=0; i<top->nIntNodes; i++)
6667         {
6668         p1 = top->intDownPass[i];
6669
6670         k = p1->index;
6671         for (j=0; j<tree->nNodes; j++)
6672             if (tree->nodes[j].index == k)
6673                 break;
6674         p = &tree->nodes[j];
6675
6676         k = p1->left->index;
6677         for (j=0; j<tree->nNodes; j++)
6678             if (tree->nodes[j].index == k)
6679                 break;
6680         q = &tree->nodes[j];
6681
6682         k = p1->left->sib->index;
6683         for (j=0; j<tree->nNodes; j++)
6684             if (tree->nodes[j].index == k)
6685                 break;
6686         r = &tree->nodes[j];
6687
6688         p->left = q;
6689         p->right= r;
6690         q->anc = r->anc = p;
6691         }
6692
6693     /* arrange the root */
6694     if (top->isRooted == YES)
6695         {
6696         k = top->root->index;
6697         for (j=0; j<tree->nNodes; j++)
6698             if (tree->nodes[j].index == k)
6699                 break;
6700         p = &tree->nodes[j];
6701
6702         k = top->nNodes;
6703         for (j=0; j<tree->nNodes; j++)
6704             if (tree->nodes[j].index == k)
6705                 break;
6706         q = &tree->nodes[j];
6707
6708         q->left = p;
6709         q->anc = NULL;
6710         q->right = NULL;
6711         tree->root = q;
6712         }
6713     else /* if (top->isRooted == NO) */
6714     {
6715         k = top->root->index;
6716         for (j=0; j<tree->nNodes; j++)
6717             if (tree->nodes[j].index == k)
6718                 break;
6719         p = &tree->nodes[j];
6720
6721         k = localOutGroup;
6722         for (p1=top->root->left; p1!=NULL; p1=p1->sib)
6723             if (p1->index == k)
6724                 break;
6725
6726         assert (p1 != NULL);
6727         if (p1 == NULL)
6728             return (ERROR);
6729
6730         q = &tree->nodes[p1->index];
6731         k = p1->anc->left->sib->sib->index;     /* index of missing child */
6732         if (p->left == q)
6733             p->left = &tree->nodes[k];
6734         else if (p->right == q)
6735             p->right = &tree->nodes[k];
6736
6737         q->anc = q->right = NULL;
6738         p->anc = q;
6739         q->left = p;
6740     }
6741
6742     GetDownPass (tree);
6743
6744     return (NO_ERROR);
6745 }
6746
6747
6748 /* ResetTreePartitions: Reset bitsets describing tree partitions */
6749 void ResetTreePartitions (Tree *t)
6750 {
6751     int         i, j, numTaxa, nLongsNeeded;
6752     TreeNode    *p;
6753
6754     /* get some handy numbers */
6755     numTaxa = t->nNodes - t->nIntNodes - (t->isRooted == YES ? 1 : 0);
6756     nLongsNeeded = (numTaxa - 1) / nBitsInALong + 1;
6757
6758     /* reset bits describing partitions */
6759     for (i=0; i<t->nNodes; i++)
6760         {
6761         assert (t->allDownPass != NULL && t->allDownPass[i] != NULL);
6762         assert (t->allDownPass[i]->partition != NULL);
6763
6764         p = t->allDownPass[i];
6765         for (j=0; j<nLongsNeeded; j++)
6766             p->partition[j] = 0;
6767         }
6768
6769     /* set bits describing partitions */
6770     for (i=0; i<t->nNodes; i++)
6771         {
6772         p = t->allDownPass[i];
6773         if (p->left == NULL || (p->anc == NULL && t->isRooted == NO))
6774             SetBit (p->index, p->partition);
6775         else if (p->anc != NULL)
6776             {
6777             for (j=0; j<nLongsNeeded; j++)
6778                 p->partition[j] = p->left->partition[j] | p->right->partition[j];
6779             }
6780         }
6781 }
6782
6783
6784 /*-------------------------------------------------------
6785 |
6786 |   RetrieveRTopology: This routine will rebuild a rooted
6787 |      tree from the order array created by StoreRTopology.
6788 |      All tree information except the structure will
6789 |      remain unaltered.
6790 |
6791 --------------------------------------------------------*/
6792 int RetrieveRTopology (Tree *t, int *order)
6793 {
6794     int         i, numTaxa;
6795     TreeNode    *p, *q, *r;
6796
6797     numTaxa = t->nNodes - t->nIntNodes - 1;
6798
6799     /* sort the tips in the t->allDownPass array */
6800     p = t->nodes;
6801     for (i=0; i<t->nNodes; i++, p++)
6802         t->allDownPass[p->index] = p;
6803
6804     /* make sure the root has index 2*numTaxa-1 */
6805     q = t->allDownPass[t->nNodes-1];
6806     q->anc = q->right = NULL;
6807     t->root = q;
6808
6809     /* connect the first two tips */
6810     p = t->allDownPass[numTaxa];
6811     p->anc = q;
6812     q->left = p;
6813     p->length = 0.0;
6814     q = t->allDownPass[0];
6815     r = t->allDownPass[1];
6816     p->left = q;
6817     p->right = r;
6818     q->anc = r->anc = p;
6819
6820     /* add one tip at a time */
6821     for (i=2; i<numTaxa; i++)
6822         {
6823         p = t->allDownPass[i];
6824         q = t->allDownPass[numTaxa-1+i];
6825         r = t->allDownPass[*(order++)];
6826         p->anc = q;
6827         q->left = p;
6828         q->right = r;
6829         q->anc = r->anc;
6830         if (r->anc->left == r)
6831             r->anc->left = q;
6832         else
6833             r->anc->right = q;
6834         r->anc = q;
6835         }
6836
6837     /* get downpass */
6838     GetDownPass (t);
6839
6840     /* relabel interior nodes (root is correctly labeled already) */
6841     for (i=0; i<t->nIntNodes; i++)
6842         t->intDownPass[i]->index = i+numTaxa;
6843
6844     return (NO_ERROR);
6845 }
6846
6847
6848 /*-------------------------------------------------------
6849 |
6850 |   RetrieveRTree: This routine will rebuild a rooted
6851 |      tree from the arrays created by StoreRTree.
6852 |      All tree information except the structure and
6853 |      branch lengths will remain unaltered.
6854 |
6855 --------------------------------------------------------*/
6856 int RetrieveRTree (Tree *t, int *order, MrBFlt *brlens)
6857 {
6858     int         i, numTaxa;
6859     TreeNode    *p, *q, *r;
6860
6861     numTaxa = t->nNodes - t->nIntNodes - 1;
6862
6863     /* sort the tips in the t->allDownPass array */
6864     p = t->nodes;
6865     for (i=0; i<t->nNodes; i++, p++)
6866         t->allDownPass[p->index] = p;
6867
6868     /* make sure that root has index 2*numTaxa-1 */
6869     q = t->allDownPass[t->nNodes-1];
6870     q->anc = q->right = NULL;
6871     q->length = 0.0;
6872     t->root = q;
6873
6874     /* connect the first three tips */
6875     p = t->allDownPass[numTaxa];
6876     p->anc = q;
6877     q->left = p;
6878     p->length = 0.0;
6879     q = t->allDownPass[0];
6880     r = t->allDownPass[1];
6881     p->left = q;
6882     p->right = r;
6883     q->anc = r->anc = p;
6884     q->length = *(brlens++);
6885     r->length = *(brlens++);
6886
6887     /* add one tip at a time */
6888     for (i=2; i<numTaxa; i++)
6889         {
6890         p = t->allDownPass[i];
6891         q = t->allDownPass[numTaxa-1+i];
6892         r = t->allDownPass[*(order++)];
6893         p->anc = q;
6894         q->left = p;
6895         q->right = r;
6896         q->anc = r->anc;
6897         if (r->anc->left == r)
6898             r->anc->left = q;
6899         else
6900             r->anc->right = q;
6901         r->anc = q;
6902         if (q->anc->anc != NULL)
6903             q->length = *(brlens++);
6904         else
6905             {
6906             r->length = *(brlens++);
6907             q->length = 0.0;
6908             }
6909         p->length = *(brlens++);
6910         }
6911
6912     /* get downpass */
6913     GetDownPass (t);
6914
6915     /* relabel interior nodes (root is correctly labeled already) */
6916     for (i=0; i<t->nIntNodes; i++)
6917         t->intDownPass[i]->index = i+numTaxa;
6918
6919     /* set the node depths */
6920     SetNodeDepths (t);
6921
6922     return (NO_ERROR);
6923 }
6924
6925
6926 /*-------------------------------------------------------
6927 |
6928 |   RetrieveRTreeWithIndices: This routine will rebuild a rooted
6929 |      tree from the arrays created by StoreRTreeWithIndices.
6930 |      All tree information except the structure, branch lengths
6931 |      and node indices will remain unaltered.
6932 |
6933 --------------------------------------------------------*/
6934 int RetrieveRTreeWithIndices (Tree *t, int *order, MrBFlt *brlens)
6935 {
6936     int         i, numTaxa;
6937     TreeNode    *p, *q, *r;
6938
6939     extern void ShowNodes (TreeNode *, int, int);
6940
6941     numTaxa = t->nNodes - t->nIntNodes - 1;
6942
6943     /* sort the tips in the t->allDownPass array */
6944     p = t->nodes;
6945     for (i=0; i<t->nNodes; i++, p++)
6946         t->allDownPass[p->index] = p;
6947
6948     /* make sure that root has index 2*numTaxa-1 */
6949     q = t->allDownPass[t->nNodes-1];
6950     q->anc = q->right = NULL;
6951     q->length = 0.0;
6952     t->root = q;
6953
6954     /* connect the first three 'tips' with interior node, index from order array */
6955     p = t->allDownPass[numTaxa];
6956     p->x = *(order++);
6957     p->anc = q;
6958     q->left = p;
6959     p->length = 0.0;
6960     q = t->allDownPass[0];
6961     r = t->allDownPass[1];
6962     p->left = q;
6963     p->right = r;
6964     q->anc = r->anc = p;
6965     q->length = *(brlens++);
6966     r->length = *(brlens++);
6967
6968     /* add one tip at a time */
6969     for (i=2; i<numTaxa; i++)
6970         {
6971         p = t->allDownPass[i];
6972         assert (*order >= numTaxa && *order < 2*numTaxa - 1);
6973         q = t->allDownPass[numTaxa-1+i];
6974         q->x = *(order++);
6975         r = t->allDownPass[*(order++)];
6976         p->anc = q;
6977         q->left = p;
6978         q->right = r;
6979         q->anc = r->anc;
6980         if (r->anc->left == r)
6981             r->anc->left = q;
6982         else
6983             r->anc->right = q;
6984         r->anc = q;
6985         if (q->anc->anc != NULL)
6986             q->length = *(brlens++);
6987         else
6988             {
6989             r->length = *(brlens++);
6990             q->length = 0.0;
6991             }
6992         p->length = *(brlens++);
6993         }
6994
6995     /* get downpass */
6996     GetDownPass (t);
6997
6998     /* relabel interior nodes using labels in scratch variable x */
6999     for (i=0; i<t->nIntNodes; i++)
7000         {
7001         p = t->intDownPass[i];
7002         p->index = p->x;
7003         }
7004
7005     /* set the node depths */
7006     SetNodeDepths (t);
7007
7008     return (NO_ERROR);
7009 }
7010
7011
7012 /*-------------------------------------------------------
7013 |
7014 |   RetrieveUTopology: This routine will rebuild an unrooted
7015 |      tree from the order array created by StoreUTopology.
7016 |      All tree information except the structure
7017 |      will remain unaltered.
7018 |
7019 --------------------------------------------------------*/
7020 int RetrieveUTopology (Tree *t, int *order)
7021 {
7022     int         i, numTips;
7023     TreeNode    *p, *q, *r;
7024
7025     /* preliminaries */
7026     numTips = t->nNodes - t->nIntNodes;
7027     for (i=0; i<t->nNodes; i++)
7028         t->nodes[i].left = t->nodes[i].right = t->nodes[i].anc = NULL;
7029
7030     /* sort the tips in the t->allDownPass array */
7031     p = t->nodes;
7032     for (i=0; i<t->nNodes; i++, p++)
7033         t->allDownPass[p->index] = p;
7034
7035     /* make sure root has index 0 */
7036     q = t->allDownPass[0];
7037     q->anc = q->right = NULL;
7038     t->root = q;
7039
7040     /* connect the first three tips */
7041     p = t->allDownPass[numTips];
7042     p->anc = q;
7043     q->left = p;
7044     q = t->allDownPass[1];
7045     r = t->allDownPass[2];
7046     p->left = q;
7047     p->right = r;
7048     q->anc = r->anc = p;
7049
7050     /* add one tip at a time */
7051     for (i=3; i<numTips; i++)
7052         {
7053         p = t->allDownPass[i];
7054         q = t->allDownPass[numTips-2+i];
7055         r = t->allDownPass[order[i-3]];
7056         p->anc = q;
7057         q->left = p;
7058         q->right = r;
7059         q->anc = r->anc;
7060         if (r->anc->left == r)
7061             r->anc->left = q;
7062         else
7063             r->anc->right = q;
7064         r->anc = q;
7065         }
7066
7067     /* get downpass */
7068     GetDownPass (t);
7069
7070     /* relabel interior nodes (root is correctly labeled already) */
7071     for (i=0; i<t->nIntNodes; i++)
7072         t->intDownPass[i]->index = i+numTips;
7073
7074     return (NO_ERROR);
7075 }
7076
7077
7078 /*-------------------------------------------------------
7079 |
7080 |   RetrieveUTree: This routine will rebuild an unrooted
7081 |      tree from the arrays created by StoreUTree.
7082 |      All tree information except the structure and
7083 |      branch lengths will remain unaltered.
7084 |
7085 --------------------------------------------------------*/
7086 int RetrieveUTree (Tree *t, int *order, MrBFlt *brlens)
7087 {
7088     int         i, numTips;
7089     TreeNode    *p, *q, *r;
7090
7091     /* preliminaries */
7092     numTips = t->nNodes - t->nIntNodes;
7093     for (i=0; i<t->nNodes; i++)
7094         t->nodes[i].left = t->nodes[i].right = t->nodes[i].anc = NULL;
7095
7096     /* sort the tips in the t->allDownPass array */
7097     p = t->nodes;
7098     for (i=0; i<t->nNodes; i++, p++)
7099         t->allDownPass[p->index] = p;
7100
7101     /* make sure that root has index 0 */
7102     q = t->allDownPass[0];
7103     q->anc = q->right = NULL;
7104     t->root = q;
7105
7106     /* connect the first three tips */
7107     p = t->allDownPass[numTips];
7108     p->anc = q;
7109     q->left = p;
7110     p->length = *(brlens++);
7111     q = t->allDownPass[1];
7112     r = t->allDownPass[2];
7113     p->left = q;
7114     p->right = r;
7115     q->anc = r->anc = p;
7116     q->length = *(brlens++);
7117     r->length = *(brlens++);
7118
7119     /* add one tip at a time */
7120     for (i=3; i<numTips; i++)
7121         {
7122         p = t->allDownPass[i];
7123         q = t->allDownPass[numTips-2+i];
7124         r = t->allDownPass[order[i-3]];
7125         p->anc = q;
7126         q->left = p;
7127         q->right = r;
7128         q->anc = r->anc;
7129         if (r->anc->left == r)
7130             r->anc->left = q;
7131         else
7132             r->anc->right = q;
7133         r->anc = q;
7134         q->length = *(brlens++);
7135         p->length = *(brlens++);
7136         }
7137
7138     /* get downpass */
7139     GetDownPass (t);
7140
7141     /* relabel interior nodes (root is correctly labeled already) */
7142     for (i=0; i<t->nIntNodes; i++)
7143         t->intDownPass[i]->index = i+numTips;
7144
7145     return (NO_ERROR);
7146 }
7147
7148
7149 void SetDatedNodeAges (Param *param, int chain, int state)
7150 {
7151     int         i;
7152     MrBFlt      clockRate;
7153     ModelInfo   *m;
7154     TreeNode    *p;
7155     Tree        *t;
7156
7157     extern void ShowNodes(TreeNode *,int,int);
7158
7159     t = GetTree (param, chain, state);
7160     m = &modelSettings[t->relParts[0]];
7161
7162     if (m->clockRate == NULL)
7163         clockRate = 1.0;
7164     else
7165         clockRate = *GetParamVals(m->clockRate, chain, state);
7166
7167     for (i=0; i<t->nNodes-1; i++)
7168         {
7169         p = t->allDownPass[i];
7170         if (p->isDated == YES)
7171             p->age = p->nodeDepth / clockRate;
7172         else
7173             p->age = -1.0;
7174         }
7175 }
7176
7177
7178 void SetNodeDepths (Tree *t)
7179 {
7180     int     i;
7181     MrBFlt      d1, d2;
7182     TreeNode    *p;
7183
7184     extern void ShowNodes(TreeNode *,int,int);
7185
7186     for (i=0; i<t->nNodes-1; i++)
7187         {
7188         p = t->allDownPass[i];
7189         if (p->left == NULL)
7190             p->nodeDepth = 0.0;
7191         else
7192             {
7193             d1 = p->left->nodeDepth  + p->left->length;
7194             d2 = p->right->nodeDepth + p->right->length;
7195             //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.
7196             if (d1 > d2)
7197                 p->nodeDepth = d1;
7198             else
7199                 p->nodeDepth = d2;
7200             }
7201         }
7202
7203     for (i=t->nNodes-3; i>=0; i--)
7204         {
7205         p = t->allDownPass[i];
7206         if (p->left == NULL && p->calibration == NULL)
7207             p->nodeDepth = 0.0;
7208         else
7209             p->nodeDepth = p->anc->nodeDepth - p->length;
7210         }
7211 }
7212
7213
7214 /* Set ages of a clock tree according to depth and clockrate. Check that resulting ages are consistant with calibration.
7215 |  return YES if tree is age consistent, No otherwise.
7216 */
7217 int SetTreeNodeAges (Param *param, int chain, int state)
7218 {
7219     Tree        *tree;
7220     TreeNode    *p;
7221     int         i;
7222     MrBFlt      clockRate;
7223
7224     if (param->paramType != P_TOPOLOGY && param->paramType != P_BRLENS && param->paramType != P_SPECIESTREE)
7225         return YES;
7226
7227     tree = GetTree(param, chain, state);
7228     if (modelSettings[param->relParts[0]].clockRate != NULL)
7229         clockRate = *GetParamVals(modelSettings[param->relParts[0]].clockRate, chain, state);
7230     else
7231         return YES;
7232
7233     /* Clock trees */
7234
7235     /* Check that lengths and depths are consistant. That would work for the case when we set up branch length from starting tree  */
7236     for (i=0; i<tree->nNodes-1; i++) {
7237         p = tree->allDownPass[i];
7238         p->age =  p->nodeDepth / clockRate;
7239     }
7240
7241     /* Check that ages and calibrations are consistent */
7242     if (tree->isCalibrated == YES)
7243         {
7244         for (i=0; i<tree->nNodes-1; i++)
7245             {
7246             p = tree->allDownPass[i];
7247             if (p->isDated == YES) {
7248                 if (p->calibration->prior == fixed && fabs((p->age - p->calibration->priorParams[0])/p->age) > 0.000001)
7249                     {
7250                     printf ("Node %d has age %f but should be fixed to age %f\n",
7251                         p->index, p->age, p->calibration->priorParams[0]);
7252                     return NO;
7253                     }
7254                 else if (p->calibration->prior == uniform && (p->age < p->calibration->min || p->age > p->calibration->max))
7255                     {
7256                     printf ("Node %d has age %f but should be in the interval [%f,%f]\n",
7257                         p->index, p->age, p->calibration->min, p->calibration->max);
7258                     return NO;
7259                     }
7260                 else if (p->age < p->calibration->min)
7261                     {
7262                     printf ("Node %d has age %f but should be minimally of age %f\n",
7263                         p->index, p->age, p->calibration->min);
7264                     return NO;
7265                     }
7266                 else if (p->age > p->calibration->max)
7267                     {
7268                     printf ("Node %d has age %f but should be maximally of age %f\n",
7269                         p->index, p->age, p->calibration->max);
7270                     return NO;
7271                     }
7272                 }
7273             }
7274         }
7275
7276     return YES;
7277 }
7278
7279
7280 int ShowPolyNodes (PolyTree *pt)
7281 {
7282     int             i;
7283     PolyNode        *p;
7284
7285     /* this is the tree, on a node-by-node basis */
7286     printf ("   memnodes = %d  nNodes = %d  nIntNodes = %d  root = %d\n", pt->memNodes, pt->nNodes, pt->nIntNodes, pt->root->index);
7287     printf ("   isRooted = %d\n", pt->isRooted);
7288     printf ("   no. index (left sib anc) -- locked/free -- label (p->x)\n");
7289     for (i=0; i<pt->memNodes; i++)
7290         {
7291         p = &pt->nodes[i];
7292         if (!(p->left == NULL && p->sib == NULL && p->anc == NULL))
7293             {
7294             printf ("%4d -- %4d ", i, p->index);
7295             if (p->left != NULL)
7296                 printf ("(%4d ", p->left->index);
7297             else
7298                 printf ("(null ");
7299
7300             if (p->sib != NULL)
7301                 printf ("%4d ", p->sib->index);
7302             else
7303                 printf ("null ");
7304
7305             if (p->anc != NULL)
7306                 printf ("%4d)", p->anc->index);
7307             else
7308                 printf ("null)");
7309
7310             if (p->isLocked == YES)
7311                 printf ("-- locked -- ");
7312             else
7313                 printf ("-- free --");
7314
7315             if (p->left == NULL && p->anc != NULL)
7316                 printf ("  \"%s\" (%d)\n", p->label, p->x);
7317             else
7318                 printf (" \"\" (%d)\n", p->x);
7319             }
7320         }
7321
7322     return NO_ERROR;
7323 }
7324
7325
7326 /* ShowTree: Show tree on screen */
7327 int ShowTree (Tree *t)
7328 {
7329     int             i, j, k, x, nLines, nLevels, levelDepth, from, to;
7330     char            treeLine[SCREENWIDTH2], labelLine[100];
7331     TreeNode        *p;
7332
7333     /* get coordinates */
7334     x = 0;
7335     nLines = 0;
7336     for (i=0; i<t->nNodes; i++)
7337         {
7338         p = t->allDownPass[i];
7339         if (p->left == NULL && p->right == NULL)
7340             {
7341             p->x = x;
7342             x += 2;
7343             p->y = 0;
7344             nLines += 2;
7345             }
7346         else if (p->left != NULL && p->right != NULL && p->anc != NULL)
7347             {
7348             p->x = p->left->x + (p->right->x - p->left->x) / 2;
7349             if (p->left->y > p->right->y)
7350                 p->y = p->left->y + 1;
7351             else
7352                 p->y = p->right->y + 1;
7353             }
7354         else
7355             {
7356             p->x = x;
7357             x += 2;
7358             p->y = 0;
7359             }
7360         }
7361
7362     /* print tree out, line-by-line */
7363     levelDepth = SCREENWIDTH / t->root->left->y;
7364     nLevels = t->root->left->y;
7365     for (j=0; j<=nLines-2; j++)
7366         {
7367         for (i=0; i<SCREENWIDTH2-2; i++)
7368             treeLine[i] = ' ';
7369         treeLine[SCREENWIDTH-1] = '\n';
7370         if (j % 2 == 0)
7371             {
7372             for (i=0; i<t->nNodes; i++)
7373                 {
7374                 p = t->allDownPass[i];
7375                 if (p->left == NULL && p->x == j)
7376                     {
7377                     strcpy (labelLine, p->label);
7378                     }
7379                 }
7380             }
7381         for (i=0; i<t->nNodes; i++)
7382             {
7383             p = t->allDownPass[i];
7384             if (p->anc != NULL)
7385                 {
7386                 if (p->anc->anc != NULL)
7387                     {
7388                     if (p->x == j)
7389                         {
7390                         from = (nLevels - p->anc->y) * levelDepth;
7391                         to   = (nLevels - p->y) * levelDepth;
7392                         if (p->y == 0)
7393                             to = SCREENWIDTH-1;
7394                         if (to >= SCREENWIDTH)
7395                             to = SCREENWIDTH-1;
7396
7397                         for (k=from; k<to; k++)
7398                             treeLine[k] = '-';
7399                         if (p->anc->left == p)
7400                             treeLine[from] = '/';
7401                         else
7402                             treeLine[from] = '\\';
7403                         if (p->left != NULL)
7404                             {
7405                             treeLine[to] = '+';
7406                             }
7407                         if (p->anc->anc == t->root && p->anc->right == p)
7408                             {
7409                             if (t->isRooted == NO)
7410                                 treeLine[to] = '+';
7411                             else
7412                                 treeLine[from] = '\\';
7413                             }
7414                         }
7415                     else
7416                         {
7417                         if (p->left != NULL && p->right != NULL)
7418                             {
7419                             if (j < p->x && j > p->left->x)
7420                                 {
7421                                 from = (nLevels - p->y) * levelDepth;
7422                                 treeLine[from] = '|';
7423                                 }
7424                             else if (j > p->x && j < p->right->x && p->left != NULL)
7425                                 {
7426                                 from = (nLevels - p->y) * levelDepth;
7427                                 treeLine[from] = '|';
7428                                 }
7429                             }
7430                         }
7431                     }
7432                 else
7433                     {
7434                     if (p->x == j)
7435                         {
7436                         treeLine[0] = '|'; /* temp */
7437                         }
7438                     else if (j < p->x && j > p->left->x)
7439                         {
7440                         treeLine[0] = '|';
7441                         }
7442                     else if (j > p->x && j < p->right->x)
7443                         {
7444                         treeLine[0] = '|';
7445                         }
7446                     if (t->isRooted == NO)
7447                         {
7448                         if (j > p->x && j <= nLines-2)
7449                             treeLine[0] = '|';
7450                         if (j == p->right->x)
7451                             treeLine[0] = '+';
7452                         }
7453                     else
7454                         {
7455                         if (j == p->x)
7456                             treeLine[0] = '+';
7457                         }
7458                     }
7459                 }
7460             }
7461         treeLine[SCREENWIDTH-1] = '\0';
7462         if (j % 2 == 0)
7463             MrBayesPrint ("   %s %s\n", treeLine, labelLine);
7464         else
7465             MrBayesPrint ("   %s \n", treeLine);
7466         }
7467
7468     if (t->isRooted == NO)
7469         {
7470         for (i=0; i<SCREENWIDTH; i++)
7471             treeLine[i] = ' ';
7472         treeLine[SCREENWIDTH-1] = '\0';
7473         MrBayesPrint ("   |\n");
7474         for (k=0; k<SCREENWIDTH; k++)
7475             treeLine[k] = '-';
7476         treeLine[SCREENWIDTH-1] = '\0';
7477         treeLine[0] = '\\';
7478         strcpy (labelLine, t->root->label);
7479         labelLine[19] = '\0';
7480         MrBayesPrint ("   %s %s\n", treeLine, labelLine);
7481         }
7482
7483 #   if defined (DEBUG_CONSTRAINTS)
7484     for (i=0; i<t->nNodes; i++)
7485         printf ("%d -- %s\n", t->allDownPass[i]->index + 1, t->allDownPass[i]->isLocked == YES ? "locked" : "free");
7486 #   endif
7487
7488     return (NO_ERROR);
7489 }
7490
7491
7492 /*-------------------------------------------------------
7493 |
7494 |   StoreRPolyTopology: Same as StoreRTopology but for
7495 |   binary polytree source trees.
7496 |
7497 --------------------------------------------------------*/
7498 int StoreRPolyTopology (PolyTree *t, int *order)
7499 {
7500     int         i, numTaxa;
7501     PolyNode    *p, *q;
7502
7503     /* find number of taxa */
7504     numTaxa = t->nNodes - t->nIntNodes;
7505
7506     /* first get the terminal taxon positions and store
7507        them in the order array. */
7508     for (i=0; i<t->nNodes; i++)
7509         {
7510         p = t->allDownPass[i];
7511         /* we do not need to worry about the first two taxa */
7512         if (p->index > 1 && p->index < numTaxa)
7513             order[p->index-2] = i;
7514         }
7515
7516     /* label the interior nodes with the correct index */
7517     for (i=0; i<t->nNodes; i++)
7518         {
7519         p = t->allDownPass[i];
7520         if (p->left == NULL)
7521             p->x = p->y = p->index;
7522         else
7523             {
7524             if (p->left->y < p->left->sib->y)
7525                 {
7526                 p->y = p->left->y;
7527                 p->x = p->left->sib->y + numTaxa - 1;
7528                 }
7529             else
7530                 {
7531                 p->y = p->left->sib->y;
7532                 p->x = p->left->y + numTaxa - 1;
7533                 }
7534             }
7535         }
7536
7537     /* break the tree into pieces */
7538     for (i=0; i<numTaxa-2; i++)
7539         {
7540         /* find the next node to remove */
7541         p = t->allDownPass[order[numTaxa-3-i]];
7542         q = p->anc;
7543         if (q->left == p)
7544             {
7545             order[numTaxa-3-i] = q->left->sib->x;
7546             p->sib->anc = q->anc;
7547             if (q->anc == NULL)
7548                 {
7549                 p->sib->left->sib->sib = p->sib->sib;
7550                 p->sib->sib = NULL;
7551                 }
7552             else if (q->anc->left == q)
7553                 {
7554                 q->anc->left = q->left->sib;
7555                 p->sib->sib = q->sib;
7556                 }
7557             else
7558                 q->anc->left->sib = q->left->sib;
7559             }
7560         else
7561             {
7562             order[numTaxa-3-i] = q->left->x;
7563             q->left->anc = q->anc;
7564             if (q->anc == NULL)
7565                 {
7566                 q->left->left->sib->sib = p->sib;
7567                 q->left->sib = NULL;
7568                 }
7569             else if (q->anc->left == q)
7570                 {
7571                 q->anc->left = q->left;
7572                 q->anc->left->sib = q->sib;
7573                 }
7574             else
7575                 {
7576                 q->anc->left->sib = q->left;
7577                 q->left->sib = NULL;
7578                 }
7579             }
7580         }
7581
7582     return (NO_ERROR);
7583 }
7584
7585
7586 /*-------------------------------------------------------
7587 |
7588 |   StoreRPolyTree: Same as StoreRTree but for
7589 |      binary rooted polytree source trees.
7590 |
7591 --------------------------------------------------------*/
7592 int StoreRPolyTree (PolyTree *t, int *order, MrBFlt *brlens)
7593 {
7594     int         i, j, numTaxa;
7595     PolyNode    *p, *q;
7596
7597     /* find number of taxa */
7598     numTaxa = t->nNodes - t->nIntNodes;
7599
7600     /* first get the terminal taxon positions and store
7601        them in the order array. */
7602     for (i=0; i<t->nNodes; i++)
7603         {
7604         p = t->allDownPass[i];
7605         /* we do not need to worry about the first two taxa */
7606         if (p->index > 1 && p->index < numTaxa)
7607             order[p->index-2] = i;
7608         }
7609
7610     /* label the interior nodes with the correct index */
7611     for (i=0; i<t->nNodes; i++)
7612         {
7613         p = t->allDownPass[i];
7614         if (p->left == NULL)
7615             p->x = p->y = p->index;
7616         else
7617             {
7618             if (p->left->y < p->left->sib->y)
7619                 {
7620                 p->y = p->left->y;
7621                 p->x = p->left->sib->y + numTaxa - 1;
7622                 }
7623             else
7624                 {
7625                 p->y = p->left->sib->y;
7626                 p->x = p->left->y + numTaxa - 1;
7627                 }
7628             }
7629         }
7630
7631     /* break the tree into pieces */
7632     j = t->nNodes - 2;     /* index of first branch length */
7633     for (i=0; i<numTaxa-2; i++)
7634         {
7635         /* find the next node to remove */
7636         p = t->allDownPass[order[numTaxa-3-i]];
7637         q = p->anc;
7638         brlens[j--] = p->length;
7639         brlens[j--] = q->length;
7640         if (q->left == p)
7641             {
7642             order[numTaxa-3-i] = q->left->sib->x;
7643             p->sib->anc = q->anc;
7644             if (q->anc == NULL)
7645                 {
7646                 p->sib->left->sib->sib = p->sib->sib;
7647                 p->sib->sib = NULL;
7648                 }
7649             else if (q->anc->left == q)
7650                 {
7651                 q->anc->left = q->left->sib;
7652                 p->sib->sib = q->sib;
7653                 }
7654             else
7655                 q->anc->left->sib = q->left->sib;
7656             }
7657         else
7658             {
7659             order[numTaxa-3-i] = q->left->x;
7660             q->left->anc = q->anc;
7661             if (q->anc == NULL)
7662                 {
7663                 q->left->left->sib->sib = p->sib;
7664                 q->left->sib = NULL;
7665                 }
7666             else if (q->anc->left == q)
7667                 {
7668                 q->anc->left = q->left;
7669                 q->anc->left->sib = q->sib;
7670                 }
7671             else
7672                 {
7673                 q->anc->left->sib = q->left;
7674                 q->left->sib = NULL;
7675                 }
7676             }
7677         }
7678
7679     /* store the last two lengths; index 0 and 1 */
7680     p = t->root;
7681     brlens[p->left->index] = p->left->length;
7682     brlens[p->left->sib->index] = p->left->sib->length;
7683
7684     return (NO_ERROR);
7685 }
7686
7687
7688 /*-------------------------------------------------------
7689 |
7690 |   StoreRTopology: This routine will break a rooted tree
7691 |      into an array of ints describing the structure
7692 |      of the tree. The tree will be destroyed
7693 |      in the process (the node pointers, that is).
7694 |      However, the tree is not deleted.
7695 |
7696 --------------------------------------------------------*/
7697 int StoreRTopology (Tree *t, int *order)
7698 {
7699     int         i, numTaxa;
7700     TreeNode    *p, *q;
7701
7702     /* find number of taxa */
7703     numTaxa = t->nNodes - t->nIntNodes - 1;
7704
7705     /* first get the terminal taxon positions and store
7706        them in the order array. */
7707     for (i=0; i<t->nNodes; i++)
7708         {
7709         p = t->allDownPass[i];
7710         /* we do not need to worry about the first two taxa */
7711         if (p->index > 1 && p->index < numTaxa)
7712             order[p->index-2] = i;
7713         }
7714
7715     /* label the interior nodes with the correct index */
7716     for (i=0; i<t->nNodes; i++)
7717         {
7718         p = t->allDownPass[i];
7719         if (p->left == NULL)
7720             p->x = p->y = p->index;
7721         else if (p->right != NULL)
7722             {
7723             if (p->left->y < p->right->y)
7724                 {
7725                 p->y = p->left->y;
7726                 p->x = p->right->y + numTaxa - 1;
7727                 }
7728             else
7729                 {
7730                 p->y = p->right->y;
7731                 p->x = p->left->y + numTaxa - 1;
7732                 }
7733             }
7734         }
7735
7736     /* break the tree into pieces */
7737     for (i=0; i<numTaxa-2; i++)
7738         {
7739         /* find the next node to remove */
7740         p = t->allDownPass[order[numTaxa-3-i]];
7741         q = p->anc;
7742         if (q->left == p)
7743             {
7744             order[numTaxa-3-i] = q->right->x;
7745             q->right->anc = q->anc;
7746             if (q->anc->left == q)
7747                 q->anc->left = q->right;
7748             else
7749                 q->anc->right = q->right;
7750             }
7751         else
7752             {
7753             order[numTaxa-3-i] = q->left->x;
7754             q->left->anc = q->anc;
7755             if (q->anc->left == q)
7756                 q->anc->left = q->left;
7757             else
7758                 q->anc->right = q->left;
7759             }
7760         }
7761
7762     return (NO_ERROR);
7763 }
7764
7765
7766 /*-------------------------------------------------------
7767 |
7768 |   StoreRTree: This routine will break a rooted tree
7769 |      into an array of ints describing the structure
7770 |      of the tree and an array of doubles storing
7771 |      the branch lengths. The tree will be
7772 |      destroyed in the process (the node pointers,
7773 |      that is). However, the tree is not deleted.
7774 |
7775 --------------------------------------------------------*/
7776 int StoreRTree (Tree *t, int *order, MrBFlt *brlens)
7777 {
7778     int         i, j, numTaxa;
7779     TreeNode    *p, *q;
7780
7781     extern void ShowNodes (TreeNode *p, int indent, int isRooted);
7782
7783     /* find number of taxa */
7784     numTaxa = t->nNodes - t->nIntNodes - 1;
7785
7786     /* first get the terminal taxon positions and store
7787        them in the order array. */
7788     for (i=0; i<t->nNodes; i++)
7789         {
7790         p = t->allDownPass[i];
7791         /* we do not need to worry about the first two taxa */
7792         if (p->index > 1 && p->index < numTaxa)
7793             order[p->index-2] = i;
7794         }
7795
7796     /* label the interior nodes with the correct index */
7797     for (i=0; i<t->nNodes; i++)
7798         {
7799         p = t->allDownPass[i];
7800         if (p->left == NULL)
7801             p->x = p->y = p->index;
7802         else if (p->right != NULL)
7803             {
7804             if (p->left->y < p->right->y)
7805                 {
7806                 p->y = p->left->y;
7807                 p->x = p->right->y + numTaxa - 1;
7808                 }
7809             else
7810                 {
7811                 p->y = p->right->y;
7812                 p->x = p->left->y + numTaxa - 1;
7813                 }
7814             }
7815         }
7816
7817     /* break the tree into pieces */
7818     j = 2 * numTaxa - 3;
7819     for (i=0; i<numTaxa-2; i++)
7820         {
7821         /* find the next node to remove */
7822         p = t->allDownPass[order[numTaxa-3-i]];
7823         q = p->anc;
7824         brlens[j--] = p->length;
7825         if (q->left == p)
7826             {
7827             if (q->anc->anc != NULL)
7828                 brlens[j--] = q->length;
7829             else
7830                 brlens[j--] = q->right->length;
7831             order[numTaxa-3-i] = q->right->x;
7832             q->right->anc = q->anc;
7833             if (q->anc->left == q)
7834                 q->anc->left = q->right;
7835             else
7836                 q->anc->right = q->right;
7837             }
7838         else
7839             {
7840             if (q->anc->anc != NULL)
7841                 brlens[j--] = q->length;
7842             else
7843                 brlens[j--] = q->left->length;
7844             order[numTaxa-3-i] = q->left->x;
7845             q->left->anc = q->anc;
7846             if (q->anc->left == q)
7847                 q->anc->left = q->left;
7848             else
7849                 q->anc->right = q->left;
7850             }
7851         }
7852
7853     /* store the final two branch lengths in the right order; they have indices 0 and 1 */
7854     p = t->root->left;
7855     brlens[p->left->index] = p->left->length;
7856     brlens[p->right->index] = p->right->length;
7857
7858     return (NO_ERROR);
7859 }
7860
7861
7862 /*-------------------------------------------------------
7863 |
7864 |   StoreRTreeWithIndices: This routine will break a rooted
7865 |      tree into an array of ints describing the structure
7866 |      of the tree and the interior node indices, and an array
7867 |      of doubles storing the branch lengths. The tree will be
7868 |      destroyed in the process (the node pointers,
7869 |      that is). However, the tree is not deleted.
7870 |
7871 --------------------------------------------------------*/
7872 int StoreRTreeWithIndices (Tree *t, int *order, MrBFlt *brlens)
7873 {
7874     int         i, j, k, numTaxa;
7875     TreeNode    *p, *q;
7876
7877     extern void ShowNodes (TreeNode *p, int indent, int isRooted);
7878
7879     /* find number of taxa */
7880     numTaxa = t->nNodes - t->nIntNodes - 1;
7881
7882     /* first get the terminal taxon positions and store
7883        them in the order array. */
7884     for (i=0; i<t->nNodes; i++)
7885         {
7886         p = t->allDownPass[i];
7887         /* we do not need to worry about the first two taxa */
7888         if (p->index > 1 && p->index < numTaxa)
7889             order[p->index-2] = i;
7890         }
7891
7892     /* label the interior nodes with the correct index */
7893     for (i=0; i<t->nNodes; i++)
7894         {
7895         p = t->allDownPass[i];
7896         if (p->left == NULL)
7897             p->x = p->y = p->index;
7898         else if (p->right != NULL)
7899             {
7900             if (p->left->y < p->right->y)
7901                 {
7902                 p->y = p->left->y;
7903                 p->x = p->right->y + numTaxa - 1;
7904                 }
7905             else
7906                 {
7907                 p->y = p->right->y;
7908                 p->x = p->left->y + numTaxa - 1;
7909                 }
7910             }
7911         }
7912
7913     /* break the tree into pieces */
7914     j = 2 * numTaxa - 3;
7915     k = 2*(numTaxa - 2);
7916     for (i=0; i<numTaxa-2; i++)
7917         {
7918         /* find the next node to remove */
7919         p = t->allDownPass[order[numTaxa-3-i]];
7920         q = p->anc;
7921         brlens[j--] = p->length;
7922         if (q->left == p)
7923             {
7924             if (q->anc->anc != NULL)
7925                 brlens[j--] = q->length;
7926             else
7927                 brlens[j--] = q->right->length;
7928             order[k--] = q->right->x;
7929             order[k--] = q->index;
7930             q->right->anc = q->anc;
7931             if (q->anc->left == q)
7932                 q->anc->left = q->right;
7933             else
7934                 q->anc->right = q->right;
7935             }
7936         else
7937             {
7938             if (q->anc->anc != NULL)
7939                 brlens[j--] = q->length;
7940             else
7941                 brlens[j--] = q->left->length;
7942             order[k--] = q->left->x;
7943             order[k--] = q->index;
7944             q->left->anc = q->anc;
7945             if (q->anc->left == q)
7946                 q->anc->left = q->left;
7947             else
7948                 q->anc->right = q->left;
7949             }
7950         }
7951
7952     /* store the final two branch lengths in the right order; they have indices 0 and 1 */
7953     p = t->root->left;
7954     order[k] = p->index;
7955     brlens[p->left->index] = p->left->length;
7956     brlens[p->right->index] = p->right->length;
7957
7958     return (NO_ERROR);
7959 }
7960
7961
7962 /*-------------------------------------------------------
7963 |
7964 |   StoreUPolyTopology: Same as StoreUTopology but for
7965 |      binary polytree source.
7966 |
7967 --------------------------------------------------------*/
7968 int StoreUPolyTopology (PolyTree *t, int *order)
7969 {
7970     int         i, numTips;
7971     PolyNode    *p, *q;
7972
7973     /* check if the tree is rooted on taxon 0 */
7974     if (t->root->left->sib->sib->index != 0)
7975         MovePolyCalculationRoot (t, 0);
7976
7977     /* rearrange the root */
7978     t->root->anc = t->root->left->sib->sib;
7979     t->root->left->sib->sib = NULL;
7980     t->root->anc->left = t->root;
7981     t->root->anc->sib = NULL;
7982     t->root->anc->anc = NULL;
7983     t->root = t->root->anc;
7984
7985     /* find number of tips */
7986     numTips = t->nNodes - t->nIntNodes;
7987
7988     /* first get the terminal taxon positions and store
7989        them in the order array. */
7990     for (i=0; i<t->nNodes; i++)
7991         {
7992         p = t->allDownPass[i];
7993         /* we do not need to worry about the first three taxa */
7994         if (p->index > 2 && p->index < numTips)
7995             order[p->index-3] = i;
7996         }
7997
7998     /* label the interior nodes with the correct index */
7999     for (i=0; i<t->nNodes; i++)
8000         {
8001         p = t->allDownPass[i];
8002         if (p->left == NULL || p->anc == NULL)
8003             p->x = p->y = p->index;
8004         else
8005             {
8006             if (p->left->y < p->left->sib->y)
8007                 {
8008                 p->y = p->left->y;
8009                 p->x = p->left->sib->y + numTips - 2;
8010                 }
8011             else
8012                 {
8013                 p->y = p->left->sib->y;
8014                 p->x = p->left->y + numTips - 2;
8015                 }
8016             }
8017         }
8018
8019     /* break the tree into pieces */
8020     for (i=0; i<numTips-3; i++)
8021         {
8022         /* find the next node to remove */
8023         p = t->allDownPass[order[numTips-4-i]];
8024         q = p->anc;
8025         if (q->left == p)
8026             {
8027             order[numTips-4-i] = q->left->sib->x;
8028             p->sib->anc = q->anc;
8029             if (q->anc->left == q)
8030                 {
8031                 q->anc->left = p->sib;
8032                 p->sib->sib = q->sib;
8033                 }
8034             else
8035                 {
8036                 q->anc->left->sib = p->sib;
8037                 p->sib->sib = q->sib;
8038                 }
8039             }
8040         else
8041             {
8042             order[numTips-4-i] = q->left->x;
8043             q->left->anc = q->anc;
8044             if (q->anc->left == q)
8045                 {
8046                 q->anc->left = q->left;
8047                 q->left->sib = q->sib;
8048                 }
8049             else
8050                 {
8051                 q->anc->left->sib = q->left;
8052                 q->left->sib = q->sib;
8053                 }
8054             }
8055         }
8056
8057     return (NO_ERROR);
8058 }
8059
8060
8061 /*-------------------------------------------------------
8062 |
8063 |   StoreUPolyTree: Same as StoreUTopology but for
8064 |      binary polytree source.
8065 |
8066 --------------------------------------------------------*/
8067 int StoreUPolyTree (PolyTree *t, int *order, MrBFlt *brlens)
8068 {
8069     int         i, j, numTips;
8070     PolyNode    *p, *q;
8071
8072     /* check if the tree is rooted on taxon 0 */
8073     if (t->root->left->sib->sib->index != 0)
8074         MovePolyCalculationRoot (t, 0);
8075
8076     /* rearrange the root */
8077     t->root->anc = t->root->left->sib->sib;
8078     t->root->left->sib->sib = NULL;
8079     t->root->anc->left = t->root;
8080     t->root->anc->sib = NULL;
8081     t->root->anc->anc = NULL;
8082     t->root = t->root->anc;
8083
8084     /* find number of tips */
8085     numTips = t->nNodes - t->nIntNodes;
8086
8087     /* first get the terminal taxon positions and store
8088        them in the order array. */
8089     for (i=0; i<t->nNodes; i++)
8090         {
8091         p = t->allDownPass[i];
8092         /* we do not need to worry about the first three taxa */
8093         if (p->index > 2 && p->index < numTips)
8094             order[p->index-3] = i;
8095         }
8096
8097     /* label the interior nodes with the correct index */
8098     for (i=0; i<t->nNodes; i++)
8099         {
8100         p = t->allDownPass[i];
8101         if (p->left == NULL || p->anc == NULL)
8102             p->x = p->y = p->index;
8103         else
8104             {
8105             if (p->left->y < p->left->sib->y)
8106                 {
8107                 p->y = p->left->y;
8108                 p->x = p->left->sib->y + numTips - 2;
8109                 }
8110             else
8111                 {
8112                 p->y = p->left->sib->y;
8113                 p->x = p->left->y + numTips - 2;
8114                 }
8115             }
8116         }
8117
8118     /* break the tree into pieces */
8119     j = 2*numTips - 4;
8120     for (i=0; i<numTips-3; i++)
8121         {
8122         /* find the next node to remove */
8123         p = t->allDownPass[order[numTips-4-i]];
8124         assert (p->index > 2 && p->index < numTips);
8125         assert (p->anc->anc != NULL);
8126         q = p->anc;
8127         brlens[j--] = p->length;
8128         brlens[j--] = q->length;
8129         if (q->left == p)
8130             {
8131             order[numTips-4-i] = q->left->sib->x;
8132             p->sib->anc = q->anc;
8133             if (q->anc->left == q)
8134                 {
8135                 q->anc->left = p->sib;
8136                 p->sib->sib = q->sib;
8137                 }
8138             else
8139                 {
8140                 q->anc->left->sib = p->sib;
8141                 p->sib->sib = q->sib;
8142                 }
8143             }
8144         else
8145             {
8146             order[numTips-4-i] = q->left->x;
8147             q->left->anc = q->anc;
8148             if (q->anc->left == q)
8149                 {
8150                 q->anc->left = q->left;
8151                 q->left->sib = q->sib;
8152                 }
8153             else
8154                 {
8155                 q->anc->left->sib = q->left;
8156                 q->left->sib = q->sib;
8157                 }
8158             }
8159         }
8160
8161     /* store last three branch lengths, index 0, 1, 2 */
8162     q = t->root;
8163     assert (q->index == 0);
8164     brlens[q->index] = q->length;
8165     q = q->left->left;
8166     assert (q->index == 1 || q->index == 2);
8167     brlens[q->index] = q->length;
8168     q = q->sib;
8169     assert (q->index == 1 || q->index == 2);
8170     brlens[q->index] = q->length;
8171
8172     return (NO_ERROR);
8173 }
8174
8175
8176 /*-------------------------------------------------------
8177 |
8178 |   StoreUTopology: This routine will break an unrooted tree
8179 |      into an array of ints describing the structure
8180 |      of the tree. The tree will be destroyed
8181 |      in the process (the node pointers, that is).
8182 |      However, the tree is not deleted.
8183 |
8184 --------------------------------------------------------*/
8185 int StoreUTopology (Tree *t, int *order)
8186 {
8187     int         i, numTips;
8188     TreeNode    *p, *q;
8189
8190     /* check if the tree is rooted on taxon 0 */
8191     if (t->root->index != 0)
8192         MoveCalculationRoot (t, 0);
8193
8194     /* find number of tips */
8195     numTips = t->nNodes - t->nIntNodes;
8196
8197     /* first get the terminal taxon positions and store
8198        them in the order array. */
8199     for (i=0; i<t->nNodes; i++)
8200         {
8201         p = t->allDownPass[i];
8202         /* we do not need to worry about the first three taxa */
8203         if (p->index > 2 && p->index < numTips)
8204             order[p->index-3] = i;
8205         }
8206
8207     /* label the interior nodes with the correct index */
8208     for (i=0; i<t->nNodes; i++)
8209         {
8210         p = t->allDownPass[i];
8211         if (p->left == NULL)
8212             p->x = p->y = p->index;
8213         else if (p->right != NULL)
8214             {
8215             if (p->left->y < p->right->y)
8216                 {
8217                 p->y = p->left->y;
8218                 p->x = p->right->y + numTips - 2;
8219                 }
8220             else
8221                 {
8222                 p->y = p->right->y;
8223                 p->x = p->left->y + numTips - 2;
8224                 }
8225             }
8226         }
8227
8228     /* break the tree into pieces */
8229     for (i=0; i<numTips-3; i++)
8230         {
8231         /* find the next node to remove */
8232         p = t->allDownPass[order[numTips-4-i]];
8233         q = p->anc;
8234         if (q->left == p)
8235             {
8236             order[numTips-4-i] = q->right->x;
8237             q->right->anc = q->anc;
8238             if (q->anc->left == q)
8239                 q->anc->left = q->right;
8240             else
8241                 q->anc->right = q->right;
8242             }
8243         else
8244             {
8245             order[numTips-4-i] = q->left->x;
8246             q->left->anc = q->anc;
8247             if (q->anc->left == q)
8248                 q->anc->left = q->left;
8249             else
8250                 q->anc->right = q->left;
8251             }
8252         }
8253
8254     return (NO_ERROR);
8255 }
8256
8257
8258 /*-------------------------------------------------------
8259 |
8260 |   StoreUTree: This routine will break an unrooted tree
8261 |      into an array of ints describing the structure
8262 |      of the tree and an array of doubles storing
8263 |      the branch lengths. The tree will be
8264 |      destroyed in the process (the node pointers,
8265 |      that is). However, the tree is not deleted.
8266 |
8267 --------------------------------------------------------*/
8268 int StoreUTree (Tree *t, int *order, MrBFlt *brlens)
8269 {
8270     int         i, j, numTips;
8271     TreeNode    *p, *q;
8272
8273     /* check if the tree is rooted on taxon 0 */
8274     if (t->root->index != 0)
8275         MoveCalculationRoot(t, 0);
8276
8277     /* find number of tips */
8278     numTips = t->nNodes - t->nIntNodes;
8279
8280     /* first get the terminal taxon positions and store
8281        them in the order array. */
8282     for (i=0; i<t->nNodes; i++)
8283         {
8284         p = t->allDownPass[i];
8285         /* we do not need to worry about the first three taxa */
8286         if (p->index > 2 && p->index < numTips)
8287             order[p->index-3] = i;
8288         }
8289
8290     /* label the interior nodes with the correct index */
8291     for (i=0; i<t->nNodes; i++)
8292         {
8293         p = t->allDownPass[i];
8294         if (p->left == NULL)
8295             p->x = p->y = p->index;
8296         else if (p->right != NULL)
8297             {
8298             if (p->left->y < p->right->y)
8299                 {
8300                 p->y = p->left->y;
8301                 p->x = p->right->y + numTips - 2;
8302                 }
8303             else
8304                 {
8305                 p->y = p->right->y;
8306                 p->x = p->left->y + numTips - 2;
8307                 }
8308             }
8309         }
8310
8311     /* break the tree into pieces */
8312     j = 2 * numTips - 4;
8313     for (i=0; i<numTips-3; i++)
8314         {
8315         /* find the next node to remove */
8316         p = t->allDownPass[order[numTips-4-i]];
8317         q = p->anc;
8318         brlens[j--] = p->length;
8319         brlens[j--] = q->length;
8320         if (q->left == p)
8321             {
8322             order[numTips-4-i] = q->right->x;
8323             q->right->anc = q->anc;
8324             if (q->anc->left == q)
8325                 q->anc->left = q->right;
8326             else
8327                 q->anc->right = q->right;
8328             }
8329         else
8330             {
8331             order[numTips-4-i] = q->left->x;
8332             q->left->anc = q->anc;
8333             if (q->anc->left == q)
8334                 q->anc->left = q->left;
8335             else
8336                 q->anc->right = q->left;
8337             }
8338         }
8339
8340     /* store the final three branch lengths */
8341     /* we need to check the rotation of the tree to
8342            store the brlens in the right order (after node index) */
8343     p = t->root->left;
8344     if (p->right->index == 2)
8345             {
8346             brlens[j--] = p->right->length;
8347         brlens[j--] = p->left->length;
8348             }
8349     else
8350             {
8351             brlens[j--] = p->left->length;
8352             brlens[j--] = p->right->length;
8353             }
8354     brlens[j--] = p->length;
8355
8356     return (NO_ERROR);
8357 }
8358
8359
8360 /* TreeLength: Calculate tree length */
8361 MrBFlt TreeLen (Tree *t)
8362 {
8363     int     i, numLenNodes;
8364     MrBFlt  len = 0.0;
8365
8366     if (t->isRooted == NO)
8367         numLenNodes = t->nNodes - 1;
8368     else
8369         numLenNodes = t->nNodes - 2;
8370
8371     for (i=0; i<numLenNodes; i++)
8372         len += t->allDownPass[i]->length;
8373
8374     return len;
8375 }
8376
8377
8378 /*-------------------------------------------------------------------------------------------
8379 |
8380 |   Unmark: This routine will unmark a subtree rooted at p
8381 |
8382 ---------------------------------------------------------------------------------------------*/
8383 void Unmark (TreeNode *p)
8384 {
8385     if (p != NULL)
8386         {
8387         p->marked = NO;
8388         Unmark (p->left);
8389         Unmark (p->right);
8390         }
8391 }
8392
8393
8394 void WriteEventTree (TreeNode *p, int chain, Param *param)
8395 {
8396     int             j, nEvents;
8397     MrBFlt          brlen, *position, *rateMult;
8398
8399     if (p != NULL)
8400         {
8401         if (p->left == NULL && p->right == NULL)
8402             {
8403             printf ("%d:%s", p->index + 1, MbPrintNum(p->length));
8404             if (param->paramType == P_CPPEVENTS)
8405                 {
8406                 nEvents = param->nEvents[2*chain+state[chain]][p->index];
8407                 if (nEvents > 0)
8408                     {
8409                     printf ("[&E %s %d: (", param->name, nEvents);
8410                     position = param->position[2*chain+state[chain]][p->index];
8411                     rateMult = param->rateMult[2*chain+state[chain]][p->index];
8412                     for (j=0; j<nEvents; j++)
8413                         {
8414                         printf ("%s %s", MbPrintNum(position[j]), MbPrintNum(rateMult[j]));
8415                         if (j != nEvents-1)
8416                             printf (", ");
8417                         }
8418                     printf (")]");
8419                     }
8420                 else
8421                     printf ("[&E %s 0]", param->name);
8422                 }
8423             brlen = GetParamSubVals (param, chain, state[chain])[p->index];
8424             // brlen = (GetParamSubVals (param, chain, state[chain])[p->index] + GetParamVals (param, chain, state[chain])[p->anc->index]) / 2.0;
8425             printf ("[&B %s %s]", param->name, MbPrintNum(brlen));
8426             }
8427         else
8428             {
8429             if (p->anc != NULL)
8430                 printf ("(");
8431             WriteEventTree(p->left, chain, param);
8432             printf (",");
8433             WriteEventTree(p->right, chain, param);
8434             if (p->anc != NULL)
8435                 {
8436                 if (p->anc->anc != NULL)
8437                     {
8438                     printf ("):%s", MbPrintNum(p->length));
8439                     if (param->paramType == P_CPPEVENTS)
8440                         {
8441                         nEvents = param->nEvents[2*chain+state[chain]][p->index];
8442                         if (nEvents > 0)
8443                             {
8444                             printf ("[&E %s %d: (", param->name, nEvents);
8445                             position = param->position[2*chain+state[chain]][p->index];
8446                             rateMult = param->rateMult[2*chain+state[chain]][p->index];
8447                             for (j=0; j<nEvents; j++)
8448                                 {
8449                                 printf ("%s %s", MbPrintNum(position[j]), MbPrintNum(rateMult[j]));
8450                                 if (j != nEvents-1)
8451                                     printf (", ");
8452                                 }
8453                             printf (")]");
8454                             }
8455                         else
8456                             printf ("[&E %s 0]", param->name);
8457                         }
8458                     brlen = GetParamSubVals (param, chain, state[chain])[p->index];
8459                     // brlen = (GetParamSubVals (param, chain, state[chain])[p->index] + GetParamVals (param, chain, state[chain])[p->anc->index]) / 2.0;
8460                     printf ("[&B %s %s]", param->name, MbPrintNum(brlen));
8461                     }
8462                 else
8463                     printf (")");
8464                 }
8465             }
8466         }
8467 }
8468
8469
8470 void WriteEventTreeToPrintString (TreeNode *p, int chain, Param *param, int printAll)
8471 {
8472     char            *tempStr;
8473     int             i, j, nEvents, tempStrSize = TEMPSTRSIZE;
8474     MrBFlt          brlen, *position, *rateMult;
8475
8476     tempStr = (char *) SafeMalloc((size_t)tempStrSize * sizeof(char));
8477     if (!tempStr)
8478         MrBayesPrint ("%s   Problem allocating tempString (%d)\n", spacer, tempStrSize * sizeof(char));
8479
8480     if (p != NULL)
8481         {
8482         if (p->left == NULL && p->right == NULL)
8483             {
8484             SafeSprintf (&tempStr, &tempStrSize, "%d:%s", p->index + 1, MbPrintNum(p->length));
8485             AddToPrintString (tempStr);
8486             for (i=0; i<param->nSubParams; i++)
8487                 {
8488                 if (param->subParams[i]->paramType == P_CPPEVENTS)
8489                     {
8490                     nEvents = param->subParams[i]->nEvents[2*chain+state[chain]][p->index];
8491                     if (nEvents > 0)
8492                         {
8493                         SafeSprintf (&tempStr, &tempStrSize, "[&E %s %d", param->subParams[i]->name, nEvents);
8494                         AddToPrintString (tempStr);
8495                         position = param->subParams[i]->position[2*chain+state[chain]][p->index];
8496                         rateMult = param->subParams[i]->rateMult[2*chain+state[chain]][p->index];
8497                         if (printAll == YES)
8498                             {
8499                             SafeSprintf (&tempStr, &tempStrSize, ": (");
8500                             AddToPrintString (tempStr);
8501                             for (j=0; j<nEvents; j++)
8502                                 {
8503                                 SafeSprintf (&tempStr, &tempStrSize, "%s", MbPrintNum(position[j]));
8504                                 AddToPrintString (tempStr);
8505                                 SafeSprintf (&tempStr, &tempStrSize, " %s",  MbPrintNum(rateMult[j]));
8506                                 AddToPrintString (tempStr);
8507                                 if (j != nEvents-1)
8508                                     AddToPrintString (",");
8509                                 else
8510                                     AddToPrintString (")");
8511                                 }
8512                             }
8513                         AddToPrintString ("]");
8514                         }
8515                     else
8516                         {
8517                         SafeSprintf (&tempStr, &tempStrSize, "[&E %s 0]", param->subParams[i]->name);
8518                         AddToPrintString (tempStr);
8519                         }
8520                     }
8521                 else if (param->subParams[i]->paramType != P_CPPEVENTS)
8522                     {
8523                     /* other relaxed clock models */
8524                     brlen = GetParamSubVals (param->subParams[i], chain, state[chain])[p->index];
8525                     SafeSprintf (&tempStr, &tempStrSize, "[&B %s %s]", param->subParams[i]->name, MbPrintNum(brlen));
8526                     AddToPrintString (tempStr);
8527                     }
8528                 }
8529             }
8530         else
8531             {
8532             if (p->anc != NULL)
8533                 AddToPrintString ("(");
8534             WriteEventTreeToPrintString (p->left, chain, param, printAll);
8535             AddToPrintString (",");
8536             WriteEventTreeToPrintString (p->right, chain, param, printAll);
8537             if (p->anc != NULL)
8538                 {
8539                 if (p->anc->anc != NULL)
8540                     {
8541                     SafeSprintf (&tempStr, &tempStrSize, "):%s", MbPrintNum(p->length));
8542                     AddToPrintString (tempStr);
8543                     for (i=0; i<param->nSubParams; i++)
8544                         {
8545                         if (param->subParams[i]->paramType == P_CPPEVENTS)
8546                             {
8547                             nEvents = param->subParams[i]->nEvents[2*chain+state[chain]][p->index];
8548                             if (nEvents > 0)
8549                                 {
8550                                 SafeSprintf (&tempStr, &tempStrSize, "[&E %s %d", param->subParams[i]->name, nEvents);
8551                                 AddToPrintString (tempStr);
8552                                 position = param->subParams[i]->position[2*chain+state[chain]][p->index];
8553                                 rateMult = param->subParams[i]->rateMult[2*chain+state[chain]][p->index];
8554                                 if (printAll == YES)
8555                                     {
8556                                     SafeSprintf (&tempStr, &tempStrSize, ": (");
8557                                     AddToPrintString (tempStr);
8558                                     for (j=0; j<nEvents; j++)
8559                                         {
8560                                         SafeSprintf (&tempStr, &tempStrSize, "%s", MbPrintNum(position[j]));
8561                                         AddToPrintString (tempStr);
8562                                         SafeSprintf (&tempStr, &tempStrSize, " %s",  MbPrintNum(rateMult[j]));
8563                                         AddToPrintString (tempStr);
8564                                         if (j != nEvents-1)
8565                                             AddToPrintString (",");
8566                                         else
8567                                             AddToPrintString (")");
8568                                         }
8569                                     }
8570                                 AddToPrintString ("]");
8571                                 }
8572                             else
8573                                 {
8574                                 SafeSprintf (&tempStr, &tempStrSize, "[&E %s 0]", param->subParams[i]->name);
8575                                 AddToPrintString (tempStr);
8576                                 }
8577                             }
8578                         else if (param->subParams[i]->paramType != P_CPPEVENTS)
8579                             {
8580                             /* other relaxed clock models */
8581                             brlen = GetParamSubVals (param->subParams[i], chain, state[chain])[p->index];
8582                             SafeSprintf (&tempStr, &tempStrSize, "[&B %s %s]", param->subParams[i]->name, MbPrintNum(brlen));
8583                             AddToPrintString (tempStr);
8584                             }
8585                         }
8586                     }
8587                 else
8588                     AddToPrintString(")");
8589                 }
8590             }
8591         }
8592     free (tempStr);
8593 }
8594
8595
8596 void WriteEvolTree (TreeNode *p, int chain, Param *param)
8597 {
8598     MrBFlt          *length;
8599
8600     if (p != NULL)
8601         {
8602         length = GetParamSubVals(param, chain, state[chain]);
8603         if (p->left == NULL && p->right == NULL)
8604             {
8605             printf ("%d:%s", p->index + 1, MbPrintNum(length[p->index]));
8606             }
8607         else
8608             {
8609             if (p->anc != NULL)
8610                 printf ("(");
8611             WriteEvolTree(p->left, chain, param);
8612             printf (",");
8613             WriteEvolTree(p->right, chain, param);
8614             if (p->anc != NULL)
8615                 {
8616                 if (p->anc->anc != NULL)
8617                     printf ("):%s", MbPrintNum(length[p->index]));
8618                 else
8619                     printf (")");
8620                 }
8621             }
8622         }
8623 }
8624
8625
8626 void WriteNoEvtTreeToPrintString (TreeNode *p, int chain, Param *param, int showBrlens, int isRooted)
8627 {
8628     char            *tempStr;
8629     int             i, tempStrSize = TEMPSTRSIZE, nEvents;
8630     MrBFlt          brlen, N;
8631
8632     tempStr = (char *) SafeMalloc((size_t)tempStrSize * sizeof(char));
8633     if (!tempStr)
8634         MrBayesPrint ("%s   Problem allocating tempString (%d)\n", spacer, tempStrSize * sizeof(char));
8635
8636     if (p != NULL)
8637         {
8638         if (p->left == NULL && p->right == NULL)
8639             {
8640             if (showBrlens == YES)
8641                 {
8642                 SafeSprintf (&tempStr, &tempStrSize, "%d:%s", p->index + 1, MbPrintNum(p->length));
8643                 }
8644             else
8645                 SafeSprintf (&tempStr, &tempStrSize, "%d", p->index + 1);
8646             AddToPrintString (tempStr);
8647             if (param->paramType == P_BRLENS)
8648                 {
8649                 for (i=0; i<param->nSubParams; i++)
8650                     {
8651                     if (param->subParams[i]->paramType == P_CPPEVENTS)
8652                         {
8653                         nEvents = param->subParams[i]->nEvents[2*chain+state[chain]][p->index];
8654                         SafeSprintf (&tempStr, &tempStrSize, "[&E %s %d]", param->subParams[i]->name, nEvents);
8655                         AddToPrintString (tempStr);
8656                         }
8657                     brlen = GetParamSubVals (param->subParams[i], chain, state[chain])[p->index];
8658                     SafeSprintf (&tempStr, &tempStrSize, "[&B %s %s]", param->subParams[i]->name, MbPrintNum(brlen));
8659                     AddToPrintString (tempStr);
8660                     }
8661                 }
8662             else if (param->paramType == P_SPECIESTREE && modelSettings[param->relParts[0]].popSize->nValues > 1)
8663                 {
8664                 N = GetParamVals (modelSettings[param->relParts[0]].popSize, chain, state[chain])[p->index];
8665                 SafeSprintf (&tempStr, &tempStrSize, "[&N %s %s]", modelSettings[param->relParts[0]].popSize->name, MbPrintNum(N));
8666                 AddToPrintString (tempStr);
8667                 }
8668             }
8669         else
8670             {
8671             if (p->anc != NULL)
8672                 AddToPrintString ("(");
8673             WriteNoEvtTreeToPrintString (p->left,  chain, param, showBrlens, isRooted);
8674             if (p->anc != NULL)
8675                 AddToPrintString (",");
8676             WriteNoEvtTreeToPrintString (p->right, chain, param, showBrlens, isRooted);
8677             if (p->anc != NULL)
8678                 {
8679                 if (p->anc->anc == NULL && isRooted == NO)
8680                     {
8681                     if (showBrlens == YES)
8682                         SafeSprintf (&tempStr, &tempStrSize, ",%d:%s)", p->anc->index + 1, MbPrintNum(p->length));
8683                     else
8684                         SafeSprintf (&tempStr, &tempStrSize, ",%d)", p->anc->index + 1);
8685                     AddToPrintString (tempStr);
8686                     }
8687                 else if (p->anc->anc != NULL)
8688                     {
8689                     if (showBrlens == YES)
8690                         SafeSprintf (&tempStr, &tempStrSize, "):%s", MbPrintNum(p->length));
8691                     else
8692                         SafeSprintf (&tempStr, &tempStrSize, ")");
8693                     AddToPrintString (tempStr);
8694                     if (param->paramType == P_BRLENS)
8695                         {
8696                         for (i=0; i<param->nSubParams; i++)
8697                             {
8698                             if (param->subParams[i]->paramType == P_CPPEVENTS)
8699                                 {
8700                                 nEvents = param->subParams[i]->nEvents[2*chain+state[chain]][p->index];
8701                                 SafeSprintf (&tempStr, &tempStrSize, "[&E %s %d]", param->subParams[i]->name, nEvents);
8702                                 AddToPrintString (tempStr);
8703                                 }
8704                             brlen = GetParamSubVals (param->subParams[i], chain, state[chain])[p->index];
8705                             SafeSprintf (&tempStr, &tempStrSize, "[&B %s %s]", param->subParams[i]->name, MbPrintNum(brlen));
8706                             AddToPrintString (tempStr);
8707                             }
8708                         }
8709                     else if (param->paramType == P_SPECIESTREE && modelSettings[param->relParts[0]].popSize->nValues > 1)
8710                         {
8711                         N = GetParamVals (modelSettings[param->relParts[0]].popSize, chain, state[chain])[p->index];
8712                         SafeSprintf (&tempStr, &tempStrSize, "[&N %s %s]", modelSettings[param->relParts[0]].popSize->name, MbPrintNum(N));
8713                         AddToPrintString (tempStr);
8714                         }
8715                     }
8716                 else if (param->paramType == P_SPECIESTREE && modelSettings[param->relParts[0]].popSize->nValues > 1)
8717                     {
8718                     N = GetParamVals (modelSettings[param->relParts[0]].popSize, chain, state[chain])[p->index];
8719                     SafeSprintf (&tempStr, &tempStrSize, ")[&N %s %s]", modelSettings[param->relParts[0]].popSize->name, MbPrintNum(N));
8720                     AddToPrintString (tempStr);
8721                     }
8722                 else
8723                     AddToPrintString(")");
8724                 }
8725             }
8726         }
8727     free (tempStr);
8728 }
8729
8730
8731 /* WriteTopologyToFile: Simply write topology to file */
8732 void WriteTopologyToFile (FILE *fp, TreeNode *p, int isRooted)
8733 {
8734     if (p != NULL)
8735         {
8736         if (p->left == NULL && p->right == NULL)
8737             fprintf (fp, "%d", p->index + 1);
8738         else
8739             {
8740             if (p->anc != NULL)
8741                 fprintf (fp, "(");
8742             WriteTopologyToFile (fp, p->left, isRooted);
8743             if (p->anc != NULL)
8744                 fprintf (fp, ",");
8745             WriteTopologyToFile (fp, p->right, isRooted);
8746             if (p->anc != NULL)
8747                 {
8748                 if (p->anc->anc == NULL && isRooted == NO)
8749                     fprintf (fp, ",%d", p->anc->index + 1);
8750                 fprintf (fp, ")");
8751                 }
8752             }
8753         }
8754 }
8755
8756
8757 /* the following are moved from mbmath.c */
8758 /*---------------------------------------------------------------------------------
8759 |
8760 |   AddTwoMatrices
8761 |
8762 |   Takes the sum of two matrices, "a" and "b", and puts the results in a matrix
8763 |   called "result".
8764 |
8765 ---------------------------------------------------------------------------------*/
8766 void AddTwoMatrices (int dim, MrBFlt **a, MrBFlt **b, MrBFlt **result)
8767 {
8768     int         row, col;
8769
8770     for (row=0; row<dim; row++)
8771         {
8772         for (col=0; col<dim; col++)
8773             {
8774             result[row][col] = a[row][col] + b[row][col];
8775             }
8776         }
8777 }
8778
8779
8780 /*---------------------------------------------------------------------------------
8781 |
8782 |   AllocateSquareComplexMatrix
8783 |
8784 |   Allocate memory for a square (dim X dim) complex matrix.
8785 |
8786 ---------------------------------------------------------------------------------*/
8787 complex **AllocateSquareComplexMatrix (int dim)
8788 {
8789     int         i;
8790     complex     **m;
8791
8792     m = (complex **) SafeMalloc ((size_t)dim * sizeof(complex*));
8793     if (!m)
8794         {
8795         MrBayesPrint ("%s   Error: Problem allocating a square complex matrix.\n", spacer);
8796         exit (0);
8797         }
8798     m[0]=(complex *) SafeMalloc ((size_t)dim * (size_t)dim *sizeof(complex));
8799     if (!m[0])
8800         {
8801         MrBayesPrint ("%s   Error: Problem allocating a square complex matrix.\n", spacer);
8802         exit (0);
8803         }
8804     for (i=1;i<dim;i++)
8805         {
8806         m[i] = m[i-1] + dim;
8807         }
8808
8809     return (m);
8810 }
8811
8812
8813 /*---------------------------------------------------------------------------------
8814 |
8815 |   AllocateSquareDoubleMatrix
8816 |
8817 |   Allocate memory for a square (dim X dim) matrix of doubles.
8818 |
8819 ---------------------------------------------------------------------------------*/
8820 MrBFlt **AllocateSquareDoubleMatrix (int dim)
8821 {
8822     int         i;
8823     MrBFlt      **m;
8824
8825     m = (MrBFlt **) SafeMalloc ((size_t)dim * sizeof(MrBFlt*));
8826     if (!m)
8827         {
8828         MrBayesPrint ("%s   Error: Problem allocating a square matrix of doubles.\n", spacer);
8829         exit(1);
8830         }
8831     m[0] = (MrBFlt *) SafeMalloc ((size_t)dim * (size_t)dim * sizeof(MrBFlt));
8832     if (!m[0])
8833         {
8834         MrBayesPrint ("%s   Error: Problem allocating a square matrix of doubles.\n", spacer);
8835         exit(1);
8836         }
8837     for (i=1; i<dim; i++)
8838         {
8839         m[i] = m[i-1] + dim;
8840         }
8841
8842     return (m);
8843 }
8844
8845
8846 /*---------------------------------------------------------------------------------
8847 |
8848 |   AllocateSquareIntegerMatrix
8849 |
8850 |   Allocate memory for a square (dim X dim) matrix of integers.
8851 |
8852 ---------------------------------------------------------------------------------*/
8853 int **AllocateSquareIntegerMatrix (int dim)
8854 {
8855     int     i, **m;
8856
8857     m = (int **) SafeMalloc ((size_t)dim * sizeof(int*));
8858     if (!m)
8859         {
8860         MrBayesPrint ("%s   Error: Problem allocating a square matrix of integers.\n", spacer);
8861         exit(1);
8862         }
8863     m[0] = (int *) SafeMalloc ((size_t)dim * (size_t)dim * sizeof(int));
8864     if (!m[0])
8865         {
8866         MrBayesPrint ("%s   Error: Problem allocating a square matrix of integers.\n", spacer);
8867         exit(1);
8868         }
8869     for (i=1; i<dim; i++)
8870         {
8871         m[i] = m[i-1] + dim;
8872         }
8873
8874     return (m);
8875 }
8876
8877
8878 /*---------------------------------------------------------------------------------
8879 |
8880 |   AutodGamma
8881 |
8882 |   Auto-discrete-gamma distribution of rates over sites, K equal-probable
8883 |   categories, with the mean for each category used.
8884 |   This routine calculates M[], using rho and K (numGammaCats)
8885 |
8886 ---------------------------------------------------------------------------------*/
8887 int AutodGamma (MrBFlt *M, MrBFlt rho, int K)
8888 {
8889     int         i, j, i1, i2;
8890     MrBFlt      point[MAX_GAMMA_CATS], x, y, large = 20.0, sum;
8891
8892     for (i=0; i<K-1; i++)
8893         point[i] = PointNormal ((i + 1.0) / K);
8894     for (i=0; i<K; i++)
8895         {
8896         for (j=0; j<K; j++)
8897             {
8898             x = (i < K-1 ? point[i]:large);
8899             y = (j < K-1 ? point[j]:large);
8900             M[i * K + j] = CdfBinormal (x, y, rho);
8901             }
8902         }
8903     for (i1=0; i1<2*K-1; i1++)
8904         {
8905         for (i2=0; i2<K*K; i2++)
8906             {
8907             i = i2 / K;
8908             j = i2 % K;
8909             if (AreDoublesEqual(i+j, 2*(K-1.0)-i1, ETA)==NO)
8910                 continue;
8911             y = 0;
8912             if (i > 0)
8913                 y -= M[(i-1)*K+j];
8914             if (j > 0)
8915                 y -= M[i*K+(j-1)];
8916             if (i > 0 && j > 0)
8917                 y += M[(i-1)*K+(j-1)];
8918             M[i*K+j] = (M[i*K+j] + y) * K;
8919             }
8920         }
8921     for (i=0; i<K; i++)
8922         {
8923         sum = 0.0;
8924         for (j=0; j<K; j++)
8925             {
8926             if (M[i*K+j] < 0.0)
8927                 M[i*K+j] = 0.0;
8928             sum += M[i*K+j];
8929             }
8930         for (j=0; j<K; j++)
8931             M[i*K+j] /= sum;
8932         }
8933
8934 //    MrBayesPrint ("rho = %lf\n", rho);
8935 //    for (i=0; i<K; i++)
8936 //        {
8937 //        for (j=0; j<K; j++)
8938 //            MrBayesPrint ("%lf ", M[i*K + j]);
8939 //        MrBayesPrint ("\n");
8940 //        }
8941
8942     return (NO_ERROR);
8943 }
8944
8945
8946 /*---------------------------------------------------------------------------------
8947 |
8948 |   BackSubstitutionRow
8949 |
8950 ---------------------------------------------------------------------------------*/
8951 void BackSubstitutionRow (int dim, MrBFlt **u, MrBFlt *b)
8952 {
8953     int             i, j;
8954     MrBFlt          dotProduct;
8955
8956     b[dim-1] /= u[dim-1][dim-1];
8957     for (i=dim-2; i>=0; i--)
8958         {
8959         dotProduct = 0.0;
8960         for (j=i+1; j<dim; j++)
8961             dotProduct += u[i][j] * b[j];
8962         b[i] = (b[i] - dotProduct) / u[i][i];
8963         }
8964 }
8965
8966
8967 /*---------------------------------------------------------------------------------
8968 |
8969 |   Balanc
8970 |
8971 |   This subroutine balances a real matrix and isolates
8972 |   eigenvalues whenever possible.
8973 |
8974 |   On input:
8975 |
8976 |    * dim is the order of the matrix
8977 |
8978 |    * a contains the input matrix to be balanced
8979 |
8980 |   On output:
8981 |
8982 |    * a contains the balanced matrix.
8983 |
8984 |    * low and high are two integers such that a(i,j)
8985 |      is equal to zero if
8986 |         (1) i is greater than j and
8987 |         (2) j=1,...,low-1 or i=igh+1,...,n.
8988 |
8989 |    * scale contains information determining the
8990 |      permutations and scaling factors used.
8991 |
8992 |   Suppose that the principal submatrix in rows pLow through pHigh
8993 |   has been balanced, that p(j) denotes the index interchanged
8994 |   with j during the permutation step, and that the elements
8995 |   of the diagonal matrix used are denoted by d(i,j). Then
8996 |      scale(j) = p(j),    for j = 1,...,pLow-1
8997 |               = d(j,j),      j = pLow,...,pHigh
8998 |               = p(j)         j = pHigh+1,...,dim.
8999 |   The order in which the interchanges are made is dim to pHigh+1,
9000 |   then 1 to pLow-1.
9001 |
9002 |   Note that 1 is returned for pHigh if pHigh is zero formally.
9003 |
9004 |   The algol procedure exc contained in balance appears in
9005 |   balanc in line.  (Note that the algol roles of identifiers
9006 |   k,l have been reversed.)
9007 |
9008 |   This routine is a translation of the Algol procedure from
9009 |   Handbook for Automatic Computation, vol. II, Linear Algebra,
9010 |   by Wilkinson and Reinsch, Springer-Verlag.
9011 |
9012 |   This function was converted from FORTRAN by D. L. Swofford.
9013 |
9014 ---------------------------------------------------------------------------------*/
9015 void Balanc (int dim, MrBFlt **a, int *low, int *high, MrBFlt *scale)
9016 {
9017     int         i, j, k, l, m, noconv;
9018     MrBFlt      c, f, g, r, s, b2;
9019
9020     b2 = FLT_RADIX * FLT_RADIX;
9021     k = 0;
9022     l = dim - 1;
9023
9024     for (j=l; j>=0; j--)
9025         {
9026         for (i=0; i<=l; i++)
9027             {
9028             if (i != j)
9029                 {
9030                   if (AreDoublesEqual(a[j][i],0.0, ETA)==NO)
9031                     goto next_j1;
9032                 }
9033             }
9034
9035         /* bug that DLS caught */
9036         /*m = l;
9037         Exchange(j, k, l, m, dim, a, scale);
9038         if (l < 0)
9039             goto leave;
9040         else
9041             j = --l;*/
9042         m = l;
9043         Exchange(j, k, l, m, dim, a, scale);
9044         if (--l < 0)
9045             goto leave;
9046         next_j1:
9047             ;
9048         }
9049
9050     for (j=k; j<=l; j++)
9051         {
9052         for (i=k; i<=l; i++)
9053             {
9054             if (i != j)
9055                 {
9056                 if (AreDoublesEqual(a[i][j], 0.0, ETA)==NO)
9057                     goto next_j;
9058                 }
9059             }
9060         m = k;
9061         Exchange(j, k, l, m, dim, a, scale);
9062         k++;
9063         next_j:
9064             ;
9065         }
9066
9067     for (i=k; i<=l; i++)
9068         scale[i] = 1.0;
9069
9070     do  {
9071         noconv = FALSE;
9072         for (i=k; i<=l; i++)
9073             {
9074             c = 0.0;
9075             r = 0.0;
9076             for (j=k; j<=l; j++)
9077                 {
9078                 if (j != i)
9079                     {
9080                     c += fabs(a[j][i]);
9081                     r += fabs(a[i][j]);
9082                     }
9083                 }
9084             if (AreDoublesEqual(c,0.0,ETA)==NO && AreDoublesEqual(r,0.0,ETA)==NO)
9085                 {
9086                 g = r / FLT_RADIX;
9087                 f = 1.0;
9088                 s = c + r;
9089                 while (c < g)
9090                     {
9091                     f *= FLT_RADIX;
9092                     c *= b2;
9093                     }
9094                 g = r * FLT_RADIX;
9095                 while (c >= g)
9096                     {
9097                     f /= FLT_RADIX;
9098                     c /= b2;
9099                     }
9100                 if ((c + r) / f < s * .95)
9101                     {
9102                     g = 1.0 / f;
9103                     scale[i] *= f;
9104                     noconv = TRUE;
9105                     for (j=k; j<dim; j++)
9106                         a[i][j] *= g;
9107                     for (j=0; j<=l; j++)
9108                         a[j][i] *= f;
9109                     }
9110                 }
9111             }
9112         }
9113         while (noconv);
9114     leave:
9115         *low = k;
9116         *high = l;
9117
9118 #   if 0
9119 /* begin f2c version of code:
9120    balanc.f -- translated by f2c (version 19971204) */
9121 int balanc (int *nm, int *n, MrBFlt *a, int *low, int *igh, MrBFlt *scale)
9122
9123 {
9124
9125     /* System generated locals */
9126     int a_dim1, a_offset, i__1, i__2;
9127     MrBFlt d__1;
9128
9129     /* Local variables */
9130     static MrBFlt iexc;
9131     static MrBFlt c__, f, g;
9132     static MrBFlt i__, j, k, l, m;
9133     static MrBFlt r__, s, radix, b2;
9134     static MrBFlt jj;
9135     static logical noconv;
9136
9137     /* parameter adjustments */
9138     --scale;
9139     a_dim1 = *nm;
9140     a_offset = a_dim1 + 1;
9141     a -= a_offset;
9142
9143     /* function Body */
9144     radix = 16.0;
9145
9146     b2 = radix * radix;
9147     k = 1;
9148     l = *n;
9149     goto L100;
9150
9151     /* .......... in-line procedure for row and column exchange .......... */
9152     L20:
9153     scale[m] = (MrBFlt) j;
9154     if (j == m)
9155         goto L50;
9156
9157     i__1 = l;
9158     for (i__ = 1; i__ <= i__1; ++i__)
9159         {
9160         f = a[i__ + j * a_dim1];
9161         a[i__ + j * a_dim1] = a[i__ + m * a_dim1];
9162         a[i__ + m * a_dim1] = f;
9163         /* L30: */
9164         }
9165
9166     i__1 = *n;
9167     for (i__ = k; i__ <= i__1; ++i__)
9168         {
9169         f = a[j + i__ * a_dim1];
9170         a[j + i__ * a_dim1] = a[m + i__ * a_dim1];
9171         a[m + i__ * a_dim1] = f;
9172         /* L40: */
9173         }
9174
9175     L50:
9176     switch (iexc)
9177         {
9178         case 1:
9179             goto L80;
9180         case 2:
9181             goto L130;
9182         }
9183
9184     /* .......... search for rows isolating an eigenvalue and push them down .......... */
9185     L80:
9186     if (l == 1)
9187         goto L280;
9188     --l;
9189
9190     /* .......... for j=l step -1 until 1 do -- .......... */
9191     L100:
9192     i__1 = l;
9193     for (jj = 1; jj <= i__1; ++jj)
9194         {
9195         j = l + 1 - jj;
9196         i__2 = l;
9197         for (i__ = 1; i__ <= i__2; ++i__)
9198             {
9199             if (i__ == j)
9200                 goto L110;
9201             if (a[j + i__ * a_dim1] != 0.)
9202                 goto L120;
9203             L110:
9204             ;
9205             }
9206         m = l;
9207         iexc = 1;
9208         goto L20;
9209         L120:
9210         ;
9211         }
9212
9213     goto L140;
9214     /* .......... search for columns isolating an eigenvalue and push them left .......... */
9215     L130:
9216     ++k;
9217
9218     L140:
9219     i__1 = l;
9220     for (j = k; j <= i__1; ++j)
9221         {
9222         i__2 = l;
9223         for (i__ = k; i__ <= i__2; ++i__)
9224             {
9225             if (i__ == j)
9226                 goto L150;
9227             if (a[i__ + j * a_dim1] != 0.)
9228                 goto L170;
9229             L150:
9230             ;
9231             }
9232         m = k;
9233         iexc = 2;
9234         goto L20;
9235         L170:
9236         ;
9237         }
9238
9239     /* .......... now balance the submatrix in rows k to l .......... */
9240     i__1 = l;
9241     for (i__ = k; i__ <= i__1; ++i__)
9242         {
9243         /* L180: */
9244         scale[i__] = 1.0;
9245         }
9246     /* .......... iterative loop for norm reduction .......... */
9247     L190:
9248     noconv = FALSE;
9249
9250     i__1 = l;
9251     for (i__ = k; i__ <= i__1; ++i__)
9252         {
9253         c__ = 0.0;
9254         r__ = 0.0;
9255         i__2 = l;
9256         for (j = k; j <= i__2; ++j)
9257             {
9258             if (j == i__)
9259                 goto L200;
9260             c__ += (d__1 = a[j + i__ * a_dim1], abs(d__1));
9261             r__ += (d__1 = a[i__ + j * a_dim1], abs(d__1));
9262             L200:
9263             ;
9264             }
9265
9266         /* .......... guard against zero c or r due to underflow .......... */
9267         if (c__ == 0. || r__ == 0.)
9268             goto L270;
9269         g = r__ / radix;
9270         f = 1.0;
9271         s = c__ + r__;
9272         L210:
9273         if (c__ >= g)
9274             goto L220;
9275         f *= radix;
9276         c__ *= b2;
9277         goto L210;
9278         L220:
9279         g = r__ * radix;
9280         L230:
9281         if (c__ < g)
9282             goto L240;
9283         f /= radix;
9284         c__ /= b2;
9285         goto L230;
9286
9287         /*     .......... now balance .......... */
9288         L240:
9289         if ((c__ + r__) / f >= s * .95)
9290             goto L270;
9291         g = 1.0 / f;
9292         scale[i__] *= f;
9293         noconv = TRUE;
9294
9295         i__2 = *n;
9296         for (j = k; j <= i__2; ++j)
9297             {
9298             /* L250: */
9299             a[i__ + j * a_dim1] *= g;
9300             }
9301
9302         i__2 = l;
9303         for (j = 1; j <= i__2; ++j)
9304             {
9305             /* L260: */
9306             a[j + i__ * a_dim1] *= f;
9307             }
9308
9309         L270:
9310         ;
9311         }
9312
9313     if (noconv)
9314         goto L190;
9315
9316     L280:
9317     *low = k;
9318     *igh = l;
9319     return 0;
9320
9321 }
9322 /* end f2c version of code */
9323 #   endif
9324
9325 }
9326
9327
9328 /*---------------------------------------------------------------------------------
9329 |
9330 |   BalBak
9331 |
9332 |   This subroutine forms the eigenvectors of a real general
9333 |   matrix by back transforming those of the corresponding
9334 |   balanced matrix determined by  balance.
9335 |
9336 |   On input:
9337 |
9338 |    * dim is the order of the matrix
9339 |
9340 |    * low and high are integers determined by  balance
9341 |
9342 |    * scale contains information determining the permutations
9343 |      and scaling factors used by balance
9344 |
9345 |    * m is the number of columns of z to be back transformed
9346 |
9347 |    * z contains the real and imaginary parts of the eigen-
9348 |      vectors to be back transformed in its first m columns
9349 |
9350 |   On output:
9351 |
9352 |    * z contains the real and imaginary parts of the
9353 |      transformed eigenvectors in its first m columns
9354 |
9355 |   This routine is a translation of the Algol procedure from
9356 |   Handbook for Automatic Computation, vol. II, Linear Algebra,
9357 |   by Wilkinson and Reinsch, Springer-Verlag.
9358 |
9359 ---------------------------------------------------------------------------------*/
9360 void BalBak (int dim, int low, int high, MrBFlt *scale, int m, MrBFlt **z)
9361 {
9362     int         i, j, k, ii;
9363     MrBFlt      s;
9364
9365     if (m != 0) /* change "==" to "!=" to eliminate a goto statement */
9366         {
9367         if (high != low) /* change "==" to "!=" to eliminate a goto statement */
9368             {
9369             for (i=low; i<=high; i++)
9370                 {
9371                 s = scale[i];
9372                 for (j=0; j<m; j++)
9373                     z[i][j] *= s;
9374                 }
9375             }
9376         for (ii=0; ii<dim; ii++)
9377             {
9378             i = ii;
9379             if ((i < low) || (i > high)) /* was (i >= lo) && (i<= hi) but this */
9380                 {                        /* eliminates a goto statement        */
9381                 if (i < low)
9382                     i = low - ii;
9383                 k = (int)scale[i];
9384                 if (k != i) /* change "==" to "!=" to eliminate a goto statement */
9385                     {
9386                     for (j = 0; j < m; j++)
9387                         {
9388                         s = z[i][j];
9389                         z[i][j] = z[k][j];
9390                         z[k][j] = s;
9391                         }
9392                     }
9393                 }
9394             }
9395         }
9396
9397 #if 0
9398 /* begin f2c version of code:
9399    balbak.f -- translated by f2c (version 19971204) */
9400 int balbak (int *nm, int *n, int *low, int *igh, MrBFlt *scale, int *m, MrBFlt *z__)
9401
9402 {
9403
9404     /* system generated locals */
9405     int z_dim1, z_offset, i__1, i__2;
9406
9407     /* Local variables */
9408     static int i__, j, k;
9409     static MrBFlt s;
9410     static int ii;
9411
9412     /* parameter adjustments */
9413     --scale;
9414     z_dim1 = *nm;
9415     z_offset = z_dim1 + 1;
9416     z__ -= z_offset;
9417
9418     /* function Body */
9419     if (*m == 0)
9420         goto L200;
9421     if (*igh == *low)
9422         goto L120;
9423
9424     i__1 = *igh;
9425     for (i__ = *low; i__ <= i__1; ++i__)
9426         {
9427         s = scale[i__];
9428         /* .......... left hand eigenvectors are back transformed */
9429         /*            if the foregoing statement is replaced by */
9430         /*            s=1.0d0/scale(i) ........... */
9431         i__2 = *m;
9432         for (j = 1; j <= i__2; ++j)
9433             {
9434             /* L100: */
9435             z__[i__ + j * z_dim1] *= s;
9436             }
9437
9438         /* L110: */
9439         }
9440
9441     /* .........for i=low-1 step -1 until 1, igh+1 step 1 until n do -- .......... */
9442     L120:
9443     i__1 = *n;
9444     for (ii = 1; ii <= i__1; ++ii)
9445         {
9446         i__ = ii;
9447         if (i__ >= *low && i__ <= *igh)
9448             goto L140;
9449     if (i__ < *low)
9450         i__ = *low - ii;
9451     k = (integer) scale[i__];
9452     if (k == i__)
9453         goto L140;
9454
9455     i__2 = *m;
9456     for (j = 1; j <= i__2; ++j)
9457         {
9458         s = z__[i__ + j * z_dim1];
9459         z__[i__ + j * z_dim1] = z__[k + j * z_dim1];
9460         z__[k + j * z_dim1] = s;
9461         /* L130: */
9462         }
9463     L140:
9464     ;
9465     }
9466
9467     L200:
9468     return 0;
9469
9470 }
9471 /* end f2c version of code */
9472 #endif
9473
9474 }
9475
9476
9477 void BetaBreaks (MrBFlt alpha, MrBFlt beta, MrBFlt *values, int K)
9478 {
9479     int             i;
9480     MrBFlt          r, quantile, lower, upper;
9481
9482     r = (1.0 / K) * 0.5;
9483     lower = 0.0;
9484     upper = (1.0 / K);
9485     r = (upper - lower) * 0.5 + lower;
9486     for (i=0; i<K; i++)
9487         {
9488         quantile = BetaQuantile (alpha, beta, r);
9489         values[i] = quantile;
9490         lower += (1.0/K);
9491         upper += (1.0/K);
9492         r += (1.0/K);
9493         }
9494
9495 #   if 0
9496     for (i=0; i<K; i++)
9497         {
9498         MrBayesPrint ("%4d %lf %lf\n", i, values[i]);
9499         }
9500 #   endif
9501 }
9502
9503
9504 MrBFlt BetaCf (MrBFlt a, MrBFlt b, MrBFlt x)
9505 {
9506     int         m, m2;
9507     MrBFlt      aa, c, d, del, h, qab, qam, qap;
9508
9509     qab = a + b;
9510     qap = a + 1.0;
9511     qam = a - 1.0;
9512     c = 1.0;
9513     d = 1.0 - qab * x / qap;
9514     if (fabs(d) < (1.0e-30))
9515         d = (1.0e-30);
9516     d = 1.0 / d;
9517     h = d;
9518     for (m=1; m<=100; m++)
9519         {
9520         m2 = 2 * m;
9521         aa = m * (b-m) * x / ((qam+m2) * (a+m2));
9522         d = 1.0 + aa * d;
9523         if (fabs(d) < (1.0e-30))
9524             d = (1.0e-30);
9525         c = 1.0 + aa / c;
9526         if (fabs(c) < (1.0e-30))
9527             c = (1.0e-30);
9528         d = 1.0 / d;
9529         h *= d * c;
9530         aa = -(a+m) * (qab+m) * x / ((a+m2) * (qap+m2));
9531         d = 1.0 + aa * d;
9532         if (fabs(d) < (1.0e-30))
9533             d = (1.0e-30);
9534         c = 1.0 + aa / c;
9535         if (fabs(c) < (1.0e-30))
9536             c = (1.0e-30);
9537         d = 1.0 / d;
9538         del = d * c;
9539         h *= del;
9540         if (fabs(del - 1.0) < (3.0e-7))
9541             break;
9542         }
9543     if (m > 100)
9544         {
9545         MrBayesPrint ("%s   Error in BetaCf.\n", spacer);
9546         exit(0);
9547         }
9548     return (h);
9549 }
9550
9551
9552 MrBFlt BetaQuantile (MrBFlt alpha, MrBFlt beta, MrBFlt x)
9553 {
9554     int     i, stopIter, direction, nswitches;
9555     MrBFlt  curPos, curFraction, increment;
9556
9557     i = nswitches = 0;
9558     curPos = 0.5;
9559     stopIter = NO;
9560     increment = 0.25;
9561     curFraction = IncompleteBetaFunction (alpha, beta, curPos);
9562     if (curFraction > x)
9563         direction = DOWN;
9564     else
9565         direction = UP;
9566
9567     while (stopIter == NO)
9568         {
9569         curFraction = IncompleteBetaFunction (alpha, beta, curPos);
9570         if (curFraction > x && direction == DOWN)
9571             {
9572             /* continue going down */
9573             while (curPos - increment <= 0.0)
9574                 {
9575                 increment /= 2.0;
9576                 }
9577             curPos -= increment;
9578             }
9579         else if (curFraction > x && direction == UP)
9580             {
9581             /* switch directions, and go down */
9582             nswitches++;
9583             direction = DOWN;
9584             while (curPos - increment <= 0.0)
9585                 {
9586                 increment /= 2.0;
9587                 }
9588             increment /= 2.0;
9589             curPos -= increment;
9590             }
9591         else if (curFraction < x && direction == UP)
9592             {
9593             /* continue going up */
9594             while (curPos + increment >= 1.0)
9595                 {
9596                 increment /= 2.0;
9597                 }
9598             curPos += increment;
9599             }
9600         else if (curFraction < x && direction == DOWN)
9601             {
9602             /* switch directions, and go up */
9603             nswitches++;
9604             direction = UP;
9605             while (curPos + increment >= 1.0)
9606                 {
9607                 increment /= 2.0;
9608                 }
9609             increment /= 2.0;
9610             curPos += increment;
9611             }
9612         else
9613             {
9614             stopIter = YES;
9615             }
9616         if (i > 1000 || nswitches > 20)
9617             stopIter = YES;
9618         i++;
9619         }
9620
9621     return (curPos);
9622 }
9623
9624
9625 /*---------------------------------------------------------------------------------
9626 |
9627 |   CalcCijk
9628 |
9629 |   This function precalculates the product of the eigenvectors and their
9630 |   inverse for faster calculation of transition probabilities. The output
9631 |   is a vector of precalculated values. The input is the eigenvectors (u) and
9632 |   the inverse of the eigenvector matrix (v).
9633 |
9634 ---------------------------------------------------------------------------------*/
9635 void CalcCijk (int dim, MrBFlt *c_ijk, MrBFlt **u, MrBFlt **v)
9636 {
9637     register int    i, j, k;
9638     MrBFlt          *pc;
9639
9640     pc = c_ijk;
9641     for (i=0; i<dim; i++)
9642         for (j=0; j<dim; j++)
9643             for (k=0; k<dim; k++)
9644                 *pc++ = u[i][k] * v[k][j];
9645 }
9646
9647
9648 /*---------------------------------------------------------------------------------
9649 |
9650 |   CdfBinormal
9651 |
9652 |   F(h1,h2,r) = prob(x<h1, y<h2), where x and y are standard binormal.
9653 |
9654 ---------------------------------------------------------------------------------*/
9655 MrBFlt CdfBinormal (MrBFlt h1, MrBFlt h2, MrBFlt r)
9656 {
9657     return (LBinormal(h1, h2, r) + CdfNormal(h1) + CdfNormal(h2) - 1.0);
9658 }
9659
9660
9661 /*---------------------------------------------------------------------------------
9662 |
9663 |   CdfNormal
9664 |
9665 |   Calculates the cumulative density distribution (CDF) for the normal using:
9666 |
9667 |   Hill, I. D.  1973.  The normal integral.  Applied Statistics, 22:424-427.
9668 |      (AS66)
9669 |
9670 ---------------------------------------------------------------------------------*/
9671 MrBFlt CdfNormal (MrBFlt x)
9672 {
9673     int             invers = 0;
9674     MrBFlt          p, limit = 10.0, t = 1.28, y = x*x/2.0;
9675
9676     if (x < 0.0)
9677         {
9678         invers = 1;
9679         x  *= -1.0;
9680         }
9681     if (x > limit)
9682         return (invers ? 0 : 1);
9683     if (x < t)
9684         p = 0.5 - x * (0.398942280444 - 0.399903438504 * y /
9685             (y + 5.75885480458 - 29.8213557808 /
9686             (y + 2.62433121679 + 48.6959930692 /
9687             (y + 5.92885724438))));
9688     else
9689         p = 0.398942280385 * exp(-y) /
9690             (x - 3.8052e-8 + 1.00000615302 /
9691             (x + 3.98064794e-4 + 1.98615381364 /
9692             (x - 0.151679116635 + 5.29330324926 /
9693             (x + 4.8385912808 - 15.1508972451 /
9694             (x + 0.742380924027 + 30.789933034 /
9695             (x + 3.99019417011))))));
9696
9697     return (invers ? p : 1-p);
9698 }
9699
9700
9701 /*---------------------------------------------------------------------------------
9702 |
9703 |   Complex
9704 |
9705 |   Returns a complex number with specified real and imaginary parts.
9706 |
9707 ---------------------------------------------------------------------------------*/
9708 complex Complex (MrBFlt a, MrBFlt b)
9709 {
9710     complex c;
9711
9712     c.re = a;
9713     c.im = b;
9714
9715     return (c);
9716 }
9717
9718
9719 /*---------------------------------------------------------------------------------
9720 |
9721 |   ComplexAbsoluteValue
9722 |
9723 |   Returns the complex absolute value (modulus) of a complex number.
9724 |
9725 ---------------------------------------------------------------------------------*/
9726 MrBFlt ComplexAbsoluteValue (complex a)
9727 {
9728     MrBFlt      x, y, answer, temp;
9729
9730     x = fabs(a.re);
9731     y = fabs(a.im);
9732     if (AreDoublesEqual(x, 0.0, ETA)==YES)  /* x == 0.0 */
9733         answer = y;
9734     else if (AreDoublesEqual(y, 0.0, ETA)==YES) /* y == 0.0 */
9735         answer = x;
9736     else if (x > y)
9737         {
9738         temp = y / x;
9739         answer = x * sqrt(1.0 + temp * temp);
9740         }
9741     else
9742         {
9743         temp = x / y;
9744         answer = y * sqrt(1.0 + temp * temp);
9745         }
9746
9747     return (answer);
9748 }
9749
9750
9751 /*---------------------------------------------------------------------------------
9752 |
9753 |   ComplexAddition
9754 |
9755 |   Returns the complex sum of two complex numbers.
9756 |
9757 ---------------------------------------------------------------------------------*/
9758 complex ComplexAddition (complex a, complex b)
9759 {
9760     complex     c;
9761
9762     c.re = a.re + b.re;
9763     c.im = a.im + b.im;
9764
9765     return (c);
9766 }
9767
9768
9769 /*---------------------------------------------------------------------------------
9770 |
9771 |   ComplexConjugate
9772 |
9773 |   Returns the complex conjugate of a complex number.
9774 |
9775 ---------------------------------------------------------------------------------*/
9776 complex ComplexConjugate (complex a)
9777 {
9778     complex     c;
9779
9780     c.re = a.re;
9781     c.im = -a.im;
9782
9783     return (c);
9784 }
9785
9786
9787 /*---------------------------------------------------------------------------------
9788 |
9789 |   ComplexDivision
9790 |
9791 |   Returns the complex quotient of two complex numbers.
9792 |
9793 ---------------------------------------------------------------------------------*/
9794 complex ComplexDivision (complex a, complex b)
9795 {
9796     complex     c;
9797     MrBFlt      r, den;
9798
9799     if (fabs(b.re) >= fabs(b.im))
9800         {
9801         r = b.im / b.re;
9802         den = b.re + r * b.im;
9803         c.re = (a.re + r * a.im) / den;
9804         c.im = (a.im - r * a.re) / den;
9805         }
9806     else
9807         {
9808         r = b.re / b.im;
9809         den = b.im + r * b.re;
9810         c.re = (a.re * r + a.im) / den;
9811         c.im = (a.im * r - a.re) / den;
9812         }
9813
9814     return (c);
9815 }
9816
9817
9818 /*---------------------------------------------------------------------------------
9819 |
9820 |   ComplexDivision2
9821 |
9822 |   Returns the complex quotient of two complex numbers. It does not require that
9823 |   the numbers be in a complex structure.
9824 |
9825 ---------------------------------------------------------------------------------*/
9826 void ComplexDivision2 (MrBFlt ar, MrBFlt ai, MrBFlt br, MrBFlt bi, MrBFlt *cr, MrBFlt *ci)
9827 {
9828     MrBFlt      s, ais, bis, ars, brs;
9829
9830     s = fabs(br) + fabs(bi);
9831     ars = ar / s;
9832     ais = ai / s;
9833     brs = br / s;
9834     bis = bi / s;
9835     s = brs*brs + bis*bis;
9836     *cr = (ars*brs + ais*bis) / s;
9837     *ci = (ais*brs - ars*bis) / s;
9838 }
9839
9840
9841 /*---------------------------------------------------------------------------------
9842 |
9843 |   ComplexExponentiation
9844 |
9845 |   Returns the complex exponential of a complex number.
9846 |
9847 ---------------------------------------------------------------------------------*/
9848 complex ComplexExponentiation (complex a)
9849 {
9850     complex     c;
9851
9852     c.re = exp(a.re);
9853     if (AreDoublesEqual(a.im,0.0, ETA)==YES) /* == 0 */
9854         c.im = 0;
9855     else
9856         {
9857         c.im = c.re*sin(a.im);
9858         c.re *= cos(a.im);
9859         }
9860
9861     return (c);
9862 }
9863
9864
9865 /*---------------------------------------------------------------------------------
9866 |
9867 |   ComplexInvertMatrix
9868 |
9869 |   Inverts a matrix of complex numbers using the LU-decomposition method.
9870 |   The program has the following variables:
9871 |
9872 |      a        -- the matrix to be inverted
9873 |      aInverse -- the results of the matrix inversion
9874 |      dim      -- the dimension of the square matrix a and its inverse
9875 |      dwork    -- a work vector of doubles
9876 |      indx     -- a work vector of integers
9877 |      col      -- carries the results of the back substitution
9878 |
9879 |   The function returns YES (1) or NO (0) if the results are singular.
9880 |
9881 ---------------------------------------------------------------------------------*/
9882 int ComplexInvertMatrix (int dim, complex **a, MrBFlt *dwork, int *indx, complex **aInverse, complex *col)
9883 {
9884     int             isSingular, i, j;
9885
9886     isSingular = ComplexLUDecompose (dim, a, dwork, indx, (MrBFlt *)NULL);
9887
9888     if (isSingular == 0)
9889         {
9890         for (j=0; j<dim; j++)
9891             {
9892             for (i=0; i<dim; i++)
9893                 col[i] = Complex (0.0, 0.0);
9894             col[j] = Complex (1.0, 0.0);
9895             ComplexLUBackSubstitution (dim, a, indx, col);
9896             for (i=0; i<dim; i++)
9897                 aInverse[i][j] = col[i];
9898             }
9899         }
9900
9901     return (isSingular);
9902 }
9903
9904
9905 /*---------------------------------------------------------------------------------
9906 |
9907 |   ComplexExponentiation
9908 |
9909 |   Returns the complex exponential of a complex number.
9910 |
9911 ---------------------------------------------------------------------------------*/
9912 complex ComplexLog (complex a)
9913 {
9914     complex     c;
9915
9916     c.re = log(ComplexAbsoluteValue(a));
9917     if (AreDoublesEqual(a.re,0.0,ETA)==YES) /* == 0.0 */
9918         {
9919         c.im = PIOVER2;
9920         }
9921     else
9922         {
9923         c.im = atan2(a.im, a.re);
9924         }
9925
9926     return (c);
9927 }
9928
9929
9930 /*---------------------------------------------------------------------------------
9931 |
9932 |   ComplexLUBackSubstitution
9933 |
9934 |   Perform back-substitution into a LU-decomposed matrix to obtain
9935 |   the inverse.
9936 |
9937 ---------------------------------------------------------------------------------*/
9938 void ComplexLUBackSubstitution (int dim, complex **a, int *indx, complex *b)
9939 {
9940     int             i, ip, j, ii = -1;
9941     complex         sum;
9942
9943     for (i = 0; i < dim; i++)
9944         {
9945         ip = indx[i];
9946         sum = b[ip];
9947         b[ip] = b[i];
9948         if (ii >= 0)
9949             {
9950             for (j = ii; j <= i - 1; j++)
9951                 sum = ComplexSubtraction (sum, ComplexMultiplication (a[i][j], b[j]));
9952             }
9953         else if (AreDoublesEqual(sum.re,0.0,ETA)==NO || AreDoublesEqual(sum.im, 0.0, ETA)==NO) /* 2x != 0.0 */
9954             ii = i;
9955         b[i] = sum;
9956         }
9957     for (i = dim - 1; i >= 0; i--)
9958         {
9959         sum = b[i];
9960         for (j = i + 1; j < dim; j++)
9961             sum = ComplexSubtraction (sum, ComplexMultiplication (a[i][j], b[j]));
9962         b[i] = ComplexDivision (sum, a[i][i]);
9963         }
9964 }
9965
9966
9967 /*---------------------------------------------------------------------------------
9968 |
9969 |   ComplexLUDecompose
9970 |
9971 |   Replaces the matrix a with its LU-decomposition.
9972 |   The program has the following variables:
9973 |
9974 |      a        -- the matrix
9975 |      dim      -- the dimension of the square matrix a and its inverse
9976 |      vv       -- a work vector of doubles
9977 |      indx     -- row permutation according to partitial pivoting sequence
9978 |      pd       -- 1 if number of row interchanges was even, -1 if number of
9979 |                  row interchanges was odd. Can be NULL.
9980 |
9981 |   The function returns YES (1) or NO (0) if the results are singular.
9982 |
9983 ---------------------------------------------------------------------------------*/
9984 int ComplexLUDecompose (int dim, complex **a, MrBFlt *vv, int *indx, MrBFlt *pd)
9985 {
9986     int             i, imax, j, k;
9987     MrBFlt          big, dum, temp, d;
9988     complex         sum, cdum;
9989
9990     d = 1.0;
9991     imax = 0;
9992
9993     for (i = 0; i < dim; i++)
9994         {
9995         big = 0.0;
9996         for (j = 0; j < dim; j++)
9997             {
9998             if ((temp = ComplexAbsoluteValue (a[i][j])) > big)
9999                 big = temp;
10000             }
10001         if (AreDoublesEqual(big, 0.0, ETA)==YES) /* == 0.0 */
10002             {
10003             MrBayesPrint ("%s   Error: Problem in ComplexLUDecompose\n", spacer);
10004             return (1);
10005             }
10006         vv[i] = 1.0 / big;
10007         }
10008
10009     for (j = 0; j < dim; j++)
10010         {
10011         for (i = 0; i < j; i++)
10012             {
10013             sum = a[i][j];
10014             for (k = 0; k < i; k++)
10015                 sum = ComplexSubtraction (sum, ComplexMultiplication (a[i][k], a[k][j]));
10016             a[i][j] = sum;
10017             }
10018         big = 0.0;
10019         for (i = j; i < dim; i++)
10020             {
10021             sum = a[i][j];
10022             for (k = 0; k < j; k++)
10023             sum = ComplexSubtraction (sum, ComplexMultiplication (a[i][k], a[k][j]));
10024             a[i][j] = sum;
10025             dum = vv[i] * ComplexAbsoluteValue (sum);
10026             if (dum >= big)
10027                 {
10028                 big = dum;
10029                 imax = i;
10030                 }
10031             }
10032         if (j != imax)
10033             {
10034             for (k = 0; k < dim; k++)
10035                 {
10036                 cdum = a[imax][k];
10037                 a[imax][k] = a[j][k];
10038                 a[j][k] = cdum;
10039                 }
10040             d = -d;
10041             vv[imax] = vv[j];
10042             }
10043         indx[j] = imax;
10044         if (AreDoublesEqual(a[j][j].re, 0.0, ETA)==YES && AreDoublesEqual(a[j][j].im, 0.0, ETA)==YES) /* 2x == 0.0 */
10045             a[j][j] = Complex (1.0e-20, 1.0e-20);
10046         if (j != dim - 1)
10047             {
10048             cdum = ComplexDivision (Complex(1.0, 0.0), a[j][j]);
10049             for (i = j + 1; i < dim; i++)
10050             a[i][j] = ComplexMultiplication (a[i][j], cdum);
10051             }
10052         }
10053
10054     if (pd != NULL)
10055         *pd = d;
10056
10057     return (0);
10058 }
10059
10060
10061 /*---------------------------------------------------------------------------------
10062 |
10063 |   ComplexMultiplication
10064 |
10065 |   Returns the complex product of two complex numbers.
10066 |
10067 ---------------------------------------------------------------------------------*/
10068 complex ComplexMultiplication (complex a, complex b)
10069 {
10070     complex     c;
10071
10072     c.re = a.re * b.re - a.im * b.im;
10073     c.im = a.im * b.re + a.re * b.im;
10074
10075     return (c);
10076 }
10077
10078
10079 /*---------------------------------------------------------------------------------
10080 |
10081 |   ComplexSquareRoot
10082 |
10083 |   Returns the complex square root of a complex number.
10084 |
10085 ---------------------------------------------------------------------------------*/
10086 complex ComplexSquareRoot (complex a)
10087 {
10088     complex         c;
10089     MrBFlt          x, y, w, r;
10090
10091     if (AreDoublesEqual(a.re, 0.0, ETA)==YES && AreDoublesEqual(a.im, 0.0, ETA)==YES) /* 2x == 0.0 */
10092         {
10093         c.re = 0.0;
10094         c.im = 0.0;
10095         return (c);
10096         }
10097     else
10098         {
10099         x = fabs(a.re);
10100         y = fabs(a.im);
10101         if (x >= y)
10102             {
10103             r = y / x;
10104             w = sqrt(x) * sqrt(0.5 * (1.0 + sqrt(1.0 + r * r)));
10105             }
10106         else
10107             {
10108             r = x / y;
10109             w = sqrt(y) * sqrt(0.5 * (r + sqrt(1.0 + r * r)));
10110             }
10111         if (a.re >= 0.0)
10112             {
10113             c.re = w;
10114             c.im = a.im / (2.0 * w);
10115             }
10116         else
10117             {
10118             c.im = (a.im >= 0.0) ? w : -w;
10119             c.re = a.im / (2.0 * c.im);
10120             }
10121         return (c);
10122         }
10123 }
10124
10125
10126 /*---------------------------------------------------------------------------------
10127 |
10128 |   ComplexSubtraction
10129 |
10130 |   Returns the complex difference of two complex numbers.
10131 |
10132 ---------------------------------------------------------------------------------*/
10133 complex ComplexSubtraction (complex a, complex b)
10134 {
10135     complex     c;
10136
10137     c.re = a.re - b.re;
10138     c.im = a.im - b.im;
10139
10140     return (c);
10141 }
10142
10143
10144 /*---------------------------------------------------------------------------------
10145 |
10146 |   ComputeEigenSystem
10147 |
10148 |   Calculates the eigenvalues, eigenvectors, and the inverse of the eigenvectors
10149 |   for a matrix of real numbers.
10150 |
10151 ---------------------------------------------------------------------------------*/
10152 int ComputeEigenSystem (int dim, MrBFlt **a, MrBFlt *v, MrBFlt *vi, MrBFlt **u, int *iwork, MrBFlt *dwork)
10153 {
10154     int         i, rc;
10155
10156     rc = EigensForRealMatrix (dim, a, v, vi, u, iwork, dwork);
10157     if (rc != NO_ERROR)
10158         {
10159         MrBayesPrint ("%s   Error in ComputeEigenSystem.\n", spacer);
10160         return (ERROR);
10161         }
10162     for (i=0; i<dim; i++)
10163         {
10164         if (AreDoublesEqual(vi[i], 0.0, ETA)==NO) /* != 0.0 */
10165             return (EVALUATE_COMPLEX_NUMBERS);
10166         }
10167
10168     return (NO_ERROR);
10169 }
10170
10171
10172 /*---------------------------------------------------------------------------------
10173 |
10174 |   ComputeLandU
10175 |
10176 |   This function computes the L and U decomposition of a matrix. Basically,
10177 |   we find matrices lMat and uMat such that
10178 |
10179 |      lMat * uMat = aMat
10180 |
10181 ---------------------------------------------------------------------------------*/
10182 void ComputeLandU (int dim, MrBFlt **aMat, MrBFlt **lMat, MrBFlt **uMat)
10183 {
10184     int         i, j, k, m, row, col;
10185
10186     for (j=0; j<dim; j++)
10187         {
10188         for (k=0; k<j; k++)
10189             for (i=k+1; i<j; i++)
10190                 aMat[i][j] = aMat[i][j] - aMat[i][k] * aMat[k][j];
10191
10192         for (k=0; k<j; k++)
10193             for (i=j; i<dim; i++)
10194                 aMat[i][j] = aMat[i][j] - aMat[i][k]*aMat[k][j];
10195
10196         for (m=j+1; m<dim; m++)
10197             aMat[m][j] /= aMat[j][j];
10198         }
10199
10200     for (row=0; row<dim; row++)
10201         {
10202         for (col=0; col<dim; col++)
10203             {
10204             if (row <= col)
10205                 {
10206                 uMat[row][col] = aMat[row][col];
10207                 lMat[row][col] = (row == col ? 1.0 : 0.0);
10208                 }
10209             else
10210                 {
10211                 lMat[row][col] = aMat[row][col];
10212                 uMat[row][col] = 0.0;
10213                 }
10214             }
10215         }
10216 }
10217
10218
10219 /*---------------------------------------------------------------------------------
10220 |
10221 |   ComputeMatrixExponential
10222 |
10223 |   The method approximates the matrix exponential, f = e^a, using
10224 |   the algorithm 11.3.1, described in:
10225 |
10226 |   Golub, G. H., and C. F. Van Loan. 1996. Matrix Computations, Third Edition.
10227 |      The Johns Hopkins University Press, Baltimore, Maryland.
10228 |
10229 |   The method has the advantage of error control. The error is controlled by
10230 |   setting qValue appropriately (using the function SetQValue).
10231 |
10232 ---------------------------------------------------------------------------------*/
10233 void ComputeMatrixExponential (int dim, MrBFlt **a, int qValue, MrBFlt **f)
10234 {
10235     int         i, j, k, negativeFactor;
10236     MrBFlt      maxAValue, c, **d, **n, **x, **cX;
10237
10238     d  = AllocateSquareDoubleMatrix (dim);
10239     n  = AllocateSquareDoubleMatrix (dim);
10240     x  = AllocateSquareDoubleMatrix (dim);
10241     cX = AllocateSquareDoubleMatrix (dim);
10242
10243     SetToIdentity (dim, d);
10244     SetToIdentity (dim, n);
10245     SetToIdentity (dim, x);
10246
10247     maxAValue = 0;
10248     for (i=0; i<dim; i++)
10249         maxAValue = MAX (maxAValue, a[i][i]);
10250
10251     j = MAX (0, LogBase2Plus1 (maxAValue));
10252
10253     DivideByTwos (dim, a, j);
10254
10255     c = 1;
10256     for (k=1; k<=qValue; k++)
10257         {
10258         c = c * (qValue - k + 1.0) / ((2.0 * qValue - k + 1.0) * k);
10259
10260         /* X = AX */
10261         MultiplyMatrices (dim, a, x, x);
10262
10263         /* N = N + cX */
10264         MultiplyMatrixByScalar (dim, x, c, cX);
10265         AddTwoMatrices (dim, n, cX, n);
10266
10267         /* D = D + (-1)^k*cX */
10268         negativeFactor = (k % 2 == 0 ? 1 : -1);
10269         if (negativeFactor == -1)
10270             MultiplyMatrixByScalar (dim, cX, negativeFactor, cX);
10271         AddTwoMatrices (dim, d, cX, d);
10272         }
10273
10274     GaussianElimination (dim, d, n, f);
10275
10276     for (k = 0; k < j; k++)
10277         MultiplyMatrices (dim, f, f, f);
10278
10279     for (i=0; i<dim; i++)
10280         {
10281         for (j=0; j<dim; j++)
10282             {
10283             if (f[i][j] < 0.0)
10284                 f[i][j] = fabs(f[i][j]);
10285             }
10286         }
10287
10288     FreeSquareDoubleMatrix (d);
10289     FreeSquareDoubleMatrix (n);
10290     FreeSquareDoubleMatrix (x);
10291     FreeSquareDoubleMatrix (cX);
10292 }
10293
10294
10295 /*---------------------------------------------------------------------------------
10296 |
10297 |   CopyComplexMatrices
10298 |
10299 |   Copies the contents of one matrix of complex numbers to another matrix.
10300 |
10301 ---------------------------------------------------------------------------------*/
10302 void CopyComplexMatrices (int dim, complex **from, complex **to)
10303 {
10304     int         i, j;
10305
10306     for (i=0; i<dim; i++)
10307         {
10308         for (j=0; j<dim; j++)
10309             {
10310             to[i][j].re = from[i][j].re;
10311             to[i][j].im = from[i][j].im;
10312             }
10313         }
10314 }
10315
10316
10317 /*---------------------------------------------------------------------------------
10318 |
10319 |   CopyDoubleMatrices
10320 |
10321 |   Copies the contents of one matrix of doubles to another matrix.
10322 |
10323 ---------------------------------------------------------------------------------*/
10324 void CopyDoubleMatrices (int dim, MrBFlt **from, MrBFlt **to)
10325 {
10326     int         i, j;
10327
10328     for (i=0; i<dim; i++)
10329         {
10330         for (j=0; j<dim; j++)
10331             {
10332             to[i][j] = from[i][j];
10333             }
10334         }
10335 }
10336
10337
10338 /*---------------------------------------------------------------------------------
10339 |
10340 |   DirichletRandomVariable
10341 |
10342 |   Generate a Dirichlet-distributed random variable. The parameter of the
10343 |   Dirichlet is contained in the vector alp. The random variable is contained
10344 |   in the vector z.
10345 |
10346 ---------------------------------------------------------------------------------*/
10347 void DirichletRandomVariable (MrBFlt *alp, MrBFlt *z, int n, RandLong *seed)
10348 {
10349     int     i;
10350     MrBFlt  sum;
10351
10352     sum = 0.0;
10353     for (i=0; i<n; i++)
10354         {
10355         z[i] = RndGamma (alp[i], seed) / 1.0;
10356         sum += z[i];
10357         }
10358     for (i=0; i<n; i++)
10359         z[i] /= sum;
10360 }
10361
10362
10363 /*---------------------------------------------------------------------------------
10364 |
10365 |   DiscreteGamma
10366 |
10367 |   Discretization of gamma distribution with equal proportions in each
10368 |   category.
10369 |
10370 ---------------------------------------------------------------------------------*/
10371 int DiscreteGamma (MrBFlt *rK, MrBFlt alfa, MrBFlt beta, int K, int median)
10372 {
10373     int             i;
10374     MrBFlt          gap05 = 1.0/(2.0*K), t, factor = alfa/beta*K, lnga1;
10375
10376     if (median)
10377         {
10378         for (i=0; i<K; i++)
10379             rK[i] = POINTGAMMA((i*2.0+1.0)*gap05, alfa, beta);
10380         for (i=0,t=0; i<K; i++)
10381             t += rK[i];
10382         for (i=0; i<K; i++)
10383             rK[i] *= factor / t;
10384         }
10385     else
10386         {
10387         lnga1 = LnGamma(alfa+1);
10388         /* calculate the points in the gamma distribution */
10389         for (i=0; i<K-1; i++)
10390             rK[i] = POINTGAMMA((i+1.0)/K, alfa, beta);
10391         /* calculate the cumulative values */
10392         for (i=0; i<K-1; i++)
10393             rK[i] = IncompleteGamma(rK[i] * beta, alfa + 1.0, lnga1);
10394         rK[K-1] = 1.0;
10395         /* calculate the relative values and rescale */
10396         for (i=K-1; i>0; i--)
10397             {
10398             rK[i] -= rK[i-1];
10399             rK[i] *= factor;
10400             }
10401         rK[0] *= factor;
10402         }
10403
10404     return (NO_ERROR);
10405 }
10406
10407
10408 /*---------------------------------------------------------------------------------
10409  |
10410  |   DiscreteLogNormal
10411  |
10412  |   Discretization of lognormal distribution with equal proportions in each
10413  |   category.
10414  |
10415  |   LBH Notes:     K = # of rate classes
10416  |                *rK = pointer to output rate class matrix
10417  |               alfa = alpha param
10418  |               beta = beta param
10419  |             median = flag to use media or not (1 = use median, 0 = mean?)
10420  |
10421  ---------------------------------------------------------------------------------*/
10422 int DiscreteLogNormal (MrBFlt *rK, MrBFlt sigma, int K, int median)
10423 {
10424     int i;
10425     MrBFlt t, factor;
10426     MrBFlt sigmaL = sqrt(sigma);
10427     MrBFlt mu = -1.0*((0.5*pow(sigmaL,2.0)));
10428     if (median)
10429         {
10430         for (i=0; i<K; i++) {
10431             rK[i] = QuantileLogNormal( ((2.0*i + 1) / (2.0 * K)), mu, sigmaL);
10432             }
10433         for (i=0,t=0.0; i<K; i++) {
10434             t = t+rK[i];
10435             }
10436         t /= K;
10437         for (i=0; i<K; i++)
10438             rK[i] /= t;
10439         }
10440     else
10441         {
10442         mu = -1.0*((0.5*pow(sigmaL,2.0)));
10443         /* Mean set to 1.0 so factor = K */
10444         factor = 1.0*K;
10445         for (i=0; i<K-1; i++) {
10446             rK[i] = QuantileLogNormal(((i + 1.0) / (K)), mu, sigmaL);
10447             }
10448         for (i=0; i<K-1; i++) {
10449             //rK[i] = LogNormalPoint(rK[i], mu, sigma);
10450             //rK[i] = QuantileLogNormal(rK[i], mu, sigma);
10451             //rK[i] = CdfNormal((log(rK[i])-mu)/sigma);
10452             rK[i] = 1 - (1.0 * CdfNormal((mu + pow(sigmaL,2.0) - log(rK[i]))/sigmaL));
10453             }
10454         rK[K-1] = 1.0;
10455         for (i=K-1; i>0; i--) {
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 /* LogNormal Quantile Function */
10467 MrBFlt QuantileLogNormal (MrBFlt prob, MrBFlt mu, MrBFlt sigma)
10468 {
10469     MrBFlt a = 0.0, b = 0.0;
10470     a = PointNormal((0.5*(2.0*prob-1.0))+0.5) / sqrt(2.0);
10471     b = mu+(sqrt(2.0)* sigma * a);
10472     return exp(b);
10473 }
10474
10475
10476 /* LogNormal Point Function */
10477 MrBFlt LogNormalPoint (MrBFlt x, MrBFlt mu, MrBFlt sigma)
10478 {
10479     if(x <= 0.0) return(0.0);
10480     MrBFlt a = LnProbLogNormal(mu, sigma, x);
10481     return exp(a);
10482 }
10483
10484
10485 /*---------------------------------------------------------------------------------
10486 |
10487 |   DivideByTwos
10488 |
10489 |   Divides all of the elements of the matrix a by 2^power.
10490 |
10491 ---------------------------------------------------------------------------------*/
10492 void DivideByTwos (int dim, MrBFlt **a, int power)
10493 {
10494     int         divisor = 1, i, row, col;
10495
10496     for (i=0; i<power; i++)
10497         divisor = divisor * 2;
10498
10499     for (row=0; row<dim; row++)
10500         for (col=0; col<dim; col++)
10501             a[row][col] /= divisor;
10502 }
10503
10504
10505 /*---------------------------------------------------------------------------------
10506 |
10507 |   D_sign
10508 |
10509 |   This function is called from "Hqr2".
10510 |
10511 ---------------------------------------------------------------------------------*/
10512 MrBFlt D_sign (MrBFlt a, MrBFlt b)
10513 {
10514     MrBFlt      x;
10515
10516     x = (a >= 0 ? a : -a);
10517
10518     return (b >= 0 ? x : -x);
10519 }
10520
10521
10522 /*---------------------------------------------------------------------------------
10523 |
10524 |   Eigens
10525 |
10526 |   The matrix of interest is a. The ouptut is the real and imaginary parts of the
10527 |   eigenvalues (wr and wi). z contains the real and imaginary parts of the
10528 |   eigenvectors. iv2 and fv1 are working vectors.
10529 |
10530 ---------------------------------------------------------------------------------*/
10531 int EigensForRealMatrix (int dim, MrBFlt **a, MrBFlt *wr, MrBFlt *wi, MrBFlt **z, int *iv1, MrBFlt *fv1)
10532 {
10533     static int  is1, is2;
10534     int         ierr;
10535
10536     Balanc (dim, a, &is1, &is2, fv1);
10537     ElmHes (dim, is1, is2, a, iv1);
10538     ElTran (dim, is1, is2, a, iv1, z);
10539     ierr = Hqr2 (dim, is1, is2, a, wr, wi, z);
10540     if (ierr == 0)
10541         BalBak (dim, is1, is2, fv1, dim, z);
10542
10543     return (ierr);
10544 }
10545
10546
10547 /*---------------------------------------------------------------------------------
10548 |
10549 |   ElmHes
10550 |
10551 |   Given a real general matrix, this subroutine
10552 |   reduces a submatrix situated in rows and columns
10553 |   low through high to upper Hessenberg form by
10554 |   stabilized elementary similarity transformations.
10555 |
10556 |   On input:
10557 |
10558 |    * dim is the order of the matrix
10559 |
10560 |    * low and high are integers determined by the balancing
10561 |      subroutine  balanc.  if  balanc  has not been used,
10562 |      set low=1, high=dim.
10563 |
10564 |    * a contains the input matrix.
10565 |
10566 |   On output:
10567 |
10568 |    * a contains the hessenberg matrix.  The multipliers
10569 |      which were used in the reduction are stored in the
10570 |      remaining triangle under the hessenberg matrix.
10571 |
10572 |    * interchanged contains information on the rows and columns
10573 |      interchanged in the reduction.
10574 |
10575 |   Only elements low through high are used.
10576 |
10577 ---------------------------------------------------------------------------------*/
10578 void ElmHes (int dim, int low, int high, MrBFlt **a, int *interchanged)
10579 {
10580     int         i, j, m, la, mm1, kp1, mp1;
10581     MrBFlt      x, y;
10582
10583     la = high - 1;
10584     kp1 = low + 1;
10585     if (la < kp1)
10586         return; /* remove goto statement, which exits at bottom of function */
10587
10588     for (m=kp1; m<=la; m++)
10589         {
10590         mm1 = m - 1;
10591         x = 0.0;
10592         i = m;
10593
10594         for (j=m; j<=high; j++)
10595             {
10596             if (fabs(a[j][mm1]) > fabs(x)) /* change direction of inequality */
10597                 {                          /* remove goto statement          */
10598                 x = a[j][mm1];
10599                 i = j;
10600                 }
10601             }
10602
10603         interchanged[m] = i;
10604         if (i != m) /* change "==" to "!=", eliminating goto statement */
10605             {
10606             /* interchange rows and columns of a */
10607             for (j=mm1; j<dim; j++)
10608                 {
10609                 y = a[i][j];
10610                 a[i][j] = a[m][j];
10611                 a[m][j] = y;
10612                 }
10613             for (j=0; j<=high; j++)
10614                 {
10615                 y = a[j][i];
10616                 a[j][i] = a[j][m];
10617                 a[j][m] = y;
10618                 }
10619             }
10620
10621         if (AreDoublesEqual(x, 0.0, ETA)==NO) /* change "==" to "!=", eliminating goto statement */
10622             {
10623             mp1 = m + 1;
10624
10625             for (i=mp1; i<=high; i++)
10626                 {
10627                 y = a[i][mm1];
10628                 if (AreDoublesEqual(y, 0.0, ETA)==NO) /* != 0.0 */
10629                     {
10630                     y /= x;
10631                     a[i][mm1] = y;
10632                     for (j = m; j < dim; j++)
10633                         a[i][j] -= y * a[m][j];
10634                     for (j = 0; j <= high; j++)
10635                         a[j][m] += y * a[j][i];
10636                     }
10637                 }
10638             }
10639         }
10640
10641 #if 0
10642 /* begin f2c version of code:
10643    elmhes.f -- translated by f2c (version 19971204) */
10644 int elmhes (int *nm, int *n, int *low, int *igh, MrBFlt *a, int *int__)
10645
10646 {
10647
10648     /*system generated locals */
10649     int a_dim1, a_offset, i__1, i__2, i__3;
10650     MrBFlt d__1;
10651
10652     /* local variables */
10653     static int i__, j, m;
10654     static MrBFlt x, y;
10655     static int la, mm1, kp1, mp1;
10656
10657     /* parameter adjustments */
10658     a_dim1 = *nm;
10659     a_offset = a_dim1 + 1;
10660     a -= a_offset;
10661     --int__;
10662
10663     /* function body */
10664     la = *igh - 1;
10665     kp1 = *low + 1;
10666     if (la < kp1)
10667         goto L200;
10668
10669     i__1 = la;
10670     for (m = kp1; m <= i__1; ++m)
10671         {
10672         mm1 = m - 1;
10673         x = 0.;
10674         i__ = m;
10675         i__2 = *igh;
10676         for (j = m; j <= i__2; ++j)
10677             {
10678             if ((d__1 = a[j + mm1 * a_dim1], abs(d__1)) <= abs(x))
10679                 goto L100;
10680             x = a[j + mm1 * a_dim1];
10681             i__ = j;
10682             L100:
10683             ;
10684         }
10685
10686     int__[m] = i__;
10687     if (i__ == m)
10688         goto L130;
10689
10690     /* .......... interchange rows and columns of a.......... */
10691     i__2 = *n;
10692     for (j = mm1; j <= i__2; ++j)
10693         {
10694         y = a[i__ + j * a_dim1];
10695         a[i__ + j * a_dim1] = a[m + j * a_dim1];
10696         a[m + j * a_dim1] = y;
10697         /* L110: */
10698         }
10699
10700     i__2 = *igh;
10701     for (j = 1; j <= i__2; ++j)
10702         {
10703         y = a[j + i__ * a_dim1];
10704         a[j + i__ * a_dim1] = a[j + m * a_dim1];
10705         a[j + m * a_dim1] = y;
10706         /* L120: */
10707         }
10708
10709     /* .......... end interchange .......... */
10710     L130:
10711     if (x == 0.)
10712         goto L180;
10713     mp1 = m + 1;
10714
10715     i__2 = *igh;
10716     for (i__ = mp1; i__ <= i__2; ++i__)
10717         {
10718         y = a[i__ + mm1 * a_dim1];
10719         if (y == 0.)
10720             goto L160;
10721         y /= x;
10722         a[i__ + mm1 * a_dim1] = y;
10723
10724         i__3 = *n;
10725         for (j = m; j <= i__3; ++j)
10726             {
10727             /* L140: */
10728             a[i__ + j * a_dim1] -= y * a[m + j * a_dim1];
10729             }
10730
10731         i__3 = *igh;
10732         for (j = 1; j <= i__3; ++j)
10733             {
10734             /* L150: */
10735             a[j + m * a_dim1] += y * a[j + i__ * a_dim1];
10736             }
10737
10738         L160:
10739             ;
10740         }
10741
10742     L180:
10743         ;
10744     }
10745
10746     L200:
10747     return 0;
10748
10749 }
10750 /* end f2c version of code */
10751 #endif
10752
10753 }
10754
10755
10756 /*---------------------------------------------------------------------------------
10757 |
10758 |   ElTran
10759 |
10760 |   This subroutine accumulates the stabilized elementary
10761 |   similarity transformations used in the reduction of a
10762 |   real general matrix to upper Hessenberg form by ElmHes.
10763 |
10764 |   On input:
10765 |
10766 |    * dim is the order of the matrix.
10767 |
10768 |    * low and high are integers determined by the balancing
10769 |      subroutine  balanc. If Balanc has not been used,
10770 |      set low=0, high=dim-1.
10771 |
10772 |    * a contains the multipliers which were used in the
10773 |      reduction by  ElmHes in its lower triangle
10774 |      below the subdiagonal.
10775 |
10776 |    * interchanged contains information on the rows and columns
10777 |      interchanged in the reduction by ElmHes.
10778 |      only elements low through high are used.
10779 |
10780 |   On output:
10781 |
10782 |    * z contains the transformation matrix produced in the
10783 |      reduction by ElmHes.
10784 |
10785 |   This routine is a translation of the Algol procedure from
10786 |   Handbook for Automatic Computation, vol. II, Linear Algebra,
10787 |   by Wilkinson and Reinsch, Springer-Verlag.
10788 |
10789 ---------------------------------------------------------------------------------*/
10790 void ElTran (int dim, int low, int high, MrBFlt **a, int *interchanged, MrBFlt **z)
10791 {
10792     int         i, j, mp;
10793
10794     /* initialize z to identity matrix */
10795     for (j=0; j<dim; j++)
10796         {
10797         for (i=0; i<dim; i++)
10798             z[i][j] = 0.0;
10799         z[j][j] = 1.0;
10800         }
10801     for (mp=high-1; mp>=low+1; mp--) /* there were a number of additional    */
10802         {                            /* variables (kl, la, m, mm, mp1) that  */
10803         for (i=mp+1; i<=high; i++)   /* have been eliminated here simply by  */
10804             z[i][mp] = a[i][mp-1];   /* initializing variables appropriately */
10805         i = interchanged[mp];        /* in the loops                         */
10806         if (i != mp) /* change "==" to "!=" to eliminate a goto statement */
10807             {
10808             for (j=mp; j<=high; j++)
10809                 {
10810                 z[mp][j] = z[i][j];
10811                 z[i][j] = 0.0;
10812                 }
10813             z[i][mp] = 1.0;
10814             }
10815         }
10816
10817 #if 0
10818 /* begin f2c version of code:
10819    eltran.f -- translated by f2c (version 19971204) */
10820 int eltran (int *nm, int *n, int *low, int *igh, MrBFlt *a, int *int__, MrBFlt *z__)
10821
10822 {
10823
10824     /* system generated locals */
10825     int a_dim1, a_offset, z_dim1, z_offset, i__1, i__2;
10826
10827     /* local variables */
10828     static int i__, j, kl, mm, mp, mp1;
10829
10830     /*     .......... initialize z to identity matrix .......... */
10831
10832     /* parameter adjustments */
10833     z_dim1 = *nm;
10834     z_offset = z_dim1 + 1;
10835     z__ -= z_offset;
10836     --int__;
10837     a_dim1 = *nm;
10838     a_offset = a_dim1 + 1;
10839     a -= a_offset;
10840
10841     /* function Body */
10842     i__1 = *n;
10843     for (j = 1; j <= i__1; ++j)
10844         {
10845         i__2 = *n;
10846         for (i__ = 1; i__ <= i__2; ++i__)
10847             {
10848             /* L60: */
10849             z__[i__ + j * z_dim1] = 0.0;
10850             }
10851         z__[j + j * z_dim1] = 1.0;
10852         /* L80: */
10853         }
10854
10855     kl = *igh - *low - 1;
10856     if (kl < 1)
10857         goto L200;
10858
10859     /* .......... for mp=igh-1 step -1 until low+1 do -- .......... */
10860     i__1 = kl;
10861     for (mm = 1; mm <= i__1; ++mm)
10862         {
10863         mp = *igh - mm;
10864         mp1 = mp + 1;
10865         i__2 = *igh;
10866         for (i__ = mp1; i__ <= i__2; ++i__)
10867             {
10868             /* L100: */
10869             z__[i__ + mp * z_dim1] = a[i__ + (mp - 1) * a_dim1];
10870             }
10871         i__ = int__[mp];
10872         if (i__ == mp)
10873             goto L140;
10874         i__2 = *igh;
10875         for (j = mp; j <= i__2; ++j)
10876             {
10877             z__[mp + j * z_dim1] = z__[i__ + j * z_dim1];
10878             z__[i__ + j * z_dim1] = 0.;
10879             /* L130: */
10880             }
10881         z__[i__ + mp * z_dim1] = 1.;
10882         L140:
10883             ;
10884         }
10885
10886     L200:
10887     return 0;
10888
10889 }
10890 /* end f2c version of code */
10891 #endif
10892
10893 }
10894
10895
10896 /*---------------------------------------------------------------------------------
10897 |
10898 |   Exchange
10899 |
10900 ---------------------------------------------------------------------------------*/
10901 void Exchange (int j, int k, int l, int m, int n, MrBFlt **a, MrBFlt *scale)
10902 {
10903     int         i;
10904     MrBFlt      f;
10905
10906     scale[m] = (MrBFlt)j;
10907     if (j != m)
10908         {
10909         for (i = 0; i <= l; i++)
10910             {
10911             f = a[i][j];
10912             a[i][j] = a[i][m];
10913             a[i][m] = f;
10914             }
10915         for (i = k; i < n; i++)
10916             {
10917             f = a[j][i];
10918             a[j][i] = a[m][i];
10919             a[m][i] = f;
10920             }
10921         }
10922 }
10923
10924
10925 /*---------------------------------------------------------------------------------
10926 |
10927 |   Factorial
10928 |
10929 |   Returns x!
10930 |
10931 ---------------------------------------------------------------------------------*/
10932 MrBFlt Factorial (int x)
10933 {
10934     int         i;
10935     MrBFlt      fac;
10936
10937     fac = 1.0;
10938     for (i=0; i<x; i++)
10939         {
10940         fac *= (i+1);
10941         }
10942
10943     return (fac);
10944 }
10945
10946
10947 /*---------------------------------------------------------------------------------
10948 |
10949 |   ForwardSubstitutionRow
10950 |
10951 ---------------------------------------------------------------------------------*/
10952 void ForwardSubstitutionRow (int dim, MrBFlt **L, MrBFlt *b)
10953 {
10954     int         i, j;
10955     MrBFlt      dotProduct;
10956
10957     b[0] = b[0] / L[0][0];
10958     for (i=1; i<dim; i++)
10959         {
10960         dotProduct = 0.0;
10961         for (j=0; j<i; j++)
10962             dotProduct += L[i][j] * b[j];
10963         b[i] = (b[i] - dotProduct) / L[i][i];
10964         }
10965 }
10966
10967
10968 /*---------------------------------------------------------------------------------
10969 |
10970 |   FreeSquareComplexMatrix
10971 |
10972 |   Frees a matrix of complex numbers.
10973 |
10974 ---------------------------------------------------------------------------------*/
10975 void FreeSquareComplexMatrix (complex **m)
10976 {
10977     free((char *) (m[0]));
10978     free((char *) (m));
10979 }
10980
10981
10982 /*---------------------------------------------------------------------------------
10983 |
10984 |   FreeSquareDoubleMatrix
10985 |
10986 |   Frees a matrix of doubles.
10987 |
10988 ---------------------------------------------------------------------------------*/
10989 void FreeSquareDoubleMatrix (MrBFlt **m)
10990 {
10991     free((char *) (m[0]));
10992     free((char *) (m));
10993 }
10994
10995
10996 /*---------------------------------------------------------------------------------
10997 |
10998 |   FreeSquareIntegerMatrix
10999 |
11000 |   Frees a matrix of integers.
11001 |
11002 ---------------------------------------------------------------------------------*/
11003 void FreeSquareIntegerMatrix (int **m)
11004 {
11005     free((char *) (m[0]));
11006     free((char *) (m));
11007 }
11008
11009
11010 /*---------------------------------------------------------------------------------
11011 |
11012 |   GammaRandomVariable
11013 |
11014 |   This function generates a gamma-distributed random variable with parameters
11015 |   a and b. The mean is E(X) = a / b and the variance is Var(X) = a / b^2.
11016 |
11017 ---------------------------------------------------------------------------------*/
11018 MrBFlt GammaRandomVariable (MrBFlt a, MrBFlt b, RandLong *seed)
11019 {
11020     return (RndGamma (a, seed) / b);
11021 }
11022
11023
11024 /*---------------------------------------------------------------------------------
11025 |
11026 |   GaussianElimination
11027 |
11028 ---------------------------------------------------------------------------------*/
11029 void GaussianElimination (int dim, MrBFlt **a, MrBFlt **bMat, MrBFlt **xMat)
11030 {
11031     int         i, k;
11032     MrBFlt      *bVec, **lMat, **uMat;
11033
11034     lMat = AllocateSquareDoubleMatrix (dim);
11035     uMat = AllocateSquareDoubleMatrix (dim);
11036     bVec = (MrBFlt *) SafeMalloc ((size_t)dim * sizeof(MrBFlt));
11037     if (!bVec)
11038         {
11039         MrBayesPrint ("%s   Error: Problem allocating bVec\n", spacer);
11040         exit (0);
11041         }
11042
11043     ComputeLandU (dim, a, lMat, uMat);
11044
11045     for (k=0; k<dim; k++)
11046         {
11047
11048         for (i=0; i<dim; i++)
11049             bVec[i] = bMat[i][k];
11050
11051         /* Answer of Ly = b (which is solving for y) is copied into b. */
11052         ForwardSubstitutionRow (dim, lMat, bVec);
11053
11054         /* Answer of Ux = y (solving for x and the y was copied into b above)
11055            is also copied into b. */
11056         BackSubstitutionRow (dim, uMat, bVec);
11057
11058         for (i=0; i<dim; i++)
11059             xMat[i][k] = bVec[i];
11060
11061         }
11062
11063     FreeSquareDoubleMatrix (lMat);
11064     FreeSquareDoubleMatrix (uMat);
11065     free (bVec);
11066 }
11067
11068
11069 /*---------------------------------------------------------------------------------
11070 |
11071 |   GetEigens
11072 |
11073 |   returns NO if non complex eigendecomposition, YES if complex eigendecomposition,  ABORT if an error has occured
11074 |
11075 ---------------------------------------------------------------------------------*/
11076 int GetEigens (int dim, MrBFlt **q, MrBFlt *eigenValues, MrBFlt *eigvalsImag, MrBFlt **eigvecs, MrBFlt **inverseEigvecs, complex **Ceigvecs, complex **CinverseEigvecs)
11077 {
11078     int         i, j, rc, *iWork, isComplex;
11079     MrBFlt      **tempWork, *dWork;
11080     complex     **cWork, *Ccol;
11081
11082     /* allocate memory */
11083     dWork = (MrBFlt *) SafeMalloc ((size_t)dim * sizeof(MrBFlt));
11084     iWork = (int *) SafeMalloc ((size_t)dim * sizeof(int));
11085     if (!dWork || !iWork)
11086         {
11087         MrBayesPrint ("%s   Error: Problem in GetEigens\n", spacer);
11088         exit (0);
11089         }
11090
11091     /* calculate eigenvalues and eigenvectors */
11092     isComplex = NO;
11093     rc = ComputeEigenSystem (dim, q, eigenValues, eigvalsImag, eigvecs, iWork, dWork);
11094     if (rc != NO_ERROR)
11095         {
11096         if (rc == EVALUATE_COMPLEX_NUMBERS)
11097             isComplex = YES;
11098         else
11099             isComplex = ABORT;
11100         }
11101
11102     /* invert eigenvectors */
11103     if (isComplex == NO)
11104         {
11105         tempWork = AllocateSquareDoubleMatrix (dim);
11106         CopyDoubleMatrices (dim, eigvecs, tempWork);
11107         InvertMatrix (dim, tempWork, dWork, iWork, inverseEigvecs);
11108         FreeSquareDoubleMatrix (tempWork);
11109         }
11110     else if (isComplex == YES)
11111         {
11112         for (i=0; i<dim; i++)
11113             {
11114               if (fabs(eigvalsImag[i])<1E-20) /* == 0.0 */
11115                 {
11116                 for (j=0; j<dim; j++)
11117                     {
11118                     Ceigvecs[j][i].re = eigvecs[j][i];
11119                     Ceigvecs[j][i].im = 0.0;
11120                     }
11121                 }
11122             else if (eigvalsImag[i] > 0)
11123                 {
11124                 for (j=0; j<dim; j++)
11125                     {
11126                     Ceigvecs[j][i].re = eigvecs[j][i];
11127                     Ceigvecs[j][i].im = eigvecs[j][i + 1];
11128                     }
11129                 }
11130             else if (eigvalsImag[i] < 0)
11131                 {
11132                 for (j=0; j<dim; j++)
11133                     {
11134                     Ceigvecs[j][i].re =  eigvecs[j][i-1];
11135                     Ceigvecs[j][i].im = -eigvecs[j][i];
11136                     }
11137                 }
11138             }
11139         Ccol = (complex *) SafeMalloc ((size_t)dim * sizeof(complex));
11140         if (!Ccol)
11141             {
11142             MrBayesPrint ("%s   Error: Problem in GetEigens\n", spacer);
11143             exit (0);
11144             }
11145         cWork = AllocateSquareComplexMatrix (dim);
11146         CopyComplexMatrices (dim, Ceigvecs, cWork);
11147         ComplexInvertMatrix (dim, cWork, dWork, iWork, CinverseEigvecs, Ccol);
11148         free (Ccol);
11149         FreeSquareComplexMatrix (cWork);
11150         }
11151
11152     free (dWork);
11153     free (iWork);
11154
11155     return (isComplex);
11156 }
11157
11158
11159 /*---------------------------------------------------------------------------------
11160 |
11161 |   Hqr2
11162 |
11163 |   This subroutine finds the eigenvalues and eigenvectors
11164 |   of a real upper Hessenberg matrix by the QR method. The
11165 |   eigenvectors of a real general matrix can also be found
11166 |   if ElmHes  and ElTran or OrtHes and OrTran have
11167 |   been used to reduce this general matrix to Hessenberg form
11168 |   and to accumulate the similarity transformations.
11169 |
11170 |   On input:
11171 |
11172 |    * dim is the order of the matrix.
11173 |
11174 |    * low and high are integers determined by the balancing
11175 |      subroutine  balanc. If  balanc has not been used,
11176 |      set low=0, high=dim-1.
11177 |
11178 |    * h contains the upper hessenberg matrix. Information about
11179 |      the transformations used in the reduction to Hessenberg
11180 |      form by  ElmHes  or OrtHes, if performed, is stored
11181 |      in the remaining triangle under the Hessenberg matrix.
11182 |
11183 |   On output:
11184 |
11185 |    * h has been destroyed.
11186 |
11187 |    * wr and wi contain the real and imaginary parts,
11188 |      respectively, of the eigenvalues. The eigenvalues
11189 |      are unordered except that complex conjugate pairs
11190 |      of values appear consecutively with the eigenvalue
11191 |      having the positive imaginary part first. If an
11192 |      error exit is made, the eigenvalues should be correct
11193 |      for indices j,...,dim-1.
11194 |
11195 |    * z contains the transformation matrix produced by ElTran
11196 |      after the reduction by ElmHes, or by OrTran after the
11197 |      reduction by OrtHes, if performed. If the eigenvectors
11198 |      of the Hessenberg matrix are desired, z must contain the
11199 |      identity matrix.
11200 |
11201 |   Calls ComplexDivision2 for complex division.
11202 |
11203 |   This function returns:
11204 |      zero       for normal return,
11205 |      j          if the limit of 30*n iterations is exhausted
11206 |                 while the j-th eigenvalue is being sought.
11207 |
11208 |   This subroutine is a translation of the ALGOL procedure HQR2,
11209 |   Num. Math. 14, 219,231(1970) by Martin, Peters, and Wilkinson.
11210 |   Handbook for Automatic Computation, vol. II - Linear Algebra,
11211 |   pp. 357-391 (1971).
11212 |
11213 ---------------------------------------------------------------------------------*/
11214 int Hqr2 (int dim, int low, int high, MrBFlt **h, MrBFlt *wr, MrBFlt *wi, MrBFlt **z)
11215 {
11216     int         i, j, k, l, m, na, en, notlas, mp2, itn, its, enm2, twoRoots;
11217     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;
11218
11219     norm = 0.0;
11220     k = 0;  /* used for array indexing. FORTRAN version: k = 1 */
11221
11222     /* store roots isolated by balance, and compute matrix norm */
11223     for (i=0; i<dim; i++)
11224         {
11225         for (j=k; j<dim; j++)
11226             norm += fabs(h[i][j]);
11227
11228         k = i;
11229         if ((i < low) || (i > high))
11230             {
11231             wr[i] = h[i][i];
11232             wi[i] = 0.0;
11233             }
11234         }
11235     en = high;
11236     t = 0.0;
11237     itn = dim * 30;
11238
11239     /* search for next eigenvalues */
11240     while (en >= low) /* changed from an "if (en < lo)" to eliminate a goto statement */
11241         {
11242         its = 0;
11243         na = en - 1;
11244         enm2 = na - 1;
11245         twoRoots = FALSE;
11246
11247         for (;;)
11248             {
11249             for (l=en; l>low; l--) /* changed indexing, got rid of lo, ll */
11250                 {
11251                 s = fabs(h[l-1][l-1]) + fabs(h[l][l]);
11252                 if (AreDoublesEqual(s, 0.0, ETA)==YES) /* == 0.0 */
11253                     s = norm;
11254                 tst1 = s;
11255                 tst2 = tst1 + fabs(h[l][l-1]);
11256                 if (fabs(tst2 - tst1) < ETA) /* tst2 == tst1 */
11257                     break; /* changed to break to remove a goto statement */
11258                 }
11259
11260             /* form shift */
11261             x = h[en][en];
11262             if (l == en) /* changed to break to remove a goto statement */
11263                 break;
11264             y = h[na][na];
11265             w = h[en][na] * h[na][en];
11266             if (l == na)         /* used to return to other parts of the code */
11267                 {
11268                 twoRoots = TRUE;
11269                 break;
11270                 }
11271             if (itn == 0)
11272                 return (en);
11273
11274             /* form exceptional shift */
11275             if ((its == 10) || (its == 20)) /* changed to remove a goto statement */
11276                 {
11277                 t += x;
11278                 for (i = low; i <= en; i++)
11279                     h[i][i] -= x;
11280                 s = fabs(h[en][na]) + fabs(h[na][enm2]);
11281                 x = 0.75 * s;
11282                 y = x;
11283                 w = -0.4375 * s * s;
11284                 }
11285             its++;
11286             itn--;
11287
11288             /* look for two consecutive small sub-diagonal elements */
11289             for (m=enm2; m>=l; m--)
11290                 {
11291                 /* removed m = enm2 + l - mm and above loop to remove variables */
11292                 zz = h[m][m];
11293                 r = x - zz;
11294                 s = y - zz;
11295                 p = (r * s - w) / h[m+1][m] + h[m][m+1];
11296                 q = h[m+1][m+1] - zz - r - s;
11297                 r = h[m+2][m+1];
11298                 s = fabs(p) + fabs(q) + fabs(r);
11299                 p /= s;
11300                 q /= s;
11301                 r /= s;
11302                 if (m == l)
11303                     break; /* changed to break to remove a goto statement */
11304                 tst1 = fabs(p) * (fabs(h[m-1][m-1]) + fabs(zz) + fabs(h[m+1][m+1]));
11305                 tst2 = tst1 + fabs(h[m][m-1]) * (fabs(q) + fabs(r));
11306                 if (fabs(tst2 - tst1) < ETA) /* tst2 == tst1 */
11307                     break; /* changed to break to remove a goto statement */
11308                 }
11309
11310             mp2 = m + 2;
11311             for (i = mp2; i <= en; i++)
11312                 {
11313                 h[i][i-2] = 0.0;
11314                 if (i != mp2) /* changed "==" to "!=" to remove a goto statement */
11315                     h[i][i-3] = 0.0;
11316                 }
11317
11318             /* MrBFlt QR step involving rows l to en and columns m to en */
11319             for (k=m; k<=na; k++)
11320                 {
11321                 notlas = (k != na);
11322                 if (k != m) /* changed "==" to "!=" to remove a goto statement */
11323                     {
11324                     p = h[k][k-1];
11325                     q = h[k+1][k-1];
11326                     r = 0.0;
11327                     if (notlas)
11328                         r = h[k+2][k-1];
11329                     x = fabs(p) + fabs(q) + fabs(r);
11330                     if (x < ETA) /* == 0.0 */
11331                         continue; /* changed to continue remove a goto statement */
11332                     p /= x;
11333                     q /= x;
11334                     r /= x;
11335                     }
11336
11337                 /*s = sqrt(p*p+q*q+r*r);
11338                 sgn = (p<0)?-1:(p>0);
11339                 s = sgn*sqrt(p*p+q*q+r*r);*/
11340                 s = D_sign(sqrt(p*p + q*q + r*r), p);
11341                 if (k != m) /* changed "==" to "!=" to remove a goto statement */
11342                     h[k][k-1] = -s * x;
11343                 else if (l != m) /* else if gets rid of another goto statement */
11344                     h[k][k-1] = -h[k][k-1];
11345                 p += s;
11346                 x = p / s;
11347                 y = q / s;
11348                 zz = r / s;
11349                 q /= p;
11350                 r /= p;
11351                 if (!notlas) /* changed to !notlas to remove goto statement (see **) */
11352                     {
11353                     /* row modification */
11354                     for (j=k; j<dim; j++)
11355                         {
11356                         p = h[k][j] + q * h[k+1][j];
11357                         h[k][j] -= p * x;
11358                         h[k+1][j] -= p * y;
11359                         }
11360                     j = MIN(en, k + 3);
11361
11362                     /* column modification */
11363                     for (i=0; i<=j; i++)
11364                         {
11365                         p = x * h[i][k] + y * h[i][k+1];
11366                         h[i][k] -= p;
11367                         h[i][k+1] -= p * q;
11368                         }
11369
11370                     /* accumulate transformations */
11371                     for (i=low; i<=high; i++)
11372                         {
11373                         p = x * z[i][k] + y * z[i][k+1];
11374                         z[i][k] -= p;
11375                         z[i][k+1] -= p * q;
11376                         }
11377                     }
11378                 else /* (**) also put in else */
11379                     {
11380                     /* row modification */
11381                     for (j=k; j<dim; j++)
11382                         {
11383                         p = h[k][j] + q * h[k+1][j] + r * h[k+2][j];
11384                         h[k][j] -= p * x;
11385                         h[k+1][j] -= p * y;
11386                         h[k+2][j] -= p * zz;
11387                         }
11388                     j = MIN(en, k + 3);
11389
11390                     /* column modification */
11391                     for (i = 0; i <= j; i++)
11392                         {
11393                         p = x * h[i][k] + y * h[i][k+1] + zz * h[i][k+2];
11394                         h[i][k] -= p;
11395                         h[i][k+1] -= p * q;
11396                         h[i][k+2] -= p * r;
11397                         }
11398
11399                     /* accumulate transformations */
11400                     for (i = low; i <= high; i++)
11401                         {
11402                         p = x * z[i][k] + y * z[i][k+1] + zz * z[i][k+2];
11403                         z[i][k] -= p;
11404                         z[i][k+1] -= p * q;
11405                         z[i][k+2] -= p * r;
11406                         }
11407                     }
11408                 }
11409             }
11410
11411         if (twoRoots)
11412             {
11413             /* two roots found */
11414             p = (y - x) / 2.0;
11415             q = p * p + w;
11416             zz = sqrt(fabs(q));
11417             h[en][en] = x + t;
11418             x = h[en][en];
11419             h[na][na] = y + t;
11420             if (q >= -1e-12) /* change "<" to ">=", and also change "0.0" to */
11421                 {            /* a small number (Swofford's change)           */
11422                 /* real pair */
11423                 zz = p + D_sign(zz, p);
11424                 wr[na] = x + zz;
11425                 wr[en] = wr[na];
11426                 if (fabs(zz) > ETA) /* != 0.0 */
11427                     wr[en] = x - w/zz;
11428                 wi[na] = 0.0;
11429                 wi[en] = 0.0;
11430                 x = h[en][na];
11431                 s = fabs(x) + fabs(zz);
11432                 p = x / s;
11433                 q = zz / s;
11434                 r = sqrt(p*p + q*q);
11435                 p /= r;
11436                 q /= r;
11437
11438                 /* row modification */
11439                 for (j=na; j<dim; j++)
11440                     {
11441                     zz = h[na][j];
11442                     h[na][j] = q * zz + p * h[en][j];
11443                     h[en][j] = q * h[en][j] - p * zz;
11444                     }
11445
11446                 /* column modification */
11447                 for (i = 0; i <= en; i++)
11448                     {
11449                     zz = h[i][na];
11450                     h[i][na] = q * zz + p * h[i][en];
11451                     h[i][en] = q * h[i][en] - p * zz;
11452                     }
11453
11454                 /* accumulate transformations */
11455                 for (i = low; i <= high; i++)
11456                     {
11457                     zz = z[i][na];
11458                     z[i][na] = q * zz + p * z[i][en];
11459                     z[i][en] = q * z[i][en] - p * zz;
11460                     }
11461                 }
11462             else
11463                 {
11464                 /* complex pair */
11465                 wr[na] = x + p;
11466                 wr[en] = x + p;
11467                 wi[na] = zz;
11468                 wi[en] = -zz;
11469                 }
11470             en = enm2;
11471             }
11472         else
11473             {
11474             /* one root found */
11475             h[en][en] = x + t;
11476             wr[en] = h[en][en];
11477             wi[en] = 0.0;
11478             en = na;
11479             }
11480         }
11481
11482     if (fabs(norm) < ETA) /* == 0.0 */
11483         return (0); /* was a goto end of function */
11484
11485     for (en=dim-1; en>=0; en--)
11486         {
11487         /*en = n - nn - 1; and change for loop */
11488         p = wr[en];
11489         q = wi[en];
11490         na = en - 1;
11491
11492         if (q < -1e-12)
11493             {
11494             /* last vector component chosen imaginary so that eigenvector
11495                matrix is triangular */
11496             m = na;
11497             if (fabs(h[en][na]) > fabs(h[na][en]))
11498                 {
11499                 h[na][na] = q / h[en][na];
11500                 h[na][en] = -(h[en][en] - p) / h[en][na];
11501                 }
11502             else
11503                 ComplexDivision2 (0.0, -h[na][en], h[na][na] - p, q, &h[na][na], &h[na][en]);
11504
11505             h[en][na] = 0.0;
11506             h[en][en] = 1.0;
11507             enm2 = na - 1;
11508             if (enm2 >= 0) /* changed direction to remove goto statement */
11509                 {
11510                 for (i=enm2; i>=0; i--)
11511                     {
11512                     w = h[i][i] - p;
11513                     ra = 0.0;
11514                     sa = 0.0;
11515
11516                     for (j=m; j<=en; j++)
11517                         {
11518                         ra += h[i][j] * h[j][na];
11519                         sa += h[i][j] * h[j][en];
11520                         }
11521
11522                     if (wi[i] < 0.0) /* changed direction to remove goto statement */
11523                         {
11524                         zz = w;
11525                         r = ra;
11526                         s = sa;
11527                         }
11528                     else
11529                         {
11530                         m = i;
11531                         if (fabs(wi[i])<ETA) /* == 0.0 */ /* changed direction to remove goto statement */
11532                             ComplexDivision2 (-ra, -sa, w, q, &h[i][na], &h[i][en]);
11533                         else
11534                             {
11535                             /* solve complex equations */
11536                             x = h[i][i+1];
11537                             y = h[i+1][i];
11538                             vr = (wr[i] - p) * (wr[i] - p) + wi[i] * wi[i] - q * q;
11539                             vi = (wr[i] - p) * 2.0 * q;
11540                             if ((fabs(vr)<ETA) && (fabs(vi)<ETA))
11541                                 {
11542                                 tst1 = norm * (fabs(w) + fabs(q) + fabs(x) + fabs(y) + fabs(zz));
11543                                 vr = tst1;
11544                                 do  {
11545                                     vr *= .01;
11546                                     tst2 = tst1 + vr;
11547                                     }
11548                                     while (tst2 > tst1); /* made into a do/while loop */
11549                                 }
11550                             ComplexDivision2 (x * r - zz * ra + q * sa, x * s - zz * sa - q * ra, vr, vi, &h[i][na], &h[i][en]);
11551                             if (fabs(x) > fabs(zz) + fabs(q)) /* changed direction to remove goto statement */
11552                                 {
11553                                 h[i+1][na] = (-ra - w * h[i][na] + q * h[i][en]) / x;
11554                                 h[i+1][en] = (-sa - w * h[i][en] - q * h[i][na]) / x;
11555                                 }
11556                             else
11557                                 ComplexDivision2 (-r - y * h[i][na], -s - y * h[i][en], zz, q, &h[i+1][na], &h[i+1][en]);
11558                             }
11559
11560                         /* overflow control */
11561                         tst1 = fabs(h[i][na]);
11562                         tst2 = fabs(h[i][en]);
11563                         t = MAX(tst1, tst2);
11564                         if (t > ETA) /* t != 0.0 */
11565                             {
11566                             tst1 = t;
11567                             tst2 = tst1 + 1.0 / tst1;
11568                             if (tst2 <= tst1)
11569                                 {
11570                                 for (j = i; j <= en; j++)
11571                                     {
11572                                     h[j][na] /= t;
11573                                     h[j][en] /= t;
11574                                     }
11575                                 }
11576                             }
11577                         }
11578                     }
11579                 }
11580             }
11581         else if (fabs(q)<ETA)
11582             {
11583             /* real vector */
11584             m = en;
11585             h[en][en] = 1.0;
11586             if (na >= 0)
11587                 {
11588                 for (i=na; i>=0; i--)
11589                     {
11590                     w = h[i][i] - p;
11591                     r = 0.0;
11592                     for (j = m; j <= en; j++)
11593                         r += h[i][j] * h[j][en];
11594                     if (wi[i] < 0.0) /* changed direction to remove goto statement */
11595                         {
11596                         zz = w;
11597                         s = r;
11598                         continue;  /* changed to continue to remove goto statement */
11599                         }
11600                     else
11601                         {
11602                         m = i;
11603                         if (fabs(wi[i])<ETA) /* changed to remove goto statement */
11604                             {
11605                             t = w;
11606                             if (fabs(t)<ETA)  /* changed to remove goto statement */
11607                                 {
11608                                 tst1 = norm;
11609                                 t = tst1;
11610                                 do  {
11611                                     t *= .01;
11612                                     tst2 = norm + t;
11613                                     }
11614                                     while (tst2 > tst1);
11615                                 }
11616                             h[i][en] = -r / t;
11617                             }
11618                         else
11619                             {
11620                             /* solve real equations */
11621                             x = h[i][i+1];
11622                             y = h[i+1][i];
11623                             q = (wr[i] - p) * (wr[i] - p) + wi[i] * wi[i];
11624                             t = (x * s - zz * r) / q;
11625                             h[i][en] = t;
11626                             if (fabs(x) > fabs(zz))  /* changed direction to remove goto statement */
11627                                 h[i+1][en] = (-r - w * t) / x;
11628                             else
11629                                 h[i+1][en] = (-s - y * t) / zz;
11630                             }
11631
11632                         /* overflow control */
11633                         t = fabs(h[i][en]);
11634                         if (t > ETA)
11635                             {
11636                             tst1 = t;
11637                             tst2 = tst1 + 1. / tst1;
11638                             if (tst2 <= tst1)
11639                                 {
11640                                 for (j = i; j <= en; j++)
11641                                     h[j][en] /= t;
11642                                 }
11643                             }
11644                         }
11645                     }
11646                 }
11647             }
11648         }
11649
11650     for (i=0; i<dim; i++)
11651         {
11652         if ((i < low) || (i > high)) /* changed to rid goto statement */
11653             {
11654             for (j=i; j<dim; j++)
11655                 z[i][j] = h[i][j];
11656             }
11657         }
11658
11659     /* multiply by transformation matrix to give vectors of original
11660        full matrix */
11661     for (j=dim-1; j>=low; j--)
11662         {
11663         m = MIN(j, high);
11664         for (i=low; i<=high; i++)
11665             {
11666             zz = 0.0;
11667             for (k = low; k <= m; k++)
11668                 zz += z[i][k] * h[k][j];
11669             z[i][j] = zz;
11670             }
11671         }
11672
11673     return (0);
11674
11675 #if 0
11676 int hqr2 (int *nm, int *n, int *low, int *igh, MrBFlt *h__, MrBFlt *wr, MrBFlt *wi, MrBFlt *z__, int *ierr)
11677
11678 {
11679
11680     /* system generated locals */
11681     int h_dim1, h_offset, z_dim1, z_offset, i__1, i__2, i__3;
11682     MrBFlt d__1, d__2, d__3, d__4;
11683
11684     /* builtin functions */
11685     MrBFlt sqrt(doublereal), d_sign(doublereal *, doublereal *);
11686
11687     /* Local variables */
11688     static MrBFlt norm;
11689     static int i__, j, k, l, m;
11690     static MrBFlt p, q, r__, s, t, w, x, y;
11691     static int na, ii, en, jj;
11692     static MrBFlt ra, sa;
11693     static int ll, mm, nn;
11694     static MrBFlt vi, vr, zz;
11695     static logical notlas;
11696     static int mp2, itn, its, enm2;
11697     static MrBFlt tst1, tst2;
11698
11699     /* parameter adjustments */
11700     z_dim1 = *nm;
11701     z_offset = z_dim1 + 1;
11702     z__ -= z_offset;
11703     --wi;
11704     --wr;
11705     h_dim1 = *nm;
11706     h_offset = h_dim1 + 1;
11707     h__ -= h_offset;
11708
11709     /* function Body */
11710     *ierr = 0;
11711     norm = 0.;
11712     k = 1;
11713
11714     /* .......... store roots isolated by balanc and compute matrix norm .......... */
11715     i__1 = *n;
11716     for (i__ = 1; i__ <= i__1; ++i__)
11717         {
11718         i__2 = *n;
11719         for (j = k; j <= i__2; ++j)
11720             {
11721             /* L40: */
11722             norm += (d__1 = h__[i__ + j * h_dim1], abs(d__1));
11723             }
11724         k = i__;
11725         if (i__ >= *low && i__ <= *igh)
11726             goto L50;
11727         wr[i__] = h__[i__ + i__ * h_dim1];
11728         wi[i__] = 0.;
11729         L50:
11730             ;
11731         }
11732
11733     en = *igh;
11734     t = 0.;
11735     itn = *n * 30;
11736
11737     /* ..........search for next eigenvalues.......... */
11738     L60:
11739     if (en < *low)
11740         goto L340;
11741     its = 0;
11742     na = en - 1;
11743     enm2 = na - 1;
11744
11745     /* ..........look for single small sub-diagonal element for l=en step -1 until low do -- .......... */
11746     L70:
11747     i__1 = en;
11748     for (ll = *low; ll <= i__1; ++ll)
11749         {
11750         l = en + *low - ll;
11751         if (l == *low)
11752             goto L100;
11753         s = (d__1 = h__[l - 1 + (l - 1) * h_dim1], abs(d__1)) + (d__2 = h__[l + l * h_dim1], abs(d__2));
11754         if (s == 0.0)
11755             s = norm;
11756         tst1 = s;
11757         tst2 = tst1 + (d__1 = h__[l + (l - 1) * h_dim1], abs(d__1));
11758         if (tst2 == tst1)
11759             goto L100;
11760         /* L80: */
11761         }
11762
11763     /* .......... form shift .......... */
11764     L100:
11765     x = h__[en + en * h_dim1];
11766     if (l == en)
11767         goto L270;
11768     y = h__[na + na * h_dim1];
11769     w = h__[en + na * h_dim1] * h__[na + en * h_dim1];
11770     if (l == na)
11771         goto L280;
11772     if (itn == 0)
11773         goto L1000;
11774     if (its != 10 && its != 20)
11775         goto L130;
11776
11777     /* .......... form exceptional shift .......... */
11778     t += x;
11779
11780     i__1 = en;
11781     for (i__ = *low; i__ <= i__1; ++i__)
11782         {
11783         /* L120: */
11784         h__[i__ + i__ * h_dim1] -= x;
11785         }
11786
11787     s = (d__1 = h__[en + na * h_dim1], abs(d__1)) + (d__2 = h__[na + enm2 * h_dim1], abs(d__2));
11788     x = s * 0.75;
11789     y = x;
11790     w = s * -0.4375 * s;
11791     L130:
11792     ++its;
11793     --itn;
11794
11795     /* .......... look for two consecutive small sub-diagonal elements for m=en-2 step -1 until l do -- .......... */
11796     i__1 = enm2;
11797     for (mm = l; mm <= i__1; ++mm)
11798         {
11799         m = enm2 + l - mm;
11800         zz = h__[m + m * h_dim1];
11801         r__ = x - zz;
11802         s = y - zz;
11803         p = (r__ * s - w) / h__[m + 1 + m * h_dim1] + h__[m + (m + 1) * h_dim1];
11804         q = h__[m + 1 + (m + 1) * h_dim1] - zz - r__ - s;
11805         r__ = h__[m + 2 + (m + 1) * h_dim1];
11806         s = abs(p) + abs(q) + abs(r__);
11807         p /= s;
11808         q /= s;
11809         r__ /= s;
11810         if (m == l)
11811             goto L150;
11812         tst1 = abs(p) * ((d__1 = h__[m - 1 + (m - 1) * h_dim1], abs(d__1)) +
11813         abs(zz) + (d__2 = h__[m + 1 + (m + 1) * h_dim1], abs(d__2)));
11814         tst2 = tst1 + (d__1 = h__[m + (m - 1) * h_dim1], abs(d__1)) * (abs(q) + abs(r__));
11815         if (tst2 == tst1)
11816             goto L150;
11817         /* L140: */
11818         }
11819     L150:
11820     mp2 = m + 2;
11821
11822     i__1 = en;
11823     for (i__ = mp2; i__ <= i__1; ++i__)
11824         {
11825         h__[i__ + (i__ - 2) * h_dim1] = 0.0;
11826         if (i__ == mp2)
11827             goto L160;
11828         h__[i__ + (i__ - 3) * h_dim1] = 0.;
11829         L160:
11830             ;
11831         }
11832
11833     /*     .......... MrBFlt qr step involving rows l to en and columns m to en .......... */
11834     i__1 = na;
11835     for (k = m; k <= i__1; ++k)
11836         {
11837         notlas = k != na;
11838         if (k == m)
11839             goto L170;
11840         p = h__[k + (k - 1) * h_dim1];
11841         q = h__[k + 1 + (k - 1) * h_dim1];
11842         r__ = 0.;
11843         if (notlas)
11844             r__ = h__[k + 2 + (k - 1) * h_dim1];
11845         x = abs(p) + abs(q) + abs(r__);
11846         if (x == 0.)
11847             goto L260;
11848         p /= x;
11849         q /= x;
11850         r__ /= x;
11851         L170:
11852         d__1 = sqrt(p * p + q * q + r__ * r__);
11853         s = d_sign(&d__1, &p);
11854         if (k == m)
11855             goto L180;
11856         h__[k + (k - 1) * h_dim1] = -s * x;
11857         goto L190;
11858         L180:
11859         if (l != m)
11860             {
11861             h__[k + (k - 1) * h_dim1] = -h__[k + (k - 1) * h_dim1];
11862             }
11863         L190:
11864         p += s;
11865         x = p / s;
11866         y = q / s;
11867         zz = r__ / s;
11868         q /= p;
11869         r__ /= p;
11870         if (notlas)
11871             goto L225;
11872
11873         /* .......... row modification .......... */
11874         i__2 = *n;
11875         for (j = k; j <= i__2; ++j)
11876             {
11877             p = h__[k + j * h_dim1] + q * h__[k + 1 + j * h_dim1];
11878             h__[k + j * h_dim1] -= p * x;
11879             h__[k + 1 + j * h_dim1] -= p * y;
11880             /* L200: */
11881             }
11882
11883         /* computing MIN */
11884         i__2 = en, i__3 = k + 3;
11885         j = min(i__2,i__3);
11886
11887         /* .......... column modification .......... */
11888         i__2 = j;
11889         for (i__ = 1; i__ <= i__2; ++i__)
11890             {
11891             p = x * h__[i__ + k * h_dim1] + y * h__[i__ + (k + 1) * h_dim1];
11892             h__[i__ + k * h_dim1] -= p;
11893             h__[i__ + (k + 1) * h_dim1] -= p * q;
11894             /* L210: */
11895             }
11896
11897         /* .......... accumulate transformations .......... */
11898         i__2 = *igh;
11899         for (i__ = *low; i__ <= i__2; ++i__)
11900             {
11901             p = x * z__[i__ + k * z_dim1] + y * z__[i__ + (k + 1) * z_dim1];
11902             z__[i__ + k * z_dim1] -= p;
11903             z__[i__ + (k + 1) * z_dim1] -= p * q;
11904             /* L220: */
11905             }
11906         goto L255;
11907         L225:
11908
11909         /* .......... row modification .......... */
11910         i__2 = *n;
11911         for (j = k; j <= i__2; ++j)
11912             {
11913             p = h__[k + j * h_dim1] + q * h__[k + 1 + j * h_dim1] + r__ * h__[k + 2 + j * h_dim1];
11914             h__[k + j * h_dim1] -= p * x;
11915             h__[k + 1 + j * h_dim1] -= p * y;
11916             h__[k + 2 + j * h_dim1] -= p * zz;
11917             /* L230: */
11918             }
11919
11920         /* computing MIN */
11921         i__2 = en, i__3 = k + 3;
11922         j = min(i__2,i__3);
11923
11924         /* .......... column modification .......... */
11925         i__2 = j;
11926         for (i__ = 1; i__ <= i__2; ++i__)
11927             {
11928             p = x * h__[i__ + k * h_dim1] + y * h__[i__ + (k + 1) * h_dim1] +
11929             zz * h__[i__ + (k + 2) * h_dim1];
11930             h__[i__ + k * h_dim1] -= p;
11931             h__[i__ + (k + 1) * h_dim1] -= p * q;
11932             h__[i__ + (k + 2) * h_dim1] -= p * r__;
11933             /* L240: */
11934             }
11935
11936         /* .......... accumulate transformations .......... */
11937         i__2 = *igh;
11938         for (i__ = *low; i__ <= i__2; ++i__)
11939             {
11940             p = x * z__[i__ + k * z_dim1] + y * z__[i__ + (k + 1) * z_dim1] + zz * z__[i__ + (k + 2) * z_dim1];
11941             z__[i__ + k * z_dim1] -= p;
11942             z__[i__ + (k + 1) * z_dim1] -= p * q;
11943             z__[i__ + (k + 2) * z_dim1] -= p * r__;
11944             /* L250: */
11945             }
11946         L255:
11947         L260:
11948             ;
11949         }
11950     goto L70;
11951
11952     /* .......... one root found .......... */
11953     L270:
11954     h__[en + en * h_dim1] = x + t;
11955     wr[en] = h__[en + en * h_dim1];
11956     wi[en] = 0.;
11957     en = na;
11958     goto L60;
11959
11960     /* .......... two roots found .......... */
11961     L280:
11962     p = (y - x) / 2.;
11963     q = p * p + w;
11964     zz = sqrt((abs(q)));
11965     h__[en + en * h_dim1] = x + t;
11966     x = h__[en + en * h_dim1];
11967     h__[na + na * h_dim1] = y + t;
11968     if (q < 0.)
11969         goto L320;
11970
11971     /* .......... real pair .......... */
11972     zz = p + d_sign(&zz, &p);
11973     wr[na] = x + zz;
11974     wr[en] = wr[na];
11975     if (zz != 0.)
11976         {
11977         wr[en] = x - w / zz;
11978         }
11979     wi[na] = 0.0;
11980     wi[en] = 0.0;
11981     x = h__[en + na * h_dim1];
11982     s = abs(x) + abs(zz);
11983     p = x / s;
11984     q = zz / s;
11985     r__ = sqrt(p * p + q * q);
11986     p /= r__;
11987     q /= r__;
11988
11989     /* .......... row modification .......... */
11990     i__1 = *n;
11991     for (j = na; j <= i__1; ++j)
11992         {
11993         zz = h__[na + j * h_dim1];
11994         h__[na + j * h_dim1] = q * zz + p * h__[en + j * h_dim1];
11995         h__[en + j * h_dim1] = q * h__[en + j * h_dim1] - p * zz;
11996         /* L290: */
11997         }
11998
11999     /* .......... column modification .......... */
12000     i__1 = en;
12001     for (i__ = 1; i__ <= i__1; ++i__)
12002         {
12003         zz = h__[i__ + na * h_dim1];
12004         h__[i__ + na * h_dim1] = q * zz + p * h__[i__ + en * h_dim1];
12005         h__[i__ + en * h_dim1] = q * h__[i__ + en * h_dim1] - p * zz;
12006         /* L300: */
12007         }
12008
12009     /* .......... accumulate transformations .......... */
12010     i__1 = *igh;
12011     for (i__ = *low; i__ <= i__1; ++i__)
12012         {
12013         zz = z__[i__ + na * z_dim1];
12014         z__[i__ + na * z_dim1] = q * zz + p * z__[i__ + en * z_dim1];
12015         z__[i__ + en * z_dim1] = q * z__[i__ + en * z_dim1] - p * zz;
12016         /* L310: */
12017         }
12018     goto L330;
12019
12020     /* .......... complex pair .......... */
12021     L320:
12022     wr[na] = x + p;
12023     wr[en] = x + p;
12024     wi[na] = zz;
12025     wi[en] = -zz;
12026     L330:
12027     en = enm2;
12028     goto L60;
12029
12030     /* .......... all roots found.  backsubstitute to find vectors of upper triangular form .......... */
12031     L340:
12032     if (norm == 0.0)
12033         goto L1001;
12034
12035     /* .......... for en=n step -1 until 1 do -- .......... */
12036     i__1 = *n;
12037     for (nn = 1; nn <= i__1; ++nn)
12038         {
12039         en = *n + 1 - nn;
12040         p = wr[en];
12041         q = wi[en];
12042         na = en - 1;
12043         if (q < 0.)
12044             goto L710;
12045         else if (q == 0)
12046             goto L600;
12047         else
12048             goto L800;
12049
12050         /* .......... real vector .......... */
12051         L600:
12052         m = en;
12053         h__[en + en * h_dim1] = 1.0;
12054         if (na == 0)
12055             goto L800;
12056
12057         /*     .......... for i=en-1 step -1 until 1 do -- .......... */
12058         i__2 = na;
12059         for (ii = 1; ii <= i__2; ++ii)
12060             {
12061             i__ = en - ii;
12062             w = h__[i__ + i__ * h_dim1] - p;
12063             r__ = 0.0;
12064
12065             i__3 = en;
12066             for (j = m; j <= i__3; ++j)
12067                 {
12068                 /* L610: */
12069                 r__ += h__[i__ + j * h_dim1] * h__[j + en * h_dim1];
12070                 }
12071
12072             if (wi[i__] >= 0.0)
12073                 goto L630;
12074             zz = w;
12075             s = r__;
12076             goto L700;
12077             L630:
12078             m = i__;
12079             if (wi[i__] != 0.0)
12080                 goto L640;
12081             t = w;
12082             if (t != 0.0)
12083                 goto L635;
12084             tst1 = norm;
12085             t = tst1;
12086             L632:
12087             t *= 0.01;
12088             tst2 = norm + t;
12089             if (tst2 > tst1)
12090                 goto L632;
12091             L635:
12092             h__[i__ + en * h_dim1] = -r__ / t;
12093             goto L680;
12094
12095             /* .......... solve real equations .......... */
12096             L640:
12097             x = h__[i__ + (i__ + 1) * h_dim1];
12098             y = h__[i__ + 1 + i__ * h_dim1];
12099             q = (wr[i__] - p) * (wr[i__] - p) + wi[i__] * wi[i__];
12100             t = (x * s - zz * r__) / q;
12101             h__[i__ + en * h_dim1] = t;
12102             if (abs(x) <= abs(zz))
12103                 goto L650;
12104             h__[i__ + 1 + en * h_dim1] = (-r__ - w * t) / x;
12105             goto L680;
12106             L650:
12107             h__[i__ + 1 + en * h_dim1] = (-s - y * t) / zz;
12108
12109             /*     .......... overflow control .......... */
12110             L680:
12111             t = (d__1 = h__[i__ + en * h_dim1], abs(d__1));
12112             if (t == 0.0)
12113                 goto L700;
12114             tst1 = t;
12115             tst2 = tst1 + 1.0 / tst1;
12116             if (tst2 > tst1)
12117                 goto L700;
12118             i__3 = en;
12119             for (j = i__; j <= i__3; ++j)
12120                 {
12121                 h__[j + en * h_dim1] /= t;
12122                 /* L690: */
12123                 }
12124
12125             L700:
12126                 ;
12127             }
12128
12129         /* .......... end real vector .......... */
12130         goto L800;
12131
12132         /* .......... complex vector .......... */
12133         L710:
12134         m = na;
12135
12136         /* .......... last vector component chosen imaginary so that eigenvector matrix is triangular .......... */
12137         if ((d__1 = h__[en + na * h_dim1], abs(d__1)) <= (d__2 = h__[na + en *
12138         h_dim1], abs(d__2)))
12139             goto L720;
12140         h__[na + na * h_dim1] = q / h__[en + na * h_dim1];
12141         h__[na + en * h_dim1] = -(h__[en + en * h_dim1] - p) / h__[en + na * h_dim1];
12142         goto L730;
12143         L720:
12144         d__1 = -h__[na + en * h_dim1];
12145         d__2 = h__[na + na * h_dim1] - p;
12146         cdiv_(&c_b49, &d__1, &d__2, &q, &h__[na + na * h_dim1], &h__[na + en *
12147         h_dim1]);
12148         L730:
12149         h__[en + na * h_dim1] = 0.0;
12150         h__[en + en * h_dim1] = 1.0;
12151         enm2 = na - 1;
12152         if (enm2 == 0)
12153             goto L800;
12154
12155         /*     .......... for i=en-2 step -1 until 1 do -- .......... */
12156         i__2 = enm2;
12157         for (ii = 1; ii <= i__2; ++ii)
12158             {
12159             i__ = na - ii;
12160             w = h__[i__ + i__ * h_dim1] - p;
12161             ra = 0.0;
12162             sa = 0.0;
12163
12164             i__3 = en;
12165             for (j = m; j <= i__3; ++j)
12166                 {
12167                 ra += h__[i__ + j * h_dim1] * h__[j + na * h_dim1];
12168                 sa += h__[i__ + j * h_dim1] * h__[j + en * h_dim1];
12169                 /* L760: */
12170                 }
12171
12172             if (wi[i__] >= 0.0)
12173                 goto L770;
12174             zz = w;
12175             r__ = ra;
12176             s = sa;
12177             goto L795;
12178             L770:
12179             m = i__;
12180             if (wi[i__] != 0.0)
12181                 goto L780;
12182             d__1 = -ra;
12183             d__2 = -sa;
12184             cdiv_(&d__1, &d__2, &w, &q, &h__[i__ + na * h_dim1], &h__[i__ + en * h_dim1]);
12185             goto L790;
12186
12187             /*     .......... solve complex equations .......... */
12188             L780:
12189             x = h__[i__ + (i__ + 1) * h_dim1];
12190             y = h__[i__ + 1 + i__ * h_dim1];
12191             vr = (wr[i__] - p) * (wr[i__] - p) + wi[i__] * wi[i__] - q * q;
12192             vi = (wr[i__] - p) * 2.0 * q;
12193             if (vr != 0.0 || vi != 0.0)
12194                 goto L784;
12195             tst1 = norm * (abs(w) + abs(q) + abs(x) + abs(y) + abs(zz));
12196             vr = tst1;
12197             L783:
12198             vr *= 0.01;
12199             tst2 = tst1 + vr;
12200             if (tst2 > tst1)
12201                 goto L783;
12202             L784:
12203             d__1 = x * r__ - zz * ra + q * sa;
12204             d__2 = x * s - zz * sa - q * ra;
12205             cdiv_(&d__1, &d__2, &vr, &vi, &h__[i__ + na * h_dim1], &h__[i__ + en * h_dim1]);
12206             if (abs(x) <= abs(zz) + abs(q))
12207                 goto L785;
12208             h__[i__ + 1 + na * h_dim1] = (-ra - w * h__[i__ + na * h_dim1] + q * h__[i__ + en * h_dim1]) / x;
12209             h__[i__ + 1 + en * h_dim1] = (-sa - w * h__[i__ + en * h_dim1] - q * h__[i__ + na * h_dim1]) / x;
12210             goto L790;
12211             L785:
12212             d__1 = -r__ - y * h__[i__ + na * h_dim1];
12213             d__2 = -s - y * h__[i__ + en * h_dim1];
12214             cdiv_(&d__1, &d__2, &zz, &q, &h__[i__ + 1 + na * h_dim1], &h__[i__ + 1 + en * h_dim1]);
12215
12216             /*     .......... overflow control .......... */
12217             L790:
12218             /* Computing MAX */
12219             d__3 = (d__1 = h__[i__ + na * h_dim1], abs(d__1)), d__4 = (d__2 = h__[i__ + en * h_dim1], abs(d__2));
12220             t = max(d__3,d__4);
12221             if (t == 0.0)
12222                 goto L795;
12223             tst1 = t;
12224             tst2 = tst1 + 1.0 / tst1;
12225             if (tst2 > tst1)
12226                 goto L795;
12227             i__3 = en;
12228             for (j = i__; j <= i__3; ++j)
12229                 {
12230                 h__[j + na * h_dim1] /= t;
12231                 h__[j + en * h_dim1] /= t;
12232                 /* L792: */
12233                 }
12234             L795:
12235                 ;
12236             }
12237         /*     .......... end complex vector .......... */
12238         L800:
12239             ;
12240         }
12241     /*     .......... end back substitution vectors of isolated roots .......... */
12242     i__1 = *n;
12243     for (i__ = 1; i__ <= i__1; ++i__)
12244         {
12245         if (i__ >= *low && i__ <= *igh)
12246             goto L840;
12247         i__2 = *n;
12248         for (j = i__; j <= i__2; ++j)
12249             {
12250             /* L820: */
12251             z__[i__ + j * z_dim1] = h__[i__ + j * h_dim1];
12252             }
12253         L840:
12254         ;
12255         }
12256
12257     /* .......... multiply by transformation matrix to give vectors of original full matrix. */
12258     /*            for j=n step -1 until low do -- .......... */
12259     i__1 = *n;
12260     for (jj = *low; jj <= i__1; ++jj)
12261         {
12262         j = *n + *low - jj;
12263         m = min(j,*igh);
12264
12265         i__2 = *igh;
12266         for (i__ = *low; i__ <= i__2; ++i__)
12267             {
12268             zz = 0.0;
12269             i__3 = m;
12270             for (k = *low; k <= i__3; ++k)
12271                 {
12272                 /* L860: */
12273                 zz += z__[i__ + k * z_dim1] * h__[k + j * h_dim1];
12274                 }
12275
12276             z__[i__ + j * z_dim1] = zz;
12277             /* L880: */
12278             }
12279         }
12280
12281     goto L1001;
12282     /* .......... set error -- all eigenvalues have not converged after 30*n iterations .......... */
12283     L1000:
12284     *ierr = en;
12285     L1001:
12286     return 0;
12287
12288 }
12289 /* end f2c version of code */
12290 #endif
12291
12292 }
12293
12294
12295 MrBFlt IncompleteBetaFunction (MrBFlt alpha, MrBFlt beta, MrBFlt x)
12296 {
12297     MrBFlt      bt, gm1, gm2, gm3, temp;
12298
12299     if (x < 0.0 || x > 1.0)
12300         {
12301         MrBayesPrint ("%s   Error: Problem in IncompleteBetaFunction.\n", spacer);
12302         exit (0);
12303         }
12304     if (fabs(x) < ETA || fabs(x-1.0)<ETA) /* x == 0.0 || x == 1.0 */
12305         {
12306         bt = 0.0;
12307         }
12308     else
12309         {
12310         gm1 = LnGamma (alpha + beta);
12311         gm2 = LnGamma (alpha);
12312         gm3 = LnGamma (beta);
12313         temp = gm1 - gm2 - gm3 + (alpha) * log(x) + (beta) * log(1.0 - x);
12314         bt = exp(temp);
12315         }
12316     if (x < (alpha + 1.0)/(alpha + beta + 2.0))
12317         return (bt * BetaCf(alpha, beta, x) / alpha);
12318     else
12319         return (1.0 - bt * BetaCf(beta, alpha, 1.0-x) / beta);
12320 }
12321
12322
12323 /*---------------------------------------------------------------------------------
12324 |
12325 |   IncompleteGamma
12326 |
12327 |   Returns the incomplete gamma ratio I(x,alpha) where x is the upper
12328 |   limit of the integration and alpha is the shape parameter.  Returns (-1)
12329 |   if in error.
12330 |
12331 |   Bhattacharjee, G. P.  1970.  The incomplete gamma integral.  Applied
12332 |      Statistics, 19:285-287 (AS32)
12333 |
12334 ---------------------------------------------------------------------------------*/
12335 MrBFlt IncompleteGamma (MrBFlt x, MrBFlt alpha, MrBFlt LnGamma_alpha)
12336 {
12337     int             i;
12338     MrBFlt      p = alpha, g = LnGamma_alpha,
12339                     accurate = 1e-8, overflow = 1e30,
12340                     factor, gin = 0.0, rn = 0.0, a = 0.0, b = 0.0, an = 0.0,
12341                     dif = 0.0, term = 0.0, pn[6];
12342
12343     if (fabs(x) < ETA)
12344         return (0.0);
12345     if (x < 0 || p <= 0)
12346         return (-1.0);
12347
12348     factor = exp(p*log(x)-x-g);
12349     if (x>1 && x>=p)
12350         goto l30;
12351     gin = 1.0;
12352     term = 1.0;
12353     rn = p;
12354     l20:
12355         rn++;
12356         term *= x/rn;
12357         gin += term;
12358         if (term > accurate)
12359             goto l20;
12360         gin *= factor/p;
12361         goto l50;
12362     l30:
12363         a = 1.0-p;
12364         b = a+x+1.0;
12365         term = 0.0;
12366         pn[0] = 1.0;
12367         pn[1] = x;
12368         pn[2] = x+1;
12369         pn[3] = x*b;
12370         gin = pn[2]/pn[3];
12371     l32:
12372         a++;
12373         b += 2.0;
12374         term++;
12375         an = a*term;
12376         for (i=0; i<2; i++)
12377             pn[i+4] = b*pn[i+2]-an*pn[i];
12378         if (fabs(pn[5]) < ETA)
12379             goto l35;
12380         rn = pn[4]/pn[5];
12381         dif = fabs(gin-rn);
12382         if (dif>accurate)
12383             goto l34;
12384         if (dif<=accurate*rn)
12385             goto l42;
12386     l34:
12387         gin = rn;
12388     l35:
12389         for (i=0; i<4; i++)
12390             pn[i] = pn[i+2];
12391         if (fabs(pn[4]) < overflow)
12392             goto l32;
12393         for (i=0; i<4; i++)
12394             pn[i] /= overflow;
12395         goto l32;
12396     l42:
12397         gin = 1.0-factor*gin;
12398     l50:
12399         return (gin);
12400 }
12401
12402
12403 /*---------------------------------------------------------------------------------
12404 |
12405 |   InvertMatrix
12406 |
12407 |   Calculates aInv = a^{-1} using LU-decomposition. The input matrix a is
12408 |   destroyed in the process. The program returns an error if the matrix is
12409 |   singular. col and indx are work vectors.
12410 |
12411 ---------------------------------------------------------------------------------*/
12412 int InvertMatrix (int dim, MrBFlt **a, MrBFlt *col, int *indx, MrBFlt **aInv)
12413 {
12414     int         rc, i, j;
12415
12416     rc = LUDecompose (dim, a, col, indx, (MrBFlt *)NULL);
12417     if (rc == FALSE)
12418         {
12419         for (j = 0; j < dim; j++)
12420             {
12421             for (i = 0; i < dim; i++)
12422                 col[i] = 0.0;
12423             col[j] = 1.0;
12424             LUBackSubstitution (dim, a, indx, col);
12425             for (i = 0; i < dim; i++)
12426                 aInv[i][j] = col[i];
12427             }
12428         }
12429
12430     return (rc);
12431 }
12432
12433
12434 /*---------------------------------------------------------------------------------
12435 |
12436 |   LBinormal
12437 |
12438 |   L(h1,h2,r) = prob(x>h1, y>h2), where x and y are standard binormal,
12439 |   with r=corr(x,y),  error < 2e-7.
12440 |
12441 |   Drezner Z., and G.O. Wesolowsky (1990) On the computation of the
12442 |      bivariate normal integral.  J. Statist. Comput. Simul. 35:101-107.
12443 |
12444 ---------------------------------------------------------------------------------*/
12445 MrBFlt LBinormal (MrBFlt h1, MrBFlt h2, MrBFlt r)
12446 {
12447     int i;
12448     MrBFlt      x[]={0.04691008, 0.23076534, 0.5, 0.76923466, 0.95308992};
12449     MrBFlt      w[]={0.018854042, 0.038088059, 0.0452707394,0.038088059,0.018854042};
12450     MrBFlt      Lh=0.0, r1, r2, r3, rr, aa, ab, h3, h5, h6, h7, h12, temp1, temp2, exp1, exp2;
12451
12452     h12 = (h1 * h1 + h2 * h2) / 2.0;
12453     if (fabs(r) >= 0.7)
12454         {
12455         r2 = 1.0 - r * r;
12456         r3 = sqrt(r2);
12457         if (r < 0)
12458             h2 *= -1;
12459         h3 = h1 * h2;
12460         h7 = exp(-h3 / 2.0);
12461         if (fabs(r-1.0)>ETA)  /* fabs(r) != 1.0 */
12462             {
12463             h6 = fabs(h1-h2);
12464             h5 = h6 * h6 / 2.0;
12465             h6 /= r3;
12466             aa = 0.5 - h3 / 8;
12467             ab = 3.0 - 2.0 * aa * h5;
12468             temp1 = -h5 / r2;
12469             if (temp1 < -100.0)
12470                 exp1 = 0.0;
12471             else
12472                 exp1 = exp(temp1);
12473             Lh = 0.13298076 * h6 * ab * (1.0 - CdfNormal(h6)) - exp1 * (ab + aa * r2) * 0.053051647;
12474             for (i=0; i<5; i++)
12475                 {
12476                 r1 = r3 * x[i];
12477                 rr = r1 * r1;
12478                 r2 = sqrt(1.0 - rr);
12479                 temp1 = -h5 / rr;
12480                 if (temp1 < -100.0)
12481                     exp1 = 0.0;
12482                 else
12483                     exp1 = exp(temp1);
12484                 temp2 = -h3 / (1.0 + r2);
12485                 if (temp2 < -100.0)
12486                     exp2 = 0.0;
12487                 else
12488                     exp2 = exp(temp2);
12489                 Lh -= w[i] * exp1 * (exp2 / r2 / h7 - 1.0 - aa * rr);
12490                 }
12491             }
12492         if (r > 0)
12493             Lh = Lh * r3 * h7 + (1.0 - CdfNormal(MAX(h1, h2)));
12494         else if (r<0)
12495             Lh = (h1 < h2 ? CdfNormal(h2) - CdfNormal(h1) : 0) - Lh * r3 * h7;
12496         }
12497     else
12498         {
12499         h3 = h1 * h2;
12500         if (fabs(r)>ETA)
12501             {
12502             for (i=0; i<5; i++)
12503                 {
12504                 r1 = r * x[i];
12505                 r2 = 1.0 - r1 * r1;
12506                 temp1 = (r1 * h3 - h12) / r2;
12507                 if (temp1 < -100.0)
12508                     exp1 = 0.0;
12509                 else
12510                     exp1 = exp(temp1);
12511                 Lh += w[i] * exp1 / sqrt(r2);
12512                 }
12513             }
12514         Lh = (1.0 - CdfNormal(h1)) * (1.0 - CdfNormal(h2)) + r * Lh;
12515         }
12516     return (Lh);
12517 }
12518
12519
12520 /*---------------------------------------------------------------------------------
12521 |
12522 |   LnFactorial: Calculates the log of the factorial for an integer
12523 |
12524 ---------------------------------------------------------------------------------*/
12525 MrBFlt  LnFactorial (int value)
12526 {
12527     int     i;
12528     MrBFlt  result;
12529
12530     result = 0.0;
12531
12532     for (i = 2; i<=value; i++)
12533         result += log(i);
12534
12535     return result;
12536 }
12537
12538
12539 /*---------------------------------------------------------------------------------
12540 |
12541 |   LnGamma
12542 |
12543 |   Calculates the log of the gamma function. The Gamma function is equal
12544 |   to:
12545 |
12546 |      Gamma(alp) = {integral from 0 to infinity} t^{alp-1} e^-t dt
12547 |
12548 |   The result is accurate to 10 decimal places. Stirling's formula is used
12549 |   for the central polynomial part of the procedure.
12550 |
12551 |   Pike, M. C. and I. D. Hill.  1966.  Algorithm 291: Logarithm of the gamma
12552 |      function.  Communications of the Association for Computing
12553 |      Machinery, 9:684.
12554 |
12555 ---------------------------------------------------------------------------------*/
12556 MrBFlt LnGamma (MrBFlt alp)
12557 {
12558     MrBFlt      x = alp, f = 0.0, z;
12559
12560     if (x < 7)
12561         {
12562         f = 1.0;
12563         z = x-1.0;
12564         while (++z < 7.0)
12565             f *= z;
12566         x = z;
12567         f = -log(f);
12568         }
12569     z = 1.0 / (x*x);
12570     return  (f + (x-0.5)*log(x) - x + 0.918938533204673 +
12571             (((-0.000595238095238*z+0.000793650793651)*z-0.002777777777778)*z +0.083333333333333)/x);
12572 }
12573
12574
12575 /* Calculate probability of a realization for exponential random variable */
12576 MrBFlt LnPriorProbExponential (MrBFlt val, MrBFlt *params)
12577 {
12578     return log(params[0]) - params[0] * val;
12579 }
12580
12581
12582 /* Calculate probability of a realization for exponential random variable; parameter mean and not rate */
12583 MrBFlt LnPriorProbExponential_Param_Mean (MrBFlt val, MrBFlt *params)
12584 {
12585     return - log(params[0]) - val / params[0];
12586 }
12587
12588
12589 /* Calculate probability of a realization for a fixed variable */
12590 MrBFlt LnPriorProbFix (MrBFlt val, MrBFlt *params)
12591 {
12592     if (fabs((val - params[0])/val) < 1E-5)
12593         return 0.0;
12594     else
12595         return NEG_INFINITY;
12596 }
12597
12598
12599 /* Calculate probability of a realization for gamma random variable */
12600 MrBFlt LnPriorProbGamma (MrBFlt val, MrBFlt *params)
12601 {
12602     return (params[0] - 1) * log(val) + params[0] * log(params[1]) - params[1] * val - LnGamma(params[0]);
12603 }
12604
12605
12606 /* Calculate probability of a realization for gamma random variable; parameters mean and sd */
12607 MrBFlt LnPriorProbGamma_Param_Mean_Sd (MrBFlt val, MrBFlt *params)
12608 {
12609     MrBFlt  alpha, beta;
12610
12611     beta  = params[0] / (params[1]*params[1]);
12612     alpha = params[0] * beta;
12613
12614     return (alpha - 1) * log(val) + alpha * log(beta) - beta * val - LnGamma(alpha);
12615 }
12616
12617
12618 /* Calculate probability of a realization for lognormal random variable */
12619 MrBFlt LnPriorProbLognormal (MrBFlt val, MrBFlt *params)
12620 {
12621     MrBFlt z;
12622
12623     z = (log(val) - params[0]) / params[1];
12624
12625     return - log(params[1] * val * sqrt(2.0 * PI)) - z * z / 2.0;
12626 }
12627
12628
12629 /* Calculate probability of a realization for lognormal random variable; parameters mean and sd on linear scale */
12630 MrBFlt LnPriorProbLognormal_Param_Mean_Sd (MrBFlt val, MrBFlt *params)
12631 {
12632     MrBFlt z, mean_log, sd_log;
12633
12634     sd_log      = sqrt (log((params[1]*params[1])/(params[0]*params[0]) + 1));
12635     mean_log    = log(params[0]) - sd_log * sd_log / 2.0;
12636
12637     z= (log(val) - mean_log) / sd_log;
12638
12639     return - log(sd_log * val * sqrt(2.0 * PI)) - z * z / 2.0;
12640 }
12641
12642
12643 /* Calculate probability of a realization for normal random variable */
12644 MrBFlt LnPriorProbNormal (MrBFlt val, MrBFlt *params)
12645 {
12646     MrBFlt z;
12647
12648     z = (val - params[0]) / params[1];
12649
12650     return - log(params[1] * sqrt(2.0 * PI)) - z * z / 2.0;
12651 }
12652
12653
12654 /* Calculate probability of a realization for an offset exponential random variable */
12655 MrBFlt LnPriorProbOffsetExponential (MrBFlt val, MrBFlt *params)
12656 {
12657     return log(params[1]) - params[1] * (val - params[0]);
12658 }
12659
12660
12661 /* Calculate probability of a realization for an offset exponential random variable; parameters offset and mean */
12662 MrBFlt LnPriorProbOffsetExponential_Param_Offset_Mean (MrBFlt val, MrBFlt *params)
12663 {
12664     MrBFlt  x, rate;
12665
12666     x    = val - params[0];
12667     rate = 1.0 / (params[1] - params[0]);
12668
12669     return log(rate) - rate * x;
12670 }
12671
12672
12673 /* Calculate probability of a realization for an offset gamma random variable */
12674 MrBFlt LnPriorProbOffsetGamma (MrBFlt val, MrBFlt *params)
12675 {
12676     MrBFlt x, alpha, beta;
12677
12678     x     = val - params[0];
12679     alpha = params[1];
12680     beta  = params[2];
12681
12682     return (alpha - 1) * log(x) + alpha * log(beta) - beta * x - LnGamma(alpha);
12683 }
12684
12685
12686 /* Calculate probability of a realization for an offset gamma random variable; parameters offset, mean and sd */
12687 MrBFlt LnPriorProbOffsetGamma_Param_Offset_Mean_Sd (MrBFlt val, MrBFlt *params)
12688 {
12689     MrBFlt  x, mean, sd, alpha, beta;
12690
12691     x     = val - params[0];
12692     mean  = params[1] - params[0];
12693     sd    = params[2];
12694
12695     beta  = mean / (sd*sd);
12696     alpha = mean * beta;
12697
12698     return (alpha - 1) * log(x) + alpha * log(beta) - beta * x - LnGamma(alpha);
12699 }
12700
12701
12702 /* Calculate probability of a realization for an offset lognormal random variable */
12703 MrBFlt LnPriorProbOffsetLognormal (MrBFlt val, MrBFlt *params)
12704 {
12705     MrBFlt x, mean_log, sd_log, z;
12706
12707     x        = val - params[0];
12708     mean_log = params[1] - params[0];
12709     sd_log   = params[2];
12710
12711     z = (log(x) - mean_log) / sd_log;
12712
12713     return - log(sd_log * x * sqrt(2.0 * PI)) - z * z / 2.0;
12714 }
12715
12716
12717 /* Calculate probability of a realization for an offset lognormal random variable; parameters offset, mean and sd */
12718 MrBFlt LnPriorProbOffsetLognormal_Param_Offset_Mean_Sd (MrBFlt val, MrBFlt *params)
12719 {
12720     MrBFlt x, mean, sd, mean_log, sd_log, z;
12721
12722     x        = val - params[0];
12723     mean     = params[1] - params[0];
12724     sd       = params[2];
12725     sd_log   = sqrt (log((sd*sd)/(mean*mean) + 1));
12726     mean_log = log(mean) - sd_log * sd_log / 2.0;
12727
12728     z = (log(x) - mean_log) / sd_log;
12729
12730     return - log(sd_log * x * sqrt(2.0 * PI)) - z * z / 2.0;
12731 }
12732
12733
12734 /* Calculate probability of a realization for truncated (only positive values) normal random variable */
12735 MrBFlt LnPriorProbTruncatedNormal (MrBFlt val, MrBFlt *params)
12736 {
12737     MrBFlt z, z_0, normConst;
12738
12739     z = (val - params[0]) / params[1];
12740     z_0 = (0.0 - params[0]) / params[1];
12741     normConst = CdfNormal(z_0);
12742
12743     return - log(params[1] * sqrt(2.0 * PI)) - z * z / 2.0 - log(1.0 - normConst);
12744 }
12745
12746
12747 /* Calculate probability of a realization for arbitrarily truncated normal random variable; parameters truncation point, mean and sd */
12748 MrBFlt LnPriorProbTruncatedNormal_Param_Trunc_Mean_Sd (MrBFlt val, MrBFlt *params)
12749 {
12750     MrBFlt z, z_trunc, normConst;
12751
12752     z = (val - params[1]) / params[2];
12753     z_trunc = (params[0] - params[1]) / params[2];
12754     normConst = CdfNormal(z_trunc);
12755
12756     return - log(params[2] * sqrt(2.0 * PI)) - z * z / 2.0 - log(1.0 - normConst);
12757 }
12758
12759
12760 /* Calculate probability of a realization for uniform random variable */
12761 MrBFlt LnPriorProbUniform (MrBFlt val, MrBFlt *params)
12762 {
12763     return - log(params[1] - params[0]);
12764     MrBayesPrint ("%lf", val); /* just because I am tired of seeing the unused parameter error msg */
12765 }
12766
12767
12768 /* Calculate probability ratio of realizations for exponential random variable */
12769 MrBFlt LnProbRatioExponential (MrBFlt newX, MrBFlt oldX, MrBFlt *params)
12770 {
12771     return params[0] * (oldX - newX);
12772 }
12773
12774
12775 /* Calculate probability ratio of realizations for exponential random variable; parameter mean and not rate */
12776 MrBFlt LnProbRatioExponential_Param_Mean (MrBFlt newX, MrBFlt oldX, MrBFlt *params)
12777 {
12778     return (oldX - newX) / params[0];
12779 }
12780
12781
12782 /* Calculate probability of a realization for a fixed variable */
12783 MrBFlt LnProbRatioFix (MrBFlt newX, MrBFlt oldX, MrBFlt *params)
12784 {
12785     if (fabs((newX - params[0])/newX) < 1E-5 && fabs((oldX - params[0])/oldX) < 1E-5)
12786         return 0.0;
12787     else
12788         return NEG_INFINITY;
12789 }
12790
12791
12792 /* Calculate probability ratio of realizations for gamma random variable */
12793 MrBFlt LnProbRatioGamma (MrBFlt newX, MrBFlt oldX, MrBFlt *params)
12794 {
12795     MrBFlt  alpha, beta;
12796
12797     alpha   = params[0];
12798     beta    = params[1];
12799
12800     return (alpha - 1.0) * (log(newX) - log(oldX)) - beta * (newX - oldX);
12801 }
12802
12803
12804 /* Calculate probability ratio of realizations for gamma random variable; parameters mean and sd */
12805 MrBFlt LnProbRatioGamma_Param_Mean_Sd (MrBFlt newX, MrBFlt oldX, MrBFlt *params)
12806 {
12807     MrBFlt  alpha, beta;
12808
12809     beta  = params[0] / (params[1]*params[1]);
12810     alpha = params[0] * beta;
12811
12812     return (alpha - 1.0) * (log(newX) - log(oldX)) - beta * (newX - oldX);
12813 }
12814
12815
12816 /* Calculate probability ratio of realizations for log normal random variable */
12817 MrBFlt LnProbRatioLognormal (MrBFlt newX, MrBFlt oldX, MrBFlt *params)
12818 {
12819     MrBFlt  newZ, oldZ;
12820
12821     newZ = (log(newX) - params[0]) / params[1];
12822     oldZ = (log(oldX) - params[0]) / params[1];
12823
12824     return (oldZ * oldZ - newZ * newZ) / 2.0 + log(oldX) - log(newX);
12825 }
12826
12827
12828 /* Calculate probability ratio of realizations for log normal random variable; parameters mean and sd */
12829 MrBFlt LnProbRatioLognormal_Param_Mean_Sd (MrBFlt newX, MrBFlt oldX, MrBFlt *params)
12830 {
12831     MrBFlt newZ, oldZ, mean_log, sd_log;
12832
12833     sd_log      = sqrt (log((params[1]*params[1])/(params[0]*params[0]) + 1));
12834     mean_log    = log(params[0]) - sd_log * sd_log / 2.0;
12835
12836     newZ = (log(newX) - mean_log) / sd_log;
12837     oldZ = (log(oldX) - mean_log) / sd_log;
12838
12839     return (oldZ * oldZ - newZ * newZ) / 2.0 + log(oldX) - log(newX);
12840 }
12841
12842
12843 /* Calculate probability ratio of realizations for normal random variable */
12844 MrBFlt LnProbRatioNormal (MrBFlt newX, MrBFlt oldX, MrBFlt *params)
12845 {
12846     MrBFlt  newZ, oldZ;
12847
12848     newZ = (newX - params[0]) / params[1];
12849     oldZ = (oldX - params[0]) / params[1];
12850
12851     return (oldZ * oldZ - newZ * newZ) / 2.0;
12852 }
12853
12854
12855 /* Calculate probability ratio of realizations for offset exponential random variable */
12856 MrBFlt LnProbRatioOffsetExponential (MrBFlt newX, MrBFlt oldX, MrBFlt *params)
12857 {
12858     return params[1] * (oldX - newX);
12859 }
12860
12861
12862 /* Calculate probability ratio of realizations for offset exponential random variable; parameters offset and mean */
12863 MrBFlt LnProbRatioOffsetExponential_Param_Offset_Mean (MrBFlt newX, MrBFlt oldX, MrBFlt *params)
12864 {
12865     return (oldX - newX) / (params[1] - params[0]);
12866 }
12867
12868
12869 /* Calculate probability ratio of realizations for offset gamma random variable */
12870 MrBFlt LnProbRatioOffsetGamma (MrBFlt newX, MrBFlt oldX, MrBFlt *params)
12871 {
12872     MrBFlt  alpha, beta, newZ, oldZ;
12873
12874     alpha = params[1];
12875     beta  = params[2];
12876     newZ  = newX - params[0];
12877     oldZ  = oldX - params[0];
12878
12879     return (alpha - 1.0) * (log(newZ) - log(oldZ)) - beta * (newZ - oldZ);
12880 }
12881
12882
12883 /* Calculate probability ratio of realizations for offset gamma random variable; parameters offset, mean and sd */
12884 MrBFlt LnProbRatioOffsetGamma_Param_Offset_Mean_Sd (MrBFlt newX, MrBFlt oldX, MrBFlt *params)
12885 {
12886     MrBFlt  mean, sd, alpha, beta;
12887
12888     mean  = params[1] - params[0];
12889     sd    = params[2];
12890
12891     beta  = mean / (sd*sd);
12892     alpha = mean * beta;
12893
12894     newX  -= params[0];
12895     oldX  -= params[0];
12896
12897     return (alpha - 1.0) * (log(newX) - log(oldX)) - beta * (newX - oldX);
12898 }
12899
12900
12901 /* Calculate probability ratio of realizations for offset lognormal random variable */
12902 MrBFlt LnProbRatioOffsetLognormal (MrBFlt newX, MrBFlt oldX, MrBFlt *params)
12903 {
12904     MrBFlt newZ, oldZ, mean_log, sd_log;
12905
12906     sd_log      = params[2];
12907     mean_log    = params[1];
12908
12909     newZ = (log(newX-params[0]) - mean_log) / sd_log;
12910     oldZ = (log(oldX-params[0]) - mean_log) / sd_log;
12911
12912     return (oldZ * oldZ - newZ * newZ) / 2.0 + log(oldX-params[0]) - log(newX-params[0]);
12913 }
12914
12915
12916 /* Calculate probability ratio of realizations for offset lognormal random variable; parameters offset, mean and sd */
12917 MrBFlt LnProbRatioOffsetLognormal_Param_Offset_Mean_Sd (MrBFlt newX, MrBFlt oldX, MrBFlt *params)
12918 {
12919     MrBFlt newZ, oldZ, mean, sd, mean_log, sd_log;
12920
12921     mean        = params[1] - params[0];
12922     sd          = params[2];
12923     sd_log      = sqrt (log((sd*sd)/(mean*mean) + 1));
12924     mean_log    = log(mean) - sd_log * sd_log / 2.0;
12925
12926     newX -= params[0];
12927     oldX -= params[0];
12928     newZ = (log(newX) - mean_log) / sd_log;
12929     oldZ = (log(oldX) - mean_log) / sd_log;
12930
12931     return (oldZ * oldZ - newZ * newZ) / 2.0 - log(newX / oldX);
12932 }
12933
12934
12935 /* Calculate probability ratio of realizations for truncated normal random variable */
12936 MrBFlt LnProbRatioTruncatedNormal (MrBFlt newX, MrBFlt oldX, MrBFlt *params)
12937 {
12938     MrBFlt  newZ, oldZ;
12939
12940     newZ = (newX - params[0]) / params[1];
12941     oldZ = (oldX - params[0]) / params[1];
12942
12943     return (oldZ * oldZ - newZ * newZ) / 2.0;
12944 }
12945
12946
12947 /* Calculate probability ratio of realizations for arbitrarily truncated normal random variable; parameters truncation point, mean and sd */
12948 MrBFlt LnProbRatioTruncatedNormal_Param_Trunc_Mean_Sd (MrBFlt newX, MrBFlt oldX, MrBFlt *params)
12949 {
12950     MrBFlt  newZ, oldZ;
12951
12952     newZ = (newX - params[1]) / params[2];
12953     oldZ = (oldX - params[1]) / params[2];
12954
12955     return (oldZ * oldZ - newZ * newZ) / 2.0;
12956 }
12957
12958
12959 /* Calculate probability ratio of realizations for uniform random variable */
12960 MrBFlt LnProbRatioUniform (MrBFlt newX, MrBFlt oldX, MrBFlt *params)
12961 {
12962     return 0.0;
12963     MrBayesPrint ("%lf %lf", newX, oldX); /* just because I am tired of seeing the unused parameter error msg */
12964     MrBayesPrint ("%lf", *params);
12965 }
12966
12967
12968 /* Log probability for a value drawn from a gamma distribution */
12969 MrBFlt LnProbGamma (MrBFlt alpha, MrBFlt beta, MrBFlt x)
12970 {
12971     MrBFlt lnProb;
12972
12973     lnProb = (alpha-1.0)*log(x) + alpha*log(beta) - x*beta - LnGamma(alpha);
12974
12975     return lnProb;
12976 }
12977
12978
12979 /* Log probability for a value drawn from a truncated gamma distribution */
12980 MrBFlt LnProbTruncGamma (MrBFlt alpha, MrBFlt beta, MrBFlt x, MrBFlt min, MrBFlt max)
12981 {
12982     MrBFlt lnProb;
12983
12984     lnProb = (alpha-1.0)*log(x) + alpha*log(beta) - x*beta - LnGamma(alpha);
12985
12986     lnProb -= log (IncompleteGamma (max*beta, alpha, LnGamma(alpha)) - IncompleteGamma (min*beta, alpha, LnGamma(alpha)));
12987
12988     return lnProb;
12989 }
12990
12991
12992 /* Log probability for a value drawn from a lognormal distribution */
12993 MrBFlt LnProbLogNormal (MrBFlt exp, MrBFlt sd, MrBFlt x)
12994 {
12995     MrBFlt lnProb, z;
12996
12997     z = (log(x) - exp) / sd;
12998
12999     lnProb = - log (x * sd * sqrt (2.0 * PI)) - (z * z / 2.0);
13000
13001     return lnProb;
13002 }
13003
13004
13005 /* Log ratio for two values drawn from a lognormal distribution */
13006 MrBFlt LnRatioLogNormal (MrBFlt exp, MrBFlt sd, MrBFlt xNew, MrBFlt xOld)
13007 {
13008     MrBFlt  newZ, oldZ;
13009
13010     newZ = (log(xNew) - exp) / sd;
13011     oldZ = (log(xOld) - exp) / sd;
13012
13013     return (oldZ * oldZ - newZ * newZ) / 2.0 + log(xOld) - log(xNew);
13014 }
13015
13016
13017 /* Log probability for a value drawn from a lognormal distribution;
13018    parameters are mean and variance of value (not of log value) */
13019 MrBFlt LnProbTK02LogNormal (MrBFlt mean, MrBFlt var, MrBFlt x)
13020 {
13021     MrBFlt  z, lnProb, mu, sigma;
13022
13023     sigma = sqrt(log(1.0 + (var / (mean*mean))));
13024     mu    = log(mean) - sigma * sigma / 2.0;
13025
13026     z = (log(x) - mu) / sigma;
13027
13028     lnProb = - log (x * sigma * sqrt (2.0 * PI)) - (z * z / 2.0);
13029
13030     return lnProb;
13031 }
13032
13033
13034 /* Log ratio for two values drawn from a lognormal distribution */
13035 MrBFlt LnRatioTK02LogNormal (MrBFlt mean, MrBFlt var, MrBFlt xNew, MrBFlt xOld)
13036 {
13037     MrBFlt  newZ, oldZ, mu, sigma;
13038
13039     sigma = sqrt(log(1.0 + (var / (mean*mean))));
13040     mu    = log(mean) - sigma * sigma / 2.0;
13041
13042     newZ = (log(xNew) - mu) / sigma;
13043     oldZ = (log(xOld) - mu) / sigma;
13044
13045     return (oldZ * oldZ - newZ * newZ) / 2.0 + log(xOld) - log(xNew);
13046 }
13047
13048
13049 /*---------------------------------------------------------------------------------
13050 |
13051 |   LogBase2Plus1
13052 |
13053 |   This function is called from ComputeMatrixExponential.
13054 |
13055 ---------------------------------------------------------------------------------*/
13056 int LogBase2Plus1 (MrBFlt x)
13057 {
13058     int     j = 0;
13059
13060     while (x > 1.0 - 1.0e-07)
13061         {
13062         x /= 2.0;
13063         j++;
13064         }
13065
13066     return (j);
13067 }
13068
13069
13070 /*---------------------------------------------------------------------------------
13071 |
13072 |   LogNormalRandomVariable
13073 |
13074 |   Draw a random variable from a lognormal distribution.
13075 |
13076 ---------------------------------------------------------------------------------*/
13077 MrBFlt LogNormalRandomVariable (MrBFlt mean, MrBFlt sd, RandLong *seed)
13078 {
13079     MrBFlt      x;
13080
13081     x = PointNormal(RandomNumber(seed));
13082
13083     x*= sd;
13084     x += mean;
13085
13086     return exp(x);
13087 }
13088
13089
13090 /*---------------------------------------------------------------------------------
13091 |
13092 |   LUBackSubstitution
13093 |
13094 |   Back substitute into an LU-decomposed matrix.
13095 |
13096 ---------------------------------------------------------------------------------*/
13097 void LUBackSubstitution (int dim, MrBFlt **a, int *indx, MrBFlt *b)
13098 {
13099     int         i, ip, j, ii = -1;
13100     MrBFlt      sum;
13101
13102     for (i=0; i<dim; i++)
13103         {
13104         ip = indx[i];
13105         sum = b[ip];
13106         b[ip] = b[i];
13107         if (ii >= 0)
13108             {
13109             for (j=ii; j<=i-1; j++)
13110                 sum -= a[i][j] * b[j];
13111             }
13112         else if (fabs(sum)>ETA)
13113             ii = i;
13114         b[i] = sum;
13115         }
13116     for (i=dim-1; i>=0; i--)
13117         {
13118         sum = b[i];
13119         for (j=i+1; j<dim; j++)
13120             sum -= a[i][j] * b[j];
13121         b[i] = sum / a[i][i];
13122         }
13123 }
13124
13125
13126 /*---------------------------------------------------------------------------------
13127 |
13128 |   LUDecompose
13129 |
13130 |   Calculate the LU-decomposition of the matrix a. The matrix a is replaced.
13131 |
13132 ---------------------------------------------------------------------------------*/
13133 int LUDecompose (int dim, MrBFlt **a, MrBFlt *vv, int *indx, MrBFlt *pd)
13134 {
13135     int         i, imax=0, j, k;
13136     MrBFlt      big, dum, sum, temp, d;
13137
13138     d = 1.0;
13139     for (i=0; i<dim; i++)
13140         {
13141         big = 0.0;
13142         for (j = 0; j < dim; j++)
13143             {
13144             if ((temp = fabs(a[i][j])) > big)
13145                 big = temp;
13146             }
13147         if (fabs(big)<ETA)
13148             {
13149             MrBayesPrint ("%s   Error: Problem in LUDecompose\n", spacer);
13150             return (ERROR);
13151             }
13152         vv[i] = 1.0 / big;
13153         }
13154     for (j=0; j<dim; j++)
13155         {
13156         for (i = 0; i < j; i++)
13157             {
13158             sum = a[i][j];
13159             for (k = 0; k < i; k++)
13160                 sum -= a[i][k] * a[k][j];
13161             a[i][j] = sum;
13162             }
13163         big = 0.0;
13164         for (i=j; i<dim; i++)
13165             {
13166             sum = a[i][j];
13167             for (k = 0; k < j; k++)
13168                 sum -= a[i][k] * a[k][j];
13169             a[i][j] = sum;
13170             dum = vv[i] * fabs(sum);
13171             if (dum >= big)
13172                 {
13173                 big = dum;
13174                 imax = i;
13175                 }
13176             }
13177         if (j != imax)
13178             {
13179             for (k=0; k<dim; k++)
13180                 {
13181                 dum = a[imax][k];
13182                 a[imax][k] = a[j][k];
13183                 a[j][k] = dum;
13184                 }
13185             d = -d;
13186             vv[imax] = vv[j];
13187             }
13188         indx[j] = imax;
13189         if (fabs(a[j][j])<ETA)
13190             a[j][j] = TINY;
13191         if (j != dim - 1)
13192             {
13193             dum = 1.0 / (a[j][j]);
13194             for (i=j+1; i<dim; i++)
13195                 a[i][j] *= dum;
13196             }
13197         }
13198     if (pd != NULL)
13199         *pd = d;
13200
13201     return (NO_ERROR);
13202 }
13203
13204
13205 /*---------------------------------------------------------------------------------
13206 |
13207 |   MultiplyMatrices
13208 |
13209 |   Multiply matrix a by matrix b and put the results in matrix result.
13210 |
13211 ---------------------------------------------------------------------------------*/
13212 void MultiplyMatrices (int dim, MrBFlt **a, MrBFlt **b, MrBFlt **result)
13213 {
13214     register int    i, j, k;
13215     MrBFlt          **temp;
13216
13217     temp = AllocateSquareDoubleMatrix (dim);
13218
13219     for (i=0; i<dim; i++)
13220         {
13221         for (j=0; j<dim; j++)
13222             {
13223             temp[i][j] = 0.0;
13224             for (k=0; k<dim; k++)
13225                 {
13226                 temp[i][j] += a[i][k] * b[k][j];
13227                 }
13228             }
13229         }
13230     for (i=0; i<dim; i++)
13231         {
13232         for (j=0; j<dim; j++)
13233             {
13234             result[i][j] = temp[i][j];
13235             }
13236         }
13237
13238     FreeSquareDoubleMatrix (temp);
13239 }
13240
13241
13242 /*---------------------------------------------------------------------------------
13243 |
13244 |   MultiplyMatrixByScalar
13245 |
13246 |   Multiply the elements of matrix a by a scalar.
13247 |
13248 ---------------------------------------------------------------------------------*/
13249 void MultiplyMatrixByScalar (int dim, MrBFlt **a, MrBFlt scalar, MrBFlt **result)
13250 {
13251     int         row, col;
13252
13253     for (row=0; row<dim; row++)
13254         for (col=0; col<dim; col++)
13255              result[row][col] = a[row][col] * scalar;
13256 }
13257
13258
13259 /*---------------------------------------------------------------------------------
13260 |
13261 |   MultiplyMatrixNTimes
13262 |
13263 ---------------------------------------------------------------------------------*/
13264 int MultiplyMatrixNTimes (int dim, MrBFlt **Mat, int power, MrBFlt **Result)
13265 {
13266     register int    i, j;
13267     int             k, numSquares, numRemaining;
13268     MrBFlt          **TempIn, **TempOut;
13269
13270     if (power < 0)
13271         {
13272         MrBayesPrint ("%s   Error: Power cannot be a negative number.\n", spacer);
13273         return (ERROR);
13274         }
13275     else if (power == 0)
13276         {
13277         for (i=0; i<dim; i++)
13278             for (j=0; j<dim; j++)
13279                 Result[i][j] = 1.0;
13280         }
13281     else
13282         {
13283         TempIn  = AllocateSquareDoubleMatrix (dim);
13284         TempOut = AllocateSquareDoubleMatrix (dim);
13285
13286         /* how many times can I multiply the matrices together */
13287         numSquares = 0;
13288         while (pow (2.0, (MrBFlt)(numSquares)) < power)
13289             numSquares++;
13290         numRemaining = power - (int)(pow(2.0, (MrBFlt)(numSquares)));
13291
13292         /* now, multiply matrix by power of 2's */
13293         CopyDoubleMatrices (dim, Mat, TempIn);
13294         for (k=0; k<numSquares; k++)
13295             {
13296             MultiplyMatrices (dim, TempIn, TempIn, TempOut);
13297             CopyDoubleMatrices (dim, TempOut, TempIn);
13298             }
13299
13300         /* TempIn is Mat^numSquares. Now, multiply it by Mat numRemaining times */
13301         for (k=0; k<numRemaining; k++)
13302             {
13303             MultiplyMatrices (dim, TempIn, Mat, TempOut);
13304             CopyDoubleMatrices (dim, TempOut, TempIn);
13305             }
13306
13307         /* copy result */
13308         CopyDoubleMatrices (dim, TempIn, Result);
13309
13310         FreeSquareDoubleMatrix (TempIn);
13311         FreeSquareDoubleMatrix (TempOut);
13312         }
13313
13314     return (NO_ERROR);
13315 }
13316
13317
13318 /*---------------------------------------------------------------------------------
13319 |
13320 |   PointChi2
13321 |
13322 |   Returns z so that Prob(x < z) = prob where x is Chi2 distributed with df=v.
13323 |   Returns -1 if in error.   0.000002 < prob < 0.999998.
13324 |
13325 ---------------------------------------------------------------------------------*/
13326 MrBFlt PointChi2 (MrBFlt prob, MrBFlt v)
13327 {
13328     MrBFlt      e = 0.5e-6, aa = 0.6931471805, p = prob, g,
13329                     xx, c, ch, a = 0.0, q = 0.0, p1 = 0.0, p2 = 0.0, t = 0.0,
13330                     x = 0.0, b = 0.0, s1, s2, s3, s4, s5, s6;
13331
13332     if (p < 0.000002 || p > 0.999998 || v <= 0.0)
13333         return (-1.0);
13334     g = LnGamma (v/2.0);
13335     xx = v/2.0;
13336     c = xx - 1.0;
13337     if (v >= -1.24*log(p))
13338         goto l1;
13339     ch = pow((p*xx*exp(g+xx*aa)), 1.0/xx);
13340     if (ch-e<0)
13341         return (ch);
13342     goto l4;
13343     l1:
13344         if (v > 0.32)
13345             goto l3;
13346         ch = 0.4;
13347         a = log(1.0-p);
13348     l2:
13349         q = ch;
13350         p1 = 1.0+ch*(4.67+ch);
13351         p2 = ch*(6.73+ch*(6.66+ch));
13352         t = -0.5+(4.67+2.0*ch)/p1 - (6.73+ch*(13.32+3.0*ch))/p2;
13353         ch -= (1.0-exp(a+g+0.5*ch+c*aa)*p2/p1)/t;
13354         if (fabs(q/ch-1.0)-0.01 <= 0.0)
13355             goto l4;
13356         else
13357             goto l2;
13358     l3:
13359         x = PointNormal (p);
13360         p1 = 0.222222/v;
13361         ch = v*pow((x*sqrt(p1)+1.0-p1), 3.0);
13362         if (ch > 2.2*v+6.0)
13363             ch = -2.0*(log(1.0-p)-c*log(0.5*ch)+g);
13364     l4:
13365         q = ch;
13366         p1 = 0.5*ch;
13367         if ((t = IncompleteGamma (p1, xx, g)) < 0.0)
13368             {
13369             MrBayesPrint ("%s   Error: Problem in PointChi2", spacer);
13370             return (-1.0);
13371             }
13372         p2 = p-t;
13373         t = p2*exp(xx*aa+g+p1-c*log(ch));
13374         b = t/ch;
13375         a = 0.5*t-b*c;
13376         s1 = (210.0+a*(140.0+a*(105.0+a*(84.0+a*(70.0+60.0*a))))) / 420.0;
13377         s2 = (420.0+a*(735.0+a*(966.0+a*(1141.0+1278.0*a))))/2520.0;
13378         s3 = (210.0+a*(462.0+a*(707.0+932.0*a)))/2520.0;
13379         s4 = (252.0+a*(672.0+1182.0*a)+c*(294.0+a*(889.0+1740.0*a)))/5040.0;
13380         s5 = (84.0+264.0*a+c*(175.0+606.0*a)) / 2520.0;
13381         s6 = (120.0+c*(346.0+127.0*c)) / 5040.0;
13382         ch += t*(1+0.5*t*s1-b*c*(s1-b*(s2-b*(s3-b*(s4-b*(s5-b*s6))))));
13383         if (fabs(q/ch-1.0) > e)
13384             goto l4;
13385         return (ch);
13386 }
13387
13388
13389 /*---------------------------------------------------------------------------------
13390 |
13391 |   PointNormal
13392 |
13393 |   Returns z so That Prob{x<z} = prob where x ~ N(0,1) and
13394 |   (1e-12) < prob < 1-(1e-12).  Returns (-9999) if in error.
13395 |
13396 |   Odeh, R. E. and J. O. Evans.  1974.  The percentage points of the normal
13397 |     distribution.  Applied Statistics, 22:96-97 (AS70).
13398 |
13399 |   Newer methods:
13400 |
13401 |   Wichura, M. J.  1988.  Algorithm AS 241: The percentage points of the
13402 |      normal distribution.  37:477-484.
13403 |   Beasley, JD & S. G. Springer.  1977.  Algorithm AS 111: The percentage
13404 |      points of the normal distribution.  26:118-121.
13405 |
13406 ---------------------------------------------------------------------------------*/
13407 MrBFlt PointNormal (MrBFlt prob)
13408 {
13409     MrBFlt      a0 = -0.322232431088, a1 = -1.0, a2 = -0.342242088547, a3 = -0.0204231210245,
13410                     a4 = -0.453642210148e-4, b0 = 0.0993484626060, b1 = 0.588581570495,
13411                     b2 = 0.531103462366, b3 = 0.103537752850, b4 = 0.0038560700634,
13412                     y, z = 0, p = prob, p1;
13413
13414     p1 = (p<0.5 ? p : 1-p);
13415     if (p1<1e-20)
13416        return (-9999);
13417     y = sqrt (log(1/(p1*p1)));
13418     z = y + ((((y*a4+a3)*y+a2)*y+a1)*y+a0) / ((((y*b4+b3)*y+b2)*y+b1)*y+b0);
13419
13420     return (p<0.5 ? -z : z);
13421 }
13422
13423
13424 /*---------------------------------------------------------------------------------
13425 |
13426 |   PrintComplexVector
13427 |
13428 |   Prints a vector of dim complex numbers.
13429 |
13430 ---------------------------------------------------------------------------------*/
13431 void PrintComplexVector (int dim, complex *vec)
13432 {
13433     int     i;
13434
13435     MrBayesPrint ("{");
13436     for (i = 0; i < (dim - 1); i++)
13437         {
13438         MrBayesPrint ("%lf + %lfi, ", vec[i].re, vec[i].im);
13439         if (i == 1)
13440             MrBayesPrint("\n    ");
13441         }
13442     MrBayesPrint ("%lf + %lfi}\n", vec[dim - 1].re, vec[dim - 1].im);
13443 }
13444
13445
13446 /*---------------------------------------------------------------------------------
13447 |
13448 |   PrintSquareComplexMatrix
13449 |
13450 |   Prints a square matrix of complex numbers.
13451 |
13452 ---------------------------------------------------------------------------------*/
13453 void PrintSquareComplexMatrix (int dim, complex **m)
13454 {
13455     int     row, col;
13456
13457     MrBayesPrint ("{");
13458     for (row = 0; row < (dim - 1); row++)
13459         {
13460         MrBayesPrint ("{");
13461         for (col = 0; col < (dim - 1); col++)
13462             {
13463             MrBayesPrint ("%lf + %lfi, ", m[row][col].re, m[row][col].im);
13464             if (col == 1)
13465                 MrBayesPrint ("\n    ");
13466             }
13467         MrBayesPrint ("%lf + %lfi},\n",
13468         m[row][dim - 1].re, m[row][dim - 1].im);
13469         }
13470     MrBayesPrint ("{");
13471     for (col = 0; col < (dim - 1); col++)
13472         {
13473         MrBayesPrint ("%lf + %lfi, ", m[dim - 1][col].re, m[dim - 1][col].im);
13474         if (col == 1)
13475             MrBayesPrint ("\n    ");
13476         }
13477     MrBayesPrint ("%lf + %lfi}}", m[dim - 1][dim - 1].re, m[dim - 1][dim - 1].im);
13478     MrBayesPrint ("\n");
13479 }
13480
13481
13482 /*---------------------------------------------------------------------------------
13483 |
13484 |   PrintSquareDoubleMatrix
13485 |
13486 |   Prints a square matrix of doubles.
13487 |
13488 ---------------------------------------------------------------------------------*/
13489 void PrintSquareDoubleMatrix (int dim, MrBFlt **matrix)
13490 {
13491     int         i, j;
13492
13493     for (i=0; i<dim; i++)
13494         {
13495         for (j=0; j<dim; j++)
13496             MrBayesPrint ("%1.6lf ", matrix[i][j]);
13497         MrBayesPrint ("\n");
13498         }
13499 }
13500
13501
13502 /*---------------------------------------------------------------------------------
13503 |
13504 |   PrintSquareIntegerMatrix
13505 |
13506 |   Prints a square matrix of integers.
13507 |
13508 ---------------------------------------------------------------------------------*/
13509 void PrintSquareIntegerMatrix (int dim, int **matrix)
13510 {
13511     int         i, j;
13512
13513     for (i=0; i<dim; i++)
13514         {
13515         for (j=0; j<dim; j++)
13516             MrBayesPrint ("%d ", matrix[i][j]);
13517         MrBayesPrint ("\n");
13518         }
13519 }
13520
13521
13522 /*---------------------------------------------------------------------------------
13523 |
13524 |   ProductOfRealAndComplex
13525 |
13526 |   Returns the complex product of a real and complex number.
13527 |
13528 ---------------------------------------------------------------------------------*/
13529 complex ProductOfRealAndComplex (MrBFlt a, complex b)
13530 {
13531     complex     c;
13532
13533     c.re = a * b.re;
13534     c.im = a * b.im;
13535
13536     return (c);
13537 }
13538
13539
13540 /*---------------------------------------------------------------------------------
13541 |
13542 |   PsiExp: Returns psi (also called digamma) exponentiated
13543 |       Algorithm from http://lib.stat.cmu.edu/apstat/103
13544 |
13545 ---------------------------------------------------------------------------------*/
13546 MrBFlt  PsiExp (MrBFlt alpha)
13547 {
13548     MrBFlt      digamma, y, r, s, c, s3, s4, s5, d1;
13549
13550     s = 1.0e-05;
13551     c = 8.5;
13552     s3 = 8.333333333333333333333333e-02;
13553     s4 = 8.333333333333333333333333e-03;
13554     s5 = 3.968253968e-03;
13555     d1 = -0.577215664901532860606512;   /* negative of Euler's constant */
13556
13557     digamma = 0.0;
13558     y = alpha;
13559     if (y <= 0.0)
13560         return (0.0);
13561
13562     if (y <= s)
13563         {
13564         digamma = d1 - 1.0 / y;
13565         return (exp (digamma));
13566         }
13567
13568     while (y < c)
13569         {
13570         digamma -= 1.0 / y;
13571         y += 1.0;
13572         }
13573
13574     r = 1.0 / y;
13575     digamma += (log (y) - 0.5 * r);
13576     r *= r;
13577     digamma -= r * (s3 - r * (s4 - r * s5));
13578
13579     return (exp (digamma));
13580 }
13581
13582
13583 /*---------------------------------------------------------------------------------
13584 |
13585 |   PsiGammaLnProb: Calculates the log probability of a PsiGamma distributed
13586 |      variable
13587 |
13588 ---------------------------------------------------------------------------------*/
13589 MrBFlt  PsiGammaLnProb (MrBFlt alpha, MrBFlt value)
13590 {
13591     MrBFlt  beta, lnProb;
13592
13593     beta = PsiExp (alpha);
13594
13595     lnProb = alpha * log (beta) - LnGamma (alpha) + (alpha - 1.0) * log (value) - beta * value;
13596
13597     return lnProb;
13598 }
13599
13600
13601 /*---------------------------------------------------------------------------------
13602 |
13603 |   PsiGammaLnRatio: Calculates the log prob ratio of two PsiGamma distributed
13604 |      variables
13605 |
13606 ---------------------------------------------------------------------------------*/
13607 MrBFlt  PsiGammaLnRatio (MrBFlt alpha, MrBFlt numerator, MrBFlt denominator)
13608 {
13609     MrBFlt beta, lnRatio;
13610
13611     beta = PsiExp (alpha);
13612
13613     lnRatio = (alpha - 1.0) * (log (numerator) - log (denominator)) - beta * (numerator - denominator);
13614
13615     return (lnRatio);
13616 }
13617
13618
13619 /*---------------------------------------------------------------------------------
13620 |
13621 |   PsiGammaRandomVariable: Returns a random draw from the PsiGamma
13622 |
13623 ---------------------------------------------------------------------------------*/
13624 MrBFlt  PsiGammaRandomVariable (MrBFlt alpha, RandLong *seed)
13625 {
13626     return GammaRandomVariable (alpha, PsiExp(alpha), seed);
13627 }
13628
13629
13630 /*---------------------------------------------------------------------------------
13631 |
13632 |   QuantileGamma
13633 |
13634 ---------------------------------------------------------------------------------*/
13635 MrBFlt QuantileGamma (MrBFlt x, MrBFlt alfa, MrBFlt beta)
13636 {
13637     MrBFlt      quantile;
13638
13639     quantile = POINTGAMMA(x, alfa, beta);
13640
13641     return (quantile);
13642 }
13643
13644
13645 /*---------------------------------------------------------------------------------
13646 |
13647 |   RandomNumber
13648 |
13649 |   This pseudorandom number generator is described in:
13650 |   Park, S. K. and K. W. Miller.  1988.  Random number generators: good
13651 |      ones are hard to find.  Communications of the ACM, 31(10):1192-1201.
13652 |
13653 ---------------------------------------------------------------------------------*/
13654 MrBFlt RandomNumber (RandLong *seed)
13655 {
13656     RandLong    lo, hi, test;
13657
13658     hi = (*seed) / 127773;
13659     lo = (*seed) % 127773;
13660     test = 16807 * lo - 2836 * hi;
13661     if (test > 0)
13662         *seed = test;
13663     else
13664         *seed = test + 2147483647;
13665     return ((MrBFlt)(*seed) / (MrBFlt)2147483647);
13666 }
13667
13668
13669 /*---------------------------------------------------------------------------------
13670 |
13671 |   RndGamma
13672 |
13673 ---------------------------------------------------------------------------------*/
13674 MrBFlt RndGamma (MrBFlt s, RandLong *seed)
13675 {
13676     MrBFlt  r=0.0;
13677
13678     if (s <= 0.0)
13679         puts ("Gamma parameter less than zero\n");
13680
13681     else if (s < 1.0)
13682         r = RndGamma1 (s, seed);
13683     else if (s > 1.0)
13684         r = RndGamma2 (s, seed);
13685     else    /* 0-log() == -1 * log(), but =- looks confusing */
13686         r -= log(RandomNumber(seed));
13687
13688     return (r);
13689 }
13690
13691
13692 /*---------------------------------------------------------------------------------
13693 |
13694 |   RndGamma1
13695 |
13696 ---------------------------------------------------------------------------------*/
13697 MrBFlt RndGamma1 (MrBFlt s, RandLong *seed)
13698 {
13699     MrBFlt          r, x=0.0, tiny=1e-37, w;
13700     static MrBFlt   a, p, uf, ss=10.0, d;
13701
13702     if (fabs(s-ss)>ETA) /* s != ss */
13703         {
13704         a  = 1.0 - s;
13705         p  = a / (a + s * exp(-a));
13706         uf = p * pow(tiny / a, s);
13707         d  = a * log(a);
13708         ss = s;
13709         }
13710     for (;;)
13711         {
13712         r = RandomNumber(seed);
13713         if (r > p)
13714             x = a - log((1.0 - r) / (1.0 - p)), w = a * log(x) - d;
13715         else if (r>uf)
13716             x = a * pow(r / p, 1.0 / s), w = x;
13717         else
13718             return (0.0);
13719         r = RandomNumber(seed);
13720         if (1.0 - r <= w && r > 0.0)
13721         if (r*(w + 1.0) >= 1.0 || -log(r) <= w)
13722             continue;
13723         break;
13724         }
13725
13726     return (x);
13727 }
13728
13729
13730 /*---------------------------------------------------------------------------------
13731 |
13732 |   RndGamma2
13733 |
13734 ---------------------------------------------------------------------------------*/
13735 MrBFlt RndGamma2 (MrBFlt s, RandLong *seed)
13736 {
13737     MrBFlt          r , d, f, g, x;
13738     static MrBFlt   b, h, ss=0.0;
13739
13740     if (fabs(s-ss)>ETA) /* s != ss */
13741         {
13742         b  = s - 1.0;
13743         h  = sqrt(3.0 * s - 0.75);
13744         ss = s;
13745         }
13746     for (;;)
13747         {
13748         r = RandomNumber(seed);
13749         g = r - r * r;
13750         f = (r - 0.5) * h / sqrt(g);
13751         x = b + f;
13752         if (x <= 0.0)
13753             continue;
13754         r = RandomNumber(seed);
13755         d = 64 * r * r * g * g * g;
13756         if (d * x < x - 2.0 * f * f || log(d) < 2.0 * (b * log(x / b) - f))
13757             break;
13758         }
13759
13760     return (x);
13761 }
13762
13763
13764 /*---------------------------------------------------------------------------------
13765 |
13766 |   SetQvalue
13767 |
13768 |   The Pade method for calculating the matrix exponential, tMat = e^{qMat * v},
13769 |   has an error, e(p,q), that can be controlled by setting p and q to appropriate
13770 |   values. The error is:
13771 |
13772 |      e(p,q) = 2^(3-(p+q)) * ((p!*q!) / (p+q)! * (p+q+1)!)
13773 |
13774 |   Setting p = q will minimize the error for a given amount of work. This function
13775 |   assumes that p = q. The function takes in as a parameter the desired tolerance
13776 |   for the accuracy of the matrix exponentiation, and returns qV = p = q, that
13777 |   will achieve the tolerance. The Pade approximation method is described in:
13778 |
13779 |   Golub, G. H., and C. F. Van Loan. 1996. Matrix Computations, Third Edition.
13780 |      The Johns Hopkins University Press, Baltimore, Maryland.
13781 |
13782 |   The function is called from TiProbsUsingPadeApprox.
13783 |
13784 ---------------------------------------------------------------------------------*/
13785 int SetQvalue (MrBFlt tol)
13786 {
13787     int         qV;
13788     MrBFlt      x;
13789
13790     x = pow(2.0, 3.0 - (0 + 0)) * Factorial(0) * Factorial (0) / (Factorial(0+0) * Factorial (0+0+1));
13791     qV = 0;
13792     while (x > tol)
13793         {
13794         qV++;
13795         x = pow(2.0, 3.0 - (qV + qV)) * Factorial(qV) * Factorial (qV) / (Factorial(qV+qV) * Factorial (qV+qV+1));
13796         }
13797
13798     return (qV);
13799 }
13800
13801
13802 /*---------------------------------------------------------------------------------
13803 |
13804 |   SetToIdentity
13805 |
13806 |   Make a dim X dim identity matrix.
13807 |
13808 ---------------------------------------------------------------------------------*/
13809 void SetToIdentity (int dim, MrBFlt **matrix)
13810 {
13811     int         row, col;
13812
13813     for (row=0; row<dim; row++)
13814         for (col=0; col<dim; col++)
13815             matrix[row][col] = (row == col ? 1.0 : 0.0);
13816 }
13817
13818
13819 /*---------------------------------------------------------------------------------
13820 |
13821 |   Tha
13822 |
13823 |   Calculate Owen's (1956) T(h,a) function, -inf <= h, a <= inf,
13824 |   where h = h1/h2, a = a1/a2, from the program of:
13825 |
13826 |   Young, J. C. and C. E. Minder.  1974.  Algorithm AS 76.  An integral
13827 |      useful in calculating non-central t and bivariate normal
13828 |      probabilities.  Appl. Statist., 23:455-457.  [Correction: Appl.
13829 |      Statist., 28:113 (1979).  Remarks: Appl. Statist. 27:379 (1978),
13830 |      28: 113 (1979), 34:100-101 (1985), 38:580-582 (1988)]
13831 |
13832 |   See also:
13833 |
13834 |   Johnson, N. L.  and S. Kotz.  1972.  Distributions in statistics:
13835 |      multivariate distributions.  Wiley and Sons.  New York.  pp. 93-100.
13836 |
13837 ---------------------------------------------------------------------------------*/
13838 MrBFlt Tha (MrBFlt h1, MrBFlt h2, MrBFlt a1, MrBFlt a2)
13839 {
13840     int             ng = 5, i;
13841     MrBFlt          U[] = {0.0744372, 0.2166977, 0.3397048, 0.4325317, 0.4869533},
13842                     R[] = {0.1477621, 0.1346334, 0.1095432, 0.0747257, 0.0333357},
13843                     pai2 = 6.283185307, tv1 = 1e-35, tv2 = 15.0, tv3 = 15.0, tv4 = 1e-5,
13844                     a, h, rt, t, x1, x2, r1, r2, s, k, sign = 1.0;
13845
13846     if (fabs(h2) < tv1)
13847         return (0.0);
13848     h = h1 / h2;
13849     if (fabs(a2) < tv1)
13850         {
13851         t = CdfNormal(h);
13852         if (h >= 0.0)
13853             t = (1.0 - t) / 2.0;
13854         else
13855             t /= 2.0;
13856         return (t*(a1 >= 0.0 ? 1.0 : -1.0));
13857         }
13858     a = a1 / a2;
13859     if (a < 0.0)
13860         sign = -1.0;
13861     a = fabs(a);
13862     h = fabs(h);
13863     k = h*a;
13864     if (h > tv2 || a < tv1)
13865         return (0.0);
13866     if (h < tv1)
13867         return (atan(a)/pai2*sign);
13868     if (h < 0.3 && a > 7.0) /* (Boys RJ, 1989) */
13869         {
13870         x1 = exp(-k*k/2.0)/k;
13871         x2 = (CdfNormal(k)-0.5)*sqrt(pai2);
13872         t = 0.25 - (x1+x2)/pai2*h + ((1.0+2.0/(k*k))*x1+x2)/(6.0*pai2)*h*h*h;
13873         return (MAX(t,0)*sign);
13874         }
13875     t = -h*h / 2.0;
13876     x2 = a;
13877     s = a*a;
13878     if (log(1.0+s)-t*s >= tv3)
13879         {
13880         x1 = a/2;
13881         s /= 4.0;
13882     for (;;) /* truncation point by Newton iteration */
13883         {
13884         x2 = x1 + (t*s+tv3-log(s+1.0)) / (2.0*x1*(1.0/(s+1.0)-t));
13885         s = x2*x2;
13886         if (fabs(x2-x1) < tv4)
13887             break;
13888         x1 = x2;
13889         }
13890     }
13891     for (i=0,rt=0; i<ng; i++) /* Gauss quadrature */
13892         {
13893         r1 = 1.0+s*SQUARE(0.5+U[i]);
13894         r2 = 1.0+s*SQUARE(0.5-U[i]);
13895         rt+= R[i]*(exp(t*r1)/r1 + exp(t*r2)/r2);
13896         }
13897
13898     return (MAX(rt*x2/pai2,0)*sign);
13899 }
13900
13901
13902 /*---------------------------------------------------------------------------------
13903 |
13904 |   TiProbsUsingEigens
13905 |
13906 ---------------------------------------------------------------------------------*/
13907 void TiProbsUsingEigens (int dim, MrBFlt *cijk, MrBFlt *eigenVals, MrBFlt v, MrBFlt r, MrBFlt **tMat, MrBFlt **fMat, MrBFlt **sMat)
13908 {
13909     int             i, j, s;
13910     MrBFlt          sum, sumF, sumS, *ptr, EigValexp[192];
13911
13912     for (s=0; s<dim; s++)
13913         EigValexp[s] = exp(eigenVals[s] * v * r);
13914
13915     ptr = cijk;
13916     for (i=0; i<dim; i++)
13917         {
13918         for (j=0; j<dim; j++)
13919             {
13920             sum = 0.0;
13921             for (s=0; s<dim; s++)
13922                 sum += (*ptr++) * EigValexp[s];
13923             tMat[i][j] = (sum < 0.0) ? 0.0 : sum;
13924             }
13925         }
13926
13927 #   if 0
13928     for (i=0; i<dim; i++)
13929         {
13930         sum = 0.0;
13931         for (j=0; j<dim; j++)
13932             {
13933             sum += tMat[i][j];
13934             }
13935         if (sum > 1.0001 || sum < 0.9999)
13936             {
13937             MrBayesPrint ("%s   Warning: Transition probabilities do not sum to 1.0 (%lf)\n", spacer, sum);
13938             }
13939         }
13940 #   endif
13941
13942     if (fMat != NULL && sMat != NULL)
13943         {
13944         ptr = cijk;
13945         for (i=0; i<dim; i++)
13946             {
13947             for (j=0; j<dim; j++)
13948                 {
13949                 sumF = sumS = 0.0;
13950                 for (s=0; s<dim; s++)
13951                     {
13952                     sumF += (*ptr) * eigenVals[s] * r * EigValexp[s];
13953                     sumS += (*ptr++) * eigenVals[s] * eigenVals[s] * r * r * EigValexp[s];
13954                     }
13955                 fMat[i][j] = sumF;
13956                 sMat[i][j] = sumS;
13957                 }
13958             }
13959         }
13960 }
13961
13962
13963 /*---------------------------------------------------------------------------------
13964 |
13965 |   TiProbsUsingPadeApprox
13966 |
13967 |   The method approximates the matrix exponential, tMat = e^{qMat * v}, using
13968 |   the Pade approximation method, described in:
13969 |
13970 |   Golub, G. H., and C. F. Van Loan. 1996. Matrix Computations, Third Edition.
13971 |      The Johns Hopkins University Press, Baltimore, Maryland.
13972 |
13973 |   The method approximates the matrix exponential with accuracy tol.
13974 |
13975 ---------------------------------------------------------------------------------*/
13976 void TiProbsUsingPadeApprox (int dim, MrBFlt **qMat, MrBFlt v, MrBFlt r, MrBFlt **tMat, MrBFlt **fMat, MrBFlt **sMat)
13977 {
13978     int         qValue;
13979     MrBFlt      **a, tol;
13980
13981     tol = 0.0000001;
13982
13983     a = AllocateSquareDoubleMatrix (dim);
13984
13985     MultiplyMatrixByScalar (dim, qMat, v * r, a);
13986
13987     qValue = SetQvalue (tol);
13988
13989     ComputeMatrixExponential (dim, a, qValue, tMat);
13990
13991     FreeSquareDoubleMatrix (a);
13992
13993     if (fMat != NULL && sMat != NULL)
13994         {
13995         MultiplyMatrices (dim, qMat, tMat, fMat);
13996         MultiplyMatrices (dim, qMat, fMat, sMat);
13997         }
13998 }
13999