/* statfunc.c */
/* Kate Cowles */
/* 02-06-93 */
/* 03-17-94 */
/* 09-09-94 -- functions removed that required CMLIB routines */
/* 12-14-94 -- added chol, det2, det3, matinvt2, matinvt3 */ 
/* 01-01-95 -- added matinvrt */
/* 04-22-95 -- added bivnormd */
/* 05-23-96 -- corrected wishart */
/* 05-29-96 -- added diricvar and weibvar */
/* 06-18-96 -- memory allocation improved by Ken Kleinman */
/* 07-30-98 -- added inprod */
/* 09-98    -- added adaptive */
/* 10-13-98 -- added cholleast */
/* 10-15-98 -- added triinvrt */
/* 07-29-99 -- added cholsum */
/* 07-30-99 -- added multltri and multutri */
/* 08-03-99 -- added choltsum and choltleast */
/* 04-02-2000 -- added backsubst and stdnorm */
/* 06-14-2000 -- added forsubst */

/* 
   adaptive --  adaptive quadrature; Simpson's rule; not ready for use
   backsubst -- solve upper triangular system using backward substitution
   bivnormd --  bivariate normal density
   chol  --     choleski decomposition of positive definite nxn matrix
   cholleast -- least squares using cholesky decomp 
   choltleast -- least squares using upper triangular left sq rt 
   cholsum --   choleski decomp of sum of pos def nxn mat and diagonal mat
   choltsum --  upper tri left sq rt of sum of pos def nxn mat and diagonal mat
   dabs  --     double precision absolute value
   dmax  --     double precision maximum of 2 double precision numbers
   dmin  --     double precision minimum
   det2  --     double prec determinant of double prec 2x2 matrix
   det3  --     double prec determinant of double prec 3x3 matrix
   extremec --  extreme value (minimum) cdf
   extremed --  extreme value (minimum) density
   extremeq --  quantile of extreme value distrib
   extrevar --  random variate from extreme value distribution (minimum)
   forsubst --  solve lower triangular system using forward substitution
   gammavar --  random gamma variate
   geweke   --  random variate from truncated normal; Geweke's algorithm
   inprod   --  inner product of 2 double-prec vectors
   invwish  --  inverse wishart random matrix
   logistd  --  standard logistic density
   logistc  --  standard logistic cdf
   logistq  --  quantile of standard logistic
   logisvar --  random standard logistic variate
   matinvrt --  double prec inverse of double prec nonsing matrix
   matinvt2 --  double prec inverse of double prec 2x2 matrix
   matinvt3 --  double prec inverse of SYMMETRIC double prec 3x3 matrix
   matmult  --  product of two matrices
   matnorm  --  l-infinity norm of a matrix
   matprint --  print a double precision matrix
   mattrans --  transpose a matrix
   midpoint --  composite midpoint algorithm for 1-dim definite
                integrals
   multltri --  multiply a lower triangular matrix times a vector
   multltrim --  multiply a lower triangular matrix times a matrix
   multnorm --  generate a random multivariate normal vector
   multutri --  multiply an upper triangular matrix times a vector
   multutrim --  multiply an upper triangular matrix times a matrix
   normald  --  normal density 
   normalphi -- normal cdf
   normalz   -- normal quantile
   normvar  --  generate 2 normal(0,1) variates; Marsaglia's polar algorithm
   randseq --   generate random permutation of n integers
   readrand --  initialize seed for drand48()
   simpson  --  composite Simpson's algorithm for 1-dim definite integrals
   sortarry --  sort an array; Shell-Metzner algorithm
   stdnorm  --  generate vector of i.i.d. std normals
   triinvrt --  invert double-precision upper triangular matrix ;
   truncnrm --  random variate from truncated normal; inversion algorithm
   tvar     --  generate random variate from t distrib
   updtseed --  update seed file for drand48
   vectmult --
   vectnorm --  l-infinity norm of a vector
   wishart  --  random matrix from wishart distrib; Odell & Feivesen
   wish2_2  --  random 2x2 from wishart
   wish2_2nint  --  random 2x2 from wishart ; noninteger df

*/

/* ******** */
/* adaptive */
/* ******** */

/* adaptive quadrature; Simpson's rule */
/* Burden and Faires algorithm 4.2 */
/*
   n        maximum number of levels
   a, b     left and right limits of integration
   eps      desired accuracy
   f        function to be evaluated
*/

 double adaptive( n, a, b, eps, f)
 int n ;
 double a, b, eps, (*f)() ;

   {
    double TOL[20], A[20], H[20], FA[20], FC[20], FB[20], S[20], V[7]; 
    int L[20]; 
    double APP,FD,FE,S1,S2, dabs(); 
    int I,LEV; 
   
 
       APP = 0.0; 
       I = 1;
  
       TOL[I] = 10.0 * eps;
       A[I] = a;
       H[I] = (b - a) / 2.0;
       FA[I] = f(a);
       FC[I] = f((a+H[I]));
       FB[I] = f(b);
 
       S[I] = H[I] * (FA[I] + 4.0 * FC[I] + FB[I]) / 3.0;
       L[I] = 1;
  
       while ((I > 0) )   
         {
 
 	 FD = f((A[I] + 0.5 * H[I]));     
 	 FE = f((A[I] + 1.5 * H[I]));
 
 	 S1 = H[I] * (FA[I] + 4.0 * FD + FC[I]) / 6.0;
 	 S2 = H[I] * (FC[I] + 4.0 * FE + FB[I]) / 6.0;
 
 	 V[0] = A[I];
 	 V[1] = FA[I];
 	 V[2] = FC[I];
 	 V[3] = FB[I];
 	 V[4] = H[I];
 	 V[5] = TOL[I];
 	 V[6] = S[I];
 	 LEV = L[I];
 	
 	 I--;   /* line 100 */
 	 
         /* printf("S0 %7.4f S1 %7.4f S2 %7.4f \n", V[6], S1, S2) ; */

 	 if (dabs(S1 + S2 - V[6]) < V[5])     
            {
 	    APP = APP + (S1 + S2);
            /* printf("app %7.4f \n", APP) ; */
            }
         else 
            {
            if(LEV >= n)
              { 
                printf("Number of levels exceeded in adaptive quadrature\n") ;
                exit(1) ;
              }
            else
              { 
               I++ ;
 	       A[I] = V[0] + V[4];
 	       FA[I] = V[2]; 
 	       FC[I] = FE;
 	       FB[I] = V[3];
 	       H[I] = 0.5 * V[4]; 
 	       TOL[I] = 0.5 * V[5];
 	       S[I] = S2;
 	       L[I] = LEV + 1;
 	
 	       I++;
 	       A[I] = V[0];
 	       FA[I] = V[1];
 	       FC[I] = FD;
 	       FB[I] = V[2];
 	       H[I] = H[I-1];
 	       TOL[I] = TOL[I-1];
 	       S[I] = S1;
 	       L[I] = L[I-1];
                /* printf("level %d \n", L[I]) ; */
              }
 	    }
       /* printf("i %d\n", I) ; */
 	 }
 
       /* printf("just before return APP %7.4f\n", APP) ; */
       return(APP);
 }
 
/* ********************************************** */
/*                    backsubst                   */
/* solves upper triangular system L^T e = z for e */
/* parameters are L^T, e, z, and dim z            */
/* ********************************************** */

void backsubst( Lt, e, z, n )
double Lt[], e[], z[] ;
int n ;

{
 int i, j, k ;
 double tempsum ;

  e[n-1] = z[n-1] / Lt[n * (n-1) + n-1] ;
  for (i = n-2; i >= 0; i--)
     {
      tempsum = 0.0 ;
      for (j = i+1; j < n; j++)
         tempsum += Lt[n * i + j] * e[j] ;

      e[i] = (z[i] - tempsum) / Lt[n * i + i] ;
     }
}


/* ******* */ 
/* bivnorm */ 
/* ******* */ 

/* bivariate normal density */

double bivnormd(x1, x2, mu1, mu2, sigma1sq, sigma2sq, sigma12)
double x1, x2, mu1, mu2, sigma1sq, sigma2sq, sigma12 ;
{
  double sqrt(), exp(), pow(), PI = 3.14159265359 ;
  double sigma1, sigma2, rho, det, denom, inside, whole ;

  sigma1 = sqrt(sigma1sq) ;
  sigma2 = sqrt(sigma2sq) ;
  rho = sigma12 / (sigma1 * sigma2) ;
  det = sigma1sq * sigma2sq - sigma12 * sigma12 ;
  denom = 1.0 - rho * rho ;
  inside = pow( (( x1 - mu1 ) / sigma1 ), 2.0) 
           - 2.0 * rho * (x1 - mu1)  * (x2 - mu2) / (sigma1 * sigma2) 
           + pow( (( x2 - mu2 ) / sigma2 ), 2.0) ;

  whole = exp ( - inside / (2.0 * denom) ) / (2.0 * PI * sigma1 * sigma2 * 
          sqrt( denom) ) ;

   return( whole ) ;
} 

/* *********************************************************** */
/* cholleast */
/* computes least squares solution to Ax = b */
/* parameters are (choleski decomp of A), b, and x, and dim x  */
/* *********************************************************** */

double cholleast( C, b, x, n )
double C[], b[], x[] ;
int n ;

{
 int i, j, k ;
 double *ty, tempsum ;

 char *malloc() ;
 ty = (double *) malloc(n * sizeof (double) ) ;

 ty[0] = b[0] / C[0] ;

 for (i = 1; i < n; i++)
    {
     tempsum = 0.0 ;
     for (j = 0; j < i; j++)
        tempsum += C[n * i + j] * ty[j] ;
     ty[i] = (b[i] - tempsum) / C[n * i + i] ;
    }

  x[n-1] = ty[n-1] / C[n * (n-1) + n-1] ;
  for (i = n-2; i >= 0; i--)
     {
      tempsum = 0.0 ;
      for (j = i+1; j < n; j++)
         tempsum += C[n * j + i] * x[j] ;

      x[i] = (ty[i] - tempsum) / C[n * i + i] ;
     }

  free(ty) ; 

}

/* *********************************************************** */
/* choltleast */
/* computes least squares solution to Ax = b */
/* parameters are (upper tri left sq rt of A), b, and x, and dim x  */
/* *********************************************************** */

double choltleast( C, b, x, n )
double C[], b[], x[] ;
int n ;

{
 int i, j, k ;
 double *ty, tempsum ;

 char *malloc() ;
 ty = (double *) malloc(n * sizeof (double) ) ;


  ty[n-1] = b[n-1] / C[n * (n-1) + n-1] ;
  for (i = n-2; i >= 0; i--)
     {
      tempsum = 0.0 ;
      for (j = i+1; j < n; j++)
         tempsum += C[n * i + j] * ty[j] ;

      ty[i] = (b[i] - tempsum) / C[n * i + i] ;
     }

 x[0] = ty[0] / C[0] ;
 for (i = 1; i < n; i++)
    {
     tempsum = 0.0 ;
     for (j = 0; j < i; j++)
        tempsum += C[n * j + i] * x[j] ;
     x[i] = (ty[i] - tempsum) / C[n * i + i] ;
    }
  free(ty) ; 

}
 
/* **** */
/* chol */  
/* **** */

/* Choleski decomposition of positive definite nxn matrix */
/* a is matrix to be factored; lower triangular factorization will be
   returned in l.  n is dimension of a */

void chol(a, l, n)
double a[], l[] ;
long n ;
{

   long i, j, k, nsq, errflag ;
   double pow(), sqrt(), sum ;
   double tol = .000000000000001 ;

   nsq = n * n ;
   
   if (a[0] > tol )
      l[0] = sqrt(a[0]) ;
   else
      {
        printf("Error 1 in choleski decomposition.\n") ;
        exit(1) ;
       }
   for (j = 1; j < n; j++)
       l[n * j] = a[n * j] / l[0] ;
   
   for ( i = 1; i < n-1; i++)
       {
        sum = 0.0 ;
        for (k = 0 ; k < i; k ++) 
            sum += l[ n * i + k] * l[n * i + k] ;
        if (a[n * i + i] - sum > tol)
            l[n * i + i] = sqrt(a[n * i + i] - sum) ;
        else
           {
            printf("Error 2 in choleski decomposition.\n") ;
            exit(1) ;
           }
        for (j = i + 1; j < n; j++)
           {
            sum = 0.0 ;
            for (k = 0; k < i; k++)
                sum += l[n * j + k] * l[n * i + k] ;
            l[n * j + i] = (a[n * j + i] - sum) / l[n * i + i] ;
           }
      }
  sum = 0.0 ;
  for (k = 0; k < n - 1; k++)
     sum += l[n * (n-1) + k] * l[n * (n-1) + k] ;
  if (a[n * (n-1) + n-1] - sum >= tol)
     l[n * (n-1) + n-1] = sqrt(a[n * (n-1) + n-1 ] - sum) ;
  else
      {
        printf("a[%d][%d] %7.4f sum %7.4f \n", n-1, n-1, a[n * (n-1) + n-1], sum) ; 
        printf("Error 3 in choleski decomposition.\n") ;
        exit(1) ;
      }
  for (i = 0; i < n; i++)
     for (j = i + 1; j < n; j++)
        l[n * i + j] = 0.0 ;

 }

/* ******* */
/* cholsum */
/* ******* */

/* Choleski decomposition of sum of pos def nxn mat and diagonal mat */
/* oldl is chol decomp of orig pos dev nxn mat */
/* d is vector of diagonal entries of second matrix */
/* Cholesky decomp is returned in l.  n is dimension of orig mat */

void cholsum(oldl, d, l, n)
double oldl[], d[], l[] ;
long n ;
{

   long i, j, k, nsq, errflag ;
   double pow(), sqrt(), sum1, sum2, tol = 0.000000001 ;

   nsq = n * n ;
   
   l[0] = sqrt(oldl[0] * oldl[0] + d[0]) ;
   if (l[0] < tol)
      {
        printf("Error 1 in choleski decomposition.\n") ;
        exit(1) ;
       }
   for (j = 1; j < n; j++)
       l[n * j] = oldl[0] * oldl[n * j] / l[0] ;
   
   for ( i = 1; i < n-1; i++)
       {
        sum1 = sum2  = 0.0 ;
        for (k = 0 ; k < i; k ++) 
           {
            sum1 += oldl[ n * i + k] * oldl[n * i + k] ;
            sum2 += l[ n * i + k] * l[n * i + k] ;
           }
        sum1 += oldl[n * i + i] * oldl[n * i + i] ;   /* sum1 is orig mat[i][i] */
        l[n * i + i] = sqrt(sum1 + d[i] - sum2) ;
        if (l[n * i + i] < tol)
           {
            printf("Error 2 in choleski decomposition.\n") ;
            exit(1) ;
           }
        for (j = i + 1; j < n; j++)
           {
            sum1 = sum2 = 0.0 ;
            for (k = 0; k < i; k++)
               {
                sum1 += oldl[n * i + k] * oldl[n * j + k] ;
                sum2 += l[n * j + k] * l[n * i + k] ;
               }
            sum1 += oldl[n * i + i] * oldl[n * j + i] ;   /* sum1 is orig mat[i][i] */
            l[n * j + i] = (sum1 - sum2) / l[n * i + i] ;
           }
      }
  sum1 = sum2 = 0.0 ;
  for (k = 0; k < n - 1; k++)
    {
      sum1 += oldl[ n * (n - 1) + k] * oldl[n * (n-1) + k] ;
      sum2 += l[ n * (n-1) + k] * l[n * (n-1) + k] ;
    }
  sum1 += oldl[n * (n-1) + i] * oldl[n * (n-1) + i] ;   /* sum1 is orig mat[n-1][n-1] */
  l[n * (n-1) + n-1] = sqrt(sum1 + d[n-1] - sum2) ;
  if (l[n * (n-1) + n-1] < tol)
      {
        printf("Error 3 in choleski decomposition.\n") ;
        exit(1) ;
      }
  for (i = 0; i < n; i++)
     for (j = i + 1; j < n; j++)
        l[n * i + j] = 0.0 ;
}

/* ******* */
/* choltsum */
/* ******* */

/* upper triangular left sq root of sum of pos def nxn mat and diagonal mat */
/* oldl is upper triangular left sq rt of orig pos dev nxn mat */
/* d is vector of diagonal entries of second matrix */
/* result s returned in l.  n is dimension of orig mat */

void choltsum(oldl, d, l, n)
double oldl[], d[], l[] ;
long n ;
{

   long i, j, k, nsq, errflag, index ;
   double pow(), sqrt(), sum1, sum2, tol = 0.000000000001 ;

   nsq = n * n ;

   index = n * (n-1) + n-1 ; 
   l[index ] = sqrt(oldl[index] * oldl[index] + d[n-1]) ;
   if (l[index] < tol)
      {
        printf("Error 1 in choleski decomposition.\n") ;
        exit(1) ;
       }
   for (j = n-2; j >= 0; j--)
       l[n * j + n - 1] = oldl[index] * oldl[n * j + n-1] / l[index] ;
   
   for ( i = n-2; i > 0; i--)
       {
        sum1 = sum2  = 0.0 ;
        for (k = n-1 ; k > i; k--) 
           {
            sum1 += oldl[ n * i + k] * oldl[n * i + k] ;
            sum2 += l[ n * i + k] * l[n * i + k] ;
           }
        sum1 += oldl[n * i + i] * oldl[n * i + i] ;   /* sum1 is orig mat[i][i] */
        l[n * i + i] = sqrt(sum1 + d[i] - sum2) ;
        if (l[n * i + i] < tol)
           {
            printf("Error 2 in choleski decomposition.\n") ;
            exit(1) ;
           }
        for (j = i - 1; j >= 0; j--)
           {
            sum1 = sum2 = 0.0 ;
            for (k = n-1; k > i; k--)
               {
                sum1 += oldl[n * i + k] * oldl[n * j + k] ;
                sum2 += l[n * j + k] * l[n * i + k] ;
               }
            sum1 += oldl[n * i + i] * oldl[n * j + i] ;   /* sum1 is orig mat[i][i] */
            l[n * j + i] = (sum1 - sum2) / l[n * i + i] ;
           }
      }
  sum1 = sum2 = 0.0 ;
  for (k = n-1; k > 0; k--)
    {
      sum1 += oldl[ 0 + k] * oldl[0 + k] ;
      sum2 += l[ 0 + k] * l[0 + k] ;
    }
  sum1 += oldl[0 + i] * oldl[0 + i] ;   /* sum1 is orig mat[0][0] */
  l[0] = sqrt(sum1 + d[0] - sum2) ;
  if (l[0] < tol)
      {
        printf("Error 3 in choleski decomposition.\n") ;
        exit(1) ;
      }
  for (i = 0; i < n; i++)
     for (j = 0; j < i; j++)
        l[n * i + j] = 0.0 ;
}

/* Return double precision absolute value */

double dabs(x) 
double x;
{
   double y ;
   return( (x < 0.0) ? -x : x) ;
}

/* Return the maximum of 2 double-precision numbers */

double dmax(x,y) 
double x, y ;
{
   return( (x >= y) ? x : y ) ;
}


/* Return the minimum of 2 double-precision numbers */

double dmin(x,y) 
double x, y ;
{
   return( (x <= y ) ? x : y ) ;
}

/* return double precision determinant of double prec 2x2 matrix */

double det2(a)
double a[] ;
{
   return( (double)(a[0] * a[3] - a[1] * a[2]) ) ;
}


/* return double precision determinant of double prec 3x3 matrix */

double det3(a)
double a[] ;
{
   return( a[0] * a[4] * a[8]  + 2.0 * a[1] * a[2] * a[5] - a[1] * a[1] * a[8] 
           - a[0] * a[5] * a[5] - a[4] * a[2] * a[2] ) ;
}

/***********************/
/* diricvar            */
/* Dirichlet rand vars */
/***********************/

/* Return double precision vector of Dirichlet variates */
/* alpha is parameter vector
   n is length of alpha
   retvect is vector of length n in which to return variate */

double diricvar( alpha, n, retvect )
double alpha[], retvect[] ;
long n ;

{
  double gammavar(), *y, sumy ;
  long i,j,k ;
  char *malloc() ;

  y = (double *) malloc(n, sizeof (double) ) ;

  for (i = 0; i < n; i++)
     y[i] = 0.0 ;

  sumy = 0.0 ;
  for (i = 0; i < n; i++)
      {
       y[i] = gammavar( alpha[i], 1.0) ;
       sumy += y[i] ;
      }

  for (i = 0; i < n; i++)
       retvect[i] = y[i] / sumy ;
 
free(y) ;

}


/* extreme value cdf */

double extremec(x)
double x ;
{
   double exp() ;
   return( 1.0 - exp( - exp(x) ) ) ;
}

/* extreme value density */

double extremed(x)
double x ;
{
   double exp() ;
   return( exp(x - exp(x) ) ) ;
}

/* return quantile of extreme value distribution */

double extremeq(x)
double x ;
{
   double log() ;
   return( log( -log(1.0 - x)) );
}

/* return random variate from extreme value distribution */

double extrevar()
{
   double log(), u, drand48() ;
   u = drand48() ;
   return( log( -log(1.0 - u)) );
}
 
/* ********************************************** */
/*                    forsubst                    */
/* solves lower triangular system L e = z for e */
/* parameters are L, e, z, and dim z            */
/* ********************************************** */

void forsubst( L, e, z, n )
double L[], e[], z[] ;
int n ;

{
 int i, j, k ;
 double tempsum ;

  e[0] = z[0] / L[0] ;
  for (i = 1; i < n; i++)
     {
      tempsum = 0.0 ;
      for (j = 0; j < i; j++)
         tempsum += L[n * i + j] * e[j] ;

      e[i] = (z[i] - tempsum) / L[n * i + i] ;
     }

}



/* Return a gamma(alpha,beta) variate */
/* Return a gamma(alpha,beta) variate */
/* 
    alpha -- shape parameter; double prec
    beta  -- scale parameter; double prec
*/

double gammavar(alpha,beta)
double alpha, beta ;

{
  double u0, u1, u2, x, c1, c2, c3, c4, w ;
  double E, pow(), log(), drand48(), exp(), sqrt() ;
  int done = 0, done2 ;
   /* if (alpha <= 0.0 || beta <= 0.0) */
   if (alpha < 0.0 || beta < 0.0)
       {
        printf("negative parm for gamma\n") ;
	exit(1);
       }
  E = exp(1.0) ;
  if (alpha <1.0)   /* Ahrens and Dieter */
     {
      while (done==0)
         {
          u0 = drand48() ;
          u1 = drand48() ;
          if (u0 > E/(alpha + E) )
             {
              x = -log( (alpha + E) * (1.0 - u0) / (alpha * E) ) ;
              if (u1 <= pow(x, alpha - 1))
                  done = 1 ;
             }
          else
             {
              x = pow( (alpha + E) * u0 / E, 1.0 / alpha ) ;
              if (u1 <= exp(-x) )
                 done = 1 ;
             } 
          }
         return(x / beta) ;
     }
  else if (alpha > 1.0)  /* Cheng and Feast */
     {
      c1 = alpha - 1.0 ;
      c2 = (alpha - 1.0 / (6.0 * alpha)) / c1 ;
      c3 = 2.0 / c1 ;
      c4 = c3 + 2.0 ;
      while (done==0)
         {
          do
             {
              u1 = drand48() ;
              u2 = drand48() ;
              if (alpha > 2.5)
                 u1 = u2 + (1.0 - 1.86 * u1) / sqrt(alpha) ;
             } while ( !(0.0 < u1 && u1 < 1.0)) ;
          w = c2 * u2 / u1 ;
          if ((c3 * u1 + w + 1.0 / w) <= c4)
             done = 1 ;
          else if (c3 * log(u1) - log(w) + w < 1.0)
             done = 1 ;
         }
      return (c1 * w / beta) ;
     }
  else   /* alpha = 1.0 so exponential */
     {
      c1 = 0.0 ;
      while (done==0)
         {
          u0 = drand48() ;
          c2 = u0 ;
          done2 = 0 ;
          while (done2==0 && done==0 )
             {
              u1 = drand48() ;
              if (u0 <= u1)
                 {
                  x = c1 + c2 ;
                  done = 1 ;
                  done2 = 1 ;
                 }
              else
                 {
                  u0 = drand48() ;
                  if (u0 >= u1)
                     done2 = 1 ;
                 }
             }
          c1++ ;
         }            /* while done==0 */
      return (x / beta) ;
     }
}

/* Return univariate truncated normal; Geweke's algorithm */
/*
    (a,b) is interval to which normal is truncated; double prec endpoints
    mu is mean of normal, double prec
    sigma is std of normal, double prec
    la is integer; 1 = left endpoint is infinite; 0 = not infinite  
    lb is integer; 1 = right endpoint is infinite; 0 = not infinite
    retvar is double precision variable for variate to be returned in
*/
geweke(a,b,mu,sigma,la,lb, retvar)  
double a,b,sigma,mu, *retvar ;
int la, lb;
{
   int lflip ;
   double eps = 2.0,
          t1  = 0.375,
          t2  = 2.18,
          t3  = 0.725,
          t4  = 0.45 ;
   double f(), normvect[2], drand48(), c1, c2, c, x, cdel, f1, f2, z, dabs(), y ;
   double exprej(), f(), halfline(), halfnorm(), normrej(), unifrej() ;
   void normvar();

   if (la & lb)  /* both endpoints infinite; return untruncated normal */
      {
       normvar(normvect) ;
       *retvar = normvect[0] * sigma + mu ;
       return ;
      }

   if (b <= a)   /* 0-width interval */
      {
       *retvar = a ;
       return ;
      }

   a = (a - mu) / sigma ;
   b = (b - mu) / sigma ;

   lflip = 0 ;   /* haven't reversed signs */

   if (la | lb)  /* one endpoint is infinite */
      x = halfline(a,b, &lflip, lb) ;

   else
      {
       c1 = a ;
       c2 = b ;
       if ((c1 * c2) < 0.0)  /* (a,b) includes 0 */
          {
           if ((c1 > -t1) && (c2 < t1))
              x = unifrej(c1,c2,1.0) ;
           else
              x = normrej(c1,c2) ;
          }
       else
          {
           if (c1 < 0.0)
              {
               c = c1 ;
               c1 = -c2 ;
               c2 = -c ;
               lflip = 1 ;
              }
           f1 = f(c1) ;
           f2 = f(c2) ;
           if ( (f2 < eps) || ( (f1/f2) > t2) )
              {
               if (c1 > t3) 
                  x = exprej(c1,c2) ;
               else
                  x = halfnorm(c1,c2) ;
              } 
           else
              x = unifrej(c1,c2) ;
           }
      }
   if (lflip)
      x = -x; 

   y = x * sigma + mu ;
   *retvar = y ;
}

double exprej(c1,c2)
double c1, c2 ;
{
   double x, drand48(), z, u, c, log(), f() ;

   c = c2 - c1 ;
   do
      {
       z = -log(drand48()) / c1 ;
      } while ( (z > c) || (drand48() > f(z)) ) ;
   x = c1 + z ;
   return(x) ;
}

 
double f(x) 
double x ;
{
  double exp() ;
  return(exp(-0.5 * x *x) ) ;
}

double halfline(a,b,lflipptr,lb)
double a,b ;
int *lflipptr, lb ;
{
  double c1, c2, t4 = 0.45, u, x, z, drand48(), normvect[2], 
         f(), log() ;
  void normvar();

   c1 = a ;
   if (lb==0)
      {
       c1 = -b ;
       *lflipptr = 1 ;
      }
   if (c1 > t4)    /* a large; exponential importance sampling */
      {
       do
          {
           z = -log(drand48()) / c1 ;
          } while (drand48() > f(z) ) ;
       x = c1 + z ;
      }
   else            /* a not large; full normal with rej */
      {
       do
          {
           normvar(normvect) ;
           x = normvect[0]; 
           if (x < c1)
              x = normvect[1] ;

          } while (x < c1) ;
      }
   return(x) ;
}

double halfnorm(c1,c2) 
double c1,c2 ;
{
   double x, dabs(), normvect[2];
   void normvar() ;

   do
      {
       normvar(normvect) ;
       x = dabs(normvect[0]) ;
       if (x < c1 || x > c2)
          x = dabs(normvect[1]) ;
      } while (x < c1 || x > c2) ;
   return(x) ;
}
        

double normrej(c1,c2) 
double c1,c2 ;
{
   double x, normvect[2];
   void normvar() ;

   do
      {
       normvar(normvect) ;
       x = normvect[0] ;
       if (x < c1 || x > c2)
          x = normvect[1] ;
      } while (x < c1 || x > c2) ;
   return(x) ;
}

double unifrej(c1,c2,f1) 
double c1,c2,f1 ;
{
   double cdel, u, x, drand48(), f() ;

   cdel = c2 - c1 ;
   do
      {
       x = c1 + cdel * drand48() ;
      } while (drand48() > (f(x)/f1) ) ;
   return(x) ;
}

  /* ******** */
  /*  inprod  */
  /* ******** */

/* generate inner product of two double precision vectors 
   a[] and b[] are the vectors, n is their length */

double inprod(a,b,n)
double a[],b[] ;
long n ;
{
   int i ;
   double retval = 0.0  ;

   for (i = 0; i < n; i++)
      retval += a[i] * b[i] ;

   return(retval) ;
}


/* ******** */
/* invwish  */
/* ******** */

void invwish(parmmat, df, n, retmat)
double parmmat[], retmat[] ;
int df, n ;

{

 double *temp ;
 void wishart(), matinvrt(), matprint() ;

 char *malloc() ;
 temp = (double *) malloc(n * n * sizeof (double) ) ;

 wishart(parmmat, df, n, temp) ;
printf("temp \n") ;
matprint( temp, n, n) ;

 matinvrt(temp, retmat, n) ;

 free(temp) ;

}

/* generate standard logistic random variate */

double logisvar()
{
   double u, drand48(), log() ;
   u = drand48() ;
   return( log(u / (1.0 - u) ) ) ;
}

/* evaluate standard logistic cdf */

double logistc(x)
double x;
{
  double y, exp() ;
  y = exp(x) ;
  return( y / (1.0 + y) ); 
}

/* evaluate standard logistic density */

double logistd(x)
double x;
{
  double y, exp(), pow() ;
  y = exp(x) ;
  return( y / pow((1.0 + y), 2.0) ) ; 
}

/* quantile of standard logistic */

double logistq(x)
double x;
{
    double log() ;
    return( log( x / (1.0 - x)) ) ;
}

/* add one double prec matrix to another */
/*
   dest -- address of destination matrix
   src  -- address of matrix to be added into dest matrix
   rows, cols -- integer; dims of the 2 matrices
   sum overwrites dest
*/
   
void mataccum(dest,src,rows,cols) 
double dest[], src[] ;
int rows, cols ;
{
   int i, j, index ;
   for (i = 0; i < rows; i++ )
      for (j = 0; j < cols; j++)
         {
          index = cols * i + j ;
          dest[index] += src[index] ;
         }
}

/* Copy src matrix into dest matrix */

void matcopy(dest,src,rows,cols) 
double dest[], src[] ;
int rows, cols ;
{
   int i, j, index ;
   for (i = 0; i < rows; i++ )
      for (j = 0; j < cols; j++)
         {
          index = cols * i + j ;
          dest[index] = src[index] ;
         }
}

/* Return double-prec inverse of square non-singular double-prec matrix */

/* *************************** */
/*       matinvrt              */
/* Generic function to invert  */
/* nonsingular square matrix.  */
/* n is dimension of b and binv */
/* Pass square matrix, address */
/* of return matrix, & dim .   */
/* *************************** */

void matinvrt(b, binv, n)
double b[], binv[] ;
long n ;
/* b is matrix to be inverted */
/* binv is matrix in which results will be returned */
/* n is dimension of b and binv */

{
   /* The dimensions of a depend on the value of n that is
      passed to the function.  Therefore, we declare pointer to this array
      rather than dimensioning it directly */ 
      
/*   char *calloc() ; */
   long i, j, k, nsq, twon, p, errflag ;
   double pow(), sqrt(), dabs(), sum, m, *a, *temp, tol ;
   char *malloc() ;

   nsq = n * n ;
   a = (double *) malloc( 2 * nsq* sizeof (double) ) ;
   temp = (double *) malloc(2 * n* sizeof (double) ) ;

for (i = 0; i < (2 * nsq) ; i++) a[i]=0;
for (i = 0; i < (2 * n) ; i++) temp[i]=0;

   tol = 0.00000000001 ;
   /* changed from 0.00001  5/9/00 */
   twon = 2 * n ;

   for (i = 0; i < n; i++)       /* construct augmented matrix */
      {
      for (j = 0; j < n; j++)
         {
          a[twon * i + j] = b[n * i + j] ;
          if (i == j)
             a[twon * i + j + n] = 1.0 ;
          else
             a[twon * i + j + n] = 0.0 ;
         } 
      }

   for (i = 0; i < n - 1; i++)
      {
       for (p = i; (dabs(a[twon * p + i]) < tol) && (p < n); p++);
       if (p == n)
          {
           printf("Matrix inversion fails.\n") ;
           exit(1) ;
          }
       else
          if (p != i)   /* exchange rows */
             {
              for (j = 0; j < twon; j++)
                 {
                   temp[j] = a[twon * p + j] ;
                   a[twon * p + j] = a[twon * i + j] ;
                   a[twon * i + j] = temp[j] ;
                 }
              }
      for (j = i + 1; j < n; j++)
         {
          m = a[twon * j + i] / a[twon * i + i] ;
          for (k = 0; k < twon; k++)
             a[twon * j + k] -= m * a[twon * i + k] ;
         }
     }

   if (dabs(a[twon * (n - 1) + (n - 1)]) < tol)
      {
       printf("Matrix inversion fails.\n") ;
       exit(1) ;
      }
   else
      {
       for (i = (n - 1); i >= 0; i--)
          {
           m = a[twon * (i) + i] ;
           for (j = 0; j < twon; j++)
              a[twon * (i) + j] /= m ;
           for (j = i - 1; j >= 0; j--)
              {
               m = a[twon * j + i]  ;
               for (k = 0; k < twon; k++)
                  a[twon * j + k] -= m * a[twon * i + k] ;
              }
           }
       for (i = 0; i < n; i++)
          for (j = 0; j < n; j++)
             binv[n * i + j] = a[twon * i + n + j] ;
     }

free(a);
free(temp);
 }

/* Return double-prec inverse of 2x2 non-singular double-prec matrix */

double matinvt2(a, b) 
double a[], b[] ;
{
    double det2(), dabs(), d ;

    d = det2(a) ;
    if (dabs(d) < .00000000001)
       {
        printf("Attempt to invert singular 2x2 matrix.\n") ;
        exit(1) ;
       }
    else
       {
        b[0] = a[3] / d ;
        b[1] = - a[1] / d ;
        b[2] = - a[2] / d ;
        b[3] = a[0] / d ;
       }
    return ;
}
   
/* Return double-prec inverse of 3x3 SYMMETRIC non-sing double-prec matrix */

double matinvt3(a, b) 
double a[], b[] ;
{
    double det3(), dabs(), d ;

    d = det3(a) ;
    if (dabs(d) < .00001 || a[1] != a[3] || a[2] != a[6] || a[5] != a[7] )
       {
        printf("Attempt to invert singular or non-symmetric 3x3 matrix.\n") ;
        exit(1) ;
       }
    else
       {
        b[0] = (a[4] * a[8] - a[5] * a[5]) / d ;
        b[1] = b[3] = (- a[1] * a[8] + a[2] * a[5]) / d ;
        b[2] = b[6] = (a[1] * a[5] - a[4] * a[2]) / d ;
        b[4] = ( a[0] * a[8] - a[2] * a[2]) / d ;
        b[5] = b[7] = (- a[0] * a[5] + a[2] * a[1]) / d ;
        b[8] = ( a[0] * a[4] - a[1] * a[1]) / d ;
       }
    return ;
}
   
/* Return product of 2 double prec matrices */
/*
    mat1 -- address of one matrix
    mat2 -- address of other matrix
    m1 -- integer; number of rows in mat1
    n1 -- integer; number of cols in mat1
    n2 -- integer;  number of cols in mat2
    retmat -- double precision matrix in which product is returned
*/


void matmult(mat1, mat2, m1, n1, n2, retmat)
double mat1[], mat2[], retmat[];
int m1, n1, n2 ;
{
   int i, j, k ;
   for (i = 0; i < m1; i++)
      {
       for (j = 0; j < n2; j++)
          {
/* 	printf("%g\n",mat1[n1 * i +j]);   */
           retmat[n2 * i + j] = 0.0 ;
           for (k = 0; k < n1; k++)
              retmat[n2 * i + j] += mat1[n1 * i + k] * mat2[n2 * k + j]; 
          }
       }
}


/*
double matmult(mat1, mat2, m1, n1, n2, retmat)
double **mat1, **mat2, **retmat;
int m1, n1, n2 ;
{
   int i, j, k ;
	for (i=0; i<m1 ; i++) {
	   for (j=0; j < n2; j++) {
		for (k=0; k < n1; k++)  {
		   retmat[i][j] = retmat[i][j] + (mat1[i][k] * mat2[k][j]);
		   }
	        }
	 }
}
*/




/* Return l-infinity norm of a square matrix */
/*  
     mmatrix -- double-prec square matrix
     n       -- integer; dim of mmatrix
*/
double matnorm(mmatrix, n) 
double mmatrix[] ;
int n ;
{
double norm = 0.0, sum ;
int i, j ;

for (i = 0; i < n; i++)  /* for each row of matrix */
   {
    sum = 0.0 ;
    for (j = 0; j < n; j++)
       sum = sum + dabs(mmatrix[n * i + j]) ;
    if (norm < sum)
       norm = sum ;
   }
return(norm) ;
}

/* print a double precision matrix */

void matprint(mat, nrow, ncol)
double mat[] ;
int nrow, ncol ;

{
    int i,j ;

    for (i = 0; i < nrow; i++)
       {
        for (j = 0; j < ncol; j++)
           printf("%10.5g ", mat[ncol * i + j]) ;
        printf("\n") ;
       }
     printf("\n") ;
}


/* Transpose a matrix */
/*    mata = original matrix
    retmat = matrix to be returned
         m = number of rows in original matrix
         n = number of columns in original matrix  */

void mattrans(mata, retmat, m, n) 
double mata[], retmat[] ;
int m, n;
{
int i, j ;

for (i = 0; i < m; i++ )
   {
    for (j = 0; j < n; j++ )
       retmat[m * j + i] = mata[n * i + j] ;
   }

}

/* Return estimate of integral

   a = left endpoint
   b = right endpoint
   m = number fo subintervals
   f = function to be integrated
*/

double midpoint(a,b,m,f)
double a,b,(*f)() ;
int m;
{
   double h, sum, I, x;
   int j;
   h = (b - a) / (2.0 * (double) m + 2.0) ;
   sum = 0.0 ;
   for (j = 0; j <= m; j++)
      {
       x = a + (1.0 + 2.0 * (double) j ) * h ;
       sum += (*f)(x) ;
      }
   I = 2.0 * h * sum ;
   return(I) ;
}

/* *********** */
/*   multltri  */
/* *********** */

/* multiply a vector x of length n by a lower triangular matrix l */

void multltri(l, x, result, n)
double l[], x[], result[] ;
long n ;

{
int i, j ;

for (i = 0; i < n; i++)
   {
    result[i] = 0.0 ;
    for (j = 0; j <= i; j++)
       result[i] += l[n * i + j] * x[j] ;
   }

}

/* *********** */
/*   multltrim  */
/* *********** */

/* multiply a matrix A of dim m x n by an m x m lower triangular matrix l */
/* compute l A */

void multltrim(l, A, retmat, m,n)
double l[], A[], retmat[] ;
long m,n ;

{
int i, j, k ;

for (i = 0; i < m; i++)
   for (j = 0; j < n; j++)
      {
       retmat[n * i + j] = 0.0 ;
       for (k = 0; k <= i; k++)
        {
           retmat[n * i + j] += l[m * i + k] * A[n * k + j] ;
        }
      }

}


/* Return multivariate normal vector */
/*
     cholsig -- Choleski decomposition of covariance matrix; double prec
                         lower triangular
     retvect -- vector in which values will be returned; double prec
     tempvect -- working vector; double prec
     n       -- integer; dimension of cholsig, retvect, & tempvect
*/

void multnorm(cholsig, retvect, tempvect, n) 
double cholsig[], tempvect[], retvect[] ;
int n ;
{

  int i, j=1  ; 
  double norm[2];
  void matmult(), multltri() ;
  void normvar() ;

  for (i = 0; i < n ; i +=2 ) 
    {
      normvar(norm) ;
      tempvect[i] = norm[0] ;
      if (i < n - 1)
            tempvect[i + 1] = norm[1] ;
     } 
  /* matmult(cholsig,tempvect,n,n,j,retvect) ;  */ 
  multltri(cholsig, tempvect, retvect, n) ;
}

/* *********** */
/*   multutri  */
/* *********** */

/* multiply a vector x of length n by an upper  triangular matrix l */

void multutri(l, x, result, n)
double l[], x[], result[] ;
long n ;

{
int i, j ;

for (i = 0; i < n; i++)
   {
    result[i] = 0.0 ;
    for (j = i; j < n; j++)
       result[i] += l[n * i + j] * x[j] ;
   }

}


/* *********** */
/*   multutrim  */
/* *********** */

/* multiply a matrix A of dim m x n by an m x m upper triangular matrix l */
/* compute l A */

void multutrim(l, A, retmat, m,n)
double l[], A[], retmat[] ;
long m,n ;

{
int i, j, k ;

for (i = 0; i < m; i++)
   for (j = 0; j < n; j++)
      {
       retmat[n * i + j] = 0.0 ;
       for (k = i; k < m; k++)
        {
           retmat[n * i + j] += l[m * i + k] * A[n * k + j] ;
        }
      }

}

/* Return normal density for given x, mu, and sigma */

double normald(x, mu, sigma)
double x, mu, sigma ;
{
  double exp(), sqrt(), pi = 3.14159265 ;

  return( exp( - ( ( x - mu) * (x - mu) / (2.0 * sigma * sigma) )) / ( sqrt( 2.0 * pi) *
      sigma) ) ; 

}

/* Return normal CDF of a value */

double normalphi(x) 
double x;
{
   double phix, erf(), erfc(), sqrt()  ;
   if (x > 0.0)
       phix = (1 + erf(x /sqrt(2.0))) / 2.0 ;
   else
      {
       if (x < 0)
          phix = erfc( (-x) / sqrt(2.0)) / 2.0 ;
       else
          phix = .50000 ;
      }
   return(phix) ;
}

/* Return quantile of standard normal */

double normalz(p1)
double p1 ;
{
  double p[5], q[5], pow(), log(), sqrt(), lim = pow(10.0,-20.0), xp, pval, y ;
  p[1] = -0.322232431088 ;
  p[2] = -1.0 ;
  p[3] = -0.342242088547 ;
  p[4] = -0.0204231210245 ;
  p[5] = -0.453642210148 * 0.0001 ;
  q[1] = 0.0993484626060 ;
  q[2] = 0.588581570495 ;
  q[3] = 0.531103462366 ;
  q[4] = 0.103537752850 ;
  q[5] = 0.38560700634 * .01 ;
  xp = 0.0 ;
  if (p1 > 0.5)
     pval = 1.0 - p1 ;
  else
     pval = p1 ;
  if (pval >= lim && pval != 0.5)
     {
       y = sqrt(log(1.0/pow(pval,2.0))) ;
       xp = y + ((((y * p[5] + p[4]) * y + p[3]) * y + p[2]) * y + p[1]) /
                ((((y * q[5] + q[4]) * y + q[3]) * y + q[2]) * y + q[1]) ;
       if (p1 < 0.5)
         xp = - xp ;
     }
  return(xp) ;
}
 

/* Generate 2 indep standard normal variates; Marsaglia's Polar algorithm */
/*
   nrm -- double prec vector of length 2 in which the variates are returned
*/
void normvar(nrm)
double *nrm;
{
  double drand48() ;
  double u1, u2, w, c, log(), sqrt()  ;

  w = 3.0 ;
  while (w > 1.0 )
    {
     u1 = 2.0 * drand48() - 1.0 ;
     u2 = 2.0 * drand48() - 1.0 ;
     w = u1 * u1 + u2 * u2 ;
    }

  c = sqrt( -2.0 / w * log(w)) ;
  nrm[0] = c * u1 ;
  nrm[1] = c * u2 ;
}


/* randseq 
   generate a random permutation of integers 0 to n - 1 */ 

randseq(intvect, n) 
int intvect[], n ;
{

  double drand48(), *a, tempd ;
  int i, j, tempi ;
  char *malloc() ;

  a = (double *) malloc(n * sizeof (double) ) ;

  for (i = 0; i < n; i++)
     {
      a[i] = drand48() ;
      intvect[i] = i ;
     }

  /* bubble sort the random numbers and their indices */

  for (i = 0; i < n; i++ )
      {
      for (j = i + 1 ; j < n; j++)
          if (a[j] < a[i])
            {
              tempd = a[i] ;
              tempi = intvect[i] ;
              a[i] = a[j] ;
              intvect[i] = intvect[j] ;
              a[j] = tempd ;
              intvect[j] = tempi ;
             }
      }

  free(a) ;

}

   /* ******************************************* */
   /*                 readrand                    */
   /* Initialize seed for random number generator */
   /*                                             */
   /* ******************************************* 

readrand()

{
   FILE *in ;
   int i, j, tempseed[3] ;
   unsigned short *seed48() ;


   if ( (in = fopen( "/space/kcowles/libraries/seedfile","r" )) != NULL)
      {
       for (i = 0; i < 3; i++)
          {
           fscanf( in, "%d", &tempseed[i] ) ;
           seed16v[i] = tempseed[i] ;
          }
      }

   else
      {
       printf("Seed file cannot be opened for reading.\n") ;
       exit(1) ;
      }

   fclose(in) ;
   myptr = seed48(seed16v) ;
}
*/

/* Composite Simpson's algorith for evaluating 1-dimensional definite integral*/
/*
     a,b -- double precision endpoints of interval
     f   -- address of double prec function to be integrated
     n   -- even pos integer; number of subintervals
*/
double simpson(a,b,n,f) 
double a,b,(*f)() ;
int n ;

{
   double h, XI0, XI1, XI2, X, XI, fx ;
   int i;

   h = (b - a) / n ;
   XI0 = (*f)(a) + (*f)(b) ;
   XI1 = XI2 = 0.0 ;

   for (i = 1; i < n; i++)
      {
       X = a + (double) i * h ;
       fx = (*f)(X) ;
       if ((i % 2) ==  0 )
          XI2 += fx ;
       else XI1 += fx; 
      }
   XI = h * (XI0 + 2.0 * XI2 + 4.0 * XI1) / 3.0 ;
   
   return (XI) ;
}

    
/* Sort array; Shell-Metzner algorithm */

void sortarry(d, n)
double d[];
int n;
{
   int p, k, j, i, l, flips ;
   double tmp ;

   for (p = n/2; p > 0; p/= 2)
      {
       k = n - p ;
       for (j = 1; j <=k; j++)
          {
           i = j ;
           do
              {
               flips = 0 ;
               l = i + p ;
               if (d[i-1] >  d[l-1])
                  {
                   tmp = d[i-1] ;
                   d[i-1] = d[l-1] ;
                   d[l-1] = tmp ;
                   i = i - p ;
                   flips = 1 ;
                  }
               } while (flips == 1 && i >= 1) ;
            }
        } 
       
  }

/* ****************************************** */
/*                    stdnorm                 */
/* generate vector of i.i.d. standard normals */
/* ****************************************** */

void stdnorm(hold, n)
double hold[] ;
int n ;
{
void normvar() ;
double normvect[2] ;
int i, j ;

for (i = 0; i < n; i+=2)
   {
    normvar(normvect) ;
    hold[i] = normvect[0] ;
    if (i < n-1)
        hold[i+1] = normvect[1] ;
   }
   
} 



/* triinvrt -- inverse of double-precision upper triangular matrix */
/* A is the matrix, n is its dimension, hold is a double prec work vector of
   length n */
/* so inverse is overwritten into A */

double triinvrt(A, n, hold)
double A[], hold[] ;
int n ;

{
int i, j, k ;
double aii ;

for (i = 0; i < n; i++)
  {
   A[n*i + i] = 1.0 / A[n * i + i] ;
   aii = -A[n * i + i] ;
   if (i > 0)
     { 
      for (j = 0; j < i; j++)
         {
          hold[j] = 0 ;
          for (k = j; k < i; k++)
             hold[j] += A[n * j + k] * A[n * k + i] ;
          A[n * j + i] = aii * hold[j] ;
         }
      }
  }
}
      
      
/* triinvrtl -- inverse of double-precision lower triangular matrix */
/* A is the matrix, n is its dimension, hold is a double prec work vector of
   length n */
/* so inverse is overwritten into A */

double triinvrtl(A, n, hold)
double A[], hold[] ;
int n ;

{
int i, j, k ;
double aii, tol = 0.0000000000001 ;

for (i = 0; i < n; i++)
  {
   if (A[n * i + i] < tol)
        {
         printf("Error 1 in triinvrtl \n") ;
         exit(1) ;
        }
   A[n*i + i] = 1.0 / A[n * i + i] ;
   aii = -A[n * i + i] ;
   if (i > 0)
     { 
      for (j = 0; j < i; j++)
         {
          hold[j] = 0 ;
          for (k = j; k < i; k++)
             hold[j] += A[n * i + k] * A[n * k + j] ;
          A[n * i + j] = aii * hold[j] ;
         }
      }
  }
}
      
      




/* Generate a variate from a truncated normal */
/* Devroye's c.d.f. inversion algorithm */

double truncnrm(mu, sigma, a, b)
double mu, sigma, a, b ;
{
   double normalphi(), normalz(), drand48(), u, g, h, x ;

   u = drand48() ;
   h = normalphi( (a - mu) / sigma ) ;
   printf("%10.7f %10.7f\n", h, normalphi( (b - mu) / sigma) ) ; 
   g = h + u * (normalphi( (b - mu) / sigma) - h) ;
   x = mu + sigma * normalz(g) ;
   return(x) ;
}


/* Generate a Student's t variate with d.f. = nu1 */
/* Ratio of uniforms algorithm */

double tvar(nu1) 
int nu1 ;
{
   double a, bmin, bplus, u, u1, u2, x, v, bdiff ;
   double sqrt(),  pow(), drand48() ;
   int done ; 

   a = 1.0 ;
   bplus = sqrt( (2.0 * nu1) / ( nu1 - 1.0) * pow( ((nu1 + 1.0)/(nu1 - 1.0)),
           ( -(nu1 + 1.0) / 2.0))) ;
   bmin = -1.0 * bplus ;
   bdiff = bplus - bmin ;
   done = 0 ;
   while (done == 0)
     { 
     u1 = drand48() ;
     u2 = drand48() ;
     u = a * u1 ;
     v = bmin + bdiff * u2 ;
     x = v / u ;
     if (u <= pow( (1.0 + x * x / nu1) , - (nu1 + 1.0)/4.0  ) )  
        done = 1 ;
      }
     return(x) ;
}


   /* **************** */
   /*     updtseed     */
   /* Update seed file */
   /* **************** 

updtseed()

{
   FILE *out ;
   int i ;
   unsigned short *seed48() ;

   myptr = seed48(seed16v) ;
   out = fopen("/space/kcowles/libraries/seedfile","w") ;
   for (i = 0; i < 3; i++)
       fprintf( out, "%10u", *(myptr + i) ) ;
   fprintf( out, "\n" ) ;
   fclose(out) ;
}
*/


/* Multiply a column vector times a row vector to return a matrix */

void vectmult(colv,rowv,collen,rowlen,retmat)
double colv[], rowv[], retmat[] ;
int collen, rowlen ;
{
   int i, j ;
   for (i = 0; i < collen; i++) 
      {
       for (j = 0; j < rowlen; j++) 
          retmat[rowlen * i + j] = colv[i] * rowv[j] ;
      }
}

/* Return the l-infinity norm of a vector */

double vectnorm(marray,n)
double marray[] ;
int n;
{
double norm = 0.0 ;
int i ;
for (i = 0; i < n; i++)
   {
    if (dabs(marray[i]) > norm)
       norm = dabs(marray[i]) ;
   }
return(norm) ;
}


/* Generate double prec Weibull variate; Kalbfleish & Prentice param */

double weibvar( lambda, p )
double lambda, p;

{
  double y, u, temp, drand48(), pow(), log() ;
  long i,j,k ;

  u = drand48() ;

  temp = - log(1.0 -u) ;

  y = pow( temp, (1.0 / p) ) / lambda ;

  return(y) ;

}


/* Generate a random Wishart matrix -- Odell and Feiveson algorithm */

void wishart(parmmat, df, n, retmat)
int df, n ;
double parmmat[], retmat[] ;
{
   unsigned int i, j, k, l, nsq ;
   double  gammavar(), normvect[2];
   void normvar(),mattrans(), chol(), matmult() ;
   double sqrt() ;
   long p = n ;
   char *calloc() ;
   double *chisqs, *normals, *cholparm, *choltran, *temp1, *temp2, *work ;
   long *jpvt ;
   char *malloc() ;

   nsq = n*n; 
   chisqs = (double *) malloc(n* sizeof (double) ) ;
   normals = (double *) malloc(nsq* sizeof (double) ) ;
   cholparm = (double *) malloc(nsq* sizeof (double) ) ;
   choltran = (double *) malloc(nsq* sizeof (double) ) ;
   temp1 = (double *) malloc(nsq* sizeof (double) ) ;
   temp2 = (double *) malloc(nsq* sizeof (double) ) ;
   work = (double *) malloc(n* sizeof (double) ) ;
   jpvt = (long *) malloc(n* sizeof (double) ) ;

for (i = 0; i < (n) ; i++) chisqs[i]=0;
for (i = 0; i < (nsq) ; i++) normals[i]=0;
for (i = 0; i < (nsq) ; i++) cholparm[i]=0;
for (i = 0; i < (nsq) ; i++) choltran[i]=0;
for (i = 0; i < (nsq) ; i++) temp1[i]=0;
for (i = 0; i < (nsq) ; i++) temp2[i]=0;
for (i = 0; i < (n) ; i++) work[i]=0;
for (i = 0; i < (n) ; i++) jpvt[i]=0;

   for (i = 0; i < n; i++)
      {
       chisqs[i] = gammavar( (double) (df - i) / 2.0, 0.5) ;
       for (j=0; j < n; j+= 2)
          {
           normvar(normvect) ;
           normals[i * n + j] = normvect[0] ;
           if (j < n-1)
              normals[i * n + j + 1] = normvect[1] ; 
          }
      }
   temp1[0] = chisqs[0] ;
   for (j = 1; j < n; j++ )
      {
       temp1[(n + 1) * j] = chisqs[j] ;
       for (i = 0; i < j; i++)
          {
           l = n * i + j ;
           temp1[(n + 1) * j] += (normals[l] * normals[l] ) ;
           if (i != j)
              {
               temp1[l] = normals[l] * sqrt(chisqs[i]) ;
               for (k = 0; k < i; k++)
                  temp1[l] += (normals[n * k + i] * normals[n * k + j] ) ;
               temp1[n * j + i] = temp1[l] ;
              }
          }
      }

   /* cholparm will be lower triangular choleski decomp of parmmat */ 

   chol(parmmat, cholparm, n) ;

   mattrans(cholparm, choltran, n, n) ;    /* choltran = cholparm transposed */

   matmult(cholparm, temp1, n, n, n, temp2) ;
   matmult(temp2, choltran, n, n, n, retmat) ;

free(   chisqs );
 free(  normals); 
free(   cholparm); 
free(   choltran); 
free(   temp1); 
free(   temp2); 
free(   work); 
free(   jpvt);

} 



void wish2_2(parmmat, df, retmat)
int df ;
double parmmat[], retmat[] ;

{
    double  gammavar(), normvect[2];
    void normvar(),mattrans(), chol(), matmult() ;
    double sqrt(), chisqs[2], normals, cholparm[2][2], choltran[2][2] ;
    double temp1[2][2], temp2[2][2] ;
    long  i, j, k ;


    for (i = 0; i < 2; i++)
       chisqs[i] = gammavar( (double)( df - i) / 2.0, 0.5 );

    normvar(normvect) ;
    normals = normvect[0] ;

    temp1[0][0] = chisqs[0] ;
    temp1[0][1] = temp1[1][0] = normals * sqrt(chisqs[0]) ;
    temp1[1][1] = chisqs[1] + normals * normals ;

    chol(parmmat, cholparm,2) ;
    mattrans(cholparm, choltran, 2,2) ;
    matmult(cholparm, temp1, 2,2,2, temp2) ;
    matmult(temp2, choltran, 2,2,2, retmat) ;

}

void wish2_2nint(parmmat, df, retmat)
double parmmat[], retmat[], df ;

{
    double  gammavar(), normvect[2];
    void normvar(),mattrans(), chol(), matmult() ;
    double sqrt(), chisqs[2], normals, cholparm[2][2], choltran[2][2] ;
    double temp1[2][2], temp2[2][2] ;
    long  i, j, k ;


    for (i = 0; i < 2; i++)
      {
       chisqs[i] = gammavar( (df - (double) i) / 2.0, 0.5 );
       printf("chisqs[%d] %7.4f \n", i, chisqs[i]) ;
      }

    normvar(normvect) ;
    normals = normvect[0] ;

    temp1[0][0] = chisqs[0] ;
    temp1[0][1] = temp1[1][0] = normals * sqrt(chisqs[0]) ;
    temp1[1][1] = chisqs[1] + normals * normals ;

    chol(parmmat, cholparm,2) ;
    mattrans(cholparm, choltran, 2,2) ;
    matmult(cholparm, temp1, 2,2,2, temp2) ;
    matmult(temp2, choltran, 2,2,2, retmat) ;

}
