/* mh.c

   written by Frederic Bois
   5 January 1996

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

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

*/

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

#include "mh.h"
#include "lsodes.h"
#include "lexerr.h"
#include "simmonte.h"


/* 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];

  int 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;
   this routine marks such vars
   Called from TraverseLevels
*/

void CheckForFixed (PLEVEL plevel, char **args)
{
  int     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

   Consider statements of type 'Distrib(<var1>, <distrib>, Prediction, <var2>)'
   If var1 and var2 do not have identical 'Print' times, we cannot obtain
   the data likelihood for var1. Here we check these times.
   We also check for two print statements for the same variable, which can
   affect the output under some circumstances.
   Called from TraverseLevels
*/

void CheckPrintStatements (PLEVEL plevel, char **args)
{
  PANALYSIS panal = (PANALYSIS)args[0];
  POUTSPEC pos;
  PMCVAR pMCVar;
  int n, m, VarIndex = 0, SDIndex;

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

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

  for (n = 0; n < pos->nOutputs; ++n)
    for (m = n+1; m < pos->nOutputs; ++m)
      if (pos->phvar[n] == pos->phvar[m])
        ReportRunTimeError 
          (panal, RE_DUPVARINPRINT | RE_FATAL, "CheckPrintStatements");

  for (n = 0; n < panal->nModelVars; ++n) {
    pMCVar = panal->rgpModelVars[n];

    if ((pMCVar->cVarParm >> 1 & MCVP_VARIABLE) &&
        IsModelVar(pMCVar->hParm[1])) {
      SDIndex = -1;

      for (m = 0; m < pos->nOutputs; ++m) {
        if (pMCVar->hvar == pos->phvar[m])
          VarIndex = m;
        if (pMCVar->hParm[1] == pos->phvar[m])
          SDIndex = m;
      }

      if (SDIndex == -1)
        ReportRunTimeError
          (panal, RE_NOPRINTSTATEMENT | RE_FATAL, "CheckPrintStatements");

      if (pos->pcOutputTimes[VarIndex] != pos->pcOutputTimes[SDIndex])
        ReportRunTimeError
          (panal, RE_UNEQUALNUMTIMES | RE_FATAL, "CheckPrintStatements");

      for (m = 0; m < pos->pcOutputTimes[VarIndex]; ++m)
        if (pos->prgdOutputTimes[VarIndex][m] !=
            pos->prgdOutputTimes[SDIndex][m])
          ReportRunTimeError
              (panal, RE_UNEQUALTIMES | RE_FATAL, "CheckPrintStatements");

      pMCVar->iParmIndex = SDIndex;
    }
  }

} /* CheckPrintStatements */


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

   Called from TraverseLevels
   For all MC vars in list at given level, add to arrays of all instances of
   next (lower) level
*/

void CloneMCVars (PLEVEL plevel, char **args)
{
  int nMCVars = ListLength(plevel->plistMCVars);
  int n;
  PLEVEL pLower;

  for (n = 0; n < plevel->iInstances; ++n) {
    pLower = plevel->pLevels[n];
    pLower->nMCVars = nMCVars;
    pLower->rgpMCVars = (PMCVAR*) malloc (nMCVars * sizeof(PMCVAR));
  }

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

} /* CloneMCVars */


void CloneMCVarsL (PVOID pData, PVOID pUser1, PVOID pUser2, PVOID pUser3)
{
  PMCVAR pMCVar = (PMCVAR)pData;
  PLEVEL plevel = (PLEVEL)pUser1;
  int *pnMCVars = (int*)pUser2;
  int n;
  PLEVEL pLower;
  PMCVAR pClone;

  ++pMCVar->iDepth;
  for (n = 0; n < plevel->iInstances; ++n) {
    pLower = plevel->pLevels[n];
    pClone = (PMCVAR) malloc (sizeof (MCVAR));
    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.pfileGibOut) {
    fclose (panal->gd.pfileGibOut);
    printf ("\nWrote results to \"%s\"\n", panal->gd.szGout);
  }

} /* CloseMarkovFiles */


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

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

  ListToPMCArray (panal, panal->plistModelVars,
                  &panal->nModelVars, &panal->rgpModelVars);

  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 (pMCVar->nDependents == 0)
      pMCVar->bExptIsDep = TRUE;
  }
    

} /*ConvertMCLists */


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

   Core routine of the MCMC sampler
*/

void DoMarkov (PANALYSIS panal)
{
  PGIBBSDATA pgd = &panal->gd;
  PLEVEL     pLevel0 = panal->pLevels[0];
  int        nThetas, nUpdateAt;
  long       iter = 0;
  long       nIter = pgd->nMaxIter; /* scheduled iterations of the sampler */
  double     *pdMCVarVals;          /* initial values of thetas */
  double     dLnPrior = 0, dLnData = 0;

  InitRandom (panal->dSeed, TRUE);

  printf ("\nDoing analysis - %ld %s iteration%s\n",
          nIter, "MCMC sampling", (nIter != 1 ? "s " : " "));

  OpenMarkovFiles (panal);

  /* we do not want more than 1 top level; Get out; 
     This should 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);

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

  /* Now that we have the MC vars right, write the output file header */
  fprintf (pgd->pfileGibOut, "iter\t");
  TraverseLevels (pLevel0, WriteHeader, panal, pgd->pfileGibOut, NULL);
  fprintf (pgd->pfileGibOut,
           "LnPrior\tLnData\tLnPosterior\n");
  fflush (pgd->pfileGibOut);

  /* 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);
	  exit(0);
  }

  /* 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 */
  if (pgd->szGrestart) { 

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

    if ((pdMCVarVals = (double*) malloc (nThetas * sizeof (double))) == NULL)
      ReportRunTimeError (panal, RE_OUTOFMEM | RE_FATAL, "DoMarkov");

    /* Read the starting values in the order they are printed and
       close the file when finished */
    ReadRestart (pgd->pfileRestart, nThetas, pdMCVarVals, &iter);
    nThetas = 0;
    TraverseLevels (pLevel0, SetMCVars, &nThetas, pdMCVarVals, NULL);

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

    /* The MCVars have been altered by SetKernel, reset them */
    nThetas = 0;
    TraverseLevels (pLevel0, SetMCVars, &nThetas, pdMCVarVals, NULL);
    free (pdMCVarVals);

    /* Initilalize the predictions arrays by running all experiments and
       save the output */
    RunAllExpts (pLevel0, 0, panal, &dLnData);
  }

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

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

    /* Output log-densities */
    TraverseLevels(pLevel0, CalculateTotals, panal, &dLnPrior, NULL);
    /* Initilalize the predictions arrays by running all experiments and
       save the data likelihood output */
    RunAllExpts(pLevel0, 0, panal, &dLnData);

    fprintf (pgd->pfileGibOut, "%e\t%e\t%e\n", dLnPrior, dLnData,
             dLnPrior + dLnData);
    fflush (pgd->pfileGibOut);
  }

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

  /* Initializations are finished, let's do the iterations */
  nUpdateAt = UPDATE_AT;

  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->pfileGibOut, "%ld\t", iter + 1);

    TraverseLevels (pLevel0, SampleThetas, panal, pgd, &iter, &nUpdateAt, 
                    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->pfileGibOut, "%e\t%e\t%e\n", dLnPrior, dLnData,
               dLnPrior + dLnData);
      fflush (pgd->pfileGibOut);
    }

    /* Adjust the update time eventually */
    if ((iter % nUpdateAt == 0) && (iter > 0))
      nUpdateAt = nUpdateAt * 1.5;

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

  } /* while iter */

  CloseMarkovFiles (panal);

} /* DoMarkov */


/* 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];
  int       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];
    for (m = 0; m < n; ++m) {
      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->nMCVars; ++m) {
      pMCVar1 = plevel->rgpMCVars[m];
      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;
          }
        }
      }
    }
  }

} /* FindMCParents */


/* 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)
{
  int n, m;

  for (n = 0; n < plevel->nMCVars; ++n)
    for (m = 0; m < 4; ++m)
      if (plevel->rgpMCVars[n]->pMCVParent[m] != NULL &&
          plevel->rgpMCVars[n]->pMCVParent[m]->hvar == 
          plevel->rgpMCVars[n]->hParm[m])
        QueueListItem(plevel->rgpMCVars[n]->pMCVParent[m]->plistDependents,
                      plevel->rgpMCVars[n]);

} /*FindMCDependents */


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

   Find the total number of MC vars
   Called from TraverseLevels
*/
void GetNumberOfMCVars (PLEVEL plevel, char **args) 
{
  int *pnThetas = (int*) 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)
{
  PANALYSIS panal = (PANALYSIS)args[0];
  FILE      *pOutFile = (FILE*)args[1];
  int       n;

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

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

} /* InitMCVars */

#ifdef ndef
/* Function -------------------------------------------------------------------
   L2

   Sum of squares for one experiment
*/

double L2 (PEXPERIMENT pexpt, PANALYSIS panal) 
{
  POUTSPEC pos;
  PMCVAR pMCVar;
  int n, m, l;
  double x = dSS = 0.0;

  pos = &pexpt->os;
  for(n = 0; n < panal->nModelVars; ++n) {
    if(!IsOutput((pMCVar = panal->rgpModelVars[n])->hvar))
      continue;
    for(m = 0; m < pos->nOutputs; ++m) {
      if(pos->phvar[m] == pMCVar->hvar) {
        for(l = 0; l < pos->pcOutputTimes[m]; ++l) {
          if(pos->prgdOutputVals[m][l] != MISSING_VALUE) {
            x = pos->prgdDataVals[m][l] - pos->prgdOutputVals[m][l];
            x *= x;
            dSS += x;
          }
          else
            dSS += BAD_VAL;
        }
      }
    }
  }
  return (dSS);

} /* L2 */
#endif

/* 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))) == NULL)
    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))) == 
       NULL)
    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 (MCVAR *pMCVar, PANALYSIS panal)
{
  double dTmp, 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 (dTheta > dMax || dTheta < dMin)
    return (BAD_VAL);

  switch (pMCVar->iType) {

    case MCV_UNIFORM:
      if (dMax <= dMin)
        ReportRunTimeError (panal, RE_BADUNIFORMDIST | RE_FATAL,
                            pMCVar->pszName, "LnDensity");
      return -log(dMax - dMin);

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

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

    case MCV_LOGNORMALV: dParm2 = exp(sqrt(log(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));

    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) / 
             (CDFNormal ((dMax - dParm1) / dParm2) - 
              CDFNormal ((dMin - dParm1) / dParm2));

    case MCV_TRUNCLOGNORMALV: dParm2 = exp(sqrt(log(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) /
             (CDFNormal (log (dMax / dParm1) / dTmp) - 
              CDFNormal (log (dMin / dParm1) / dTmp));

    case MCV_BETA:
      if (dMax <= dMin) {
        printf ("Error: bad range for beta variate in LnDensity\n");
        exit (0);
      }
      return (dParm1 - 1) * log (dTheta) +
             (dParm2 - 1) * log (1 - dTheta) +
             lnGamma (dParm1 + dParm2) -
             lnGamma (dParm1) - lnGamma(dParm2) - log (dMax - dMin);

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

    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: bad scale for exponential variate in LnDensity\n");
        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_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);

    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);


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

  } /* switch */

  /* Not reached */
  return 0.0 ;

} /* LnDensity */


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

   returns the log-likelihood of a parameter
*/

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

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

  return dLnLike;
  
} /* LnLike */


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

   Likelihood of the data for one experiment
*/

double LnLikeData (PEXPERIMENT pexpt, PANALYSIS panal) {

  POUTSPEC pos;
  PMCVAR pMCVar;
  int n, m, l;
  double dLnLike = 0.0;

  pos = &pexpt->os;
  for (n = 0; n < panal->nModelVars; ++n) {
    pMCVar = panal->rgpModelVars[n];

    for (m = 0; m < pos->nOutputs; ++m) {
      if (pos->phvar[m] == pMCVar->hvar) {
        for (l = 0; l < pos->pcOutputTimes[m]; ++l) {
          if (pos->prgdOutputVals[m][l] != MISSING_VALUE) {

            pMCVar->dVal = pos->prgdDataVals[m][l];
            pMCVar->dParm[0] = pos->prgdOutputVals[m][l];

            /* This finds the SD to use */
            if (pMCVar->cVarParm >> 1 & MCVP_VARIABLE) 
              if (!IsModelVar (pMCVar->hParm[1])) {
                pMCVar->dParm[1] = GetVarValue (pMCVar->hParm[1]);
                /* This is not very clean and the dVal of a MCVar structure
                   should be used instead */
              }
              else
                pMCVar->dParm[1] = pos->prgdOutputVals[pMCVar->iParmIndex][l];
            
            dLnLike += LnDensity (pMCVar, panal);
          }
          else
            ReportRunTimeError (panal, RE_BADMODEL | RE_FATAL, "LnLikeData");
        }
      }
    }
  }
  return (dLnLike);

} /* LnLikeData */


/* 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->expGlobal.os.bCommandLineSpec)
    panal->gd.szGout = panal->expGlobal.os.szOutfilename;

  /* Default if none given */
  else if (!(panal->gd.szGout))
    panal->gd.szGout = "simgb.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.pfileGibOut)
      && !(panal->gd.pfileGibOut = fopen (panal->gd.szGout, "w")))
    ReportRunTimeError(panal, RE_FATAL | RE_CANNOTOPEN,
                       panal->gd.szGout, "OpenMarkovFiles");

} /* OpenMarkovFiles */


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

   Called from TraverseLevels

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

void PrintDeps (PLEVEL plevel, char **args)
{
  int 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) [%x]\n",
            pMCVar->pszName, pMCVar->iDepth, (unsigned int) pMCVar);

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

    for (m = 0; m < pMCVar->nDependents; ++m)
      fprintf (stderr, "  Dependent: %s (%d) [%x]\n",
               pMCVar->rgpDependents[m]->pszName,
               pMCVar->rgpDependents[m]->iDepth, 
               (unsigned int) 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, long *pIter) 
{
  int n;
  long lDummy;

  *pIter = -1;

  /* 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 and sigmas, they keep only their
     last value. We also keep incrementing the global iteration counter
     iter:
   */
  while (!(feof (pfileRestart) ||
          (fscanf (pfileRestart, "%ld", &lDummy) == EOF))) {
    for (n = 0; n < nThetas; ++n) {
      if (fscanf(pfileRestart, "%lg", &(pdTheta[n])) == 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);

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

  } /* end while */

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

  fclose (pfileRestart);

} /* ReadRestart */


/* 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 at level below `plevel'

Do we need this one really ? Who calls it ?

*/

void RunAllExpts (PLEVEL plevel, int nVar, PANALYSIS panal, double *pdLnData)
{
  int n;

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

} /* RunAllExpts */


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

   If `plevel' has no experiments, modify the variables using its two
   lists; if it has experiments, run them. Return 1 on success and 0 if
   failure

   Called from TraverseLevels1
*/

int RunExpt (PLEVEL plevel, char **args)
{
  PANALYSIS   panal = (PANALYSIS)args[0];
  double      *pdLnData = (double*)args[1];
  int         n;
  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 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 {
      pExpt->dLnLike = LnLikeData (pExpt, panal);
      *pdLnData += pExpt->dLnLike;
    }

  } /* if */

  return (1);

} /* RunExpt */


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

double SampleTheta (PMCVAR pMCVar) {

  double dMin = *(pMCVar->pdParm[2]);
  double dMax = *(pMCVar->pdParm[3]);
  double dpropSD;

  if (pMCVar->iType == MCV_LOGNORMAL || 
      pMCVar->iType == MCV_TRUNCLOGNORMAL ||
      pMCVar->iType == MCV_LOGUNIFORM)
    dpropSD = /* log */ (pMCVar->dKernelSD);
  else
    dpropSD = pMCVar->dKernelSD;

  return TruncNormalRandom (pMCVar->dVal, dpropSD, dMin, dMax);

} /* SampleTheta */


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

   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];
  int    *pnUpdateAt = (int*)args[3];

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

  /* 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 */
    if ((*pnIter % *pnUpdateAt == 0) && (*pnIter > 0)) {
      if ((dJumps = (double) pMCVar->lJumps / (double) *pnUpdateAt) > 0.3)
        pMCVar->dKernelSD = pMCVar->dKernelSD * 2;
      else 
        if ((dJumps < 0.15) && (pMCVar->dKernelSD < (DBL_MAX / 2)))
          pMCVar->dKernelSD = pMCVar->dKernelSD * 0.5;

      pMCVar->lJumps = 0;
    }

    /* 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, *pnIter, pgd->nInitIter,
               dLnPrior, dLnPriorNew, dLnLike, dLnLikeNew,
               dLnData, dLnDataNew)) {
      pMCVar->dVal = dTheta;

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

      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->pfileGibOut, "%5g\t", pMCVar->dVal);
    }
  }

} /* SampleThetas */


/* 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)
{
  int 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)
{
  double dMin, dMax, dTmp;
  long   n, m;

  /* 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)) {
      CalculateOneMCParm (plevel->rgpMCVars[n]);
      dMin = dMax = plevel->rgpMCVars[n]->dVal;
      for (m = 0; m < 2; ++m) {
        CalculateOneMCParm (plevel->rgpMCVars[n]);
        dTmp = plevel->rgpMCVars[n]->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 order to never
         exceed computational bounds, and we never form the dangerous complete
         range */
      plevel->rgpMCVars[n]->dKernelSD = (0.5 * dMax) - (0.5 * dMin);
    }

} /* 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)
{
  int n;
  PMCVAR  pMCVar;

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

} /* SetModelVars */


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

   Set initial values of thetas after reading input file -
   values are assumed to be in proper order
   Called from TraverseLevels
*/

void SetMCVars (PLEVEL plevel, char **args)
{
  long   *pnThetas = (long*) args[0];
  double *pdMCVarVals = (double*) args[1];
  long   n;

  for (n = 0; n < plevel->nMCVars; ++n)
    plevel->rgpMCVars[n]->dVal = pdMCVarVals[(*pnThetas)++];

} /* 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
*/

void SetPointers (PLEVEL plevel, char **args)
{
  int n, m;
  PMCVAR pMCVar;

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

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

} /* SetPointers */


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

   If `plevel' has experiments, add the current Likelihood and
   sum-of-squares to the totals

   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 -------------------------------------------------------------------
   Test

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

BOOL Test (BOOL bExptIsDep, long iter, long initIter, double dLnPrior,
           double dLnPriorNew, double dLnLike, double dLnLikeNew,
           double dLnData, double dLnDataNew) {

  double dPjump, dTmp;

  if (dLnPriorNew == BAD_VAL || dLnLikeNew == BAD_VAL)
    return FALSE;

  dPjump = dLnPriorNew - dLnPrior + dLnLikeNew - dLnLike;
  if (bExptIsDep)
    dPjump += dLnDataNew - dLnData;

  /* Disabled: If we are doing an initialization iteration we jump each time
     only if we improve (i.e. if dPjump > 1) */
/*  if (iter >= initIter) */
    dTmp = log(Randoms());
/*  else
    dTmp = 0;
*/
  return ((BOOL) (dTmp <= dPjump));

} /* Test */


/* 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;
  BYTE 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;
  BYTE 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 thetas to output file header
*/

void WriteHeader (PLEVEL plevel, char **args)
{
  PANALYSIS panal = (PANALYSIS)args[0];
  FILE *outFile = (FILE*)args[1];
  int 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]);
  }

  fflush (outFile);

} /* WriteHeader */


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

   WriteMCVars

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

void WriteMCVars (PLEVEL plevel, PANALYSIS panal, FILE* pOutFile)
{
  int n;
  PMCVAR pMCVar;

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

} /* WriteMCVars */
