      SUBROUTINE MB03KE( TRANA, TRANB, ISGN, K, M, N, PREC, SMIN, S, A,
     $                   B, C, SCALE, DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To solve small periodic Sylvester-like equations (PSLE)
C
C      op(A(i))*X( i ) + isgn*X(i+1)*op(B(i)) = -scale*C(i), S(i) =  1,
C      op(A(i))*X(i+1) + isgn*X( i )*op(B(i)) = -scale*C(i), S(i) = -1.
C
C     i = 1, ..., K, where op(A) means A or A**T, for the K-periodic
C     matrix sequence X(i) = X(i+K), where A, B and C are K-periodic
C     matrix sequences and A and B are in periodic real Schur form. The
C     matrices A(i) are M-by-M and B(i) are N-by-N, with 1 <= M, N <= 2.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     TRANA   LOGICAL
C             Specifies the form of op(A) to be used, as follows:
C             = .FALSE.:  op(A) = A,
C             = .TRUE. :  op(A) = A**T.
C
C     TRANB   LOGICAL
C             Specifies the form of op(B) to be used, as follows:
C             = .FALSE.:  op(B) = B,
C             = .TRUE. :  op(B) = B**T.
C
C     ISGN    INTEGER
C             Specifies which sign variant of the equations to solve.
C             ISGN = 1 or ISGN = -1.
C
C     Input/Output Parameters
C
C     K       (input) INTEGER
C             The period of the periodic matrix sequences A, B, C and X.
C             K >= 2. (For K = 1, a standard Sylvester equation is
C             obtained.)
C
C     M       (input) INTEGER
C             The order of the matrices A(i) and the number of rows of
C             the matrices C(i) and X(i), i = 1, ..., K.  1 <= M <= 2.
C
C     N       (input) INTEGER
C             The order of the matrices B(i) and the number of columns
C             of the matrices C(i) and X(i), i = 1, ..., K.
C             1 <= N <= 2.
C
C     PREC    (input) DOUBLE PRECISION
C             The relative machine precision. See the LAPACK Library
C             routine DLAMCH.
C
C     SMIN    (input) DOUBLE PRECISION
C             The machine safe minimum divided by PREC.
C
C     S       (input) INTEGER array, dimension (K)
C             The leading K elements of this array must contain the
C             signatures (exponents) of the factors in the K-periodic
C             matrix sequences for A and B. Each entry in S must be
C             either 1 or -1. Notice that it is assumed that the same
C             exponents are tied to both A and B on reduction to the
C             periodic Schur form.
C
C     A       (input) DOUBLE PRECISION array, dimension (M*M*K)
C             On entry, this array must contain the M-by-M matrices
C             A(i), for i = 1, ..., K, stored with the leading dimension
C             M. Matrix A(i) is stored starting at position M*M*(i-1)+1.
C
C     B       (input) DOUBLE PRECISION array, dimension (N*N*K)
C             On entry, this array must contain the N-by-N matrices
C             B(i), for i = 1, ..., K, stored with the leading dimension
C             N. Matrix B(i) is stored starting at position N*N*(i-1)+1.
C
C     C       (input/output) DOUBLE PRECISION array, dimension (M*N*K)
C             On entry, this array must contain the M-by-N matrices
C             C(i), for i = 1, ..., K, stored with the leading dimension
C             M. Matrix C(i) is stored starting at position M*N*(i-1)+1.
C             On exit, the matrices C(i) are overwritten by the solution
C             sequence X(i).
C
C     SCALE   (output) DOUBLE PRECISION
C             The scale factor, scale, set less than or equal to 1 to
C             avoid overflow in X.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) returns the optimal LDWORK.
C             On exit, if INFO = -21, DWORK(1) returns the minimum value
C             of LDWORK.
C
C     LDWORK  INTEGER
C             The dimension of the array DWORK.
C             LDWORK >= (4*K-3) * (M*N)**2 + K * M*N.
C
C             If LDWORK = -1  a workspace query is assumed; the
C             routine only calculates the optimal size of the DWORK
C             array, returns this value as the first entry of the DWORK
C             array, and no error message is issued by XERBLA.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -21, then LDWORK is too small; appropriate
C                   value for LDWORK is returned in DWORK(1); the other
C                   arguments are not tested, for efficiency;
C             = 1:  the solution would overflow with scale = 1, so
C                   SCALE was set less than 1. This is a warning, not
C                   an error.
C
C     METHOD
C
C     A version of the algorithm described in [1] is used. The routine
C     uses a sparse Kronecker product representation Z of the PSLE and
C     solves for X(i) from an associated linear system Z*x = c using
C     structured (overlapping) variants of QR factorization and backward
C     substitution.
C
C     REFERENCES
C
C     [1] Granat, R., Kagstrom, B. and Kressner, D.
C         Computing periodic deflating subspaces associated with a
C         specified set of eigenvalues.
C         BIT Numerical Mathematics, vol. 47, 763-791, 2007.
C
C     NUMERICAL ASPECTS
C
C     The implemented method is numerically backward stable.
C
C     CONTRIBUTOR
C
C     V. Sima, Research Institute for Informatics, Bucharest, Romania,
C     Mar. 2010, an essentially new version of the PEP routine
C     PEP_DGESY2, by R. Granat, Umea University, Sweden, Apr. 2008.
C
C     REVISIONS
C
C     V. Sima, Apr. 2010, Oct. 2010, Aug. 2011.
C
C     KEYWORDS
C
C     Orthogonal transformation, periodic QZ algorithm, periodic
C     Sylvester-like equations, QZ algorithm.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE, TWO
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 )
C     ..
C     .. Scalar Arguments ..
      LOGICAL            TRANA, TRANB
      INTEGER            INFO, ISGN, K, LDWORK, M, N
      DOUBLE PRECISION   PREC, SCALE, SMIN
C     ..
C     .. Array Arguments ..
      INTEGER            S( * )
      DOUBLE PRECISION   A( * ), B( * ), C( * ), DWORK( * )
C     ..
C     .. Local Scalars ..
      LOGICAL            DOSCAL, LQUERY
      INTEGER            CB, I, IA1, IA3, IB1, IB3, IC1, II, IM1, IXA,
     $                   IXB, IXC, IZ, J, KM2, KM3, KMN, L, LDW, LEN,
     $                   MINWRK, MM, MN, MN6, MN7, NN, ZC, ZD, ZI, ZI2,
     $                   ZIS
      DOUBLE PRECISION   AC, AD, BETA, BIGNUM, DMIN, ELEM, SCALOC, SGN,
     $                   SPIV, TAU, TEMP
C     ..
C     .. External Functions ..
      INTEGER            IDAMAX
C     ..
C     .. External Subroutines ..
      EXTERNAL           DAXPY, DSCAL, XERBLA
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC          ABS, DBLE, MAX, MIN, MOD
C     ..
C     .. Executable Statements ..
C
C     Decode the input parameters.
C     For efficiency reasons, the parameters are not checked.
C
      INFO   = 0
      LQUERY = LDWORK.EQ.-1
C
      MN  = M*N
      KMN = K*MN
C
      MINWRK = ( 4*K - 3 ) * MN**2 + KMN
      IF( .NOT. LQUERY .AND. LDWORK.LT.MINWRK )
     $   INFO = -21
C
C     Quick return if possible.
C
      DWORK( 1 ) = DBLE( MINWRK )
      IF( LQUERY ) THEN
         RETURN
      ELSE IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'MB03KE', -INFO )
         RETURN
      END IF
C
C     Find the overflow threshold.
C
      BIGNUM = PREC / SMIN
C
C     --- Use QR-factorizations and backward substitution ---
C
C     This variant does not utilize the sparsity structure of the
C     individual blocks of the matrix Z - storage of each block Z_i,i
C     is compatible with the BLAS. Numerics is stable since excessive
C     pivot growth is avoided.
C
      MM  = M*M
      NN  = N*N
      SGN = DBLE( ISGN )
      LDW = 3*MN
      IF( M.EQ.2 .AND. N.EQ.2 ) THEN
         MN6 = LDW + LDW
         MN7 = MN6 + LDW
         KM2 = KMN + KMN
         KM3 = KM2 + KMN
      END IF
C
C     Divide workspace for superdiagonal + diagonal + subdiagonal blocks
C     and right-most block column stored in a "block-packed" format. For
C     simplicity, an additional block Z_{0,1} appears in the first block
C     column in Z.
C
      ZD = 1
      ZC = ZD + LDW*MN*( K - 1 )
C
C     Also give workspace for right hand side in CB.
C
      CB = ZC + MN*KMN
C
C     Fill the Z part of the workspace with zeros.
C
      DO 10 J = 1, CB - 1
         DWORK( J ) = ZERO
   10 CONTINUE
C
C     Build matrix Z in ZD and ZC.
C
      IXA = 1
      IXB = 1
      IXC = 1
      IM1 = K
      ZI  = ZD + MN
C
      DO 20 I = 1, K - 1
C
C        Build Z_{i,i}, i = 1,...,K-1.
C
         IF( S( IM1 ).EQ.-1 ) THEN
C
            IA1 = ( IM1 - 1 )*MM + 1
            DWORK( ZI ) = A( IA1 )
            IF( M.EQ.2 ) THEN
               IA3 = IA1 + 2
               IF( .NOT. TRANA ) THEN
                  DWORK( ZI + 1   )  = A( IA1 + 1 )
                  DWORK( ZI + LDW )  = A( IA3     )
               ELSE
                  DWORK( ZI + 1   )  = A( IA3     )
                  DWORK( ZI + LDW )  = A( IA1 + 1 )
               END IF
               DWORK( ZI + LDW + 1 ) = A( IA3 + 1 )
            END IF
            IF( N.EQ.2 ) THEN
               ZI2 = ZI + ( LDW + 1 )*M
               DWORK( ZI2 ) = DWORK( ZI )
               IF( M.EQ.2 ) THEN
                  DWORK( ZI2 + 1 )       = DWORK( ZI + 1 )
                  DWORK( ZI2 + LDW     ) = DWORK( ZI + LDW     )
                  DWORK( ZI2 + LDW + 1 ) = DWORK( ZI + LDW + 1 )
               END IF
            END IF
C
         ELSE
C
            IB1 = ( IM1 - 1 )*NN + 1
            DWORK( ZI ) = SGN*B( IB1 )
            IF( .NOT. TRANB ) THEN
               IF( M.EQ.2 ) THEN
                  DWORK( ZI + LDW + 1 ) = DWORK( ZI )
                  IF( N.EQ.2 ) THEN
                     IB3 = IB1 + 2
                     DWORK( ZI + 2 )       = SGN*B( IB3 )
                     DWORK( ZI + LDW + 3 ) = DWORK( ZI  + 2 )
                     DWORK( ZI + MN6     ) = SGN*B( IB1 + 1 )
                     DWORK( ZI + MN6 + 2 ) = SGN*B( IB3 + 1 )
                     DWORK( ZI + MN7 + 1 ) = DWORK( ZI  + MN6 )
                     DWORK( ZI + MN7 + 3 ) = DWORK( ZI  + MN6 + 2 )
                  END IF
               ELSE IF( N.EQ.2 ) THEN
                  IB3 = IB1 + 2
                  DWORK( ZI + 1 )       = SGN*B( IB3 )
                  DWORK( ZI + LDW     ) = SGN*B( IB1 + 1 )
                  DWORK( ZI + LDW + 1 ) = SGN*B( IB3 + 1 )
               END IF
            ELSE
               IF( M.EQ.2 ) THEN
                  DWORK( ZI + LDW + 1 ) = DWORK( ZI )
                  IF( N.EQ.2 ) THEN
                     IB3 = IB1 + 2
                     DWORK( ZI + 2 )       = SGN*B( IB1 + 1 )
                     DWORK( ZI + LDW + 3 ) = DWORK( ZI  + 2 )
                     DWORK( ZI + MN6     ) = SGN*B( IB3     )
                     DWORK( ZI + MN6 + 2 ) = SGN*B( IB3 + 1 )
                     DWORK( ZI + MN7 + 1 ) = DWORK( ZI  + MN6 )
                     DWORK( ZI + MN7 + 3 ) = DWORK( ZI  + MN6 + 2 )
                  END IF
               ELSE IF( N.EQ.2 ) THEN
                  IB3 = IB1 + 2
                  DWORK( ZI + 1 )       = SGN*B( IB1 + 1 )
                  DWORK( ZI + LDW     ) = SGN*B( IB3     )
                  DWORK( ZI + LDW + 1 ) = SGN*B( IB3 + 1 )
               END IF
            END IF
C
         END IF
C
C        Build Z_{i+1,i}, i = 1,...,K-1.
C
         ZI = ZI + MN
         IF( S( I ).EQ.1 ) THEN
C
            IA1 = IXA
            DWORK( ZI ) = A( IA1 )
            IF( M.EQ.2 ) THEN
               IA3 = IA1 + 2
               IF( .NOT. TRANA ) THEN
                  DWORK( ZI + 1   )  = A( IA1 + 1 )
                  DWORK( ZI + LDW )  = A( IA3     )
               ELSE
                  DWORK( ZI + 1   )  = A( IA3     )
                  DWORK( ZI + LDW )  = A( IA1 + 1 )
               END IF
               DWORK( ZI + LDW + 1 ) = A( IA3 + 1 )
            END IF
            IF( N.EQ.2 ) THEN
               ZI2 = ZI + ( LDW + 1 )*M
               DWORK( ZI2 ) = DWORK( ZI )
               IF( M.EQ.2 ) THEN
                  DWORK( ZI2 + 1 )       = DWORK( ZI + 1 )
                  DWORK( ZI2 + LDW     ) = DWORK( ZI + LDW     )
                  DWORK( ZI2 + LDW + 1 ) = DWORK( ZI + LDW + 1 )
               END IF
            END IF
C
         ELSE
C
            IB1 = IXB
            DWORK( ZI ) = SGN*B( IB1 )
            IF( .NOT. TRANB ) THEN
               IF( M.EQ.2 ) THEN
                  DWORK( ZI + LDW + 1 ) = DWORK( ZI )
                  IF( N.EQ.2 ) THEN
                     IB3 = IB1 + 2
                     DWORK( ZI + 2 )       = SGN*B( IB3 )
                     DWORK( ZI + LDW + 3 ) = DWORK( ZI  + 2 )
                     DWORK( ZI + MN6     ) = SGN*B( IB1 + 1 )
                     DWORK( ZI + MN6 + 2 ) = SGN*B( IB3 + 1 )
                     DWORK( ZI + MN7 + 1 ) = DWORK( ZI  + MN6     )
                     DWORK( ZI + MN7 + 3 ) = DWORK( ZI  + MN6 + 2 )
                  END IF
               ELSE IF( N.EQ.2 ) THEN
                  IB3 = IB1 + 2
                  DWORK( ZI + 1 )       = SGN*B( IB3 )
                  DWORK( ZI + LDW     ) = SGN*B( IB1 + 1 )
                  DWORK( ZI + LDW + 1 ) = SGN*B( IB3 + 1 )
               END IF
            ELSE
               IF( M.EQ.2 ) THEN
                  DWORK( ZI + LDW + 1 ) = DWORK( ZI )
                  IF( N.EQ.2 ) THEN
                     IB3 = IB1 + 2
                     DWORK( ZI + 2 )       = SGN*B( IB1 + 1 )
                     DWORK( ZI + LDW + 3 ) = DWORK( ZI  + 2 )
                     DWORK( ZI + MN6     ) = SGN*B( IB3     )
                     DWORK( ZI + MN6 + 2 ) = SGN*B( IB3 + 1 )
                     DWORK( ZI + MN7 + 1 ) = DWORK( ZI  + MN6     )
                     DWORK( ZI + MN7 + 3 ) = DWORK( ZI  + MN6 + 2 )
                  END IF
               ELSE IF( N.EQ.2 ) THEN
                  IB3 = IB1 + 2
                  DWORK( ZI + 1 )       = SGN*B( IB1 + 1 )
                  DWORK( ZI + LDW     ) = SGN*B( IB3     )
                  DWORK( ZI + LDW + 1 ) = SGN*B( IB3 + 1 )
               END IF
            END IF
         END IF
C
         IXA = IXA + MM
         IXB = IXB + NN
         IM1 = I
         ZI  = ZI + MN*( LDW - 1 )
   20 CONTINUE
C
C     Build Z_{K,K}.
C
      IXA = IXA - MM
      IXB = IXB - NN
      ZI  = ZC + KMN - MN
      IF( S( K - 1 ).EQ.-1 ) THEN
C
         IA1 = IXA
         DWORK( ZI ) = A( IA1 )
         IF( M.EQ.2 ) THEN
            IA3 = IA1 + 2
            IF( .NOT. TRANA ) THEN
               DWORK( ZI + 1   )  = A( IA1 + 1 )
               DWORK( ZI + KMN )  = A( IA3     )
            ELSE
               DWORK( ZI + 1   )  = A( IA3     )
               DWORK( ZI + KMN )  = A( IA1 + 1 )
            END IF
            DWORK( ZI + KMN + 1 ) = A( IA3 + 1 )
         END IF
         IF( N.EQ.2 ) THEN
            ZI2 = ZI + ( KMN + 1 )*M
            DWORK( ZI2 ) = DWORK( ZI )
            IF( M.EQ.2 ) THEN
               DWORK( ZI2 + 1 )       = DWORK( ZI + 1 )
               DWORK( ZI2 + KMN     ) = DWORK( ZI + KMN     )
               DWORK( ZI2 + KMN + 1 ) = DWORK( ZI + KMN + 1 )
            END IF
         END IF
C
      ELSE
C
         IB1 = IXB
         DWORK( ZI ) = SGN*B( IB1 )
         IF( .NOT. TRANB ) THEN
            IF( M.EQ.2 ) THEN
               DWORK( ZI + KMN + 1 ) = DWORK( ZI )
               IF( N.EQ.2 ) THEN
                  IB3 = IB1 + 2
                  DWORK( ZI + 2 )       = SGN*B( IB3 )
                  DWORK( ZI + KMN + 3 ) = DWORK( ZI  + 2 )
                  DWORK( ZI + KM2     ) = SGN*B( IB1 + 1 )
                  DWORK( ZI + KM2 + 2 ) = SGN*B( IB3 + 1 )
                  DWORK( ZI + KM3 + 1 ) = DWORK( ZI  + KM2     )
                  DWORK( ZI + KM3 + 3 ) = DWORK( ZI  + KM2 + 2 )
               END IF
            ELSE IF( N.EQ.2 ) THEN
               IB3 = IB1 + 2
               DWORK( ZI + 1 )       = SGN*B( IB3 )
               DWORK( ZI + KMN     ) = SGN*B( IB1 + 1 )
               DWORK( ZI + KMN + 1 ) = SGN*B( IB3 + 1 )
            END IF
         ELSE
            IF( M.EQ.2 ) THEN
               DWORK( ZI + KMN + 1 ) = DWORK( ZI )
               IF( N.EQ.2 ) THEN
                  IB3 = IB1 + 2
                  DWORK( ZI + 2 )       = SGN*B( IB1 + 1 )
                  DWORK( ZI + KMN + 3 ) = DWORK( ZI  + 2 )
                  DWORK( ZI + KM2     ) = SGN*B( IB3     )
                  DWORK( ZI + KM2 + 2 ) = SGN*B( IB3 + 1 )
                  DWORK( ZI + KM3 + 1 ) = DWORK( ZI  + KM2     )
                  DWORK( ZI + KM3 + 3 ) = DWORK( ZI  + KM2 + 2 )
               END IF
            ELSE IF( N.EQ.2 ) THEN
               IB3 = IB1 + 2
               DWORK( ZI + 1 )       = SGN*B( IB1 + 1 )
               DWORK( ZI + KMN     ) = SGN*B( IB3     )
               DWORK( ZI + KMN + 1 ) = SGN*B( IB3 + 1 )
            END IF
         END IF
      END IF
C
C     Build Z_{1,K}.
C
      IF( S( K ).EQ.1 ) THEN
C
         IA1 = IA1 + MM
         DWORK( ZC ) = A( IA1 )
         IF( M.EQ.2 ) THEN
            IA3 = IA1 + 2
            IF( .NOT. TRANA ) THEN
               DWORK( ZC + 1   )  = A( IA1 + 1 )
               DWORK( ZC + KMN )  = A( IA3     )
            ELSE
               DWORK( ZC + 1   )  = A( IA3     )
               DWORK( ZC + KMN )  = A( IA1 + 1 )
            END IF
            DWORK( ZC + KMN + 1 ) = A( IA3 + 1 )
         END IF
         IF( N.EQ.2 ) THEN
            ZI2 = ZC + ( KMN + 1 )*M
            DWORK( ZI2 ) = DWORK( ZC )
            IF( M.EQ.2 ) THEN
               DWORK( ZI2 + 1 )       = DWORK( ZC + 1 )
               DWORK( ZI2 + KMN     ) = DWORK( ZC + KMN     )
               DWORK( ZI2 + KMN + 1 ) = DWORK( ZC + KMN + 1 )
            END IF
         END IF
C
      ELSE
C
         IB1 = IB1 + NN
         DWORK( ZC ) = SGN*B( IB1 )
         IF( .NOT. TRANB ) THEN
            IF( M.EQ.2 ) THEN
               DWORK( ZC + KMN + 1 ) = DWORK( ZC )
               IF( N.EQ.2 ) THEN
                  IB3 = IB1 + 2
                  DWORK( ZC + 2 )       = SGN*B( IB3 )
                  DWORK( ZC + KMN + 3 ) = DWORK( ZC  + 2 )
                  DWORK( ZC + KM2     ) = SGN*B( IB1 + 1 )
                  DWORK( ZC + KM2 + 2 ) = SGN*B( IB3 + 1 )
                  DWORK( ZC + KM3 + 1 ) = DWORK( ZC  + KM2     )
                  DWORK( ZC + KM3 + 3 ) = DWORK( ZC  + KM2 + 2 )
               END IF
            ELSE IF( N.EQ.2 ) THEN
               IB3 = IB1 + 2
               DWORK( ZC + 1 )       = SGN*B( IB3 )
               DWORK( ZC + KMN     ) = SGN*B( IB1 + 1 )
               DWORK( ZC + KMN + 1 ) = SGN*B( IB3 + 1 )
            END IF
         ELSE
            IF( M.EQ.2 ) THEN
               DWORK( ZC + KMN + 1 ) = DWORK( ZC )
               IF( N.EQ.2 ) THEN
                  IB3 = IB1 + 2
                  DWORK( ZC + 2 )       = SGN*B( IB1 + 1 )
                  DWORK( ZC + KMN + 3 ) = DWORK( ZC  + 2 )
                  DWORK( ZC + KM2     ) = SGN*B( IB3     )
                  DWORK( ZC + KM2 + 2 ) = SGN*B( IB3 + 1 )
                  DWORK( ZC + KM3 + 1 ) = DWORK( ZC  + KM2     )
                  DWORK( ZC + KM3 + 3 ) = DWORK( ZC  + KM2 + 2 )
               END IF
            ELSE IF( N.EQ.2 ) THEN
               IB3 = IB1 + 2
               DWORK( ZC + 1 )       = SGN*B( IB1 + 1 )
               DWORK( ZC + KMN     ) = SGN*B( IB3     )
               DWORK( ZC + KMN + 1 ) = SGN*B( IB3 + 1 )
            END IF
         END IF
      END IF
C
C     Prepare right hand side in CB.
C
      ZI = CB + MN
      DO 30 L = 1, K - 1
         IC1 = IXC
         DWORK( ZI ) = -C( IC1 )
         IF( M.EQ.1 ) THEN
            IF( N.EQ.2 )
     $         DWORK( ZI + 1 ) = -C( IC1 + 1 )
         ELSE
            DWORK( ZI + 1 )    = -C( IC1 + 1 )
            IF( N.EQ.2 ) THEN
               DWORK( ZI + 2 ) = -C( IC1 + 2 )
               DWORK( ZI + 3 ) = -C( IC1 + 3 )
            END IF
         END IF
         IXC = IXC + MN
         ZI  = ZI  + MN
   30 CONTINUE
C
      ZI  = CB
      IC1 = IXC
      DWORK( ZI ) = -C( IC1 )
      IF( M.EQ.1 ) THEN
         IF( N.EQ.2 )
     $      DWORK( ZI + 1 ) = -C( IC1 + 1 )
      ELSE
         DWORK( ZI + 1 )    = -C( IC1 + 1 )
         IF( N.EQ.2 ) THEN
            DWORK( ZI + 2 ) = -C( IC1 + 2 )
            DWORK( ZI + 3 ) = -C( IC1 + 3 )
         END IF
      END IF
C
C     Solve the Kronecker product system for X_i, i = 1,...,K
C     using overlapping (structured) QR-factorization and
C     backward substitution.
C
C     Step 1: Reduce the system to triangular form via overlapping
C             QR-factorizations.
C
C             The method here is based on successively formed
C             Householder reflections which are applied one by one
C             to the matrix Z and the right hand side c. The size
C             of each reflection is chosen as the number of elements
C             in each column from the last non-zero element up to
C             the diagonal.
C
C             Notation:
C             L   = current position of the column to work with;
C             I   = corresponding block column in Z;
C             II  = corresponding row and column position in Z-block;
C             LEN = length of the current Householder reflection.
C
      I   = 1
      II  = 0
      ZIS = ZD + MN
      ZI2 = ZD + MN*LDW
C
C     Treat Z_{K,K} separately from [Z_{i,i}',Z_{i+1,i}']' (see below).
C     DMIN is the minimum modulus of the final diagonal values.
C
      DMIN = BIGNUM
C
      DO 50 L = 1, KMN - MN
         II  = II   + 1
         ZI  = ZIS  + 2*MN
         LEN = 2*MN - II + 1
C
C        REPEAT
   40    CONTINUE
         ZI = ZI - 1
         ELEM = DWORK( ZI )
         IF( ELEM.EQ.ZERO ) THEN
            LEN = LEN - 1
            GO TO 40
         END IF
C        UNTIL ELEM.NE.ZERO.
C
         IF( LEN.GT.1 ) THEN
C
C           Generate Householder reflection to zero out the current
C           column. The new main diagonal value is stored temporarily
C           in BETA.
C
            ZI = ZI - LEN + 1
            CALL DLARFG( LEN, DWORK( ZI ), DWORK( ZI + 1 ), 1, TAU )
            BETA = DWORK( ZI )
            DWORK( ZI ) = ONE
C
C           Apply reflection to Z and c: first to the rest of the
C           corresponding rows and columns of [Z_{i,i}',Z_{i+1,i}']'
C           of size LEN-by-(MN-II) ...
C
            CALL DLARFX( 'Left', LEN, MN - II, DWORK( ZI ), TAU,
     $                   DWORK( ZI + LDW ), LDW, DWORK )
C
C           ... then to the corresponding part of
C           [Z_{i,i+1}',Z_{i+1,i+1}']' of size LEN-by-MN ...
C
            IF( I.LT.K - 1 )
     $         CALL DLARFX( 'Left', LEN, MN, DWORK( ZI ), TAU,
     $                      DWORK( ZI2 ), LDW, DWORK )
C
C           ... next to the corresponding part of
C           [Z_{i,K}',Z_{i+1,K}']' of size LEN-by-MN ...
C
            CALL DLARFX( 'Left', LEN, MN, DWORK( ZI ), TAU,
     $                   DWORK( ZC + L - 1 ), KMN, DWORK )
C
C           ... and finally to c(L:L+LEN-1).
C
            CALL DLARFX( 'Left', LEN, 1, DWORK( ZI ), TAU,
     $                   DWORK( CB + L - 1 ), KMN, DWORK )
C
C           Store the new diagonal value.
C
            DWORK( ZI ) = BETA
            DMIN = MIN( DMIN, ABS( BETA ) )
         END IF
C
         ZIS = ZIS + LDW
         ZI2 = ZI2 + 1
         IF( MOD( L, MN ).EQ.0 ) THEN
            I   =  I + 1
            II  =  0
            ZI2 = ZD + I*MN*LDW
         END IF
   50 CONTINUE
C
      II = 0
      ZI = ZC + KMN - MN
C
C     Z_{K,K} is treated separately.
C
      DO 60 L = KMN - MN + 1, KMN
         II  = II + 1
         LEN = MN - II + 1
         IF( LEN.GT.1 ) THEN
C
C           Generate Householder reflection.
C
            CALL DLARFG( LEN, DWORK( ZI ), DWORK( ZI + 1 ), 1, TAU )
            BETA = DWORK( ZI )
            DWORK( ZI ) = ONE
C
C           Apply reflection to Z and c: first to Z_{i,i} ...
C
            CALL DLARFX( 'Left', LEN, MN - II, DWORK( ZI ), TAU,
     $                   DWORK( ZI + KMN ), KMN, DWORK )
C
C           ... and finally to c(L:L+LEN-1).
C
            CALL DLARFX( 'Left', LEN, 1, DWORK( ZI ), TAU,
     $                   DWORK( CB + L - 1 ), KMN, DWORK )
C
C           Store the new diagonal value.
C
            DWORK( ZI ) = BETA
            DMIN = MIN( DMIN, ABS( BETA ) )
         END IF
         ZI = ZI + KMN + 1
C
   60 CONTINUE
C
C     Step 2: Use backward substitution on the computed triangular
C             system.
C
C             Here, we take the possible irregularities above the
C             diagonal of the resulting R-factor into account by
C             checking the number of elements from the main diagonal
C             to the last non-zero element above the diagonal that
C             resides in the current column.
C             Pivots less than SPIV = MAX( PREC*DMIN, SMIN ) are set
C             to SPIV.
C
      SCALE  = ONE
      DOSCAL = .FALSE.
      DMIN   = MAX( DMIN, SMIN )
      SPIV   = MAX( PREC*DMIN, SMIN )
C
C     Check for scaling.
C
      I  = IDAMAX( KMN, DWORK( CB ), 1 )
      AC = ABS( DWORK( CB + I - 1 ) )
      IF( TWO*SMIN*AC.GT.DMIN ) THEN
         TEMP = ( ONE / TWO ) / AC
         CALL DSCAL( KMN, TEMP, DWORK( CB ), 1 )
         SCALE = SCALE*TEMP
      END IF
C
      ZI = CB - 1
C
      DO 70 I = KMN, KMN - MN + 1, -1
C
         AD = ABS( DWORK( ZI ) )
         AC = ABS( DWORK( CB + I - 1 ) )
         IF( AD.LT.SPIV ) THEN
            AD = SPIV
            DWORK( ZI ) = SPIV
         END IF
         SCALOC = ONE
         IF( AD.LT.ONE .AND. AC.GT.ONE ) THEN
            IF( AC.GT.BIGNUM*AD ) THEN
               INFO   = 1
               SCALOC = BIGNUM*AD / AC
               DOSCAL = .TRUE.
               SCALE  = SCALE * SCALOC
            END IF
         END IF
         TEMP = ( DWORK( CB + I - 1 ) * SCALOC ) / DWORK( ZI )
         IF( DOSCAL ) THEN
            DOSCAL = .FALSE.
            CALL DSCAL( KMN, SCALOC, DWORK( CB ), 1 )
         END IF
         DWORK( CB + I - 1 ) = TEMP
C
         CALL DAXPY( I - 1, -TEMP, DWORK( ZI - I + 1 ), 1, DWORK( CB ),
     $               1 )
C
         ZI = ZI - KMN - 1
   70 CONTINUE
C
      ZIS = ZC - LDW
      ZI  = ZIS + 2*MN - 1
      IZ  = 0
C
      DO 90 I = KMN - MN, 1, -1
         AD = ABS( DWORK( ZI ) )
         AC = ABS( DWORK( CB + I - 1 ) )
         IF( AD.LT.SPIV ) THEN
            AD = SPIV
            DWORK( ZI ) = SPIV
         END IF
         SCALOC = ONE
         IF( AD.LT.ONE .AND. AC.GT.ONE ) THEN
            IF( AC.GT.BIGNUM*AD ) THEN
               INFO   = 1
               SCALOC = BIGNUM*AD / AC
               DOSCAL = .TRUE.
               SCALE  = SCALE * SCALOC
            END IF
         END IF
         TEMP = ( DWORK( CB + I - 1 ) * SCALOC ) / DWORK( ZI )
         IF( DOSCAL ) THEN
            DOSCAL = .FALSE.
            CALL DSCAL( KMN, SCALOC, DWORK( CB ), 1 )
         END IF
         DWORK( CB + I - 1 ) = TEMP
         LEN = MN + MOD( I - 1, MN ) + 1
         ZI2 = ZIS
   80    CONTINUE
         IF( DWORK( ZI2 ).EQ.ZERO ) THEN
            LEN = LEN - 1
            ZI2 = ZI2 + 1
            GO TO 80
         END IF
C
         J = MAX( 1, I - LEN + 1 )
         CALL DAXPY( I - J, -TEMP, DWORK( ZI - I + J ), 1,
     $               DWORK( CB + J - 1 ), 1 )
C
         IF( MN.GT.1 ) THEN
            IF( MOD( I, MN ).EQ.1 ) THEN
               IZ = 1 - MN
            ELSE
               IZ = 1
            END IF
         END IF
         ZI  = ZI  - LDW - IZ
         ZIS = ZIS - LDW
   90 CONTINUE
C
C     Reshape the solution into C.
C
      IC1 = 1
      ZI  = CB
C
      DO 100 L = 1, K
         C( IC1 ) = DWORK( ZI )
         IF( M.EQ.1 ) THEN
            IF( N.EQ.2 )
     $         C( IC1 + 1 ) = DWORK( ZI + 1 )
         ELSE
            C( IC1 + 1 ) = DWORK( ZI + 1 )
            IF( N.EQ.2 ) THEN
               C( IC1 + 2 ) = DWORK( ZI + 2 )
               C( IC1 + 3 ) = DWORK( ZI + 3 )
            END IF
         END IF
         IC1 = IC1 + MN
         ZI  = ZI  + MN
  100 CONTINUE
C
C     Store the minimal workspace on output.
C
      DWORK( 1 ) = DBLE( MINWRK )
      RETURN
C
C *** Last line of MB03KE ***
      END


!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998-2015 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine shape20h(xi,et,ze,xl,xsj,shp,iflag)
!
!     shape functions and derivatives for a 20-node quadratic
!     isoparametric brick element. -1<=xi,et,ze<=1
!
!     iflag=1: calculate only the value of the shape functions
!     iflag=2: calculate the value of the shape functions and
!              the Jacobian determinant
!     iflag=3: calculate the value of the shape functions, the
!              value of their derivatives w.r.t. the global
!              coordinates and the Jacobian determinant
!
      implicit none
!
      integer i,j,k,iflag
!
      real*8 shp(4,20),xs(3,3),xsi(3,3),xl(3,20),shpe(4,20),dd,
     &  dd1,dd2,dd3
!
      real*8 xi,et,ze,xsj,omg,omh,omr,opg,oph,opr,
     &  tpgphpr,tmgphpr,tmgmhpr,tpgmhpr,tpgphmr,tmgphmr,tmgmhmr,tpgmhmr,
     &  omgopg,omhoph,omropr,omgmopg,omhmoph,omrmopr
!
      intent(in) xi,et,ze,xl,iflag
!
      intent(out) shp,xsj
!
!     shape functions and their glocal derivatives
!
      omg=1.d0-xi
      omh=1.d0-et
      omr=1.d0-ze
      opg=1.d0+xi
      oph=1.d0+et
      opr=1.d0+ze
      tpgphpr=opg+oph+ze
      tmgphpr=omg+oph+ze
      tmgmhpr=omg+omh+ze
      tpgmhpr=opg+omh+ze
      tpgphmr=opg+oph-ze
      tmgphmr=omg+oph-ze
      tmgmhmr=omg+omh-ze
      tpgmhmr=opg+omh-ze
      omgopg=omg*opg/4.d0
      omhoph=omh*oph/4.d0
      omropr=omr*opr/4.d0
      omgmopg=(omg-opg)/4.d0
      omhmoph=(omh-oph)/4.d0
      omrmopr=(omr-opr)/4.d0
!
!     shape functions
!
      shp(4, 1)=-omg*omh*omr*tpgphpr/8.d0
      shp(4, 2)=-opg*omh*omr*tmgphpr/8.d0
      shp(4, 3)=-opg*oph*omr*tmgmhpr/8.d0
      shp(4, 4)=-omg*oph*omr*tpgmhpr/8.d0
      shp(4, 5)=-omg*omh*opr*tpgphmr/8.d0
      shp(4, 6)=-opg*omh*opr*tmgphmr/8.d0
      shp(4, 7)=-opg*oph*opr*tmgmhmr/8.d0
      shp(4, 8)=-omg*oph*opr*tpgmhmr/8.d0
      shp(4, 9)=omgopg*omh*omr
      shp(4,10)=omhoph*opg*omr
      shp(4,11)=omgopg*oph*omr
      shp(4,12)=omhoph*omg*omr
      shp(4,13)=omgopg*omh*opr
      shp(4,14)=omhoph*opg*opr
      shp(4,15)=omgopg*oph*opr
      shp(4,16)=omhoph*omg*opr
      shp(4,17)=omropr*omg*omh
      shp(4,18)=omropr*opg*omh
      shp(4,19)=omropr*opg*oph
      shp(4,20)=omropr*omg*oph
!
      if(iflag.eq.1) return
!
!     local derivatives of the shape functions: xi-derivative
!
      shpe(1, 1)=omh*omr*(tpgphpr-omg)/8.d0
      shpe(1, 2)=(opg-tmgphpr)*omh*omr/8.d0
      shpe(1, 3)=(opg-tmgmhpr)*oph*omr/8.d0
      shpe(1, 4)=oph*omr*(tpgmhpr-omg)/8.d0
      shpe(1, 5)=omh*opr*(tpgphmr-omg)/8.d0
      shpe(1, 6)=(opg-tmgphmr)*omh*opr/8.d0
      shpe(1, 7)=(opg-tmgmhmr)*oph*opr/8.d0
      shpe(1, 8)=oph*opr*(tpgmhmr-omg)/8.d0
      shpe(1, 9)=omgmopg*omh*omr
      shpe(1,10)=omhoph*omr
      shpe(1,11)=omgmopg*oph*omr
      shpe(1,12)=-omhoph*omr
      shpe(1,13)=omgmopg*omh*opr
      shpe(1,14)=omhoph*opr
      shpe(1,15)=omgmopg*oph*opr
      shpe(1,16)=-omhoph*opr
      shpe(1,17)=-omropr*omh
      shpe(1,18)=omropr*omh
      shpe(1,19)=omropr*oph
      shpe(1,20)=-omropr*oph
!
!     local derivatives of the shape functions: eta-derivative
!
      shpe(2, 1)=omg*omr*(tpgphpr-omh)/8.d0
      shpe(2, 2)=opg*omr*(tmgphpr-omh)/8.d0
      shpe(2, 3)=opg*(oph-tmgmhpr)*omr/8.d0
      shpe(2, 4)=omg*(oph-tpgmhpr)*omr/8.d0
      shpe(2, 5)=omg*opr*(tpgphmr-omh)/8.d0
      shpe(2, 6)=opg*opr*(tmgphmr-omh)/8.d0
      shpe(2, 7)=opg*(oph-tmgmhmr)*opr/8.d0
      shpe(2, 8)=omg*(oph-tpgmhmr)*opr/8.d0
      shpe(2, 9)=-omgopg*omr
      shpe(2,10)=omhmoph*opg*omr
      shpe(2,11)=omgopg*omr
      shpe(2,12)=omhmoph*omg*omr
      shpe(2,13)=-omgopg*opr
      shpe(2,14)=omhmoph*opg*opr
      shpe(2,15)=omgopg*opr
      shpe(2,16)=omhmoph*omg*opr
      shpe(2,17)=-omropr*omg
      shpe(2,18)=-omropr*opg
      shpe(2,19)=omropr*opg
      shpe(2,20)=omropr*omg
!
!     local derivatives of the shape functions: zeta-derivative
!
      shpe(3, 1)=omg*omh*(tpgphpr-omr)/8.d0
      shpe(3, 2)=opg*omh*(tmgphpr-omr)/8.d0
      shpe(3, 3)=opg*oph*(tmgmhpr-omr)/8.d0
      shpe(3, 4)=omg*oph*(tpgmhpr-omr)/8.d0
      shpe(3, 5)=omg*omh*(opr-tpgphmr)/8.d0
      shpe(3, 6)=opg*omh*(opr-tmgphmr)/8.d0
      shpe(3, 7)=opg*oph*(opr-tmgmhmr)/8.d0
      shpe(3, 8)=omg*oph*(opr-tpgmhmr)/8.d0
      shpe(3, 9)=-omgopg*omh
      shpe(3,10)=-omhoph*opg
      shpe(3,11)=-omgopg*oph
      shpe(3,12)=-omhoph*omg
      shpe(3,13)=omgopg*omh
      shpe(3,14)=omhoph*opg
      shpe(3,15)=omgopg*oph
      shpe(3,16)=omhoph*omg
      shpe(3,17)=omrmopr*omg*omh
      shpe(3,18)=omrmopr*opg*omh
      shpe(3,19)=omrmopr*opg*oph
      shpe(3,20)=omrmopr*omg*oph
!
!     computation of the local derivative of the global coordinates
!     (xs)
!
      do i=1,3
        do j=1,3
          xs(i,j)=0.d0
          do k=1,20
            xs(i,j)=xs(i,j)+xl(i,k)*shpe(j,k)
          enddo
        enddo
      enddo
!
!     computation of the jacobian determinant
!
      dd1=xs(2,2)*xs(3,3)-xs(2,3)*xs(3,2)
      dd2=xs(2,3)*xs(3,1)-xs(2,1)*xs(3,3)
      dd3=xs(2,1)*xs(3,2)-xs(2,2)*xs(3,1)
      xsj=xs(1,1)*dd1+xs(1,2)*dd2+xs(1,3)*dd3
!
      if(iflag.eq.2) return
!
      dd=1.d0/xsj
!
!     computation of the global derivative of the local coordinates
!     (xsi) (inversion of xs)
!
      xsi(1,1)=dd1*dd
      xsi(1,2)=(xs(1,3)*xs(3,2)-xs(1,2)*xs(3,3))*dd
      xsi(1,3)=(xs(1,2)*xs(2,3)-xs(2,2)*xs(1,3))*dd
      xsi(2,1)=dd2*dd
      xsi(2,2)=(xs(1,1)*xs(3,3)-xs(3,1)*xs(1,3))*dd
      xsi(2,3)=(xs(1,3)*xs(2,1)-xs(1,1)*xs(2,3))*dd
      xsi(3,1)=dd3*dd
      xsi(3,2)=(xs(1,2)*xs(3,1)-xs(1,1)*xs(3,2))*dd
      xsi(3,3)=(xs(1,1)*xs(2,2)-xs(2,1)*xs(1,2))*dd
!
!     computation of the global derivatives of the shape functions
!
      do k=1,20
        do j=1,3
          shp(j,k)=shpe(1,k)*xsi(1,j)+shpe(2,k)*xsi(2,j)
     &          +shpe(3,k)*xsi(3,j)
        enddo
      enddo
c      do k=1,20
c        do j=1,3
c          shp(j,k)=shpe(j,k)
c        enddo
c      enddo
!
      return
      end


      SUBROUTINE LOCPT ( N,P, M,S,K,KS, EPS, LOC)
C
C     DETERMINES POSITION OF EACH OF N POINTS (P) RELATIVE TO SURFACE
C        BOUNDED BY M POINTS (S)
C        ALL POINTS IN THE SAME COORDINATE SYSTEM
C     KS IS THE (UNIT) VECTOR NORMAL TO THE SURFACE
C     LOC(I) IS FLAG INDICATING POSITION OF POINT I RELATIVE TO SURFACE:
C        LOC= 1    WHEN POINT WITHIN SURFACE BOUNDRY
C        LOC= 0    WHEN POINT IS ON SURFACE BOUNDRY
C        LOC= -1   WHEN POINT OUTSIDE SURFACE BOUNDRY
C
C     MAXIMUM OF 4 POINTS MAY BE LOCATED RELATIVE
C        TO SURFACE WITH MAXIMUM OF 4 SIDES
C        WHOSE ENDPOINTS ARE IN K(2,M)
C
      DOUBLE PRECISION P(3,4), S(3,4), KS(3)
      DOUBLE PRECISION VE(3,4), VP(3), V(3),VEMAG(4)
      DOUBLE PRECISION VMAG, VPMAG, VDOTK, EDOTP
      DOUBLE PRECISION DVMAG, DADOTB, EPS(2)
C
      INTEGER LOC(1), K(2,1)
C
C
C     EPS ARRAY FOR SIGNIFICANCE TESTING
C        EPS(1) IS AREA, ANGLE LIMIT
C        EPS(2) IS LENGTH LIMIT
C
C
C
C     SET UP VECTORS ALONG EACH SURFACE EDGE
C
      DO 20 NE=1,M
      K1= K(1,NE)
      K2= K(2,NE)
C
      DO 15 I=1,2
C     VE IS VECTOR ALONG SURFACE EDGE
   15 VE(I,NE)= S(I,K2) -S(I,K1)
      VE(3,NE)=0.D0
      VEMAG(NE)= DVMAG( VE(1,NE), EPS(2) )
   20 CONTINUE
C
C      DETERMINE LOCATION OF POINT RELATIVE TO SURFACE
C
      DO 40 NP= 1,N
C        (PRESET POINT FLAG TO INTERIOR CODE)
      LOC(NP)= 1
C
      DO 30 NE= 1,M
      K1= K(1,NE)
C
      DO 24  I=1,2
C     VP IS VECTOR FROM FIRST END OF EDGE VECTOR TO POINT
   24 VP(I)= P(I,NP) -S(I,K1)
      VP(3)= 0.D0
      VPMAG= DVMAG(VP,EPS(2))
C
C     V= VE CROSS VP
      CALL DAXB(VE(1,NE), VP,V)
      VMAG= DVMAG(V,EPS(1))
C     VDOTK= (VE CROSS VP) DOT K,  K NORMAL TO PLANE OF SURFACE
      VDOTK= DADOTB(V, KS)
C     EDOTP IS VE DOT VP
      EDOTP= DADOTB( VE(1,NE), VP)
      IF (VPMAG .LE. EPS(2) )    GO TO 37
      IF (VDOTK .GT. EPS(1))           GO TO 30
C                                      INSIDE THIS EDGE
      IF (         (VDOTK .LT. -EPS(1) )         .OR.
     1             (EDOTP .LE. EPS(1))           .OR.
     2             (VEMAG(NE) +EPS(2) .LT. VPMAG) )        GO TO 35
C                                                          OUTSIDE
                   GO TO 37
C                  ON THIS EDGE
   30 CONTINUE
C     POINT IS WITHIN SURFACE BOUNDRY IF NOT OUTSIDE ANY EDGE
C        AND NOT ON SURFACE BOUNDRY
      GO TO 40
C
C     POINT IS OUTSIDE SURFACE BOUNDRY IF OUTSIDE ANY EDGE
   35 LOC(NP)= -1
      GO TO 40
C
C
C     POINT IS ON BOUNDRY WHEN ANGLE IS EFFECTIVELY ZERO
C        OR (EFFECTIVELY) COINCIDENT WITH EDGE POINT
   37 LOC(NP)= 0
C
   40 CONTINUE
      RETURN
      END


      subroutine clawpack46_rpt2(ixy,maxm,meqn,mwaves,mbc,mx,
     &      ql,qr,aux1,aux2,aux3,ilr,asdq,bmasdq,bpasdq)
c     =====================================================
      implicit double precision (a-h,o-z)
c
c     # Riemann solver in the transverse direction for the shallow water
c     equations .
c     # Split asdq (= A^* \Delta q, where * = + or -)
c     # into down-going flux difference bmasdq (= B^- A^* \Delta q)
c     #    and up-going flux difference bpasdq (= B^+ A^* \Delta q)
c
c     # Uses Roe averages and other quantities which were
c     # computed in rpn2sh and stored in the common block comroe.
c
      dimension     ql(1-mbc:maxm+mbc, meqn)
      dimension     qr(1-mbc:maxm+mbc, meqn)
      dimension   asdq(1-mbc:maxm+mbc, meqn)
      dimension bmasdq(1-mbc:maxm+mbc, meqn)
      dimension bpasdq(1-mbc:maxm+mbc, meqn)
c
      common /cparam/  grav    !# gravitational parameter
      dimension waveb(3,3),sb(3)
      parameter (maxm2 = 603)  !# assumes at most 600x600 grid with mbc=3
      double precision, dimension(-2:maxm2) :: u,v,a,h
      common /comroe/ u,v,a,h
c
      if (-2.gt.1-mbc .or. maxm2 .lt. maxm+mbc) then
          write(6,*) 'need to increase maxm2 in rpB'
          stop
      endif
c
      if (ixy.eq.1) then
          mu = 2
          mv = 3
      else
          mu = 3
          mv = 2
      endif
c
      do i = 2-mbc, mx+mbc
          a1 = ((v(i)+a(i))*asdq(i,1)-asdq(i,mv))/(2*a(i))
          a2 = asdq(i,mu) - u(i)*asdq(i,1)
          a3 = (-(v(i)-a(i))*asdq(i,1)+asdq(i,mv))/(2*a(i))
c
          waveb(1,1) = a1
          waveb(mu,1) = a1*u(i)
          waveb(mv,1) = a1*(v(i)-a(i))
          sb(1) = v(i) - a(i)

          waveb(1,2) = 0.0d0
          waveb(mu,2) = a2
          waveb(mv,2) = 0.0d0
          sb(2) = v(i)

          waveb(1,3) = a3
          waveb(mu,3) = a3*u(i)
          waveb(mv,3) = a3*(v(i)+a(i))
          sb(3) = v(i) + a(i)

c         # compute the flux differences bmasdq and bpasdq

          do m=1,meqn
              bmasdq(i,m) = 0.d0
              bpasdq(i,m) = 0.d0
              do mw=1,mwaves
                  bmasdq(i,m) = bmasdq(i,m)
     &                          + dmin1(sb(mw), 0.d0) * waveb(m,mw)
                  bpasdq(i,m) = bpasdq(i,m)
     &                          + dmax1(sb(mw), 0.d0) * waveb(m,mw)
               enddo
           enddo
      enddo
      return
      end


module compute_flux_module

  implicit none

  private

  public :: &
       godunov_flux_2d, &
       mol2ndord_flux_2d, &
       mol4thord_flux_2d_limited, &
       mol4thord_flux_2d_nolimit, &
       getmaxmin_bounds

contains

  subroutine godunov_flux_2d(lo, hi, dt, dx, &
                             phi,ph_lo,ph_hi, &
                             umac,  u_lo,  u_hi, &
                             vmac,  v_lo,  v_hi, &
                             flxx, fx_lo, fx_hi, &
                             flxy, fy_lo, fy_hi, &
                             phix_1d, phiy_1d, phix, phiy, slope, glo, ghi, nu,  uselimit)

    use slope_module, only: slopex, slopey, slopex_nolim, slopey_nolim

    integer, intent(in) :: lo(2), hi(2), glo(2), ghi(2), uselimit
    double precision, intent(in) :: dt, dx(2), nu
    integer, intent(in) :: ph_lo(2), ph_hi(2)
    integer, intent(in) ::  u_lo(2),  u_hi(2)
    integer, intent(in) ::  v_lo(2),  v_hi(2)
    integer, intent(in) :: fx_lo(2), fx_hi(2)
    integer, intent(in) :: fy_lo(2), fy_hi(2)
    double precision, intent(in   ) :: phi (ph_lo(1):ph_hi(1),ph_lo(2):ph_hi(2))
    double precision, intent(in   ) :: umac( u_lo(1): u_hi(1), u_lo(2): u_hi(2))
    double precision, intent(in   ) :: vmac( v_lo(1): v_hi(1), v_lo(2): v_hi(2))
    double precision, intent(  out) :: flxx(fx_lo(1):fx_hi(1),fx_lo(2):fx_hi(2))
    double precision, intent(  out) :: flxy(fy_lo(1):fy_hi(1),fy_lo(2):fy_hi(2))
    double precision, dimension(glo(1):ghi(1),glo(2):ghi(2)) :: &
         phix_1d, phiy_1d, phix, phiy, slope

    integer :: i, j
    double precision :: hdtdx(2)

    hdtdx = 0.5*(dt/dx)

    if(uselimit .eq. 0) then
       call slopex_nolim(glo, ghi, &
            phi, ph_lo, ph_hi, &
            slope, glo, ghi)
    else

       call slopex(glo, ghi, &
            phi, ph_lo, ph_hi, &
            slope, glo, ghi)
    endif

    ! compute phi on x faces using umac to upwind; ignore transverse terms
    do    j = lo(2)-1, hi(2)+1
       do i = lo(1)  , hi(1)+1

          if (umac(i,j) .lt. 0.d0) then
             phix_1d(i,j) = phi(i  ,j) - (0.5d0 + hdtdx(1)*umac(i,j))*slope(i  ,j)
          else
             phix_1d(i,j) = phi(i-1,j) + (0.5d0 - hdtdx(1)*umac(i,j))*slope(i-1,j)
          end if

       end do
    end do

    if(uselimit .eq. 0) then
       call slopey_nolim(glo, ghi, &
            phi, ph_lo, ph_hi, &
            slope, glo, ghi)
    else
       call slopey(glo, ghi, &
            phi, ph_lo, ph_hi, &
            slope, glo, ghi)
    endif
    ! compute phi on y faces using umac to upwind; ignore transverse terms
    do    j = lo(2)  , hi(2)+1
       do i = lo(1)-1, hi(1)+1

          if (vmac(i,j) .lt. 0.d0) then
             phiy_1d(i,j) = phi(i,j  ) - (0.5d0 + hdtdx(2)*vmac(i,j))*slope(i,j  )
          else
             phiy_1d(i,j) = phi(i,j-1) + (0.5d0 - hdtdx(2)*vmac(i,j))*slope(i,j-1)
          end if

       end do
    end do

    ! update phi on x faces by adding in y-transverse terms
    do    j = lo(2), hi(2)
       do i = lo(1), hi(1)+1

          if (umac(i,j) .lt. 0.d0) then
             phix(i,j) = phix_1d(i,j) &
                  - hdtdx(2)*( 0.5d0*(vmac(i  ,j+1)+vmac(i  ,j)) * (phiy_1d(i  ,j+1)-phiy_1d(i  ,j)) )
          else
             phix(i,j) = phix_1d(i,j) &
                  - hdtdx(2)*( 0.5d0*(vmac(i-1,j+1)+vmac(i-1,j)) * (phiy_1d(i-1,j+1)-phiy_1d(i-1,j)) )
          end if

          ! compute final x-fluxes
          ! including diffusive fluxes
          flxx(i,j) = phix(i,j)*umac(i,j)  - nu*(phi(i,j) - phi(i-1,j))/dx(1)

       end do
    end do

    ! update phi on y faces by adding in x-transverse terms
    do    j = lo(2), hi(2)+1
       do i = lo(1), hi(1)

          if (vmac(i,j) .lt. 0.d0) then
             phiy(i,j) = phiy_1d(i,j) &
                  - hdtdx(1)*( 0.5d0*(umac(i+1,j  )+umac(i,j  )) * (phix_1d(i+1,j  )-phix_1d(i,j  )) )
          else
             phiy(i,j) = phiy_1d(i,j) &
                  - hdtdx(1)*( 0.5d0*(umac(i+1,j-1)+umac(i,j-1)) * (phix_1d(i+1,j-1)-phix_1d(i,j-1)) )
          end if

          ! compute final y-fluxes
          ! including diffusive fluxes
          flxy(i,j) = phiy(i,j)*vmac(i,j)  - nu*(phi(i,j) - phi(i,j-1))/dx(2)

       end do
    end do

  end subroutine godunov_flux_2d

  subroutine mol2ndord_flux_2d(lo, hi, dt, dx, &
       phi,ph_lo,ph_hi, &
       umac,  u_lo,  u_hi, &
       vmac,  v_lo,  v_hi, &
       flxx, fx_lo, fx_hi, &
       flxy, fy_lo, fy_hi, &
       phix_1d, phiy_1d, slope, glo, ghi, nu, uselimit)

    use slope_module, only: slopex, slopey, slopex_nolim, slopey_nolim

    integer, intent(in) :: lo(2), hi(2), glo(2), ghi(2), uselimit
    double precision, intent(in) :: dt, dx(2), nu
    integer, intent(in) :: ph_lo(2), ph_hi(2)
    integer, intent(in) ::  u_lo(2),  u_hi(2)
    integer, intent(in) ::  v_lo(2),  v_hi(2)
    integer, intent(in) :: fx_lo(2), fx_hi(2)
    integer, intent(in) :: fy_lo(2), fy_hi(2)
    double precision, intent(in   ) :: phi (ph_lo(1):ph_hi(1),ph_lo(2):ph_hi(2))
    double precision, intent(in   ) :: umac( u_lo(1): u_hi(1), u_lo(2): u_hi(2))
    double precision, intent(in   ) :: vmac( v_lo(1): v_hi(1), v_lo(2): v_hi(2))
    double precision, intent(  out) :: flxx(fx_lo(1):fx_hi(1),fx_lo(2):fx_hi(2))
    double precision, intent(  out) :: flxy(fy_lo(1):fy_hi(1),fy_lo(2):fy_hi(2))
    double precision, dimension(glo(1):ghi(1),glo(2):ghi(2)) :: &
         phix_1d, phiy_1d, slope
    double precision phi1, phi2, ftemp, veltemp, diffterm

    integer :: i, j

    if(uselimit .eq. 0) then
       call slopex_nolim(glo, ghi, &
            phi, ph_lo, ph_hi, &
            slope, glo, ghi)
    else
       call slopex(glo, ghi, &
            phi, ph_lo, ph_hi, &
            slope, glo, ghi)
    endif

    ! compute phi on x faces using umac to upwind; ignore transverse terms
    do    j = lo(2)-1, hi(2)+1
       do i = lo(1)  , hi(1)+1

          phi1 =  phi(i  ,j) - 0.5d0*slope(i  ,j)
          phi2 =  phi(i-1,j) + 0.5d0*slope(i-1,j)

          if (umac(i,j) .lt. 0.d0) then
             phix_1d(i,j) = phi(i  ,j) - 0.5d0*slope(i  ,j)
          else
             phix_1d(i,j) = phi(i-1,j) + 0.5d0*slope(i-1,j)
          end if

       end do
    end do

    if(uselimit .eq. 0) then
       call slopey_nolim(glo, ghi, &
            phi, ph_lo, ph_hi, &
            slope, glo, ghi)
    else
       call slopey(glo, ghi, &
            phi, ph_lo, ph_hi, &
            slope, glo, ghi)
    endif

    ! compute phi on y faces using umac to upwind; ignore transverse terms
    do    j = lo(2)  , hi(2)+1
       do i = lo(1)-1, hi(1)+1

          if (vmac(i,j) .lt. 0.d0) then
             phiy_1d(i,j) = phi(i,j  ) - (0.5d0)*slope(i,j  )
          else
             phiy_1d(i,j) = phi(i,j-1) + (0.5d0)*slope(i,j-1)
          end if

       end do
    end do

    ! compute final x-fluxes
    do    j = lo(2), hi(2)
       do i = lo(1), hi(1)+1
          ! including diffusive fluxes
          veltemp  = umac(i,j)
          diffterm = - nu*(phi(i,j) - phi(i-1,j))/dx(1)
          phi1  = phix_1d(i,j)
          ftemp  = phix_1d(i,j)*umac(i,j)  - nu*(phi(i,j) - phi(i-1,j))/dx(1)
          flxx(i,j) = phix_1d(i,j)*umac(i,j)  - nu*(phi(i,j) - phi(i-1,j))/dx(1)
       end do
    end do

    ! compute final y-fluxes
    do    j = lo(2), hi(2)+1
       do i = lo(1), hi(1)
          ! including diffusive fluxes
          ftemp  = phiy_1d(i,j)*vmac(i,j)  - nu*(phi(i,j) - phi(i,j-1))/dx(2)

          flxy(i,j) = phiy_1d(i,j)*vmac(i,j)  - nu*(phi(i,j) - phi(i,j-1))/dx(2)
       end do
    end do

  end subroutine mol2ndord_flux_2d

  !phi coming in is assumed to be cell-averaged
  !velocity is pointwise on faces---no limiting here
  subroutine mol4thord_flux_2d_nolimit(lo, hi, dt, dx, &
                                       phi ,ph_lo,ph_hi, &
                                       umac,  u_lo,  u_hi, &
                                       vmac,  v_lo,  v_hi, &
                                       flxx, fx_lo, fx_hi, &
                                       flxy, fy_lo, fy_hi, &
                                       fluxptx, phiptx, phiavex, &
                                       fluxpty, phipty, phiavey, &
                                       phiptcc, glo, ghi, nu, &
                                       deblocell, debhicell, &
                                       hisidedebfacelo, hisidedebfacehi, &
                                       losidedebfacelo, losidedebfacehi, printstuff)

    integer, intent(in) :: lo(2), hi(2), glo(2), ghi(2), printstuff
    integer, intent(in) :: deblocell(2), debhicell(2)
    integer, intent(in) :: hisidedebfacelo(2), hisidedebfacehi(2)
    integer, intent(in) :: losidedebfacelo(2), losidedebfacehi(2)
    double precision, intent(in) :: dt, dx(2), nu
    integer, intent(in) :: ph_lo(2), ph_hi(2)
    integer, intent(in) ::  u_lo(2),  u_hi(2)
    integer, intent(in) ::  v_lo(2),  v_hi(2)
    integer, intent(in) :: fx_lo(2), fx_hi(2)
    integer, intent(in) :: fy_lo(2), fy_hi(2)
    double precision, intent(in   ) :: phi (ph_lo(1):ph_hi(1),ph_lo(2):ph_hi(2))
    double precision, intent(in   ) :: umac( u_lo(1): u_hi(1), u_lo(2): u_hi(2))
    double precision, intent(in   ) :: vmac( v_lo(1): v_hi(1), v_lo(2): v_hi(2))
    double precision, intent(  out) :: flxx(fx_lo(1):fx_hi(1),fx_lo(2):fx_hi(2))
    double precision, intent(  out) :: flxy(fy_lo(1):fy_hi(1),fy_lo(2):fy_hi(2))
    double precision, dimension(glo(1):ghi(1),glo(2):ghi(2)) :: &
         fluxptx, fluxpty,  phiptx, phipty,  phiavex, phiavey, phiptcc

    double precision :: diffflux, phicctemp, debtemp
    integer :: i, j
!    integer ::  numphi
!    double precision :: phitot

    fluxptx = 1.0d30
    fluxpty = 1.0d30
    phiptx  = 1.0d30
    phipty  = 1.0d30
    phiavex = 1.0d30
    phiavey = 1.0d30
    phiptcc = 1.0d30
    !STEP 0
    ! 2.1 get cell-centered phi so we can compute a pointwise, fourth order gradient at faces
    ! needed  for diffusive fluxes

    do    j = lo(2)-3, hi(2)+3
       do i = lo(1)-3, hi(1)+3
          phicctemp  = phi(i,j) - (1.0d0/24.d0)* &
               (phi(i+1,j  )+phi(i-1,j  )&
               +phi(i  ,j+1)+phi(i  ,j-1)&
               -4.d0*phi(i,j))
          phiptcc(i,j)  = phicctemp
       end do
    end do

    ! STEP ONE--- HYPERBOLIC FLUXES
    ! compute face average phi on x faces via eqn 17 of mccorquodale, colella

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

          debtemp  = &
                (7.d0/12.d0)*(phi(i  ,j) + phi(i-1,j)) &
               -(1.d0/12.d0)*(phi(i-2,j) + phi(i+1,j))

          phiavex(i,j)  = debtemp
       end do
    end do

    !same for y faces
    do    j = lo(2)  , hi(2)+1
       do i = lo(1)-2, hi(1)+2

          debtemp  = &
                (7.d0/12.d0)*(phi(i,j  ) + phi(i,j-1)) &
               -(1.d0/12.d0)*(phi(i,j-2) + phi(i,j+1))
          phiavey(i,j)  = debtemp

       end do
    end do

    !now get point valued phi at faces so we can multiply by point valued velocity
    ! phipt = phiave - (h^2/24)*(lapl^2d(phi_ave))
    ! while I am at it, multiply in pointwise velocity so we get pointwise *HYPERBOLIC* flux
    !also  get pointwise diffusive fluxes using 4th order finite differences of pointwise phi

    do    j = lo(2)-1, hi(2)+1
       do i = lo(1)  , hi(1)+1
          phiptx(i,j)  =    phiavex(i,j  ) - (1.0d0/24.d0)* &
               (phiavex(i,j+1) + phiavex(i,j-1) - 2.d0*phiavex(i,j))

          debtemp  = phiptx(i,j)

          diffflux  = (-nu/dx(1))* &
               ((27.0d0/24.0d0)*(phiptcc(i  ,j) - phiptcc(i-1,j)) &
               +( 1.0d0/24.0d0)*(phiptcc(i-2,j) - phiptcc(i+1,j)))

          fluxptx(i,j) = umac(i,j)*phiptx(i,j) + diffflux

!uncomment to just do diffusion
!          fluxptx(i,j) =  diffflux

       end do
    end do

    !same for y faces
    do    j = lo(2)  , hi(2)+1
       do i = lo(1)-1, hi(1)+1

          phipty(i,j)  = phiavey(i,j) - (1.0d0/24.d0)* &
               (phiavey(i+1,j)+phiavey(i-1,j)-2.d0*phiavey(i,j))

          debtemp  = phipty(i,j)

          diffflux  = (-nu/dx(2))* &
               ((27.0d0/24.0d0)*(phiptcc(i,j  ) - phiptcc(i,j-1)) &
               +( 1.0d0/24.0d0)*(phiptcc(i,j-2) - phiptcc(i,j+1)))

          fluxpty(i,j) = vmac(i,j)*phipty(i,j) + diffflux

!uncomment to just do diffusion
!          fluxpty(i,j) =  diffflux

       end do
    end do

    ! now transform pointwise fluxes into face-averaged fluxes
    !fluxave = fluxpt + (1/24)(Lapl2d(fluxpt))

    do    j = lo(2), hi(2)
       do i = lo(1), hi(1)+1
          debtemp  = fluxptx(i,j) + (1.0d0/24.d0)* &
               (fluxptx(i,j+1) + fluxptx(i,j-1) - 2.d0*fluxptx(i,j))

          flxx(i,j)  = debtemp

!debug   just set the flux = phiavex
!          flxx(i,j)  = phiavex(i,j)
!end debug
       end do
    end do

    do    j = lo(2), hi(2)+1
       do i = lo(1), hi(1)
          debtemp  = fluxpty(i,j) + (1.0d0/24.d0)* &
               (fluxpty(i+1,j) + fluxpty(i-1,j) - 2.d0*fluxpty(i,j))
          flxy(i,j)  = debtemp

!debug   just set the flux = phiavex
!          flxy(i,j)  = phiavey(i,j)
!end debug
       end do
    end do

 end subroutine mol4thord_flux_2d_nolimit

  subroutine getmaxmin_bounds(lo, hi, glo, ghi, phi, maxval, minval, imax, imin)

    integer, intent(in) :: lo(2), hi(2), glo(2), ghi(2)
    double precision, intent(in   ) :: phi (glo(1):ghi(1),glo(2):ghi(2))
    double precision, intent(out   ) :: maxval, minval
    integer, intent(out) :: imax(2), imin(2)
    integer :: i, j

    maxval = -1.0d30
    minval =  1.0d30

    do    j = lo(2), hi(2)
       do i = lo(1), hi(1)
          if(phi(i,j) .gt. maxval) then
             maxval = phi(i,j)
             imax(1) = i
             imax(2) = j
          endif
          if(phi(i,j) .lt. minval) then
             minval = phi(i,j)
             imin(1) = i
             imin(2) = j
          endif
       enddo
    enddo

    return
  end subroutine getmaxmin_bounds

  !phi coming in is assumed to be cell-averaged
  !velocity is pointwise on faces---this is the more complicated one that does limiting.
  subroutine mol4thord_flux_2d_limited(lo, hi, dt, dx, &
                                       phi ,ph_lo,ph_hi, &
                                       umac,  u_lo,  u_hi, &
                                       vmac,  v_lo,  v_hi, &
                                       flxx, fx_lo, fx_hi, &
                                       flxy, fy_lo, fy_hi, &
                                       fluxptx, phiptx, phiavex, &
                                       fluxpty, phipty, phiavey, &
                                       phiptcc, glo, ghi, nu, &
                                       deblocell, debhicell, &
                                       hisidedebfacelo, hisidedebfacehi, &
                                       losidedebfacelo, losidedebfacehi, printstuff)

    use amrex_mempool_module, only : bl_allocate, bl_deallocate

    integer, intent(in) :: lo(2), hi(2), glo(2), ghi(2), printstuff
    integer, intent(in) :: deblocell(2), debhicell(2)
    integer, intent(in) :: hisidedebfacelo(2), hisidedebfacehi(2)
    integer, intent(in) :: losidedebfacelo(2), losidedebfacehi(2)
    double precision, intent(in) :: dt, dx(2), nu
    integer, intent(in) :: ph_lo(2), ph_hi(2)
    integer, intent(in) ::  u_lo(2),  u_hi(2)
    integer, intent(in) ::  v_lo(2),  v_hi(2)
    integer, intent(in) :: fx_lo(2), fx_hi(2)
    integer, intent(in) :: fy_lo(2), fy_hi(2)
    double precision, intent(in   ) :: phi (ph_lo(1):ph_hi(1),ph_lo(2):ph_hi(2))
    double precision, intent(in   ) :: umac( u_lo(1): u_hi(1), u_lo(2): u_hi(2))
    double precision, intent(in   ) :: vmac( v_lo(1): v_hi(1), v_lo(2): v_hi(2))
    double precision, intent(  out) :: flxx(fx_lo(1):fx_hi(1),fx_lo(2):fx_hi(2))
    double precision, intent(  out) :: flxy(fy_lo(1):fy_hi(1),fy_lo(2):fy_hi(2))
    double precision, dimension(glo(1):ghi(1),glo(2):ghi(2)) :: &
         fluxptx, fluxpty,  phiptx, phipty,  phiavex, phiavey, phiptcc

    double precision, dimension(:,:), pointer, contiguous :: &
         dwfminux, dwfminuy, dwfplusx, dwfplusy, d2wfx, d2wfy, d2wcx, d2wcy, d3wx, d3wy, &
         wleftx, wrighx, wlefty, wrighy

    double precision :: diffflux, phicctemp, debtemp, mono1, mono2, signd2, d2wlim, &
         d2wc1, d2wc2, d2wc3, d2wf1, rho, d3wmin, d3wmax, dwthresh, maxw
    logical :: applylim
    integer :: i, j
    integer :: imax(2), imin(2), blo(2), bhi(2);
    double precision ::     maxval, minval
!    double precision :: phitot
!    integer ::  numphi

    call bl_allocate(dwfplusx,glo(1), ghi(1), glo(2), ghi(2))
    call bl_allocate(dwfminux,glo(1), ghi(1), glo(2), ghi(2))
    call bl_allocate(dwfplusy,glo(1), ghi(1), glo(2), ghi(2))
    call bl_allocate(dwfminuy,glo(1), ghi(1), glo(2), ghi(2))
    call bl_allocate(d2wfx   ,glo(1), ghi(1), glo(2), ghi(2))
    call bl_allocate(d2wcx   ,glo(1), ghi(1), glo(2), ghi(2))
    call bl_allocate(d3wx    ,glo(1), ghi(1), glo(2), ghi(2))
    call bl_allocate(d3wy    ,glo(1), ghi(1), glo(2), ghi(2))
    call bl_allocate(d2wfy   ,glo(1), ghi(1), glo(2), ghi(2))
    call bl_allocate(d2wcy   ,glo(1), ghi(1), glo(2), ghi(2))

    call bl_allocate(wleftx  ,glo(1), ghi(1), glo(2), ghi(2))
    call bl_allocate(wlefty  ,glo(1), ghi(1), glo(2), ghi(2))
    call bl_allocate(wrighx  ,glo(1), ghi(1), glo(2), ghi(2))
    call bl_allocate(wrighy  ,glo(1), ghi(1), glo(2), ghi(2))

    phiavey  = 1.0d30
    phiptcc  = 1.0d30
    dwfplusx = 1.0d30
    dwfminux = 1.0d30
    dwfplusy = 1.0d30
    dwfminuy = 1.0d30
    d2wfx    = 1.0d30
    d2wcx    = 1.0d30
    d3wx     = 1.0d30
    d2wfy    = 1.0d30
    d2wcy    = 1.0d30
    d3wy     = 1.0d30

    !STEP 0
    ! 2.1 get cell-centered phi so we can compute a pointwise, fourth order gradient at faces
    ! needed  for diffusive fluxes (eqn 16 of m + c)

    do    j = lo(2)-3, hi(2)+3
       do i = lo(1)-3, hi(1)+3
          phicctemp  = phi(i,j) - (1.0d0/24.d0)* &
               (phi(i+1,j  )+phi(i-1,j  )&
               +phi(i  ,j+1)+phi(i  ,j-1)&
               -4.d0*phi(i,j))
          phiptcc(i,j)  = phicctemp

       end do
    end do

    blo(1) = lo(1)-3
    bhi(1) = hi(1)+3
    blo(2) = lo(2)-3
    bhi(2) = hi(2)+3
    call getmaxmin_bounds(blo, bhi, glo, ghi, phiptcc, maxval, minval, imax, imin)

    ! STEP ONE--- HYPERBOLIC FLUXES
    ! compute face average phi on x faces via eqn 17 of mccorquodale, colella

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

          debtemp  = &
                (7.d0/12.d0)*(phi(i  ,j) + phi(i-1,j)) &
               -(1.d0/12.d0)*(phi(i-2,j) + phi(i+1,j))

          phiavex(i,j)  = debtemp

       end do
    end do

    blo(2) = lo(2)-2
    bhi(2) = hi(2)+2
    blo(1) = lo(1)-1
    bhi(1) = hi(1)+2
    call getmaxmin_bounds(blo, bhi, glo, ghi, phiavex, maxval, minval, imax, imin)

    !same for y faces
    do    j = lo(2)-1, hi(2)+2
       do i = lo(1)-2, hi(1)+2

          debtemp  = &
                (7.d0/12.d0)*(phi(i,j  ) + phi(i,j-1)) &
               -(1.d0/12.d0)*(phi(i,j-2) + phi(i,j+1))
          phiavey(i,j)  = debtemp

       end do
    end do

    blo(2) = lo(2)-1
    bhi(2) = hi(2)+2
    blo(1) = lo(1)-2
    bhi(1) = hi(1)+2
    call getmaxmin_bounds(blo, bhi, glo, ghi, phiavey, maxval, minval, imax, imin)

    !this stuff is for limiting
    !The variable names are from mccorquodale & colella.   I could not come
    ! up with anything more sensible.   This is from section 2.4.1.
    do    j = lo(2)-2, hi(2)+2
       do i = lo(1)  , hi(1)
          dwfminux(i,j) =     phi(i  ,j) - phiavex(i,j)
          dwfplusx(i,j) = phiavex(i+1,j) -     phi(i,j)
       enddo
    enddo

    blo(2) = lo(2)-2
    bhi(2) = hi(2)+2
    blo(1) = lo(1)
    bhi(1) = hi(1)
    call getmaxmin_bounds(blo, bhi, glo, ghi, dwfminux, maxval, minval, imax, imin)
    call getmaxmin_bounds(blo, bhi, glo, ghi, dwfplusx, maxval, minval, imax, imin)

    do    j = lo(2)    , hi(2)
       do i = lo(1)-2  , hi(1)+2
          dwfminuy(i,j) =     phi(i,j  ) - phiavey(i,j)
          dwfplusy(i,j) = phiavey(i,j+1) -     phi(i,j)

       enddo
    enddo

    blo(2) = lo(2)
    bhi(2) = hi(2)
    blo(1) = lo(1)-2
    bhi(1) = hi(1)+2
    call getmaxmin_bounds(blo, bhi, glo, ghi, dwfminuy, maxval, minval, imax, imin)
    call getmaxmin_bounds(blo, bhi, glo, ghi, dwfplusy, maxval, minval, imax, imin)

    do    j = lo(2)-2, hi(2)+2
       do i = lo(1)-1, hi(1)+1
          d2wfx(i,j) = 6.0d0*(phiavex(i  ,j) + phiavex(i+1,j) - 2.0d0*phi(i,j))
          d2wcx(i,j) =       (    phi(i-1,j) +     phi(i+1,j) - 2.0d0*phi(i,j))

       enddo
    enddo

    blo(2) = lo(2)-2
    bhi(2) = hi(2)+2
    blo(1) = lo(1)-1
    bhi(1) = hi(1)+1
    call getmaxmin_bounds(blo, bhi, glo, ghi, d2wfx, maxval, minval, imax, imin)
    call getmaxmin_bounds(blo, bhi, glo, ghi, d2wcx, maxval, minval, imax, imin)

    do    j = lo(2)-1, hi(2)+1
       do i = lo(1)-2, hi(1)+2
          d2wfy(i,j) = 6.0d0*(phiavey(i,j  ) + phiavey(i,j+1) - 2.0d0*phi(i,j))
          d2wcy(i,j) =       (    phi(i,j-1) +     phi(i,j+1) - 2.0d0*phi(i,j))

       enddo
    enddo

    blo(2) = lo(2)-1
    bhi(2) = hi(2)+1
    blo(1) = lo(1)-2
    bhi(1) = hi(1)+2
    call getmaxmin_bounds(blo, bhi, glo, ghi, d2wfy, maxval, minval, imax, imin)
    call getmaxmin_bounds(blo, bhi, glo, ghi, d2wcy, maxval, minval, imax, imin)

    do    j = lo(2)-2, hi(2)+2
       do i = lo(1),   hi(1)+1
          d3wx(i,j) = d2wcx(i,j) - d2wcx(i-1,j)
       enddo
    enddo

    blo(2) = lo(2)-2
    bhi(2) = hi(2)+2
    blo(1) = lo(1)
    bhi(1) = hi(1)+1
    call getmaxmin_bounds(blo, bhi, glo, ghi, d3wx, maxval, minval, imax, imin)

    do    j = lo(2)  , hi(2)+1
       do i = lo(1)-2, hi(1)+2
          d3wy(i,j) = d2wcy(i,j) - d2wcy(i,j-1)
       enddo
    enddo

    blo(2) = lo(2)
    bhi(2) = hi(2)+1
    blo(1) = lo(1)-2
    bhi(1) = hi(1)+2
    call getmaxmin_bounds(blo, bhi, glo, ghi, d3wy, maxval, minval, imax, imin)

    !initialize left and right states
    do    j = lo(2)-2, hi(2)+2
       do i = lo(1)  , hi(1)+1
          wleftx(i,j) = phiavex(i,j)
          wrighx(i,j) = phiavex(i,j)

       enddo
    enddo
    do    j = lo(2)  , hi(2)+1
       do i = lo(1)-2, hi(1)+2
          wlefty(i,j) = phiavey(i,j)
          wrighy(i,j) = phiavey(i,j)
       enddo
    enddo

    !now for the really complicted stuff in 2.4.1
    !If there are extrema detected a cell, modify the states
    !that are extrapolate from that cell.  If monotonoic but there
    ! is a huge jump in the state, mollify that
    do    j = lo(2)-2, hi(2)+2
       do i = lo(1)  , hi(1)+1
          mono1 = dwfminux(i,j) * dwfplusx(i,j)
          mono2 = (phi(i,j)-phi(i-2,j))*(phi(i+2,j)-phi(i,j))
          if((mono1 .lt. 0.0d0).or.(mono2 .lt. 0.0d0)) then

             !see if all second derivs in sight are the same sign.   If they are,
             ! calculate d2wlim.     Otherwise, d2wlim = 0
             !this stuff comes from equation 26
             d2wlim = 0.0d0
             signd2 = 0.0d0
             d2wc1 = d2wcx(i-1,j)
             d2wc2 = d2wcx(i  ,j)
             d2wc3 = d2wcx(i+1,j)
             d2wf1 = d2wfx(i  ,j)
             d2wlim = min(abs(d2wf1), 1.25d0*abs(d2wc1))
             d2wlim = min(d2wlim    , 1.25d0*abs(d2wc2))
             d2wlim = min(d2wlim    , 1.25d0*abs(d2wc3))
             if((d2wc1.gt.0.0d0) .and. &
                (d2wc2.gt.0.0d0) .and. &
                (d2wc3.gt.0.0d0) .and. &
                (d2wf1.gt.0.0d0)) then
                signd2 = 1.0d0
                d2wlim = d2wlim*signd2
             else if((d2wc1.lt.0.0d0) .and. &
                     (d2wc2.lt.0.0d0) .and. &
                     (d2wc3.lt.0.0d0) .and. &
                     (d2wf1.lt.0.0d0)) then
                signd2 = -1.0d0
                d2wlim = d2wlim*signd2
             else
                d2wlim = 0.0d0
             endif
             !equation 27 below
             maxw = max(abs(phi(i,j)),abs(phi(i+1,j)))
             maxw = max(maxw         ,abs(phi(i-1,j)))
             maxw = max(maxw         ,abs(phi(i+2,j)))
             maxw = max(maxw         ,abs(phi(i-2,j)))
             dwthresh = 1.0d-12*(maxw)
             if(abs(d2wf1).lt.dwthresh) then
                rho = 0.0d0
             else
                rho = d2wlim/d2wf1
             endif
             if(rho .lt. (1.0d0 - 1.0d-12)) then
                applylim = .false.
             else
                !this stuff is equation 28
                d3wmin = min(d3wx(i,j),d3wx(i-1,j))
                d3wmin = min(d3wmin   ,d3wx(i+1,j))
                d3wmin = min(d3wmin   ,d3wx(i+2,j))
                d3wmax = max(d3wx(i,j),d3wx(i-1,j))
                d3wmax = max(d3wmax   ,d3wx(i+1,j))
                d3wmax = max(d3wmax   ,d3wx(i+2,j))
                dwthresh = 0.1d0*max(abs(d3wmax),abs(d3wmin))
                if((d3wmax - d3wmin).lt. dwthresh) then
                   applylim = .false.
                else
                   applylim = .true.
                endif
             endif
             !the following covered equations 29-32
             if(applylim) then
                if((dwfminux(i,j)*dwfplusx(i,j)).lt.0.0) then

                   wrighx(i,j) = phi(i,j) -  rho*dwfminux(i,j) !eqn 29 (corrected)
                   wleftx(i,j) = phi(i,j) +  rho*dwfplusx(i,j) !eqn 30

                else if(abs(dwfminux(i,j)) .ge. 2.0d0*abs(dwfplusx(i,j))) then
                   !equation 31
                   wrighx(i,j) = phi(i,j) -  2.0d0*(1.0d0-rho)*dwfplusx(i,j) - rho*dwfminux(i,j)
                else if(abs(dwfplusx(i,j)) .ge. 2.0d0*abs(dwfminux(i,j))) then
                   !equation 32
                   wleftx(i,j) = phi(i,j) +  2.0d0*(1.0d0-rho)*dwfminux(i,j) + rho*dwfplusx(i,j)
                endif
             endif
          else !monotonic but still need to check for big jumps in the state
             if(abs(dwfminux(i,j)) .ge. (2.0d0*abs(dwfplusx(i,j)))) then
                wrighx(i,j) = phi(i,j) -  2.0d0*dwfplusx(i,j) !eqn 33
             endif
             if(abs(dwfplusx(i,j)) .ge. (2.0d0*abs(dwfminux(i,j)))) then
                wleftx(i,j) = phi(i,j) +  2.0d0*dwfminux(i,j) !eqn 34
             endif
          endif
       enddo
    enddo
    !now we do it all again for the y direction.
    do    j = lo(2)  , hi(2)+1
       do i = lo(1)-2, hi(1)+2
          mono1 = dwfminuy(i,j) * dwfplusy(i,j)
          mono2 = (phi(i,j)-phi(i,j-2))*(phi(i,j+2)-phi(i,j))
          if((mono1 .lt. 0.0d0).or.(mono2 .lt. 0.0d0)) then

             !see if all second derivs in sight are the same sign.   If they are,
             ! calculate d2wlim.     Otherwise, d2wlim = 0
             !this stuff comes from equation 26
             d2wlim = 0.0d0
             signd2 = 0.0d0
             d2wc1 = d2wcy(i,j-1)
             d2wc2 = d2wcy(i,j  )
             d2wc3 = d2wcy(i,j+1)
             d2wf1 = d2wfy(i,j  )
             d2wlim = min(abs(d2wf1), 1.25d0*abs(d2wc1))
             d2wlim = min(d2wlim    , 1.25d0*abs(d2wc2))
             d2wlim = min(d2wlim    , 1.25d0*abs(d2wc3))
             if((d2wc1.gt.0.0d0) .and. &
                (d2wc2.gt.0.0d0) .and. &
                (d2wc3.gt.0.0d0) .and. &
                (d2wf1.gt.0.0d0)) then
                signd2 = 1.0d0
                d2wlim = d2wlim*signd2
             else if((d2wc1.lt.0.0d0) .and. &
                     (d2wc2.lt.0.0d0) .and. &
                     (d2wc3.lt.0.0d0) .and. &
                     (d2wf1.lt.0.0d0)) then
                signd2 = -1.0d0
                d2wlim = d2wlim*signd2
             else
                d2wlim = 0.0d0
             endif
             !equation 27 below
             maxw = max(abs(phi(i,j)),abs(phi(i,j+1)))
             maxw = max(maxw         ,abs(phi(i,j-1)))
             maxw = max(maxw         ,abs(phi(i,j+2)))
             maxw = max(maxw         ,abs(phi(i,j-2)))
             dwthresh = 1.0d-12*(maxw)
             if(abs(d2wf1).lt.dwthresh) then
                rho = 0.0d0
             else
                rho = d2wlim/d2wf1
             endif
             if(rho .lt. (1.0d0 - 1.0d-12)) then
                applylim = .false.
             else
                !this stuff is equation 28
                d3wmin = min(d3wy(i,j),d3wy(i,j-1))
                d3wmin = min(d3wmin   ,d3wy(i,j+1))
                d3wmin = min(d3wmin   ,d3wy(i,j+2))
                d3wmax = max(d3wy(i,j),d3wy(i,j-1))
                d3wmax = max(d3wmax   ,d3wy(i,j+1))
                d3wmax = max(d3wmax   ,d3wy(i,j+2))
                dwthresh = 0.1d0*max(abs(d3wmax),abs(d3wmin))
                if((d3wmax - d3wmin).lt. dwthresh) then
                   applylim = .false.
                else
                   applylim = .true.
                endif
             endif
             !the following covered equations 29-32
             if(applylim) then
                if((dwfminuy(i,j)*dwfplusy(i,j)).lt.0.0) then

                   wrighy(i,j) = phi(i,j) -  rho*dwfminuy(i,j) !eqn 29 (corrected)
                   wlefty(i,j) = phi(i,j) +  rho*dwfplusy(i,j) !eqn 30

                else if(abs(dwfminuy(i,j)) .ge. 2.0d0*abs(dwfplusy(i,j))) then
                   !equation 31
                   wrighy(i,j) = phi(i,j) -  2.0d0*(1.0d0-rho)*dwfplusy(i,j) - rho*dwfminuy(i,j)
                else if(abs(dwfplusy(i,j)) .ge. 2.0d0*abs(dwfminuy(i,j))) then
                   !equation 32
                   wlefty(i,j) = phi(i,j) +  2.0d0*(1.0d0-rho)*dwfminuy(i,j) + rho*dwfplusy(i,j)
                endif
             endif

          else !monotonic but still need to check for big jumps in the state
             if(abs(dwfminuy(i,j)) .ge. (2.0d0*abs(dwfplusy(i,j)))) then
                wrighy(i,j) = phi(i,j) -  2.0d0*dwfplusy(i,j) !eqn 33
             endif
             if(abs(dwfplusx(i,j)) .ge. (2.0d0*abs(dwfminux(i,j)))) then
                wlefty(i,j) = phi(i,j) +  2.0d0*dwfminuy(i,j) !eqn 34
             endif
          endif

       enddo
    enddo
    !now get point valued phi at faces so we can multiply by point valued velocity
    ! phipt = phiave - (h^2/24)*(lapl^2d(phi_ave))
    ! while I am at it, multiply in pointwise velocity so we get pointwise *HYPERBOLIC* flux
    !also  get pointwise diffusive fluxes using 4th order finite differences of pointwise phi

    do    j = lo(2)-1, hi(2)+1
       do i = lo(1)  , hi(1)+1
          phiptx(i,j)  =    phiavex(i,j  ) - (1.0d0/24.d0)* &
               (phiavex(i,j+1) + phiavex(i,j-1) - 2.d0*phiavex(i,j))

          debtemp  = phiptx(i,j)

          diffflux  = (-nu/dx(1))* &
               ((27.0d0/24.0d0)*(phiptcc(i  ,j) - phiptcc(i-1,j)) &
               +( 1.0d0/24.0d0)*(phiptcc(i-2,j) - phiptcc(i+1,j)))

          fluxptx(i,j) = umac(i,j)*phiptx(i,j) + diffflux

!uncomment to just do diffusion
!          fluxptx(i,j) =  diffflux

       end do
    end do

    !same for y faces
    do    j = lo(2)  , hi(2)+1
       do i = lo(1)-1, hi(1)+1

          phipty(i,j)  = phiavey(i,j) - (1.0d0/24.d0)* &
               (phiavey(i+1,j)+phiavey(i-1,j)-2.d0*phiavey(i,j))

          debtemp  = phipty(i,j)

          diffflux  = (-nu/dx(2))* &
               ((27.0d0/24.0d0)*(phiptcc(i,j  ) - phiptcc(i,j-1)) &
               +( 1.0d0/24.0d0)*(phiptcc(i,j-2) - phiptcc(i,j+1)))

          fluxpty(i,j) = vmac(i,j)*phipty(i,j) + diffflux

!uncomment to just do diffusion
!          fluxpty(i,j) =  diffflux

       end do
    end do

    ! now transform pointwise fluxes into face-averaged fluxes
    !fluxave = fluxpt + (1/24)(Lapl2d(fluxpt))

    do    j = lo(2), hi(2)
       do i = lo(1), hi(1)+1
          debtemp  = fluxptx(i,j) + (1.0d0/24.d0)* &
               (fluxptx(i,j+1) + fluxptx(i,j-1) - 2.d0*fluxptx(i,j))

          flxx(i,j)  = debtemp

!debug   just set the flux = phiavex
!          flxx(i,j)  = phiavex(i,j)
!end debug
       end do
    end do

    do    j = lo(2), hi(2)+1
       do i = lo(1), hi(1)
          debtemp  = fluxpty(i,j) + (1.0d0/24.d0)* &
               (fluxpty(i+1,j) + fluxpty(i-1,j) - 2.d0*fluxpty(i,j))
          flxy(i,j)  = debtemp

!debug   just set the flux = phiavex
!          flxy(i,j)  = phiavey(i,j)
!end debug
       end do
    end do

    call bl_deallocate(dwfplusx)
    call bl_deallocate(dwfminux)
    call bl_deallocate(dwfplusy)
    call bl_deallocate(dwfminuy)
    call bl_deallocate(d2wfx   )
    call bl_deallocate(d2wcx   )
    call bl_deallocate(d3wx    )
    call bl_deallocate(d3wy    )
    call bl_deallocate(d2wfy   )
    call bl_deallocate(d2wcy   )
    call bl_deallocate(d3wy    )
    call bl_deallocate(wleftx  )
    call bl_deallocate(wlefty  )
    call bl_deallocate(wrighx  )
    call bl_deallocate(wrighy  )

 end subroutine mol4thord_flux_2d_limited

end module compute_flux_module


cc      real*8 function rinteg(x,f,fint,n,start)
      function rinteg(x,f,fint,n,start)
c******************************************************************************
c     This routine is from ATLAS6
* Copied from MOOG 06/04-2001
c******************************************************************************

cc      implicit real*8 (a-h,o-z)
      dimension x(5000), f(5000), fint(5000)
      dimension a(5000), b(5000), c(5000)

      call parcoe (f,x,a,b,c,n)
      fint(1) = start
      rinteg = start
      n1 = n - 1
      do 10 i=1,n1
         fint(i+1)= (a(i)+b(i)/2.*(x(i+1)+x(i))+
     .     c(i)/3.*((x(i+1)+x(i))*x(i+1)+x(i)*x(i)))*(x(i+1)-x(i))
10    rinteg = rinteg + fint(i+1)

      return
      end

      subroutine parcoe(f,x,a,b,c,n)

cc      implicit real*8 (a-h,o-z)
      dimension f(5000), x(5000), a(5000), b(5000), c(5000)

      c(1)=0.
      b(1)=(f(2)-f(1))/(x(2)-x(1))
      a(1)=f(1)-x(1)*b(1)
      n1=n-1
      c(n)=0.
      b(n)=(f(n)-f(n1))/(x(n)-x(n1))
      a(n)=f(n)-x(n)*b(n)
      if(n.eq.2)return
      do 1 j=2,n1
      j1=j-1
      d=(f(j)-f(j1))/(x(j)-x(j1))
      c(j)=f(j+1)/((x(j+1)-x(j))*(x(j+1)-x(j1)))-f(j)/((x(j)-x(j1))*
     1(x(j+1)-x(j)))+f(j1)/((x(j)-x(j1))*(x(j+1)-x(j1)))
      b(j)=d-(x(j)+x(j1))*c(j)
    1 a(j)=f(j1)-x(j1)*d+x(j)*x(j1)*c(j)
      c(2)=0.
      b(2)=(f(3)-f(2))/(x(3)-x(2))
      a(2)=f(2)-x(2)*b(2)
      c(3)=0.
      b(3)=(f(4)-f(3))/(x(4)-x(3))
      a(3)=f(3)-x(3)*b(3)
      if(c(j).eq.0.)go to 2
      j1=j+1
      wt=abs(c(j1))/(abs(c(j1))+abs(c(j)))
      a(j)=a(j1)+wt*(a(j)-a(j1))
      b(j)=b(j1)+wt*(b(j)-b(j1))
      c(j)=c(j1)+wt*(c(j)-c(j1))
    2 continue
      a(n1)=a(n)
      b(n1)=b(n)
      c(n1)=c(n)
      return
      end


subroutine react(Xin, T, rho, tmax, Xout, ierr)

   use network
   use rpar_indices
   use bl_types
   use bl_constants_module

   implicit none
   !$acc routine(dgesv) seq

   ! do a simple first-order backward Euler method for integrating
   ! a stiff-system of ODEs.

   ! Note: this should not been seen as a science code, but rather
   ! just used to test ideas about putting reactions on GPUs

   interface
      subroutine rhs(n, t, y, ydot, rpar, ipar)
         !$acc routine seq
         import dp_t
         integer,         intent(in   ) :: n, ipar
         real(kind=dp_t), intent(in   ) :: y(n), t
         real(kind=dp_t), intent(  out) :: ydot(n)
         real(kind=dp_t), intent(inout) :: rpar(:)
      end subroutine rhs
   end interface
   real(kind=dp_t), intent(in)  :: Xin(:,:), T(:), rho(:), tmax
   real(kind=dp_t), intent(out) :: Xout(:,:)
   integer,          intent(out) :: ierr

   real(kind=dp_t) :: time, dt, I

   integer :: m, n

   real(kind=dp_t) :: dXdt(nspec)
   real(kind=dp_t) :: X1(nspec), X2(nspec), dX1dt(nspec), dX2dt(nspec)
   real(kind=dp_t) :: X_n(nspec), X_np1(nspec), dX(nspec), dfdX(nspec)
   real(kind=dp_t) :: A(nspec, nspec), J(nspec, nspec), b(nspec)
   real(kind=dp_t), allocatable :: scratch(:)
   integer :: info

   real(kind=dp_t) :: eps = 1.d-8

   real(kind=dp_t) :: rpar(n_rpar_comps)
   integer :: ipar

   integer :: ipiv(nspec)

   integer :: ic12, io16

   real(kind=dp_t) :: tol = 1.d-6
   integer :: max_iter = 10
   integer :: iter, npts, p
   logical :: converged

   !ic12 = network_species_index("carbon-12")
   !io16 = network_species_index("oxygen-16")
   ic12 = ic12_
   io16 = io16_
   npts = size(T)
   ierr = 0
   allocate(scratch(npts))
   scratch = 0.0

   !Start OpenACC here.  This is about where we would want to start it for a
   !higher order, vectorized integrator.
   !Note: print statements don't play nice with GPUs, so
   !      they're commented out.

   !$acc data copyin(Xin, T, rho, tmax, eps, tol, max_iter, ic12, io16)        &
   !$acc copyout(Xout)                                                         &
   !$acc copy(ierr)

   !$acc kernels

   ierr = 0
   !$acc loop gang vector reduction(max:ierr)                                  &
   !$acc private(m,n,iter,I,time,dt,converged)                                 &
   !$acc private(dXdt, X1, X2, dX1dt, dX2dt, X_n, X_np1, dX, A, J, b)          &
   !$acc private(info, ipiv, rpar, ipar)
   !!$omp parallel do private(m,n,iter,I,time,dt,converged)                     &
   !!$omp private(dXdt, X1, X2, dX1dt, dX2dt, X_n, X_np1, dX, A, J, b)          &
   !!$omp private(info, ipiv, rpar, ipar)
   do p=1, npts
      ! get an estimate of the timestep by looking at the RHS
      ! dt = min{X/(dX/dt)}
      rpar(irp_dens) = rho(p)
      rpar(irp_temp) = T(p)
      rpar(irp_o16) = Xin(io16,p)

      X_n(:) = Xin(:,p)

      call rhs(nspec, ZERO, X_n, dXdt, rpar, ipar)
      !print *, p, ': dXdt = ', dXdt
      !scratch(p) = dXdt(1)

      dt = 1.d33
      dt = 0.1*min(dt, abs(Xin(ic12,p)/dXdt(ic12)))

      !print *, p, ': dt = ', dt

      ! do the integration
      time = ZERO
      do while (time < tmax)

         !print *, p, ': t = ', time

         converged = .false.

         ! initial guess
         X_np1(:) = X_n(:)

         do iter = 1, max_iter

            ! construct a numerical Jacobian via simple differencing
            ! Lapack matrix ordering is described here:
            ! http://www.netlib.org/lapack/lug/node116.html#subsecarrayargs
            ! in general, A(i,j) holds matrix element a_{i,j}

            ! J_{m,n} = df_m/dX_n
            do n = 1, nspec
               X1(:) = X_np1(:)
               X1(n) = X1(n) + eps

               X2(:) = X_np1(:)
               X2(n) = X2(n) - eps

               call rhs(nspec, ZERO, X1, dX1dt, rpar, ipar)
               call rhs(nspec, ZERO, X2, dX2dt, rpar, ipar)

               do m = 1, nspec
                  J(m,n) = 0.5d0*(dX2dt(m) - dX1dt(m))/(X2(n) - X1(n))
               enddo
            enddo

            ! construct the matrix for the linear system
            ! (I - dt J) dX^{n+1} = rhs
            do n = 1, nspec
               do m = 1, nspec
                  if (m == n) then
                     I = 1.0d0
                  else
                     I = 0.0d0
                  endif

                  A(m,n) = I - dt*J(m,n)
               enddo
            enddo

            ! construct the RHS
            call rhs(nspec, ZERO, X_np1, dXdt, rpar, ipar)
            b(:) = X_n(:) - X_np1(:) + dt*dXdt(:)

            ! solve the linear system -- we'll just use Lapack.  Note that the
            ! input b is overwritten on output
            call dgesv(nspec, 1, A, nspec, ipiv, b, nspec, info)

            dX(:) = b(:)

            X_np1(:) = X_np1(:) + dX(:)

            ! compare to see if we converged
            if (abs(dX(1)) < tol*X_n(1)) then
               converged = .true.
               exit
            endif

         enddo   ! dX iteration loop

         if (.not. converged) then
            ierr = 1
            exit
            !stop 'convergence failure'
         endif

         if (time + dt > tmax) then
            dt = tmax - time
         endif

         X_n(:) = X_np1(:)
         time = time + dt
      enddo

      Xout(:,p) = X_n(:)
   enddo

   !$acc end kernels
   !$acc end data

end subroutine react


c
c-----------------------------------------------------------------------
c
c
      subroutine p18(xupw,yupw,n)
      implicit double precision(a-h,o-z)
      dimension xupw(n),yupw(n)
      common/p18c/ delta,pmu0,theta1
c
c     # find the upper wall of the rarefaction channel for problem 18
c
      pi2 = datan(1.d0)*2.d0
      delta = dsqrt(2.4d0/0.4d0)
      amach = 1.30255d0
      q0 = 1.d0
      a0 = q0/amach
      p0 = 9.04545d0
      rho0 = 1.4d0*p0/a0**2
      dmu0 = dasin(1.d0/amach)
      pmu0 = delta*datan(delta*dtan(dmu0)) - dmu0
      h = 1.7d0/dfloat(n)
      xw0 = .1d0
      yw0 = .302d0
      width0 = .2d0
      theta0 = 0.d0
      x0 = xw0 + width0/dtan(theta0+dmu0)
      y0 = yw0 + width0
      xupw(1) = 0.d0
      yupw(1) = y0
      xupw(2) = x0
      yupw(2) = y0
c
      do 10 i=1,n-2
	 xw = xw0 + i*h
	 yw = p18yw(xw)
	 theta = p18th(xw)
	 dmu = p18mu(theta)
	 aratio = dsqrt((1.d0+0.4d0/(2.d0*dsin(dmu0)**2)) /
     &        (1.d0+0.4d0/(2.d0*dsin(dmu)**2)))
	 q = a0*aratio/dsin(dmu)
	 aa = a0*aratio
	 p = p0*((1.d0+0.4d0/(2.d0*dsin(dmu0)**2)) /
     &        (1.d0+0.4d0/(2.d0*dsin(dmu)**2)))**(1.4d0/0.4d0)
	 rho = 1.4d0*p/aa**2
	 width = rho0*width0*q0 / (rho*q*dcos(pi2-dmu))
	 x = xw + width*dcos(theta+dmu)
	 y = yw + width*dsin(theta+dmu)
	 xupw(i+2) = x
	 yupw(i+2) = y
  10     continue
      return
      end


!-------------------------------------------------------------------------------
! Copyright (c) 2019 FrontISTR Commons
! This software is released under the MIT License, see LICENSE.txt
!-------------------------------------------------------------------------------
!> This module provides function to check input data of 2d static analysis
module m_precheck_LIB_2d
contains
  !***********************************************************************
  !  2D Element: PreCheck
  !    PRE_231( xx,yy,thick,vol,almax,almin )
  !    PRE_241( xx,yy,thick,vol,almax,almin )
  !    PRE_232( xx,yy,thick,vol,almax,almin )
  !    PRE_242( xx,yy,thick,vol,almax,almin )
  !***********************************************************************
  !----------------------------------------------------------------------*
  subroutine PRE_231( XX,YY,thick,vol,almax,almin )
    !----------------------------------------------------------------------*
    !
    ! CALCULATION 2D 3 NODE PLANE ELEMENT
    !
    use hecmw
    use gauss_integration
    implicit none
    ! I/F VARIABLES
    real(kind=kreal) XX(*),YY(*),thick,vol,almax,almin
    ! LOCAL VARIABLES
    integer(kind=kint) NN
    integer(kind=kint) NG
    parameter(NN=3,NG=2)
    real(kind=kreal) H(NN),HL1(NN),HL2(NN),HL3(NN)
    integer(kind=kint) L1,L2,I
    real(kind=kreal) X1,X2,X3,XL1,XL2
    real(kind=kreal) RI,SI,RP,SP,RM,SM
    real(kind=kreal) XJ11,XJ21,XJ12,XJ22,DET,WG,area
    real(kind=kreal) a1,a2,a3
    !C
    area = 0.0
    vol  = 0.0
    !* LOOP OVER ALL INTEGRATION POINTS
    do L2=1,NG
      XL2=XG(NG,L2)
      X2 =(XL2+1.0)*0.5
      do L1=1,NG
        XL1=XG(NG,L1)
        X1=0.5*(1.0-X2)*(XL1+1.0)
        !  INTERPOLATION FUNCTION
        X3=1.0-X1-X2
        H(1)=X1
        H(2)=X2
        H(3)=X3
        !  DERIVATIVE OF INTERPOLATION FUNCTION
        !  FOR L1-COORDINATE
        HL1(1)=1.0
        HL1(2)=0.0
        HL1(3)=0.0
        !  FOR L2-COORDINATE
        HL2(1)=0.0
        HL2(2)=1.0
        HL2(3)=0.0
        !  FOR L3-COORDINATE
        HL3(1)=0.0
        HL3(2)=0.0
        HL3(3)=1.0
        !  JACOBI MATRIX
        XJ11=0.0
        XJ21=0.0
        XJ12=0.0
        XJ22=0.0
        do I=1,NN
          XJ11=XJ11+(HL1(I)-HL3(I))*XX(I)
          XJ21=XJ21+(HL2(I)-HL3(I))*XX(I)
          XJ12=XJ12+(HL1(I)-HL3(I))*YY(I)
          XJ22=XJ22+(HL2(I)-HL3(I))*YY(I)
        enddo
        DET=XJ11*XJ22-XJ21*XJ12
        WG=WGT(NG,L1)*WGT(NG,L2)*DET*(1.0-X2)*0.25
        do I = 1, NN
          area = area + H(I)*WG
        enddo
      enddo
    enddo

    vol = area * thick
    a1 = sqrt( (xx(2)-xx(1))**2+(yy(2)-yy(1))**2 )
    a2 = sqrt( (xx(3)-xx(2))**2+(yy(3)-yy(2))**2 )
    a3 = sqrt( (xx(1)-xx(3))**2+(yy(1)-yy(3))**2 )
    almax = dmax1( a1,a2,a3 )
    almin = dmin1( a1,a2,a3 )

  end subroutine PRE_231
  !----------------------------------------------------------------------*
  subroutine PRE_241( XX,YY,thick,vol,almax,almin )
    !----------------------------------------------------------------------*
    !
    ! CALCULATION 2D 4 NODE PLANE ELEMENT
    !
    use hecmw
    use gauss_integration
    implicit none
    ! I/F VARIABLES
    real(kind=kreal) XX(*),YY(*),thick,vol,almax,almin
    ! LOCAL VARIABLES
    integer(kind=kint) NN
    integer(kind=kint) NG
    parameter(NN=4,NG=2)
    real(kind=kreal) H(NN),HR(NN),HS(NN)
    integer(kind=kint) LX,LY,I
    real(kind=kreal) RI,SI,RP,SP,RM,SM
    real(kind=kreal) XJ11,XJ21,XJ12,XJ22,DET,WG,area
    real(kind=kreal) a1,a2,a3,a4
    !C
    area = 0.0
    vol  = 0.0
    !* LOOP OVER ALL INTEGRATION POINTS
    do LX=1,NG
      RI=XG(NG,LX)
      do LY=1,NG
        SI=XG(NG,LY)
        RP=1.0+RI
        SP=1.0+SI
        RM=1.0-RI
        SM=1.0-SI
        H(1)=0.25*RM*SM
        H(2)=0.25*RP*SM
        H(3)=0.25*RP*SP
        H(4)=0.25*RM*SP
        HR(1)=-.25*SM
        HR(2)= .25*SM
        HR(3)= .25*SP
        HR(4)=-.25*SP
        HS(1)=-.25*RM
        HS(2)=-.25*RP
        HS(3)= .25*RP
        HS(4)= .25*RM
        XJ11=0.0
        XJ21=0.0
        XJ12=0.0
        XJ22=0.0
        do I=1,NN
          XJ11=XJ11+HR(I)*XX(I)
          XJ21=XJ21+HS(I)*XX(I)
          XJ12=XJ12+HR(I)*YY(I)
          XJ22=XJ22+HS(I)*YY(I)
        enddo
        DET=XJ11*XJ22-XJ21*XJ12
        WG=WGT(NG,LX)*WGT(NG,LY)*DET
        do I = 1, NN
          area = area + H(I)*WG
        enddo
      enddo
    enddo

    vol = area * thick
    a1 = sqrt( (xx(2)-xx(1))**2+(yy(2)-yy(1))**2 )
    a2 = sqrt( (xx(3)-xx(2))**2+(yy(3)-yy(2))**2 )
    a3 = sqrt( (xx(4)-xx(3))**2+(yy(4)-yy(3))**2 )
    a4 = sqrt( (xx(1)-xx(4))**2+(yy(1)-yy(4))**2 )
    almax = dmax1( a1,a2,a3,a4 )
    almin = dmin1( a1,a2,a3,a4 )

  end subroutine PRE_241
  !----------------------------------------------------------------------*
  subroutine PRE_232( XX,YY,thick,vol,almax,almin )
    !----------------------------------------------------------------------*
    !
    ! CALCULATION 2D 6 NODE PLANE ELEMENT
    !
    use hecmw
    use gauss_integration
    implicit none
    ! I/F VARIABLES
    real(kind=kreal) XX(*),YY(*),thick,vol,tline,almax,almin
    ! LOCAL VARIABLES
    integer(kind=kint) NN
    integer(kind=kint) NG
    parameter(NN=6,NG=3)
    real(kind=kreal) H(NN),HL1(NN),HL2(NN),HL3(NN)
    integer(kind=kint) L1,L2,I
    real(kind=kreal) X1,X2,X3,XL1,XL2
    real(kind=kreal) RI,SI,RP,SP,RM,SM
    real(kind=kreal) XJ11,XJ21,XJ12,XJ22,DET,WG,area
    real(kind=kreal)  a1,a2,AL1,AL2,AL3

    !*************************
    area = 0.0
    vol  = 0.0
    !* LOOP OVER ALL INTEGRATION POINTS
    do L2=1,NG
      XL2=XG(NG,L2)
      X2 =(XL2+1.0)*0.5
      do L1=1,NG
        XL1=XG(NG,L1)
        X1=0.5*(1.0-X2)*(XL1+1.0)
        !  INTERPOLATION FUNCTION
        X3=1.0-X1-X2
        H(1)= X1*(2.0*X1-1.)
        H(2)= X2*(2.0*X2-1.)
        H(3)= X3*(2.0*X3-1.)
        H(4)= 4.0*X1*X2
        H(5)= 4.0*X2*X3
        H(6)= 4.0*X1*X3
        !  DERIVATIVE OF INTERPOLATION FUNCTION
        !  FOR L1-COORDINATE
        HL1(1)=4.0*X1-1.0
        HL1(2)= 0.0
        HL1(3)= 0.0
        HL1(4)= 4.0*X2
        HL1(5)= 0.0
        HL1(6)= 4.0*X3
        !  FOR L2-COORDINATE
        HL2(1)= 0.0
        HL2(2)= 4.0*X2-1.0
        HL2(3)= 0.0
        HL2(4)= 4.0*X1
        HL2(5)= 4.0*X3
        HL2(6)= 0.0
        !  FOR L3-COORDINATE
        HL3(1)= 0.0
        HL3(2)= 0.0
        HL3(3)= 4.0*X3-1.0
        HL3(4)= 0.0
        HL3(5)= 4.0*X2
        HL3(6)= 4.0*X1
        !  JACOBI MATRIX
        XJ11=0.0
        XJ21=0.0
        XJ12=0.0
        XJ22=0.0
        do I=1,NN
          XJ11=XJ11+(HL1(I)-HL3(I))*XX(I)
          XJ21=XJ21+(HL2(I)-HL3(I))*XX(I)
          XJ12=XJ12+(HL1(I)-HL3(I))*YY(I)
          XJ22=XJ22+(HL2(I)-HL3(I))*YY(I)
        enddo
        DET=XJ11*XJ22-XJ21*XJ12
        WG=WGT(NG,L1)*WGT(NG,L2)*DET*(1.0-X2)*0.25
        do I = 1, NN
          area = area + H(I)*WG
        enddo
      enddo
    enddo

    vol = area * thick
    a1 = sqrt( (xx(4)-xx(1))**2+(yy(4)-yy(1))**2 )
    a2 = sqrt( (xx(2)-xx(4))**2+(yy(2)-yy(4))**2 )
    AL1 = a1 + a2
    a1 = sqrt( (xx(5)-xx(2))**2+(yy(5)-yy(2))**2 )
    a2 = sqrt( (xx(3)-xx(5))**2+(yy(3)-yy(5))**2 )
    AL2 = a1 + a2
    a1 = sqrt( (xx(6)-xx(3))**2+(yy(6)-yy(3))**2 )
    a2 = sqrt( (xx(1)-xx(6))**2+(yy(1)-yy(6))**2 )
    AL3 = a1 + a2
    almax = dmax1( AL1,AL2,AL3 )
    almin = dmin1( AL1,AL2,AL3 )

  end subroutine  PRE_232
  !----------------------------------------------------------------------*
  subroutine PRE_242( XX,YY,thick,vol,almax,almin )
    !----------------------------------------------------------------------*
    !
    ! CALCULATION 2D 8 NODE PLANE ELEMENT
    !
    use hecmw
    use gauss_integration
    implicit none
    ! I/F VARIABLES
    real(kind=kreal) XX(*),YY(*),thick,vol,almax,almin
    ! LOCAL VARIABLES
    integer(kind=kint) NN
    integer(kind=kint) NG
    parameter(NN=8,NG=3)
    real(kind=kreal) H(NN),HR(NN),HS(NN)
    integer(kind=kint) LX,LY,I
    real(kind=kreal) RI,SI,RP,SP,RM,SM
    real(kind=kreal) XJ11,XJ21,XJ12,XJ22,DET,WG,area
    !REAL(kind=kreal) RX(8),SX(8)
    real(kind=kreal)  a1,a2,AL1,AL2,AL3,AL4
    !DATA RX/-1., 1.,1.,-1., 0., 1., 0., -1./
    !DATA SX/-1.,-1.,1., 1.,-1., 0., 1.,  0./
    !*************************
    area = 0.0
    vol  = 0.0
    !* LOOP OVER ALL INTEGRATION POINTS
    do LX=1,NG
      RI=XG(NG,LX)
      do LY=1,NG
        SI=XG(NG,LY)
        RP=1.0+RI
        SP=1.0+SI
        RM=1.0-RI
        SM=1.0-SI
        H(1)=0.25*RM*SM*(-1.0-RI-SI)
        H(2)=0.25*RP*SM*(-1.0+RI-SI)
        H(3)=0.25*RP*SP*(-1.0+RI+SI)
        H(4)=0.25*RM*SP*(-1.0-RI+SI)
        H(5)=0.5*(1.0-RI*RI)*(1.0-SI)
        H(6)=0.5*(1.0-SI*SI)*(1.0+RI)
        H(7)=0.5*(1.0-RI*RI)*(1.0+SI)
        H(8)=0.5*(1.0-SI*SI)*(1.0-RI)
        HR(1)=-.25*SM*(-1.0-RI-SI)-0.25*RM*SM
        HR(2)= .25*SM*(-1.0+RI-SI)+0.25*RP*SM
        HR(3)= .25*SP*(-1.0+RI+SI)+0.25*RP*SP
        HR(4)=-.25*SP*(-1.0-RI+SI)-0.25*RM*SP
        HR(5)=-RI*(1.0-SI)
        HR(6)= 0.5*(1.0-SI*SI)
        HR(7)=-RI*(1.0+SI)
        HR(8)=-0.5*(1.0-SI*SI)
        HS(1)=-.25*RM*(-1.0-RI-SI)-0.25*RM*SM
        HS(2)=-.25*RP*(-1.0+RI-SI)-0.25*RP*SM
        HS(3)= .25*RP*(-1.0+RI+SI)+0.25*RP*SP
        HS(4)= .25*RM*(-1.0-RI+SI)+0.25*RM*SP
        HS(5)=-0.5*(1.0-RI*RI)
        HS(6)=-SI *(1.0+RI)
        HS(7)= 0.5*(1.0-RI*RI)
        HS(8)= -SI*(1.0-RI)
        XJ11=0.0
        XJ21=0.0
        XJ12=0.0
        XJ22=0.0
        do I=1,NN
          XJ11=XJ11+HR(I)*XX(I)
          XJ21=XJ21+HS(I)*XX(I)
          XJ12=XJ12+HR(I)*YY(I)
          XJ22=XJ22+HS(I)*YY(I)
        enddo
        DET=XJ11*XJ22-XJ21*XJ12
        WG=WGT(NG,LX)*WGT(NG,LY)*DET
        do I = 1, NN
          area = area + H(I)*WG
        enddo
      enddo
    enddo

    vol = area * thick
    a1 = sqrt( (xx(5)-xx(1))**2+(yy(5)-yy(1))**2 )
    a2 = sqrt( (xx(2)-xx(5))**2+(yy(2)-yy(5))**2 )
    AL1 = a1 + a2
    a1 = sqrt( (xx(6)-xx(2))**2+(yy(6)-yy(2))**2 )
    a2 = sqrt( (xx(3)-xx(6))**2+(yy(3)-yy(6))**2 )
    AL2 = a1 + a2
    a1 = sqrt( (xx(7)-xx(3))**2+(yy(7)-yy(3))**2 )
    a2 = sqrt( (xx(4)-xx(7))**2+(yy(4)-yy(7))**2 )
    AL3 = a1 + a2
    a1 = sqrt( (xx(8)-xx(4))**2+(yy(8)-yy(4))**2 )
    a2 = sqrt( (xx(1)-xx(8))**2+(yy(1)-yy(8))**2 )
    AL4 = a1 + a2
    almax = dmax1( AL1,AL2,AL3,AL4 )
    almin = dmin1( AL1,AL2,AL3,AL4 )

  end subroutine PRE_242
end module m_precheck_LIB_2d