! This program takes output from the QHULL package and converts it into
! a format suitable for use with the GeomGen script
! J.Grogan 05/08/11
program Voronoi3DPost
!
!	Parameters
	parameter(max_verts=500000,max_cells=50000,max_verts_in_cell=100)
	parameter(max_hyps=500000,max_hyp_in_cell=100,max_verts_on_hyp=50)
!
!	Variables
    character(len=256)full_line,test_string
	integer	num_verts(max_cells)
    integer vert_list(max_cells,max_verts_in_cell)
	integer facet(2,max_hyps)
    integer hyp_list(max_cells,max_hyp_in_cell)
	integer num_cell_hyp(max_cells)
	integer cell_status(max_cells)
	integer	num_hyp_verts(max_cells,max_hyp_in_cell)
    integer hyp_vert_list(max_cells,max_hyp_in_cell,max_verts_on_hyp)
    double precision xv_cor(max_verts)
    double precision yv_cor(max_verts)
    double precision zv_cor(max_verts)
    double precision cor(3,max_hyps)
    double precision offset(max_hyps)
	double precision xcor,ycor,zcor
	double precision dotrprod,distance,tol
	logical xtrue,ytrue,ztrue
!
!	Open output files
    open(unit=12,file='fortranout.dat',status='unknown')
!
!	Open scales file
	open(unit=15,file='scales.dat',status='unknown')
    read(15,*)rmaxscale
!
!	Read tessellation results from QHULL
    open(unit=11,file='qhullout.dat',status='unknown')
	read(11,*)
	read(11,*)num_total_verts,num_cells
!
!	Read in all vertice co-ordinates
    do i=1,num_total_verts
       read(11,*)xv_cor(i),yv_cor(i),zv_cor(i)
    enddo
!
!	Read in vertice labels for each voronoi cell
    do i=1,num_cells
         read(11,*)num_verts(i)
		 backspace(11)
		 if(num_verts(i)>9)then
			read(11,'(i3,a256)')idummy,full_line
		else
			read(11,'(i2,a256)')idummy,full_line
		endif
         ileft=1
         num_points=1
         do iright=1,256
             test_string=full_line(iright:iright)
             if((test_string==' ').or.(iright==256))then
                 read(full_line(ileft:iright-1),'(i6)')vert_list(i,num_points)
                 if(num_points==num_verts(i))exit
                 ileft=iright+1
                 num_points=num_points+1
             endif
         enddo
    enddo
!
!	Read in bounded hyperplane cell labels and co-ordinates
     read(11,*)num_hyp
     do i=1,num_hyp
       read(11,*)dummy,facet(1,i),facet(2,i),cor(1,i),cor(2,i),cor(3,i),offset(i)
     enddo
!
!	Determine hyperplanes of each cell
	do i=1,num_cells
    	num_hy=1
    	do j=1,num_hyp
        	if((facet(1,j)==i-1).or.(facet(2,j)==i-1))then
            	hyp_list(i,num_hy)=j
                num_cell_hyp(i)=num_hy
                num_hy=num_hy+1
            endif
        enddo
    enddo
!
!	Check if any cell vertices are outside the chosen tolerance
    do i=1,num_cells
        cell_status(i)=1
		if(num_verts(i)<3)cycle
		ibreak=0
		do j=1,num_verts(i)
			do k=1,num_verts(i)
				if(j==k)cycle
				x1=xv_cor(vert_list(i,j)+1)
				y1=yv_cor(vert_list(i,j)+1)
				z1=zv_cor(vert_list(i,j)+1)
				x2=xv_cor(vert_list(i,k)+1)
				y2=yv_cor(vert_list(i,k)+1)
				z2=zv_cor(vert_list(i,k)+1)
				dist=sqrt((x2-x1)*(x2-x1)+(y2-y1)*(y2-y1)+(z2-z1)*(z2-z1))
				if (dist<1.e-5)ibreak=1
			enddo
		enddo
		if(ibreak==1)cycle
        do j=1,num_verts(i)
			xcor=xv_cor(vert_list(i,j)+1)
			ycor=yv_cor(vert_list(i,j)+1)
			zcor=zv_cor(vert_list(i,j)+1)
			rmax=1.1*rmaxscale
			rmin=-0.1
			xtrue=(xcor<rmax).and.(xcor>rmin)
			ytrue=(ycor<rmax).and.(ycor>rmin)
			ztrue=(zcor<rmax).and.(zcor>rmin)
            if(xtrue.and.ytrue.and.ztrue)cell_status(i)=0
        enddo
    enddo
!
!	For all cells within tolerance determine vertices on each hyperplane
	num_skipped=0
	tol=1.e-5*rmaxscale
	do i=1,num_cells
    	if(cell_status(i)/=0)then
        	num_skipped=num_skipped+1
            cycle
        endif
        do j=1,num_cell_hyp(i)
          	nverts_on_hyp=1
            do k=1,num_verts(i)
              	dotprod1=cor(1,hyp_list(i,j))*xv_cor(vert_list(i,k)+1)
              	dotprod2=cor(2,hyp_list(i,j))*yv_cor(vert_list(i,k)+1)
              	dotprod3=cor(3,hyp_list(i,j))*zv_cor(vert_list(i,k)+1)
              	distance=dotprod1+dotprod2+dotprod3+offset(hyp_list(i,j))
              	if(abs(distance)<tol)then
                	hyp_vert_list(i,j,nverts_on_hyp)=vert_list(i,k)
                    num_hyp_verts(i,j)=nverts_on_hyp
                    nverts_on_hyp=nverts_on_hyp+1
              	endif
            enddo
        enddo
    enddo
!	Write output for the of co-orindates of vertices on each hyperplane
!	that make up a cell.
    write(12,*)num_cells-num_skipped
	do i=1,num_cells
    	if(cell_status(i)/=0)cycle
        write(12,*)num_cell_hyp(i)
        do j=1,num_cell_hyp(i)
			write(12,*)num_hyp_verts(i,j)
			do k=1,num_hyp_verts(i,j)
				xcor=xv_cor(hyp_vert_list(i,j,k)+1)
				ycor=yv_cor(hyp_vert_list(i,j,k)+1)
				zcor=zv_cor(hyp_vert_list(i,j,k)+1)
				write(12,'(2(f20.15,a),f20.15)')xcor,',',ycor,',',zcor
			enddo
        enddo
    enddo
end program


      LOGICAL FUNCTION SB02OV( ALPHAR, ALPHAI, BETA )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To select the unstable generalized eigenvalues for solving the
C     discrete-time algebraic Riccati equation.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     ALPHAR  (input) DOUBLE PRECISION
C             The real part of the numerator of the current eigenvalue
C             considered.
C
C     ALPHAI  (input) DOUBLE PRECISION
C             The imaginary part of the numerator of the current
C             eigenvalue considered.
C
C     BETA    (input) DOUBLE PRECISION
C             The (real) denominator of the current eigenvalue
C             considered.
C
C     METHOD
C
C     The function value SB02OV is set to .TRUE. for an unstable
C     eigenvalue (i.e., with modulus greater than or equal to one) and
C     to .FALSE., otherwise.
C
C     REFERENCES
C
C     None.
C
C     NUMERICAL ASPECTS
C
C     None.
C
C     CONTRIBUTOR
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Sep. 1997.
C     Supersedes Release 2.0 routine SB02CX by P. Van Dooren, Philips
C     Research Laboratory, Brussels, Belgium.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Algebraic Riccati equation, closed loop system, continuous-time
C     system, optimal regulator, Schur form.
C
C     ******************************************************************
C
C     .. Scalar Arguments ..
      DOUBLE PRECISION   ALPHAR, ALPHAI, BETA
C     .. External Functions ..
      DOUBLE PRECISION   DLAPY2
      EXTERNAL           DLAPY2
C     .. Intrinsic Functions ..
      INTRINSIC          ABS
C     .. Executable Statements ..
C
      SB02OV = DLAPY2( ALPHAR, ALPHAI ).GE.ABS( BETA )
C
      RETURN
C *** Last line of SB02OV ***
      END


c=======================================================================
      subroutine dpdenregr(nrec,nx,nvar,nmissi,nmiss,z,missp,npred,
     &                     xpred,ngrid,grid,
     &                     a0b0,k0,nuvec,s2inv,
     &                     s2invm2,
     &                     psiinv2,tau,mcmc,nsave,
     &                     cpo,thetasave,denspm,denspl,densph,
     &                     meanfpm,meanfpl,meanfph,
     &                     alpha,m1,muclus,ncluster,
     &                     psi1,psiinv1,s1,sigmaclus,ss,ccluster,cstrt,
     &                     iflag,num,denom,fs,fm,
     &                     muwork,prob,seed,sigmawork,sigworkinv,theta,
     &                     workm1,workm2,workm3,workmh1,workmh2,workv1,
     &                     workv2,workv3,ywork,
     &                     iflagx,workvx,workmx,worksam,
     &                     numcpo,denomcpo)
c=======================================================================
c     # of arguments = 63.
c
c     Subroutine `dpdenregr' to run a Markov chain in the DP mixture of
c     normals model for conditional density estimation.
c
c     In this routine, inference is based on the
c     Polya urn representation of the Dirichlet process. The algorithm
c     8 of Neal (2000) is used with m=1.
c
c     Copyright: Alejandro Jara, 2008-2010.
c
c     Version 1.0:
c
c     Last modification: 25-06-2008.
c
c     This program is free software; you can redistribute it and/or modify
c     it under the terms of the GNU General Public License as published by
c     the Free Software Foundation; either version 2 of the License, or (at
c     your option) any later version.
c
c     This program is distributed in the hope that it will be useful, but
c     WITHOUT ANY WARRANTY; without even the implied warranty of
c     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
c     General Public License for more details.
c
c     You should have received a copy of the GNU General Public License
c     along with this program; if not, write to the Free Software
c     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
c
c     The author's contact information:
c
c      Alejandro Jara
c      Department of Statistics
c      Facultad de Matematicas
c      Pontificia Universidad Catolica de Chile
c      Casilla 306, Correo 22
c      Santiago
c      Chile
c      Voice: +56-2-3544506  URL  : http://www.mat.puc.cl/~ajara
c      Fax  : +56-2-3547729  Email: atjara@uc.cl
c
c---- Data -------------------------------------------------------------
c
c        nmissi      :  integer indicating whether the data contain
c                       (1) or not (0) missing data.
c        nmiss       :  integer giving the number of missing data
c                       points.
c        missp       :  integer matrix giving the location of the
c                       missing data points, missp(nmiss,2).
c        nrec        :  integer giving the number of observations.
c        nvar        :  integer giving the number of variables.
c        nx          :  integer giving the number of predictors.
c        z           :  real matrix giving the response variables,
c                       z(nrec,nvar).
c
c---- Predictions ------------------------------------------------------
c
c        cband       :  integer value indicating whether the
c                       credible bands need to be computed or not.
c        ngrid       :  integer giving the size of the grid where
c                       the densities will be evaluated.
c        grid        :  real vector giving the grid of values for
c                       the response, grid(ngrid).
c        npred       :  integer giving the number of predictions.
c        tband       :  integer indicating the type of credible
c                       band that need to be computed.
c        xpred       :  real matrix giving the value of the
c                       predictors for prediction, xpred(npred,nx).
c
c-----------------------------------------------------------------------
c
c---- Prior information ------------------------------------------------
c
c        aa0, ab0    :  reals giving the hyperparameters of the prior
c                       distribution for the precision parameter,
c                       alpha ~ Gamma(aa0,ab0). If aa0<0 the precision
c                       parameter is considered as a constant.
c        nu1         :  integer giving the degrees of freedom for the
c                       inverted-Wishart component of the baseline
c                       distribution.
c        nu2         :  integer giving the degrees of freedom for the
c                       inverted-Wishart prior distribution for the
c                       covariance matrix of the normal component of
c                       the baseline distribution.
c        m1rand      :  integer indicating wether m1 should be held
c                       fix, 0, or random, 1.
c        s2inv       :  real matrix giving the precision of the normal
c                       prior distribution on the mean of the normal
c                       component of the baseline distribution,
c                       s2inv(nvar,nvar).
c        s2invm2     :  real vector giving the the product of precision
c                       matrix and the prior mean of the normal
c                       prior distribution on the mean of the normal
c                       component of the baseline distribution,
c                       s2ivm2(nvar).
c        tau1, tau2  :  reals giving the hyperparameters of the prior
c                       distribution for k0, k0 ~ Gamma(tau1/2,tau2/2).
c        psiinv2     :  real matrix giving the inverse of the scale
c                       matrix for the inverted-Wishart prior on the
c                       variance matrix of the normal component of
c                       the baseline distribution, psiinv2(nvar,nvar).
c
c        NOTE        :  the inverted-Wishart here is parametrized,
c                       sigma ~ Inv-Wishart(nu0,tinv^{-1}), such that
c                       E(sigma)=(1/(nu0-q-1)) * tinv
c
c-----------------------------------------------------------------------
c
c---- MCMC parameters --------------------------------------------------
c
c        nburn       :  integer giving the number of burn-in scans.
c        ndisplay    :  integer giving the number of saved scans to be
c                       displayed on screen.
c        nskip       :  integer giving the thinning interval.
c        nsave       :  integer giving the number of scans to be saved.
c
c-----------------------------------------------------------------------
c
c---- Output -----------------------------------------------------------
c
c        cpo         :  real matrix giving the cpo's.
c        thetasave   :  real matrix containing the mcmc samples for
c                       the parameters,
c        meansave    :  real matrix containing the mcmc samples for
c                       the conditional means.
c                       thetasave(nsave,nvar+nvar*(nvar+1)/2+3).
c        denspm      :  real matrix giving the posterior means for the
c                       conditional densities, denspm(npred,ngrid).
c        denspl      :  real matrix giving the lower limit for the
c                       95%HPD for the conditional densities,
c                       denspl(npred,ngrid).
c        densph      :  real matrix giving the upper limit for the
c                       95%HPD for the conditional densities,
c                       densph(npred,ngrid).
c        meanfpm     :  real vector giving the posterior means for the
c                       conditional means, meanfpm(npred).
c        meanfpl     :  real vector giving the lower limit for the
c                       95%HPD for the conditional means,
c                       meanfpl(npred).
c        meanfph     :  real vector giving the upper limit for the
c                       95%HPD for the conditional means,
c                       meanfph(npred).
c
c-----------------------------------------------------------------------
c
c---- Current value of the parameters ----------------------------------
c
c        alpha       :  real giving the current value of the precision
c                       parameter of the Dirichlet process.
c        k0          :  real giving the precision parameter for the
c                       normal baseline
c        m1          :  real vector giving the mean of the normal
c                       component of the baseline distribution, m1(nvar)
c        muclus      :  real matrix giving the current value of the
c                       means, muclus(nrec+2,nvar).
c        ncluster    :  integer giving the number of clusters in the
c                       data.
c        psi1        :  real matrix giving the scale matrix for the
c                       inverted-Wishart component of the baseline
c                       distribution, psi1(nvar,nvar).
c        psiinv1     :  real matrix giving the inverse of the scale
c                       matrix for the inverted-Wishart component of
c                       the baseline distribution, psiinv1(nvar,nvar).
c        sigmaclus   :  real matrix giving the current value of the
c                       variances, sigmaclus(nrec+2,nvar*(nvar+1)/2) .
c        ss          :  integer vector giving the cluster label for
c                       each record, ss(nrec).
c
c-----------------------------------------------------------------------
c
c---- Working space ----------------------------------------------------
c
c        ccluster    :  integer vector indicating the number of
c                       subjects in each cluster, ccluster(nrec).
c        cstrt       :  integer matrix used to save the cluster
c                       structure, cstrt(nsave,nsave).
c        count       :  index.
c        detlog      :  real used to save the log-determinant in an
c                       matrix inversion process.
c        denom       :  real matrix used to evaluate the conditional
c                       densities, denom(npred).
c        dispcount   :  index.
c        dnrm        :  density of a normal distribution.
c        evali       :  integer indicator used in updating the state.
c        fs          :  real vector used to evaluate the conditional
c                       densities, fs(ngrid).
c        fm          :  real vector used to evaluate the conditional
c                       means, fs(npred).
c        i           :  index.
c        ii          :  index.
c        ihmssf      :  integer function to determine the position of a
c                       half-stored matrix.
c        iflag       :  integer vector used to evaluate the mvn density,
c                       iflag(nvar).
c        iflagx      :  integer vector used to evaluate the mvn density,
c                       iflagx(nx).
c        isave       :  index.
c        iscan       :  index.
c        j           :  index.
c        k           :  index.
c        l           :  index.
c        l1          :  index.
c        l2          :  index.
c        muwork      :  real vector used to save the mean,
c                       one observation, muwork(nvar).
c        num         :  real matrix used to evaluate the conditional
c                       densities, num(npred,ngrid).
c        ns          :  integer indicator used in updating the state.
c        nscan       :  integer indicating the total number of MCMC
c                       scans.
c        nuniqs      :  integer giving the dimension of the half-stored
c                       covariance matrix.
c        nuwork      :  index.
c        prob        :  real vector used to update the cluster
c                       structure, prob(nrec+2).
c        rgamma      :  gamma random number generator
c        s1          :  real matrix giving the covariance matrix of
c                       the normal component of the baseline
c                       distribution, s1(nvar,nvar).
c        seed1       :  seed for random number generation.
c        seed2       :  seed for random number generation.
c        seed3       :  seed for random number generation.
c        sigmawork   :  real matrix used to save the variance of
c                       one observation, sigmawork(nvar,nvar).
c        sigworkinv  :  real matrix used to save the inverse of the
c                       variance of one observation,
c                       sigworkinv(nvar,nvar).
c        since       :  index.
c        skipcount   :  index.
c        theta       :  real vector used to save randomnly generated
c                       mean vector, theta(nvar).
c        tmp1        :  real working variable.
c        tmp2        :  real working variable.
c        workm1      :  real matrix used to update the cluster
c                       structure, workm1(nvar,nvar).
c        workm2      :  real matrix used to update the cluster
c                       structure, workm2(nvar,nvar).
c        workm3      :  real matrix used to update the cluster
c                       structure, workm3(nvar,nvar).
c        workmx      :  real matrix used to evaluate the
c                       conditional densities, workmn(nx,nx).
c        workmh1     :  real vector used to update the cluster
c                       structure, workmh1(nvar*(nvar+1)/2).
c        workmh2     :  real vector used to update the cluster
c                       structure, workmh2(nvar*(nvar+1)/2).
c        worksam     :  real matrix used to store samples,
c                       worksam(ngrid).
c        workv1      :  real vector used to update the cluster
c                       structure, workv1(nvar).
c        workv2      :  real vector used to update the cluster
c                       structure, workv2(nvar).
c        workv3      :  real vector used to update the cluster
c                       structure, workv3(nvar).
c        workvx      :  real vector used to evaluate the
c                       conditional densities, workvx(nx).
c        ywork       :  real vector used to save the variables of,
c                       one observation, ywork(nvar).
c
c=======================================================================

      implicit none

c+++++Data
      integer nrec,nx,nvar,nmissi,nmiss
      integer missp(nmiss,2)
      real*8 z(nrec,nvar)

c+++++Prediction
      integer cband,npred,ngrid,tband
      real*8 xpred(npred,nx)
      real*8 grid(ngrid)

c+++++Prior
      integer nuvec(3),nu1,nu2,m1rand
      real*8 aa0,ab0,a0b0(2)
      real*8 psiinv2(nvar,nvar)
      real*8 tau(2),tau1,tau2
      real*8 s2inv(nvar,nvar),s2invm2(nvar)

c+++++MCMC parameters
      integer mcmc(5),nburn,nskip,nsave,ndisplay

c+++++Output
      real*8 cpo(nrec,2)
      real*8 thetasave(nsave,nvar+nvar*(nvar+1)/2+3)
      real*8 denspm(npred,ngrid)
      real*8 denspl(npred,ngrid)
      real*8 densph(npred,ngrid)
      real*8 meanfpm(npred)
      real*8 meanfpl(npred)
      real*8 meanfph(npred)

c+++++Current values of the parameters
      integer ncluster,ss(nrec)
      real*8 alpha,k0,m1(nvar),muclus(nrec+100,nvar)
      real*8 psi1(nvar,nvar),psiinv1(nvar,nvar)
      real*8 sigmaclus(nrec+100,nvar*(nvar+1)/2)

c+++++Seeds
      integer seed(2),seed1,seed2

c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c+++++External working space
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      integer ccluster(nrec)
      integer cstrt(nrec,nrec)
      integer iflag(nvar)
      integer iflagx(nx)
      real*8 muwork(nvar),prob(nrec+100)
      real*8 s1(nvar,nvar)
      real*8 sigmawork(nvar,nvar),sigworkinv(nvar,nvar)
      real*8 theta(nvar)
      real*8 workm1(nvar,nvar),workm2(nvar,nvar),workm3(nvar,nvar)
      real*8 workmh1(nvar*(nvar+1)/2),workmh2(nvar*(nvar+1)/2)
      real*8 workv1(nvar),workv2(nvar),workv3(nvar)
      real*8 ywork(nvar)

      real*8 workvx(nx)
      real*8 workmx(nx,nx)

      real*8 num(npred,ngrid)
      real*8 denom(npred)
      real*8 fs(ngrid)
      real*8 fm(npred)

      real*8 worksam(nsave)

      real*8 numcpo(nrec),denomcpo(nrec)

c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c+++++Internal working space
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

c+++++General
      integer counter,evali
      integer i,ii,ihmssf,j,jj,k,l,nuniqs,nuwork,ns,ok
      integer since,sprint
      integer isample

      real*8 detlog,detlogx
      real*8 muc,sigmac
      real*8 tmp1,tmp2,tmp3,tmp4,tmp5,tmp6,tmp7
      real*8 tpi
      real*8 cpotest
      parameter(tpi=6.283185307179586476925286766559d0)

c+++++MCMC
      integer dispcount,isave,iscan,nscan,skipcount

c+++++RNG and distributions
      real*8 dnrm,rnorm,rgamma

c+++++DP (functional parameter)
      real*8 eps,rbeta,weight
      parameter(eps=0.01)

c+++++CPU time
      real*8 sec00,sec0,sec1,sec

c++++ Define parameters

      aa0=a0b0(1)
      ab0=a0b0(2)

      tau1=tau(1)
      tau2=tau(2)

      nburn=mcmc(1)
      nskip=mcmc(2)
      ndisplay=mcmc(3)
      cband=mcmc(4)
      tband=mcmc(5)

      nuniqs=nvar*(nvar+1)/2
      nu1=nuvec(1)
      nu2=nuvec(2)
      m1rand=nuvec(3)

      cpotest=0.d0

c++++ opening files

      open(unit=1,file='dppackage1.out',status='unknown',
     &     form='unformatted')

      open(unit=2,file='dppackage2.out',status='unknown',
     &     form='unformatted')

c++++ set random number generator

      seed1=seed(1)
      seed2=seed(2)

      call setall(seed1,seed2)

c++++ cluster structure

      do i=1,nrec
         ccluster(ss(i))=ccluster(ss(i))+1
         cstrt(ss(i),ccluster(ss(i)))=i
      end do

c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c++++ start the MCMC algorithm
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      isample=1
      isave=0
      skipcount=0
      dispcount=0
      nscan=nburn+(nskip+1)*(nsave)

      call cpu_time(sec0)
      sec00=0.d0

      do iscan=1,nscan

c+++++++++++++++++++++++++++++++++++++++++
c+++++++ Imputing the missing data
c+++++++++++++++++++++++++++++++++++++++++

         if(nmissi.eq.1)then

c++++++++++ check if the user has requested an interrupt
            call rchkusr()

            do ii=1,nmiss

               i=missp(ii,1)
               jj=missp(ii,2)

               do j=1,nvar
                  muwork(j)=muclus(ss(i),j)
                  do k=1,nvar
                     sigmawork(j,k)=sigmaclus(ss(i),ihmssf(j,k,nvar))
                  end do
               end do

               call condmvn(jj,sigmawork,nvar,workm1,workm2)
               tmp1=sqrt(workm1(1,1))

               do k=1,nvar
                  tmp2=0.d0
                  do l=1,nvar
                     tmp2=tmp2+workm2(k,l)*muwork(l)
                  end do
                  workv2(k)=tmp2

                  tmp2=0.d0
                  do l=1,nvar
                     tmp2=tmp2+workm2(k,l)*z(i,l)
                  end do
                  workv3(k)=tmp1
               end do

               tmp2=muwork(jj)
               do k=2,nvar
                  tmp2=tmp2-workm1(1,k)*(workv3(k)-workv2(k))
               end do

               z(i,jj)=rnorm(tmp2,tmp1)
            end do
         end if

c++++++++++++++++++++++++++++++++++
c+++++++ DP part
c++++++++++++++++++++++++++++++++++

c++++++++++++++++++++++++++++++
c+++++++ a) configurations
c++++++++++++++++++++++++++++++

c         call intpr("Step 1a",-1,0,1)

         do i=1,nrec

            ns=ccluster(ss(i))

c++++++++++ observation in cluster with more than 1 element

            if(ns.gt.1)then

               ccluster(ss(i))=ccluster(ss(i))-1

               j=1
               ok=0
               do while(ok.eq.0.and.j.le.ns)
                  if(cstrt(ss(i),j).eq.i)ok=j
                  j=j+1
               end do

               do j=ok,ns-1
                  cstrt(ss(i),j)=cstrt(ss(i),j+1)
               end do

               isample=1
            end if

c++++++++++ observation in cluster with only 1 element

            if(ns.eq.1)then

               since=ss(i)

               if(since.lt.ncluster)then

                   call relabelddr(i,since,nrec,nvar,ncluster,
     &                             ccluster,cstrt,ss,muclus,sigmaclus,
     &                             muwork,sigmawork)
               end if

               ccluster(ncluster)=ccluster(ncluster)-1
               ncluster=ncluster-1

               isample=2
            end if

c++++++++++ sampling

            do j=1,nvar
               ywork(j)=z(i,j)
            end do

            do j=1,ncluster
               do k=1,nvar
                  muwork(k)=muclus(j,k)
                  do l=1,nvar
                     sigmawork(k,l)=sigmaclus(j,ihmssf(k,l,nvar))
                  end do
               end do

               call dmvn(nvar,ywork,muwork,sigmawork,tmp1,
     &                   workv1,workm1,workm2,workv2,iflag)

               prob(j)=dble(ccluster(j))*exp(tmp1)
            end do

            if(isample.eq.1)then

               do k=1,nvar
                  do l=1,nvar
                     workm3(k,l)=psiinv1(k,l)
                  end do
               end do

               call riwishart(nvar,nu1,workm3,workm1,workm2,workv1,
     &                        workmh1,workmh2,iflag)

               do k=1,nvar
                  do l=1,nvar
                     s1(k,l)=workm3(k,l)/k0
                     sigmaclus(ncluster+1,ihmssf(k,l,nvar))=
     &                      workm3(k,l)
                  end do
               end do

               call rmvnorm(nvar,m1,s1,workmh1,workv1,theta)

               do k=1,nvar
                  muclus(ncluster+1,k)=theta(k)
               end do
            end if

            do k=1,nvar
                  muwork(k)=muclus(ncluster+1,k)
                  do l=1,nvar
                  sigmawork(k,l)=
     &                     sigmaclus(ncluster+1,ihmssf(k,l,nvar))
               end do
            end do

            call dmvn(nvar,ywork,muwork,sigmawork,tmp1,
     &                workv1,workm1,workm2,workv2,iflag)

            prob(ncluster+1)=alpha*exp(tmp1)

            call simdisc(prob,nrec+100,ncluster+1,evali)

            if(evali.le.ncluster)then
               ss(i)=evali
               ccluster(evali)=ccluster(evali)+1
               cstrt(evali,ccluster(evali))=i
            end if

            if(evali.gt.ncluster)then
               ncluster=ncluster+1
               ss(i)=ncluster
               ccluster(ncluster)=1
               cstrt(ncluster,ccluster(ncluster))=i
               do j=1,nvar
                  muclus(ncluster,j)=muclus(evali,j)
                  do k=j,nvar
                     sigmaclus(ncluster,ihmssf(j,k,nvar))=
     &                         sigmaclus(evali,ihmssf(j,k,nvar))
                  end do
               end do
            end if

         end do

c++++++++++++++++++++++++++++++
c+++++++ b) Resampling step
c++++++++++++++++++++++++++++++

c         call intpr("Step 1b",-1,0,1)

         do ii=1,ncluster

c++++++++++ check if the user has requested an interrupt
            call rchkusr()

c++++++++++ cluster's means and variances

            ns=ccluster(ii)

            do i=1,nvar
               workv1(i)=m1(i)*(dble(k0)/(dble(k0)+dble(ns)))
               workv2(i)=0.d0
            end do

            do i=1,ns
               do j=1,nvar
                  workv2(j)=workv2(j)+z(cstrt(ii,i),j)
               end do
            end do

            do i=1,nvar
               workv2(i)=workv2(i)/dble(ns)
               muwork(i)=workv1(i)+workv2(i)*
     &                  (dble(ns)/(dble(k0)+dble(ns)))
            end do

            do i=1,nvar
               do j=1,nvar
                  workm1(i,j)=0.d0
                  workm2(i,j)=0.d0
               end do
            end do

            do i=1,ns
               do j=1,nvar
                  do k=1,nvar
                     workm1(j,k)=workm1(j,k)+
     &                     (z(cstrt(ii,i),j)-workv2(j))*
     &                     (z(cstrt(ii,i),k)-workv2(k))
                  end do
               end do
            end do

            do i=1,nvar
               do j=1,nvar
                  workm1(i,j)=workm1(i,j)+psiinv1(i,j)
               end do
            end do

            do i=1,nvar
               do j=1,nvar
                  workm2(i,j)=workm2(i,j)+
     &                       (workv2(i)-m1(i))*
     &                       (workv2(j)-m1(j))
               end do
            end do

            do i=1,nvar
               do j=1,nvar
                  workm1(i,j)=workm1(i,j)+workm2(i,j)
     &                       *(dble(k0*ns)/dble(k0+ns))
               end do
            end do

            call riwishart(nvar,nu1+ns,workm1,workm2,workm3,workv1,
     &                     workmh1,workmh2,iflag)

            do i=1,nvar
               do j=i,nvar
                  sigmaclus(ii,ihmssf(i,j,nvar))=workm1(i,j)
               end do
            end do

            do i=1,nvar
               do j=1,nvar
                  sigmawork(i,j)=workm1(i,j)/dble(k0+ns)
               end do
            end do

            call rmvnorm(nvar,muwork,sigmawork,workmh1,workv1,theta)

            do i=1,nvar
               muclus(ii,i)=theta(i)
            end do
         end do

c++++++++++++++++++++++++++++++++++
c+++++++ Baseline distribution
c++++++++++++++++++++++++++++++++++

c+++++++ check if the user has requested an interrupt
         call rchkusr()

c+++++++ scale matrix of the inverted-Wishart component

c         call intpr("Step 2a",-1,0,1)

         if(nu2.gt.0)then

            do i=1,nvar
               do j=1,nvar
                  workm1(i,j)=0.d0
               end do
            end do

            do i=1,ncluster
               do j=1,nvar
                  do k=1,nvar
                     sigmawork(j,k)=
     &                           sigmaclus(i,ihmssf(j,k,nvar))
                  end do
               end do

               call invdet(sigmawork,nvar,sigworkinv,detlog,iflag,
     &                     workv3)

               do j=1,nvar
                  do k=1,nvar
                     workm1(j,k)=workm1(j,k)+sigworkinv(j,k)
                  end do
               end do
            end do

            do i=1,nvar
               do j=1,nvar
                  workm1(i,j)=workm1(i,j)+psiinv2(i,j)
               end do
            end do

            nuwork=nu2+ncluster*nu1

            call riwishart(nvar,nuwork,workm1,workm2,workm3,
     &                     workv1,workmh1,workmh2,iflag)

            do i=1,nvar
               do j=1,nvar
                  psi1(i,j)=workm1(i,j)
                  psiinv1(i,j)=workm2(i,j)
               end do
            end do

         end if

c+++++++ mean of the normal component

         if(m1rand.eq.1)then

            do i=1,nvar
               workv1(i)=s2invm2(i)
               workv2(i)=0.d0
               do j=1,nvar
                  workm1(i,j)=0.d0
               end do
            end do

            do i=1,ncluster

               do j=1,nvar
                  do k=1,nvar
                     sigmawork(j,k)=
     &                           sigmaclus(i,ihmssf(j,k,nvar))
                  end do
               end do

               call invdet(sigmawork,nvar,sigworkinv,detlog,iflag,
     &                     workv3)

               do j=1,nvar
                  tmp1=0.d0
                  do k=1,nvar
                     workm1(j,k)=workm1(j,k)+sigworkinv(j,k)
                     tmp1=tmp1+dble(k0)*sigworkinv(j,k)*muclus(i,k)
                  end do
                  workv2(j)=workv2(j)+tmp1
               end do
            end do

            do i=1,nvar
               do j=1,nvar
                  workm1(i,j)=workm1(i,j)*k0
               end do
            end do

            do i=1,nvar
               workv1(i)=workv1(i)+workv2(i)
               do j=1,nvar
                  sigmawork(i,j)=s2inv(i,j)+workm1(i,j)
               end do
            end do

            call invdet(sigmawork,nvar,sigworkinv,detlog,iflag,workv3)

            do i=1,nvar
               tmp1=0.d0
               do j=1,nvar
                  tmp1=tmp1+sigworkinv(i,j)*workv1(j)
                  sigmawork(i,j)=sigworkinv(i,j)
               end do
               muwork(i)=tmp1
            end do

            call rmvnorm(nvar,muwork,sigmawork,workmh1,workv1,theta)

            do i=1,nvar
               m1(i)=theta(i)
            end do

         end if

c+++++++ k0

         if(tau1.gt.0)then

            tmp1=0.d0
            do i=1,ncluster
               do j=1,nvar
                  ywork(j)=muclus(i,j)-m1(j)
                  do k=1,nvar
                     sigmawork(j,k)=sigmaclus(i,ihmssf(j,k,nvar))
                  end do
               end do

               call invdet(sigmawork,nvar,sigworkinv,detlog,iflag,
     &                     workv3)

               do j=1,nvar
                  do k=1,nvar
                     tmp1=tmp1+ywork(j)*sigworkinv(j,k)*ywork(k)
                  end do
               end do
            end do

            k0=rgamma(0.5d0*(dble(ncluster)+tau1),0.5d0*(tmp1+tau2))

         end if

c++++++++++++++++++++++++++++++++++
c+++++++ Precision parameter
c++++++++++++++++++++++++++++++++++

c         call intpr("Step 3",-1,0,1)

         if(aa0.gt.0.d0)then
            call samalph(alpha,aa0,ab0,ncluster,nrec)
         end if

c++++++++++++++++++++++++++++++++++
c+++++++ save samples
c++++++++++++++++++++++++++++++++++

         if(iscan.gt.nburn)then
            skipcount=skipcount+1
            if(skipcount.gt.nskip)then
               isave=isave+1
               dispcount=dispcount+1

               counter=0

c+++++++++++++ normal baseline mean

               do i=1,nvar
                  counter=counter+1
                  thetasave(isave,counter)=m1(i)
               end do

c+++++++++++++ k0 parameter

               counter=counter+1
               thetasave(isave,counter)=k0

c+++++++++++++ IW baseline scale

               do i=1,nvar
                  do j=i,nvar
                     counter=counter+1
                     thetasave(isave,counter)=psi1(i,j)
                  end do
               end do

c+++++++++++++ cluster information

               counter=counter+1
               thetasave(isave,counter)=ncluster
               counter=counter+1
               thetasave(isave,counter)=alpha

c+++++++++++++ Partially sampling the DP and computing the cond. dist.

               do i=1,ncluster
                  prob(i)=dble(ccluster(i))/(alpha+dble(nrec))
               end do
               prob(ncluster+1)=alpha/(alpha+dble(nrec))
               call simdisc(prob,nrec+100,ncluster+1,evali)

               if(evali.le.ncluster)then
                  do i=1,nvar
                     muwork(i)=muclus(evali,i)
                     do j=1,nvar
                        sigmawork(i,j)=sigmaclus(evali,
     &                                 ihmssf(i,j,nvar))
                     end do
                  end do
               end if
               if(evali.eq.ncluster+1)then
                  do k=1,nvar
                     do l=1,nvar
                        workm3(k,l)=psiinv1(k,l)
                     end do
                  end do

                  call riwishart(nvar,nu1,workm3,workm1,workm2,
     &                           workv1,workmh1,workmh2,iflag)
                  do k=1,nvar
                     do l=1,nvar
                        s1(k,l)=workm3(k,l)/dble(k0)
                        sigmawork(k,l)=workm3(k,l)
                     end do
                  end do
                  call rmvnorm(nvar,m1,s1,workmh1,workv1,theta)
                  do k=1,nvar
                     muwork(k)=theta(k)
                  end do
               end if

               do i=2,nvar
                  workvx(i-1)=muwork(i)
                  do j=2,nvar
                     workmx(i-1,j-1)=sigmawork(i,j)
                  end do
               end do
               call inversedet(workmx,nx,iflagx,detlogx)

               call condmvn(1,sigmawork,nvar,workm1,workm2)
               sigmac=sqrt(workm1(1,1))

               tmp1=rbeta(1.d0,alpha+dble(nrec))
               tmp2=tmp1
               weight=(1.d0-tmp1)

               do i=1,npred
                  call rchkusr()
                  muc=muwork(1)
                  do k=2,nvar
                     muc=muc-workm1(1,k)*(xpred(i,k-1)-muwork(k))
                  end do

                  tmp4=-(dble(nx)*log(tpi))
                  tmp5=0.d0
                  do j=1,nx
                     do k=1,nx
                        tmp5=tmp5+(xpred(i,j)-workvx(j))*
     &                       workmx(j,k)*(xpred(i,k)-workvx(k))
                     end do
                  end do
                  tmp6=(tmp4-detlogx-tmp5)/2.d0
                  tmp7=exp(tmp6)

                  do j=1,ngrid
                     num(i,j)=tmp1*dnrm(grid(j),muc,sigmac,0,0)*tmp7
                  end do
                  denom(i)=tmp1*tmp7
                  fm(i)=tmp1*tmp7*muc
               end do

               do while((1.d0-tmp2).gt.eps)
                  call rchkusr()

                  tmp3=rbeta(1.d0,alpha+dble(nrec))
                  tmp1=weight*tmp3
                  weight=weight*(1.d0-tmp3)

                  call simdisc(prob,nrec+2,ncluster+1,evali)

                  if(evali.le.ncluster)then
                     do i=1,nvar
                        muwork(i)=muclus(evali,i)
                        do j=1,nvar
                           sigmawork(i,j)=sigmaclus(evali,
     &                                              ihmssf(i,j,nvar))
                        end do
                     end do
                  end if

                  if(evali.eq.ncluster+1)then
                     do k=1,nvar
                        do l=1,nvar
                           workm3(k,l)=psiinv1(k,l)
                        end do
                     end do

                     call riwishart(nvar,nu1,workm3,workm1,workm2,
     &                              workv1,workmh1,workmh2,iflag)

                     do k=1,nvar
                        do l=1,nvar
                           s1(k,l)=workm3(k,l)/dble(k0)
                           sigmawork(k,l)=workm3(k,l)
                        end do
                     end do
                     call rmvnorm(nvar,m1,s1,workmh1,workv1,theta)
                     do k=1,nvar
                        muwork(k)=theta(k)
                     end do
                  end if

                  do i=2,nvar
                     workvx(i-1)=muwork(i)
                     do j=2,nvar
                        workmx(i-1,j-1)=sigmawork(i,j)
                     end do
                  end do
                  call inversedet(workmx,nx,iflagx,detlogx)

                  call condmvn(1,sigmawork,nvar,workm1,workm2)
                  sigmac=sqrt(workm1(1,1))

                  do i=1,npred
                     call rchkusr()
                     muc=muwork(1)
                     do k=2,nvar
                        muc=muc-workm1(1,k)*(xpred(i,k-1)-muwork(k))
                     end do

                     tmp4=-(dble(nx)*log(tpi))
                     tmp5=0.d0
                     do j=1,nx
                        do k=1,nx
                           tmp5=tmp5+(xpred(i,j)-workvx(j))*
     &                       workmx(j,k)*(xpred(i,k)-workvx(k))
                        end do
                     end do
                     tmp6=(tmp4-detlogx-tmp5)/2.d0
                     tmp7=exp(tmp6)

                     do j=1,ngrid
                        num(i,j)=num(i,j)+
     &                           tmp1*dnrm(grid(j),muc,sigmac,0,0)*tmp7
                     end do
                     denom(i)=denom(i)+tmp1*tmp7
                     fm(i)=fm(i)+tmp1*tmp7*muc
                 end do

                  tmp2=tmp2+tmp1
               end do

               do i=1,npred
                  call rchkusr()

                  fm(i)=fm(i)/denom(i)
                  meanfpm(i)=meanfpm(i)+fm(i)
                  do j=1,ngrid
                     fs(j)=num(i,j)/denom(i)
                     denspm(i,j)=denspm(i,j)+fs(j)
                  end do
                  write(1) (fs(j),j=1,ngrid)
               end do
               write(2) (fm(j),j=1,npred)

c+++++++++++++ cpo

               do i=1,ncluster
                  prob(i)=dble(ccluster(i))/(alpha+dble(nrec))
               end do
               do i=ncluster+1,ncluster+100
                  prob(i)=alpha/(100.d0*(alpha+dble(nrec)))
               end do
               call simdisc(prob,nrec+100,ncluster+100,evali)

               do i=ncluster+1,ncluster+100
                  do k=1,nvar
                     do l=1,nvar
                        workm3(k,l)=psiinv1(k,l)
                     end do
                  end do

                  call riwishart(nvar,nu1,workm3,workm1,workm2,
     &                           workv1,workmh1,workmh2,iflag)
                  do k=1,nvar
                     do l=1,nvar
                        s1(k,l)=workm3(k,l)/dble(k0)
                        sigmaclus(i,ihmssf(k,l,nvar))=workm3(k,l)
                     end do
                  end do
                  call rmvnorm(nvar,m1,s1,workmh1,workv1,theta)
                  do k=1,nvar
                     muclus(i,k)=theta(k)
                  end do
               end do

               do i=1,nrec
                  numcpo(i)=0.d0
                  denomcpo(i)=0.d0
               end do

               do ii=1,ncluster+100

                  do j=1,nvar
                     muwork(j)=muclus(ii,j)
                     do k=1,nvar
                        sigmawork(j,k)=
     &                         sigmaclus(ii,ihmssf(j,k,nvar))
                     end do
                  end do

                  do j=2,nvar
                     workvx(j-1)=muwork(j)
                     do k=2,nvar
                        workmx(j-1,k-1)=sigmawork(j,k)
                     end do
                  end do
                  call inversedet(workmx,nx,iflagx,detlogx)

                  call condmvn(1,sigmawork,nvar,workm1,workm2)
                  sigmac=sqrt(workm1(1,1))

                  do i=1,nrec
                     call rchkusr()
                     muc=muwork(1)
                     do k=2,nvar
                        muc=muc-workm1(1,k)*(z(i,k)-muwork(k))
                     end do

                     tmp4=-(dble(nx)*log(tpi))
                     tmp5=0.d0
                     do j=1,nx
                        do k=1,nx
                           tmp5=tmp5+(z(i,j+1)-workvx(j))*
     &                       workmx(j,k)*(z(i,k+1)-workvx(k))
                        end do
                     end do
                     tmp6=(tmp4-detlogx-tmp5)/2.d0
                     tmp7=exp(tmp6)

                     numcpo(i)=numcpo(i)+
     &                   prob(ii)*dnrm(z(i,1),muc,sigmac,0,0)*tmp7
                     denomcpo(i)=denomcpo(i)+prob(ii)*tmp7

                  end do
               end do

               tmp2=0.d0
               do i=1,nrec
                  tmp3=numcpo(i)/denomcpo(i)
                  cpo(i,1)=cpo(i,1)+1.0d0/tmp3
                  cpo(i,2)=cpo(i,2)+tmp3

                  tmp2=tmp2+log(dble(isave)/cpo(i,1))
               end do

c               call dblepr("LPML",-1,tmp2,1)

c+++++++++++++ print
               skipcount = 0
               if(dispcount.ge.ndisplay)then
                  call cpu_time(sec1)
                  sec00=sec00+(sec1-sec0)
                  sec=sec00
                  sec0=sec1
                  tmp1=sprint(isave,nsave,sec)
                  dispcount=0
               end if
            end if
         end if
      end do

      do i=1,nrec
         call rchkusr()
         cpo(i,1)=dble(nsave)/cpo(i,1)
         cpo(i,2)=cpo(i,2)/dble(nsave)
      end do

      do i=1,npred
         call rchkusr()

         meanfpm(i)=meanfpm(i)/dble(nsave)
         do j=1,ngrid
            denspm(i,j)= denspm(i,j)/dble(nsave)
         end do
      end do

      close(unit=1)
      close(unit=2)

      if(cband.eq.1)then

         call hpddensreg(nsave,npred,ngrid,0.05d0,tband,
     &                   worksam,fs,denspl,densph)

         call hpddensregmf(nsave,npred,0.05d0,tband,
     &                     worksam,meanfpl,meanfph)
      end if

      return
      end

c=======================================================================
      subroutine hpddensregmf(nsave,npred,alpha,tint,
     &                        worksam,llower,lupper)
c=======================================================================
c     Compute CI for the conditional means.
c
c     Alejandro Jara, 2007-2008
c=======================================================================
      implicit none

c+++++External parameters
      integer tint
      integer nsave,npred
      real*8 alpha

c+++++External working
      real*8 worksam(nsave)

c+++++Output
      real*8 llower(npred)
      real*8 lupper(npred)

c+++++Internal working
      integer maxnsave,maxnpred
      parameter(maxnsave=30000,maxnpred=500)
      real*8 aupp(2),alow(2)
      real*8 workm(maxnsave,maxnpred)

c+++++Internal working
      integer i,ii,j

c+++++algorithm

      if(maxnsave.lt.nsave)then
         call rexit("Increase 'maxnsave' in 'hpddensreg'")
      end if

      if(maxnpred.lt.npred)then
         call rexit("Increase 'maxnpred' in 'hpddensreg'")
      end if

      open(unit=2,file='dppackage2.out',status='old',
     &     form='unformatted')

      do i=1,nsave
         read(2) (workm(i,j),j=1,npred)
      end do

      do ii=1,npred
         do i=1,nsave
            call rchkusr()
            worksam(i)=workm(i,ii)
         end do

         call hpd(nsave,alpha,worksam,alow,aupp)

         if(tint.eq.1)then
c               (alow(1),aupp(1)): 100(1-alpha)% HPD interval
c
            llower(ii)=alow(1)
            lupper(ii)=aupp(1)

           else
c              (alow(2),aupp(2)): 100(1-alpha)% Bayesian credible
c              interval

            llower(ii)=alow(2)
            lupper(ii)=aupp(2)
         end if

      end do

      close(unit=2)
      return
      end

c=======================================================================
      subroutine hpddensreg(nsave,npred,ngrid,alpha,tint,
     &                      workv1,fs,llower,lupper)
c=======================================================================
c     Compute CI for the conditional densities.
c
c     Alejandro Jara, 2007-2008
c=======================================================================
      implicit none
c+++++External parameters
      integer tint
      integer nsave,npred,ngrid
      real*8 alpha

c+++++External working
      real*8 fs(ngrid)
      real*8 workv1(nsave)

c+++++Output
      real*8 llower(npred,ngrid)
      real*8 lupper(npred,ngrid)

c+++++Internal parameters
      integer maxnsave,maxngrid
      parameter(maxnsave=30000,maxngrid=500)
      real*8 aupp(2),alow(2)
      real*8 workm(maxnsave,maxngrid)

c+++++Internal working
      integer i,ii,j,l

c+++++algorithm

      if(maxnsave.lt.nsave)then
         call rexit("Increase 'maxnsave' in 'hpddensreg'")
      end if

      if(maxngrid.lt.ngrid)then
         call rexit("Increase 'maxngrid' in 'hpddensreg'")
      end if

      open(unit=1,file='dppackage1.out',status='old',
     &     form='unformatted')

      do ii=1,npred
         do i=1,nsave
            call rchkusr()
            do j=1,npred
               read(1) (fs(l),l=1,ngrid)
               if(ii.eq.j)then
                  do l=1,ngrid
                     workm(i,l)=fs(l)
                  end do
               end if
            end do
          end do
          rewind(unit=1)

          do i=1,ngrid
             do j=1,nsave
                workv1(j)=workm(j,i)
             end do

             call hpd(nsave,alpha,workv1,alow,aupp)

             if(tint.eq.1)then
c               (alow(1),aupp(1)): 100(1-alpha)% HPD interval
c
                llower(ii,i)=alow(1)
                lupper(ii,i)=aupp(1)

              else
c              (alow(2),aupp(2)): 100(1-alpha)% Bayesian credible
c              interval

                llower(ii,i)=alow(2)
                lupper(ii,i)=aupp(2)
             end if

          end do

      end do

      close(unit=1)
      return
      end

c=======================================================================
      subroutine relabelddr(ind,since,nrec,nvar,ncluster,ccluster,cstrt,
     &                      ss,muclus,sigmaclus,muwork,sigmawork)
c=======================================================================
c     relabel the clusters after the elimination of one of them
c     A.J.V., 2006
      implicit none
      integer dimen,i,ihmssf,j
      integer ind,since,nrec,nvar,ncluster,ccluster(nrec)
      integer cstrt(nrec,nrec)
      integer ss(nrec)
      real*8 muclus(nrec+100,nvar),sigmaclus(nrec+100,nvar*(nvar+1)/2)
      real*8 muwork(nvar),sigmawork(nvar,nvar)

      integer ns,ii
      dimen=nvar*(nvar+1)/2

      do i=1,nvar
         muwork(i)=muclus(since,i)
         do j=1,nvar
            sigmawork(i,j)=sigmaclus(since,ihmssf(i,j,nvar))
         end do
      end do

      do i=since+1,ncluster

         ns=ccluster(i)

         do j=1,ns
c++++++++++ check if the user has requested an interrupt
            call rchkusr()
            ii=cstrt(i,j)
            ss(ii)=i-1
         end do

         do j=1,ns
            cstrt(i-1,j)=cstrt(i,j)
         end do

         do j=1,nvar
            muclus(i-1,j)=muclus(i,j)
         end do
         do j=1,dimen
            sigmaclus(i-1,j)=sigmaclus(i,j)
         end do

         ccluster(i-1)=ccluster(i)
      end do

      ss(ind)=ncluster

      do i=1,nvar
         muclus(ncluster,i)=muwork(i)
         do j=i,nvar
             sigmaclus(ncluster,ihmssf(i,j,nvar))=sigmawork(i,j)
         end do
      end do

      ccluster(ncluster)=1

      return
      end


!-----------------------------------------------------------------------

      subroutine dermagvel(magvel,vel_l1,vel_l2,vel_h1,vel_h2,nv, &
                           dat,dat_l1,dat_l2,dat_h1,dat_h2,nc,lo,hi,domlo, &
                           domhi,dx,xlo,time,dt,bc,level,grid_no)
!
!     This routine will derive magnitude of velocity.
!
      implicit none

      integer          lo(2), hi(2)
      integer          vel_l1,vel_l2,vel_h1,vel_h2,nv
      integer          dat_l1,dat_l2,dat_h1,dat_h2,nc
      integer          domlo(2), domhi(2)
      integer          bc(2,2,nc)
      double precision dx(2), xlo(2), time, dt
      double precision magvel(vel_l1:vel_h1,vel_l2:vel_h2,nv)
      double precision    dat(dat_l1:dat_h1,dat_l2:dat_h2,nc)
      integer    level, grid_no

      integer    i,j

      do j = lo(2), hi(2)
         do i = lo(1), hi(1)
            magvel(i,j,1) = sqrt( dat(i,j,2)**2 + dat(i,j,3)**2 )
         end do
      end do

      end subroutine dermagvel

!-----------------------------------------------------------------------

      subroutine derlapvar(var,var_l1,var_l2,var_h1,var_h2,nv, &
                           dat,dat_l1,dat_l2,dat_h1,dat_h2,nc,lo,hi,domlo, &
                           domhi,delta,xlo,time,dt,bc,level,grid_no)
!
!     This routine will derive the weighted-Laplacian of the variable for
!       the purposes of error estimation
!
      implicit none

      integer          lo(2), hi(2)
      integer          var_l1,var_l2,var_h1,var_h2,nv
      integer          dat_l1,dat_l2,dat_h1,dat_h2,nc
      integer          domlo(2), domhi(2)
      integer          bc(2,2,nc)
      double precision delta(2), xlo(2), time, dt
      double precision var(var_l1:var_h1,var_l2:var_h2,nv)
      double precision dat(dat_l1:dat_h1,dat_l2:dat_h2,nc)
      integer    level, grid_no

      double precision ::  delu(2,var_l1:var_h1,var_l2:var_h2)
      double precision :: delua(2,var_l1:var_h1,var_l2:var_h2)
      double precision :: delu2(4), delu3(4), delu4(4)
      double precision :: num, denom
      integer          :: i,j

      ! This value is taken from FLASH
      double precision, parameter:: epsil=0.02

      ! adapted from ref_marking.f90 in FLASH2.5

      ! d/dx
      do j=lo(2)-1,hi(2)+1
      do i=lo(1)-1,hi(1)+1
          delu(1,i,j) =     dat(i+1,j,1) -      dat(i-1,j,1)
         delua(1,i,j) = abs(dat(i+1,j,1)) + abs(dat(i-1,j,1))
      end do
      end do

      ! d/dy
      do j=lo(2)-1,hi(2)+1
      do i=lo(1)-1,hi(1)+1
          delu(2,i,j) =     dat(i,j+1,1) -      dat(i,j-1,1)
         delua(2,i,j) = abs(dat(i,j+1,1)) + abs(dat(i,j-1,1))
      end do
      end do

      do j = lo(2),hi(2)
      do i = lo(1),hi(1)

         ! d/dxdx
         delu2(1) =     delu(1,i+1,j)  -     delu(1,i-1,j)
         delu3(1) = abs(delu(1,i+1,j)) + abs(delu(1,i-1,j))
         delu4(1) =    delua(1,i+1,j)  +    delua(1,i-1,j)

         ! d/dydx
         delu2(2) =     delu(1,i,j+1)  -     delu(1,i,j-1)
         delu3(2) = abs(delu(1,i,j+1)) + abs(delu(1,i,j-1))
         delu4(2) =    delua(1,i,j+1)  +    delua(1,i,j-1)

         ! d/dxdy
         delu2(3) =     delu(2,i+1,j)  -     delu(2,i-1,j)
         delu3(3) = abs(delu(2,i+1,j)) + abs(delu(2,i-1,j))
         delu4(3) =    delua(2,i+1,j)  +    delua(2,i-1,j)

         ! d/dydy
         delu2(4) =     delu(2,i,j+1)  -     delu(2,i,j-1)
         delu3(4) = abs(delu(2,i,j+1)) + abs(delu(2,i,j-1))
         delu4(4) =    delua(2,i,j+1)  +    delua(2,i,j-1)

         ! compute the error
         num   =  delu2(1)**2 + delu2(2)**2 + delu2(3)**2 + delu2(4)**2
         denom = (delu3(1) + (epsil*delu4(1)+1.d-99))**2 + &
                 (delu3(2) + (epsil*delu4(2)+1.d-99))**2 + &
                 (delu3(3) + (epsil*delu4(3)+1.d-99))**2 + &
                 (delu3(4) + (epsil*delu4(4)+1.d-99))**2

         var(i,j,1) = sqrt(num/denom)

      end do
      end do

      end subroutine derlapvar

!-----------------------------------------------------------------------

      subroutine dermagvort(vort,v_l1,v_l2,v_h1,v_h2,nv, &
                            dat,dat_l1,dat_l2,dat_h1,dat_h2,nc,lo,hi,domlo, &
                            domhi,delta,xlo,time,dt,bc,level,grid_no)
!
!     This routine will calculate vorticity
!
      implicit none

      integer          lo(2), hi(2)
      integer            v_l1,  v_l2,  v_h1,  v_h2,nv
      integer          dat_l1,dat_l2,dat_h1,dat_h2,nc
      integer          domlo(2), domhi(2)
      integer          bc(2,2,nc)
      double precision delta(2), xlo(2), time, dt
      double precision vort(  v_l1:  v_h1,  v_l2:  v_h2,nv)
      double precision  dat(dat_l1:dat_h1,dat_l2:dat_h2,nc)
      integer    level, grid_no

      integer          :: i,j
      double precision :: vx,uy

      ! Calculate vorticity
      do j = lo(2), hi(2)
      do i = lo(1), hi(1)
         vx = 0.5d0 * (dat(i+1,j,2) - dat(i-1,j,2)) / delta(1)
         uy = 0.5d0 * (dat(i,j+1,1) - dat(i,j-1,1)) / delta(2)
         vort(i,j,1) = abs(vx - uy)
      end do
      end do

      end subroutine dermagvort

!-----------------------------------------------------------------------

      subroutine derspec(spec,spec_l1,spec_l2,spec_h1,spec_h2,nv,&
                         dat,dat_l1,dat_l2,dat_h1,dat_h2,nc,lo,hi,domlo,&
                         domhi,delta,xlo,time,dt,bc,level,grid_no)
!
!     This routine will derive the X from the (rho X)
!
      implicit none

      integer          lo(2), hi(2)
      integer          spec_l1,spec_l2,spec_h1,spec_h2,nv
      integer          dat_l1,dat_l2,dat_h1,dat_h2,nc
      integer          domlo(2), domhi(2)
      integer          bc(2,2,nc)
      double precision delta(2), xlo(2), time, dt
      double precision spec(spec_l1:spec_h1,spec_l2:spec_h2,nv)
      double precision dat(dat_l1:dat_h1,dat_l2:dat_h2,nc)
      integer    level, grid_no

      integer    i,j

      do j = lo(2), hi(2)
         do i = lo(1), hi(1)
            spec(i,j,1) = dat(i,j,2) / dat(i,j,1)
         end do
      end do

      end subroutine derspec

!-----------------------------------------------------------------------

      subroutine derstate(state,state_l1,state_l2,state_h1,state_h2,nv,&
                          dat,dat_l1,dat_l2,dat_h1,dat_h2,nc,lo,hi,domlo,&
                          domhi,delta,xlo,time,dt,bc,level,grid_no)
!
!     This routine will derive the X from the (rho X)
!
      use network, only : nspec
      implicit none

      integer          lo(2), hi(2)
      integer          state_l1,state_l2,state_h1,state_h2,nv
      integer          dat_l1,dat_l2,dat_h1,dat_h2,nc
      integer          domlo(2), domhi(2)
      integer          bc(2,2,nc)
      double precision delta(2), xlo(2), time, dt
      double precision state(state_l1:state_h1,state_l2:state_h2,nv)
      double precision   dat(dat_l1:dat_h1,dat_l2:dat_h2,nc)
      integer    level, grid_no

      integer    i,j

      ! Density
      do j = lo(2), hi(2)
         do i = lo(1), hi(1)
            state(i,j,1:nspec) = dat(i,j,2:nspec+1) / dat(i,j,1)
         end do
      end do

      end subroutine derstate


! // Author: Kevin D. O'Mara //
! Version: 1.0.0
! Date of Last Change: 10/14/15

!This document should help you learn the basics and intermediate Fortran array syntax.

! Each subroutine contains an example showcasing a specific aspect of arrays.

program FortranArrayBasics

	call arrayBasics()
	call twoDimensionalArrays()
	call allocatableArrays()
	call bonusStuff()

end program FortranArrayBasics

subroutine arrayBasics()
	implicit none

    !// ignore me //
    integer :: i
    !// ignore me //

    !Two ways to declare an array:
    integer :: myArray(5) !this is an array of integers, it holds *5* values
    integer, dimension(5) :: myOtherArray !same as "myArray"

    !Bonus:
    integer, dimension(5) :: anArray1, anArray2, anArray3 !this makes three arrays, each holding 5 values
    integer :: thatArray1(5), thatArray2(15), thatArray(2) !these three arrays each have different sizes

    print '(/,A)', "Example 1"

! initializing an array
    ! to zero:
    myArray = 0  !ALL values are set to 0 in the array (i.e. each element)

    ! with individual values
    thatArray(1) = -2 !this is how you access individual elements
    thatArray(2) = 7

    ! in a loop (part A)
    do i = 1, 5
        myOtherArray(i) = i
    end do

! print out arrays
    ! individual elements
    print *, "Printing individual elements:"
    print '(A,I1)', "thatArray(1) = ", myArray(1)
    print '(A,I1)', "thatArray(2) = ", myArray(2)

    ! the whole array
    print *, "Printing an entire array:"
    do i = 1, 5
        print '(A,I1,A,I1)', "myOtherArray(", i, ") = ", myOtherArray(i)
    end do

return; end subroutine arrayBasics

subroutine twoDimensionalArrays()
    implicit none

    !// ignore me //
    integer :: i, j
    !// ignore me //

    ! let's make some 2d arrays, i.e. matrices
    integer :: matrixOne(5,5) ! this is a 5 by 5 matrix.  The first index is rows, second is columns
    integer, dimension(2,4) :: matrixTwo ! 2 by 4 (2 rows and 4 columns)

    print '(/,A)', "Example 2"

    ! let's initialize and print "matrixTwo"
    print *, "Contents of matrixTwo:"
    do i = 1, 2
        do j = 1, 4
            matrixTwo(i,j) = i + j
            write(*,'(I2)',advance='no') matrixTwo(i,j)
        end do
        print *, '' !blank line
    end do

    !Bonus: "implicit do loops"
    matrixOne = 0 !initialize

    print *, "Contents of matrixOne:"
    do i = 1, 5 !put the outer loop here (i.e. rows)
        write(*,'(5(I1))') (matrixOne(i,j),j=1,5) !put the second loop index inside here; pay careful attention to the parenthesis
    end do

return; end subroutine twoDimensionalArrays

subroutine allocatableArrays()
    implicit none

    ! what if you don't know how big you want your array to be?
    ! make it "allocatable", that's what!
    integer, allocatable, dimension(:) :: myAllocatableArray
    integer, allocatable :: myOtherAllocatableArray(:), evenAnotherArray(:)

    integer, allocatable, dimension(:,:) :: myArray
    integer, allocatable, dimension(:,:,:) :: myCube

    print '(/,A)', "Example 3"

    ! allocating a single array
    allocate(myAllocatableArray(10))

    ! allocating multiple arrays on the same line
    allocate(myOtherAllocatableArray(5),evenAnotherArray(7))

    ! allocating a multi-dimensional array
    allocate(myArray(7,4))
    allocate(myCube(1,2,3))

    ! what if you've forgoten how big your array is?
    print *, "Size of myAllocatableArray:"
    print *, shape(myAllocatableArray) !size of array (i.e. # of elements in each dimension)
    print '(A,I2,1x,I2)', "myArray; dimension 1 and 2: ", shape(myArray)

    ! individual bounds
    print *, "lower bound: ", lbound(evenAnotherArray) !lower bound
    print *, "upper bound: ", ubound(evenAnotherArray) !upper bound

    ! individual bounds in multi-dimensional arrays
    print *, "upper bound, dimension 1: ", ubound(myArray,1)
    print *, "upper bound, dimension 2: ", ubound(myArray,2)

return; end subroutine allocatableArrays

subroutine bonusStuff()
    implicit none

    !// ignore me //
    integer :: i, j
    !// ignore me //

    integer, allocatable, dimension(:,:) :: bonusArray

    print '(/,A)', "Example 4"

    allocate(bonusArray(3,10))

    ! this is most generic way of looping through a two dimensional matrix
    ! note: the bound are calculated for you, so you don't have to worry about them
    print *, 'Contents of bonusArray:'
    do i=lbound(bonusArray,1),ubound(bonusArray,1)
        do j=lbound(bonusArray,2),ubound(bonusArray,2)
            bonusArray(i,j) = i + j
            write(*,'(I2,1x)',advance='no'), bonusArray(i,j)
        end do
        print *, ''
    end do

return; end subroutine bonusStuff


      SUBROUTINE CLARTG( F, G, CS, SN, R )
*
*  -- LAPACK auxiliary routine (version 3.1) --
*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
*     November 2006
*
*     .. Scalar Arguments ..
      REAL               CS
      COMPLEX            F, G, R, SN
*     ..
*
*  Purpose
*  =======
*
*  CLARTG generates a plane rotation so that
*
*     [  CS  SN  ]     [ F ]     [ R ]
*     [  __      ]  .  [   ]  =  [   ]   where CS**2 + |SN|**2 = 1.
*     [ -SN  CS  ]     [ G ]     [ 0 ]
*
*  This is a faster version of the BLAS1 routine CROTG, except for
*  the following differences:
*     F and G are unchanged on return.
*     If G=0, then CS=1 and SN=0.
*     If F=0, then CS=0 and SN is chosen so that R is real.
*
*  Arguments
*  =========
*
*  F       (input) COMPLEX
*          The first component of vector to be rotated.
*
*  G       (input) COMPLEX
*          The second component of vector to be rotated.
*
*  CS      (output) REAL
*          The cosine of the rotation.
*
*  SN      (output) COMPLEX
*          The sine of the rotation.
*
*  R       (output) COMPLEX
*          The nonzero component of the rotated vector.
*
*  Further Details
*  ======= =======
*
*  3-5-96 - Modified with a new algorithm by W. Kahan and J. Demmel
*
*  This version has a few statements commented out for thread safety
*  (machine parameters are computed on each entry). 10 feb 03, SJH.
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               TWO, ONE, ZERO
      PARAMETER          ( TWO = 2.0E+0, ONE = 1.0E+0, ZERO = 0.0E+0 )
      COMPLEX            CZERO
      PARAMETER          ( CZERO = ( 0.0E+0, 0.0E+0 ) )
*     ..
*     .. Local Scalars ..
*     LOGICAL            FIRST
      INTEGER            COUNT, I
      REAL               D, DI, DR, EPS, F2, F2S, G2, G2S, SAFMIN,
     $                   SAFMN2, SAFMX2, SCALE
      COMPLEX            FF, FS, GS
*     ..
*     .. External Functions ..
      REAL               SLAMCH, SLAPY2
      EXTERNAL           SLAMCH, SLAPY2
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, AIMAG, CMPLX, CONJG, INT, LOG, MAX, REAL,
     $                   SQRT
*     ..
*     .. Statement Functions ..
      REAL               ABS1, ABSSQ
*     ..
*     .. Save statement ..
*     SAVE               FIRST, SAFMX2, SAFMIN, SAFMN2
*     ..
*     .. Data statements ..
*     DATA               FIRST / .TRUE. /
*     ..
*     .. Statement Function definitions ..
      ABS1( FF ) = MAX( ABS( REAL( FF ) ), ABS( AIMAG( FF ) ) )
      ABSSQ( FF ) = REAL( FF )**2 + AIMAG( FF )**2
*     ..
*     .. Executable Statements ..
*
*     IF( FIRST ) THEN
         SAFMIN = SLAMCH( 'S' )
         EPS = SLAMCH( 'E' )
         SAFMN2 = SLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) /
     $            LOG( SLAMCH( 'B' ) ) / TWO )
         SAFMX2 = ONE / SAFMN2
*        FIRST = .FALSE.
*     END IF
      SCALE = MAX( ABS1( F ), ABS1( G ) )
      FS = F
      GS = G
      COUNT = 0
      IF( SCALE.GE.SAFMX2 ) THEN
   10    CONTINUE
         COUNT = COUNT + 1
         FS = FS*SAFMN2
         GS = GS*SAFMN2
         SCALE = SCALE*SAFMN2
         IF( SCALE.GE.SAFMX2 )
     $      GO TO 10
      ELSE IF( SCALE.LE.SAFMN2 ) THEN
         IF( G.EQ.CZERO ) THEN
            CS = ONE
            SN = CZERO
            R = F
            RETURN
         END IF
   20    CONTINUE
         COUNT = COUNT - 1
         FS = FS*SAFMX2
         GS = GS*SAFMX2
         SCALE = SCALE*SAFMX2
         IF( SCALE.LE.SAFMN2 )
     $      GO TO 20
      END IF
      F2 = ABSSQ( FS )
      G2 = ABSSQ( GS )
      IF( F2.LE.MAX( G2, ONE )*SAFMIN ) THEN
*
*        This is a rare case: F is very small.
*
         IF( F.EQ.CZERO ) THEN
            CS = ZERO
            R = SLAPY2( REAL( G ), AIMAG( G ) )
*           Do complex/real division explicitly with two real divisions
            D = SLAPY2( REAL( GS ), AIMAG( GS ) )
            SN = CMPLX( REAL( GS ) / D, -AIMAG( GS ) / D )
            RETURN
         END IF
         F2S = SLAPY2( REAL( FS ), AIMAG( FS ) )
*        G2 and G2S are accurate
*        G2 is at least SAFMIN, and G2S is at least SAFMN2
         G2S = SQRT( G2 )
*        Error in CS from underflow in F2S is at most
*        UNFL / SAFMN2 .lt. sqrt(UNFL*EPS) .lt. EPS
*        If MAX(G2,ONE)=G2, then F2 .lt. G2*SAFMIN,
*        and so CS .lt. sqrt(SAFMIN)
*        If MAX(G2,ONE)=ONE, then F2 .lt. SAFMIN
*        and so CS .lt. sqrt(SAFMIN)/SAFMN2 = sqrt(EPS)
*        Therefore, CS = F2S/G2S / sqrt( 1 + (F2S/G2S)**2 ) = F2S/G2S
         CS = F2S / G2S
*        Make sure abs(FF) = 1
*        Do complex/real division explicitly with 2 real divisions
         IF( ABS1( F ).GT.ONE ) THEN
            D = SLAPY2( REAL( F ), AIMAG( F ) )
            FF = CMPLX( REAL( F ) / D, AIMAG( F ) / D )
         ELSE
            DR = SAFMX2*REAL( F )
            DI = SAFMX2*AIMAG( F )
            D = SLAPY2( DR, DI )
            FF = CMPLX( DR / D, DI / D )
         END IF
         SN = FF*CMPLX( REAL( GS ) / G2S, -AIMAG( GS ) / G2S )
         R = CS*F + SN*G
      ELSE
*
*        This is the most common case.
*        Neither F2 nor F2/G2 are less than SAFMIN
*        F2S cannot overflow, and it is accurate
*
         F2S = SQRT( ONE+G2 / F2 )
*        Do the F2S(real)*FS(complex) multiply with two real multiplies
         R = CMPLX( F2S*REAL( FS ), F2S*AIMAG( FS ) )
         CS = ONE / F2S
         D = F2 + G2
*        Do complex/real division explicitly with two real divisions
         SN = CMPLX( REAL( R ) / D, AIMAG( R ) / D )
         SN = SN*CONJG( GS )
         IF( COUNT.NE.0 ) THEN
            IF( COUNT.GT.0 ) THEN
               DO 30 I = 1, COUNT
                  R = R*SAFMX2
   30          CONTINUE
            ELSE
               DO 40 I = 1, -COUNT
                  R = R*SAFMN2
   40          CONTINUE
            END IF
         END IF
      END IF
      RETURN
*
*     End of CLARTG
*
      END


PROGRAM ComputePrimitiveTest

  USE KindModule, ONLY: &
    DP, &
    Zero, &
    One
  USE UnitsModule, ONLY: &
    Kilometer, &
    Gram, &
    Second, &
    Erg, &
    Centimeter
  USE GeometryFieldsModule, ONLY: &
    nGF, &
    iGF_Gm_dd_11, &
    iGF_Gm_dd_22, &
    iGF_Gm_dd_33
  USE FluidFieldsModule, ONLY: &
    nCF, &
    iCF_D, &
    iCF_S1, &
    iCF_S2, &
    iCF_S3, &
    iCF_E, &
    iCF_Ne, &
    nPF, &
    iPF_D, &
    iPF_V1, &
    iPF_V2, &
    iPF_V3, &
    iPF_E, &
    iPF_Ne
  USE EquationOfStateModule, ONLY: &
    InitializeEquationOfState, &
    FinalizeEquationOfState, &
    ComputeSpecificInternalEnergy
  USE EquationOfStateModule_TABLE, ONLY: &
    MinT
  USE Euler_UtilitiesModule_Relativistic, ONLY: &
    ComputePrimitive_Euler_Relativistic

  IMPLICIT NONE

  INCLUDE 'mpif.h'

  INTEGER,  PARAMETER :: MaxIter = 10000000
  INTEGER             :: i, ITER, iErr
  REAL(DP)            :: U(nCF), P(nPF), G(nGF), rhot, Ye, MinE
  REAL(DP), PARAMETER :: UnitsD    = Gram / Centimeter**3
  REAL(DP), PARAMETER :: UnitsS1   = Gram / Centimeter**2 / Second
  REAL(DP), PARAMETER :: UnitsE    = Erg  / Centimeter**3
  REAL(DP), PARAMETER :: UnitsNe   = One  / Centimeter**3
  REAL(DP), PARAMETER :: UnitsGm11 = One
  REAL(DP), PARAMETER :: UnitsGm22 = Kilometer**2
  REAL(DP), PARAMETER :: UnitsGm33 = Kilometer**2
  REAL(DP), PARAMETER :: UnitsV1   = Kilometer / Second

  CALL InitializeEquationOfState &
         ( EquationOfState_Option &
             = 'TABLE', &
           EquationOfStateTableName_Option &
             = 'wl-EOS-SFHo-25-50-100.h5' )

! bad
 U(iCF_D) =    7.0649187518464309E-011
 U(iCF_S1) =   -1.0090020859170580E-011
 U(iCF_S2) =    0.0000000000000000
 U(iCF_S3) =    0.0000000000000000
 U(iCF_E) =    4.6814468682533512E-012
 U(iCF_Ne) =    2.5320751005275095d043
 G(iGF_Gm_dd_11) =    1.3084305249726724
 G(iGF_Gm_dd_22) =    52098906.726469778
 G(iGF_Gm_dd_33) =    52098906.726469778

!! good
! U(iCF_D) =    7.1310685995766948E-011
! U(iCF_S1) =   -9.6043957705295021E-012
! U(iCF_S2) =    0.0000000000000000
! U(iCF_S3) =    0.0000000000000000
! U(iCF_E) =    4.7298870460777394E-012
! U(iCF_Ne) =    2.5552046053893353d+043
! G(iGF_Gm_dd_11) =    1.3072681090882421
! G(iGF_Gm_dd_22) =    52052367.494140975
! G(iGF_Gm_dd_33) =    52052367.494140975

  WRITE(*,*)
  WRITE(*,'(A)') 'Inputs:'
  WRITE(*,'(A,ES24.16E3)') 'CF_D  = ', U(iCF_D ) / UnitsD
  WRITE(*,'(A,ES24.16E3)') 'CF_S1 = ', U(iCF_S1) / UnitsS1
  WRITE(*,'(A,ES24.16E3)') 'CF_S2 = ', U(iCF_S2)
  WRITE(*,'(A,ES24.16E3)') 'CF_S3 = ', U(iCF_S3)
  WRITE(*,'(A,ES24.16E3)') 'CF_E  = ', U(iCF_E ) / UnitsE
  WRITE(*,'(A,ES24.16E3)') 'CF_Ne = ', U(iCF_Ne) / UnitsNe
  WRITE(*,'(A,ES24.16E3)') 'GF_g1 = ', G(iGF_Gm_dd_11) / UnitsGm11
  WRITE(*,'(A,ES24.16E3)') 'GF_g2 = ', G(iGF_Gm_dd_22) / UnitsGm22
  WRITE(*,'(A,ES24.16E3)') 'GF_g3 = ', G(iGF_Gm_dd_33) / UnitsGm33
  WRITE(*,*)

 rhot =    7.0375498702540617d-011
 Ye =   0.44187368273397742_DP
  CALL ComputeSpecificInternalEnergy( rhot, MinT, Ye, MinE )
print*
print*,'From Table: ', MinE
print*,'From Code:  ', 5.9387860185921022d-002
print*
  iErr = 0

  CALL ComputePrimitive_Euler_Relativistic &
         ( U(iCF_D ), &
           U(iCF_S1), &
           U(iCF_S2), &
           U(iCF_S3), &
           U(iCF_E ), &
           U(iCF_Ne), &
           P(iPF_D ), &
           P(iPF_V1), &
           P(iPF_V2), &
           P(iPF_V3), &
           P(iPF_E ), &
           P(iPF_Ne), &
           G(iGF_Gm_dd_11), &
           G(iGF_Gm_dd_22), &
           G(iGF_Gm_dd_33), &
           iErr )

  IF( iErr .NE. 0 )THEN

    print*,'iErr = ', iErr
    stop 'fail'

  END IF

  WRITE(*,'(A)') 'Outputs:'
  WRITE(*,'(A,ES24.16E3)') 'PF_D  = ', P(iPF_D ) / UnitsD
  WRITE(*,'(A,ES24.16E3)') 'PF_V1 = ', P(iPF_V1) / UnitsV1
  WRITE(*,'(A,ES24.16E3)') 'PF_V2 = ', P(iPF_V2)
  WRITE(*,'(A,ES24.16E3)') 'PF_V3 = ', P(iPF_V3)
  WRITE(*,'(A,ES24.16E3)') 'PF_E  = ', P(iPF_E ) / UnitsE
  WRITE(*,'(A,ES24.16E3)') 'PF_Ne = ', P(iPF_Ne) / UnitsNe

  CALL FinalizeEquationOfState

END PROGRAM ComputePrimitiveTest


      SUBROUTINE PTGEN( DOTDEN, PTMAX, PTNO, PTXYZ, ERROUT, LERR)
      IMPLICIT NONE
C ********************************************************************
C *                                                                  *
C * This software is an unpublished work containing confidential and *
C * proprietary information of Birkbeck College. Use, disclosure,    *
C * reproduction and transfer of this work without the express       *
C * written consent of Birkbeck College are prohibited. This notice  *
C * must be attached to all copies or extracts of the software.      *
C *                                                                  *
C * (c) 1993 Oliver Smart & Birkbeck College, All rights reserved    *
C * (c) 1996 Oliver Smart & Birkbeck College, All rights reserved    *
C *                                                                  *
C ********************************************************************
C
C Modification history:
C
C Date	Author		Modification
C 12/93	O.S. Smart	Original public release in HOLE suite beta1.0
C
C
C this s/r generates dots coordinates ptxyz
C reasonably distributed on a sphere of unit radius

C Dotden controls the number of dots generated
C 2*dotden dots should be generated on a great circle
      INTEGER				DOTDEN

C array bound for number of points
      INTEGER				PTMAX

C number of points found (n.b. should not exceed number of points)
      INTEGER				PTNO

C co-ordinates of points
      DOUBLE PRECISION			PTXYZ( 3, PTMAX)

C stream number for error output, error indicator
      INTEGER				ERROUT
      LOGICAL				LERR

C internal variables *******************

C loop count circle number along Z
      INTEGER				ZCOUNT

C angle from z axis to edge of circle, radius of the circle
C z coordinate of circle
      DOUBLE PRECISION			ZANG, RCIRC, ZCOORD
C numb of dots on a particular circle
      INTEGER				RNUMB
C loop count for angle in circle
      INTEGER				ACOUNT
C xcoord and y coord of point
      DOUBLE PRECISION                  XCOORD, YCOORD
C number to swap
      DOUBLE PRECISION			DUM

C pi
      DOUBLE PRECISION                  PI

C end of declarations ******************

C initialize things
      PI = ACOS(0.)*2.
      PTNO = 0

C will produce points on series of circles with constant z
C there should be 2*dotden dots on a great circle
C the circles should be distributed with equal angle
      DO 10 ZCOUNT = 0, DOTDEN/2
C angle of the circle to z axis
        ZANG = REAL(ZCOUNT)/REAL(DOTDEN)*PI
C radius of the circle at this angle
        RCIRC = SIN(ZANG)
C z coordinate of the circle
        ZCOORD = COS(ZANG)
C number of points on the circle
C (radius=1 - number of points = 2*dotden)
C add 0.95 to round up
        RNUMB = REAL(2*DOTDEN)*RCIRC+0.95
C now have to draw rnumb points in x, y plane
        IF (RNUMB.EQ.0) THEN
C top and bottom
          PTNO = PTNO+1
          PTXYZ(1,PTNO) = 0.
          PTXYZ(2,PTNO) = 0.
          PTXYZ(3,PTNO) = ZCOORD
          PTNO = PTNO+1
          PTXYZ(1,PTNO) = 0.
          PTXYZ(2,PTNO) = 0.
          PTXYZ(3,PTNO) = -ZCOORD
        ELSE
C draw rnumb points
          DO 20 ACOUNT = 0, RNUMB-1
C angle from xaxis is (acount/rnumb)*2pi
            XCOORD = RCIRC*COS(2.*PI*REAL(ACOUNT)/REAL(RNUMB))
            YCOORD = RCIRC*SIN(2.*PI*REAL(ACOUNT)/REAL(RNUMB))
C make sure that we don't get one half great circle with points
C and the other without - swap x and y every 2nd time
            IF (MOD(ZCOUNT,2).EQ.0) THEN
              DUM = XCOORD
              XCOORD = YCOORD
              YCOORD = DUM
            ENDIF
C make point at x, y, and +/- z
            IF (PTNO+2.GT.PTMAX) THEN
              WRITE( ERROUT, '(A/ A,I10,A/ A)')
     &' Error in s/r PTGET (making isotropic sphere of dots)',
     &' Dotden specified to be ', DOTDEN, ' causes too many dots',
     &' Either decrease dotden or increase PTMAX'
              LERR = .TRUE.
              GOTO 55555
            ENDIF
            PTNO = PTNO+1
            PTXYZ(1,PTNO) = XCOORD
            PTXYZ(2,PTNO) = YCOORD
            PTXYZ(3,PTNO) = ZCOORD
            PTNO = PTNO+1
            PTXYZ(1,PTNO) = XCOORD
            PTXYZ(2,PTNO) = YCOORD
            PTXYZ(3,PTNO) = -ZCOORD
20        CONTINUE
        ENDIF
10    CONTINUE

55555 RETURN
      END


      subroutine simunpack(cpack,len,idrstmpl,ndpts,fld)
!$$$  SUBPROGRAM DOCUMENTATION BLOCK
!                .      .    .                                       .
! SUBPROGRAM:    simunpack
!   PRGMMR: Gilbert          ORG: W/NP11    DATE: 2000-06-21
!
! ABSTRACT: This subroutine unpacks a data field that was packed using a
!   simple packing algorithm as defined in the GRIB2 documention,
!   using info from the GRIB2 Data Representation Template 5.0.
!
! PROGRAM HISTORY LOG:
! 2000-06-21  Gilbert
!
! USAGE:    CALL simunpack(cpack,len,idrstmpl,ndpts,fld)
!   INPUT ARGUMENT LIST:
!     cpack    - The packed data field (character*1 array)
!     len      - length of packed field cpack().
!     idrstmpl - Contains the array of values for Data Representation
!                Template 5.0
!     ndpts    - The number of data values to unpack
!
!   OUTPUT ARGUMENT LIST:
!     fld()    - Contains the unpacked data values
!
! REMARKS: None
!
! ATTRIBUTES:
!   LANGUAGE: XL Fortran 90
!   MACHINE:  IBM SP
!
!$$$

      character(len=1),intent(in) :: cpack(len)
      integer,intent(in) :: ndpts,len
      integer,intent(in) :: idrstmpl(*)
      real,intent(out) :: fld(ndpts)

      integer :: ifld(ndpts)
      integer(4) :: ieee
      real :: ref,bscale,dscale

      ieee = idrstmpl(1)
      call rdieee(ieee,ref,1)
      bscale = 2.0**real(idrstmpl(2))
      dscale = 10.0**real(-idrstmpl(3))
      nbits = idrstmpl(4)
      itype = idrstmpl(5)
!
!  if nbits equals 0, we have a constant field where the reference value
!  is the data value at each gridpoint
!
      if (nbits.ne.0) then
         call gbytes(cpack,ifld,0,nbits,0,ndpts)
         do j=1,ndpts
           fld(j)=((real(ifld(j))*bscale)+ref)*dscale
         enddo
      else
         do j=1,ndpts
           fld(j)=ref
         enddo
      endif

      return
      end


C
C	$Id: sigplc.f,v 1.5 2008-07-27 00:16:54 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      REAL FUNCTION SIGPLC(M1,M2,HUE)
C
C_BEGIN PROLOGUE SIGPLC
C
C_SUBSIDIARY HLSRGB, HSVRGB
C
C_PURPOSE
C    To define a generic piecewise linear curve (as a function
C    of HUE) which can be used to calculate the R, G, B
C    values.
C
C_DESCRIPTION
C    This subroutine takes a minimum and maximum value and
C    defines a piecewise linear curve as a function of HUE.
C
C_ARGUMENTS
C
C M1      (INPUT,SINGLE,VARIABLE)  The minimum value.
C
C M2      (INPUT,SINGLE,VARIABLE)  The maximum value.
C
C HUE     (INPUT,SINGLE,VARIABLE)  Hue.
C
C_I/O
C    (NONE)
C
C_ROUTINES CALLED
C    (NONE)
C
C_COMMON BLOCKS
C    (NONE)
C
C_MAXIMUM GKS LEVEL
C    (NONE)
C
C_LANGUAGE
C    FORTRAN
C
C_REVISION DATE
C    880511 (YYMMDD)
C
C_HISTORY
C    This subroutine was originally coded at NCAR by Roy Barnes
C    using the algorithm presented in Foley and van Dam (see
C    REFERENCES); it was prepared for the NCAR Graphics
C    package by Fred Clare.
C
C_REFERENCES
C    Foley, James D. and van Dam, Andries,"Fundamentals of Interactive
C    Computer Graphics",Addison-Wesley Publishing Company, 1982.
C
C    Smith, A.R.,"Color Gamut Transformation Pairs",SIGGRAPH '78
C    Proceedings, published as Computer Graphics, 12(3),August 1978,
C    pp.12-19.
C
C_END PROLOGUE SIGPLC
C
      REAL M1,M2,HUE,H
C_FIRST EXECUTABLE STATEMENT SIGPLC
      H = HUE
      H = MOD(H,360.)
      IF (H .LT. 0.) H = H+360.
      IF (H .LT. 60.0) THEN
C
C  Linear curve from M1 to M2 if HUE is in [0.,60.)
C
          SIGPLC = M1 + (M2 - M1) * H / 60.0
      ELSE IF (H .LT. 180.0) THEN
C
C  Maximum value for HUE in [60.,180.)
C
          SIGPLC = M2
      ELSE IF (H .LT. 240.0) THEN
C
C  Linear curve from M2 to M1 for HUE in [180.,240.)
C
          SIGPLC = M1 + (M2 - M1) * (240.0 - H) / 60.0
      ELSE
C
C  Minimum value for HUE in [240.,360.)
C
          SIGPLC = M1
      ENDIF
C
C  Guarantee SIGPLC is in the range 0. to 1.
C
      SIGPLC = MIN(1.,MAX(0.,SIGPLC))
      RETURN
      END


! ****************************************
!   module.f90 for sden2d
!  18 Jan. 2016  written by D.KAWATA
! ****************************************

module gcdp_const
      implicit none

      double precision,parameter :: M_PI=3.141592653589793238d0

! *** for Tree ***
! number of dauthter tree
      integer,parameter :: NDTREE=8
! maximum number of node for ddec
      integer,parameter :: MAXNODE=80000000
! maximum number of node to be sent
      integer,parameter :: MAXNODESEND=70
! Margin for Size of root tree
      double precision,parameter :: MGROOT=1.001d0
! Max number of particles
      integer,parameter :: MNB=10000000

! *** for at Table ***
      integer,parameter :: NATTABLE=50000
! *** for kernel tables ***
      integer,parameter :: NKTAB=100000

! *** For Arithmetic Value ***
      double precision,parameter :: THIRD=1.0d0/3.0d0
      double precision,parameter :: V34=3.0d0/4.0d0
      double precision,parameter :: INF=1.0d6
      double precision,parameter :: MININF=1.0d-20
      double precision,parameter :: MININFESN=1.0d-20

! *** Normalization Unit ***
! * mass unit ( solar mass ) *
      double precision,parameter :: MUSM=1.0d12
! * (solarmass)/(gram) *
!      parameter (MUG=1.99e45)
! * length unit / pc ( 100kpc/pc ) *
      double precision,parameter :: LUPC=1.0e5
! * length unit(100kpc)/kpc *
      double precision,parameter :: LUKPC=1.0e2
! * (100 kpc)/(cm) *
      double precision,parameter :: LUCM=3.086e23
! * Density *
      double precision,parameter :: DU=6.77e-26
! * Pressure *
      double precision,parameter :: PU=2.91e-11
! * tempature ( K ) *
      double precision,parameter :: TUK=1.0e4
! * time ( yr ) *
      double precision,parameter :: TMUYR=4.71e8
! * time ( Gyr ) *
      double precision,parameter :: TMUGYR=0.471d0
! * time (s) *
      double precision,parameter :: TMUS=1.488d16
! * km/s *
      double precision,parameter :: VUKMS=207.4d0
! * cooling (energy) rate (erg s^-1 cm^-3) *
      double precision,parameter :: ERU=1.96d-27
! * k/m unit /( cm^2 s^-2 K^-1) *
      double precision,parameter :: K_MU=4.3d10

! *** For Physical Value ***
! * Gravitatrional Constant *
      double precision,parameter :: G=1.0d0
! * Boltzmann constarnt *
      double precision,parameter :: KCGS=1.381d-16
! * average molecular weight (default) *
      double precision,parameter :: MYU=0.6d0
! * proton mass *
      double precision,parameter :: MP=1.67265d-24
! * G(cgs) *
      double precision,parameter :: GCGS=6.672d-8
      double precision,parameter :: TPRHO=((KCGS/(MYU*MP))/K_MU)
! * Hubble constant 9.78x10^9xh^-1 yr h = 1.0*
      double precision,parameter :: H0_1=(1.0d0/((100.0d0*1.0d5)/(3.086d24))) &
       /((((3600.0d0*24.0d0)*365.0d0)*4.0d0+(3600.0d0*24.0d0))/4.0d0)
      double precision,parameter :: HUB0=100.0d0/(VUKMS*10.0d0)
! * Solar metallicity *
      double precision,parameter :: XZSOL=0.019d0
! He primordial and Solar metallicity
      double precision,parameter :: XHE0=0.24d0
      double precision,parameter :: XHESOL=0.275d0
! * photon velocity *
      double precision,parameter :: CVEL=(2.997925e5/VUKMS)

! *** note:  h_gcdp = 2 h_monaghan ***
      double precision,parameter :: ETAH=2.7d0
      double precision,parameter :: ERRH=0.01d0
! for setting stellar h_p
      double precision,parameter :: NSTH=0.1d0
      double precision,parameter :: XHSOL=0.706d0
! *** limit for the maximum change of h during the iteration ***
      double precision,parameter :: DHFLIM=4.0d0

! * For Parallel *
! maximum number of cpus
      integer,parameter :: NCPU=256
! *** Peano-Hilbert curve ***
      integer*8,parameter :: NDPH=8

end module gcdp_const

module gcdp_baryon

      implicit none
! * Particle ID *
      integer,allocatable,save :: id_p(:)
! * number neighbour *
      integer,allocatable,save :: nnb_p(:)
! * Mass *
      double precision,allocatable,save :: m_p(:)
! * Virtual Position Xn+1,Xn *
      double precision,allocatable,save :: x_p(:),y_p(:),z_p(:)
! * Velosity Vn-1/2,Vn+1/2 *
      double precision,allocatable,save :: vx_p(:),vy_p(:),vz_p(:)
      double precision,allocatable,save :: u_p(:)
! * molecular weight *
      double precision,allocatable,save :: myu_p(:)
! * Smoothing Length hn+1,hn *
      double precision,allocatable,save :: h_p(:)
! * Density rhon+1,rhon *
      double precision,allocatable,save :: rho_p(:)
! * Presure Pn+1,Pn *
      double precision,allocatable,save :: p_p(:)
! * Sound Velocity *
      double precision,allocatable,save :: cs_p(:)
! * Entropic function *
      double precision,allocatable,save :: as_p(:)
! * div V *
      double precision,allocatable,save :: div_v_p(:)
! *** artificial viscosity and thermal conductivity term ***
      double precision,allocatable,save :: alpv_p(:),alpu_p(:)
! ***** For Individual Time Step *****
! * list of active particles for gas and star *
      integer,allocatable,save :: list_ap(:)

! * For Heavy Elements unit Solar Mass *
      double precision,allocatable,save :: mzHe_p(:),mzC_p(:),mzN_p(:) &
       ,mzO_p(:),mzNe_p(:),mzMg_p(:) &
       ,mzSi_p(:),mzFe_p(:),mzZ_p(:)

! star formation time
      double precision,allocatable,save :: ts_p(:)

      integer,allocatable,save :: flagfd_p(:),flagc_p(:)

end module gcdp_baryon

module gcdp_dm
      use gcdp_const
      implicit none
! ***** For Dark Matter *****
! * Particle ID *
      integer,allocatable,save :: id_dm(:)
! *** number of neighbour particles ***
      integer,allocatable,save :: nnb_dm(:)
! * mass *
      double precision,allocatable,save :: m_dm(:)
! * Virtual Position *
      double precision,allocatable,save :: x_dm(:),y_dm(:),z_dm(:)
! * Velocity V(n+1/2) *
      double precision,allocatable,save :: vx_dm(:),vy_dm(:),vz_dm(:)
! *** for adaptive softening ***
      double precision,allocatable,save :: h_dm(:),rho_dm(:)
! * list of active particles for DM *
      integer,allocatable,save :: list_adm(:)

end module gcdp_dm

module gcdp_system
      implicit none

! ***** for MPI *****
      integer,save :: nprocs,myrank

end module gcdp_system

module gcdp_kernel
      use gcdp_const
      implicit none
! *** kernel look up table ****
      double precision,save :: dnktab
      double precision,save :: s_tb(0:NKTAB),w_tb(0:NKTAB),dwds_s_tb(0:NKTAB)
end module gcdp_kernel

module gcdp_gtree
      use gcdp_const
      implicit none
! ***** Tree for SPH particles _gtr *****
      integer,save :: num_gtr
! * max node id sent to the other proc
      integer,save :: nodese_gtr,nodess_gtr
! * number of contained particle *
      integer,allocatable,save :: np_gtr(:)
! * name of Particle *
      integer,allocatable,save :: pn_gtr(:)
! * length of side *
      double precision,allocatable,save :: l_gtr(:),hm_gtr(:)
      double precision,allocatable,save :: cx_gtr(:),cy_gtr(:),cz_gtr(:)
! * first child node *
      integer,allocatable,save :: daughter_gtr(:)
! * next node *
      integer,allocatable,save :: next_gtr(:)
! *** proc id ***
      integer,allocatable,save :: proc_gtr(:)
end module gcdp_gtree

module particle
      integer,allocatable,save :: idp(:),listp(:)
      double precision,allocatable,save :: xp(:),yp(:),massp(:),hp(:),metp(:)
end module particle

module mesh
      double precision,allocatable,save :: x_m(:,:),y_m(:,:)
      double precision,allocatable,save :: denxy_m(:,:),met_m(:,:)
end module mesh