/* mh.c

   written by Frederic Bois
   5 January 1996

   Copyright (c) 1996-2004.  Frederic Bois.  All rights reserved.

   This program is free software; you can redistribute it and/or
   modify it under the terms of the GNU General Public License
   as published by the Free Software Foundation; either version 2
   of the License, or (at your option) any later version.

   This program is distributed in the hope that it will be useful,
   but WITHOUT ANY WARRANTY; without even the implied warranty of
   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   GNU General Public License for more details.

   You should have received a copy of the GNU General Public License
   along with this program; if not, write to the Free Software
   Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.

   -- Revisions -----
     Logfile:  %F%
    Revision:  %I%
        Date:  %G%
     Modtime:  %U%
      Author:  @a
   -- SCCS  ---------

*/

#include <stdio.h>
#include <string.h>

#include <gsl/gsl_cdf.h>
#include "mh.h"
#include "lsodes.h"
#include "lexerr.h"
#include "simmonte.h"

/* ------------------ global /External variables ------------------------ */
/*  temperature */

#define NTEMP 5


/* Function -------------------------------------------------------------------
   CalculateTotals

   Find total prior, likelihood for all MC vars
   Called from TraverseLevels
*/

void CalculateTotals (PLEVEL plevel, char **args)
{
  PANALYSIS panal = (PANALYSIS)args[0];
  double *pdLnPrior = (double*)args[1];

  long n;

  for (n = 0; n < plevel->nMCVars; n++) {
    *pdLnPrior += LnDensity(plevel->rgpMCVars[n], panal);
  }

} /* CalculateTotals */


/* Function -------------------------------------------------------------------
   CheckForFixed

   It is possible for an MC var to be fixed by a subsequent `=' statement in 
   the level just below the level at which it is declared in the input file;
   This routine marks such vars as "Fixed" and set their dVal to the
   prescribed number.
   Called from TraverseLevels
*/

void CheckForFixed (PLEVEL plevel, char **args)
{
  long    n, m;
  PMCVAR  pMCVar;
  PVARMOD pFVar;

  for (n = 0; n < plevel->nMCVars; n++) {
    pMCVar = plevel->rgpMCVars[n];
    for (m = 0; m < plevel->nFixedVars; m++) {
      pFVar = plevel->rgpFixedVars[m];
      if (pMCVar->hvar == pFVar->hvar) {
        pMCVar->bIsFixed = TRUE;
        if (IsInput (pFVar->hvar)) {
          printf("Error: a sampled parameter cannot be assigned an input\n");
          exit(0);
        }
        else
          pMCVar->dVal = pFVar->uvar.dVal;
      }
    }
  }

} /* CheckForFixed */


/* Function -------------------------------------------------------------------
   CheckPrintStatements

   Tries to check that 'Print' and 'Data' statements are consistent.
   Note that experiments must have outputs; this is checked in
   PrepareOutSpec in siminit.c.
   Called from TraverseLevels
*/

void CheckPrintStatements (PLEVEL plevel, char **args)
{
  PANALYSIS panal = (PANALYSIS) args[0];
  POUTSPEC  pos;
  /* PMCVAR    pMCVar;
  BOOL      bFound, bOK; */
  long      i, j /* , k, l, dCount, dIndex */;

  if (plevel->pexpt == NULL)
    return;

  pos = &(plevel->pexpt->os);

  /* check that the same var does not appear in 2 or more print statements */
  for (j = 0; j < pos->nOutputs; j++)
    for (i = j+1; i < pos->nOutputs; i++)
      if (pos->phvar_out[j] == pos->phvar_out[i])
        ReportRunTimeError (panal, RE_DUPVARINEXPRT | RE_FATAL,
                            pos->pszOutputNames[i], "Print");

  /* check that the same var does not appear in 2 or more data statements */
  for (j = 0; j < pos->nData; j++)
    for (i = j+1; i < pos->nData; i++)
      if (pos->phvar_dat[j] == pos->phvar_dat[i])
        ReportRunTimeError (panal, RE_DUPVARINEXPRT | RE_FATAL,
                            pos->pszDataNames[i], "Data");

#ifdef ndef

  /* this section needs to be completely revamped */

  /* check that all Predictions or Data appearing in Distrib statements have
     a corresponding output or data specification and that these have same
     output times */
  for (i = 0; i < plevel->nMCVars; i++) {
    pMCVar = plevel->rgpMCVars[i]; /* current Distrib examined */
    if (!IsParm (pMCVar->hParm[0])) { /* deal with first parameter */
        /* it's a state, input or output, it must have had a Prediction
           or a Data keyword and must have an output or data */
        bFound = FALSE;
        /* check the outputs */
        for (k = 0; (k < pos->nOutputs) || bFound; k++) {
          if (bFound = (pMCVar->hParm[0] == pos->phvar_out[k])) {
            dCount = pos->pcOutputTimes[k]; /* init dCount */
            dIndex = k;
          }
        }
        if (!bFound) {
          /* check the data statements */
          for (k = 0; (k < pos->nData) || bFound; k++) {
            if (bFound = (pMCVar->hParm[0] == pos->phvar_dat[k])) {
              dCount = pos->pcData[k]; /* init dCount */
              dIndex = k;
            }
          }
        }

        if (!bFound) /* still not found */
          ReportRunTimeError (panal, RE_NOPDSTATEMENT | RE_FATAL,
                              pMCVar->pszName);
      }

    /* now check that distributional parameters which are Data or Prediction
       have data or print statements and adequate number of output times or
       data items */
    for (j = 1; j < 4; j++) {
      if (!IsParm (pMCVar->hParm[j])) {
        bFound = FALSE;
        for (k = 0; (k < pos->nOutputs) || bFound; k++) {
          if (bFound = (pMCVar->hParm[j] == pos->phvar_out[k])) {
            bOK = (dCount == pos->pcOutputTimes[k]);
            for (l = 0; (l < dCount) && bOK; l++)
              bOK = (pos->prgdOutputTimes[dIndex][l] ==
                     pos->prgdOutputTimes[k][l]);
          }
          if (!bOK)
            ReportRunTimeError (panal, RE_UNEQUALTIMES | RE_FATAL,
                                GetVarName (pMCVar->hParm[0]),
                                GetVarName (pMCVar->hParm[j]),
                                pMCVar->pszName);
        } /* for k */

        if (!bFound)
          ReportRunTimeError (panal, RE_NOPRINTSTATEMENT | RE_FATAL,
                              pMCVar->pszName);
      }
    } /* for j */
  } /* for i */

  /* check that each variable for which Data are specified also have a
     Distrib statement */
  for (i = 0; i < pos->nData; i++) {
    bFound = FALSE;
    for (j = 0; (j < plevel->nMCVars) || bFound; j++) {
      pMCVar = plevel->rgpMCVars[j]; /* current Distrib examined */
      bFound = (pMCVar->hvar == pos->phvar_dat[i]);
    }
    if (!bFound)
      ReportRunTimeError (panal, RE_NOLIKELIHOOD | RE_FATAL,
                          pos->pszDataNames[i]);
  }*/

#endif

} /* CheckPrintStatements */


/* Function -------------------------------------------------------------------
   CloneLikes

   Called from TraverseLevels
   First copy the likelihoods in the current plistLikes in the rgpLikes
   down to the next lower levels. Then eventually override them by definitions
   in rgpLikes at this level.
*/
void CloneLikes (PLEVEL plevel, char **args)
{
  long nLikes;
  long i, j, k;
  PLEVEL pLower;
  PMCVAR pClone;
  PMCVAR pMCVar;
  BOOL bFound;

  for (i = 0; i < plevel->iInstances; i++) {
    pLower = plevel->pLevels[i];
    /* The number of likelihoods is overestimated by this, but that will do 
       for now: */
    pLower->nLikes = nLikes = plevel->nLikes + ListLength(plevel->plistLikes);

    if (pLower->nLikes != 0) {
      if (!(pLower->rgpLikes =
             (PMCVAR*) malloc (pLower->nLikes * sizeof(PMCVAR))))
        ReportError (NULL, RE_OUTOFMEM | RE_FATAL, "CloneLikes", NULL);
    }
  }

  /* Copy the likelihoods in the plistLikes at this level to the
     rgpLikes of the lower levels */
  nLikes = 0;
  ForAllList3 (plevel->plistLikes, &CloneLikesL, plevel, &nLikes, NULL);

  /* Note: nLikes now equals the number of likelihoods in the current
     plistLikes */

  /* Copy the likelihoods in rgpLikes at this level down to the lower
     levels, if they are not already defined */
  for (i = 0; i < plevel->iInstances; i++) {
    pLower = plevel->pLevels[i];

    for (j = 0; j < plevel->nLikes; j++) {
      pMCVar = plevel->rgpLikes[j];

      /* if that likelihood is already in pLower->rgpLikes forget it */
      bFound = FALSE;
      k = 0;
      while ((k < nLikes) && (!bFound)) {
        bFound = (pMCVar->hvar == pLower->rgpLikes[k]->hvar);
        if (!bFound) k++;
      }
      if (!bFound) {
        if (!(pClone = (PMCVAR) malloc (sizeof (MCVAR))))
          ReportError (NULL, RE_OUTOFMEM | RE_FATAL, "CloneLikes", NULL);

        memcpy (pClone, pMCVar, sizeof (MCVAR));
        pLower->rgpLikes[nLikes+j] = pClone;
      }
    }
  }

} /* CloneLikes */


/* Function -------------------------------------------------------------------
   CloneLikesL

   Clone and copy the members of a plistLikes from a level to the rgpLikes
   arrays of the levels below
   Called from ForAllList3
*/
void CloneLikesL (PVOID pData, PVOID pUser1, PVOID pUser2, PVOID pUser3)
{
  PMCVAR pMCVar = (PMCVAR) pData;
  PLEVEL plevel = (PLEVEL) pUser1;
  long   *pnLikes = (long *) pUser2;
  long   i;
  PLEVEL pLower;
  PMCVAR pClone;

  ++pMCVar->iDepth;
  for (i = 0; i < plevel->iInstances; i++) {
    pLower = plevel->pLevels[i];
    if (!(pClone = (PMCVAR) malloc (sizeof (MCVAR))))
      ReportError (NULL, RE_OUTOFMEM | RE_FATAL, "CloneLikeL", NULL);
    memcpy (pClone, pMCVar, sizeof (MCVAR));
    pLower->rgpLikes[*pnLikes] = pClone;
  }
  ++(*pnLikes);

} /* CloneLikesL */


/* Function -------------------------------------------------------------------
   CloneMCVars

   Called from TraverseLevels
   For all MC vars in list at given level, add to arrays of all instances of
   next (lower) level; the instances are created by the cloning routine
   CloneMCVarsL
*/
void CloneMCVars (PLEVEL plevel, char **args)
{
  long nMCVars = ListLength(plevel->plistMCVars);
  long n;
  PLEVEL pLower;

  for (n = 0; n < plevel->iInstances; n++) {
    pLower = plevel->pLevels[n];
    pLower->nMCVars = nMCVars;
    if (nMCVars != 0) {
      if (!(pLower->rgpMCVars = (PMCVAR*) malloc (nMCVars * sizeof(PMCVAR))))
        ReportError (NULL, RE_OUTOFMEM | RE_FATAL, "CloneMCVars", NULL);
    }
  }

  nMCVars = 0;
  ForAllList3 (plevel->plistMCVars, &CloneMCVarsL, plevel, &nMCVars, NULL);

} /* CloneMCVars */


/* Function -------------------------------------------------------------------
   CloneMCVarsL

   Clone and copy the members of a plistMCVars
   Called from ForAllList3
*/
void CloneMCVarsL (PVOID pData, PVOID pUser1, PVOID pUser2, PVOID pUser3)
{
  PMCVAR pMCVar = (PMCVAR) pData;
  PLEVEL plevel = (PLEVEL) pUser1;
  long   *pnMCVars = (long *) pUser2;
  long   i;
  PLEVEL pLower;
  PMCVAR pClone;

  ++pMCVar->iDepth;
  for (i = 0; i < plevel->iInstances; i++) {
    pLower = plevel->pLevels[i];
    if (!(pClone = (PMCVAR) malloc (sizeof (MCVAR))))
      ReportError (NULL, RE_OUTOFMEM | RE_FATAL, "CloneMCVarsL", NULL);
    memcpy (pClone, pMCVar, sizeof (MCVAR));
    pClone->plistDependents = InitList ();
    pLower->rgpMCVars[*pnMCVars] = pClone;
  }
  ++(*pnMCVars);

} /* CloneMCVarsL */



/* Function -------------------------------------------------------------------
   CloseMarkovFiles

   Closes output files associated with the Markov sampler.
   The restart file has already been closed by the ReadRestart

*/

void CloseMarkovFiles (PANALYSIS panal)
{
  if (panal->gd.pfileOut) {
    fclose (panal->gd.pfileOut);
    printf ("\nWrote results to \"%s\"\n", panal->gd.szGout);
  }

} /* CloseMarkovFiles */


/* Function -------------------------------------------------------------------
   ConvertLists

   Converts lists to arrays
   Called from TraverseLevels
*/

void ConvertLists(PLEVEL plevel, char **args)
{
  PANALYSIS panal = (PANALYSIS)args[0];
  long m, n;
  PMCVAR pMCVar;

  if (plevel->pexpt == NULL)
    ListToPVArray (panal, plevel->plistVars, &plevel->nFixedVars,
                   &plevel->rgpFixedVars);
  else
    ListToPVArray (panal, plevel->pexpt->plistParmMods, &plevel->nFixedVars,
                   &plevel->rgpFixedVars);

  for (n = 0; n < plevel->nMCVars; n++) {
    pMCVar = plevel->rgpMCVars[n];
    ListToPMCArray (panal, pMCVar->plistDependents,
                    &pMCVar->nDependents, &pMCVar->rgpDependents);

    /* if there are no dependent, experiments are most likely to be dependent
       on that parameter (complete checking would require  verifying the
       model file - FB 2 May 1998 */
    if (pMCVar->nDependents == 0)
      pMCVar->bExptIsDep = TRUE;
    else {
      /* if there are dependent, experiments may be dependent on that
         parameter if they are not shielded by an intermediate instance of
         the same parameter */
      m = 0;
      while ((m < pMCVar->nDependents) &&
             !(pMCVar->bExptIsDep = (strcmp(pMCVar->rgpDependents[m]->pszName,
                                            pMCVar->pszName) ? TRUE : FALSE)))
        m++;
    }
  }

} /* ConvertLists */


/* Function -------------------------------------------------------------------
   dInvTemper

   set inverse temperatures for annealing algorithm
*/

double dInvTemper( long indexT){

  double dInvTemper;

  if (indexT == 0) dInvTemper = 0.4;         /* hot */
  else{ if (indexT == NTEMP-1) dInvTemper = 1;      /* cold */
   else dInvTemper = pow(0.8, (NTEMP-1-indexT));
  }

  return(dInvTemper);

} /* dInvTemp */


/* Function -------------------------------------------------------------------
   DoMarkov

   Core routine of the MCMC sampler
*/

void DoMarkov (PANALYSIS panal)
{
  PGIBBSDATA pgd = &panal->gd;
  PLEVEL     pLevel0 = panal->pLevels[0];
  long       nThetas, nUpdateAt, nTotal;
  long       i, iter = 0;
  long       nIter = pgd->nMaxIter;  /* scheduled iterations of the sampler */
  double     *pdMCVarVals  = NULL;   /* read in values of thetas */
  double     *pdSum        = NULL;   /* column sums of read thetas */
  double     **prgdSumProd = NULL;   /* column sums of thetas cross-products */
  double     dLnPrior = 0, dLnData = 0;


  /* temperature stuff */

  long indexT = 0; /* hot */
  static  long  attemptedTempe = 0; /* attempted temperature jumps */
  double dlnPi[NTEMP];
  double dCZero = 10;
  double dNZero = 50;
  long CTemp[NTEMP];    /* temperature count*/

  if (pgd->nInitIter == 3) { /* tempered */
    for (i = 0; i < NTEMP ; i++) {
      CTemp[i] = dlnPi[i] = 0;
    }
  }

  InitRandom (panal->dSeed, TRUE);

  if (pgd->nInitIter == 1)
    printf ("\nDoing analysis -"
            "\nPrinting data and predictions for the last line of the "
            "restart file\n");
  else
    printf ("\nDoing analysis - %ld %s iteration%s\n",
            nIter, "MCMC sampling", (nIter != 1 ? "s " : " "));

  OpenMarkovFiles (panal);

  if (panal->gd.szGdata) { /* read the data from a file */
    FILE *pfile = fopen (panal->gd.szGdata, "r");
    if (!pfile) {
      printf ("Cannot open data file '%s'\n", panal->gd.szGdata);
      exit (0);
    } /* if */

    /* skip the first line.  This allows a MC output file to be used
       directly as a restart file. */
    fscanf (pfile, "%*[^\n]");  getc(pfile);

    TraverseLevels (pLevel0, ReadData, pfile, NULL);

    fclose (pfile);
  }

  /* we do not want more than 1 top level; Get out;
     This could be dealth with earlier, though */
  if (panal->iInstances > 1) {
    printf("Error: only one top level is allowed\nExiting\n");
    exit(0);
  }

  /* MC variables must be placed in arrays at the next lower level */
  TraverseLevels (pLevel0, CloneMCVars, NULL);

  /* Likelihoods must percolate down to the experiment level */
  TraverseLevels (pLevel0, CloneLikes, NULL);

  /* Find the parents and dependents of the MC vars */
  TraverseLevels (pLevel0, FindMCParents, panal, NULL);
  TraverseLevels (pLevel0, FindMCDependents, panal, NULL);

  /* Find the parents of the parameters in likelihood statements */
  TraverseLevels (pLevel0, FindLikeParents, panal, NULL);

  /* Now that we have the MC vars right, write the output file header
     unless it's just a run for fit checking */
  if (pgd->nInitIter != 1) {
    fprintf (pgd->pfileOut, "iter\t");
    TraverseLevels (pLevel0, WriteHeader, panal, pgd->pfileOut, NULL);
    if (pgd->nInitIter == 3) {   /* tempered */
      fprintf (pgd->pfileOut, "IndexT\t");
      for (i = 0; i < NTEMP; i++) 
        fprintf (pgd->pfileOut, "LnPseudoPrior(%ld)\t",i);
      fprintf (pgd->pfileOut, "LnPrior\tLnData\tLnPosterior\n");
    }
    else {
      fprintf (pgd->pfileOut, "LnPrior\tLnData\tLnPosterior\n");
    }
    fflush (pgd->pfileOut);
  }

  /* Convert the rest of the lists to arrays */
  TraverseLevels (pLevel0, ConvertLists, panal, NULL);

  /* Check for MC vars that have been fixed */
  TraverseLevels (pLevel0, CheckForFixed, NULL);

  /* Check variables in statements of type
     'Distrib(<var1>, <distrib>, Prediction, <var2>)'
     for identical 'Print' statements */
  TraverseLevels (pLevel0, CheckPrintStatements, panal, NULL);

  /* Print out the structure for checking */
  if (panal->bDependents) {
    TraverseLevels (pLevel0, PrintDeps, NULL);
    CloseMarkovFiles (panal);
    return;
  }

  /* Change the MC vars hvar pointers from pointing to model parameters to
     pointing to the parents' dVal */
  TraverseLevels (pLevel0, SetPointers, panal, NULL);

  /* Get the initial values of the MC vars by reading th restart file if
     one is given */
  if (pgd->szGrestart) {

    /* Read them from the restart file */
    nThetas = 0;
    TraverseLevels (pLevel0, GetNumberOfMCVars, &nThetas, NULL);

    if ( !(pdMCVarVals = InitdVector (nThetas)) ||
         !(pdSum       = InitdVector (nThetas)) ||
         !(prgdSumProd = InitdMatrix (nThetas, nThetas))) {
      /* FB 6/4/98 */
      /* lack of memory can be severe here, free immediately some space */
      if (pdMCVarVals) free (pdMCVarVals);
      if (pdSum) free (pdSum);
      ReportRunTimeError (panal, RE_OUTOFMEM | RE_FATAL, "DoMarkov");
    }

    /* Read the starting values in the order they are printed and
       close the file when finished */

    if (pgd->nInitIter == 3) {
       ReadRestart2 (pgd->pfileRestart, nThetas, pdMCVarVals, pdSum,
                     prgdSumProd, &iter, &indexT, dlnPi);
    }
    else {
      ReadRestart (pgd->pfileRestart, nThetas, pdMCVarVals, pdSum, prgdSumProd,
                   &iter);
    }

    /* Set the dVals of the variables to the values read in */
    nThetas = 0;
    if (!TraverseLevels1 (pLevel0, SetMCVars, pdMCVarVals, &nThetas, NULL)) {
      printf ("\nError: some read-in parameters are out of bounds - "
              "Exiting\n\n");
      exit(0);
    }

    /* If nInitIter is 1 print just the predictions and data and exit */
    if (pgd->nInitIter == 1) {
      PrintAllExpts (pLevel0, panal, pgd->pfileOut);
      CloseMarkovFiles (panal);
      return;
    }

    /* If component jumps or tempered */
    if ((pgd->nInitIter == 0) || (pgd->nInitIter == 3)) { 
      /* Set the jumping kernel's SD */
      TraverseLevels (pLevel0, SetKernel, 1, pdMCVarVals, NULL);

      /* Free the now useless array */
      free (pdMCVarVals);
    }
    else { /* vector jumping, initialize prior */
      TraverseLevels (pLevel0, CalculateTotals, panal, &dLnPrior, NULL);
    }

    /* Initialize the predictions arrays by running all experiments and
       save the likelihood */
    if (!RunAllExpts (panal, &dLnData)) {
      /* error, cannot compute */
      printf ("\nError: cannot compute at the starting point - Exiting\n\n");
      exit(0);
    }
  }

  else { /* no restart file, init by sampling */

    /* If nInitIter is 1 print an error message and exit */
    if (pgd->nInitIter == 1) {
      printf ("\nError: a restart file must be given to print data and"
              "         predictions - Exiting.\n\n");
      exit (0);
    }

    /* Set the jumping kernel's SD */
    TraverseLevels (pLevel0, SetKernel, 2, pdMCVarVals, NULL);

    /* Initialize the thetas by sampling, write them out at the same time */
    fprintf (pgd->pfileOut, "0\t");
    TraverseLevels (pLevel0, InitMCVars, pgd->pfileOut, NULL);

    /* Calculate the total prior */
    TraverseLevels (pLevel0, CalculateTotals, panal, &dLnPrior, NULL);
    /* Initilalize the predictions arrays by running all experiments and
       save the data likelihood output */
    if (!RunAllExpts (panal, &dLnData)) {
      /* error, cannot compute */
      printf ("\nError: cannot compute at the starting point - Exiting\n\n");
      exit(0);
    }

    if (pgd->nInitIter == 3) {  /*output indexT and PseudoPrior*/
      fprintf (pgd->pfileOut, "0\t");
      for (i = 0; i < NTEMP; i++) fprintf (pgd->pfileOut, "%e\t",dlnPi[i]);
      fflush (pgd->pfileOut);
    }

    /* Output prior and likelihood */
    fprintf (pgd->pfileOut, "%e\t%e\t%e\n", dLnPrior, dLnData,
             dLnPrior + dLnData);
    fflush (pgd->pfileOut);
  }

  /* Save the data likelihoods */
  TraverseLevels1 (pLevel0, SaveLikelihoods, NULL);

  /* Initializations are finished, let's do the iterations */
  nTotal = UPDATE_BASE;
  nUpdateAt = iter + nTotal; /* kernel will be updated at that iteration */

  while (iter < nIter) {

    /* Output to screen, eventually */
    if (panal->bPrintIter && ((iter+1) % 100 == 0))
      fprintf(stderr, "Iteration %ld\n", iter + 1);

    /* Start output to file, eventually */

    if (((iter + 1) % pgd->nPrintFreq == 0) &&
        (iter >= pgd->nMaxIter - pgd->nPrintIter))
      fprintf (pgd->pfileOut, "%ld\t", iter + 1);


    if (pgd->nInitIter == 0) { /* component jumps */

      TraverseLevels (pLevel0, SampleThetas, panal, pgd, &iter, &nUpdateAt,
                      &nTotal, NULL);

      /* Output log-densities, eventually */
      if (((iter + 1) % pgd->nPrintFreq == 0) &&
          (iter >= pgd->nMaxIter - pgd->nPrintIter)) {
        dLnPrior = 0.0;
        TraverseLevels (pLevel0, CalculateTotals, panal, &dLnPrior, NULL);
        dLnData = 0.0;
        TraverseLevels1 (pLevel0, SumAllExpts, &dLnData, NULL);
        fprintf (pgd->pfileOut, "%e\t%e\t%e\n", dLnPrior, dLnData,
               dLnPrior + dLnData);
        fflush (pgd->pfileOut);
      }
    }
    else {

    if (pgd->nInitIter == 3) { /* tempered */

      TraverseLevels (pLevel0, SampleThetasTempered, panal, pgd, &iter, 
                      &nUpdateAt,  &nTotal, &indexT, NULL);

      dLnPrior = 0.0;
      TraverseLevels (pLevel0, CalculateTotals, panal, &dLnPrior, NULL);
      dLnData = 0.0;
      TraverseLevels1 (pLevel0, SumAllExpts, &dLnData, NULL);

      /* test the temperature */
      attemptedTempe++; /* this need to be before the next which uses it */

      /* Robbins-Monro updating of the pseudo prior */
      for (i = 0; i <NTEMP; i++)
        if (i == indexT)
          dlnPi[i] = dlnPi[i] - (dCZero / (attemptedTempe + dNZero));
        else
          dlnPi[i] = dlnPi[i] + (dCZero / (NTEMP * (attemptedTempe + dNZero)));

      /* Output log-densities, indexT, Pseudoprior, eventually */
      if (((iter + 1) % pgd->nPrintFreq == 0) &&
          (iter >= pgd->nMaxIter - pgd->nPrintIter)) {
        fprintf (pgd->pfileOut, "%ld\t", indexT);
        for (i = 0; i < NTEMP; i++) fprintf (pgd->pfileOut, "%e\t",dlnPi[i]);
        fprintf (pgd->pfileOut, "%e\t%e\t%e\n", dLnPrior, dLnData,
                 dLnPrior + dLnData);
        fflush (pgd->pfileOut);
      }

      /* count of temperatures*/
      CTemp[indexT] = CTemp[indexT]+1;

      /* test the temperature and change indexT if necessary*/
      indexT = SampleTemperature (indexT, dLnPrior, dLnData, attemptedTempe,
                                  dlnPi);
    }
    else { /* vector jumps */

      SampleThetaVector (pLevel0, panal, nThetas, pdMCVarVals, pdSum,
                         prgdSumProd, iter, nUpdateAt, nTotal, &dLnPrior,
                         &dLnData);

      /* Output, eventually */
      if (((iter + 1) % pgd->nPrintFreq == 0) &&
          (iter >= pgd->nMaxIter - pgd->nPrintIter)) {
        for (i = 0; i < nThetas; i++)
          fprintf(pgd->pfileOut, "%5g\t", pdMCVarVals[i]);
        fprintf (pgd->pfileOut, "%e\t%e\t%e\n", dLnPrior, dLnData,
               dLnPrior + dLnData);
        fflush (pgd->pfileOut);
      }
    }
    }
    /* Adjust the update time eventually */
    if (iter == nUpdateAt) {
      nTotal = nTotal * 3 / 2;
      nUpdateAt = iter + nTotal;
    }

    /* Increment the iteration counter */
    iter = iter + 1;

  } /* while iter */


  CloseMarkovFiles (panal);

  if (pgd->nInitIter == 3){
   printf("\ntemperature count\n");
  for (i=0;i<NTEMP;i++) printf("%ld\t",CTemp[i]);
  }

} /* DoMarkov */


/* Function -------------------------------------------------------------------
   FindLikeParents

   Called from TraverseLevels
   Find the parents of the MC vars corresponding to likelihood at this level
   by looking at sampled parameters at this and all previous levels. Note that
   dependencies are not checked among likelihoods.
*/
void FindLikeParents (PLEVEL plevel, char **args)
{
  PANALYSIS panal = (PANALYSIS)args[0];
  long      n, m, l, k;
  PLEVEL    pPrevLev;
  PMCVAR    pMCVar1, pMCVar2;

  /* Set the current level array as we pass through */
  panal->pCurrentLevel[plevel->iDepth] = plevel;

  /* First, this level; Parents do not need to appear before current */
  for (n = 0; n < plevel->nLikes; n++) {
    pMCVar1 = plevel->rgpLikes[n]; /* current likelihood */
    for (m = 0; m < plevel->nMCVars; m++) { /* for all previous distrib */
      pMCVar2 = plevel->rgpMCVars[m];
      for (l = 0; l < 4; l++) {
        if (pMCVar1->hParm[l] == pMCVar2->hvar) {
          pMCVar1->pMCVParent[l] = pMCVar2;
        }
      }
    }
  }

  /* Now, all previous levels */
  for (n = plevel->iDepth - 1; n >= 0; n--) {
    pPrevLev = panal->pCurrentLevel[n];
    for (m = 0; m < plevel->nLikes; m++) {
      pMCVar1 = plevel->rgpLikes[m]; /* current likelihood */
      for (l = 0; l < pPrevLev->nMCVars; l++) {
        pMCVar2 = pPrevLev->rgpMCVars[l];
        for (k = 0; k < 4; k++) {
          if (pMCVar1->pMCVParent[k] == NULL &&
              pMCVar1->hParm[k] == pMCVar2->hvar) {
            pMCVar1->pMCVParent[k] = pMCVar2;
          }
        }
      }
    }
  }

} /* FindLikeParents */


/* Function -------------------------------------------------------------------
   FindMCDependents

   Called from TraverseLevels
   Find the direct dependents of the MC vars at this level by looking at this
   and all lower levels
*/

void FindMCDependents (PLEVEL plevel, char **args)
{
  long   i, j;
  PMCVAR pMCVar;

  for (i = 0; i < plevel->nMCVars; i++) {
    pMCVar = plevel->rgpMCVars[i];
    for (j = 0; j < 4; j++)
      if ((pMCVar->pMCVParent[j] != NULL) &&
          (pMCVar->pMCVParent[j]->hvar == pMCVar->hParm[j]))
        QueueListItem(pMCVar->pMCVParent[j]->plistDependents, pMCVar);
  }

} /*FindMCDependents */


/* Function -------------------------------------------------------------------
   FindMCParents

   Called from TraverseLevels
   Find the parents of the MC vars at this level by looking at this and
   all previous levels.
*/
void FindMCParents (PLEVEL plevel, char **args)
{
  PANALYSIS panal = (PANALYSIS)args[0];
  long      n, m, l, k;
  PLEVEL    pPrevLev;
  PMCVAR    pMCVar1, pMCVar2;

  /* Set the current level array as we pass through */
  panal->pCurrentLevel[plevel->iDepth] = plevel;

  /* First, this level; Parents must appear before current in the array */
  for (n = 0; n < plevel->nMCVars; n++) {
    pMCVar1 = plevel->rgpMCVars[n]; /* current */
    for (m = 0; m < n; m++) { /* for all previous */
      pMCVar2 = plevel->rgpMCVars[m];
      for (l = 0; l < 4; l++) {
        if (pMCVar1->hParm[l] == pMCVar2->hvar) {
          pMCVar1->pMCVParent[l] = pMCVar2;
        }
      }
    }
  }

  /* Now, all previous levels, starting with the one above and going up */
  for (n = plevel->iDepth-1; n > 0; --n) { /* 27/8/02 FB changed from n >= 0 */
    pPrevLev = panal->pCurrentLevel[n];
    for (m = 0; m < plevel->nMCVars; m++) { /* for each var in the level */
      pMCVar1 = plevel->rgpMCVars[m];
      /* check each var of the upper level */
      for (l = 0; l < pPrevLev->nMCVars; l++) {
        pMCVar2 = pPrevLev->rgpMCVars[l];
        for (k = 0; k < 4; k++) { /* for the 4 distribution parameters */
          if (pMCVar1->pMCVParent[k] == NULL &&
              pMCVar1->hParm[k] == pMCVar2->hvar) {
            pMCVar1->pMCVParent[k] = pMCVar2;
          }
        }
      }
    }
  }

} /* FindMCParents */

/* Function -------------------------------------------------------------------
   GetNumberOfMCVars

   Find the total number of MC vars
   Called from TraverseLevels
*/
void GetNumberOfMCVars (PLEVEL plevel, char **args)
{
  long *pnThetas = (long *) args[0];

  *pnThetas += plevel->nMCVars;

} /* GetNumberOfMCVars */


/* Function -------------------------------------------------------------------
   InitMCVars

   Sample initial values of thetas if not fixed
   Called from TraverseLevels
*/

void InitMCVars(PLEVEL plevel, char **args)
{
  FILE *pOutFile = (FILE*)args[0];
  long n;

  for (n = 0; n < plevel->nMCVars; n++)
    if ( !(plevel->rgpMCVars[n]->bIsFixed))
      CalculateOneMCParm (plevel->rgpMCVars[n]);

  /* Write out the sampled values */
  WriteMCVars (plevel, pOutFile);

} /* InitMCVars */


/* Function -------------------------------------------------------------------
   ListToPMCArray
*/

void ListToPMCArray (PANALYSIS panal, PLIST plist,
                     long *pnMCVars, PMCVAR **rgpMCVars)
{
  if ((*pnMCVars = ListLength(plist)) == 0)
    return;

  if (!(*rgpMCVars = (PMCVAR*) malloc (*pnMCVars * sizeof(PMCVAR))))
    ReportRunTimeError (panal, RE_OUTOFMEM | RE_FATAL, "ListToPMCArray");

  *pnMCVars = 0;
  ForAllList3 (plist, &ListToPMCArrayL, pnMCVars, *rgpMCVars, NULL);

} /*ListToPMCArray */


/* Function -------------------------------------------------------------------
   ListToPMCArrayL
*/

void ListToPMCArrayL (PVOID pData, PVOID pUser1, PVOID pUser2, PVOID pUser3)
{
  PMCVAR pMCVar = (PMCVAR)pData;
  long *pnMCVars = (long*)pUser1;
  PMCVAR *rgpMCVars = (PMCVAR*)pUser2;

  rgpMCVars[(*pnMCVars)++] = pMCVar;

} /* ListToPMCArrayL */


/* Function -------------------------------------------------------------------
   ListToPVArray
*/

void ListToPVArray (PANALYSIS panal, PLIST plist,
                    long *pnFixedVars, PVARMOD **rgpFixedVars)
{
  if ((*pnFixedVars = ListLength (plist)) == 0)
    return;

  if (!(*rgpFixedVars = (PVARMOD*) malloc (*pnFixedVars * sizeof(PVARMOD))))
    ReportRunTimeError (panal, RE_OUTOFMEM | RE_FATAL, "ListToPVArray");

  *pnFixedVars = 0;
  ForAllList3 (plist, &ListToPVArrayL, pnFixedVars, *rgpFixedVars, NULL);

} /*ListToPVArray */


/* Function -------------------------------------------------------------------
   ListToPVArrayL
*/

void ListToPVArrayL (PVOID pData, PVOID pUser1, PVOID pUser2, PVOID pUser3)
{
  PVARMOD pVar = (PVARMOD)pData;
  long    *pnFixedVars = (long*)pUser1;
  PVARMOD *rgpFixedVars = (PVARMOD*)pUser2;

  rgpFixedVars[(*pnFixedVars)++] = pVar;

} /* ListToPVArrayL */


/* Function -------------------------------------------------------------------
   LnDensity

   Returns the log of the (exact) density of variate under its distribution.
*/
#define LNSQRT2PI 9.189385332046E-01

double LnDensity (PMCVAR pMCVar, PANALYSIS panal)
{
  double dTmp = 0, density;
  double dParm1 = *(pMCVar->pdParm[0]);
  double dParm2 = *(pMCVar->pdParm[1]);
  double dMin   = *(pMCVar->pdParm[2]);
  double dMax   = *(pMCVar->pdParm[3]);
  double dTheta = pMCVar->dVal;
  char str[10];

  /* This should take care of all dTheta checking */
  if (pMCVar->iType == MCV_BINOMIALBETA) {
    if (dTheta < 0) {
      printf ("Error: variate out of bounds in LnDensity\n");
      exit (0);
    }
  }
  else {
    if (dTheta > dMax || dTheta < dMin) {
      return (NULL_SUPPORT);
    }
  }

  switch (pMCVar->iType) {

    case MCV_UNIFORM:
      if (dTheta > dParm2 || dTheta < dParm1)
        return (NULL_SUPPORT);
      if (dParm2 <= dParm1)
        ReportRunTimeError (panal, RE_BADUNIFORMDIST | RE_FATAL,
                            pMCVar->pszName, "LnDensity");
      return -log(dParm2 - dParm1);

    case MCV_LOGUNIFORM:
      if (dTheta > dParm2 || dTheta < dParm1)
        return (NULL_SUPPORT);
      if (dParm2 <= dParm1)
        ReportRunTimeError (panal, RE_BADUNIFORMDIST | RE_FATAL,
                            pMCVar->pszName, "LnDensity");
      return -log(dTheta * (dParm2 - dParm1));

    case MCV_NORMALV: dParm2 = sqrt (dParm2); /* fall thru */
    case MCV_NORMAL:
    case MCV_HALFNORMAL:
      return lnDFNormal (dTheta, dParm1, dParm2);

    case MCV_LOGNORMALV: dParm2 = exp(sqrt(dParm2)); /* fall thru */
    case MCV_LOGNORMAL:
      if (dParm1 <= 0.0) {
        sprintf(str, "%5.2e", dParm1);
        ReportRunTimeError(panal, RE_BADLOGNORMALMEAN | RE_FATAL,
                           pMCVar->pszName, str, "LnDensity");
      }
      return (lnDFNormal(log(dTheta),log(dParm1),log(dParm2)) - log(dTheta));

    case MCV_TRUNCNORMALV: dParm2 = sqrt (dParm2); /* fall thru */
    case MCV_TRUNCNORMAL:
      if (dParm2 <= 0.0) {
        sprintf(str, "%5.2e", dParm2);
        ReportRunTimeError(panal, RE_BADNORMALSD | RE_FATAL,
                           pMCVar->pszName, str, "LnDensity");
      }
      return lnDFNormal (dTheta, dParm1, dParm2) -
             log(CDFNormal ((dMax - dParm1) / dParm2) -
                 CDFNormal ((dMin - dParm1) / dParm2));

    case MCV_TRUNCLOGNORMALV: dParm2 = exp(sqrt(dParm2)); /* fall thru */
    case MCV_TRUNCLOGNORMAL:
      if (dParm1 <= 0.0 ) {
        sprintf(str, "%5.2e", dParm1);
        ReportRunTimeError(panal, RE_BADLOGNORMALMEAN | RE_FATAL,
                           pMCVar->pszName, str, "LnDensity");
      }
      if (dParm2 <= 1.0 ) {
        sprintf(str, "%5.2e", dParm2);
        ReportRunTimeError(panal, RE_BADLOGNORMALSD | RE_FATAL,
                           pMCVar->pszName, str, "LnDensity");
      }
      dTmp = log(dParm2);
      return lnDFNormal (log(dTheta), log(dParm1), dTmp) - log(dTheta) -
             log(CDFNormal (log(dMax / dParm1) / dTmp) -
                 CDFNormal (log(dMin / dParm1) / dTmp));

    case MCV_BETA:
      return lnDFBeta (dTheta, dParm1, dParm2, dMin, dMax);

    case MCV_CHI2:
      dTmp = 0.5 * dParm1;
      return (dTmp - 1) * log(dTheta) - 0.5 * dTheta +
             dTmp * (-6.9314718056E-01) - lnGamma (dTmp);

    case MCV_BINOMIAL:
      if ((dParm1 < 0) || (dParm1 > 1)) {
        printf ("Error: bad p for binomial variate in LnDensity\n");
        exit (0);
      }
      if (dTheta > dParm2) {
        return (NULL_SUPPORT);
      }
      /* log binomial coefficient n! / (x!(n-x)!) */
      dTmp = lnGamma (dParm2 + 1) - lnGamma (dTheta + 1) -
             lnGamma (dParm2 - dTheta + 1);

      if (dParm1 == 0) { /* revised FB 18/07/97 */
        if (dTheta != 0)
          return (NULL_SUPPORT); /* should be -INF */
      }
      else
        dTmp = dTmp + dTheta * log(dParm1);

      if (dParm1 == 1) { /* revised FB 18/07/97 */
        if ((dParm2 - dTheta) == 0)
          return dTmp; /* because log(0^0) is 0 */
        else
          return (NULL_SUPPORT); /* should be -INF */
      }
      else
        return dTmp + (dParm2 - dTheta) * log(1 - dParm1);

    case MCV_PIECEWISE:
      density = 2 / (dMax + dParm2 - dParm1 - dMin);

      if (dTheta <= dParm1)
        return log(density * (dTheta - dMin) / (dParm1 - dMin));

      else
        if (dTheta <= dParm2)
          return log(density);
        else
          return log(density * (dMax - dTheta) / (dMax - dParm2));

    case MCV_EXPONENTIAL:
      if (dParm1 <= 0) {
        printf ("Error: negative or null inverse scale (%g) for exponential "
                "variate in LnDensity\n", dParm1);
        exit (0);
      }
      return -dTheta * dParm1 + log(dParm1);

    case MCV_GGAMMA:
      if (dParm2 <= 0) {
        printf ("Error: bad inv. scale for gamma variate in LnDensity\n");
        exit (0);
      }
      return (dParm1 - 1) * log(dTheta) - dParm2 * dTheta +
             dParm1 * log(dParm2) - lnGamma (dParm1);

    case MCV_TRUNCINVGGAMMA: 
      dTmp = gsl_cdf_gamma_P (1/dMax, dParm1, dParm2) - 
             gsl_cdf_gamma_P (1/dMin, dParm1, dParm2); /* fall thru */
    case MCV_INVGGAMMA:
      if (dParm2 <= 0) {
        printf ("Error: bad scale for inv. gamma variate in LnDensity\n");
        exit (0);
      }
      return (-dParm1 - 1) * log(dTheta) - dParm2 / dTheta +
             dParm1 * log(dParm2) - lnGamma (dParm1) - dTmp;

    case MCV_POISSON:
      if (dParm1 <= 0) {
        printf ("Error: bad rate for Poisson variate in LnDensity\n");
        exit (0);
      }
      return dTheta * log(dParm1) - dParm1 - lnGamma (dTheta + 1);

    case MCV_BINOMIALBETA:
      if (dParm1 < 0) {
        printf ("Error: bad expectation for BinomialBeta variate "
                "in LnDensity\n");
        exit (0);
      }
      if (dParm2 <= 0) {
        printf ("Error: bad alpha for BinomialBeta variate in LnDensity\n");
        exit (0);
      }
      if (dMin <= 0) {
        printf ("Error: bad beta for BinomialBeta variate in LnDensity\n");
        exit (0);
      }
      dTmp = floor (0.5 + dParm1 + dParm1 * dMin / dParm2); /* this is N */
      if (dTheta > dTmp)
        return (NULL_SUPPORT);
      else {
        if ((dParm2 == 0.5) && (dMin == 0.5))
          dTmp = lnGamma (0.5 + dTheta) +
                 lnGamma (0.5 + dTmp - dTheta) -
                 lnGamma (dTheta + 1) - lnGamma (dTmp - dTheta + 1);
        else
          dTmp = lnGamma (dParm2 + dMin) + lnGamma (dTmp + 1) +
                 lnGamma (dParm2 + dTheta) +
                 lnGamma (dMin + dTmp - dTheta) -
                 lnGamma (dTheta + 1) - lnGamma (dTmp - dTheta + 1) -
                 lnGamma (dParm2) - lnGamma(dMin) -
                 lnGamma (dParm2 + dMin + dTmp);
        return dTmp;
      }

    default:
      ReportRunTimeError(panal, RE_UNKNOWNDIST | RE_FATAL, "LnDensity");

  } /* switch */

  /* Not reached */
  return 0.0 ;

} /* LnDensity */


/* Function -------------------------------------------------------------------
   LnLike

   returns the log-likelihood of the dependents given the parameter specified
   by pMCVar
*/

double LnLike (PMCVAR pMCVar, PANALYSIS panal)
{
  long n;
  double dDensity, dLnLike = 0.0;

  for (n = 0; n < pMCVar->nDependents; n++) {
    dDensity = LnDensity(pMCVar->rgpDependents[n], panal);
    if (dDensity == NULL_SUPPORT)
      return NULL_SUPPORT;
    else
      dLnLike += dDensity;
  }
  return dLnLike;

} /* LnLike */


/* Function -------------------------------------------------------------------
   LnLikeData

   Likelihood of the data for one experiment
*/

double LnLikeData (PLEVEL plevel, PANALYSIS panal) {

  PMCVAR pMCVar;
  long   i, j, k;
  double dLnLike = 0.0;
  double dTmp;
  BOOL   bMissData, bMissOutp;
  static PDOUBLE pdBase[4];

  /* For all the likelihoods seen at the experiment level */
  for (i = 0; i < plevel->nLikes; i++) {
    pMCVar = plevel->rgpLikes[i];

    for (k = 0; k < 4; k++)
      pdBase[k] = pMCVar->pdParm[k]; /* store the base pointers of pdParm */

    /* Set dVal of pMCVar to the current data value */
    for (j = 0; j < pMCVar->lCount; j++) { /* for each data value */

      pMCVar->dVal = pMCVar->pdVal[j]; /* point to jth data value */

      /* If the main data is coded as missing do nothing, and otherwise: */
      if (pMCVar->dVal != INPUT_MISSING_VALUE) {
        /* Set the pdParms of pMCVar to point to data or output values */
        bMissData = FALSE; /* initialize */
        bMissOutp = FALSE; /* initialize */
        for (k = 0; k < 4; k++) {
          if (pMCVar->iParmType[k] == MCVP_PRED) {
            /* Advance in the prediction array */
            pMCVar->pdParm[k] = pdBase[k] + j;
            bMissOutp = bMissOutp + (*(pMCVar->pdParm[k]) == MISSING_VALUE);
          }
          else if (pMCVar->iParmType[k] == MCVP_DATA) {
            /* Advance in the data array */
            pMCVar->pdParm[k] = pdBase[k] + j;
            bMissData = bMissData +
                        (*(pMCVar->pdParm[k]) == INPUT_MISSING_VALUE);
          }
        } /* end for k */

        /* If no missing data among the k parameters */
        if (bMissData == FALSE) {
          /* If no missing model output among the k parameters */
          if (bMissOutp == FALSE) {
            dTmp = LnDensity (pMCVar, panal);
            if (dTmp == NULL_SUPPORT) {
              /* Reset the pdParms to the beginning of arrays  FB 9/6/99 */
              for (k = 0; k < 4; k++)
                pMCVar->pdParm[k] = pdBase[k];
              return (NULL_SUPPORT);
            }
            else
              dLnLike = dLnLike + dTmp;
          }
          else /* missing output, cannot compute */
            ReportRunTimeError (panal, RE_BADMODEL | RE_FATAL, "LnLikeData");
        } /* end if bMissData */

      } /* end if ! INPUT_MISSING_VALUE */
    } /* end for j */

    /* Reset the pdParms to the beginning of the output or data arrays */
    for (k = 0; k < 4; k++)
      pMCVar->pdParm[k] = pdBase[k];

  } /* end for i */

  return (dLnLike);

} /* LnLikeData */


/* Function -------------------------------------------------------------------
   MaxMCVar

   get the maximum of MC variables
*/

double MaxMCVar (PMCVAR pMCVar) {

  /* if the parameter has a discrete distribution, round it - FB 12/06/97 */
  if (pMCVar->iType == MCV_BINOMIAL || pMCVar->iType == MCV_POISSON ) {
   return( *(pMCVar->pdParm[3]));
  }
  else { /* FB fixed the uniform case - FB 30/06/97 */
    if (pMCVar->iType == MCV_UNIFORM || pMCVar->iType == MCV_LOGUNIFORM ) {
      return( *(pMCVar->pdParm[1]));
    }
    else {
      return( *(pMCVar->pdParm[3]));
    }
  }

} /* MaxMCVar*/


/* Function -------------------------------------------------------------------
   MinMCVar

    get the minimum of MC variables
*/

double MinMCVar (PMCVAR pMCVar) {

  /* if the parameter has a discrete distribution, round it - FB 12/06/97 */
  if (pMCVar->iType == MCV_BINOMIAL || pMCVar->iType == MCV_POISSON ) {
   return( *(pMCVar->pdParm[2]));                                 
  }
  else { /* FB fixed the uniform case - FB 30/06/97 */
    if (pMCVar->iType == MCV_UNIFORM || pMCVar->iType == MCV_LOGUNIFORM ) {
      return( *(pMCVar->pdParm[0]));
    }
    else {
      return( *(pMCVar->pdParm[2]));
    }
  }

} /* MinMCVar*/


/* Function -------------------------------------------------------------------
   OpenMarkovFiles

   Opens the output file and the restart file.
*/

void OpenMarkovFiles (PANALYSIS panal)
{
  /* Take care of the output file first */

  /* Use command line spec if given */
  if (panal->bCommandLineSpec)
    panal->gd.szGout = panal->szOutfilename;

  /* Default if none given */
  else if (!(panal->gd.szGout))
    panal->gd.szGout = "MCMC.default.out";

  /* eventually open the restart file before crushing the output file */
  if (panal->gd.szGrestart)
    if (!(panal->gd.pfileRestart)
      && !(panal->gd.pfileRestart = fopen (panal->gd.szGrestart, "r")))
      ReportRunTimeError(panal, RE_FATAL | RE_CANNOTOPEN,
                         panal->gd.szGrestart, "OpenMarkovFiles");

  if (!(panal->gd.pfileOut)
      && !(panal->gd.pfileOut = fopen (panal->gd.szGout, "w")))
    ReportRunTimeError(panal, RE_FATAL | RE_CANNOTOPEN,
                       panal->gd.szGout, "OpenMarkovFiles");

} /* OpenMarkovFiles */


/* Function -------------------------------------------------------------------
   PrintAllExpts

   Run and print all experiments at level below `plevel'
*/

void PrintAllExpts (PLEVEL plevel, PANALYSIS panal, PFILE pOutFile)
{
  long n;

  for (n = 0; n < plevel->iInstances; n++)
    TraverseLevels1 (plevel->pLevels[n], PrintExpt, panal, pOutFile, NULL);

} /* PrintAllExpts */


/* Function -------------------------------------------------------------------
   PrintExpt

   Run all experiments and print the level code, experiment number, time, data,
   and predictions to the output file.

   Called from TraverseLevels1
*/

int PrintExpt (PLEVEL plevel, char **args)
{
  PANALYSIS   panal = (PANALYSIS)args[0];
  PFILE       pOutFile = (PFILE)args[1];
  long        l, m, n;
  PEXPERIMENT pExpt = plevel->pexpt;
  POUTSPEC    pos;
  static long printed_head = 0;

  if (!printed_head) {
    fprintf (pOutFile,
             "Level\tSimulation\tOutput_Var\tTime\tData\tPrediction\n");
    printed_head = 1;
  }

  /* Set level sequence */
  panal->pCurrentLevel[plevel->iDepth] = plevel;

  panal->iInstance[plevel->iDepth] = plevel->iSequence;

  if (pExpt != NULL) {
    InitModel ();

    /* Set the model vars that have been sampled in this experiment and
       above levels */
    for (n = 0; n <= plevel->iDepth; n++) {
      SetModelVars (panal->pCurrentLevel[n]);
      SetFixedVars (panal->pCurrentLevel[n]);
    }

    if (!DoOneExperiment (pExpt)) {
      /* Error */
      printf ("Warning: DoOneExperiment failed\n");
      return 0;
    }
    else {
      pos = &pExpt->os;
      for (m = 0; m < pos->nOutputs; m++) {
        for (l = 0; l < pos->pcOutputTimes[m]; l++) {
          for (n = 1; n < plevel->iDepth; n++)
            fprintf (pOutFile, "%d_", panal->iInstance[n]);
          fprintf (pOutFile, "%d\t", panal->iInstance[plevel->iDepth]);

          if (pos->prgdDataVals[m] != NULL) /* FB 18/10/98 */
            fprintf (pOutFile, "%d\t%s\t%g\t%g\t%g\n", pExpt->iExp,
                     pos->pszOutputNames[m], pos->prgdOutputTimes[m][l],
                     pos->prgdDataVals[m][l], pos->prgdOutputVals[m][l]);
          else
            fprintf (pOutFile, "%d\t%s\t%g\t\t%g\n", pExpt->iExp,
                     pos->pszOutputNames[m], pos->prgdOutputTimes[m][l],
                     pos->prgdOutputVals[m][l]);

        } /* end for l */

        fprintf (pOutFile, "\n");

      } /* end for m */

      fprintf (pOutFile, "\n");

    } /* end else */

  } /* end if pExpt */

  return (1);

} /* PrintExpt*/


/* Function -------------------------------------------------------------------
   ReadData

   Reads in data from a specified data file. There need to be on data item
   per output specified.
   Upgraded by FB 27/03/99 to deal with improved data handling.
   Called from TraverseLevels.
*/

void ReadData (PLEVEL plevel, char **args)
{
  FILE *pfileData = (FILE *) args[0];
  POUTSPEC pos;
  int cDat, i, j;

  if (plevel->pexpt == NULL)
    return;

  pos = &(plevel->pexpt->os);

  /* here the number of data must equal the number of outputs */
  cDat = pos->nOutputs;
  pos->prgdDataVals = InitpdVector (cDat);
  pos->pcData       = InitiVector (cDat);  /* FB 5/11/99 */
  pos->pszDataNames = (PSTR *) malloc (cDat * sizeof(PSTR));
  pos->phvar_dat    = (HVAR *) malloc (cDat * sizeof(HVAR));

  if (pos->prgdDataVals == NULL || pos->phvar_dat == NULL ||
      pos->pszDataNames == NULL || pos->pcData    == NULL)
    ReportError (NULL, RE_OUTOFMEM | RE_FATAL, "ReadData()", NULL);
  else {
    pos->nData = cDat;  /* FB 27/03/99: Set count of data */

    /* scan all data values for data file */
    for (i = 0; i < cDat; i++) {
      /* allocate space for pos->prgdDataVals[i] */
      if ( !(pos->prgdDataVals[i] = InitdVector (pos->pcOutputTimes[i])))
        ReportError (NULL, RE_OUTOFMEM | RE_FATAL, "ReadData()", NULL);;

      /* for each requested output time */
      for (j = 0; j < pos->pcOutputTimes[i]; j++)
        if (fscanf(pfileData, "%lg", &(pos->prgdDataVals[i][j])) == EOF) {
          printf ("Error: incorrect length for data file - Exiting\n");
          exit(0);
        }
      pos->pcData[i] = j; /* FB 5/11/99 */
      pos->phvar_dat[i] = pos->phvar_out[i];
      pos->pszDataNames[i] = pos->pszOutputNames[i];

    } /* for i */

  } /* else */

} /* ReadData */


/* Function -------------------------------------------------------------------
   PrintDeps

   Called from TraverseLevels

   For debugging, print the variables, parents, and dependencies
*/

void PrintDeps (PLEVEL plevel, char **args)
{
  long n, m;
  PMCVAR pMCVar;

  fprintf (stderr, "Depth %d; Instance %d\n",
           plevel->iDepth, plevel->iSequence);

  for (n = 0; n < plevel->nMCVars; n++) {
    pMCVar = plevel->rgpMCVars[n];

    fprintf(stderr, "Variable %s (%d) [%lx]\n",
            pMCVar->pszName, pMCVar->iDepth, (unsigned long) pMCVar);

    for (m = 0; m < 4; m++)
      if (pMCVar->pMCVParent[m] != NULL)
        fprintf (stderr, "  Parent %ld: %s (%d) [%lx]\n", m,
                 pMCVar->pMCVParent[m]->pszName,
                 pMCVar->pMCVParent[m]->iDepth,
                 (unsigned long) pMCVar->pMCVParent[m]);

    for (m = 0; m < pMCVar->nDependents; m++)
      fprintf (stderr, "  Dependent: %s (%d) [%lx]\n",
               pMCVar->rgpDependents[m]->pszName,
               pMCVar->rgpDependents[m]->iDepth,
               (unsigned long) pMCVar->rgpDependents[m]);

    if (pMCVar->bExptIsDep)
      fprintf(stderr, "  This variable influences experiments directly\n");
  }

} /* PrintDeps */


/* Function -------------------------------------------------------------------
   ReadRestart

   initialize the population and individual parameters by reading them in the
   restart file.
*/

void ReadRestart (FILE *pfileRestart, long nThetas,
                  double *pdTheta, double *pdSum, double **prgdSumProd,
                  long *pIter)
{
  register long i, j;

  *pIter = -1;

  for (i = 0; i < nThetas; i++) {
    pdSum[i] = 0.0;
    for (j = 0; j < nThetas; j++)
      prgdSumProd[i][j] = 0.0;
  }

  /* skip the first line.  This allows a MC output file to be used
     directly as a restart file. */
  fscanf (pfileRestart,  "%*[^\n]");  getc(pfileRestart);

  /* as long as we have not reached the end of the file we keep reading lines
     and overwriting the thetas, they keep only their last value.
     We throw away first field, and we keep incrementing the global iteration
     counter iter:
   */
  while (!(feof (pfileRestart) ||
          (fscanf (pfileRestart, "%*s") == EOF))) {
    for (i = 0; i < nThetas; i++) {
      if (fscanf(pfileRestart, "%lg", &(pdTheta[i])) == EOF) {
        printf ("Error: incorrect length for restart file - Exiting\n");
        exit(0);
      }
      else { /* reading ok */
        /* update pdSum, the column sum of pdTheta */
        pdSum[i] = pdSum[i] + pdTheta[i];
      }
    }

    /* Throw away remainder of line. This allows a MC output file to be used
       directly as a restart file. */
    fscanf (pfileRestart,  "%*[^\n]"); getc(pfileRestart);

    /* update prgdSumProd */
    for (i = 0; i < nThetas; i++)
      for (j = 0; j < nThetas; j++)
        prgdSumProd[i][j] = prgdSumProd[i][j] + pdTheta[i] * pdTheta[j];


    /* increment pIter */
    *pIter = *pIter + 1;

  } /* end while */

  /* note that the theta returned is the last parameter set read */

  fclose (pfileRestart);

} /* ReadRestart */

/* Function -------------------------------------------------------------------
   ReadRestart2

   initialize the population and individual parameters and temperature stuff
   (pseudoprior, indexT) by reading them in the restart file.
   */

void ReadRestart2 (FILE *pfileRestart, long nThetas,
                  double *pdTheta, double *pdSum, double **prgdSumProd,
                  long *pIter, long *pindexT, double *pdlnPi)
{
  register long i, j;
  double aux[NTEMP];
  long iT;
  *pIter = -1;

  for (i = 0; i < NTEMP; i++) aux[i] = 0.0;

  for (i = 0; i < nThetas; i++) {
    pdSum[i] = 0.0;
    for (j = 0; j < nThetas; j++)
      prgdSumProd[i][j] = 0.0;
  }

  /* skip the first line.  This allows a MC output file to be used
     directly as a restart file. */
  fscanf (pfileRestart,  "%*[^\n]");  getc(pfileRestart);

  /* as long as we have not reached the end of the file we keep reading lines
     and overwriting the thetas, they keep only their last value.
     We throw away first field, and we keep incrementing the global iteration
     counter iter:
     */
  while (!(feof (pfileRestart) ||
           (fscanf (pfileRestart, "%*s") == EOF))) {
    for (i = 0; i < nThetas; i++) {
      if (fscanf(pfileRestart, "%lg", &(pdTheta[i])) == EOF) {
        printf ("Error: incorrect length for restart file - Exiting\n");
        exit(0);
      }
      else { /* reading ok */
        /* update pdSum, the column sum of pdTheta */
        pdSum[i] = pdSum[i] + pdTheta[i];
      }
    }

     if (fscanf(pfileRestart,"%ld", &(iT)) == EOF) {
        printf ("Error: incorrect length for restart file - Exiting\n");
        exit(0);
     }
     for (i = 0; i < NTEMP; i++) {
       if (fscanf(pfileRestart,"%lg", &(aux[i])) == EOF) {
         printf ("Error: incorrect length for restart file - Exiting\n");
         exit(0);
       }
     }

    /* Throw away remainder of line. This allows a MC output file to be used
       directly as a restart file. */
    fscanf (pfileRestart,  "%*[^\n]"); getc(pfileRestart);

    *pindexT = iT;
    for (i = 0; i < NTEMP; i++) pdlnPi[i] = aux[i];

    /* update prgdSumProd */
    for (i = 0; i < nThetas; i++)
      for (j = 0; j < nThetas; j++)
        prgdSumProd[i][j] = prgdSumProd[i][j] + pdTheta[i] * pdTheta[j];


    /* increment pIter */
    *pIter = *pIter + 1;

  } /* end while */

  /* note that the theta returned is the last parameter set read */

  fclose (pfileRestart);

} /* ReadRestart2 */


/* Function -------------------------------------------------------------------
   RestoreLikelihoods

   Called from TraverseLevels1
*/

int RestoreLikelihoods (PLEVEL plevel, char **args)
{
  PEXPERIMENT pExpt = plevel->pexpt;

  if (pExpt != NULL) {
    pExpt->dLnLike = pExpt->dLnLikeSave;
  }

  return (1);

} /* RestoreLikelihoods */


/* Function -------------------------------------------------------------------
   RunAllExpts

   Run all experiments (i.e. experiments at all levels below 
   panal->pLevels[0]).
*/

int RunAllExpts (PANALYSIS panal, PDOUBLE pdLnData)
{
  PLEVEL plevel0 = panal->pLevels[0];
  long n;

  for (n = 0; n < plevel0->iInstances; n++) {
    if (!TraverseLevels1 (plevel0->pLevels[n], RunExpt, panal,
                          pdLnData, NULL)) {
      /* error */
      return (0);
    }
  }

  /* success */
  return (1);

} /* RunAllExpts */


/* Function -------------------------------------------------------------------
   RunExpt

   If `plevel' has experiments, modify the variables that have been sampled
   at this level and above using its two lists, and run the experiments.
   Return 1 on success and 0 if failure.
   Computes the data likelihood in case of success.

   Called from TraverseLevels1
*/

int RunExpt (PLEVEL plevel, char **args)
{
  PANALYSIS   panal = (PANALYSIS) args[0];
  double      *pdLnData = (double *) args[1];
  long        i;
  PEXPERIMENT pExpt = plevel->pexpt;

  /* Set level sequence */
  panal->pCurrentLevel[plevel->iDepth] = plevel;

  if (pExpt != NULL) {
    InitModel ();

    /* Set the model vars that have been sampled in this level and above */
    for (i = 0; i <= plevel->iDepth; i++) {
      SetModelVars (panal->pCurrentLevel[i]);
      SetFixedVars (panal->pCurrentLevel[i]);
    }

    if (!DoOneExperiment (pExpt)) {
      /* Error */
      printf ("Warning: DoOneExperiment failed\n");
      return 0;
    }
    else {
      pExpt->dLnLike = LnLikeData (plevel, panal);
      *pdLnData = (*pdLnData) + pExpt->dLnLike;
    }
  } /* if */

  return (1);

} /* RunExpt */

/* Function -------------------------------------------------------------------
   SampleTemperature
*/

long SampleTemperature (long indexT, double dLnPrior, double dLnData, 
                        long attemptedTempe, double dlnPi[NTEMP])
{
  static long accptTempe = 0; /* accepted temperature jumps */
  long   indexT_new;
  double pseudo, pseudonew;

  /* Propose a new inverse temperature */
  if (indexT == 0) indexT_new = indexT + 1;
  else {
    if (indexT == NTEMP-1) indexT_new = indexT - 1;
    else {
      if (Randoms() > 0.5) indexT_new = indexT + 1;
         else indexT_new = indexT - 1;
    }
  }

  /* Test the temperature */

  pseudo = dlnPi[indexT];
  pseudonew = dlnPi[indexT_new];

  if (Test2(indexT, indexT_new, dLnPrior, dLnData, attemptedTempe, 
            pseudo, pseudonew)) {   
    /* jump */
    return( indexT_new);
    accptTempe++;
  }
  else 
    return(indexT);

}/* SampleTemperature */


/* Function -------------------------------------------------------------------
   SampleTheta
*/

double SampleTheta (PMCVAR pMCVar) {

  /* if the parameter has a discrete distribution, round it - FB 12/06/97 */
  if (pMCVar->iType == MCV_BINOMIAL || pMCVar->iType == MCV_POISSON) {
   return floor (0.5 + TruncNormalRandom (pMCVar->dVal, pMCVar->dKernelSD,
                                          MinMCVar(pMCVar),
                                          MaxMCVar(pMCVar)));
  }
  else { /* FB fixed the uniform case - FB 30/06/97 */
    return TruncNormalRandom (pMCVar->dVal, pMCVar->dKernelSD,
                              MinMCVar(pMCVar), MaxMCVar(pMCVar));
  }

} /* SampleTheta */


/* Function -------------------------------------------------------------------
   SampleThetas

   Perform a Metropolis step on all the random (MC) variables at the
   level passed as argument 1.
   Sample thetas in sequence - test using prior and likelihood -
   restore old values if necessary - write new values to output file.

   Called from TraverseLevels
*/

void SampleThetas (PLEVEL plevel, char **args)
{
  PANALYSIS  panal = (PANALYSIS) args[0];
  PGIBBSDATA pgd = (PGIBBSDATA) args[1];
  long *pnIter = (long *) args[2];
  long *pnUpdateAt = (long *) args[3];
  long *pnTotal = (long *) args[4];

  double dLnPrior, dLnLike, dLnData;
  double dLnPriorNew, dLnLikeNew, dLnDataNew;
  double dTheta, dJumps, dMaxSD;
  PMCVAR pMCVar;
  long  n;

  /* Set level sequence. This is needed to call RunExpt from the middle
     of the tree with the right initialization of the nodes above */
  panal->pCurrentLevel[plevel->iDepth] = plevel;

  /* For all MC vars at this level */
  for (n = 0; n < plevel->nMCVars; n++) {

    pMCVar = plevel->rgpMCVars[n];

    /* If the MC var is fixed, no sampling is made, just write it out */
    if (pMCVar->bIsFixed)
      goto WriteIt;

    /* Compute prior and likelihood */
    dLnPrior = LnDensity (pMCVar, panal);
    dLnLike = LnLike (pMCVar, panal);

    dLnData = 0.0;

    /* If data are dependent compute the data likelihood */
    if (pMCVar->bExptIsDep) {
      /* Form the likelihood of all experiments at this level or beneath.*/
      TraverseLevels1 (plevel, SumAllExpts, &dLnData, NULL);
    }

    /* Save current value */
    dTheta = pMCVar->dVal;

    /* Adjust the jumping kernel SD, depending on acceptance rates,
       make sure it does not exceed DBL_MAX or a third of the range */
    if (*pnIter == *pnUpdateAt) {

      dJumps = (double) pMCVar->lJumps / (double) (*pnTotal);

      /* set bounds for kernel increase */
      if (pMCVar->iType == MCV_UNIFORM || pMCVar->iType == MCV_LOGUNIFORM )
        dMaxSD = (*(pMCVar->pdParm[1]) / 6.0) - (*(pMCVar->pdParm[0]) / 6.0);
      else
        dMaxSD = (*(pMCVar->pdParm[3]) / 6.0) - (*(pMCVar->pdParm[2]) / 6.0);

      if (dJumps > 0.3) { /* we will increase the kernel spread */
        if (dJumps == 1) {
          /* pathological case: chances are the parameter has such a
             small kernel that it does not change values, this leads
             to a "jump" each time. Drastic increase of the kernel is
             attempted */
          if (pMCVar->dKernelSD < sqrt(DBL_MAX)) {
            if (pMCVar->dKernelSD > 2)
              pMCVar->dKernelSD = pMCVar->dKernelSD * pMCVar->dKernelSD;
            else /* FB 28/03/1999 */
              pMCVar->dKernelSD = pMCVar->dKernelSD * 20;
          }
          else
            pMCVar->dKernelSD = DBL_MAX;
        }
        else { /* more normal case */
          if (pMCVar->dKernelSD < DBL_MAX / 2)
            pMCVar->dKernelSD = pMCVar->dKernelSD * 2;
          else
            pMCVar->dKernelSD = DBL_MAX;
        }

        /* check that kernel SD does not increase wildly */
        if (pMCVar->dKernelSD > dMaxSD)
          pMCVar->dKernelSD = dMaxSD;
      }
      else { /* we will decrease the kernel spread */
        if (dJumps == 0) {
          /* pathological case: chances are the parameter has such a
             big kernel that it will never jump. Drastic decrease of
             the kernel is attempted, dissymetric from the increase */
          if (pMCVar->dKernelSD > pow(DBL_MIN, 0.45)) {
            if (pMCVar->dKernelSD > 2) { /* FB 28/03/1999 */
              pMCVar->dKernelSD = pow(pMCVar->dKernelSD, 0.45);
            }
            else {
              pMCVar->dKernelSD = pMCVar->dKernelSD * 0.04;
            }
          }
          else
            pMCVar->dKernelSD = DBL_MIN;
        }
        else { /* more normal case */
          /* the kernel should not be infinitely decreased; decrease
             is otherwise slighly different from the increase to avoid
             oscillations */
          if (pMCVar->dKernelSD > DBL_MIN / 0.4)
            pMCVar->dKernelSD = pMCVar->dKernelSD * 0.4;
          else
            pMCVar->dKernelSD = DBL_MIN;
        }
      }

      pMCVar->lJumps = 0; /* reset the jumps counter */

    }

    /* sample a new value */
    pMCVar->dVal = SampleTheta (pMCVar);

    /* recompute prior and likelihood */
    dLnPriorNew = LnDensity (pMCVar, panal);
    dLnLikeNew = LnLike (pMCVar, panal);

    dLnDataNew = 0.0;

    /* If data are dependent compute the data likelihood */
    if (pMCVar->bExptIsDep) {
      /* Run all experiments at this level or beneath.
         We should in fact run only the dependent experiments ! */

      if (!TraverseLevels1 (plevel, RunExpt, panal, &dLnDataNew, NULL)) {
        /* If running experiments fails, do not jump */
        pMCVar->dVal = dTheta;
        TraverseLevels1 (plevel, RestoreLikelihoods, NULL);
        goto WriteIt;
      }
    }

    /* Test the results and act accordingly */
    if (!Test (pMCVar->bExptIsDep, dLnPrior, dLnPriorNew, dLnLike,
               dLnLikeNew, dLnData, dLnDataNew)) {
      pMCVar->dVal = dTheta;

      if(pMCVar->bExptIsDep)
        TraverseLevels1 (plevel, RestoreLikelihoods, NULL);
    }
    else {
      pMCVar->lJumps = pMCVar->lJumps + 1;

      if(pMCVar->bExptIsDep)
        TraverseLevels1 (plevel, SaveLikelihoods, NULL);
    }

WriteIt: /* Write the MC var value to output file */

    if (((*pnIter+1) % pgd->nPrintFreq == 0) &&
        (*pnIter >= pgd->nMaxIter - pgd->nPrintIter)) {
      fprintf(pgd->pfileOut, "%5g\t", pMCVar->dVal);
    }
  } /* end for all pMCVar */

} /* SampleThetas */


/* Function -------------------------------------------------------------------
   SampleThetasTempered

   Use annealing MCMC
   Sample thetas in sequence - test using prior and likelihood -
   restore old values if necessary - write new values to output file
   Called from TraverseLevels

*/

void SampleThetasTempered (PLEVEL plevel, char **args)
{
  PANALYSIS  panal = (PANALYSIS) args[0];
  PGIBBSDATA pgd = (PGIBBSDATA) args[1];
  long *pnIter = (long *) args[2];
  long *pnUpdateAt = (long *) args[3];
  long *pnTotal = (long *) args[4];
  long *pindexT = (long *) args[5];

  double dLnPrior, dLnLike, dLnData;
  double dLnPriorNew, dLnLikeNew, dLnDataNew;
  double dTheta, dJumps,  dMaxSD,  old_dKernelSD;
  PMCVAR pMCVar;
  long   n;

  /* Set level sequence. This is needed to call RunExpt from the middle
     of the tree with the right initialization of the nodes above */
  panal->pCurrentLevel[plevel->iDepth] = plevel;

  /* For all MC vars at this level */
  for (n = 0; n < plevel->nMCVars; n++) {

    pMCVar = plevel->rgpMCVars[n];

    /* If the MC var is fixed, no sampling is made, just write it out */
    if (pMCVar->bIsFixed)
      goto WriteIt;

      /* Compute prior and likelihood */
      dLnPrior = LnDensity (pMCVar, panal);
      dLnLike = LnLike (pMCVar, panal);

      dLnData = 0.0;

      /* If data are dependent compute the data likelihood */
      if (pMCVar->bExptIsDep) {
        /* Form the likelihood of all experiments at this level or beneath.*/
        TraverseLevels1 (plevel, SumAllExpts, &dLnData, NULL);
      }

      /* Save current value */
      dTheta = pMCVar->dVal;

      /* Adjust the jumping kernel SD, depending on acceptance rates,
         make sure it does not exceed DBL_MAX or a third of the range */
      if (*pnIter == *pnUpdateAt) {

        dJumps = (double) pMCVar->lJumps / (double) (*pnTotal);

        /* set bounds for kernel increase */
        if (pMCVar->iType == MCV_UNIFORM || pMCVar->iType == MCV_LOGUNIFORM )
          dMaxSD = (*(pMCVar->pdParm[1]) / 6.0) - (*(pMCVar->pdParm[0]) / 6.0);
        else
          dMaxSD = (*(pMCVar->pdParm[3]) / 6.0) - (*(pMCVar->pdParm[2]) / 6.0);

        if (dJumps > 0.3) { /* we will increase the kernel spread */
          if (dJumps == 1) {
            /* pathological case: chances are the parameter has such a
               small kernel that it does not change values, this leads
               to a "jump" each time. Drastic increase of the kernel is
               attempted */
            if (pMCVar->dKernelSD < sqrt(DBL_MAX)) {
              if (pMCVar->dKernelSD > 2)
                pMCVar->dKernelSD = pMCVar->dKernelSD * pMCVar->dKernelSD;
              else /* FB 28/03/1999 */
                pMCVar->dKernelSD = pMCVar->dKernelSD * 20;
            }
            else
              pMCVar->dKernelSD = DBL_MAX;
          }
          else { /* more normal case */
            if (pMCVar->dKernelSD < DBL_MAX / 2)
              pMCVar->dKernelSD = pMCVar->dKernelSD * 2;
            else
              pMCVar->dKernelSD = DBL_MAX;
          }

          /* check that kernel SD does not increase wildly */
          if (pMCVar->dKernelSD > dMaxSD)
            pMCVar->dKernelSD = dMaxSD;
        }
        else { /* we will decrease the kernel spread */
          if (dJumps == 0) {
            /* pathological case: chances are the parameter has such a
               big kernel that it will never jump. Drastic decrease of
               the kernel is attempted, dissymetric from the increase */
            if (pMCVar->dKernelSD > pow(DBL_MIN, 0.45)) {
              if (pMCVar->dKernelSD > 2) { /* FB 28/03/1999 */
                pMCVar->dKernelSD = pow(pMCVar->dKernelSD, 0.45);
              }
              else {
                pMCVar->dKernelSD = pMCVar->dKernelSD * 0.04;
              }
            }
            else
              pMCVar->dKernelSD = DBL_MIN;
          }
          else { /* more normal case */
            /* the kernel should not be infinitely decreased; decrease
               is otherwise slighly different from the increase to avoid
               oscillations */
            if (pMCVar->dKernelSD > DBL_MIN / 0.4)
              pMCVar->dKernelSD = pMCVar->dKernelSD * 0.4;
            else
              pMCVar->dKernelSD = DBL_MIN;
          }
        }

        pMCVar->lJumps = 0; /* reset the jumps counter */

      }

      /* sample a new value */

      /* at first update the kernelSD according to the temperature */

      /* save the current kernelSD */
      old_dKernelSD =  pMCVar->dKernelSD;

      /* update the kernelSD according to the temperature */
      if (dInvTemper(*pindexT) != 0)
        pMCVar->dKernelSD = pMCVar->dKernelSD / dInvTemper(*pindexT);
      else
        pMCVar->dKernelSD = 0.5*(MaxMCVar(pMCVar)-MinMCVar(pMCVar));

      pMCVar->dVal = SampleTheta (pMCVar);

      /* recompute prior and likelihood */
      dLnPriorNew = LnDensity (pMCVar, panal);
      dLnLikeNew = LnLike (pMCVar, panal);

      dLnDataNew = 0.0;

      /* If data are dependent compute the data likelihood */
      if (pMCVar->bExptIsDep) {
        /* Run all experiments beneath this level.
           We should in fact run only the dependent experiments ! */
        if (!TraverseLevels1 (plevel, RunExpt, panal, &dLnDataNew, NULL)) {
          /* If running experiments fails, do not jump */
          pMCVar->dVal = dTheta;
          TraverseLevels1 (plevel, RestoreLikelihoods, NULL);
          goto WriteIt;
        }
      }

      /* Test the results and act accordingly */
      if (!Test1 (pMCVar->bExptIsDep,  dLnPrior, dLnPriorNew, dLnLike,
                 dLnLikeNew, dLnData, dLnDataNew, *pindexT)) {
        pMCVar->dVal = dTheta;

        if(pMCVar->bExptIsDep)
          TraverseLevels1 (plevel, RestoreLikelihoods, NULL);
      }
      else {
        pMCVar->lJumps = pMCVar->lJumps + 1;
        if(pMCVar->bExptIsDep)
          TraverseLevels1 (plevel, SaveLikelihoods, NULL);
      }

      /* restore kernelSD */
      pMCVar->dKernelSD = old_dKernelSD;

WriteIt: /* Write the MC var value to output file  */

    if (((*pnIter+1) % pgd->nPrintFreq == 0) &&
        (*pnIter >= pgd->nMaxIter - pgd->nPrintIter)) {
      fprintf(pgd->pfileOut, "%5g\t", pMCVar->dVal);
    }
  }  /*  (Metrolopolis-Hastings */

} /* SampleThetasTempered */



/* Function -------------------------------------------------------------------
   SampleThetaVector

   Sample thetas in block, do Metropolis test, write the sampled values to
   the output file
*/

void SampleThetaVector (PLEVEL pLevel, PANALYSIS panal, long nThetas,
                        double *pdTheta, double *pdSum, double **prgdSumProd,
                        long iter, long nUpdateAt, long nTotal,
                        PDOUBLE pdLnPrior, PDOUBLE pdLnData)
{
  register long i, j;
  double dTmp, dAccept, dLnPrior_old, dLnData_old;

  static long lAccepted = 0;
  static double dJumpSpread;
  static PDOUBLE pdTheta_old = NULL; /* previous model parameters values */
  static PDOUBLE *prgdComponent;
  static PDOUBLE *prgdVariance;
  static PDOUBLE dNormVar; /* storage for nParms normal deviates */

  if ((pdTheta_old == NULL) || (iter == nUpdateAt)) {

    if (pdTheta_old == NULL) { /* initialize */
      if ( !(pdTheta_old = InitdVector (nThetas)) ||
           !(dNormVar    = InitdVector (nThetas)) ||
           !(prgdVariance  = InitdMatrix (nThetas, nThetas)) ||
           !(prgdComponent = InitdMatrix (nThetas, nThetas)))
        ReportRunTimeError (panal, RE_OUTOFMEM | RE_FATAL,
                            "SampleThetaVector");

      /* initialize dJumpSpread */
      dJumpSpread = 2.4 / sqrt(nThetas); /* Gelman's Normal theory result */
    }
    else {
      /* done if iter == nUpdateAt, but not at start:
         if some vector samplings have been made, check that the current
         dJumpSpread leads to an acceptation rate of 15 to 30% over the
         last batch of simulations. Adjust eventually. */
      dAccept = ((double) lAccepted) / (double) (nTotal);

      if ( dAccept > 0.3) dJumpSpread = dJumpSpread * 1.5;
      else if (dAccept < 0.15) dJumpSpread = dJumpSpread * 0.7;

      printf ("Monitoring: iter\t%ld\t", iter);
      printf ("success rate\t%g\tspread\t%g\n", dAccept, dJumpSpread);
      lAccepted = 0; /* reset the counter */
    }

    /* other updates: */

    /* generate the covariance matrix */
    for (i = 0; i < nThetas; i++)
      for (j = 0; j < nThetas; j++)
        prgdVariance[i][j] = (prgdSumProd[i][j] -
                              pdSum[i] * pdSum[j] / (double) (iter+1)) /
                             (double) iter;

    /* do the Cholesky decomposition of the covariance matrix */
    if (!Cholesky (prgdVariance, prgdComponent, nThetas)) {
      /* try to save the computation by zeroing all non-diagonal elements */
      for (i = 0; i < nThetas; i++)
        for (j = 0; j < nThetas; j++) {
                if (i == j)
            prgdVariance[i][j] = prgdSumProd[i][j] / (double) (iter);
          else
            prgdVariance[i][j] = 0.0;
        }

        /* if is still does not work, exit */
      if (!Cholesky (prgdVariance, prgdComponent, nThetas)) {
        printf ("Error: impossible to compute a jumping kernel - Exiting."
                "(You should check or change the restart file).\n\n");
        exit (0);
      }
    }
  }

  /* keep the value of all thetas */
  for (i = 0; i < nThetas; i++)
    pdTheta_old[i] = pdTheta[i];

  /* keep old prior and old likelihood */
  dLnPrior_old = *pdLnPrior;
  dLnData_old  = *pdLnData;

  /* generate new pdTheta vector in the range of each element */
  do {
    for (i = 0; i < nThetas; i++) dNormVar[i] = NormalRandom(0.0, 1.0);

    for (i = 0; i < nThetas; i++) {
      dTmp = 0;
      for (j = 0; j <= i; j++) /* only the non-zero part of prgdComponent */
        dTmp = dTmp + dNormVar[j] * prgdComponent[i][j];

      pdTheta[i] = pdTheta_old[i] + dJumpSpread * dTmp;
    }

    /* Set the dVals of the variables to the values sampled and check that
       we are within bounds as a while condition */
    nThetas = 0;
  } while (!TraverseLevels1 (pLevel, SetMCVars, pdTheta, &nThetas, NULL));

  /* Calculate the new prior */
  *pdLnPrior = 0.0;
  TraverseLevels (pLevel, CalculateTotals, panal, pdLnPrior, NULL);

  /* compute the model at the newly drawn point and the likelihood */
  *pdLnData = 0.0;
  if (!RunAllExpts (panal, pdLnData)) {
    /* computation failed, don't jump, restore */
    for (i = 0; i < nThetas; i++)
      pdTheta[i] = pdTheta_old[i];
    *pdLnPrior = dLnPrior_old;
    *pdLnData  = dLnData_old;
  }
  else {
    /* Test */
    if (log(Randoms()) >
        ((*pdLnPrior) + (*pdLnData) - dLnPrior_old - dLnData_old)) {
      /* don't jump, restore */
      for (i = 0; i < nThetas; i++)
        pdTheta[i] = pdTheta_old[i];
      *pdLnPrior = dLnPrior_old;
      *pdLnData  = dLnData_old;
    }
    else { /* jump */
      lAccepted++; /* this is used above to adjust the acceptation rate */
    }
  }

  /* update arrays */
  for (i = 0; i < nThetas; i++) {
    pdSum[i] = pdSum[i] + pdTheta[i];
    for (j = 0; j < nThetas; j++)
      prgdSumProd[i][j] = prgdSumProd[i][j] + pdTheta[i] * pdTheta[j];
  }


} /* SampleThetaVector */


/* Function -------------------------------------------------------------------
   SaveLikelihoods

   Called from TraverseLevels1
*/

int SaveLikelihoods (PLEVEL plevel, char **args)
{
  PEXPERIMENT pExpt = plevel->pexpt;

  if (pExpt != NULL) {
    pExpt->dLnLikeSave = pExpt->dLnLike;
  }

  return (1);

} /* SaveLikelihoods */


/* Function -------------------------------------------------------------------
   SetFixedVars

   Set the array of fixed variables
*/

void SetFixedVars (PLEVEL plevel)
{
  long n;
  PVARMOD pFVar;

  for (n = 0; n < plevel->nFixedVars; n++) {
    pFVar = plevel->rgpFixedVars[n];
    if (IsInput (pFVar->hvar))
      SetInput (pFVar->hvar, pFVar->uvar.pifn);
    else
      SetVar (pFVar->hvar, pFVar->uvar.dVal);
  }

} /* SetFixedVars */


/* Function -------------------------------------------------------------------
   SetKernel

   Set initial values of the MCMC jumping kernel
*/

void SetKernel (PLEVEL plevel, char **args)
{
  long useMCVarVals = (long) args[0]; /* 1 if dVal is to be restored, else 2 */
  double *pdMCVarVals = (double *) args[1];
  double dMin, dMax, dTmp;
  long   n, m;
  static long nThetas;
  PMCVAR pMCVar;

  /* set the jumping kernel's SD: sample 4 variates and take the range */
  for (n = 0; n < plevel->nMCVars; n++) {

    if ( !(plevel->rgpMCVars[n]->bIsFixed)) {

      pMCVar = plevel->rgpMCVars[n];
      CalculateOneMCParm (pMCVar);

      dMin = dMax = pMCVar->dVal;
      for (m = 0; m < 3; m++) {
        CalculateOneMCParm (pMCVar);
        dTmp = pMCVar->dVal;
        if (dMin >= dTmp) dMin = dTmp;
        else if (dMax < dTmp) dMax = dTmp;
      }

      /* The range can be at most 2 DBL_MAX, so we halve it in that case
         to never exceed computational bounds, and we never form the
         dangerous complete range */
      if ((*(pMCVar->pdParm[2]) == -DBL_MAX) ||
          (*(pMCVar->pdParm[3]) == DBL_MAX))
        pMCVar->dKernelSD = (0.5 * dMax) - (0.5 * dMin);
      else
        pMCVar->dKernelSD = dMax - dMin;

      /* but if the range is zero (can happens for discrete variables, then
         set it to half the prior range - FB 12/06/97 */
      if (pMCVar->dKernelSD == 0) {
        if ((*(pMCVar->pdParm[2]) == -DBL_MAX) ||
            (*(pMCVar->pdParm[3]) == DBL_MAX))
          pMCVar->dKernelSD = (0.5 * *(pMCVar->pdParm[3]) -
                               0.5 * *(pMCVar->pdParm[2]));
        else
          pMCVar->dKernelSD = *(pMCVar->pdParm[3]) - *(pMCVar->pdParm[2]);
      }
    }

    /* restore the value of the variable - FB 02/07/97 */
    if (useMCVarVals == 1)
      plevel->rgpMCVars[n]->dVal = pdMCVarVals[nThetas++];

  }

} /* SetKernel */


/* Function -------------------------------------------------------------------
   SetModelVars

   Sets the array of model variables to the sampled values. Does not set fixed
   variables. That has to be done by SetFixedVars.
*/

void SetModelVars(PLEVEL plevel)
{
  long n;
  PMCVAR  pMCVar;

  for (n = 0; n < plevel->nMCVars; n++) {
    pMCVar = plevel->rgpMCVars[n];
    if (!(pMCVar->bIsFixed) && (IsParm (pMCVar->hvar)))
      SetVar (pMCVar->hvar, pMCVar->dVal);
  }

} /* SetModelVars */


/* Function -------------------------------------------------------------------
   SetMCVars

   Set initial values of thetas after reading input file or sampling them.
   Values are assumed to be in proper order.
   It also checks that the ranges are respected.
   Called from TraverseLevels.
*/

int SetMCVars (PLEVEL plevel, char **args)
{
  double *pdMCVarVals = (double *) args[0];
  long   *nThetas = (long *) args[1];
  PMCVAR pMCVar;
  double dVar;
  long   n;

  for (n = 0; n < plevel->nMCVars; n++) {
    dVar = pdMCVarVals[(*nThetas)++];
    pMCVar = plevel->rgpMCVars[n];
    if ((pMCVar->iType == MCV_UNIFORM) || (pMCVar->iType == MCV_LOGUNIFORM)) {
      if ((dVar < *(pMCVar->pdParm[0])) || (dVar > *(pMCVar->pdParm[1]))) {
        /* error */
        return (0);
      }
    }
    else {
      if ((dVar < *(pMCVar->pdParm[2])) || (dVar > *(pMCVar->pdParm[3]))) {
        /* error */
        return (0);
      }
    }

    pMCVar->dVal = dVar;
  }

  /* success */
  return (1);

} /* SetMCVars */


/* Function -------------------------------------------------------------------
   SetPointers

   Called from TraverseLevels

   FB 26 nov 96: For each Monte Carlo variable, pdParms are set to point to the
   parent's dVals rather than to model parameters. If there is no parent,
   pdParms point to their own dParms.
   The pdVals and pdParms of the data and output arrays are also set.
*/

void SetPointers (PLEVEL plevel, char **args)
{
  long i, j, k;
  PMCVAR pMCVar;
  POUTSPEC pos;
  BOOL bFound;

  for (i = 0; i < plevel->nMCVars; i++) { /* for parameters */
    pMCVar = plevel->rgpMCVars[i];

    /* For each distribution parameter */
    for (j = 0; j < 4; j++) {
      if (pMCVar->pMCVParent[j] == NULL) /* Point to its own values */
        pMCVar->pdParm[j] = &(pMCVar->dParm[j]);
      else /* Point to the parent dVal */
        pMCVar->pdParm[j] = &(pMCVar->pMCVParent[j]->dVal);
    }
  }

  if (plevel->pexpt != NULL) /* if the level has experiments */
  for (i = 0; i < plevel->nLikes; i++) { /* for likelihoods */
    pMCVar = plevel->rgpLikes[i];
    pos = &(plevel->pexpt->os);

    /* Set pdVal of pMCVar to a data array, first find it */
    bFound = FALSE;
    j = 0;
    while ((j < pos->nData) && (!bFound)) {
      bFound = (pMCVar->hvar == pos->phvar_dat[j]);
      if (!bFound) j++;
    }
    if (bFound) {
      pMCVar->pdVal = pos->prgdDataVals[j];
      pMCVar->lCount = pos->pcData[j]; /* number of data points */
    }
    else { /* no corresponding Data found: error */
      printf ("Error: no Data for %s in Simulation %d - Exiting.\n\n",
              pMCVar->pszName, plevel->pexpt->iExp);
      exit (0);
    }

    /* we also have to set the pdParms of pMCVar to either data or output
       arrays */
    for (j = 0; j < 4; j++) {

      if (pMCVar->iParmType[j] == MCVP_PRED) { /* it's an output */
        /* set pdParm[j] to an output, first find it */
        bFound = FALSE;
        k = 0;
        while ((k < pos->nOutputs) && (!bFound)) {
          bFound = (pMCVar->hParm[j] == pos->phvar_out[k]);
          if (!bFound) k++;
        }
        if (bFound) {
          pMCVar->pdParm[j] = &(pos->prgdOutputVals[k][0]);
        }
        else { /* no corresponding Print statement found: error */
          printf ("Error: missing Print statement for parameter number %ld\n"
                  "of %s distribution - Exiting.\n\n", j, pMCVar->pszName);
          exit (0);
        }
      } /* end if MCVP_PRED */

      else if (pMCVar->iParmType[j] == MCVP_DATA) { /* it's data */
        /* set pdParm[j] to a data array, first find it */
        bFound = FALSE;
        k = 0;
        while ((k < pos->nData) && (!bFound)) {
          bFound = (pMCVar->hParm[j] == pos->phvar_dat[k]);
          if (!bFound) k++;
        }
        if (bFound) {
          pMCVar->pdParm[j] = &(pos->prgdDataVals[k][0]);
        }
        else { /* no Data found: error */
          printf ("Error: no Data for %s in Simulation %d - Exiting.\n\n",
                  pMCVar->pszName, plevel->pexpt->iExp);
          exit (0);
        }
      } /* end if MCVP_DATA */

      else { /* it's either a parameter or a numeric */
        if (pMCVar->pMCVParent[j] == NULL) /* Point to its own values */
          pMCVar->pdParm[j] = &(pMCVar->dParm[j]);
        else /* Point to the parent dVal */
          pMCVar->pdParm[j] = &(pMCVar->pMCVParent[j]->dVal);
      }
    } /* end for j */
  }

} /* SetPointers */


/* Function -------------------------------------------------------------------
   SumAllExpts

   If `plevel' has experiments, add the current Likelihood to the total
   passed as argument 2.

   Called from TraverseLevels1
*/

int SumAllExpts (PLEVEL plevel, char **args)
{
  double      *pdLnData = (double*)args[0];
  PEXPERIMENT pExpt = plevel->pexpt;

  if (pExpt != NULL) {
    *pdLnData += pExpt->dLnLike;
  }
  return (1);

} /* SumAllExpts */

/* Function -----------------------------------------------------------------
   Temper_probabilities

  set the temperature transition probabilities
 */

  double Temper_probabilities(long i, long j)
{
  if (( i == 0 && j == 1) || (i == NTEMP-1 && j == NTEMP-2)) return(1);
  else return(0.5);

} /* Temper_probabilities */



/* Function -------------------------------------------------------------------
   Test

   Test prior, likelihood against random number between 0 and 1
*/

BOOL Test (BOOL bExptIsDep, double dLnPrior, double dLnPriorNew,
           double dLnLike, double dLnLikeNew,
           double dLnData, double dLnDataNew)
{
  double dPjump;

  if (dLnPriorNew == NULL_SUPPORT ||
      dLnLikeNew  == NULL_SUPPORT ||
      dLnDataNew  == NULL_SUPPORT)
    return FALSE;

  dPjump = dLnPriorNew - dLnPrior + dLnLikeNew - dLnLike;

  if (bExptIsDep)
    dPjump += dLnDataNew - dLnData;

  return ((BOOL) (log(Randoms()) <= dPjump));

} /* Test */

/* Function -------------------------------------------------------------------
   Test1

   Test prior, likelihood against random number between 0 and 1 according to 
   the temperature
*/

BOOL Test1 (BOOL bExptIsDep, double dLnPrior, double dLnPriorNew,
           double dLnLike, double dLnLikeNew,
           double dLnData, double dLnDataNew, long indexT)
{
  double dPjump;

  if (dLnPriorNew == NULL_SUPPORT ||
      dLnLikeNew  == NULL_SUPPORT ||
      dLnDataNew  == NULL_SUPPORT)
    return FALSE;

  dPjump = dInvTemper(indexT) * 
           (dLnPriorNew - dLnPrior + dLnLikeNew - dLnLike);

  if (bExptIsDep)
    dPjump += dInvTemper(indexT) *(dLnDataNew - dLnData);

  return ((BOOL) (log(Randoms()) <= dPjump));

} /* Test1 */


/* Function -------------------------------------------------------------------
   Test2

   Test temperature against random number between 0 and 1
*/

BOOL Test2 (long indexT, long indexT_new, double dLnPrior, double dLnData,
            long attemptedTempe, double pseudo, double pseudonew)
{
  double dPjump=0;

  if (dLnPrior + dLnData == NULL_SUPPORT )
    return FALSE;

  dPjump = (dInvTemper(indexT_new) - dInvTemper(indexT))*(dLnPrior + dLnData) +
           pseudonew - pseudo + log(Temper_probabilities(indexT_new, indexT)) -
           log(Temper_probabilities(indexT, indexT_new));

  return ((BOOL) (log(Randoms()) <= dPjump));

} /* Test2 */



/* Function -------------------------------------------------------------------
   TraverseLevels (recursive)

   Called with variable argument list ending in NULL;
   arguments should be pointers only; if you call this with a value
   that can be zero, you will be very sorry

   Find all allocated levels, execute `routinePtr' for each, starting at the
   top, passing the argument list as char**

   The argument list is saved from the initial call; on recursive calls the
   list is NULL
*/

void TraverseLevels (PLEVEL plevel,
                     void (*routinePtr)(PLEVEL plevel, char **args), ...)
{
  va_list ap;
  static char *arg[MAX_ARGS], **args = arg;
  char *arg1;
  long n, nargs = 0;

  va_start(ap, routinePtr);
  if ((arg1 = va_arg (ap, char*)) != NULL) {
    arg[0] = arg1;
    while ((arg[++nargs] = va_arg(ap, char*)) != NULL) {};
  }
  va_end (ap);

  routinePtr (plevel, args);

  for (n = 0; n < plevel->iInstances; n++)
    TraverseLevels (plevel->pLevels[n], routinePtr, NULL);

} /* TraverseLevels */


int TraverseLevels1 (PLEVEL plevel,
                     int (*routinePtr)(PLEVEL plevel, char **args), ...)
{
  va_list ap;
  static char *arg[MAX_ARGS], **args = arg;
  char *arg1;
  long n, nargs = 0;

  va_start (ap, routinePtr);
  if ((arg1 = va_arg (ap, char*)) != NULL) {
    arg[0] = arg1;
    while ((arg[++nargs] = va_arg(ap, char*)) != NULL) {};
  }
  va_end (ap);

  if (routinePtr (plevel, args)) {

    for (n = 0; n < plevel->iInstances; n++) {
      if (!TraverseLevels1(plevel->pLevels[n], routinePtr, NULL)) {
        /* error */
        return (0);
      }
    }
  }
  else /* error */
    return (0);

  /* success */
  return (1);

} /* TraverseLevels1 */


/* Function -------------------------------------------------------------------
   WriteHeader

   Called from Traverse Levels
   Write the names of the sampled parameters to output file header
*/

void WriteHeader (PLEVEL plevel, char **args)
{
  PANALYSIS panal = (PANALYSIS)args[0];
  FILE *outFile = (FILE*)args[1];
  long n, m;

  panal->iInstance[plevel->iDepth] = plevel->iSequence;

  for (n = 0; n < plevel->nMCVars; n++) {
    fprintf (outFile, "%s(", plevel->rgpMCVars[n]->pszName);
    for (m = 1; m < plevel->iDepth; m++)
      fprintf (outFile, "%d.", panal->iInstance[m]);
    fprintf (outFile, "%d)\t", panal->iInstance[plevel->iDepth]);
  }

} /* WriteHeader */


/* Function -------------------------------------------------------------------

   WriteMCVars

   Write the values of MC vars for one level to output file
*/

void WriteMCVars (PLEVEL plevel, PFILE pOutFile)
{
  long n;
  PMCVAR pMCVar;

  for (n = 0; n < plevel->nMCVars; n++) {
    pMCVar = plevel->rgpMCVars[n];
    fprintf(pOutFile, "%5g\t", pMCVar->dVal);
  }

} /* WriteMCVars */
