MODULE MomentEquationsLimiterModule_DG

  USE KindModule, ONLY: &
    DP
  USE ProgramHeaderModule, ONLY: &
    nDOFX, nDOF, &
    nX, nNodesX, &
    nE, nNodesE
  USE UtilitiesModule, ONLY: &
    NodeNumberX, &
    NodeNumber
  USE PolynomialBasisModule_Lagrange, ONLY: &
    L_E, L_X1, L_X2, L_X3
  USE PolynomialBasisModule_Legendre, ONLY: &
    P_X1, P_X2, P_X3, IndPX_Q
  USE MeshModule, ONLY: &
    MeshE, &
    MeshX
  USE MomentEquationsLimiterUtilitiesModule_DG, ONLY: &
    InitializeDiscontinuityDetector

  IMPLICIT NONE
  PRIVATE

  LOGICAL,                               PUBLIC :: ApplySlopeLimiter
  REAL(DP),                              PUBLIC :: BetaTVD
  REAL(DP),                              PUBLIC :: BetaTVB
  REAL(DP), DIMENSION(:,:), ALLOCATABLE, PUBLIC :: LegendreX

  LOGICAL,                               PUBLIC :: ApplyPositivityLimiter
  INTEGER,                               PUBLIC :: nPositivePoints
  REAL(DP), DIMENSION(:),   ALLOCATABLE, PUBLIC :: Points_E
  REAL(DP), DIMENSION(:),   ALLOCATABLE, PUBLIC :: Points_X1
  REAL(DP), DIMENSION(:),   ALLOCATABLE, PUBLIC :: Points_X2
  REAL(DP), DIMENSION(:),   ALLOCATABLE, PUBLIC :: Points_X3
  REAL(DP), DIMENSION(:,:), ALLOCATABLE, PUBLIC :: Lagrange

  PUBLIC :: InitializeLimiters_M1_DG

CONTAINS

  SUBROUTINE InitializeLimiters_M1_DG &
               ( ApplySlopeLimiter_Option, BetaTVB_Option, BetaTVD_Option, &
                 ApplyPositivityLimiter_Option )

    LOGICAL,  INTENT(in), OPTIONAL :: ApplySlopeLimiter_Option
    REAL(DP), INTENT(in), OPTIONAL :: BetaTVB_Option
    REAL(DP), INTENT(in), OPTIONAL :: BetaTVD_Option
    LOGICAL,  INTENT(in), OPTIONAL :: ApplyPositivityLimiter_Option

    INTEGER :: iNodeE, iNodeX1, iNodeX2, iNodeX3, iNode, iNodeX
    INTEGER :: jNodeE, jNodeX1, jNodeX2, jNodeX3, jNode
    REAL(DP) :: eta_E, eta_X1, eta_X2, eta_X3

    ! --- Limiter Parameters ---

    ApplySlopeLimiter = .TRUE.
    IF( PRESENT( ApplySlopeLimiter_Option ) ) &
      ApplySlopeLimiter = ApplySlopeLimiter_Option

    BetaTVB = 0.0_DP
    IF( PRESENT( BetaTVB_Option ) ) &
      BetaTVB = BetaTVB_Option

    BetaTVD = 1.8_DP
    IF( PRESENT( BetaTVD_Option ) ) &
      BetaTVD = BetaTVD_Option

    ApplyPositivityLimiter = .TRUE.
    IF( PRESENT( ApplyPositivityLimiter_Option ) ) &
      ApplyPositivityLimiter = ApplyPositivityLimiter_Option

    WRITE(*,*)
    WRITE(*,'(A5,A)') '', 'InitializeLimiters_M1_DG'
    WRITE(*,*)
    WRITE(*,'(A7,A20,L1)') &
      '', 'ApplySlopeLimiter = ', ApplySlopeLimiter
    WRITE(*,'(A7,A10,ES8.2E2)') '', 'BetaTVB = ', BetaTVB
    WRITE(*,'(A7,A10,ES8.2E2)') '', 'BetaTVD = ', BetaTVD
    WRITE(*,'(A7,A25,L1)') &
      '', 'ApplyPositivityLimiter = ', ApplyPositivityLimiter
    WRITE(*,*)

    CALL InitializeDiscontinuityDetector

    CALL InitializeSlopeLimiter_M1_DG

    CALL InitializePositivityLimiter_M1_DG

  END SUBROUTINE InitializeLimiters_M1_DG

  SUBROUTINE InitializeSlopeLimiter_M1_DG

    INTEGER :: iPol
    INTEGER :: iNodeX1, iNodeX2, iNodeX3, iNode, iNodeX

    ! --- Legendre Polynomials in Gaussian Spatial Quadrature Points ---

    ALLOCATE( LegendreX(nDOFX,nDOFX) )

    DO iPol = 1, nDOFX

      DO iNodeX3 = 1, nNodesX(3)
        DO iNodeX2 = 1, nNodesX(2)
          DO iNodeX1 = 1, nNodesX(1)

            iNodeX = NodeNumberX( iNodeX1, iNodeX2, iNodeX3 )

            LegendreX(iNodeX,iPol) &
                = P_X1  (IndPX_Q(1,iPol)) % P( MeshX(1) % Nodes(iNodeX1) ) &
                  * P_X2(IndPX_Q(2,iPol)) % P( MeshX(2) % Nodes(iNodeX2) ) &
                  * P_X3(IndPX_Q(3,iPol)) % P( MeshX(3) % Nodes(iNodeX3) )

          END DO
        END DO
      END DO

    END DO

  END SUBROUTINE InitializeSlopeLimiter_M1_DG

  SUBROUTINE InitializePositivityLimiter_M1_DG

    INTEGER :: iPoint
    INTEGER :: iNodeE, iNodeX1, iNodeX2, iNodeX3, iNode
    REAL(DP), DIMENSION(:), ALLOCATABLE :: NodesX1

    ! --- Number of Points Where Positivity is Required ---

    ALLOCATE( NodesX1(nNodesX(1)+2) )

    NodesX1 = [ - 0.5_DP, MeshX(1) % Nodes, + 0.5_DP ]

    nPositivePoints &
      = nNodesE * ( nNodesX(1) + 2 ) * nNodesX(2) * nNodesX(3)

    IF( nNodesX(2) > 1 ) &
      nPositivePoints &
        = nPositivePoints + 2 * nNodesE * nNodesX(1) * nNodesX(3)

    IF( nNodesX(3) > 1 ) &
      nPositivePoints &
        = nPositivePoints + 2 * nNodesE * nNodesX(2) * nNodesX(3)

    ! --- Coordinates of Points Where Positivity is Required:

    ALLOCATE &
      ( Points_E (nPositivePoints), Points_X1(nPositivePoints), &
        Points_X2(nPositivePoints), Points_X3(nPositivePoints) )

    iPoint = 0

    DO iNodeX3 = 1, nNodesX(3)
      DO iNodeX2 = 1, nNodesX(2)
        DO iNodeX1 = 1, SIZE( NodesX1 )
          DO iNodeE = 1, nNodesE

            iPoint = iPoint + 1

            Points_E (iPoint) = MeshE    % Nodes(iNodeE)
            Points_X1(iPoint) = NodesX1(iNodeX1)
            Points_X2(iPoint) = MeshX(2) % Nodes(iNodeX2)
            Points_X3(iPoint) = MeshX(3) % Nodes(iNodeX3)

          END DO
        END DO
      END DO
    END DO

    IF( nNodesX(2) > 1 )THEN

      DO iNodeX3 = 1, nNodesX(3)
        DO iNodeX1 = 1, nNodesX(1)
          DO iNodeE = 1, nNodesE

            iPoint = iPoint + 1

            Points_E (iPoint) = MeshE    % Nodes(iNodeE)
            Points_X1(iPoint) = MeshX(1) % Nodes(iNodeX1)
            Points_X2(iPoint) = - 0.5_DP
            Points_X3(iPoint) = MeshX(3) % Nodes(iNodeX3)

          END DO
        END DO
      END DO

      DO iNodeX3 = 1, nNodesX(3)
        DO iNodeX1 = 1, nNodesX(1)
          DO iNodeE = 1, nNodesE

            iPoint = iPoint + 1

            Points_E (iPoint) = MeshE    % Nodes(iNodeE)
            Points_X1(iPoint) = MeshX(1) % Nodes(iNodeX1)
            Points_X2(iPoint) = + 0.5_DP
            Points_X3(iPoint) = MeshX(3) % Nodes(iNodeX3)

          END DO
        END DO
      END DO

    END IF

    IF( nNodesX(3) > 1 )THEN

      DO iNodeX2 = 1, nNodesX(2)
        DO iNodeX1 = 1, nNodesX(1)
          DO iNodeE = 1, nNodesE

            iPoint = iPoint + 1

            Points_E (iPoint) = MeshE    % Nodes(iNodeE)
            Points_X1(iPoint) = MeshX(1) % Nodes(iNodeX1)
            Points_X2(iPoint) = MeshX(2) % Nodes(iNodeX2)
            Points_X3(iPoint) = - 0.5_DP

          END DO
        END DO
      END DO

      DO iNodeX2 = 1, nNodesX(2)
        DO iNodeX1 = 1, nNodesX(1)
          DO iNodeE = 1, nNodesE

            iPoint = iPoint + 1

            Points_E (iPoint) = MeshE    % Nodes(iNodeE)
            Points_X1(iPoint) = MeshX(1) % Nodes(iNodeX1)
            Points_X2(iPoint) = MeshX(1) % Nodes(iNodeX1)
            Points_X3(iPoint) = + 0.5_DP

          END DO
        END DO
      END DO

    END IF

    DEALLOCATE( NodesX1 )

    ! --- Lagrange Polynomials Evaluated in Positive Points ---

    ALLOCATE( Lagrange(nDOF,nPositivePoints) )

    DO iNodeX3 = 1, nNodesX(3)
      DO iNodeX2 = 1, nNodesX(2)
        DO iNodeX1 = 1, nNodesX(1)
          DO iNodeE = 1, nNodesE

            iNode = NodeNumber( iNodeE, iNodeX1, iNodeX2, iNodeX3 )

            DO iPoint = 1, nPositivePoints

              Lagrange(iNode,iPoint) &
                = L_E(iNodeE) % P( Points_E(iPoint) ) &
                    * L_X1(iNodeX1) % P( Points_X1(iPoint) ) &
                        * L_X2(iNodeX2) % P( Points_X2(iPoint) ) &
                            * L_X3(iNodeX3) % P( Points_X3(iPoint) )

            END DO

          END DO
        END DO
      END DO
    END DO

  END SUBROUTINE InitializePositivityLimiter_M1_DG

END MODULE MomentEquationsLimiterModule_DG


SUBROUTINE clawpack5_rpn2_euler5(ixy,maxm,meqn,mwaves,maux, &
     mbc,mx,ql,qr,auxl,auxr,wave,s,amdq,apdq)
!
! Roe-solver for the Euler equations with a tracer variable and separate shear
! and entropy waves.

! waves: 4
! equations: 5

! Conserved quantities:
!       1 density
!       2 x_momentum
!       3 y_momentum
!       4 energy
!       5 tracer

! On input, ql contains the state vector at the left edge of each cell
!           qr contains the state vector at the right edge of each cell
!
! This data is along a slice in the x-direction if ixy=1
!                            or the y-direction if ixy=2.
! On output, wave contains the waves, s the speeds,
! and amdq, apdq the decomposition of the flux difference
!     f(qr(i-1)) - f(ql(i))
! into leftgoing and rightgoing parts respectively.  With the Roe solver we have
!      amdq  =  A^- \Delta q    and    apdq  =  A^+ \Delta q
! where A is the Roe matrix.  An entropy fix can also be incorporated into the
! flux differences.

! Note that the i'th Riemann problem has left state qr(:,i-1)
!                                   and right state ql(:,i)
! From the basic clawpack routines, this routine is called with ql = qr
!
! This routine has been made thread safe by removing the common block storage
! of the Roe-averages.

  IMPLICIT NONE

    ! Input
  INTEGER, INTENT(in) :: ixy, maxm, meqn, mwaves, mbc, mx, maux
  REAL(kind=8), INTENT(in) :: ql(meqn, 1-mbc:maxm+mbc)
  REAL(kind=8), INTENT(in) :: qr(meqn, 1-mbc:maxm+mbc)
  REAL(kind=8), INTENT(in) :: auxl(maux, 1-mbc:maxm+mbc)
  REAL(kind=8), INTENT(in) :: auxr(maux, 1-mbc:maxm+mbc)

    ! Output
  REAL(kind=8), INTENT(in out) :: wave(meqn, mwaves, 1-mbc:maxm+mbc)
  REAL(kind=8), INTENT(in out) :: s(mwaves, 1-mbc:maxm+mbc)
  REAL(kind=8), INTENT(in out) :: apdq(meqn, 1-mbc:maxm+mbc)
  REAL(kind=8), INTENT(in out) :: amdq(meqn, 1-mbc:maxm+mbc)

    ! Local storage
  INTEGER :: i, m, mw, mu, mv
  REAL(kind=8) :: rho_sqrtl, rho_sqrtr, rho_sq2, u, v, u2v2, pl, pr, enth, c
  REAL(kind=8) :: g1c2, euv
  REAL(kind=8) :: delta(4), a(4)

  REAL(kind=8) :: rhoim1, pim1, cim1, s0, rho1, rhou1, rhov1, en1, p1, c1, s1
  REAL(kind=8) :: sfract, rhoi, pi, ci, s3, rho2, rhou2, rhov2, en2, p2, c2
  REAL(kind=8) :: s2, df

    ! Use entropy fix for transonic rarefactions
  LOGICAL, PARAMETER :: efix = .TRUE.

    ! Common block storage
    ! Ideal gas constant
  REAL(kind=8) :: gamma, gamma1
  COMMON /cparam/  gamma

  gamma1 = gamma - 1.d0

    ! Set mu to point to  the component of the system that corresponds to
    ! momentum in the direction of this slice, mv to the orthogonal momentum:
  IF (ixy == 1) THEN
     mu = 2
     mv = 3
  ELSE
     mu = 3
     mv = 2
  ENDIF
    ! Note that notation for u and v reflects assumption that the Riemann
    ! problems  are in the x-direction with u in the normal direciton and v in
    ! the orthogonal direcion, but with the above definitions of mu and mv the
    ! routine also works  with ixy=2 and returns, for example, f0 as the Godunov
    ! flux g0 for the Riemann problems u_t + g(u)_y = 0 in the y-direction.

    ! Initialize waves and speeds
  wave = 0.d0
  s = 0.d0

    ! Primary loop over grid cell interfaces
  DO i = 2-mbc, mx+mbc
     !! Compute Roe-averaged quantities
     rho_sqrtl = SQRT(qr(1,i-1))
     rho_sqrtr = SQRT(ql(1,i))
     rho_sq2 = rho_sqrtl + rho_sqrtr

     u = (qr(mu,i-1) / rho_sqrtl + ql(mu,i) / rho_sqrtr) / rho_sq2
     v = (qr(mv,i-1) / rho_sqrtl + ql(mv,i) / rho_sqrtr) / rho_sq2
     u2v2 = u**2 + v**2

     pl = gamma1 * (qr(4,i-1) - 0.5d0 * (qr(2,i-1)**2 + qr(3,i-1)**2) / qr(1,i-1))
     pr = gamma1 * (ql(4,i)   - 0.5d0 * (ql(2,i)**2   + ql(3,i)**2) / ql(1,i))
     enth = (((qr(4,i-1) + pl) / rho_sqrtl + (ql(4,i) + pr) / rho_sqrtr)) / rho_sq2

     c = SQRT(gamma1 * (enth - 0.5d0 * u2v2))
     g1c2 = gamma1 / (gamma1 * (enth - 0.5d0 * u2v2))
     euv = enth - u2v2

        ! Now split the jump in q at each interface into waves and find a1 thru
        ! a4, the coefficients of the 4 eigenvectors:
     delta(1) = ql(1,i) - qr(1,i-1)
     delta(2) = ql(mu,i) - qr(mu,i-1)
     delta(3) = ql(mv,i) - qr(mv,i-1)
     delta(4) = ql(4,i) - qr(4,i-1)

     a(3) = g1c2 * (euv * delta(1) + u * delta(2) + v * delta(3) - delta(4))
     a(2) = delta(3) - v * delta(1)
     a(4) = (delta(2) + (c-u) * delta(1) - c * a(3)) / (2.d0 * c)
     a(1) = delta(1) - a(3) - a(4)

        ! Compute the waves
        ! Acoustic, left-going
     wave( 1,1,i) = a(1)
     wave(mu,1,i) = a(1) * (u - c)
     wave(mv,1,i) = a(1) * v
     wave( 4,1,i) = a(1) * (enth - u * c)
     wave( 5,1,i) = 0.d0

     s(1,i) = u - c

        ! Shear wave
     wave( 1,2,i) = 0.d0
     wave(mu,2,i) = 0.d0
     wave(mv,2,i) = a(2)
     wave( 4,2,i) = a(2) * v
     wave( 5,2,i) = 0.d0

     s(2,i) = u

        ! Entropy
     wave( 1,3,i) = a(3)
     wave(mu,3,i) = a(3) * u
     wave(mv,3,i) = a(3) * v
     wave( 4,3,i) = a(3) * 0.5d0 * u2v2
     wave( 5,3,i) = 0.d0

     s(3,i) = u

        ! Acoustic, right-going
     wave( 1,4,i) = a(4)
     wave(mu,4,i) = a(4) * (u + c)
     wave(mv,4,i) = a(4) * v
     wave( 4,4,i) = a(4) * (enth + u * c)
     wave( 5,4,i) = 0.d0

     s(4,i) = u + c

        ! Tracer wave - only carried in 5th component of q
     wave(5,5,i) = ql(5,i) - qr(5,i-1)

     s(5,i) = u

  END DO

  IF (.NOT.efix) THEN
        ! Compute flux differences amdq and apdq.
        ! No entropy fix
        !
        ! amdq = SUM s*wave   over left-going waves
        ! apdq = SUM s*wave   over right-going waves
     amdq = 0.d0
     apdq = 0.d0
     DO i=2-mbc, mx+mbc
        DO mw=1,mwaves
           IF (s(mw,i) < 0.d0) THEN
              amdq(:,i) = amdq(:,i) + s(mw,i) * wave(:,mw,i)
           ELSE
              apdq(:,i) = apdq(:,i) + s(mw,i) * wave(:,mw,i)
           ENDIF
        ENDDO
     ENDDO

  ELSE
        ! With entropy fix

        ! compute flux differences amdq and apdq.
        ! First compute amdq as sum of s*wave for left going waves.
        ! Incorporate entropy fix by adding a modified fraction of wave
        ! if s should change sign.
     amdq = 0.d0
     apdq = 0.d0
     DO i = 2-mbc, mx+mbc
            ! Check 1-wave
        rhoim1 = qr(1,i-1)
        pim1 = gamma1*(qr(4,i-1) - 0.5d0*(qr(mu,i-1)**2 + qr(mv,i-1)**2) / rhoim1)
        cim1 = dsqrt(gamma*pim1/rhoim1)
        s0 = qr(mu,i-1)/rhoim1 - cim1     ! u-c in left state (cell i-1)

            ! Check for fully supersonic case:
        IF (s0 >= 0.d0 .AND. s(1,i) > 0.d0)  THEN
           !! Everything is right-going
           CYCLE
        ENDIF

        rho1 = qr(1,i-1) + wave(1,1,i)
        rhou1 = qr(mu,i-1) + wave(mu,1,i)
        rhov1 = qr(mv,i-1) + wave(mv,1,i)
        en1 = qr(4,i-1) + wave(4,1,i)
        p1 = gamma1 * (en1 - 0.5d0 * (rhou1**2 + rhov1**2) / rho1)
        c1 = SQRT(gamma * p1 / rho1)
        s1 = rhou1 / rho1 - c1  ! u-c to right of 1-wave
        IF (s0 < 0.d0 .AND. s1 > 0.d0) THEN
           !! Transonic rarefaction in the 1-wave
           sfract = s0 * (s1-s(1,i)) / (s1-s0)
        ELSE IF (s(1,i) < 0.d0) THEN
           !! 1-wave is leftgoing
           sfract = s(1,i)
        ELSE
           !! 1-wave is rightgoing
           sfract = 0.d0   ! This shouldn't happen since s0 < 0
        ENDIF
        DO m=1,meqn
           amdq(m,i) = sfract * wave(m,1,i)
        END DO

        !! Check contact discontinuity:
        IF (s(2,i) >= 0.d0) THEN
           !!# 2- 3- and 5-waves are rightgoing
           CYCLE
        ENDIF

        amdq(:,i) = amdq(:,i) + s(2,i) * wave(:,2,i)
        amdq(:,i) = amdq(:,i) + s(3,i) * wave(:,3,i)
        amdq(:,i) = amdq(:,i) + s(5,i) * wave(:,5,i)

        !! Check 4-wave:
        rhoi = ql(1,i)
        pi = gamma1*(ql(4,i) - 0.5d0*(ql(mu,i)**2 + ql(mv,i)**2) / rhoi)
        ci = SQRT(gamma*pi/rhoi)
        s3 = ql(mu,i)/rhoi + ci     ! u+c in right state  (cell i)

        rho2 = ql(1,i) - wave(1,4,i)
        rhou2 = ql(mu,i) - wave(mu,4,i)
        rhov2 = ql(mv,i) - wave(mv,4,i)
        en2 = ql(4,i) - wave(4,4,i)
        p2 = gamma1*(en2 - 0.5d0*(rhou2**2 + rhov2**2)/rho2)
        c2 = SQRT(gamma*p2/rho2)
        s2 = rhou2/rho2 + c2   ! u+c to left of 4-wave
        IF (s2 < 0.d0 .AND. s3 > 0.d0) THEN
           !! Transonic rarefaction in the 4-wave
           sfract = s2 * (s3-s(4,i)) / (s3-s2)
        ELSE IF (s(4,i) < 0.d0) THEN
           !! 4-wave is leftgoing
           sfract = s(4,i)
        ELSE
           !! 4-wave is rightgoing
           CYCLE
        ENDIF

        amdq(:,i) = amdq(:,i) + sfract * wave(:,4,i)
     ENDDO

     !! Compute the remaining right-going flux differences:
     !! df = SUM s*wave   is the total flux difference and apdq = df - amdq
     DO m=1,meqn
        DO i = 2-mbc, mx+mbc
           df = 0.d0
           DO mw=1,mwaves
              df = df + s(mw,i) * wave(m,mw,i)
           ENDDO
           apdq(m,i) = df - amdq(m,i)
        ENDDO
     ENDDO

  ENDIF
END SUBROUTINE clawpack5_rpn2_euler5


      SUBROUTINE DLASQ2( M, Q, E, QQ, EE, EPS, TOL2, SMALL2, SUP, KEND,
     $                   INFO )
*
*  -- LAPACK routine (version 2.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     September 30, 1994
*
*     .. Scalar Arguments ..
      INTEGER            INFO, KEND, M
      DOUBLE PRECISION   EPS, SMALL2, SUP, TOL2
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   E( * ), EE( * ), Q( * ), QQ( * )
*     ..
*
*     Purpose
*     =======
*
*     DLASQ2 computes the singular values of a real N-by-N unreduced
*     bidiagonal matrix with squared diagonal elements in Q and
*     squared off-diagonal elements in E. The singular values are
*     computed to relative accuracy TOL, barring over/underflow or
*     denormalization.
*
*     Arguments
*     =========
*
*  M       (input) INTEGER
*          The number of rows and columns in the matrix. M >= 0.
*
*  Q       (output) DOUBLE PRECISION array, dimension (M)
*          On normal exit, contains the squared singular values.
*
*  E       (workspace) DOUBLE PRECISION array, dimension (M)
*
*  QQ      (input/output) DOUBLE PRECISION array, dimension (M)
*          On entry, QQ contains the squared diagonal elements of the
*          bidiagonal matrix whose SVD is desired.
*          On exit, QQ is overwritten.
*
*  EE      (input/output) DOUBLE PRECISION array, dimension (M)
*          On entry, EE(1:N-1) contains the squared off-diagonal
*          elements of the bidiagonal matrix whose SVD is desired.
*          On exit, EE is overwritten.
*
*  EPS     (input) DOUBLE PRECISION
*          Machine epsilon.
*
*  TOL2    (input) DOUBLE PRECISION
*          Desired relative accuracy of computed eigenvalues
*          as defined in DLASQ1.
*
*  SMALL2  (input) DOUBLE PRECISION
*          A threshold value as defined in DLASQ1.
*
*  SUP     (input/output) DOUBLE PRECISION
*          Upper bound for the smallest eigenvalue.
*
*  KEND    (input/output) INTEGER
*          Index where minimum d occurs.
*
*  INFO    (output) INTEGER
*          = 0:  successful exit
*          < 0:  if INFO = -i, the i-th argument had an illegal value
*          > 0:  if INFO = i, the algorithm did not converge;  i
*                specifies how many superdiagonals did not converge.
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D+0 )
      DOUBLE PRECISION   FOUR, HALF
      PARAMETER          ( FOUR = 4.0D+0, HALF = 0.5D+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            ICONV, IPHASE, ISP, N, OFF, OFF1
      DOUBLE PRECISION   QEMAX, SIGMA, XINF, XX, YY
*     ..
*     .. External Subroutines ..
      EXTERNAL           DLASQ3
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN, NINT, SQRT
*     ..
*     .. Executable Statements ..
      N = M
*
*     Set the default maximum number of iterations
*
      OFF = 0
      OFF1 = OFF + 1
      SIGMA = ZERO
      XINF = ZERO
      ICONV = 0
      IPHASE = 2
*
*     Try deflation at the bottom
*
*     1x1 deflation
*
   10 CONTINUE
      IF( N.LE.2 )
     $   GO TO 20
      IF( EE( N-1 ).LE.MAX( QQ( N ), XINF, SMALL2 )*TOL2 ) THEN
         Q( N ) = QQ( N )
         N = N - 1
         IF( KEND.GT.N )
     $      KEND = N
         SUP = MIN( QQ( N ), QQ( N-1 ) )
         GO TO 10
      END IF
*
*     2x2 deflation
*
      IF( EE( N-2 ).LE.MAX( XINF, SMALL2,
     $    ( QQ( N ) / ( QQ( N )+EE( N-1 )+QQ( N-1 ) ) )*QQ( N-1 ) )*
     $    TOL2 ) THEN
         QEMAX = MAX( QQ( N ), QQ( N-1 ), EE( N-1 ) )
         IF( QEMAX.NE.ZERO ) THEN
            IF( QEMAX.EQ.QQ( N-1 ) ) THEN
               XX = HALF*( QQ( N )+QQ( N-1 )+EE( N-1 )+QEMAX*
     $              SQRT( ( ( QQ( N )-QQ( N-1 )+EE( N-1 ) ) /
     $              QEMAX )**2+FOUR*EE( N-1 ) / QEMAX ) )
            ELSE IF( QEMAX.EQ.QQ( N ) ) THEN
               XX = HALF*( QQ( N )+QQ( N-1 )+EE( N-1 )+QEMAX*
     $              SQRT( ( ( QQ( N-1 )-QQ( N )+EE( N-1 ) ) /
     $              QEMAX )**2+FOUR*EE( N-1 ) / QEMAX ) )
            ELSE
               XX = HALF*( QQ( N )+QQ( N-1 )+EE( N-1 )+QEMAX*
     $              SQRT( ( ( QQ( N )-QQ( N-1 )+EE( N-1 ) ) /
     $              QEMAX )**2+FOUR*QQ( N-1 ) / QEMAX ) )
            END IF
            YY = ( MAX( QQ( N ), QQ( N-1 ) ) / XX )*
     $           MIN( QQ( N ), QQ( N-1 ) )
         ELSE
            XX = ZERO
            YY = ZERO
         END IF
         Q( N-1 ) = XX
         Q( N ) = YY
         N = N - 2
         IF( KEND.GT.N )
     $      KEND = N
         SUP = QQ( N )
         GO TO 10
      END IF
*
   20 CONTINUE
      IF( N.EQ.0 ) THEN
*
*         The lower branch is finished
*
         IF( OFF.EQ.0 ) THEN
*
*         No upper branch; return to DLASQ1
*
            RETURN
         ELSE
*
*         Going back to upper branch
*
            XINF = ZERO
            IF( EE( OFF ).GT.ZERO ) THEN
               ISP = NINT( EE( OFF ) )
               IPHASE = 1
            ELSE
               ISP = -NINT( EE( OFF ) )
               IPHASE = 2
            END IF
            SIGMA = E( OFF )
            N = OFF - ISP + 1
            OFF1 = ISP
            OFF = OFF1 - 1
            IF( N.LE.2 )
     $         GO TO 20
            IF( IPHASE.EQ.1 ) THEN
               SUP = MIN( Q( N+OFF ), Q( N-1+OFF ), Q( N-2+OFF ) )
            ELSE
               SUP = MIN( QQ( N+OFF ), QQ( N-1+OFF ), QQ( N-2+OFF ) )
            END IF
            KEND = 0
            ICONV = -3
         END IF
      ELSE IF( N.EQ.1 ) THEN
*
*     1x1 Solver
*
         IF( IPHASE.EQ.1 ) THEN
            Q( OFF1 ) = Q( OFF1 ) + SIGMA
         ELSE
            Q( OFF1 ) = QQ( OFF1 ) + SIGMA
         END IF
         N = 0
         GO TO 20
*
*     2x2 Solver
*
      ELSE IF( N.EQ.2 ) THEN
         IF( IPHASE.EQ.2 ) THEN
            QEMAX = MAX( QQ( N+OFF ), QQ( N-1+OFF ), EE( N-1+OFF ) )
            IF( QEMAX.NE.ZERO ) THEN
               IF( QEMAX.EQ.QQ( N-1+OFF ) ) THEN
                  XX = HALF*( QQ( N+OFF )+QQ( N-1+OFF )+EE( N-1+OFF )+
     $                 QEMAX*SQRT( ( ( QQ( N+OFF )-QQ( N-1+OFF )+EE( N-
     $                 1+OFF ) ) / QEMAX )**2+FOUR*EE( OFF+N-1 ) /
     $                 QEMAX ) )
               ELSE IF( QEMAX.EQ.QQ( N+OFF ) ) THEN
                  XX = HALF*( QQ( N+OFF )+QQ( N-1+OFF )+EE( N-1+OFF )+
     $                 QEMAX*SQRT( ( ( QQ( N-1+OFF )-QQ( N+OFF )+EE( N-
     $                 1+OFF ) ) / QEMAX )**2+FOUR*EE( N-1+OFF ) /
     $                 QEMAX ) )
               ELSE
                  XX = HALF*( QQ( N+OFF )+QQ( N-1+OFF )+EE( N-1+OFF )+
     $                 QEMAX*SQRT( ( ( QQ( N+OFF )-QQ( N-1+OFF )+EE( N-
     $                 1+OFF ) ) / QEMAX )**2+FOUR*QQ( N-1+OFF ) /
     $                 QEMAX ) )
               END IF
               YY = ( MAX( QQ( N+OFF ), QQ( N-1+OFF ) ) / XX )*
     $              MIN( QQ( N+OFF ), QQ( N-1+OFF ) )
            ELSE
               XX = ZERO
               YY = ZERO
            END IF
         ELSE
            QEMAX = MAX( Q( N+OFF ), Q( N-1+OFF ), E( N-1+OFF ) )
            IF( QEMAX.NE.ZERO ) THEN
               IF( QEMAX.EQ.Q( N-1+OFF ) ) THEN
                  XX = HALF*( Q( N+OFF )+Q( N-1+OFF )+E( N-1+OFF )+
     $                 QEMAX*SQRT( ( ( Q( N+OFF )-Q( N-1+OFF )+E( N-1+
     $                 OFF ) ) / QEMAX )**2+FOUR*E( N-1+OFF ) /
     $                 QEMAX ) )
               ELSE IF( QEMAX.EQ.Q( N+OFF ) ) THEN
                  XX = HALF*( Q( N+OFF )+Q( N-1+OFF )+E( N-1+OFF )+
     $                 QEMAX*SQRT( ( ( Q( N-1+OFF )-Q( N+OFF )+E( N-1+
     $                 OFF ) ) / QEMAX )**2+FOUR*E( N-1+OFF ) /
     $                 QEMAX ) )
               ELSE
                  XX = HALF*( Q( N+OFF )+Q( N-1+OFF )+E( N-1+OFF )+
     $                 QEMAX*SQRT( ( ( Q( N+OFF )-Q( N-1+OFF )+E( N-1+
     $                 OFF ) ) / QEMAX )**2+FOUR*Q( N-1+OFF ) /
     $                 QEMAX ) )
               END IF
               YY = ( MAX( Q( N+OFF ), Q( N-1+OFF ) ) / XX )*
     $              MIN( Q( N+OFF ), Q( N-1+OFF ) )
            ELSE
               XX = ZERO
               YY = ZERO
            END IF
         END IF
         Q( N-1+OFF ) = SIGMA + XX
         Q( N+OFF ) = YY + SIGMA
         N = 0
         GO TO 20
      END IF
      CALL DLASQ3( N, Q( OFF1 ), E( OFF1 ), QQ( OFF1 ), EE( OFF1 ), SUP,
     $             SIGMA, KEND, OFF, IPHASE, ICONV, EPS, TOL2, SMALL2 )
      IF( SUP.LT.ZERO ) THEN
         INFO = N + OFF
         RETURN
      END IF
      OFF1 = OFF + 1
      GO TO 20
*
*     End of DLASQ2
*
      END


*----------------------------------------------------------------------*
      subroutine optc_minspace(
     &     iord_vsbsp,ffvsbsp,
     &     iord_rsbsp,ffrsbsp,
     &     iord_ssbsp,ffssbsp,use_s,
     &     vred,gred,mred,sred,nred,nroot,nrhs,mxdim,nopt,
     &     ffscr,ioffscr,
     &     nincore,nwfpar,lenbuf,xbuf1,xbuf2,xbuf3)
*----------------------------------------------------------------------*
*     reduce current subspace to minimal space, spanning exactly the
*     currently best solutions
*----------------------------------------------------------------------*
      implicit none

      include 'stdunit.h'
      include 'def_filinf.h'
      include 'def_file_array.h'

      integer, parameter ::
     &     ntest = 00

      integer, intent(inout) ::
     &     nred, nrhs, mxdim, nopt,
     &     iord_vsbsp(*), iord_rsbsp(*), iord_ssbsp(*)
      logical, intent(in) ::
     &     use_s(nopt)
      type(file_array), intent(inout) ::
     &     ffvsbsp(nopt), ffrsbsp(nopt), ffssbsp(nopt),
     &     ffscr(nopt)
      integer, intent(in) ::
     &     nroot, nincore, nwfpar(nopt), lenbuf, ioffscr
      real(8), intent(inout) ::
     &     vred(mxdim,nroot), gred(mxdim,nrhs),
     &     mred(mxdim,nred), sred(mxdim,nred)
      real(8), intent(inout) ::
     &     xbuf1(*), xbuf2(*), xbuf3(*)

      logical ::
     &     update_s
      integer ::
     &     iroot, idxvec, iopt
      real(8) ::
     &     xnrm
      real(8) ::
     &     smat(nroot,nroot), mscr(nred*nroot), vorth(nred*nroot),
     &     vscr(2*nroot)

      real(8), external ::
     &     dnrm2

      update_s = .false.
      do iopt = 1, nopt
        update_s = update_s.or.use_s(iopt)
      end do

      if (ntest.ge.100) then
        call write_title(lulog,wst_dbg_subr,'optc_minspace')
        write(lulog,*) 'nred, nroot: ',nred,nroot
        write(lulog,*) 'vred on entry:'
        call wrtmat2(vred,nred,nroot,mxdim,nroot)
        if (nrhs.gt.0) then
          write(lulog,*) 'gred on entry:'
          call wrtmat2(gred,nred,nroot,mxdim,nroot)
        end if
        write(lulog,*) 'mred on entry:'
        call wrtmat2(mred,nred,nred,mxdim,nred)
        if (update_s) then
          write(lulog,*) 'sred on entry:'
          call wrtmat2(sred,nred,nred,mxdim,nred)
        end if
      end if

      if (nroot.gt.nred)
     &     call quit(1,'optc_minspace','strange: nroot.gt.nred!')

      ! get overlap matrix of vectors S_ij = <v_i|v_j>
      call dgemm('T','N',nroot,nroot,nred,
     &           1d0,vred,mxdim,
     &               vred,mxdim,
     &           0d0,smat,nroot)

      if (ntest.ge.100) then
        write(lulog,*) 'overlap matrix: '
        call wrtmat2(smat,nroot,nroot,nroot,nroot)
      end if

      ! obtain orthonormalization matrix
      call mgs(mscr,smat,nroot,vscr)

      ! obtain trafo: reduced space sol. ->  orth reduced space sol.
      ! |v_i^{orth}> = |v_j> t(j,i)
      call dgemm('N','N',nred,nroot,nroot,
     &           1d0,vred,mxdim,
     &               mscr,nroot,
     &           0d0,vorth,nred)

      if (ntest.ge.100) then
        write(lulog,*) 'orthogonalized vred: '
        call wrtmat2(vorth,nred,nroot,nred,nroot)
      end if

      ! check norm of new vectors, lin. dependency occurred?
      do iroot = 1, nroot
        xnrm = dnrm2(nred,vorth,1)
c dbg
c        print *,'iroot, norm: ',iroot,xnrm
c dbg
        if (xnrm.lt.1d-4) then
          write(lulog,*) 'root, norm: ',iroot, xnrm
          write(lulog,*) 'looks like linear dependency ... oh no!'
          call quit(1,'optc_minspace',
     &         'linear dependency should not occur at this place!')
        end if
      end do

      ! trafo: old reduced space -> new reduced space
      ! |v_i> = |b_old><b_old|v_i> = |b_new><b_new|b_old><v_old|v_i>
      ! update solution vectors ...
      call dgemm('T','N',nroot,nroot,nred,
     &           1d0,vorth,nred,
     &               vred,mxdim,
     &           0d0,smat,nroot) ! use smat as scratch
      do iroot = 1, nroot
        vred(1:nroot,iroot) = smat(1:nroot,iroot)
      end do

      if (nrhs.gt.0) then
        ! ... update RHS vectors ...
        call dgemm('T','N',nroot,nrhs,nred,
     &             1d0,vorth,nred,
     &                 gred,mxdim,
     &             0d0,smat,nroot) ! use smat as scratch
        do iroot = 1, nrhs
          gred(1:nroot,iroot) = smat(1:nroot,iroot)
        end do
      end if

      if (ntest.ge.100) then
        write(lulog,*) 'new vred: '
        call wrtmat2(vred,nroot,nroot,mxdim,nroot)
        if (nrhs.gt.0) then
          write(lulog,*) 'new gred: '
          call wrtmat2(gred,nroot,nroot,mxdim,nroot)
        end if
      end if

      ! ... and subspace matrix in reduced space ...
      call dgemm('T','N',nroot,nred,nred,
     &           1d0,vorth,nred,
     &               mred,mxdim,
     &           0d0,mscr,nroot)
      call dgemm('N','N',nroot,nroot,nred,
     &           1d0,mscr,nroot,
     &               vorth,nred,
     &           0d0,mred,mxdim)

      if (ntest.ge.100) then
        write(lulog,*) 'new mred: '
        call wrtmat2(mred,nroot,nroot,mxdim,nroot)
      end if

      ! do the same for metric:
      if (update_s) then
        call dgemm('T','N',nroot,nred,nred,
     &           1d0,vorth,nred,
     &               sred,mxdim,
     &           0d0,mscr,nroot)
        call dgemm('N','N',nroot,nroot,nred,
     &           1d0,mscr,nroot,
     &               vorth,nred,
     &           0d0,sred,mxdim)

        if (ntest.ge.100) then
          write(lulog,*) 'new sred: '
          call wrtmat2(sred,nroot,nroot,mxdim,nroot)
        end if

      end if

      do iopt = 1, nopt

      ! update trial vectors and MV-products in full space
      ! assemble trial vectors:
      idxvec = 1
      do iroot = 1, nroot
        call optc_expand_vec(vorth(idxvec),nred,xnrm,.false.,
     &       ffscr(iopt)%fhand,ioffscr+iroot,0d0,
     &       ffvsbsp(iopt)%fhand,iord_vsbsp,
     &       nincore,nwfpar(iopt),lenbuf,xbuf1,xbuf2)
        idxvec = idxvec+nred
      end do
      ! copy to ffvsbsp and reset iord_vsbsp:
      do iroot = 1, nroot
        iord_vsbsp(iroot) = iroot
        call da_sccpvec(ffscr(iopt)%fhand,ioffscr+iroot,
     &                  ffvsbsp(iopt)%fhand,iroot,
     &                  1d0,nwfpar(iopt),xbuf1,lenbuf)
      end do
c dbg
c      print *,'ioffscr = ',ioffscr
c      print *,'contents on new ffscr file:'
c      call da_listvec(ffscr,1,nwfpar,0,xbuf1,lenbuf)
c      call da_listvec(ffscr,2,nwfpar,0,xbuf1,lenbuf)
c      print *,'contents on new ffvsbsp file:'
c      call da_listvec(ffvsbsp,1,nwfpar,0,xbuf1,lenbuf)
c dbg

      ! assemble MV products:
      idxvec = 1
      do iroot = 1, nroot
        call optc_expand_vec(vorth(idxvec),nred,xnrm,.false.,
     &       ffscr(iopt)%fhand,ioffscr+iroot,0d0,
     &       ffrsbsp(iopt)%fhand,iord_rsbsp,
     &       nincore,nwfpar(iopt),lenbuf,xbuf1,xbuf2)
        idxvec = idxvec+nred
      end do
      ! copy to ffrsbsp and reset iord_rsbsp:
      do iroot = 1, nroot
        iord_rsbsp(iroot) = iroot
        call da_sccpvec(ffscr(iopt)%fhand,ioffscr+iroot,
     &                  ffrsbsp(iopt)%fhand,iroot,
     &                  1d0,nwfpar(iopt),xbuf1,lenbuf)
      end do
c dbg
c      print *,'contents on new ffrsbsp file:'
c      call da_listvec(ffrsbsp(iopt)%fhand,1,nwfpar,0,xbuf1,lenbuf)
c dbg

      if (use_s(iopt)) then
        ! assemble metric-vector products:
        idxvec = 1
        do iroot = 1, nroot
          call optc_expand_vec(vorth(idxvec),nred,xnrm,.false.,
     &       ffscr(iopt)%fhand,ioffscr+iroot,0d0,
     &       ffssbsp(iopt)%fhand,iord_ssbsp,
     &       nincore,nwfpar(iopt),lenbuf,xbuf1,xbuf2)
          idxvec = idxvec+nred
        end do
        ! copy to ffssbsp and reset iord_ssbsp:
        do iroot = 1, nroot
          iord_ssbsp(iroot) = iroot
          call da_sccpvec(ffscr(iopt)%fhand,ioffscr+iroot,
     &                    ffssbsp(iopt)%fhand,iroot,
     &                    1d0,nwfpar(iopt),xbuf1,lenbuf)
        end do
c dbg
c        print *,'contents on new ffssbsp file:'
c        call da_listvec(ffssbsp(iopt)%fhand,1,nwfpar,0,xbuf1,lenbuf)
c dbg
      end if

      end do ! iopt

      ! reset nred:
      nred = nroot

      return
      end


program qml_driver
    use mpi
    implicit none

    double precision, allocatable, dimension(:,:) :: Q
    double precision, allocatable, dimension(:):: Y

    double precision :: sigma
    integer :: rep_size
    integer :: n_molecules

    double precision, allocatable, dimension(:) :: alphas

    integer :: info
    integer :: na, i, numroc
    integer :: local_i, local_j, global_i, global_j

    integer :: lwork
    double precision, dimension(:), allocatable :: work
    double precision, dimension(:,:), allocatable :: local_K, local_B

    ! pblacs data structures
    integer :: local_K_rows, local_K_cols
    integer :: local_B_rows, local_B_cols
    integer :: local_id, num_ranks, ranks_rows, ranks_cols, context
    integer :: local_rank_col, local_rank_row, block_size
    integer :: ierr
    integer, dimension(9) :: desca, descb
    integer, dimension(2) :: dims
    double precision, dimension(2) :: work_query

    ! init pblacs and set cartesian grid of MPI ranks
    call blacs_pinfo(local_id, num_ranks)

    dims = 0
    call MPI_Dims_create(num_ranks, 2, dims, ierr)
    ranks_rows = dims(1)
    ranks_cols = dims(2)

    block_size = 100

    ! create BLACS context
    call blacs_get(0, 0, context)
    call blacs_gridinit(context, 'R', ranks_rows, ranks_cols)
    call blacs_gridinfo(context, ranks_rows, ranks_cols, &
        local_rank_row, local_rank_col)

    ! Read hyperparameters and arrat suzes
    open(unit = 9, file = "parameters.fout", form="formatted")

        read(9,*) sigma, rep_size, n_molecules

        ! Allocate labels
        allocate(Y(n_molecules))

        read(9,*) Y(:n_molecules)

    close(9)

    ! allocate alphas
    allocate(alphas(n_molecules))
    ! Allocate representations
    allocate(Q(n_molecules, rep_size))

    ! Read representations
    open(unit = 9, file = "representations.fout", form="formatted")

        ! Read representaions for each molecule
        do i = 1, n_molecules
            read(9,*) Q(i,:rep_size)
        enddo

    close(9)

    ! Size of kernel
    na = size(Q, dim=1)

    ! Allocate kernel and output
    local_K_rows = numroc(na, block_size, local_rank_row, 0, ranks_rows)
    local_K_cols = numroc(na, block_size, local_rank_col, 0, ranks_cols)
    allocate(local_K(local_K_rows, local_K_cols))
    local_B_rows = numroc(na, block_size, local_rank_row, 0, ranks_rows)
    local_B_cols = numroc(1, block_size, local_rank_col, 0, ranks_cols)
    allocate(local_B(local_B_rows, local_B_cols))

    ! Calculate Laplacian kernel
    do local_j = 1, local_K_cols
        call l2g(local_j, local_rank_col, ranks_cols, &
                block_size, global_j)
        do local_i = 1, local_K_rows
            call l2g(local_i, local_rank_row, ranks_rows, &
                block_size, global_i)
            local_K(local_i, local_j) = exp(-sum(abs(Q(global_j,:) - Q(global_i,:)))/sigma)
        enddo
    enddo

    ! Setup variables for LAPACK
    call descinit(desca, na, na, block_size, block_size, 0, 0, context, MAX(1, local_K_rows), info)
    call descinit(descb, na, 1, block_size, block_size, 0, 0, context, MAX(1, local_B_rows), info)

    ! Allocate local work arrays
    call pdgels("N", na, na, 1, local_K, 1, 1, desca, local_B, 1, 1, DESCB, work_query, -1, info)
    lwork = INT(work_query(1))
    allocate(work(lwork))

    ! copy data
    local_B = 0.0d0
    if (local_B_cols .ne. 0) then
        do local_i = 1, local_B_rows
            call l2g(local_i, local_rank_row, ranks_rows, block_size, global_i)
            local_B(local_i, 1) = y(global_i)
        enddo
    end if

    ! Solver
    call pdgels("N", na, na, 1, local_K, 1, 1, desca, local_B, 1, 1, DESCB, work, lwork, info)

    ! Copy LAPACK output
    alphas = 0.0d0
    if (local_B_cols .ne. 0) then
        do local_i = 1, local_B_rows
            call l2g(local_i, local_rank_row, ranks_rows, block_size, global_i)
            alphas(global_i) = local_B(local_i, 1)
        enddo
    endif
    call DGSUM2D(context, "All", "1-tree", na, 1, alphas, 1, -1, -1)

    ! Save alphas to file
    if (local_id .eq. 0) then
        open(unit = 9, file = "alphas_mpi.fout", form="formatted")
            write(9,*) alphas(:)
        close(9)
    end if

    ! Tear down MPI
    call blacs_exit(0)

    ! Clean up
    deallocate(work)
    deallocate(local_B)
    deallocate(Q)
    deallocate(local_K)
    deallocate(Y)
    deallocate(alphas)

end program qml_driver
! convert local index to global index in block-cyclic distribution

   subroutine l2g(il,p,np,nb,i)

   implicit none
   integer :: il   ! local array index, input
   integer :: p    ! processor array index, input
   integer :: np   ! processor array dimension, input
   integer :: nb   ! block size, input
   integer :: i    ! global array index, output
   integer :: ilm1

   ilm1 = il-1
   i    = (((ilm1/nb) * np) + p)*nb + mod(ilm1,nb) + 1

   return
   end subroutine l2g


C
C $Id: idsfft.f,v 1.6 2008-07-27 00:17:30 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      SUBROUTINE IDSFFT (MD,NDP,XD,YD,ZD,NXI,NYI,NZI,XI,YI,ZI,IWK,WK)
C
C DIMENSION OF           XD(NDP), YD(NDP), ZD(NDP), XI(NXI),
C ARGUMENTS              YI(NYI), ZI(NZI,NYI), WK(6*NDP),
C                        IWK(31*NDP + NXI*NYI)
C
C PURPOSE                This subroutine performs smooth surface
C                        fitting when the projections of the data
C                        points in the X-Y plane are irregularly
C                        distributed in the plane.
C
C USAGE                  CALL IDSFFT (MD,NDP,XD,YD,ZD,NXI,NYI,NZI,
C                                     XI,YI,ZI,IWK,WK)
C
C ARGUMENTS
C
C ON INPUT               MD
C                          Mode of computation (must be 1, 2, or 3,
C                          else an error return will occur).
C                           = 1 if this is the first call to this
C                               subroutine, or if the value of NDP
C                               has been changed from the previous
C                               call, or if the contents of the XD
C                               or YD arrays have been changed from
C                               the previous call.
C                           = 2 if the values of NDP and the XD and
C                               YD arrays are unchanged from the
C                               previous call, but new values for
C                               XI and YI are being used.  If MD = 2
C                               and NDP has been changed since the
C                               previous call to IDSFFT, an error
C                               return occurs.
C                           = 3 if the values of NDP, NXI, NYI, XD,
C                               YD, XI, and YI are unchanged from the
C                               previous call, i.e., if the only change
C                               on input to IDSFFT is in the ZD array.
C                               If MD = 3 and NDP, NXI, or NYI has been
C                               changed since the previous call to
C                               IDSFFT, an error return occurs.
C
C                           Between the call with MD = 2 or MD = 3 and
C                           the preceding call, the IWK and WK work
C                           arrays should not be disturbed.
C
C                        NDP
C                          Number of data points (must be 4 or
C                          greater, else an error return will occur).
C
C                        XD
C                          Array of dimension NDP containing the X
C                          coordinates of the data points.
C
C                        YD
C                          Array of dimension NDP containing the Y
C                          coordinates of the data points.
C
C                        ZD
C                          Array of dimension NDP containing the Z
C                          coordinates of the data points.
C
C                        NXI
C                          Number of output grid points in the X
C                          direction (must be 1 or greater, else
C                          an error return will occur).
C
C                        NYI
C                          Number of output grid points in the Y
C                          direction (must be 1 or greater, else
C                          an error return will occur).
C
C                        NZI
C                          First dimension of ZI as declared in the
C                          calling program.  NZI must be greater than
C                          or equal to NXI, else an error return will
C                          occur.
C
C                        XI
C                          Array of dimension NXI containing the
C                          X coordinates of the output grid points.
C
C                        YI
C                         Array of dimension NYI containing the
C                         Y coordinates of the output grid points.
C
C                        IWK
C                          Integer work array of dimension at
C                          least 31*NDP + NXI*NYI.
C
C                        WK
C                          Real work array of dimension at least 6*NDP.
C
C ON OUTPUT              ZI
C                           Real, two-dimensional array of dimension
C                           (NZI,NYI), storing the interpolated Z
C                           values at the output grid points.
C
C SPECIAL CONDITIONS     Inadequate work space IWK and WK may cause
C                        incorrect results.
C
C                        The data points must be distinct and their
C                        projections in the X-Y plane must not be
C                        collinear, else an error return occurs.
C
C IDSFFT calls the subroutines IDGRID, IDPDRV, IDPTIP, and IDTANG.
C
C Declaration statements.
C
      DIMENSION XD(NDP),YD(NDP),ZD(NDP),XI(NXI),YI(NYI),ZI(NZI,NYI),
     +          IWK(31*NDP+NXI*NYI),WK(6*NDP)
C
      COMMON /IDPT/ ITPV,DMMY(27)
      SAVE   /IDPT/
C
      COMMON /IDCOMN/ INTY,ITTY,ALSP,BLSP,CLSP,XAVG,YAVG
      SAVE   /IDCOMN/
C
C Check for an uncleared prior error.
C
        IF (ICFELL('IDSFFT (BIVAR) - UNCLEARED PRIOR ERROR',1).NE.0)
     +                                                        RETURN
C
C Check for input errors.
C
      IF (MD.LT.1.OR.MD.GT.3) THEN
        CALL SETER ('IDSFFT (BIVAR) - INPUT VARIABLE MD IS OUT OF RANGE'
     +,2,1)
        RETURN
      END IF
C
      IF (NDP.LT.4) THEN
        CALL SETER ('IDSFFT (BIVAR) - INPUT VARIABLE NDP IS OUT OF RANGE
     +',3,1)
        RETURN
      END IF
C
      IF (NXI.LT.1.OR.NYI.LT.1) THEN
        CALL SETER ('IDSFFT (BIVAR) - INPUT VARIABLE NXI OR NYI IS OUT O
     +F RANGE',4,1)
        RETURN
      END IF
C
      IF (NXI.GT.NZI) THEN
        CALL SETER ('IDSFFT (BIVAR) - INPUT VARIABLE NZI IS LESS THAN NX
     +I',5,1)
        RETURN
      END IF
C
      IF (MD.LE.1) THEN
C
        IWK(1)=NDP
C
      ELSE
C
        NDPPV=IWK(1)
C
        IF (NDP.NE.NDPPV) THEN
          CALL SETER  ('IDSFFT (BIVAR) - MD = 2 OR 3 BUT NDP WAS CHANGED
     + SINCE LAST CALL',6,1)
          RETURN
        END IF
C
      END IF
C
      IF (MD.LE.2) THEN
C
        IWK(2)=INTY
        IWK(3)=NXI
        IWK(4)=NYI
C
      ELSE
C
        INTYPV=IWK(2)
C
        IF (INTY.NE.INTYPV) THEN
          CALL SETER ('IDSFFT (BIVAR) - MD = 3 BUT ITY WAS CHANGED SINCE
     + LAST CALL',7,1)
           RETURN
        END IF
C
        NXIPV=IWK(3)
C
        IF (NXI.NE.NXIPV) THEN
          CALL SETER ('IDSFFT (BIVAR) - MD = 3 BUT NXI WAS CHANGED SINCE
     + LAST CALL',8,1)
           RETURN
        END IF
C
        NYIPV=IWK(4)
C
        IF (NYI.NE.NYIPV) THEN
          CALL SETER ('IDSFFT (BIVAR) - MD = 3 BUT NYI WAS CHANGED SINCE
     + LAST CALL',9,1)
          RETURN
        END IF
C
      END IF
C
C Allocate storage areas in the array IWK.
C
      JWIPT=16
      JWIWL=6*NDP+1
      JWNGP0=JWIWL-1
      JWIPL=24*NDP+1
      JWIWP=30*NDP+1
      JWIGP0=31*NDP
      JWWPD=5*NDP+1
C
C If MD = 1, triangulate the X/Y plane.  (If MD = 2 or 3, this has
C already been done and need not been redone.)
C
      IF (MD.EQ.1) THEN
        CALL IDTANG (NDP,XD,YD,NT,IWK(JWIPT),NL,IWK(JWIPL),IWK(JWIWL),
     +                                                  IWK(JWIWP),WK)
        IF (ICFELL('IDSFFT',10).NE.0) RETURN
        IWK(5)=NT
        IWK(6)=NL
      ELSE
        NT=IWK(5)
        NL=IWK(6)
      END IF
C
      IF (NT.EQ.0) RETURN
C
C If linear interpolation is activated, compute the coefficients of the
C least-squares-fit plane and the mean values of X and Y.
C
      IF (INTY.NE.0) THEN
        CALL IDLSQF (XD,YD,ZD,NDP,ALSP,BLSP,CLSP,XAVG,YAVG)
      END IF
C
C If MD = 1 or 2, sort output grid points in ascending order by the
C number of the containing region (a triangle number or a combined
C pair of border line segment numbers).  (If MD = 3, this has already
C been done and need not be redone.)
C
      IF (MD.LE.2) THEN
        CALL IDGRID (XD,YD,NT,IWK(JWIPT),NL,IWK(JWIPL),NXI,
     +               NYI,XI,YI,IWK(JWNGP0+1),IWK(JWIGP0+1))
        IF (ICFELL('IDSFFT',11).NE.0) RETURN
      END IF
C
C If quintic interpolation is activated, estimate partial derivatives.
C
      IF (INTY.EQ.0) THEN
        CALL IDPDRV (NDP,XD,YD,ZD,NT,IWK(JWIPT),WK,WK(JWWPD))
      END IF
C
C Interpolate to get ZI values.
C
      ITPV=0
      JIG0MX=0
      JIG1MN=NXI*NYI+1
      NNGP=NT+2*NL
C
      DO 105 JNGP=1,NNGP
C
        ITI=JNGP
        IF (JNGP.LE.NT) GO TO 101
        IL1=(JNGP-NT+1)/2
        IL2=(JNGP-NT+2)/2
        IF (IL2.GT.NL) IL2=1
        ITI=IL1*(NT+NL)+IL2
C
  101   JWNGP=JWNGP0+JNGP
        NGP0=IWK(JWNGP)
        IF (NGP0.EQ.0) GO TO 103
        JIG0MN=JIG0MX+1
        JIG0MX=JIG0MX+NGP0
C
        DO 102 JIGP=JIG0MN,JIG0MX
          JWIGP=JWIGP0+JIGP
          IZI=IWK(JWIGP)
          IYI=(IZI-1)/NXI+1
          IXI=IZI-NXI*(IYI-1)
          CALL IDPTIP(XD,YD,ZD,NT,IWK(JWIPT),NL,IWK(JWIPL),WK,
     +                        ITI,XI(IXI),YI(IYI),ZI(IXI,IYI))
  102   CONTINUE
C
  103   JWNGP=JWNGP0+2*NNGP+1-JNGP
        NGP1=IWK(JWNGP)
        IF (NGP1.EQ.0) GO TO 105
        JIG1MX=JIG1MN-1
        JIG1MN=JIG1MN-NGP1
C
        DO 104 JIGP=JIG1MN,JIG1MX
          JWIGP=JWIGP0+JIGP
          IZI=IWK(JWIGP)
          IYI=(IZI-1)/NXI+1
          IXI=IZI-NXI*(IYI-1)
          CALL IDPTIP(XD,YD,ZD,NT,IWK(JWIPT),NL,IWK(JWIPL),WK,
     +                        ITI,XI(IXI),YI(IYI),ZI(IXI,IYI))
  104   CONTINUE
C
  105 CONTINUE
C
C Done.
C
        RETURN
C
      END


! Copyright (c) 2019 Etienne Descamps
! All rights reserved.
!
! Redistribution and use in source and binary forms, with or without modification,
! are permitted provided that the following conditions are met:
!
! 1. Redistributions of source code must retain the above copyright notice,
!    this list of conditions and the following disclaimer.
!
! 2. Redistributions in binary form must reproduce the above copyright notice,
!    this list of conditions and the following disclaimer in the documentation and/or
!    other materials provided with the distribution.
!
! 3. Neither the name of the copyright holder nor the names of its contributors may be
!    used to endorse or promote products derived from this software without specific prior
!    written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
! ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
! WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
! IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
! INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
! (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
! LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
! THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
! NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE,
! EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Program test_gamma
  Use ieee_arithmetic
  Use iso_c_binding
  Use mlf_utils
  Use mlf_gamma_dist
  Use mlf_histogram
  Use mlf_hdf5
  Use mlf_intf
  integer :: info
  type(mlf_hdf5_file) :: h5f
  info = mlf_init()
  info = h5f%createFile("test_gamma.h5")
  CALL test_gammaFun(h5f, 500000, 50d0)
  CALL test_random(h5f, "g1", 1d0, 1024, 1024)
  CALL test_random(h5f, "g0.5", 0.5d0, 1024, 1024)
  CALL test_random(h5f, "g2", 2d0, 1024, 1024)
  CALL h5f%finalize()
  info = mlf_quit()
Contains
  Subroutine test_gammaFun(h5f, N, vMax)
    class(mlf_hdf5_file), intent(inout) :: h5f
    integer, intent(in) :: N
    integer :: i
    real(c_double), intent(in) :: vMax
    real(c_double), allocatable :: gammaV(:,:)
    ALLOCATE(gammaV(5, N))
    FORALL(i=1:N) gammaV(1,i) = vMax*REAL(i,8)/REAL(N,8)
    gammaV(2,:) = LOG_GAMMA(gammaV(1,:))
    gammaV(3,:) = Digamma(gammaV(1,:))
    gammaV(4,:) = Trigamma(gammaV(1,:))
    gammaV(5,:) = Tetragamma(gammaV(1,:))
    info = h5f%pushData(gammaV, "gammaVal")
  End Subroutine
  Subroutine test_random(h5f, rname, a, k, N)
    class(mlf_hdf5_file), intent(inout) :: h5f
    character(len=*), intent(in) :: rname
    real(c_double), intent(in) :: a
    integer, intent(in) :: k, N
    real(c_double), allocatable :: X(:), points(:,:), gammaV(:,:)
    integer, allocatable :: idx(:)
    type(mlf_histogram_int) :: hist
    integer :: info, i, j
    integer, parameter :: sizeX = 16384
    real(c_double) :: vMax = 10d0
    info = hist%init(0d0, vMax, k)
    ALLOCATE(X(sizeX), idx(sizeX), points(2,k+1), gammaV(2, 64*k))
    Do j = 1, N
      Do i = 1, sizeX
        Do
          X(i) = RandomGamma(a)
          If(X(i) < vMax) EXIT
        End DO
      End Do
      CALL QSortIdx(X, idx)
      X = X(idx)
      CALL hist%addVectSorted(X)
    End Do
    info = hist%get(points(2,:), points(1,:))
    points(2,:) = REAL(k-1, 8)*points(2,:)/vMax
    info = h5f%pushData(points, rname)
    FORALL(i=1:64*k) gammaV(1,i) = vMax*REAL(i-1,8)/REAL(64*k-1,8)
    gammaV(2,:) = GammaDensity(a, gammaV(1,:))
    info = h5f%pushData(gammaV, rname//"_real")
  End Subroutine test_random
End


#include "eiscor.h"
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! z_upr1fpen_decompress
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! This routine decompresses a factored unitary plus rank one
! (upr1fpen) matrix pencil.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! INPUT VARIABLES:
!
!  N               INTEGER
!                    dimension of matrix
!
!  P               LOGICAL array of dimension (N-2)
!                    array of position flags for Q
!
!  Q               REAL(8) array of dimension (3*(N-1))
!                    array of generators for first sequence of rotations
!
!  D1,D2           REAL(8) arrays of dimension (2*N)
!                    arrays of generators for complex diagonal matrices
!                    in the upper-triangular factors
!
!  C1,C2,B1,B2     REAL(8) arrays of dimension (3*N)
!                    arrays of generators for unitary plus rank one
!                    upper-trinagular matrices
!
! OUTPUT VARIABLES:
!
!  H,T             COMPLEX(8) arrays of dimension (N,N)
!                    extended hessenberg, triangular pencil
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine z_upr1fpen_decompress(N,P,Q,D1,C1,B1,D2,C2,B2,H,T)

  implicit none

  ! input variables
  integer, intent(in) :: N
  logical, intent(in) :: P(N-2)
  real(8), intent(in) :: Q(3*(N-1)), D1(2*N), C1(3*N), B1(3*N)
  real(8), intent(in) :: D2(2*N), C2(3*N), B2(3*N)
  complex(8), intent(inout) :: H(N,N), T(N,N)

  ! decompress H
  call z_upr1fact_decompress(N,P,Q,D1,C1,B1,H)

  ! decompress T
  call z_upr1utri_decompress(.FALSE.,N,D2,C2,B2,T)

end subroutine z_upr1fpen_decompress


      SUBROUTINE W3FI59(FIELD,NPTS,NBITS,NWORK,NPFLD,ISCALE,LEN,RMIN)
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    W3FI59      FORM AND PACK POSITIVE, SCALED DIFFERENCES
C   PRGMMR:  ALLARD, R.      ORG: NMC41      DATE:  84-08-01
C
C ABSTRACT:  CONVERTS AN ARRAY OF SINGLE PRECISION REAL NUMBERS INTO
C   AN ARRAY OF POSITIVE SCALED DIFFERENCES (NUMBER(S) - MINIMUM VALUE),
C   IN INTEGER FORMAT AND PACKS THE ARGUMENT-SPECIFIED NUMBER OF
C   SIGNIFICANT BITS FROM EACH DIFFERENCE.
C
C PROGRAM HISTORY LOG:
C   84-08-01  ALLARD      ORIGINAL AUTHOR
C   90-05-17  R.E.JONES   CONVERT TO CRAY CFT77 FORTRAN
C   90-05-18  R.E.JONES   CHANGE NAME PAKMAG TO W3LIB NAME W3FI59
C   93-07-06  R.E.JONES   ADD NINT TO DO LOOP 2000 SO NUMBERS ARE
C                         ROUNDED TO NEAREST INTEGER, NOT TRUNCATED.
C   94-01-05  IREDELL     COMPUTATION OF ISCALE FIXED WITH RESPECT TO
C                         THE 93-07-06 CHANGE.
C   98-03-10  B. VUONG    REMOVE THE CDIR$ INTEGER=64 DIRECTIVE
C
C USAGE:    CALL W3FI59(FIELD,NPTS,NBITS,NWORK,NPFLD,ISCALE,LEN,RMIN)
C   INPUT ARGUMENT LIST:
C     FIELD - ARRAY OF FLOATING POINT DATA FOR PROCESSING  (REAL)
C     NPTS  - NUMBER OF DATA VALUES TO PROCESS IN FIELD (AND NWORK)
C             WHERE, NPTS > 0
C     NBITS - NUMBER OF SIGNIFICANT BITS OF PROCESSED DATA TO BE PACKED
C             WHERE, 0 < NBITS < 32+1
C
C   OUTPUT ARGUMENT LIST:
C     NWORK - ARRAY FOR INTEGER CONVERSION  (INTEGER)
C             IF PACKING PERFORMED (SEE NOTE BELOW), THE ARRAY WILL
C             CONTAIN THE PRE-PACKED, RIGHT ADJUSTED, SCALED, INTEGER
C             DIFFERENCES UPON RETURN TO THE USER.
C             (THE USER MAY EQUIVALENCE FIELD AND NWORK.  SAME SIZE.)
C     NPFLD - ARRAY FOR PACKED DATA  (INTEGER)
C             (DIMENSION MUST BE AT LEAST (NBITS * NPTS) / 64 + 1  )
C     ISCALE- POWER OF 2 FOR RESTORING DATA, SUCH THAT
C             DATUM = (DIFFERENCE * 2**ISCALE) + RMIN
C     LEN   - NUMBER OF PACKED BYTES IN NPFLD (SET TO 0 IF NO PACKING)
C             WHERE, LEN = (NBITS * NPTS + 7) / 8 WITHOUT REMAINDER
C     RMIN  - MINIMUM VALUE (REFERENCE VALUE SUBTRACTED FROM INPUT DATA)
C             THIS IS A CRAY FLOATING POINT NUMBER, IT WILL HAVE TO BE
C             CONVERTED TO AN IBM370 32 BIT FLOATING POINT NUMBER AT
C             SOME POINT IN YOUR PROGRAM IF YOU ARE PACKING GRIB DATA.
C
C REMARKS:  LEN = 0 AND NO PACKING PERFORMED IF
C
C        (1)  RMAX = RMIN  (A CONSTANT FIELD)
C        (2)  NBITS VALUE OUT OF RANGE  (SEE INPUT ARGUMENT)
C        (3)  NPTS VALUE LESS THAN 1  (SEE INPUT ARGUMENT)
C
C ATTRIBUTES:
C   LANGUAGE: CRAY CFT77 FORTRAN
C   MACHINE:  CRAY C916/256, Y-MP8/864, Y-MP EL92/256, J916/2048
C
C$$$
C
      REAL    FIELD(*)
C
      INTEGER NPFLD(*)
      INTEGER NWORK(*)
C
      DATA KZERO / 0 /
C
C  NATURAL LOGARITHM OF 2 AND 0.5 PLUS NOMINAL SAFE EPSILON
      PARAMETER(ALOG2=0.69314718056,HPEPS=0.500001)
C
C / / / / / /
C
      LEN    = 0
      ISCALE = 0
      IF (NBITS.LE.0.OR.NBITS.GT.32) GO TO 3000
      IF (NPTS.LE.0) GO TO 3000
C
C FIND THE MAX-MIN VALUES IN FIELD.
C
      RMAX = FIELD(1)
      RMIN = RMAX
      DO 1000 K = 2,NPTS
        RMAX = AMAX1(RMAX,FIELD(K))
        RMIN = AMIN1(RMIN,FIELD(K))
 1000 CONTINUE
C
C IF A CONSTANT FIELD, RETURN WITH NO PACKING PERFORMED AND 'LEN' = 0.
C
      IF (RMAX.EQ.RMIN) GO TO 3000
C
C DETERMINE LARGEST DIFFERENCE IN FIELD (BIGDIF).
C
      BIGDIF = RMAX - RMIN
C
C ISCALE IS THE POWER OF 2 REQUIRED TO RESTORE THE PACKED DATA.
C ISCALE IS COMPUTED AS THE LEAST INTEGER SUCH THAT
C   BIGDIF*2**(-ISCALE) < 2**NBITS-0.5
C IN ORDER TO ENSURE THAT THE PACKED INTEGERS (COMPUTED IN LOOP 2000
C WITH THE NEAREST INTEGER FUNCTION) STAY LESS THAN 2**NBITS.
C
      ISCALE=NINT(ALOG(BIGDIF/(2.**NBITS-0.5))/ALOG2+HPEPS)
C
C FORM DIFFERENCES, RESCALE, AND CONVERT TO INTEGER FORMAT.
C
      TWON = 2.0 ** (-ISCALE)
      DO 2000 K = 1,NPTS
        NWORK(K) = NINT( (FIELD(K) - RMIN) * TWON )
 2000 CONTINUE
C
C PACK THE MAGNITUDES (RIGHTMOST NBITS OF EACH WORD).
C
      KOFF  = 0
      ISKIP = 0
C
C     USE NCAR ARRAY BIT PACKER SBYTES  (GBYTES PACKAGE)
C
      CALL SBYTES(NPFLD,NWORK,KOFF,NBITS,ISKIP,NPTS)
C
C ADD 7 ZERO-BITS AT END OF PACKED DATA TO INSURE BYTE BOUNDARY.
C     USE NCAR WORD BIT PACKER SBYTE
C
      NOFF = NBITS * NPTS
      CALL SBYTE(NPFLD,KZERO,NOFF,7)
C
C DETERMINE BYTE LENGTH (LEN) OF PACKED FIELD (NPFLD).
C
      LEN = (NOFF + 7) / 8
C
 3000 CONTINUE
      RETURN
C
      END


!!  Take an initial model from a Lagrangian code and put it onto
!!  a uniform grid and make sure that it is happy with the EOS in
!!  our code.  The output is a .hse file that can be read directly
!!  by Maestro.
!!
!!  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
!!
!!
!!  We take the temperature structure directly from the original
!!  initial model.  We adjust the density and pressure according to
!!  HSE using the EOS.
!!
!!***

program init_1d

  use bl_types
  use bl_constants_module
  use bl_error_module
  use eos_module, only: eos, eos_init
  use eos_type_module, only : eos_t, eos_input_rt
  use network
  use fundamental_constants_module
  use extern_probin_module, only: use_eos_coulomb

  implicit none

  integer :: i, j, n

  real (kind=dp_t), allocatable :: xzn_hse(:), xznl(:), xznr(:)
  real (kind=dp_t), allocatable :: M_enclosed(:)
  real (kind=dp_t), allocatable :: model_kepler_hse(:,:)
  real (kind=dp_t), allocatable :: model_isentropic_hse(:,:)
  real (kind=dp_t), allocatable :: model_hybrid_hse(:,:)
  real (kind=dp_t), allocatable :: entropy_want(:)

  integer, parameter :: nx = 1280

  ! define convenient indices for the scalars
  integer, parameter :: nvar = 5 + nspec
  integer, parameter :: idens = 1, &
                        itemp = 2, &
                        ipres = 3, &
                        ientr = 4, &
                        isndspd = 5, &
                        ispec = 6

  real (kind=dp_t), save :: xmin, xmax, delx

  real (kind=dp_t) :: dens_zone, temp_zone, pres_zone, entropy

  real (kind=dp_t) :: A, B, dAdT, dAdrho, dBdT, dBdrho
  real (kind=dp_t) :: dpd, dpt, dsd, dst

  real (kind=dp_t) :: central_density

  real (kind=dp_t) :: p_want, drho, dtemp

  real (kind=dp_t) :: g_zone

  real (kind=dp_t) :: max_hse_error, dpdr, rhog

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

  integer, parameter :: MAX_ITER = 250

  integer :: iter, iter_dens

  integer :: igood
  real (kind=dp_t) :: slope

  logical :: converged_hse, converged_central_density, fluff, isentropic

  real (kind=dp_t) :: max_temp

  integer :: index_hse_fluff

  real (kind=dp_t), dimension(nspec) :: xn

  real (kind=dp_t), save :: low_density_cutoff, temp_fluff, temp_fluff_cutoff, smallx

  integer, parameter :: MAX_VARNAME_LENGTH=80
  integer :: npts_model, nvars_model_file

  real(kind=dp_t), allocatable :: base_state(:,:), base_r(:)
  real(kind=dp_t), allocatable :: vars_stored(:)
  character(len=MAX_VARNAME_LENGTH), allocatable :: varnames_stored(:)
  logical :: found

  integer :: ipos
  character (len=256) :: header_line, model_file, outfile
  character (len=8) num

  real(kind=dp_t) :: interpolate
  real(kind=dp_t) :: sum

  integer :: ibegin
  integer :: i_isentropic

  real(kind=dp_t), parameter :: M_solar = 1.98892d33
  real(kind=dp_t) :: anelastic_cutoff = 3.e6  ! this is for diagnostics only -- not used in the HSEing
  real(kind=dp_t) :: M_enclosed_anel
  real(kind=dp_t) :: grav_ener, M_center
  real(kind=dp_t) :: eint_hybrid

  type (eos_t) :: eos_state

  smallx = 1.d-10

  ! set the parameters
  model_file = "kepler_new_6.25e8.raw"

  xmin = 0_dp_t
  xmax = 5.d8

  low_density_cutoff =1.d-4

  ! temp_fluff_cutoff is the density below which we hold the temperature
  ! constant for the kepler model

  ! MAESTRO
  ! temp_fluff_cutoff = 1.d-4

  ! CASTRO
  temp_fluff_cutoff = 1.d3

  temp_fluff = 5.d6

  ! this comes in via extern_probin_module -- override the default
  ! here if we want
  use_eos_coulomb = .true.

  ! initialize the EOS and network
  call eos_init()
  call network_init()

  !===========================================================================
  ! 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.
  !===========================================================================

  ! allocate storage
  allocate(xzn_hse(nx))
  allocate(xznl(nx))
  allocate(xznr(nx))
  allocate(model_kepler_hse(nx,nvar))
  allocate(model_isentropic_hse(nx,nvar))
  allocate(model_hybrid_hse(nx,nvar))
  allocate(M_enclosed(nx))
  allocate(entropy_want(nx))

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

  do i = 1, nx
     xznl(i) = xmin + (dble(i) - 1.0_dp_t)*delx
     xznr(i) = xmin + (dble(i))*delx
     xzn_hse(i) = 0.5_dp_t*(xznl(i) + xznr(i))
  enddo

  !===========================================================================
  ! read in the Kepler model
  !===========================================================================

  ! Open the model file and read in the header
  !
  ! the model file is assumed to be of the follow form:
  ! # npts = 178
  ! # num of variables = 6
  ! # density
  ! # temperature
  ! # pressure
  ! # carbon-12
  ! # oxygen-16
  ! # magnesium-24
  ! 195312.5000  5437711139.  8805500.952   .4695704813E+28  0.3  0.7  0
  ! 585937.5000  5410152416.  8816689.836  0.4663923963E+28  0.3  0.7  0
  !
  ! we read in the number of variables and their order and use this to map
  ! them into the base_state array.  We ignore anything other than density,
  ! temperature, pressure and composition.
  !
  ! Presently, we take density, temperature, and composition as the
  ! independent variables and use them to define the thermodynamic state.
  !
  ! composition is assumed to be in terms of mass fractions

  open(99,file=model_file)

  ! the first line has the number of points in the model
  read (99, '(a256)') header_line
  ipos = index(header_line, '=') + 1
  read (header_line(ipos:),*) npts_model

  print *, npts_model, '    points found in the initial model file'

  ! now read in the number of variables
  read (99, '(a256)') header_line
  ipos = index(header_line, '=') + 1
  read (header_line(ipos:),*) nvars_model_file

  print *, nvars_model_file, ' variables found in the initial model file'

  allocate (vars_stored(nvars_model_file))
  allocate (varnames_stored(nvars_model_file))

  ! now read in the names of the variables
  do i = 1, nvars_model_file
     read (99, '(a256)') header_line
     ipos = index(header_line, '#') + 1
     varnames_stored(i) = trim(adjustl(header_line(ipos:)))
  enddo

  ! allocate storage for the model data
  allocate (base_state(npts_model, nvar))
  allocate (base_r(npts_model))

  do i = 1, npts_model
     read(99,*) base_r(i), (vars_stored(j), j = 1, nvars_model_file)

     base_state(i,:) = ZERO

     do j = 1, nvars_model_file

        found = .false.

        select case (trim(varnames_stored(j)))

        case ("density")
           base_state(i,idens) = vars_stored(j)
           found = .true.

        case ("temperature")
           base_state(i,itemp) = vars_stored(j)
           found = .true.

        case ("pressure")
           base_state(i,ipres) = vars_stored(j)
           found = .true.

        case default

           ! check if they are species
           n = network_species_index(trim(varnames_stored(j)))
           if (n > 0) then
              base_state(i,ispec-1+n) = vars_stored(j)
              found = .true.
           endif

        end select

        if (.NOT. found) then
           print *, 'ERROR: variable not found: ', varnames_stored(j)
        endif

     enddo

  enddo

  open (unit=50, file="model.orig", status="unknown")

  write (50,*) "# initial model as read in"

  do i = 1, npts_model
     write (50,1000) base_r(i), (base_state(i,j), j = 1, nvar)
  enddo

  close (50)

  !===========================================================================
  ! put the model onto our new uniform grid
  !===========================================================================

  igood = -1

  do i = 1, nx

     do n = 1, nvar

        if (xzn_hse(i) < base_r(npts_model)) then

           model_kepler_hse(i,n) = interpolate(xzn_hse(i), npts_model, &
                                        base_r, base_state(:,n))

           igood = i
        else

           !if (n == itemp) then

              ! linearly interpolate the last good Kepler zones
           !   slope = (model_kepler_hse(igood,itemp) - model_kepler_hse(igood-1,itemp))/ &
           !        (xzn_hse(igood) - xzn_hse(igood-1))
           !
           !   model_kepler_hse(i,n) = max(temp_fluff, &
           !                               model_kepler_hse(igood,itemp) + slope*(xzn_hse(i) - xzn_hse(igood)))

           !else
              ! use a zero-gradient at the top of the initial model if our domain is
              ! larger than the model's domain.

              model_kepler_hse(i,n) = base_state(npts_model,n)
           !endif
        endif

     enddo

     ! make sure that the species (mass fractions) sum to 1
     sum = 0.0_dp_t
     do n = ispec,ispec-1+nspec
        model_kepler_hse(i,n) = max(model_kepler_hse(i,n),smallx)
        sum = sum + model_kepler_hse(i,n)
     enddo

     do n = ispec,ispec-1+nspec
        model_kepler_hse(i,n) = model_kepler_hse(i,n)/sum
     enddo

  enddo

  open (unit=30, file="model.uniform", status="unknown")

1000 format (1x, 12(g26.16, 1x))

  write (30,*) "# initial model just after putting onto a uniform grid"

  do i = 1, nx

     write (30,1000) xzn_hse(i), model_kepler_hse(i,idens), model_kepler_hse(i,itemp), &
          model_kepler_hse(i,ipres), (model_kepler_hse(i,ispec-1+n), n=1,nspec)

  enddo

  close (unit=30)

  !===========================================================================
  ! iterate to find the central density
  !===========================================================================

  ! because the Kepler model likely begins at a larger radius than our first
  ! HSE model zone, simple interpolation will not do a good job.  We want to
  ! integrate in from the zone that best matches the first Kepler model zone,
  ! assuming HSE and constant entropy.

  ! find the zone in the uniformly gridded model that corresponds to the
  ! first zone of the original model
  ibegin = -1
  do i = 1, nx
     if (xzn_hse(i) >= base_r(1)) then
        ibegin = i
        exit
     endif
  enddo

  print *, 'ibegin = ', ibegin

  ! store the central density.  We will iterate until the central density
  ! converges
  central_density = model_kepler_hse(1,idens)
  print *, 'interpolated central density = ', central_density

  do iter_dens = 1, max_iter

     ! compute the enclosed mass
     M_enclosed(1) = FOUR3RD*M_PI*delx**3*model_kepler_hse(1,idens)

     do i = 2, ibegin
        M_enclosed(i) = M_enclosed(i-1) + &
             FOUR3RD*M_PI*(xznr(i) - xznl(i)) * &
             (xznr(i)**2 +xznl(i)*xznr(i) + xznl(i)**2)*model_kepler_hse(i,idens)
     enddo

     ! now start at ibegin and integrate inward
     eos_state%T     = model_kepler_hse(ibegin,itemp)
     eos_state%rho   = model_kepler_hse(ibegin,idens)
     eos_state%xn(:) = model_kepler_hse(ibegin,ispec:nvar)

     call eos(eos_input_rt, eos_state)

     model_kepler_hse(ibegin,ipres) = eos_state%p
     model_kepler_hse(ibegin,ientr) = eos_state%s
     model_kepler_hse(ibegin,isndspd) = &
          sqrt(eos_state%gam1*eos_state%p/eos_state%rho)

     entropy_want(:) = eos_state%s

     do i = ibegin-1, 1, -1

        ! as the initial guess for the temperature and density, use
        ! the previous zone
        dens_zone = model_kepler_hse(i+1,idens)
        temp_zone = model_kepler_hse(i+1,itemp)
        xn(:) = model_kepler_hse(i,ispec:nvar)

        ! compute the gravitational acceleration on the interface between zones
        ! i and i+1
        g_zone = -Gconst*M_enclosed(i)/(xznr(i)*xznr(i))

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

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

        do iter = 1, MAX_ITER

           p_want = model_kepler_hse(i+1,ipres) - &
                delx*0.5_dp_t*(dens_zone + model_kepler_hse(i+1,idens))*g_zone

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

           ! (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_want(i) - entropy

           dAdT = -dpt
           dAdrho = -0.5d0*delx*g_zone - dpd
           dBdT = -dst
           dBdrho = -dsd

           dtemp = (B - (dBdrho/dAdrho)*A)/ &
                ((dBdrho/dAdrho)*dAdT - dBdT)

           drho = -(A + dAdT*dtemp)/dAdrho

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

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

           ! 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

        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
           print *, drho
           call bl_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, s)

        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

        ! update the thermodynamics in this zone
        model_kepler_hse(i,idens) = dens_zone
        model_kepler_hse(i,itemp) = temp_zone
        model_kepler_hse(i,ipres) = pres_zone
        model_kepler_hse(i,ientr) = eos_state%s
        model_kepler_hse(i,isndspd) = &
             sqrt(eos_state%gam1*eos_state%p/eos_state%rho)

     enddo

     if (abs(model_kepler_hse(1,idens) - central_density) < TOL*central_density) then
        converged_central_density = .true.
        exit
     endif

     central_density = model_kepler_hse(1,idens)

  enddo

  if (.NOT. converged_central_density) then
     print *, 'ERROR: central density iterations did not converge'
     call bl_error('ERROR: non-convergence')
  endif

  print *, 'converged central density = ', model_kepler_hse(1,idens)
  print *, ' '

  !===========================================================================
  ! compute the full HSE model using our new central density and temperature,
  ! and the temperature structure as dictated by the Kepler model.
  !===========================================================================

  print *, 'putting Kepler model into HSE on our grid...'

  ! compute the enclosed mass
  M_enclosed(1) = FOUR3RD*M_PI*delx**3*model_kepler_hse(1,idens)

  fluff = .FALSE.

  do i = 2, nx

     ! use previous zone as initial guess for T, rho
     dens_zone = model_kepler_hse(i-1,idens)
     temp_zone = model_kepler_hse(i-1,itemp)

     xn(:) = model_kepler_hse(i,ispec:nvar)

     ! compute the gravitational acceleration on the interface between zones
     ! i-1 and i
     g_zone = -Gconst*M_enclosed(i-1)/(xznr(i-1)*xznr(i-1))

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

     converged_hse = .FALSE.

     if (.not. fluff) then

        do iter = 1, MAX_ITER

           ! HSE differencing
           p_want = model_kepler_hse(i-1,ipres) + &
                delx*0.5_dp_t*(dens_zone + model_kepler_hse(i-1,idens))*g_zone

           temp_zone = model_kepler_hse(i,itemp)

           if (model_kepler_hse(i-1,idens) .lt. temp_fluff_cutoff) then
              temp_zone = temp_fluff
           end if

           ! (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
           drho = (p_want - pres_zone)/(dpd - 0.5_dp_t*delx*g_zone)

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

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

           if (dens_zone < low_density_cutoff) then
              dens_zone = low_density_cutoff
              temp_zone = temp_fluff
              converged_hse = .TRUE.
              fluff = .TRUE.
              index_hse_fluff = i
              exit

           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
           print *, drho
           call bl_error('Error: HSE non-convergence')

        endif

        if (temp_zone < temp_fluff) then
           temp_zone = temp_fluff
        endif

     else
        dens_zone = low_density_cutoff
        temp_zone = temp_fluff
     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
     model_kepler_hse(i,idens) = dens_zone
     model_kepler_hse(i,itemp) = temp_zone
     model_kepler_hse(i,ipres) = pres_zone
     model_kepler_hse(i,ientr) = eos_state%s
     model_kepler_hse(i,isndspd) = &
          sqrt(eos_state%gam1*eos_state%p/eos_state%rho)

     M_enclosed(i) = M_enclosed(i-1) + &
          FOUR3RD*M_PI*(xznr(i) - xznl(i)) * &
          (xznr(i)**2 +xznl(i)*xznr(i) + xznl(i)**2)*model_kepler_hse(i,idens)

  enddo

  !===========================================================================
  ! compute the alternate model using the same central density and
  ! temperature, but assuming that we are isentropic (and in HSE).
  !===========================================================================

  print *, 'creating isentropic model...'

  ! as an initial guess, use the Kepler HSE model
  model_isentropic_hse(:,:) = model_kepler_hse(:,:)

  entropy_want(:) = model_isentropic_hse(1,ientr)

  fluff = .false.
  isentropic = .true.

  ! keep track of the mass enclosed below the current zone
  M_enclosed(1) = FOUR3RD*M_PI*delx**3*model_isentropic_hse(1,idens)

  do i = 2, nx

     ! use previous zone as initial guess for T, rho
     dens_zone = model_isentropic_hse(i-1,idens)
     temp_zone = model_isentropic_hse(i-1,itemp)

     xn(:) = model_isentropic_hse(i,ispec:nvar)

     g_zone = -Gconst*M_enclosed(i-1)/(xznr(i-1)*xznr(i-1))

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

              p_want = model_isentropic_hse(i-1,ipres) + &
                   delx*0.5_dp_t*(dens_zone + model_isentropic_hse(i-1,idens))*g_zone

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

              ! (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_want(i) - entropy

              dAdT = -dpt
              dAdrho = 0.5d0*delx*g_zone - dpd
              dBdT = -dst
              dBdrho = -dsd

              dtemp = (B - (dBdrho/dAdrho)*A)/ &
                   ((dBdrho/dAdrho)*dAdT - dBdT)

              drho = -(A + dAdT*dtemp)/dAdrho

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

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

              if (dens_zone < low_density_cutoff) then

                 dens_zone = low_density_cutoff
                 temp_zone = temp_fluff
                 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 = model_isentropic_hse(i-1,ipres) + &
                   delx*0.5*(dens_zone + model_isentropic_hse(i-1,idens))*g_zone

              temp_zone = temp_fluff

              ! (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

              dpd = eos_state%dpdr

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

              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 < low_density_cutoff) then

                 dens_zone = low_density_cutoff
                 temp_zone = temp_fluff
                 converged_hse = .TRUE.
                 fluff = .TRUE.
                 exit

              endif

           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
           print *, drho
           call bl_error('Error: HSE non-convergence')

        endif

        if (temp_zone < temp_fluff) then
           temp_zone = temp_fluff
           isentropic = .false.
        endif

     else
        dens_zone = low_density_cutoff
        temp_zone = temp_fluff
     endif

     ! call the EOS one more time for this zone and then go on to the next
     ! (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)

     pres_zone = eos_state%p

     dpd = eos_state%dpdr

     ! update the thermodynamics in this zone
     model_isentropic_hse(i,idens) = dens_zone
     model_isentropic_hse(i,itemp) = temp_zone
     model_isentropic_hse(i,ipres) = pres_zone
     model_isentropic_hse(i,ientr) = eos_state%s
     model_isentropic_hse(i,isndspd) = &
          sqrt(eos_state%gam1*eos_state%p/eos_state%rho)

     M_enclosed(i) = M_enclosed(i-1) + &
          FOUR3RD*M_PI*(xznr(i) - xznl(i))* &
          (xznr(i)**2 +xznl(i)*xznr(i) + xznl(i)**2)*model_isentropic_hse(i,idens)

  enddo

  !===========================================================================
  ! compute a hybrid model -- isentropic in the interior, Kepler's temperature
  ! structure outside.
  !===========================================================================

  print *, 'creating hybrid model...'
  print *, ' '
  eint_hybrid = 0.0

  max_temp = maxval(model_kepler_hse(:,itemp))
  i_isentropic = -1
  do i = 1, nx
     model_hybrid_hse(i,:) = model_isentropic_hse(i,:)

     if (model_kepler_hse(i,itemp) > model_isentropic_hse(i,itemp)) then

        ! there will be a few regions in the very, very center where
        ! the kepler temperature may be slightly higher than the
        ! isentropic, but we are still not done with isentropic.
        ! i_isentropic is an index that keeps track of when we switch
        ! to the original kepler model "for real".  This is used for
        ! diagnostics.  We require the temperature to have dropped by
        ! 10% from the central value at least...
        if (i_isentropic == -1 .and. &
             model_isentropic_hse(i,itemp) < 0.9*max_temp) i_isentropic = i

        model_hybrid_hse(i,itemp) = model_kepler_hse(i,itemp)
     endif

  enddo

  ! the outer part of the star will be using the original kepler
  ! temperature structure.  Because the hybrid model might hit the
  ! fluff region earlier or later than the kepler model, reset the
  ! temperatures in the fluff region to the last valid kepler zone.
  model_hybrid_hse(index_hse_fluff:,itemp) = model_kepler_hse(index_hse_fluff-1,itemp)

  ! compute the enclosed mass
  M_enclosed(1) = FOUR3RD*M_PI*delx**3*model_hybrid_hse(1,idens)

  fluff = .FALSE.

  do i = 2, nx

     ! use previous zone as initial guess for T, rho
     dens_zone = model_hybrid_hse(i-1,idens)
     temp_zone = model_hybrid_hse(i-1,itemp)

     xn(:) = model_hybrid_hse(i,ispec:nvar)

     ! compute the gravitational acceleration on the interface between zones
     ! i-1 and i
     g_zone = -Gconst*M_enclosed(i-1)/(xznr(i-1)*xznr(i-1))

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

     converged_hse = .FALSE.

     if (.not. fluff) then

        do iter = 1, MAX_ITER

           ! HSE differencing
           p_want = model_hybrid_hse(i-1,ipres) + &
                delx*0.5_dp_t*(dens_zone + model_hybrid_hse(i-1,idens))*g_zone

           temp_zone = model_hybrid_hse(i,itemp)

           ! (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
           drho = (p_want - pres_zone)/(dpd - 0.5_dp_t*delx*g_zone)

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

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

           if (dens_zone <= low_density_cutoff) then
              dens_zone = low_density_cutoff
              temp_zone = temp_fluff
              converged_hse = .TRUE.
              fluff = .TRUE.
              exit

           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
           print *, drho
           call bl_error('Error: HSE non-convergence')

        endif

        if (temp_zone < temp_fluff) then
           temp_zone = temp_fluff
        endif

     else
        dens_zone = low_density_cutoff
        temp_zone = temp_fluff
     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
     model_hybrid_hse(i,idens) = dens_zone
     model_hybrid_hse(i,itemp) = temp_zone
     model_hybrid_hse(i,ipres) = pres_zone
     model_hybrid_hse(i,ientr) = eos_state%s
     model_hybrid_hse(i,isndspd) = &
          sqrt(eos_state%gam1*eos_state%p/eos_state%rho)

     eint_hybrid = eint_hybrid + &
          dens_zone*eos_state%e*FOUR3RD*M_PI*(xznr(i) - xznl(i)) * &
          (xznr(i)**2 +xznl(i)*xznr(i) + xznl(i)**2)

     M_enclosed(i) = M_enclosed(i-1) + &
          FOUR3RD*M_PI*(xznr(i) - xznl(i)) * &
          (xznr(i)**2 +xznl(i)*xznr(i) + xznl(i)**2)*model_hybrid_hse(i,idens)

  enddo

  !===========================================================================
  ! output
  !===========================================================================

  !---------------------------------------------------------------------------
  ! kepler model
  !---------------------------------------------------------------------------

  ipos = index(model_file, '.raw')
  outfile = model_file(1:ipos-1) // '.hse'

  write(num,'(i8)') nx

  outfile = trim(outfile) // '.' // trim(adjustl(num))

  print *, 'writing HSE Kepler model to ', trim(outfile)

  open (unit=50, file=outfile, status="unknown")

  write (50,1001) "# npts = ", nx
  write (50,1001) "# num of variables = ", 3 + nspec
  write (50,1002) "# density"
  write (50,1002) "# temperature"
  write (50,1002) "# pressure"

  do n = 1, nspec
     write (50,1003) "# ", spec_names(n)
  enddo

1001 format(a, i5)
1002 format(a)
1003 format(a,a)

  do i = 1, nx

     write (50,1000) xzn_hse(i), model_kepler_hse(i,idens), model_kepler_hse(i,itemp), model_kepler_hse(i,ipres), &
          (model_kepler_hse(i,ispec-1+n), n=1,nspec)

  enddo

  close (unit=50)

  ! compute the enclosed mass
  M_enclosed(1) = FOUR3RD*M_PI*delx**3*model_kepler_hse(1,idens)

  do i = 2, nx
     M_enclosed(i) = M_enclosed(i-1) + &
          FOUR3RD*M_PI*(xznr(i) - xznl(i)) * &
          (xznr(i)**2 +xznl(i)*xznr(i) + xznl(i)**2)*model_kepler_hse(i,idens)
  enddo

  print *, 'total mass = ', real(M_enclosed(nx)), ' g = ', real(M_enclosed(nx)/M_solar), ' solar masses'

  ! compute the maximum HSE error
  max_hse_error = -1.d30

  do i = 2, nx-1
     g_zone = -Gconst*M_enclosed(i-1)/xznr(i-1)**2
     dpdr = (model_kepler_hse(i,ipres) - model_kepler_hse(i-1,ipres))/delx
     rhog = HALF*(model_kepler_hse(i,idens) + model_kepler_hse(i-1,idens))*g_zone

     if (dpdr /= ZERO .and. model_kepler_hse(i+1,idens) > low_density_cutoff) then
        max_hse_error = max(max_hse_error, abs(dpdr - rhog)/abs(dpdr))
     endif
  enddo

  print *, 'maximum HSE error = ', max_hse_error
  print *, ' '

  !---------------------------------------------------------------------------
  ! isentropic model
  !---------------------------------------------------------------------------

  ipos = index(model_file, '.raw')
  outfile = model_file(1:ipos-1) // '.isentropic.hse'

  write(num,'(i8)') nx

  outfile = trim(outfile) // '.' // trim(adjustl(num))

  print *, 'writing HSE isentropic model to ', trim(outfile)

  open (unit=50, file=outfile, status="unknown")

  write (50,1001) "# npts = ", nx
  write (50,1001) "# num of variables = ", 3 + nspec
  write (50,1002) "# density"
  write (50,1002) "# temperature"
  write (50,1002) "# pressure"

  do n = 1, nspec
     write (50,1003) "# ", spec_names(n)
  enddo

  do i = 1, nx

     write (50,1000) xzn_hse(i), model_isentropic_hse(i,idens), model_isentropic_hse(i,itemp), model_isentropic_hse(i,ipres), &
          (model_isentropic_hse(i,ispec-1+n), n=1,nspec)

  enddo

  close (unit=50)

  ! compute the enclosed mass
  M_enclosed(1) = FOUR3RD*M_PI*delx**3*model_isentropic_hse(1,idens)

  do i = 2, nx
     M_enclosed(i) = M_enclosed(i-1) + &
          FOUR3RD*M_PI*(xznr(i) - xznl(i)) * &
          (xznr(i)**2 +xznl(i)*xznr(i) + xznl(i)**2)*model_isentropic_hse(i,idens)
  enddo

  print *, 'total mass = ', real(M_enclosed(nx)), ' g = ', real(M_enclosed(nx)/M_solar), ' solar masses'

  ! compute the maximum HSE error
  max_hse_error = -1.d30

  do i = 2, nx-1
     g_zone = -Gconst*M_enclosed(i-1)/xznr(i-1)**2
     dpdr = (model_isentropic_hse(i,ipres) - model_isentropic_hse(i-1,ipres))/delx
     rhog = HALF*(model_isentropic_hse(i,idens) + model_isentropic_hse(i-1,idens))*g_zone

     if (dpdr /= ZERO .and. model_isentropic_hse(i+1,idens) > low_density_cutoff) then
        max_hse_error = max(max_hse_error, abs(dpdr - rhog)/abs(dpdr))
     endif
  enddo

  print *, 'maximum HSE error = ', max_hse_error
  print *, ' '

  !---------------------------------------------------------------------------
  ! hybrid model
  !---------------------------------------------------------------------------

  ipos = index(model_file, '.raw')
  outfile = model_file(1:ipos-1) // '.hybrid.hse'

  write(num,'(i8)') nx

  outfile = trim(outfile) // '.' // trim(adjustl(num))

  print *, 'writing HSE hybrid model to ', trim(outfile)

  open (unit=50, file=outfile, status="unknown")

  write (50,1001) "# npts = ", nx
  write (50,1001) "# num of variables = ", 3 + nspec
  write (50,1002) "# density"
  write (50,1002) "# temperature"
  write (50,1002) "# pressure"

  do n = 1, nspec
     write (50,1003) "# ", spec_names(n)
  enddo

  do i = 1, nx

     write (50,1000) xzn_hse(i), model_hybrid_hse(i,idens), model_hybrid_hse(i,itemp), model_hybrid_hse(i,ipres), &
          (model_hybrid_hse(i,ispec-1+n), n=1,nspec)

  enddo

  close (unit=50)

  ! compute the enclosed mass
  M_enclosed(1) = FOUR3RD*M_PI*delx**3*model_hybrid_hse(1,idens)

  do i = 2, nx
     M_enclosed(i) = M_enclosed(i-1) + &
          FOUR3RD*M_PI*(xznr(i) - xznl(i)) * &
          (xznr(i)**2 +xznl(i)*xznr(i) + xznl(i)**2)*model_hybrid_hse(i,idens)
  enddo

  print *, 'total mass = ', real(M_enclosed(nx)), ' g = ', real(M_enclosed(nx)/M_solar), ' solar masses'
  print *, 'mass of convective region = ', real(M_enclosed(i_isentropic)), ' g = ', &
       real(M_enclosed(i_isentropic)/M_solar), ' solar masses'
  print *, 'radius of convective region = ', real(xzn_hse(i_isentropic)), ' cm'

  ! compute the maximum HSE error
  max_hse_error = -1.d30

  do i = 2, nx-1
     g_zone = -Gconst*M_enclosed(i-1)/xznr(i-1)**2
     dpdr = (model_hybrid_hse(i,ipres) - model_hybrid_hse(i-1,ipres))/delx
     rhog = HALF*(model_hybrid_hse(i,idens) + model_hybrid_hse(i-1,idens))*g_zone

     if (dpdr /= ZERO .and. model_hybrid_hse(i+1,idens) > low_density_cutoff) then
        max_hse_error = max(max_hse_error, abs(dpdr - rhog)/abs(dpdr))
     endif
  enddo

  print *, 'maximum HSE error = ', max_hse_error

  ! output the entropy

  outfile = model_file(1:ipos-1) // '.entropy'
  outfile = trim(outfile) // '.' // trim(adjustl(num))

  open (unit=60, file=outfile, status="unknown")

  do i = 1, nx
     write (60,1000) xzn_hse(i), model_kepler_hse(i,ientr)
  enddo

  close (unit=60)

  ! compute the mass enclosed inside the anelastic_cutoff
  M_enclosed_anel = FOUR3RD*M_PI*delx**3*model_hybrid_hse(1,idens)
  do i = 2, nx
     if (model_hybrid_hse(i,idens) >= anelastic_cutoff) then
        M_enclosed_anel = M_enclosed_anel + &
             FOUR3RD*M_PI*(xznr(i) - xznl(i)) * &
             (xznr(i)**2 +xznl(i)*xznr(i) + xznl(i)**2)*model_hybrid_hse(i,idens)
     else
        exit
     endif
  enddo

  print *, ' '
  print *, 'mass within anelastic_cutoff (', real(anelastic_cutoff), ') =', &
       real(M_enclosed_anel/M_solar), 'solar masses'

  ! compute the central sound speed
  print *, 'sound speed at center of star = ', model_hybrid_hse(1,isndspd)

  ! compute the gravitational potential energy
  M_center = FOUR3RD*M_PI*xzn_hse(1)**3*model_hybrid_hse(1,idens)

  ! dU = - G M dM / r;  dM = 4 pi r**2 rho dr  -->  dU = - 4 pi G r rho dr
  grav_ener = -FOUR*M_PI*Gconst*M_center*xzn_hse(1)*model_hybrid_hse(1,idens)*(xznr(1) - xznl(1))

  do i = 2, nx
     if (model_hybrid_hse(i,idens) >= anelastic_cutoff) then
        M_center = M_center + &
             FOUR3RD*M_PI*(xzn_hse(i) - xznl(i)) * &
             (xzn_hse(i)**2 +xznl(i)*xzn_hse(i) + xznl(i)**2)*model_hybrid_hse(i,idens) + &
             FOUR3RD*M_PI*(xznr(i-1) - xzn_hse(i-1)) * &
             (xznr(i-1)**2 +xzn_hse(i-1)*xznr(i-1) + xzn_hse(i-1)**2)*model_hybrid_hse(i-1,idens)

        ! dU = - G M dM / r;  dM = 4 pi r**2 rho dr  -->  dU = - 4 pi G r rho dr
        grav_ener = grav_ener - &
             FOUR*M_PI*Gconst*M_center*xzn_hse(i)*model_hybrid_hse(i,idens)*(xznr(i) - xznl(i))
     else
        exit
     endif
  enddo

  print *, "gravitational potential energy = ", grav_ener
  print *, "internal energy = ", eint_hybrid

end program init_1d

  function interpolate(r, npts, model_r, model_var)

    use bl_types

    implicit none

    ! given the array of model coordinates (model_r), and variable (model_var),
    ! find the value of model_var at point r using linear interpolation.
    ! Eventually, we can do something fancier here.

    real(kind=dp_t) :: interpolate
    real(kind=dp_t), intent(in) :: r
    integer :: npts
    real(kind=dp_t), dimension(npts) :: model_r, model_var

    real(kind=dp_t) :: slope
    real(kind=dp_t) :: minvar, maxvar

    integer :: i, id

    ! find the location in the coordinate array where we want to interpolate
    do i = 1, npts
       if (model_r(i) >= r) exit
    enddo

    id = i

    if (id == 1) then

       slope = (model_var(id+1) - model_var(id))/(model_r(id+1) - model_r(id))
       interpolate = slope*(r - model_r(id)) + model_var(id)

       ! safety check to make sure interpolate lies within the bounding points
       !minvar = min(model_var(id+1),model_var(id))
       !maxvar = max(model_var(id+1),model_var(id))
       !interpolate = max(interpolate,minvar)
       !interpolate = min(interpolate,maxvar)

    else

       slope = (model_var(id) - model_var(id-1))/(model_r(id) - model_r(id-1))
       interpolate = slope*(r - model_r(id)) + model_var(id)

       ! safety check to make sure interpolate lies within the bounding points
       minvar = min(model_var(id),model_var(id-1))
       maxvar = max(model_var(id),model_var(id-1))
       interpolate = max(interpolate,minvar)
       interpolate = min(interpolate,maxvar)

    endif

    return

  end function interpolate