c
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c  .                                                             .
c  .                  copyright (c) 1998 by UCAR                 .
c  .                                                             .
c  .       University Corporation for Atmospheric Research       .
c  .                                                             .
c  .                      all rights reserved                    .
c  .                                                             .
c  .                                                             .
c  .                         SPHEREPACK                          .
c  .                                                             .
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c
c
      SUBROUTINE DIHGEOD(M,IDP,JDP,X,Y,Z)
      DOUBLE PRECISION X
      DOUBLE PRECISION Y
      DOUBLE PRECISION Z
      DOUBLE PRECISION PI
      DOUBLE PRECISION DPHI
      DOUBLE PRECISION BETA
      DOUBLE PRECISION THETA1
      DOUBLE PRECISION THETA2
      DOUBLE PRECISION HDPHI
      DOUBLE PRECISION TDPHI
      DOUBLE PRECISION PHI
      DOUBLE PRECISION X1
      DOUBLE PRECISION Y1
      DOUBLE PRECISION Z1
      DOUBLE PRECISION X2
      DOUBLE PRECISION Y2
      DOUBLE PRECISION Z2
      DOUBLE PRECISION X3
      DOUBLE PRECISION Y3
      DOUBLE PRECISION Z3
      DOUBLE PRECISION DXI
      DOUBLE PRECISION DYI
      DOUBLE PRECISION DZI
      DOUBLE PRECISION DXJ
      DOUBLE PRECISION DYJ
      DOUBLE PRECISION DZJ
      DOUBLE PRECISION XS
      DOUBLE PRECISION YS
      DOUBLE PRECISION ZS
      DOUBLE PRECISION X4
      DOUBLE PRECISION Y4
      DOUBLE PRECISION Z4
      DOUBLE PRECISION X5
      DOUBLE PRECISION Y5
      DOUBLE PRECISION Z5
      DOUBLE PRECISION X6
      DOUBLE PRECISION Y6
      DOUBLE PRECISION Z6
      DOUBLE PRECISION RAD
      DOUBLE PRECISION THETA
      DIMENSION X(IDP,JDP,5),Y(IDP,JDP,5),Z(IDP,JDP,5)
c
c     m         is the number of points on the edge of a
c               single geodesic triangle
c
c     x,y,z     the coordinates of the geodesic points on
c               the sphere are x(i,j,k), y(i,j,k), z(i,j,k)
c               where i=1,...,m+m-1; j=1,...,m; and k=1,...,5.
c               the indices are defined on the unfolded
c               icosahedron as follows for the case m=3
c
c                north pole
c
c                 (5,1)          0      l
c        i     (4,1) (5,2)              a    (repeated for
c           (3,1) (4,2) (5,3)  theta1   t    k=2,3,4,5 in
c        (2,1) (3,2) (4,3)              i        -->
c     (1,1) (2,2) (3,3)        theta2   t    the longitudinal
c        (1,2) (2,3)                    u    direction)
c           (1,3)                pi     d
c      j                                e
c         south pole
c
c                total number of points is 10*(m-1)**2+2
c                total number of triangles is 20*(m-1)**2
c                total number of edges is 30*(m-1)**2
c
      PI = 4.D0*ATAN(1.D0)
      DPHI = .4D0*PI
      BETA = COS(DPHI)
      THETA1 = ACOS(BETA/ (1.D0-BETA))
      THETA2 = PI - THETA1
      HDPHI = DPHI/2.D0
      TDPHI = 3.D0*HDPHI
      DO K = 1,5
          PHI = (K-1)*DPHI
          CALL DSTOC(1.D0,THETA2,PHI,X1,Y1,Z1)
          CALL DSTOC(1.D0,PI,PHI+HDPHI,X2,Y2,Z2)
          CALL DSTOC(1.D0,THETA2,PHI+DPHI,X3,Y3,Z3)
          DXI = (X2-X1)/ (M-1)
          DYI = (Y2-Y1)/ (M-1)
          DZI = (Z2-Z1)/ (M-1)
          DXJ = (X3-X2)/ (M-1)
          DYJ = (Y3-Y2)/ (M-1)
          DZJ = (Z3-Z2)/ (M-1)
          DO I = 1,M
              XS = X1 + (I-1)*DXI
              YS = Y1 + (I-1)*DYI
              ZS = Z1 + (I-1)*DZI
              DO J = 1,I
                  X(J,I,K) = XS + (J-1)*DXJ
                  Y(J,I,K) = YS + (J-1)*DYJ
                  Z(J,I,K) = ZS + (J-1)*DZJ
              END DO
          END DO
          CALL DSTOC(1.D0,THETA1,PHI+HDPHI,X4,Y4,Z4)
          DXI = (X3-X4)/ (M-1)
          DYI = (Y3-Y4)/ (M-1)
          DZI = (Z3-Z4)/ (M-1)
          DXJ = (X4-X1)/ (M-1)
          DYJ = (Y4-Y1)/ (M-1)
          DZJ = (Z4-Z1)/ (M-1)
          DO J = 1,M
              XS = X1 + (J-1)*DXJ
              YS = Y1 + (J-1)*DYJ
              ZS = Z1 + (J-1)*DZJ
              DO I = 1,J
                  X(J,I,K) = XS + (I-1)*DXI
                  Y(J,I,K) = YS + (I-1)*DYI
                  Z(J,I,K) = ZS + (I-1)*DZI
              END DO
          END DO
          CALL DSTOC(1.D0,THETA1,PHI+TDPHI,X5,Y5,Z5)
          DXJ = (X5-X3)/ (M-1)
          DYJ = (Y5-Y3)/ (M-1)
          DZJ = (Z5-Z3)/ (M-1)
          DO I = 1,M
              XS = X4 + (I-1)*DXI
              YS = Y4 + (I-1)*DYI
              ZS = Z4 + (I-1)*DZI
              DO J = 1,I
                  X(J+M-1,I,K) = XS + (J-1)*DXJ
                  Y(J+M-1,I,K) = YS + (J-1)*DYJ
                  Z(J+M-1,I,K) = ZS + (J-1)*DZJ
              END DO
          END DO
          CALL DSTOC(1.D0,0.D0,PHI+DPHI,X6,Y6,Z6)
          DXI = (X5-X6)/ (M-1)
          DYI = (Y5-Y6)/ (M-1)
          DZI = (Z5-Z6)/ (M-1)
          DXJ = (X6-X4)/ (M-1)
          DYJ = (Y6-Y4)/ (M-1)
          DZJ = (Z6-Z4)/ (M-1)
          DO J = 1,M
              XS = X4 + (J-1)*DXJ
              YS = Y4 + (J-1)*DYJ
              ZS = Z4 + (J-1)*DZJ
              DO I = 1,J
                  X(J+M-1,I,K) = XS + (I-1)*DXI
                  Y(J+M-1,I,K) = YS + (I-1)*DYI
                  Z(J+M-1,I,K) = ZS + (I-1)*DZI
              END DO
          END DO
      END DO
      DO K = 1,5
          DO J = 1,M + M - 1
              DO I = 1,M
                  CALL DCTOS(X(J,I,K),Y(J,I,K),Z(J,I,K),RAD,THETA,PHI)
                  CALL DSTOC(1.D0,THETA,PHI,X(J,I,K),Y(J,I,K),Z(J,I,K))
              END DO
          END DO
      END DO
      RETURN
      END
      SUBROUTINE DCTOS(X,Y,Z,R,THETA,PHI)
      DOUBLE PRECISION X
      DOUBLE PRECISION Y
      DOUBLE PRECISION Z
      DOUBLE PRECISION R
      DOUBLE PRECISION THETA
      DOUBLE PRECISION PHI
      DOUBLE PRECISION R1

      R1 = X*X + Y*Y
      IF (R1.NE.0.D0) GO TO 10
      PHI = 0.D0
      THETA = 0.D0
      IF (Z.LT.0.D0) THETA = 4.D0*ATAN(1.D0)
      RETURN
   10 R = SQRT(R1+Z*Z)
      R1 = SQRT(R1)
      PHI = ATAN2(Y,X)
      THETA = ATAN2(R1,Z)
      RETURN
      END
      SUBROUTINE DSTOC(R,THETA,PHI,X,Y,Z)
      DOUBLE PRECISION R
      DOUBLE PRECISION THETA
      DOUBLE PRECISION PHI
      DOUBLE PRECISION X
      DOUBLE PRECISION Y
      DOUBLE PRECISION Z
      DOUBLE PRECISION ST

      ST = SIN(THETA)
      X = R*ST*COS(PHI)
      Y = R*ST*SIN(PHI)
      Z = R*COS(THETA)
      RETURN
      END


c=======================================================================
      subroutine ldbdpdensity(y,x,nrec,p,
     &                        npred,ngrid,grid,xpred,
     &                        maxn,nu,alpha,lambda,tau1,tau2,psiinv,
     &                        s0invm,s0inv,
     &                        kk,gp,beta,mub,sb,v,
     &                        mcmc,nsave,slice,
     &                        acrate,thetasave,randsave,
     &                        fmean,flow,fupp,meanfpm,meanfpl,meanfph,
     &                        cpo,seed,
     &                        iflag,sbinv,workm1,workv1,workv2,
     &                        workmh1,workmh2,betal,betar,beta1,
     &                        vl,vr,v1,workdpw,weight,fw,fw2,
     &                        fs,fm,worksam)

c=======================================================================
c     # 57 arguments
c
c     Subroutine `ldbdpdensity' to run a Markov chain for a
c     Linear Dependent Bernstein-Dirichlet Process prior for
c     bounded conditional density estimation.
c
c     Copyright: Felipe Barrientos and Alejandro Jara, 2010.
c
c     Version 1.0:
c
c     Last modification: 30-08-2010.
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      Felipe Barrientos
c      Department of Statistics
c      Facultad de Matematicas
c      Pontificia Universidad Catolica de Chile
c      Casilla 306, Correo 22
c      Santiago
c      Chile
c      Email: afbarrie@uc.cl
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        nrec        :  integer giving the number of data points.
c        p           :  integer giving the number of predictors.
c        y           :  real vector giving the responses, y(nrec).
c        x           :  real matrix giving the design matrix, x(nrec,p).
c
c-----------------------------------------------------------------------
c
c---- Prediction -------------------------------------------------------
c
c        cband       :  integer value indicating whether the
c                       credible bands need to be computed or not.
c        ngrid       :  integer giving the number of grid points where
c                       the density estimates are evaluated..
c        npred       :  integer giving the number of predictions.
c        grid        :  real vector giving the grid, grid(ngrid).
c        tband       :  integer indicating the type of credible
c                       band that need to be computed.
c        xpred       :  real matrix giving the design matrix of the
c                       predictions, zpred(npred,p).
c
c-----------------------------------------------------------------------
c
c---- Prior information ------------------------------------------------
c
c        alpha       :  real giving the value of the DP total mass
c                       parameter.
c        lambda      :  real giving the parameter of the truncated
c                       Poisson prior for the degree of the Bernstein
c                       polynomial.
c        maxn        :  integer giving the truncation of the DP.
c        tau1        :  real giving the value of the tau1 hyperparameter
c                       in the Gamma component of the centering
c                       distribution.
c        tau1,tau2   :  real giving the values of hyperparameters of the
c                       Gamma prior for the g-prior (only internal use).
c        s0invm      :  real vector giving the product of the prior
c                       precision and the prior mean of the normal
c                       normal prior for mub, s0ivnm(p).
c        s0inv       :  real vector giving the inverse of the covariance
c                       matrix of the normal prior for mub,
c                       s0inv(p,p).
c        nu          :  integer giving the degres of freedom parameter
c                       of the inverted-Wishart prior for sb.
c        psiinv      :  real matrix giving the scale matrix of the
c                       inverted-Wishart prior for sd, psiinv(p,p).
c
c-----------------------------------------------------------------------
c
c---- Current value of the parameters ----------------------------------
c
c        kk          :  integer giving the degree of the Bernstein
c                       polynomial.
c        gp          :  real giving the value of the G-prior
c                       parameter (only for internal use).
c        beta        :  real matrix giving the value of the regression
c                       coefficients, beta(maxn,p).
c        mub         :  real vector giving the mean of the normal
c                       centering distribution, mub(p).
c        sb          :  real matrix giving the variance of the normal
c                       centering distribution, sb(p,p).
c        v           :  real vector giving the stick-breaking
c                       parameters, v(maxm).
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        betaw       :  real giving the Slice sampling parameter for
c                       the regression coefficients.
c        gw          :  real giving the Slice sampling parameter for
c                       the g-prior parameter.
c        vw          :  real giving the Slice sampling parameter for
c                       the stick-breaking parameters.
c
c-----------------------------------------------------------------------
c
c---- Output -----------------------------------------------------------
c
c        acrate      :  real vector giving the average number of
c                       evaluation of the posterior in the Slice
c                       sampling step and the acceptance rate
c                       of the MH step for the degree of the
c                       polynomial, acrate(2).
c        cpo         :  real giving the cpos and fsos, cpo(nrec,2).
c        randsave    :  real matrix containing the mcmc samples for
c                       the regression coeff and stick-breaking
c                       parameters, randsave(nsave,p*maxm,maxm).
c        thetasave   :  real matrix containing the mcmc samples for
c                       the parameters, thetasave(nsave,2+p+p*(p+1)/2)
c        fmean       :  real matrix giving the posterior mean of the
c                       density, fmean(npred,ngrid).
c        flow        :  real matrix giving the lower limit of the
c                       HPD of the density, flow(npred,ngrid).
c        fupp        :  real matrix giving the upper limit of the
c                       HPD of the density, fupp(npred,ngrid).
c        meanfpm     :  real vector giving the posterior mean of the
c                       mean function, meanfpm(npred).
c        meanfpl     :  real vector giving the lower limit of the
c                       HPD of the mean function meanfpl(npred).
c        meanfph     :  real vector giving the upper limit of the
c                       HPD of the mean function, meanfph(npred).
c
c-----------------------------------------------------------------------
c
c---- Working space ----------------------------------------------------
c
c        betal       :  real matrix used for the slice-sampling of the
c                       regression coefficients, betal(maxn,p).
c        betar       :  real matrix used for the slice-sampling of the
c                       regression coefficients, betar(maxn,p).
c        beta1       :  real matrix used for the slice-sampling of the
c                       regression coefficients, beta1(maxn,p).
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        fw          :  real vector used to compute cpos,
c                       fw(nrec).
c        fw2         :  real matrix used to evaluate the predictions,
c                       fw2(npred,ngrid).
c        iflag       :  integer vector used to evaluate reg. coeff.,
c                       iflag(p).
c        sbinv       :  real matrix used to keep the inverse of sb,
c                       sbinv(p,p).
c        seed1       :  seed for random number generation.
c        seed2       :  seed for random number generation.
c        vl          :  real vector used for the slice sampling
c                       of stick-breaking parameters, vl(maxn).
c        vr          :  real vector used for the slice sampling
c                       of stick-breaking parameters, vr(maxn).
c        v1          :  real vector used for the slice sampling
c                       of stick-breaking parameters, v1(maxn).
c        weight      :  real vector used to compute the DP weights,
c                       weight(maxn).
c        workdpw     :  real vector used to compute the DP weights,
c                       workdpw(maxn+1).

c        workm1      :  real matrix used to update centering param.,
c                       workm1(p,p).
c        workmh1     :  real vector used to update centering param.,
c                       workmh1(p*(p+1)/2).
c        workmh2     :  real vector used to update centering param.,
c                       workmh2(p*(p+1)/2).
c        workv1      :  real vector used to update centering param.,
c                       workv1(p).
c        workv2      :  real vector used to update centering param.,
c                       workv2(p).
c        worksam     :  real vector used to comput HPD bands,
c                       worksam(nsave).
c
c=======================================================================

      implicit none

c+++++Data
      integer nrec,p
      real*8 x(nrec,p)
      real*8 y(nrec)

c+++++Predictions
      integer cband,npred,ngrid,tband
      real*8  grid(ngrid),xpred(npred,p)

c+++++Prior
      integer maxn,nu
      real*8 alpha
      real*8 lambda
      real*8 tau1,tau2
      real*8 psiinv(p,p)
      real*8 s0invm(p)
      real*8 s0inv(p,p)

c+++++Current values of the parameters
      integer kk
      real*8 gp
      real*8 beta(maxn,p)
      real*8 mub(p)
      real*8 sb(p,p)
      real*8 v(maxn)

c+++++MCMC parameters
      integer mcmc(5),nburn,nskip,nsave,ndisplay
      real*8 slice(3),betaw,gw,vw

c+++++Output
      real*8 acrate(2)
      real*8 thetasave(nsave,1+p+p*(p+1)/2+1)
      real*8 randsave(nsave,p*maxn+maxn)
      real*8 fmean(npred,ngrid)
      real*8 flow(npred,ngrid)
      real*8 fupp(npred,ngrid)
      real*8 meanfpm(npred)
      real*8 meanfpl(npred)
      real*8 meanfph(npred)
      real*8 cpo(nrec,2)

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

c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c+++++External working space
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

c++++ Inversion
      integer iflag(p)
      real*8 sbinv(p,p)
      real*8 workm1(p,p)
      real*8 workv1(p)
      real*8 workv2(p)
      real*8 workmh1(p*(p+1)/2)
      real*8 workmh2(p*(p+1)/2)

c++++ Slice sampler
      real*8 betal(maxn,p)
      real*8 betar(maxn,p)
      real*8 beta1(maxn,p)
      real*8 vl(maxn)
      real*8 vr(maxn)
      real*8 v1(maxn)

c++++ DP
      real*8 workdpw(maxn+1)
      real*8 weight(maxn)

c++++ CPO
      real*8 fw(nrec)

c++++ predictions
      real*8 fw2(npred,ngrid)

c++++ credible bands
      real*8 fs(ngrid)
      real*8 fm(npred)
      real*8 worksam(nsave)

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

c+++++General
      integer count,i,i1,ii,j,j1,k
      integer sprint
      real*8 tmp1,tmp2

c+++++Distributions
      real*8 dbet,dpoiss

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

c+++++Slice sampler
      integer kk1
      real*8 evaly,evalf,aux
      real*8 gl
      real*8 gr
      real*8 g1

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

c+++++RNG and distributions
      real runif

c++++ opening files

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

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

      betaw=slice(1)
      gw=slice(2)
      vw=slice(3)

c++++ set random number generator
      seed1=seed(1)
      seed2=seed(2)
      call setall(seed1,seed2)

c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c++++ start the MCMC algorithm
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

      isave=0
      skipcount=0
      dispcount=0
      nscan=nburn+(nskip+1)*(nsave)

      call cpu_time(sec0)
      sec00=0.d0

      do i=1,p
         do j=1,p
            sbinv(i,j)=sb(i,j)
         end do
      end do
      call inverse(sbinv,p,iflag)

      do iscan=1,nscan

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

c+++++++++++++++++++++++++++++++++++++++++++++++++
c+++++++ Slice sampler step for beta, v, and g.
c+++++++++++++++++++++++++++++++++++++++++++++++++

c+++++++ Step a

         call dbdplogposteri(kk,maxn,nrec,p,
     &                       alpha,beta,gp,v,lambda,
     &                       tau1,tau2,mub,sbinv,x,y,
     &                       workdpw,weight,aux)

         evaly=log(runif())+aux

c+++++++ Step b
         call dbdpstepbslice(0,gp,gw,gL,gR)
         do i=1,maxn
            do j=1,p
               call dbdpstepbslice(0,beta(i,j),betaw,
     &                             betal(i,j),betar(i,j))
            end do
         end do
         do i=1,(maxn-1)
            call dbdpstepbslice(1,v(i),vw,vL(i),vR(i))
         end do

c+++++++ Step c
         if(tau1.gt.0.d0)then
            call dbdpstepc1slice(gl,gr,g1)
           else
            g1=gp
         end if

         do i=1,maxn
            do j=1,p
               call dbdpstepc1slice(betal(i,j),betar(i,j),beta1(i,j))
            end do
         end do

         do i=1,(maxn-1)
            call dbdpstepc1slice(vl(i),vr(i),v1(i))
         end do
         v1(maxn)=v(maxn)

         call dbdplogposteri(kk,maxn,nrec,p,
     &                       alpha,beta1,g1,v1,lambda,
     &                       tau1,tau2,mub,sbinv,x,y,
     &                       workdpw,weight,evalf)

         do while(evaly.gt.evalf)

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

            acrate(1)=acrate(1)+1.d0

            if(tau1.gt.0.d0)then
               call dbdpstepc2slice(0,gp,g1,gl,gr)
               call dbdpstepc1slice(gl,gr,g1)
              else
               g1=gp
            end if

            do i=1,maxn
               do j=1,p
                  call dbdpstepc2slice(0,beta(i,j),beta1(i,j),
     &                                 betal(i,j),betar(i,j))
                  call dbdpstepc1slice(betal(i,j),betar(i,j),
     &                                 beta1(i,j))
               end do
            end do
            do i=1,(maxn-1)
               call dbdpstepc2slice(1,v(i),v1(i),vl(i),vr(i))
               call dbdpstepc1slice(vl(i),vr(i),v1(i))
            end do

            call dbdplogposteri(kk,maxn,nrec,p,
     &                          alpha,beta1,g1,v1,lambda,
     &                          tau1,tau2,mub,sbinv,x,y,
     &                          workdpw,weight,evalf)

         end do

c+++++++ update parameters

         gp=g1
         do i=1,maxn
            do j=1,p
               beta(i,j)=beta1(i,j)
            end do
         end do
         do i=1,maxn
            v(i)=v1(i)
         end do

c+++++++++++++++++++++++++++++++++++++++++++++++++
c+++++++ sampling kk
c+++++++++++++++++++++++++++++++++++++++++++++++++
         if(lambda.gt.0.d0)then

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

            kk1=kk+1
            if(kk.gt.1)then
               if(runif().gt.0.5)then
                 kk1=kk-1
               end if
            end if

            call dbdploglike(kk,maxn,nrec,p,beta,x,y,v,workdpw,
     &                       weight,evaly)

            call dbdploglike(kk1,maxn,nrec,p,beta,x,y,v,workdpw,
     &                       weight,evalf)

            aux=evalf-evaly+
     &          dpoiss(dble(kk1),dble(lambda),1)-
     &          dpoiss(dble(kk) ,dble(lambda),1)

            if(log(dble(runif())).lt.aux)then
               acrate(2)=acrate(2)+1.d0
               kk=kk1
            end if
         end if

c         call intpr("k",-1,kk,1)

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

         do i=1,p
            workv1(i)=s0invm(i)
         end do

         do i=1,p
            do j=1,p
               workm1(i,j)=s0inv(i,j)+dble(maxn)*sbinv(i,j)
            end do
         end do
         call inverse(workm1,p,iflag)

         do ii=1,maxn
            do i=1,p
               workv2(i)=beta(ii,i)
            end do
            workv1=workv1+matmul(sbinv,workv2)
         end do

         workv2=matmul(workm1,workv1)
         call rmvnorm(p,workv2,workm1,workmh1,workv1,mub)

c++++++++++++++++++++++++++++++++++++++
c+++++++ baseline covariance matrix +++
c++++++++++++++++++++++++++++++++++++++

         if(tau1.le.0.d0)then
            do i=1,p
               do j=1,p
                  sb(i,j)=psiinv(i,j)
                  workm1(i,j)=0.d0
               end do
               workv1(i)=0.d0
               iflag(i)=0
            end do

            do ii=1,maxn
               do i=1,p
                  do j=1,p
                     sb(i,j)=sb(i,j)+(beta(ii,i)-mub(i))*
     &                               (beta(ii,j)-mub(j))
                  end do
               end do
            end do

            call riwishart(p,nu+maxn,sb,sbinv,workm1,workv1,workmh1,
     &                     workmh2,iflag)

         end if

c         call dblepr("sb",-1,sb,p*p)
c         call dblepr("sbinv",-1,sbinv,p*p)

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

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

               count=0

c+++++++++++++ kk
               count=count+1
               thetasave(isave,count)=kk

c+++++++++++++ mub, sbinv
               do i=1,p
                  count=count+1
                  thetasave(isave,count)=mub(i)
               end do
               do i=1,p
                  do j=i,p
                     count=count+1
                     thetasave(isave,count)=sb(i,j)
                  end do
               end do

c+++++++++++++ g-prior
               count=count+1
               thetasave(isave,count)=gp

c+++++++++++++ beta
               count=0
               do i=1,maxn
                  do j=1,p
                     count=count+1
                     randsave(isave,count)=beta(i,j)
                  end do
               end do

c+++++++++++++ stick-brealking weights
               do i=1,maxn
                  count=count+1
                  randsave(isave,count)=v(i)
               end do

c+++++++++++++ cpo
               call sickbreak(maxn,v,workdpw,weight)

               do i=1,nrec
                  fw(i)=0.d0
                  do j=1,maxn

                     aux=0.d0
                     do k=1,p
                        aux=aux+(x(i,k)*beta(j,k))
                     end do
                     tmp1=exp(aux)/(1.d0+exp(aux))

                     call jcomponentbd(tmp1,kk,k)

                     fw(i)=fw(i)+weight(j)*
     &                     dbet(y(i),dble(k),dble(kk-k+1),0)
                  end do
               end do

               do i=1,nrec
                   cpo(i,1)=cpo(i,1)+1.d0/fw(i)
                   cpo(i,2)=cpo(i,2)+fw(i)
               end do

c+++++++++++++ predictions

               do i1=1,npred
                  fm(i1)=0.d0

                  do j1=1,ngrid
                      fw2(i1,j1)=0.d0

                      do j=1,maxn
                         aux=0.d0
                         do k=1,p
                            aux=aux+(xpred(i1,k)*beta(j,k))
                         end do
                         tmp1=exp(aux)/(1.d0+exp(aux))
                         call jcomponentbd(tmp1,kk,k)

                         fw2(i1,j1)=fw2(i1,j1)+weight(j)*
     &                        dbet(grid(j1),dble(k),dble(kk-k+1),0)

                         if(j1.eq.1)then
                            fm(i1)=fm(i1)+weight(j)*dble(k)/dble(kk+1)
                         end if
                      end do

                      fmean(i1,j1)=fmean(i1,j1)+fw2(i1,j1)
                  end do

                  meanfpm(i1)=meanfpm(i1)+fm(i1)

                  write(1) (fw2(i1,j1),j1=1,ngrid)
               end do

               write(2) (fm(i),i=1,npred)

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 i1=1,npred
         meanfpm(i1)=meanfpm(i1)/dble(nsave)
         do j1=1,ngrid
            fmean(i1,j1)=fmean(i1,j1)/dble(nsave)
         end do
      end do

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

      do i=1,2
         acrate(i)=acrate(i)/dble(nscan)
      end do

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

      if(cband.eq.1)then
         call hpddensreg(nsave,npred,ngrid,0.05d0,tband,worksam,fs,
     &                   flow,fupp)

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

      end if

      return
      end

c=======================================================================
       subroutine dbdploglike(kk,maxn,nrec,p,beta,x,y,v,workv,weight,
     &                        eval)
c=======================================================================
c      log-Likelihood for the BDDP
c=======================================================================
       implicit none

c+++++ Input
       integer kk,maxn,nrec,p
       real*8 beta(maxn,p)
       real*8 y(nrec),x(nrec,p),v(maxn)

c+++++ External working space
       real*8 workv(maxn+1),weight(maxn)

c+++++ Internal working space
       integer i,j,k
       real*8 dbet,tmp1,tmp2

c+++++ Output
       real*8 eval

c+++++ Algorithm

       call sickbreak(maxn,v,workv,weight)

       eval=0.d0
       do i=1,nrec
          tmp2=0.d0
          do j=1,maxn
             tmp1=0.d0
             do k=1,p
                tmp1=tmp1+(x(i,k)*beta(j,k))
             end do
             tmp1=exp(tmp1)/(1.d0+exp(tmp1))
             call jcomponentbd(tmp1,kk,k)
             tmp2=tmp2+weight(j)*dbet(y(i),dble(k),dble(kk-k+1),0)
          end do
          eval=eval+log(tmp2)
       end do

       return
       end

c=======================================================================
       subroutine dbdplogpriori(kk,maxn,p,
     &                          alpha,beta,gp,lambda,tau1,tau2,v,
     &                          mb,sbinv,eval)
c=======================================================================
c      log-priori distribution
c=======================================================================
       implicit none

c+++++ Input
       integer kk,maxn,p
       real*8 alpha,beta(maxn,p),gp,lambda,tau1,tau2,v(maxn)
       real*8 mb(p),sbinv(p,p)

c+++++ Output
       real*8 eval

c+++++ Internal working space
       integer i,j,k
       real*8 dpoiss,dgamm,dbet,tmp1

c+++++ Algorithm

c      kk
       eval=dpoiss(dble(kk),lambda,1)
       eval=eval-log(1.d0-dpoiss(0.d0,lambda,0))

c      g
       if(tau1.gt.0.d0)then
          eval=eval+dgamm(gp,tau1,tau2,1)
       end if

c      v
       do i=1,maxn-1
          eval=eval+dbet(v(i),1.d0,alpha,1)
       end do

c      beta
       do i=1,maxn
          tmp1=0.d0
          do j=1,p
             do k=1,p
                tmp1=tmp1+(beta(i,j)-mb(j))*
     &                     sbinv(j,k)*
     &                    (beta(i,k)-mb(k))
             end do
          end do
          eval=eval-0.5d0*tmp1
       end do

       return
       end

c=======================================================================
       subroutine dbdplogposteri(kk,maxn,nrec,p,
     &                           alpha,beta,gp,v,lambda,
     &                           tau1,tau2,mb,sbinv,x,y,
     &                           workv,weight,eval)
c=======================================================================
c      log-posteriori distribution.
c=======================================================================
       implicit none

c+++++ Input
       integer kk,maxn,nrec,p
       real*8 alpha
       real*8 beta(maxn,p),gp,v(maxn)
       real*8 lambda,tau1,tau2
       real*8 mb(p)
       real*8 sbinv(p,p)
       real*8 x(nrec,p),y(nrec)

c+++++ External working space
       real*8 workv(maxn+1),weight(maxn)

c+++++ Internal working space
       real*8 tmp1

c+++++ Output
       real*8 eval

c+++++ Algorithm

       call dbdploglike(kk,maxn,nrec,p,beta,x,y,v,workv,
     &                  weight,eval)

       call dbdplogpriori(kk,maxn,p,
     &                    alpha,beta,gp,lambda,tau1,tau2,v,
     &                    mb,sbinv,tmp1)

       eval=eval+tmp1

       return
       end

c=======================================================================
       subroutine dbdpstepbslice(limit,x0,w,l,r)
c=======================================================================
c      step b) slice sampler - Neal (2003) Fig 8
c=======================================================================
       implicit none

c+++++ Input
       integer limit
       real*8 x0,w

c+++++ Output
       real*8 l,r

c+++++ Internal working space
       real runif

c+++++ Algorithm

       l=x0-(w*dble(runif()))
       r=l+w

       if(limit.eq.1)then
          if(l.lt.0.d0)then
             l=0.d0
          end if
          if(r.gt.1.d0)then
             r=1.d0
          end if
       end if

       return
       end

c=======================================================================
       subroutine dbdpstepc1slice(l,r,x1)
c=======================================================================
c      step b)-1 slice sampler - Neal (2003) Fig 8
c=======================================================================
       implicit none

c+++++ Input
       real*8 l,r

c+++++ Output
       real*8 x1

c+++++ Internal working space
       real runif

c+++++ Algorithm

       x1=l+(dble(runif())*(r-l))

       return
       end

c=======================================================================
       subroutine  dbdpstepc2slice(limit,x0,x1,l,r)
c=======================================================================
c      step b)-2 slice sampler - Neal (2003) Fig 8
c=======================================================================
       implicit none

c+++++ Input
       integer limit
       real*8 x0,x1

c+++++ Output
       real*8 l,r

c+++++ Algorithm

       if(x1.lt.x0)then
          l=x1
       end if

       if(x1.ge.x0)then
          r=x1
       end if

       if(limit.eq.1)then
          if(l.lt.0d0)then
             l=0.d0
          end if
          if(r.gt.1.d0)then
             r=1.d0
          end if
       end if

       return
       end


      SUBROUTINE JACOBI(A,N,NP,D,V,NROT)
      PARAMETER (NMAX=100)
      DIMENSION A(NP,NP),D(NP),V(NP,NP),B(NMAX),Z(NMAX)
      DO 12 IP=1,N
        DO 11 IQ=1,N
          V(IP,IQ)=0.
11      CONTINUE
        V(IP,IP)=1.
12    CONTINUE
      DO 13 IP=1,N
        B(IP)=A(IP,IP)
        D(IP)=B(IP)
        Z(IP)=0.
13    CONTINUE
      NROT=0
      DO 24 I=1,50
        SM=0.
        DO 15 IP=1,N-1
          DO 14 IQ=IP+1,N
            SM=SM+ABS(A(IP,IQ))
14        CONTINUE
15      CONTINUE
        IF(SM.EQ.0.)RETURN
        IF(I.LT.4)THEN
          TRESH=0.2*SM/N**2
        ELSE
          TRESH=0.
        ENDIF
        DO 22 IP=1,N-1
          DO 21 IQ=IP+1,N
            G=100.*ABS(A(IP,IQ))
            IF((I.GT.4).AND.(ABS(D(IP))+G.EQ.ABS(D(IP)))
     *         .AND.(ABS(D(IQ))+G.EQ.ABS(D(IQ))))THEN
              A(IP,IQ)=0.
            ELSE IF(ABS(A(IP,IQ)).GT.TRESH)THEN
              H=D(IQ)-D(IP)
              IF(ABS(H)+G.EQ.ABS(H))THEN
                T=A(IP,IQ)/H
              ELSE
                THETA=0.5*H/A(IP,IQ)
                T=1./(ABS(THETA)+SQRT(1.+THETA**2))
                IF(THETA.LT.0.)T=-T
              ENDIF
              C=1./SQRT(1+T**2)
              S=T*C
              TAU=S/(1.+C)
              H=T*A(IP,IQ)
              Z(IP)=Z(IP)-H
              Z(IQ)=Z(IQ)+H
              D(IP)=D(IP)-H
              D(IQ)=D(IQ)+H
              A(IP,IQ)=0.
              DO 16 J=1,IP-1
                G=A(J,IP)
                H=A(J,IQ)
                A(J,IP)=G-S*(H+G*TAU)
                A(J,IQ)=H+S*(G-H*TAU)
16            CONTINUE
              DO 17 J=IP+1,IQ-1
                G=A(IP,J)
                H=A(J,IQ)
                A(IP,J)=G-S*(H+G*TAU)
                A(J,IQ)=H+S*(G-H*TAU)
17            CONTINUE
              DO 18 J=IQ+1,N
                G=A(IP,J)
                H=A(IQ,J)
                A(IP,J)=G-S*(H+G*TAU)
                A(IQ,J)=H+S*(G-H*TAU)
18            CONTINUE
              DO 19 J=1,N
                G=V(J,IP)
                H=V(J,IQ)
                V(J,IP)=G-S*(H+G*TAU)
                V(J,IQ)=H+S*(G-H*TAU)
19            CONTINUE
              NROT=NROT+1
            ENDIF
21        CONTINUE
22      CONTINUE
        DO 23 IP=1,N
          B(IP)=B(IP)+Z(IP)
          D(IP)=B(IP)
          Z(IP)=0.
23      CONTINUE
24    CONTINUE
      PAUSE '50 iterations should never happen'
      RETURN
      END


!!  Create a 1-d hydrostatic, atmosphere with an isothermal region
!!  (T_star) representing the NS, a hyperbolic tangent rise to a
!!  peak temperature (T_hi) representing the base of an accreted
!!  layer, an isoentropic profile down to a lower temperature (T_lo),
!!  and then isothermal. This can serve as an initial model for a
!!  nova or XRB.
!!
!!  The temperature profile is:
!!
!!         ^
!!         |
!!  T_hi   +            /\
!!         |           /  \
!!         |          /  . \
!!  T_star +---------+      \
!!         |         .   .   \
!!         |                  \
!!         |         .   .     \
!!  T_lo   +                    +-----------
!!         |         .   .
!!         +---------+---+---------------> r
!!         |         \  /
!!         |       atm_delta
!!         |< H_star>|
!!
!!
!!                   ^
!!                   |
!!                   +-- dens_base
!!
!!  dens_base is the density at a height H_star -- just below the rise
!!  in T up to the peak T_hi.  The composition is "ash" in the lower
!!  isothermal region and "fuel" in the isentropic and upper
!!  isothermal regions.  In the transition region, we apply the same
!!  hyperbolic tangent profile to interpolate the composition.
!!
!!  The fuel and ash compositions are specified by the fuel?_name,
!!  fuel?_frac and ash?_name, ash?_frac parameters (name of the species
!!  and mass fraction).  Where ? = 1,2,3.
!!
!!  The model is placed into HSE by the following differencing:
!!
!!   (1/dr) [ <P>_i - <P>_{i-1} ] = (1/2) [ <rho>_i + <rho>_{i-1} ] g
!!
!!  This will be iterated over in tandem with the EOS call,
!!  P(i-1) = P_eos(rho(i-1), T(i-1), X(i-1)
!!

! this version allows for mutiple initial models

module initial_model_module

  use amrex_fort_module, only : rt => amrex_real
  use network, only : nspec

  implicit none

  ! integer keys for indexing the model_state array
  integer, parameter :: nvars_model = 3 + nspec
  integer, parameter :: idens_model = 1
  integer, parameter :: itemp_model = 2
  integer, parameter :: ipres_model = 3
  integer, parameter :: ispec_model = 4

  ! number of points in the model file
  integer, save :: gen_npts_model, num_models

  ! arrays for storing the model data -- we have an extra index here
  ! which is the model number
  real(rt), allocatable, save :: gen_model_state(:,:,:)
  real(rt), allocatable, save :: gen_model_r(:,:)

  type :: model_t

     real(rt) :: xn_base(nspec)
     real(rt) :: xn_star(nspec)
     real(rt) :: xn_perturb(nspec)

     real(rt) :: dens_base
     real(rt) :: T_star
     real(rt) :: T_hi
     real(rt) :: T_lo

     real(rt) :: H_star
     real(rt) :: atm_delta

     real(rt) :: low_density_cutoff

     logical :: index_base_from_temp

  end type model_t

contains

  subroutine init_model_data(nx, num_models_in)

    implicit none

    integer, intent(in) :: nx, num_models_in

    ! allocate storage for the model data
    allocate (gen_model_state(nx, nvars_model, num_models_in))
    allocate (gen_model_r(nx, num_models_in))

    gen_npts_model = nx
    num_models = num_models_in

  end subroutine init_model_data

  subroutine init_1d_tanh(nx, xmin, xmax, model_params, model_num)

    use amrex_constants_module
    use amrex_error_module
    use amrex_fort_module, only : rt => amrex_real

    use eos_module, only: eos
    use eos_type_module, only: eos_t, eos_input_rt
    use network, only : nspec, network_species_index, spec_names
    use fundamental_constants_module, only: Gconst
    use meth_params_module, only : const_grav

    use amrex_paralleldescriptor_module, only: parallel_IOProcessor => amrex_pd_ioprocessor

    implicit none

    integer, intent(in) :: nx
    type(model_t), intent(in) :: model_params
    integer, intent(in) :: model_num
    real(rt) :: xmin, xmax

    integer :: i, n

    real (rt) :: slope_T, slope_xn(nspec)

    real (rt) :: pres_base, entropy_base

    real :: A, B

    real (rt) :: dCoord

    real (rt) :: dens_zone, temp_zone, pres_zone, entropy
    real (rt) :: dpd, dpt, dsd, dst

    real (rt) :: p_want, drho, dtemp, delx

    real (rt), parameter :: TOL = 1.e-10

    integer, parameter :: MAX_ITER = 250

    integer :: iter

    logical :: converged_hse, fluff

    real (rt), dimension(nspec) :: xn

    integer :: index_base

    logical :: isentropic, flipped

    integer :: narg

    type (eos_t) :: eos_state

    real(rt) :: sumX, xc

    !-----------------------------------------------------------------------------
    ! Create a 1-d uniform grid that is identical to the mesh that we are
    ! mapping onto, and then we want to force it into HSE on that mesh.
    !-----------------------------------------------------------------------------

    gen_npts_model = nx

    ! compute the coordinates of the new gridded function
    dCoord = (xmax - xmin) / dble(nx)

    do i = 1, nx
       gen_model_r(i, model_num)  = xmin + (dble(i) - HALF)*dCoord
    enddo

    ! find the index of the base height
    index_base = -1
    do i = 1, nx
       if (gen_model_r(i, model_num) >= xmin + model_params % H_star) then
          index_base = i+1
          exit
       endif
    enddo

    if (index_base == -1) then
       print *, 'ERROR: base_height not found on grid'
       call amrex_error('ERROR: invalid base_height')
    endif

    !-----------------------------------------------------------------------------
    ! put the model onto our new uniform grid
    !-----------------------------------------------------------------------------
    fluff = .false.

    ! determine the conditions at the base -- this is below the atmosphere
    eos_state%T     = model_params % T_star
    eos_state%rho   = model_params % dens_base
    eos_state%xn(:) = model_params % xn_star(:)

    call eos(eos_input_rt, eos_state)

    ! store the conditions at the base -- we'll use the entropy later
    ! to constrain the isentropic layer
    pres_base = eos_state%p

    ! set an initial temperature profile and composition
    print *, "in model stuff", model_params % T_hi

    do i = 1, nx

       xc = gen_model_r(i,model_num) - (xmin + model_params % H_star) - 1.5_rt * model_params % atm_delta

       ! hyperbolic tangent transition:
       gen_model_state(i,ispec_model:ispec_model-1+nspec,model_num) = model_params % xn_star(1:nspec) + &
            HALF*(model_params % xn_base(1:nspec) - model_params % xn_star(1:nspec))* &
            (ONE + tanh(xc/(HALF*model_params % atm_delta)))

       ! force them to sum to 1
       sumX = sum(gen_model_state(i,ispec_model:ispec_model-1+nspec,model_num))
       gen_model_state(i,ispec_model:ispec_model-1+nspec,model_num) = gen_model_state(i,ispec_model:ispec_model-1+nspec,model_num) / sumX

       gen_model_state(i,itemp_model,model_num) = model_params % T_star + &
            HALF*(model_params % T_hi - model_params % T_star)* &
            (ONE + tanh(xc/(HALF*model_params % atm_delta)))

       gen_model_state(1:index_base,itemp_model,model_num) = model_params % T_star

       ! the density and pressure will be determined via HSE,
       ! for now, set them to the base conditions
       gen_model_state(i,idens_model,model_num) = model_params % dens_base
       gen_model_state(i,ipres_model,model_num) = pres_base

    enddo

    ! make the base thermodynamics consistent for this base point -- that is
    ! what we will integrate from!
    eos_state%rho = gen_model_state(index_base,idens_model,model_num)
    eos_state%T = gen_model_state(index_base,itemp_model,model_num)
    eos_state%xn(:) = gen_model_state(index_base,ispec_model:ispec_model-1+nspec,model_num)

    call eos(eos_input_rt, eos_state)

    gen_model_state(index_base,ipres_model,model_num) = eos_state%p

    !-----------------------------------------------------------------------------
    ! HSE + entropy solve
    !-----------------------------------------------------------------------------

    ! the HSE state will be done putting creating an isentropic state until
    ! the temperature goes below T_lo -- then we will do isothermal.
    ! also, once the density goes below low_density_cutoff, we stop HSE

    isentropic = .false.
    flipped = .false.   ! we start out isothermal and then 'flip' to isentropic

    !---------------------------------------------------------------------------
    ! integrate up
    !---------------------------------------------------------------------------
    do i = index_base+1, nx

       if ((gen_model_r(i,model_num) > xmin + model_params % H_star + 3.0_rt * model_params % atm_delta) .and. .not. flipped) then
          isentropic = .true.
          flipped = .true.

          ! now we need to know the entropy we are confining ourselves to
          eos_state % rho = gen_model_state(i-1,idens_model,model_num)
          eos_state % T = gen_model_state(i-1,itemp_model,model_num)
          eos_state % xn(:) = gen_model_state(i-1,ispec_model:ispec_model-1+nspec,model_num)

          call eos(eos_input_rt, eos_state)

          entropy_base = eos_state % s

          if (parallel_IOProcessor()) then
             print *, "base density = ", eos_state % rho, eos_state % T
          endif
       endif

       delx = gen_model_r(i,model_num) - gen_model_r(i-1,model_num)

       ! we've already set initial guesses for density, temperature, and
       ! composition
       dens_zone = gen_model_state(i,idens_model,model_num)
       temp_zone = gen_model_state(i,itemp_model,model_num)
       xn(:) = gen_model_state(i,ispec_model:nvars_model,model_num)

       !-----------------------------------------------------------------------
       ! iteration loop
       !-----------------------------------------------------------------------

       ! start off the Newton loop by saying that the zone has not converged
       converged_hse = .FALSE.

       if (.not. fluff) then

          do iter = 1, MAX_ITER

             if (isentropic) then

                ! get the pressure we want from the HSE equation, just the
                ! zone below the current.  Note, we are using an average of
                ! the density of the two zones as an approximation of the
                ! interface value -- this means that we need to iterate for
                ! find the density and pressure that are consistent

                ! furthermore, we need to get the entropy that we need,
                ! which will come from adjusting the temperature in
                ! addition to the density.

                ! HSE differencing
                p_want = gen_model_state(i-1,ipres_model,model_num) + &
                     delx*0.5*(dens_zone + gen_model_state(i-1,idens_model,model_num))*const_grav

                ! now we have two functions to zero:
                !   A = p_want - p(rho,T)
                !   B = entropy_base - s(rho,T)
                ! We use a two dimensional Taylor expansion and find the deltas
                ! for both density and temperature

                ! now we know the pressure and the entropy that we want, so we
                ! need to find the temperature and density through a two
                ! dimensional root find

                ! (t, rho) -> (p, s)
                eos_state%T     = temp_zone
                eos_state%rho   = dens_zone
                eos_state%xn(:) = xn(:)

                call eos(eos_input_rt, eos_state)

                entropy = eos_state%s
                pres_zone = eos_state%p

                dpt = eos_state%dpdt
                dpd = eos_state%dpdr
                dst = eos_state%dsdt
                dsd = eos_state%dsdr

                A = p_want - pres_zone
                B = entropy_base - entropy

                dtemp = ((dsd/(dpd-0.5*delx*const_grav))*A - B)/ &
                     (dsd*dpt/(dpd -0.5*delx*const_grav) - dst)

                drho = (A - dpt*dtemp)/(dpd - 0.5*delx*const_grav)

                dens_zone = max(0.9_rt*dens_zone, &
                     min(dens_zone + drho, 1.1_rt*dens_zone))

                temp_zone = max(0.9_rt*temp_zone, &
                     min(temp_zone + dtemp, 1.1_rt*temp_zone))

                ! check if the density falls below our minimum cut-off --
                ! if so, floor it
                if (dens_zone < model_params % low_density_cutoff) then

                   dens_zone = model_params % low_density_cutoff
                   temp_zone = model_params % T_lo
                   converged_hse = .TRUE.
                   fluff = .TRUE.
                   exit

                endif

                ! if (A < TOL .and. B < ETOL) then
                if (abs(drho) < TOL*dens_zone .and. &
                     abs(dtemp) < TOL*temp_zone) then
                   converged_hse = .TRUE.
                   exit
                endif

             else

                ! do isothermal
                p_want = gen_model_state(i-1,ipres_model,model_num) + &
                     delx*0.5*(dens_zone + gen_model_state(i-1,idens_model,model_num))*const_grav

                if (gen_model_r(i,model_num) > xmin + model_params % H_star + 3.0_rt * model_params % atm_delta) then
                   temp_zone = model_params % T_lo
                endif

                ! (t, rho) -> (p)
                eos_state%T   = temp_zone
                eos_state%rho = dens_zone
                eos_state%xn(:) = xn(:)

                call eos(eos_input_rt, eos_state)

                entropy = eos_state%s
                pres_zone = eos_state%p

                dpd = eos_state%dpdr

                drho = (p_want - pres_zone)/(dpd - 0.5*delx*const_grav)

                dens_zone = max(0.9*dens_zone, &
                     min(dens_zone + drho, 1.1*dens_zone))

                if (abs(drho) < TOL*dens_zone) then
                   converged_hse = .TRUE.
                   exit
                endif

                if (dens_zone < model_params % low_density_cutoff) then

                   dens_zone = model_params % low_density_cutoff
                   temp_zone = model_params % T_lo
                   converged_hse = .TRUE.
                   fluff = .TRUE.
                   exit

                endif

             endif

             if (temp_zone < model_params % T_lo) then
                temp_zone = model_params % T_lo
                isentropic = .false.
             endif

          enddo

          if (.NOT. converged_hse) then

             print *, 'Error zone', i, ' did not converge in init_1d'
             print *, 'integrate up'
             print *, dens_zone, temp_zone
             print *, p_want, entropy_base, entropy
             print *, drho, dtemp
             call amrex_error('Error: HSE non-convergence')

          endif

       else
          dens_zone = model_params % low_density_cutoff
          temp_zone = model_params % T_lo
       endif

       ! call the EOS one more time for this zone and then go on to the next
       ! (t, rho) -> (p)
       eos_state%T     = temp_zone
       eos_state%rho   = dens_zone
       eos_state%xn(:) = xn(:)

       call eos(eos_input_rt, eos_state)

       pres_zone = eos_state%p

       ! update the thermodynamics in this zone
       gen_model_state(i,idens_model,model_num) = dens_zone
       gen_model_state(i,itemp_model,model_num) = temp_zone
       gen_model_state(i,ipres_model,model_num) = pres_zone

       ! to make this process converge faster, set the density in the
       ! next zone to the density in this zone
       ! gen_model_state(i+1,idens_model) = dens_zone

    enddo

    !---------------------------------------------------------------------------
    ! integrate down -- using the temperature profile defined above
    !---------------------------------------------------------------------------
    do i = index_base-1, 1, -1

       delx = gen_model_r(i+1,model_num) - gen_model_r(i,model_num)

       ! we already set the temperature and composition profiles
       temp_zone = gen_model_state(i,itemp_model,model_num)
       xn(:) = gen_model_state(i,ispec_model:nvars_model,model_num)

       ! use our previous initial guess for density
       dens_zone = gen_model_state(i+1,idens_model,model_num)

       !-----------------------------------------------------------------------
       ! iteration loop
       !-----------------------------------------------------------------------

       ! start off the Newton loop by saying that the zone has not converged
       converged_hse = .FALSE.

       do iter = 1, MAX_ITER

          ! get the pressure we want from the HSE equation, just the
          ! zone below the current.  Note, we are using an average of
          ! the density of the two zones as an approximation of the
          ! interface value -- this means that we need to iterate for
          ! find the density and pressure that are consistent

          ! HSE differencing
          p_want = gen_model_state(i+1,ipres_model,model_num) - &
               delx*0.5*(dens_zone + gen_model_state(i+1,idens_model,model_num))*const_grav

          ! we will take the temperature already defined in gen_model_state
          ! so we only need to zero:
          !   A = p_want - p(rho)

          ! (t, rho) -> (p)
          eos_state%T     = temp_zone
          eos_state%rho   = dens_zone
          eos_state%xn(:) = xn(:)

          call eos(eos_input_rt, eos_state)

          pres_zone = eos_state%p

          dpd = eos_state%dpdr

          A = p_want - pres_zone

          drho = A/(dpd + 0.5*delx*const_grav)

          dens_zone = max(0.9_rt*dens_zone, &
               min(dens_zone + drho, 1.1_rt*dens_zone))

          if (abs(drho) < TOL*dens_zone) then
             converged_hse = .TRUE.
             exit
          endif

       enddo

       if (.NOT. converged_hse) then

          print *, 'Error zone', i, ' did not converge in init_1d'
          print *, 'integrate down'
          print *, dens_zone, temp_zone
          print *, p_want
          print *, drho
          call amrex_error('Error: HSE non-convergence')

       endif

       ! call the EOS one more time for this zone and then go on to the next
       ! (t, rho) -> (p)
       eos_state%T     = temp_zone
       eos_state%rho   = dens_zone
       eos_state%xn(:) = xn(:)

       call eos(eos_input_rt, eos_state)

       pres_zone = eos_state%p

       ! update the thermodynamics in this zone
       gen_model_state(i,idens_model,model_num) = dens_zone
       gen_model_state(i,itemp_model,model_num) = temp_zone
       gen_model_state(i,ipres_model,model_num) = pres_zone

    enddo

    !do i = 1, nx
    !   print *, gen_model_r(i), gen_model_state(i,idens_model), gen_model_state(i,ispec_model:ispec_model-1+nspec)
    !enddo

  end subroutine init_1d_tanh

end module initial_model_module


!===============================================================================
!> Fundamental constants in CGS and SI units
!===============================================================================
MODULE units_mod
  USE io_unit_mod
  USE math_mod
  USE omp_mod
  USE trace_mod
  implicit none
  private
  !-----------------------------------------------------------------------------
  ! Data type holding constants of nature for a system
  !-----------------------------------------------------------------------------
  type, public:: const_t
    character(len=16):: name='not set'
    real(kind=8):: m_u, m_h, m_he
    real(kind=8):: amu
    real(kind=8):: k_b
    real(kind=8):: h_p
    real(kind=8):: c
    real(kind=8):: e
    real(kind=8):: stefan
    real(kind=8):: grav
    real(kind=8):: AU
    real(kind=8):: pc
    real(kind=8):: yr
    real(kind=8):: kms
    real(kind=8):: mum
    real(kind=8):: Myr
    real(kind=8):: m_sun
    real(kind=8):: r_sun
    real(kind=8):: m_earth
    real(kind=8):: r_earth
    real(kind=8):: pi
  contains
    procedure:: init
  end type
  type(const_t), public:: cgs, si
  !-----------------------------------------------------------------------------
  ! Data type for transmitting system info as meta-data
  !-----------------------------------------------------------------------------
  type, public:: units_t
    character(len=4):: system='code'
    real(kind=8):: l=1d0
    real(kind=8):: t=1d0
    real(kind=8):: m=1d0
  contains
    procedure:: output
  end type
  type(units_t), public:: units
CONTAINS

SUBROUTINE init (self)
  class(const_t):: self
  !-----------------------------------------------------------------------------
  ! CGS units
  !-----------------------------------------------------------------------------
  cgs%name    = 'cgs'
  cgs%m_u     = 1.6726219d-24
  cgs%m_h     = cgs%m_u
  cgs%m_he    = 6.65e-24
  cgs%amu     = 1.66054d-24
  cgs%k_b     = 1.380658d-16                                            ! [erg/K]
  cgs%h_p     = 6.6260755d-27
  cgs%c       = 2.999792d10
  cgs%e       = 1.602177e-12
  cgs%stefan  = 5.67d-5
  cgs%grav    = 6.6743d-8
  cgs%AU      = 1.496d13
  cgs%pc      = 3.086d18
  cgs%yr      = 3.15542d7
  cgs%kms     = 1d5
  cgs%mum     = 1d-4
  cgs%Myr     = 3.15542d13
  cgs%m_sun   = 1.989d33
  cgs%r_sun   = 6.9598d10
  cgs%m_earth = 5.972d27
  cgs%r_earth = 6.371d8
  cgs%pi      = math%pi
  !-----------------------------------------------------------------------------
  ! SI units
  !-----------------------------------------------------------------------------
  si%name    = 'SI'
  si%m_u     = 1.6726d-27
  si%amu     = 1.66054d-27
  si%k_b     = 1.3807d-23
  si%h_p     = 6.6260755d-34
  si%c       = 2.999792d8
  si%e       = 1.602177e-19
  si%stefan  = 5.67d-8
  si%grav    = 6.6743d-11
  si%AU      = 1.496d11
  si%pc      = 3.086d16
  si%yr      = 3.15542d7
  si%kms     = 1d3
  si%mum     = 1d-6
  si%Myr     = 3.15542d13
  si%m_sun   = 1.989d30
  si%r_sun   = 6.9598d8
  si%m_earth = 5.972d25
  si%r_earth = 6.371d6
  si%pi      = math%pi
END SUBROUTINE init

!===============================================================================
!> Write out unit system info
!===============================================================================
SUBROUTINE output (self)
  class(units_t):: self
  character(len=4):: system
  real(kind=8):: l, t, m
  namelist /units_nml/ system, l, t, m
  !----------------------------------------------------------------------------
  call trace%begin ('units_t%init')
  system = self%system
  l      = self%l
  t      = self%t
  m      = self%m
  if (omp%master) then
    !$omp critical (write_nml_cr)
    write (io_unit%nml, units_nml)
    !$omp end critical (write_nml_cr)
  end if
  call trace%end()
END SUBROUTINE output

END MODULE units_mod


subroutine setaux(mbc,mx,xlower,dx,maux,aux)

    ! Called at start of computation before calling qinit, and
    ! when AMR is used, also called every time a new grid patch is created.
    ! Use to set auxiliary arrays aux(1:maux, 1-mbc:mx+mbc, 1-mbc:my+mbc).
    ! Note that ghost cell values may need to be set if the aux arrays
    ! are used by the Riemann solver(s).
    !
    ! This version sets aux(1,:) to b(x) for shallow flow
    ! and aux(2,:) to the ratio of cell width to dxc (capacity function).

    !use geoclaw_module, only: dry_tolerance !uncomment if needed
    !use geoclaw_module, only: grav  !uncomment if needed
    use geoclaw_module, only: earth_radius, coordinate_system, DEG2RAD
    use grid_module, only: xp_edge,z_edge,mx_edge
    use topo_module, only: topo_integrate

    implicit none
    integer, intent(in) :: mbc,mx,maux
    real(kind=8), intent(in) :: xlower,dx
    real(kind=8), intent(inout) ::  aux(maux,1-mbc:mx+mbc)

    !locals
    integer :: i,i0,i1,j
    real(kind=8) :: xcell,zcell,a

    if (mx+1 .ne. mx_edge) then
        write(6,*) 'mx_edge from grid.data must agree with mx+1'
        write(6,*) 'mx_edge = ',mx_edge
        write(6,*) 'mx = ',mx
        stop
        endif

    ! compute topo values and store in aux(1,:):
    call topo_integrate(mx,mbc,maux,aux)

    do i=1,mx
        aux(2,i) = (xp_edge(i+1) - xp_edge(i))/dx
        if (coordinate_system == 2) then
            ! convert degrees to meters:
            aux(2,i) = aux(2,i)* DEG2RAD * earth_radius
        endif
        if (aux(2,i) <= 0.d0) then
            write(6,*) '+++ i,xp_edge(i),xp_edge(i+1): ',i,xp_edge(i),xp_edge(i+1)
            endif
    enddo

    aux(:,0) = aux(:,1)
    aux(:,-1) = aux(:,1)
    aux(:,mx+1) = aux(:,mx)
    aux(:,mx+2) = aux(:,mx)

end subroutine setaux


C++*******************************************************
C Program to compute the mirror version X/Y of an image
C
C Syntax: RUNS MIRROR INPUT OUTPUT
C
C JLP
C Version of 23-03-90
C--*******************************************************
	PROGRAM MIRROR
	INTEGER*4 ISIZE,MADRID(1)
	INTEGER*4 PNTR_IN,PNTR_OUT,TEST,NX1,NY1,NX2,NY2,IOPT
	CHARACTER FILENAME*40,COMMENTS*80
	COMMON /VMR/MADRID

	CALL JLP_BEGIN

	WRITE(6,20)
20	FORMAT(' 1. X/Y mirror version of an image',/,
     1         ' 2. X mirror',/,
     1         ' 3. Y mirror',/,
     1         ' 4. Rotation of 180 degrees',/,
     1         ' 10. Exit',/,
     1         ' Enter your choice: ')
        READ(5,21) IOPT
21      FORMAT(I2)

C Exit if invalid option:
        IF(IOPT.LE.0.OR.IOPT.GT.4) THEN
          WRITE(6,*)' OK, exit without any processing'
          CALL JLP_END
          STOP
        ENDIF

C Format of the files:
	CALL JLP_INQUIFMT

C Input of the image:
        WRITE(6,*) 'Input file: '
        READ(5,10) FILENAME
10      FORMAT(A)
	CALL JLP_VM_READIMAG(PNTR_IN,NX1,NY1,FILENAME,COMMENTS)

C Allocating dynamical memory space:
	ISIZE=NX1*NY1*4
	CALL JLP_GETVM(PNTR_OUT,ISIZE)

C Calling the XY mirror subroutine :
        IF(IOPT.EQ.1)THEN
	  CALL XY_MIRROR(MADRID(PNTR_IN),MADRID(PNTR_OUT),NX1,NY1)
          NX2=NY1
          NY2=NX1
        ELSEIF(IOPT.EQ.2)THEN
	  CALL X_MIRROR(MADRID(PNTR_IN),MADRID(PNTR_OUT),NX1,NY1)
          NX2=NX1
          NY2=NY1
        ELSEIF(IOPT.EQ.3)THEN
	  CALL Y_MIRROR(MADRID(PNTR_IN),MADRID(PNTR_OUT),NX1,NY1)
          NX2=NX1
          NY2=NY1
C Rotation of 180 degrees:
        ELSEIF(IOPT.EQ.4)THEN
	  ISIZE=NX1*NY1*4
          CALL JLP_GETVM(TEST,ISIZE)
	  CALL X_MIRROR(MADRID(PNTR_IN),MADRID(TEST),NX1,NY1)
	  CALL Y_MIRROR(MADRID(TEST),MADRID(PNTR_OUT),NX1,NY1)
          CALL JLP_FREEVM(TEST,ISIZE)
          NX2=NX1
          NY2=NY1
        ENDIF

C Output of the file :
        WRITE(6,*) 'Output file: '
        READ(5,10) FILENAME
	CALL JLP_WRITEIMAG(MADRID(PNTR_OUT),NX2,NY2,NX2,
     1	FILENAME,COMMENTS)

	CALL JLP_END
	END
C---------------------------------------------------------------
C Subroutine XY_MIRROR
C--------------------------------------------------------------
	SUBROUTINE XY_MIRROR(INPUT,OUTPUT,NX1,NY1)
	REAL*4 INPUT(NX1,NY1),OUTPUT(NY1,NX1)
        INTEGER I,J

	DO J=1,NY1
	  DO I=1,NX1
	    OUTPUT(J,I)=INPUT(I,J)
	  END DO
	END DO

	RETURN
	END
C---------------------------------------------------------------
C Subroutine X_MIRROR
C--------------------------------------------------------------
	SUBROUTINE X_MIRROR(INPUT,OUTPUT,NX1,NY1)
	REAL*4 INPUT(NX1,NY1),OUTPUT(NX1,NY1)
        INTEGER I,J

	DO J=1,NY1
	  DO I=1,NX1
	    OUTPUT(I,J)=INPUT(NX1-I+1,J)
	  END DO
	END DO

	RETURN
	END
C---------------------------------------------------------------
C Subroutine Y_MIRROR
C--------------------------------------------------------------
	SUBROUTINE Y_MIRROR(INPUT,OUTPUT,NX1,NY1)
	REAL*4 INPUT(NX1,NY1),OUTPUT(NX1,NY1)
        INTEGER I,J

	DO J=1,NY1
	  DO I=1,NX1
	    OUTPUT(I,J)=INPUT(I,NY1-J+1)
	  END DO
	END DO

	RETURN
	END


!RUN: %flang -gdwarf-4 -S -emit-llvm %s -o - | FileCheck %s

!CHECK-LABEL: define void @callee_
!CHECK: call void @llvm.dbg.declare(metadata i64* %"array$p", metadata [[DLOC:![0-9]+]]
!CHECK-NEXT: call void @llvm.dbg.declare(metadata i64* %"array$p", metadata [[ASSOCIATED:![0-9]+]]
!CHECK-NEXT: call void @llvm.dbg.declare(metadata i64* %"array$sd", metadata [[ARRAY:![0-9]+]], metadata !DIExpression())
!CHECK: [[ARRAY]] = !DILocalVariable(name: "array"
!CHECK-SAME: arg: 2
!CHECK-SAME: type: [[TYPE:![0-9]+]]
!CHECK: [[TYPE]] = !DICompositeType(tag: DW_TAG_array_type,
!CHECK-SAME: dataLocation: [[DLOC]], associated: [[ASSOCIATED]]

subroutine callee (array)
  integer, pointer :: array(:, :)
  integer :: local = 4

  do i=LBOUND (array, 2), UBOUND (array, 2), 1
     do j=LBOUND (array, 1), UBOUND (array, 1), 1
        write(*, fmt="(i4)", advance="no") array (j, i)
     end do
     print *, ""
  end do

  local = local / 2
  print *, "local = ", local
end subroutine callee

program caller

  interface
     subroutine callee (array)
       integer, pointer :: array(:, :)
     end subroutine callee
  end interface

  integer, pointer :: caller_arr(:, :)
  integer, target :: tgt_arr(10,10)
  tgt_arr = 99
  tgt_arr(2,2) = 88

  caller_arr => tgt_arr
  call callee (caller_arr)

  print *, ""
end program caller


module mod_nodes_uniform
#include <messenger.h>
    use mod_kinds,      only: rk, ik
    use mod_constants,  only: ZERO, ONE, TWO, THREE, FOUR
    use mod_gridspace,  only: linspace
    implicit none

contains

    !>
    !!
    !!
    !!  @author Nathan A. Wukie
    !!  @date   6/28/2017
    !!
    !-------------------------------------------------------------------------------
    function uniform_nodes(level, dim) result(nodes_)
        integer(ik),    intent(in)  :: level
        integer(ik),    intent(in)  :: dim

        ! Level for quadrature nodes corresponds to the number of nodes
        ! in the 1D tensor construction of the node set.
        real(rk),   dimension(level+1)          :: xi_nodes, eta_nodes, zeta_nodes
        integer(ik)                             :: ixi, ieta, izeta, inode, nnodes, ierr, nnodes1d
        integer(ik)                             :: nnodes_xi, nnodes_eta, nnodes_zeta
        real(rk),   allocatable, dimension(:)   :: nodes_(:,:)

        !
        ! Uniform distribution starts with two nodes at end points.
        ! Therefore, minimum level(1) is two points(level+1)
        !
        nnodes1d = level + 1

        !
        ! Get 1D nodes
        !
        select case(dim)
            case(1)
                nnodes_xi   = nnodes1d
                nnodes_eta  = 1
                nnodes_zeta = 1
                xi_nodes    = linspace(-ONE,ONE,nnodes1d)
                eta_nodes   = ZERO
                zeta_nodes  = ZERO
            case(2)
                nnodes_xi   = nnodes1d
                nnodes_eta  = nnodes1d
                nnodes_zeta = 1
                xi_nodes    = linspace(-ONE,ONE,nnodes1d)
                eta_nodes   = linspace(-ONE,ONE,nnodes1d)
                zeta_nodes  = ZERO
            case(3)
                nnodes_xi   = nnodes1d
                nnodes_eta  = nnodes1d
                nnodes_zeta = nnodes1d
                xi_nodes    = linspace(-ONE,ONE,nnodes1d)
                eta_nodes   = linspace(-ONE,ONE,nnodes1d)
                zeta_nodes  = linspace(-ONE,ONE,nnodes1d)
            case default
                call chidg_signal_one(FATAL,"uniform_nodes: invalid dimension.",dim)
        end select

        !
        ! Allocate nodes_
        !
        nnodes = nnodes_xi*nnodes_eta*nnodes_zeta
        allocate(nodes_(nnodes,3), stat=ierr)
        if (ierr /= 0) call AllocationError

        !
        ! Contruct node set
        !
        inode = 1
        do izeta = 1,nnodes_zeta
            do ieta = 1,nnodes_eta
                do ixi = 1,nnodes_xi
                    nodes_(inode,1) = xi_nodes(ixi)
                    nodes_(inode,2) = eta_nodes(ieta)
                    nodes_(inode,3) = zeta_nodes(izeta)
                    inode = inode + 1
                end do
            end do
        end do

    end function uniform_nodes
    !***********************************************************************************

    !>
    !!
    !!
    !!  @author Nathan A. Wukie (AFRL)
    !!  @date   7/5/2017
    !!
    !-----------------------------------------------------------------------------------
    function uniform_weights(level,dim) result(weights)
        integer(ik),    intent(in)  :: level
        integer(ik),    intent(in)  :: dim

        real(rk),   allocatable :: weights(:), xi_weights(:), eta_weights(:), zeta_weights(:)
        integer(ik)             :: nnodes1d, nweights_xi, nweights_eta, nweights_zeta, nweights, &
                                   inode, ixi, ieta, izeta, ierr

        !
        ! For the node set 'Uniform', the number of nodes in 1D is
        ! defined as (level + 1)
        !
        nnodes1d = level + 1

        !
        ! Get 1D weights
        !
        allocate(xi_weights(nnodes1d), eta_weights(nnodes1d), zeta_weights(nnodes1d), stat=ierr)
        if (ierr /= 0) call AllocationError

        select case(dim)
            case(1)
                nweights_xi   = nnodes1d
                nweights_eta  = 1
                nweights_zeta = 1
                xi_weights    = uniform_weights_1d(nnodes1d)
                eta_weights   = ONE
                zeta_weights  = ONE
            case(2)
                nweights_xi   = nnodes1d
                nweights_eta  = nnodes1d
                nweights_zeta = 1
                xi_weights    = uniform_weights_1d(nnodes1d)
                eta_weights   = uniform_weights_1d(nnodes1d)
                zeta_weights  = ONE
            case(3)
                nweights_xi   = nnodes1d
                nweights_eta  = nnodes1d
                nweights_zeta = nnodes1d
                xi_weights    = uniform_weights_1d(nnodes1d)
                eta_weights   = uniform_weights_1d(nnodes1d)
                zeta_weights  = uniform_weights_1d(nnodes1d)
            case default
                call chidg_signal_one(FATAL,"quadrature_weights: invalid dimension.",dim)
        end select

        !
        ! Allocate weights_
        !
        nweights = nweights_xi*nweights_eta*nweights_zeta
        allocate(weights(nweights), stat=ierr)
        if (ierr /= 0) call AllocationError

        !
        ! Contruct node set
        !
        inode = 1
        do izeta = 1,nweights_zeta
            do ieta = 1,nweights_eta
                do ixi = 1,nweights_xi
                    weights(inode) = xi_weights(ixi)*eta_weights(ieta)*zeta_weights(izeta)
                    inode = inode + 1
                end do
            end do
        end do

    end function uniform_weights
    !***********************************************************************************

    !>  Compute quadrature weights for a 1D uniform node distribution between [-1,1].
    !!
    !!  Even number of nodes: Composite Trapezoid rule (less accurate)
    !!  Odd number of nodes:  Composite Simpson's rule (more accurate)
    !!
    !!
    !!  NOTE: An odd number of nodes should always be preferred, since the Composite
    !!        Simpson's rule is much more accurate than the Composite Trapezoid rule.
    !!
    !!
    !!  @author Nathan A. Wukie (AFRL)
    !!  @date   7/5/2017
    !!
    !------------------------------------------------------------------------------------
    function uniform_weights_1d(nnodes1d) result(weights)
        integer(ik),    intent(in)  :: nnodes1d

        real(rk)    :: weights(nnodes1d)
        integer(ik) :: inode
        logical     :: even, even_node

        ! determin odd/even
        even = (mod(nnodes1d,2) == 0)

        !
        ! EVEN: Composite Trapezoid rule
        !   int_a^b[f]dx = h/2[f(x0) + 2f(x1) + 2f(x2) + ... + 2f(x_{n-1}) + f(xn)]
        !   Weights computed for x in [-1,1]. h=2
        !
        if (even) then
            weights(1)        = ONE ! f(x0)
            weights(nnodes1d) = ONE ! f(xn)

            if (nnodes1d > 2) then
                do inode = 2,nnodes1d-1
                    weights(inode) = TWO
                end do !inode
            end if

        !
        ! ODD: Composite Simpson's rule
        !   int_a^b[f]dx = h/3[f(x0) + 4f(x1) + 2f(x2) + 4f(x3) + 2f(x4) + ... + 4f(x_{n-1}) + f(xn)]
        !   Weights computed for x in [-1,1]. h=2
        !
        else
            weights(1)        = TWO/THREE   ! f(x0)
            weights(nnodes1d) = TWO/THREE   ! f(xn)

            do inode = 2,nnodes1d-1
                even_node = (mod(inode,2) == 0)
                if (even_node) then
                    weights(inode) = (TWO/THREE)*FOUR
                else
                    weights(inode) = (TWO/THREE)*TWO
                end if
            end do !inode

        end if

    end function uniform_weights_1d
    !************************************************************************************

!    !>
!    !!
!    !!
!    !!  @author Nathan A. Wukie (AFRL)
!    !!  @date   6/28/2017
!    !!
!    !-----------------------------------------------------------------------------------
!    function linspace(xmin,xmax,res) result(nodes_)
!        real(rk),       intent(in)  :: xmin
!        real(rk),       intent(in)  :: xmax
!        integer(ik),    intent(in)  :: res
!
!        integer(ik) :: inode
!        real(rk)    :: nodes_(res)
!
!        !
!        ! Compute 1d point coordinates in each direction
!        !
!        do inode = 1,res
!            nodes_(inode) = xmin + (xmax-xmin)*(real(inode,rk)-ONE)/(real(res,rk)-ONE)
!        end do
!
!    end function linspace
!    !***********************************************************************************

end module mod_nodes_uniform


module PrecisionMod
    use iso_c_binding!OTHER-COMPILER
    implicit none
    integer, parameter :: MK = C_DOUBLE  !< MK stand for MyKind : The kind used throughout the program.
    ! Iso c binding pseudo replacement... compiler and platform dependent!
    ! Gfortran and intel have those values, but better to comment and use iso_c_binding above)
    !integer, parameter :: C_INT    = 4 !COMPAQ-COMPILER
    !integer, parameter :: C_FLOAT  = 4 !COMPAQ-COMPILER
    !integer, parameter :: C_DOUBLE = 8 !COMPAQ-COMPILER
    !integer, parameter :: C_CHAR   = 1 !COMPAQ-COMPILER

    integer, parameter :: SP = kind( 1.0e0 ) !< Single Precision
    integer, parameter :: DP = kind( 1.0d0 ) !< Double Precision
    !integer, parameter :: DP = selected_real_kind( 16 ) !< Double Precision
!     integer, parameter :: QP = selected_real_kind (32) !< Quad Precision
    integer, parameter :: QP = selected_real_kind(33, 4931)
    !integer, parameter :: MK = C_DOUBLE       !< MK stand for MyKind : The kind used throughout the program. MODIFIED BY MAKEFILE
    integer, parameter :: CDK = C_DOUBLE       !< C Double Kind
    integer, parameter :: CIK = C_INT          !< C Integer Kind
    integer, parameter :: CIC = C_CHAR         !< C Char Kind

    real(MK),parameter :: PRECISION_EPS =  epsilon(1.0_MK) !< Machine Precision For the given MyKind for problems of scale 1!
!     real(MK),parameter :: PRECISION_UI  = 2.2204460e-10_MK  !<
    real(MK),parameter :: PRECISION_UI  = PRECISION_EPS/100  !<
    ! #define FLT_EPSILON 1.19209290e-07F
    ! #define DBL_EPSILON 2.2204460492503131e-16
    ! #define LDBL_EPSILON 1.0842021724855044340075E-19L
    ! #define PRECISION_EPS DBL_EPSILON //< Machine Precision For the given MyKind for problems of scale 1!

    ! Pointers
    !integer, parameter :: IPTR_KIND = int_ptr_kind() !INTEL-COMPILER !For compatibility 32/64bits
    integer, parameter :: IPTR_KIND = 4               !OTHER-COMPILER !For compatibility 32/64bits
    !integer, parameter :: IPTR_KIND = 4              !COMPAQ-COMPILER!For compatibility 32/64bits

    integer, parameter :: I4 = 4

contains

    !> Checks if two reals are equal given machine precision
    logical function precision_equal(x,y)
        real(MK), intent(in) :: x
        real(MK), intent(in) :: y
        precision_equal=abs(x-y)<PRECISION_EPS
    end function

    !> Checks if two reals are different
    logical function precision_different(x,y)
        real(MK), intent(in) :: x
        real(MK), intent(in) :: y
        precision_different=.not.precision_equal(x,y)
    end function

    !> Checks if two reals are equal given machine precision
    logical function precision_equal_soft(x,y)
        real(MK), intent(in) :: x
        real(MK), intent(in) :: y
        precision_equal_soft=abs(x-y)<1000*PRECISION_EPS
    end function

    !> Checks if two reals are equal given machine precision
    logical function precision_equal_r4(x,y)
        real(4), intent(in) :: x
        real(4), intent(in) :: y
        precision_equal_r4=abs(x-y)<epsilon(real(1.0,4))
    end function

    !> Checks if two reals are different
    logical function precision_different_r4(x,y)
        real(4), intent(in) :: x
        real(4), intent(in) :: y
        precision_different_r4=.not.precision_equal_r4(x,y)
    end function

    !> Checks if two reals are equal given machine precision
    logical function precision_equal_r8(x,y)
        real(8), intent(in) :: x
        real(8), intent(in) :: y
        precision_equal_r8=abs(x-y)<epsilon(real(1.0,8))
    end function

    !> Checks if two reals are different
    logical function precision_different_r8(x,y)
        real(8), intent(in) :: x
        real(8), intent(in) :: y
        precision_different_r8=.not.precision_equal_r8(x,y)
    end function

    !> Checks if two reals are equal given machine precision
    logical function precision_equal_rdp(x,y)
        double precision, intent(in) :: x
        double precision, intent(in) :: y
        precision_equal_rdp=abs(x-y)<epsilon(1.0d0)
    end function

    !> Checks if two reals are different
    logical function precision_different_rdp(x,y)
        double precision, intent(in) :: x
        double precision, intent(in) :: y
        precision_different_rdp=.not. precision_equal_rdp(x,y)
    end function

    !> Print precision
    subroutine precision_print()
        print'(A,A)'     ,'Precision : ',precision_string()
        print'(A,5I3)'   ,'Precision types: ',MK,SP,DP,C_FLOAT,C_DOUBLE
        print'(a,E80.64)','Precision eps: ',PRECISION_EPS
        print'(a,E80.64)','Precision ui : ',PRECISION_UI
        print'(A,I3)','Bytes MK: ',sizeof(1.0_MK)!OTHER-COMPILER
        print'(A,I3)','Bytes SP: ',sizeof(1.0_SP)!OTHER-COMPILER
        print'(A,I3)','Bytes DP: ',sizeof(1.0_DP)!OTHER-COMPILER
    end subroutine

    integer function sizeOfReal() result(num_bytes)
        !num_bytes=0             !COMPAQ-COMPILER
        num_bytes=int(sizeof(1.0_MK))!OTHER-COMPILER
!         implicit none
!         character, dimension(:), allocatable :: c
!         real(MK) :: r
!         r=0.0_MK
! !         intrinsic size
! !         intrinsic transfer
! !         sizeOfReal = size(transfer(r,c))
!         inquire(iolength=sizeOfReal)r
!          use iso_fortran_env
!         integer :: num_file_storage_units
!         inquire(iolength=num_file_storage_units) 1.0D0
!         num_bytes = num_file_storage_units*FILE_STORAGE_SIZE/8
!         write(*,*) "double has size: ", num_bytes
!         return
    end function sizeOfReal

    !> Print precision
    function precision_string() result(s)
        character(len=40) :: s
        if(MK==SP) then
            if(SP==C_FLOAT) then
                s="single precision - C float"
            else
                s="single precision"
            endif
        elseif(MK==DP) then
            if(SP==C_DOUBLE) then
                s="double precision - C double"
            else
                s="double precision"
            endif
        else
            if(MK==C_FLOAT) then
            s="C float"
            elseif(MK==C_DOUBLE) then
                s="C double"
            else
                s="unknown"
            endif
        endif
    end function

end module PrecisionMod


program strength_red
  use iso_fortran_env, only : real64
  implicit none

  integer, parameter :: n = 19900000
  integer :: i,j
  real(real64), dimension(n) :: a,b
  real(real64) :: rec, pi = 3.1415, r

  a = (/ (i, i = 1, n) /)
  b = (/ (2*i, i = 1, n) /)

  do j = 1, 1000
     do i = 1, n
        a(i) = b(i) / pi
     end do
  end do

  ! rec = 1/pi

  ! do j = 1, 1000
  !    do i = 1, n
  !       a(i) = b(i) * rec
  !    end do
  ! end do

  write(*,*) a(100)

end program strength_red


program resolution
    implicit none

    real(8), dimension(:), allocatable :: vector
    real(8), dimension(:), allocatable :: result
    real(8), dimension(:, :), allocatable :: matrix
    real(8) :: start, end, timeRows, timeColumns
    integer :: n = 1;

    call random_seed()

    do while (.true.)
        allocate(vector(n))
        allocate(result(n))
        allocate(matrix(n, n))

        call genRandomVector(vector, n)
        call genRandomMatrix(matrix, n)

        call cpu_time(start)
        call multiplyByRows(matrix, vector, result, n)
        call cpu_time(end)
        timeRows = end - start

        call cpu_time(start)
        call multiplyByColumns(matrix, vector, result, n)
        call cpu_time(end)
        timeColumns = end - start

        print *,n,",",timeRows,",",timeColumns

        deallocate(vector)
        deallocate(result)
        deallocate(matrix)

        n = n * 2
    end do

    contains

    subroutine genRandomVector(vector, n)
        implicit none

        integer :: n, i
        real(8), dimension(:) :: vector
        real(8) :: random

        do i = 1, n
            call random_number(random)
            vector(i) = random * (n)
        end do
    end

    subroutine genRandomMatrix(matrix, n)
        implicit none

        integer :: n, i, j
        real(8), dimension(:, :) :: matrix
        real(8) :: random

        do i = 1, n
            do j = 1, n
                call random_number(random)
                matrix(i, j) = random * (n)
            end do
        end do
    end

    subroutine multiplyByRows(matrix, vector, result, n)
        implicit none

        integer :: n, i, j
        real(8), dimension(:, :) :: matrix
        real(8), dimension(:) :: vector, result

        do i = 1, n
            result(i) = 0
            do j = 1, n
                result(i) = result(i) + matrix(i, j) * vector(j)
            end do
        end do
    end

    subroutine multiplyByColumns(matrix, vector, result, n)
        implicit none

        integer :: n, i, j
        real(8), dimension(:, :) :: matrix
        real(8), dimension(:) :: vector, result

        do j = 1, n
            result(j) = 0
            do i = 1, n
                result(i) = result(i) + matrix(i, j) * vector(j)
            end do
        end do
    end

end program resolution


! Copyright 2019-2020 Free Software Foundation, Inc.
!
! This program is free software; you can redistribute it and/or modify
! it under the terms of the GNU General Public License as published by
! the Free Software Foundation; either version 3 of the License, or
! (at your option) any later version.
!
! This program is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
! GNU General Public License for more details.
!
! You should have received a copy of the GNU General Public License
! along with this program.  If not, see <http://www.gnu.org/licenses/>.

module some_module
  implicit none

  type, public :: Number
     integer :: a
   contains
     procedure :: get => get_number
     procedure :: set => set_number
  end type Number

contains

  function get_number (this) result (val)
    class (Number), intent (in) :: this
    integer :: val
    val = this%a
  end function get_number

  subroutine set_number (this, val)
    class (Number), intent (inout) :: this
    integer :: val
    this%a = val
  end subroutine set_number

end module some_module

logical function is_bigger (a,b)
  integer, intent(in) :: a
  integer, intent(in) :: b
  is_bigger = a > b
end function is_bigger

subroutine say_numbers (v1,v2,v3)
  integer,intent(in) :: v1
  integer,intent(in) :: v2
  integer,intent(in) :: v3
  print *, v1,v2,v3
end subroutine say_numbers

program test
  use some_module

  interface
     integer function fun1 (x)
       integer :: x
     end function fun1

     integer function fun2 (x)
       integer :: x
     end function fun2

     subroutine say_array (arr)
       integer, dimension (:,:) :: arr
     end subroutine say_array
  end interface

  type (Number) :: n1
  type (Number) :: n2

  procedure(fun1), pointer:: fun_ptr => NULL()

  integer, dimension (5,5) :: array
  array = 0

  call say_numbers (1,2,3)	! stop here
  call say_string ('hello world')
  call say_array (array (2:3, 2:4))
  print *, fun_ptr (3)

end program test

integer function fun1 (x)
  implicit none
  integer :: x
  fun1 = x + 1
end function fun1

integer function fun2 (x)
  implicit none
  integer :: x
  fun2 = x + 2
end function fun2

subroutine say_string (str)
  character(len=*) :: str
  print *, str
end subroutine say_string

subroutine say_array (arr)
  integer, dimension (:,:) :: arr
  do i=LBOUND (arr, 2), UBOUND (arr, 2), 1
     do j=LBOUND (arr, 1), UBOUND (arr, 1), 1
        write(*, fmt="(i4)", advance="no") arr (j, i)
     end do
     print *, ""
  end do
end subroutine say_array


#INCLUDE 'MR_H_ALIGN_PADDING.H'
!***********************************************************************************************************************************
! UNIT:
!
!  (MODULE)
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  MODULE MR_MOD_CALC_GRAD_Z

    USE MR_KINDS

    IMPLICIT NONE

    PRIVATE

    PUBLIC :: MR_CALC_GRAD_Z_UV
    PUBLIC :: MR_CALC_GRAD_Z_SS

!***********************************************************************************************************************************

  CONTAINS

!***********************************************************************************************************************************
! UNIT:
!
!  (SUBROUTINE)
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  SUBROUTINE MR_CALC_GRAD_Z_UV( NI , NJ , NK , UVW , GRAD_Z_UV )

    IMPLICIT NONE

    INTEGER(IJID_KIND) , INTENT(IN ) :: NI , NJ
    INTEGER(KKID_KIND) , INTENT(IN ) :: NK

    REAL   (FDRD_KIND) , INTENT(IN ) , DIMENSION(1:NI1(NI,FDRD_KIND),1:NJ,1:2,0:NK) :: UVW

    REAL   (FDRD_KIND) , INTENT(OUT) , DIMENSION(1:NI1(NI,FDRD_KIND),1:NJ,1:2,1:NK) :: GRAD_Z_UV

    INTEGER(IJID_KIND) :: I , J
    INTEGER            :: DIM
    INTEGER(KKID_KIND) :: K

    DO K = 1 , NK

      DO DIM = 1 , 2

        DO J = 1 , NJ
         !DIR$ VECTOR ALIGNED
          DO I = 1 , NI
            GRAD_Z_UV( I , J ,DIM, K ) = UVW( I , J ,DIM, K ) - UVW( I , J ,DIM,K-1)
          END DO
        END DO

      END DO

    END DO

  END SUBROUTINE MR_CALC_GRAD_Z_UV

!***********************************************************************************************************************************
! UNIT:
!
!  (SUBROUTINE)
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  SUBROUTINE MR_CALC_GRAD_Z_SS( NI , NJ , NK , SW , GRAD_Z_SS )

    IMPLICIT NONE

    INTEGER(IJID_KIND) , INTENT(IN ) :: NI , NJ
    INTEGER(KKID_KIND) , INTENT(IN ) :: NK

    REAL   (FDRD_KIND) , INTENT(IN ) , DIMENSION(1:NI1(NI,FDRD_KIND),1:NJ,0:NK) :: SW

    REAL   (FDRD_KIND) , INTENT(OUT) , DIMENSION(1:NI1(NI,FDRD_KIND),1:NJ,1:NK) :: GRAD_Z_SS

    INTEGER(IJID_KIND) :: I , J
    INTEGER(KKID_KIND) :: K

    DO K = 1 , NK

      DO J = 1 , NJ
       !DIR$ VECTOR ALIGNED
        DO I = 1 , NI
          GRAD_Z_SS( I , J , K ) = SW( I , J , K ) - SW( I , J ,K-1)
        END DO
      END DO

    END DO

  END SUBROUTINE MR_CALC_GRAD_Z_SS

  END MODULE MR_MOD_CALC_GRAD_Z


C    @(#)chkovflo.f	20.3 2/13/96
C****************************************************************
C
C   	File: chkovflo.f
C
C   	Purpose: This function decodes real "x" into ascii elements
C                components "array(1)", "array(2)", ..., etc. More
C                than one element will be required if the original
C                "x" cannot be coded using format "(w.d)". The sum
C                of these decoded elements will equal the original "x".
C
C       Input parameters:
C
C             x        - the real variable to be encoded (fw.d)
C             w        - the width of the format (fw.d)
C             d        - the number of digits to the right of the
C                        decimal point in the format (fw.d)
C
C       Output parameters:
C
c             num      - the number of encoded words that are required
C                        to encode x into format (fw.d) using explicit
C                        exponiation.
c             array    - a character array of length num which contains
C                        encoded x to fit collectively into x.
C
C                        if num = 1, the original format was sufficient.
C
C   	Author: Walt Powell            Date: 7 September 1994
C   	Called by: ext_bus.f
C
C****************************************************************
	integer function chkovflo (x, w, d, num, array)
       	integer w, d, num
        character array(*)*(*)

        include 'ipfinc/parametr.inc'

        include 'ipfinc/prt.inc'

        logical finished
        character fmt*10, code*10, tempc*20, ljstfy*20
        integer size, fx, ix, digits

        chkovflo = 0
        if (abs(x) .le. 1.0) then
          num = 1
          array(num) = code (x, w, d)
        else if (w - d .lt. 2) then
          num = 1
          array(num) = code (x, w, d)
        else
          num = 0
          total = 0.0           ! "total" is accumulated encoded value
          fx = w - d
          if (x-total .lt. 0.0) fx = fx - 1 ! fx is size of mantissa
          digits = w - 2
          if (x .lt. 0 .and. digits .gt. 0) digits = digits - 1
          if (abs(x-total) .gt. 1.0) then
            size = alog10 (abs (x-total)) + 1
          else
            size = 0
          endif
          do while (size .gt. fx)
            num = num + 1
            ix = int (x-total + sign (0.5, x-total))
            write (tempc, '(i10)') ix
            array(num) = ljstfy(tempc)
            write (array(num)(w-1:), 110) size-digits+d
  110       format ('E', i1)
            write (fmt, 120) w, d
  120       format (bn, '(f', i1, '.', i1, ')')
            read (array(num), fmt=fmt) temp
            total = total + temp
            if (abs(x-total) .gt. 1.0) then
              size = alog10 (abs (x-total)) + 1
            else
              size = 0
            endif
          enddo
          if (size .gt. 0) then
            num = num + 1
            array(num) = code (x-total, w, d)
          endif
       endif

       total = 0.0
       write (fmt, 120) w, d
       do i = 1, num
          read (array(i), fmt=fmt) temp
          total = total + temp
c         write (*, 150) array(i), temp, total
c 150     format (t2, 'Encoded X = ', a, t22, 'X = ', f10.2,
c    &            t38, 'Total = ', f10.2)
       enddo
       if (total .gt. 0.0 .and. abs (x/total) .gt. 1.0e-3) then
          write ( errbuf(1), 160) total, x
  160     format (' Encoding error - Total = ', e12.5, ' Original = ',
     &              e12.5)
          call prterx ('W', 1)
       endif
       return
       end


      subroutine complex_array(c)
        implicit none
        complex(kind=8), dimension(:,:), intent(inout) :: c

        c = cmplx(1, 2)

      end subroutine complex_array