      SUBROUTINE MB04FD( JOB, COMPQ, N, A, LDA, DE, LDDE, B, LDB, FG,
     $                   LDFG, Q, LDQ, ALPHAR, ALPHAI, BETA, IWORK,
     $                   DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute the eigenvalues of a real N-by-N skew-Hamiltonian/
C     skew-Hamiltonian pencil aS - bT with
C
C           (  A  D  )         (  B  F  )
C       S = (        ) and T = (        ).                           (1)
C           (  E  A' )         (  G  B' )
C
C     Optionally, if JOB = 'T', the pencil aS - bT will be transformed
C     to the structured Schur form: an orthogonal transformation matrix
C     Q is computed such that
C
C                     (  Aout  Dout  )
C       J Q' J' S Q = (              ), and
C                     (   0    Aout' )
C                                                                    (2)
C                     (  Bout  Fout  )            (  0  I  )
C       J Q' J' T Q = (              ), where J = (        ),
C                     (   0    Bout' )            ( -I  0  )
C
C     Aout is upper triangular, and Bout is upper quasi-triangular. The
C     notation M' denotes the transpose of the matrix M.
C     Optionally, if COMPQ = 'I' or COMPQ = 'U', the orthogonal
C     transformation matrix Q will be computed.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     JOB     CHARACTER*1
C             Specifies the computation to be performed, as follows:
C             = 'E':  compute the eigenvalues only; S and T will not
C                     necessarily be put into skew-Hamiltonian
C                     triangular form (2);
C             = 'T':  put S and T into skew-Hamiltonian triangular form
C                     (2), and return the eigenvalues in ALPHAR, ALPHAI
C                     and BETA.
C
C     COMPQ   CHARACTER*1
C             Specifies whether to compute the orthogonal transformation
C             matrix Q as follows:
C             = 'N':  Q is not computed;
C             = 'I':  the array Q is initialized internally to the unit
C                     matrix, and the orthogonal matrix Q is returned;
C             = 'U':  the array Q contains an orthogonal matrix Q0 on
C                     entry, and the product Q0*Q is returned, where Q
C                     is the product of the orthogonal transformations
C                     that are applied to the pencil aS - bT to reduce
C                     S and T to the forms in (2), for COMPQ = 'I'.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the pencil aS - bT.  N >= 0, even.
C
C     A       (input/output) DOUBLE PRECISION array, dimension
C                            (LDA, N/2)
C             On entry, the leading N/2-by-N/2 part of this array must
C             contain the matrix A.
C             On exit, if JOB = 'T', the leading N/2-by-N/2 part of this
C             array contains the matrix Aout; otherwise, it contains
C             meaningless elements, except for the diagonal blocks,
C             which are correctly set.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= MAX(1, N/2).
C
C     DE      (input/output) DOUBLE PRECISION array, dimension
C                            (LDDE, N/2+1)
C             On entry, the leading N/2-by-N/2 strictly lower triangular
C             part of this array must contain the strictly lower
C             triangular part of the skew-symmetric matrix E, and the
C             N/2-by-N/2 strictly upper triangular part of the submatrix
C             in the columns 2 to N/2+1 of this array must contain the
C             strictly upper triangular part of the skew-symmetric
C             matrix D.
C             The entries on the diagonal and the first superdiagonal of
C             this array are not referenced, but are assumed to be zero.
C             On exit, if JOB = 'T', the leading N/2-by-N/2 strictly
C             upper triangular part of the submatrix in the columns
C             2 to N/2+1 of this array contains the strictly upper
C             triangular part of the skew-symmetric matrix Dout.
C             If JOB = 'E', the leading N/2-by-N/2 strictly upper
C             triangular part of the submatrix in the columns 2 to N/2+1
C             of this array contains the strictly upper triangular part
C             of the skew-symmetric matrix D just before the application
C             of the QZ algorithm. The remaining entries are
C             meaningless.
C
C     LDDE    INTEGER
C             The leading dimension of the array DE.
C             LDDE >= MAX(1, N/2).
C
C     B       (input/output) DOUBLE PRECISION array, dimension
C                            (LDB, N/2)
C             On entry, the leading N/2-by-N/2 part of this array must
C             contain the matrix B.
C             On exit, if JOB = 'T', the leading N/2-by-N/2 part of this
C             array contains the matrix Bout; otherwise, it contains
C             meaningless elements, except for the diagonal 1-by-1 and
C             2-by-2 blocks, which are correctly set.
C
C     LDB     INTEGER
C             The leading dimension of the array B.  LDB >= MAX(1, N/2).
C
C     FG      (input/output) DOUBLE PRECISION array, dimension
C                            (LDFG, N/2+1)
C             On entry, the leading N/2-by-N/2 strictly lower triangular
C             part of this array must contain the strictly lower
C             triangular part of the skew-symmetric matrix G, and the
C             N/2-by-N/2 strictly upper triangular part of the submatrix
C             in the columns 2 to N/2+1 of this array must contain the
C             strictly upper triangular part of the skew-symmetric
C             matrix F.
C             The entries on the diagonal and the first superdiagonal of
C             this array are not referenced, but are assumed to be zero.
C             On exit, if JOB = 'T', the leading N/2-by-N/2 strictly
C             upper triangular part of the submatrix in the columns
C             2 to N/2+1 of this array contains the strictly upper
C             triangular part of the skew-symmetric matrix Fout.
C             If JOB = 'E', the leading N/2-by-N/2 strictly upper
C             triangular part of the submatrix in the columns 2 to N/2+1
C             of this array contains the strictly upper triangular part
C             of the skew-symmetric matrix F just before the application
C             of the QZ algorithm. The remaining entries are
C             meaningless.
C
C     LDFG    INTEGER
C             The leading dimension of the array FG.
C             LDFG >= MAX(1, N/2).
C
C     Q       (input/output) DOUBLE PRECISION array, dimension (LDQ, N)
C             On entry, if COMPQ = 'U', then the leading N-by-N part of
C             this array must contain a given matrix Q0, and on exit,
C             the leading N-by-N part of this array contains the product
C             of the input matrix Q0 and the transformation matrix Q
C             used to transform the matrices S and T.
C             On exit, if COMPQ = 'I', then the leading N-by-N part of
C             this array contains the orthogonal transformation matrix
C             Q.
C             If COMPQ = 'N', this array is not referenced.
C
C     LDQ     INTEGER
C             The leading dimension of the array Q.
C             LDQ >= 1,         if COMPQ = 'N';
C             LDQ >= MAX(1, N), if COMPQ = 'I' or COMPQ = 'U'.
C
C     ALPHAR  (output) DOUBLE PRECISION array, dimension (N/2)
C             The real parts of each scalar alpha defining an eigenvalue
C             of the pencil aS - bT.
C
C     ALPHAI  (output) DOUBLE PRECISION array, dimension (N/2)
C             The imaginary parts of each scalar alpha defining an
C             eigenvalue of the pencil aS - bT.
C             If ALPHAI(j) is zero, then the j-th eigenvalue is real; if
C             positive, then the j-th and (j+1)-st eigenvalues are a
C             complex conjugate pair.
C
C     BETA    (output) DOUBLE PRECISION array, dimension (N/2)
C             The scalars beta that define the eigenvalues of the pencil
C             aS - bT.
C             Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and
C             beta = BETA(j) represent the j-th eigenvalue of the pencil
C             aS - bT, in the form lambda = alpha/beta. Since lambda may
C             overflow, the ratios should not, in general, be computed.
C             Due to the skew-Hamiltonian/skew-Hamiltonian structure of
C             the pencil, every eigenvalue occurs twice and thus it has
C             only to be saved once in ALPHAR, ALPHAI and BETA.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (N/2+1)
C             On exit, IWORK(1) contains the number of (pairs of)
C             possibly inaccurate eigenvalues, q <= N/2, and the
C             nonzero absolute values in IWORK(2), ..., IWORK(N/2+1) are
C             indices of the possibly inaccurate eigenvalues, as well as
C             of the corresponding 1-by-1 or 2-by-2 diagonal blocks in
C             the arrays A and B on exit. The 2-by-2 blocks correspond
C             to negative values in IWORK. One negative value is stored
C             for each such eigenvalue pair. Its modulus indicates the
C             starting index of a 2-by-2 block.
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) returns the optimal LDWORK;
C             DWORK(2) and DWORK(3) contain the Frobenius norms of the
C             matrices S and T on entry. These norms are used in the
C             tests to decide that some eigenvalues are considered as
C             unreliable.
C             On exit, if INFO = -19, DWORK(1) returns the minimum
C             value of LDWORK.
C
C     LDWORK  INTEGER
C             The dimension of the array DWORK.
C             LDWORK >= MAX(3,N/2),        if JOB = 'E' and COMPQ = 'N';
C             LDWORK >= MAX(3,N**2/4+N/2), if JOB = 'T' and COMPQ = 'N';
C             LDWORK >= MAX(1,3*N**2/4),   if               COMPQ<> 'N'.
C             For good performance LDWORK should generally be larger.
C
C             If LDWORK = -1, then a workspace query is assumed;
C             the routine only calculates the optimal size of the
C             DWORK array, returns this value as the first entry of
C             the DWORK array, and no error message related to LDWORK
C             is issued by XERBLA.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0: succesful exit;
C             < 0: if INFO = -i, the i-th argument had an illegal value;
C             = 1: QZ iteration failed in the LAPACK Library routine
C                  DHGEQZ. (QZ iteration did not converge or computation
C                  of the shifts failed.)
C             = 2: warning: the pencil is numerically singular.
C
C     METHOD
C
C     The algorithm uses Givens rotations and Householder reflections to
C     annihilate elements in S and T such that S is in skew-Hamiltonian
C     triangular form and T is in skew-Hamiltonian Hessenberg form:
C
C         (  A1  D1  )      (  B1  F1  )
C     S = (          ), T = (          ),
C         (   0  A1' )      (   0  B1' )
C
C     where A1 is upper triangular and B1 is upper Hessenberg.
C     Subsequently, the QZ algorithm is applied to the pencil aA1 - bB1
C     to determine orthogonal matrices Q1 and Q2 such that
C     Q2' A1 Q1 is upper triangular and Q2' B1 Q1 is upper quasi-
C     triangular.
C     See also page 40 in [1] for more details.
C
C     REFERENCES
C
C     [1] Benner, P., Byers, R., Mehrmann, V. and Xu, H.
C         Numerical Computation of Deflating Subspaces of Embedded
C         Hamiltonian Pencils.
C         Tech. Rep. SFB393/99-15, Technical University Chemnitz,
C         Germany, June 1999.
C
C     NUMERICAL ASPECTS
C                                                               3
C     The algorithm is numerically backward stable and needs O(N )
C     real floating point operations.
C
C     CONTRIBUTOR
C
C     Matthias Voigt, Fakultaet fuer Mathematik, Technische Universitaet
C     Chemnitz, March 31, 2009.
C     V. Sima, Nov. 2009 (SLICOT version of the routine ZSHUTR).
C
C     REVISIONS
C
C     V. Sima, Dec. 2010, Jan. 2011, Aug. 2011, Aug. 2016, Sep. 2016,
C     Nov. 2016, Apr. 2020.
C     M. Voigt, Jan. 2012.
C
C     KEYWORDS
C
C     QZ algorithm, upper (quasi-)triangular matrix,
C     skew-Hamiltonian/skew-Hamiltonian pencil.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO, HALF, ONE, TWO, THREE, TEN
      PARAMETER          ( ZERO = 0.0D+0, HALF  = 0.5D+0, ONE = 1.0D+0,
     $                     TWO  = 2.0D+0, THREE = 3.0D+0, TEN  = 1.0D+1
     $                      )
C
C     .. Scalar Arguments ..
      CHARACTER          COMPQ, JOB
      INTEGER            INFO, LDA, LDB, LDDE, LDFG, LDQ, LDWORK, N
C
C     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), ALPHAI( * ), ALPHAR( * ),
     $                   B( LDB, * ), BETA( * ), DE( LDDE, * ),
     $                   DWORK( * ), FG( LDFG, * ), Q( LDQ, * )
      INTEGER            IWORK( * )
C
C     .. Local Scalars ..
      LOGICAL            LCMPQ, LINIQ, LQUERY, LTRI, LUPDQ, PSNG,
     $                   SING
      CHARACTER*16       CMPQ, CMPSC, CMPZ
      INTEGER            IQ1, IQ2, IWRK, J, K, M, M1, MINDW, MJ1, MJ2,
     $                   MJ3, MK2, MK3, MM, NBETA0, NINF, OPTDW, P
      DOUBLE PRECISION   CO, MU, NRM, NRMS, NRMT, NU, SDET, SI, TMP1,
     $                   TMP2, TOLS, TOLT, X1, X2, X3, X4
C
C     .. Local Arrays ..
      DOUBLE PRECISION   DUM( 1 )
C
C     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            MA02OD
      DOUBLE PRECISION   DDOT, DLAMCH, DLANGE, DLANTR, DLAPY2, MA02ID
      EXTERNAL           DDOT, DLAMCH, DLANGE, DLANTR, DLAPY2, LSAME,
     $                   MA02ID, MA02OD
C
C     .. External Subroutines ..
      EXTERNAL           DAXPY, DCOPY, DGEMM, DHGEQZ, DLACPY, DLARF,
     $                   DLARFG, DLARTG, DLAS2, DLASET, DLASSQ, DROT,
     $                   MA02PD, MB01LD, MB01MD, MB01ND, XERBLA
C
C     .. Intrinsic Functions ..
      INTRINSIC          ABS, INT, MAX, MIN, MOD, SIGN, SQRT
C
C     .. Executable Statements ..
C
C     Decode the input arguments.
C
      M  = N/2
      MM = M*M
      M1 = MAX( 1, M )
      LTRI   = LSAME( JOB,   'T' )
      LINIQ  = LSAME( COMPQ, 'I' )
      LUPDQ  = LSAME( COMPQ, 'U' )
      LCMPQ  = LINIQ .OR. LUPDQ
      LQUERY = LDWORK.EQ.-1
C
C     Determine the mode of computations.
C
      IQ1 = 1
      IF( LCMPQ ) THEN
         CMPQ  = 'Initialize'
         CMPZ  = CMPQ
         IQ2   = IQ1 + MM
         IWRK  = IQ2 + MM
         MINDW = MAX( 3, IWRK - 1 + MM )
      ELSE IF( LTRI ) THEN
         CMPQ  = 'Initialize'
         CMPZ  = 'No Computation'
         IQ2   = 1
         IWRK  = IQ2 + MM
         MINDW = MAX( 3, IWRK - 1 + M )
      ELSE
         CMPQ  = 'No Computation'
         CMPZ  = CMPQ
         IQ2   = 1
         IWRK  = 1
         MINDW = MAX( 3, M )
      END IF
      K = IWRK - 1
C
      IF( LTRI ) THEN
         CMPSC = 'Schur Form'
      ELSE
         CMPSC = 'Eigenvalues Only'
      END IF
C
C     Test the input arguments.
C
      INFO = 0
      IF( .NOT.( LSAME( JOB, 'E' ) .OR. LTRI ) ) THEN
         INFO = -1
      ELSE IF( .NOT.( LSAME( COMPQ, 'N' ) .OR. LCMPQ ) ) THEN
         INFO = -2
      ELSE IF( N.LT.0 .OR. MOD( N, 2 ).NE.0 ) THEN
         INFO = -3
      ELSE IF(  LDA.LT.M1 ) THEN
         INFO = -5
      ELSE IF( LDDE.LT.M1 ) THEN
         INFO = -7
      ELSE IF(  LDB.LT.M1 ) THEN
         INFO = -9
      ELSE IF( LDFG.LT.M1 ) THEN
         INFO = -11
      ELSE IF(  LDQ.LT.1 .OR. ( LCMPQ .AND. LDQ.LT.N ) ) THEN
         INFO = -13
      ELSE IF( LDWORK.LT.MINDW .AND. .NOT.LQUERY ) THEN
         DWORK( 1 ) = MINDW
         INFO = -19
      END IF
C
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'MB04FD', -INFO )
         RETURN
      ELSE IF( N.GT.0 .AND. LQUERY ) THEN
         CALL DHGEQZ( CMPSC, CMPQ, CMPZ, M, 1, M, B, LDB, A, LDA,
     $                ALPHAR, ALPHAI, BETA, DWORK, M1, DWORK, M1,
     $                DWORK, -1, INFO )
C
         IF( LCMPQ ) THEN
            OPTDW = K + MAX( K, INT( DWORK( 1 ) ) )
         ELSE IF( LTRI ) THEN
            OPTDW = K + MAX( K - M, INT( DWORK( 1 ) ) )
         ELSE
            OPTDW = INT( DWORK( 1 ) )
         END IF
         DWORK( 1 ) = MAX( OPTDW, MINDW )
         RETURN
      ELSE IF( LQUERY ) THEN
         DWORK( 1 ) = MINDW
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( N.EQ.0 ) THEN
         IWORK( 1 ) = 0
         DWORK( 1 ) = THREE
         DWORK( 2 ) = ZERO
         DWORK( 3 ) = ZERO
         RETURN
      END IF
C
C     Find half of the number of infinite eigenvalues if S is diagonal.
C     Otherwise, find a lower bound of this number.
C
      NINF = 0
      IF( M.EQ.1 ) THEN
         NRM = ZERO
      ELSE
         NRM = DLANTR( 'Max', 'Lower', 'No-diag', M-1, M-1, DE( 2, 1 ),
     $                 LDDE, DWORK ) +
     $         DLANTR( 'Max', 'Upper', 'No-diag', M-1, M-1, DE( 1, 2 ),
     $                 LDDE, DWORK )
      END IF
      IF( NRM.EQ.ZERO ) THEN
         IF( M.EQ.1 ) THEN
            NRMS = ABS( A( 1, 1 ) )
            IF( NRMS.EQ.ZERO )
     $         NINF = 1
         ELSE
            IF( DLANTR( 'Max', 'Lower', 'No-diag', M-1, M-1, A( 2, 1 ),
     $                                   LDA, DWORK ).EQ.ZERO .AND.
     $          DLANTR( 'Max', 'Upper', 'No-diag', M-1, M-1, A( 1, 2 ),
     $                                   LDA, DWORK ).EQ.ZERO ) THEN
               TMP1 = ZERO
               TMP2 = ONE
               CALL DLASSQ( M, A, LDA+1, TMP1, TMP2 )
               NRMS = TMP1*SQRT( TMP2 )
               DO 10 J = 1, M
                  IF( A( J, J ).EQ.ZERO )
     $               NINF = NINF + 1
   10          CONTINUE
            ELSE
               CALL MA02PD( M, M, A, LDA, J, K )
               NINF = MAX( J, K )
               NRMS = DLANGE( 'Frobenius', M, M, A, LDA, DWORK )
            END IF
         END IF
         NRMS = NRMS*SQRT( TWO )
      ELSE
C
C        Incrementing NINF below is due to even multiplicity of
C        eigenvalues for real skew-Hamiltonian matrices.
C
         NINF = MA02OD( 'Skew', M, A, LDA, DE, LDDE )
         IF( MOD( NINF, 2 ).GT.0 )
     $      NINF = NINF + 1
         NINF = NINF/2
         NRMS = MA02ID( 'Skew', 'Frobenius', M, A, LDA, DE, LDDE,
     $                  DWORK )
      END IF
C
      NRMT = MA02ID( 'Skew', 'Frobenius', M, B, LDB, FG, LDFG, DWORK )
C
C     STEP 1: Reduce S to skew-Hamiltonian triangular form.
C
C     Workspace:    need   N, if COMPQ <> 'N';
C                          M, if COMPQ  = 'N'.
C
      IF( LINIQ )
     $   CALL DLASET( 'Full', N, N, ZERO, ONE, Q, LDQ )
C
      DUM( 1 ) = ZERO
C
      DO 20 K = 1, M - 1
C
C        Generate elementary reflector H(k) = I - nu * v * v' to
C        annihilate E(k+2:m,k).
C
         MK2  = MIN( K+2, M )
         MK3  = MK2 + 1
         TMP1 = DE( K+1, K )
         CALL DLARFG( M-K, TMP1, DE( MK2, K ), 1, NU )
         IF( NU.NE.ZERO ) THEN
            DE( K+1, K ) = ONE
C
C           Apply H(k) from both sides to E(k+1:m,k+1:m).
C           Compute  x := nu * E(k+1:m,k+1:m) * v.
C
            CALL MB01MD( 'Lower', M-K, NU, DE( K+1, K+1 ), LDDE,
     $                   DE( K+1, K ), 1, ZERO, DWORK, 1 )
C
C           Compute  w := x - 1/2 * nu * (x'*v) * v in x.
C
            MU = -HALF*NU*DDOT( M-K, DWORK, 1, DE( K+1, K ), 1 )
            CALL DAXPY( M-K, MU, DE( K+1, K ), 1, DWORK, 1 )
C
C           Apply the transformation as a skew-symmetric rank-2 update:
C                E := E + v * w' - w * v'.
C
            CALL MB01ND( 'Lower', M-K, ONE, DE( K+1, K ), 1, DWORK, 1,
     $                   DE( K+1, K+1 ), LDDE )
C
C           Apply H(k) to G(k+1:m,1:k) from the left (and implicitly to
C           G(1:k,k+1:m) from the right).
C
            CALL DLARF( 'Left', M-K, K, DE( K+1, K ), 1, NU,
     $                  FG( K+1, 1 ), LDFG, DWORK )
C
C           Apply H(k) from both sides to G(k+1:m,k+1:m).
C           Compute  x := nu * G(k+1:m,k+1:m) * v.
C
            CALL MB01MD( 'Lower', M-K, NU, FG( K+1, K+1 ), LDFG,
     $                   DE( K+1, K ), 1, ZERO, DWORK, 1 )
C
C           Compute  w := x - 1/2 * nu * (x'*v) * v.
C
            MU = -HALF*NU*DDOT( M-K, DWORK, 1, DE( K+1, K ), 1 )
            CALL DAXPY( M-K, MU, DE( K+1, K ), 1, DWORK, 1 )
C
C           Apply the transformation as a skew-symmetric rank-2 update:
C                G := G + v * w' - w * v'.
C
            CALL MB01ND( 'Lower', M-K, ONE, DE( K+1, K ), 1, DWORK, 1,
     $                   FG( K+1, K+1 ), LDFG )
C
C           Apply H(k) from the right hand side to A(1:m,k+1:m) and
C           B(1:m,k+1:m).
C
            CALL DLARF( 'Right', M, M-K, DE( K+1, K ), 1, NU,
     $                  A( 1, K+1 ), LDA, DWORK )
            CALL DLARF( 'Right', M, M-K, DE( K+1, K ), 1, NU,
     $                  B( 1, K+1 ), LDB, DWORK )
C
            IF( LCMPQ ) THEN
C
C              Apply H(k) from the right hand side to Q(1:n,k+1:m).
C
               CALL DLARF( 'Right', N, M-K, DE( K+1, K ), 1, NU,
     $                     Q( 1, K+1 ), LDQ, DWORK )
            END IF
            DE( K+1, K ) = TMP1
         END IF
C
C        Determine a Givens rotation to annihilate E(k+1,k) from the
C        left.
C
         TMP2 = A( K+1, K )
         CALL DLARTG( TMP2, TMP1, CO, SI, A( K+1, K ) )
C
C        Update A, D and E.
C
         CALL DROT( M-K-1, DE( MK2, K+1 ), 1, A( K+1, MK2 ), LDA, CO,
     $              SI )
         CALL DROT( K, A( 1, K+1 ), 1, DE( 1, K+2 ), 1, CO, SI )
         CALL DROT( M-K-1, DE( K+1, MK3 ), LDDE, A( MK2, K+1 ), 1, CO,
     $              SI )
C
C        Update B, G and F.
C
         CALL DROT( K, FG( K+1, 1 ), LDFG, B( K+1, 1 ), LDB, CO, -SI )
         CALL DROT( M-K-1, FG( MK2, K+1 ), 1, B( K+1, MK2 ), LDB, CO,
     $              SI )
         CALL DROT( K, B( 1, K+1 ), 1, FG( 1, K+2 ), 1, CO, SI )
         CALL DROT( M-K-1, FG( K+1, MK3 ), LDFG, B( MK2, K+1 ), 1, CO,
     $              SI )
C
         IF( LCMPQ ) THEN
C
C           Update Q.
C
            CALL DROT( N, Q( 1, M+K+1 ), 1, Q( 1, K+1 ), 1, CO, -SI )
         END IF
C
C        Generate elementary reflector P(k) to annihilate A(k+1:m,k).
C
         TMP1 = A( K, K )
         CALL DLARFG( M-K+1, TMP1, A( K+1, K ), 1, NU )
         IF( NU.NE.ZERO ) THEN
            A( K, K ) = ONE
C
C           Apply P(k) from the left hand side to A(k:m,k+1:m).
C
            CALL DLARF( 'Left', M-K+1, M-K, A( K, K ), 1, NU,
     $                  A( K, K+1 ), LDA, DWORK )
C
C           Apply P(k) to D(1:k-1,k:m) from the right (and implicitly to
C           D(k:m,1:k-1) from the left).
C
            CALL DLARF( 'Right', K-1, M-K+1, A( K, K ), 1, NU,
     $                  DE( 1, K+1 ), LDDE, DWORK )
C
C           Apply P(k) from both sides to D(k:m,k:m).
C           Compute  x := nu * D(k:m,k:m) * v.
C
            CALL MB01MD( 'Upper', M-K+1, NU, DE( K, K+1 ), LDDE,
     $                   A( K, K ), 1, ZERO, DWORK, 1 )
C
C           Compute  w := x - 1/2 * nu * (x'*v) * v in x.
C
            MU = -HALF*NU*DDOT( M-K+1, DWORK, 1, A( K, K ), 1 )
            CALL DAXPY( M-K+1, MU, A( K, K ), 1, DWORK, 1 )
C
C           Apply the transformation as a skew-symmetric rank-2 update:
C                D := D + v * w' - w * v'.
C
            CALL MB01ND( 'Upper', M-K+1, ONE, A( K, K ), 1, DWORK, 1,
     $                   DE( K, K+1 ), LDDE )
C
C           Apply P(k) from the left hand side to B(k:m,1:m).
C
            CALL DLARF( 'Left', M-K+1, M, A( K, K ), 1, NU, B( K, 1 ),
     $                  LDB, DWORK )
C
C           Apply P(k) to F(1:k-1,k:m) from the right (and implicitly to
C           F(k:m,1:k-1) from the left).
C
            CALL DLARF( 'Right', K-1, M-K+1, A( K, K ), 1, NU,
     $                  FG( 1, K+1 ), LDFG, DWORK )
C
C           Apply P(k) from both sides to F(k:m,k:m).
C           Compute  x := nu * F(k:m,k:m) * v.
C
            CALL MB01MD( 'Upper', M-K+1, NU, FG( K, K+1 ), LDFG,
     $                   A( K, K ), 1, ZERO, DWORK, 1 )
C
C           Compute  w := x - 1/2 * nu * (x'*v) * v.
C
            MU = -HALF*NU*DDOT( M-K+1, DWORK, 1, A( K, K ), 1 )
            CALL DAXPY( M-K+1, MU, A( K, K ), 1, DWORK, 1 )
C
C           Apply the transformation as a skew-symmetric rank-2 update:
C                F := F + v * w' - w * v'.
C
            CALL MB01ND( 'Upper', M-K+1, ONE, A( K, K ), 1, DWORK, 1,
     $                   FG( K, K+1 ), LDFG )
C
            IF( LCMPQ ) THEN
C
C              Apply P(k) from the right hand side to Q(1:n,m+k:n).
C
               CALL DLARF( 'Right', N, M-K+1, A( K, K ), 1, NU,
     $                     Q( 1, M+K ), LDQ, DWORK )
            END IF
            A( K, K ) = TMP1
         END IF
C
C        Set A(k+1:m,k) to zero in order to be able to apply DHGEQZ.
C
         CALL DCOPY( M-K, DUM, 0, A( K+1, K ), 1 )
   20 CONTINUE
C
C     STEP 2: Reduce T to skew-Hamiltonian triangular form.
C
      DO 50 K = 1, M - 1
C
C        I. Annihilate G(k+1:m-1,k).
C
         DO 30 J = K + 1, M - 1
            MJ2 = MIN( J+2, M )
            MJ3 = MJ2 + 1
C
C           Determine a Givens rotation to annihilate G(j,k) from the
C           left.
C
            CALL DLARTG( FG( J+1, K ), FG( J, K ), CO, SI, TMP1 )
C
C           Update B and G.
C
            CALL DROT( M, B( 1, J+1 ), 1, B( 1, J ), 1, CO, SI )
            FG( J+1, K ) = TMP1
            CALL DROT( M-J-1, FG( MJ2, J+1 ), 1, FG( MJ2, J ), 1, CO, SI
     $                  )
            CALL DROT( J-K-1, FG( J+1, K+1 ), LDFG, FG( J, K+1 ), LDFG,
     $                 CO, SI )
C
C           Update A.
C
            CALL DROT( J, A( 1, J+1 ), 1, A( 1, J ), 1, CO, SI )
            TMP1          = -SI*A( J+1, J+1 )
            A( J+1, J+1 ) =  CO*A( J+1, J+1 )
C
            IF( LCMPQ ) THEN
C
C              Update Q.
C
               CALL DROT( N, Q( 1, J+1 ), 1, Q( 1, J ), 1, CO, SI )
            END IF
C
C           Determine a Givens rotation to annihilate A(j+1,j) from the
C           left.
C
            CALL DLARTG( A( J, J ), TMP1, CO, SI, TMP2 )
C
C           Update A and D.
C
            A( J, J ) = TMP2
            CALL DROT( M-J, A( J, J+1 ), LDA, A( J+1, J+1 ), LDA, CO, SI
     $                  )
            CALL DROT( J-1, DE( 1, J+1 ), 1, DE( 1, J+2 ), 1, CO, SI )
            CALL DROT( M-J-1, DE( J, MJ3 ), LDDE, DE( J+1, MJ3 ), LDDE,
     $                 CO, SI )
C
C           Update B and F.
C
            CALL DROT( M-K+1, B( J, K ), LDB, B( J+1, K ), LDB, CO, SI )
            CALL DROT( J-1, FG( 1, J+1 ), 1, FG( 1, J+2 ), 1, CO, SI )
            CALL DROT( M-J-1, FG( J, MJ3 ), LDFG, FG( J+1, MJ3 ), LDFG,
     $                 CO, SI )
C
            IF( LCMPQ ) THEN
C
C              Update Q.
C
               CALL DROT( N, Q( 1, M+J ), 1, Q( 1, M+J+1 ), 1, CO, SI )
            END IF
   30    CONTINUE
C
C        II. Annihilate G(m,k).
C
C        Determine a Givens rotation to annihilate G(m,k) from the
C        left.
C
         CALL DLARTG( B( M, K ), -FG( M, K ), CO, SI, TMP1 )
C
C        Update B and G.
C
         B(  M, K ) = TMP1
         FG( M, K ) = ZERO
         CALL DROT( M-1, FG( 1, M+1 ), 1, B( 1, M ), 1, CO, SI )
         CALL DROT( M-K-1, FG( M, K+1 ), LDFG, B( M, K+1 ), LDB, CO, SI
     $               )
C
C        Update A and D.
C
         CALL DROT( M-1, DE( 1, M+1 ), 1, A( 1, M ), 1, CO, SI )
C
         IF( LCMPQ ) THEN
C
C           Update Q.
C
            CALL DROT( N, Q( 1, N ), 1, Q( 1, M ), 1, CO, SI )
         END IF
C
C        III. Annihilate B(k+2:m,k).
C
         DO 40 J = M, K + 2, -1
            MJ1 = MIN( J+1, M )
            MJ2 = MJ1 + 1
C
C           Determine a Givens rotation to annihilate B(j,k) from the
C           left.
C
            CALL DLARTG( B( J-1, K ), B( J, K ), CO, SI, TMP1 )
C
C           Update B and F.
C
            B( J-1, K ) = TMP1
            B(   J, K ) = ZERO
            CALL DROT( J-2, FG( 1, J ), 1, FG( 1, J+1 ), 1, CO, SI )
            CALL DROT( M-K, B( J-1, K+1 ), LDB, B( J, K+1 ), LDB, CO, SI
     $                  )
            CALL DROT( M-J, FG( J-1, MJ2 ), LDFG, FG( J, MJ2 ), LDFG,
     $                 CO, SI )
C
C           Update A and D.
C
            TMP1          = -SI*A( J-1, J-1 )
            A( J-1, J-1 ) =  CO*A( J-1, J-1 )
            CALL DROT( M-J+1, A( J-1, J ), LDA, A( J, J ), LDA, CO, SI )
            CALL DROT( J-2, DE( 1, J ), 1, DE( 1, J+1 ), 1, CO, SI )
            CALL DROT( M-J, DE( J-1, MJ2 ), LDDE, DE( J, MJ2 ), LDDE,
     $                 CO, SI )
C
            IF( LCMPQ ) THEN
C
C              Update Q.
C
               CALL DROT( N, Q( 1, M+J-1 ), 1, Q( 1, M+J ), 1, CO, SI )
            END IF
C
C           Determine a Givens rotation to annihilate A(j,j-1) from the
C           right.
C
            CALL DLARTG( A( J, J ), TMP1, CO, SI, TMP2 )
C
C           Update A.
C
            A( J, J ) = TMP2
            CALL DROT( J-1, A( 1, J ), 1, A( 1, J-1 ), 1, CO, SI )
C
C           Update B and G.
C
            CALL DROT( M, B( 1, J ), 1, B( 1, J-1 ), 1, CO, SI )
            CALL DROT( J-K-1, FG( J, K ), LDFG, FG( J-1, K ), LDFG, CO,
     $                 SI )
            CALL DROT( M-J, FG( MJ1, J ), 1, FG( MJ1, J-1 ), 1, CO, SI )
C
            IF( LCMPQ ) THEN
C
C              Update Q.
C
               CALL DROT( N, Q( 1, J ), 1, Q( 1, J-1 ), 1, CO, SI )
            END IF
   40    CONTINUE
   50 CONTINUE
C
C                     (  A1  D1  )         (  B1  F1  )
C     Now we have S = (          ) and T = (          ),
C                     (   0  A1' )         (   0  B1' )
C
C     where A1 is upper triangular and B1 is upper Hessenberg.
C
C     STEP 3: Apply the QZ algorithm to the pencil aA1 - bB1 to
C             determine orthogonal matrices Q1 and Q2 such that
C             Q2' A1 Q1 is upper triangular and Q2' B1 Q1 is upper
C             quasi-triangular.
C
C     Workspace:    need   w + M, where
C                          w = 2*M**2, if COMPQ <> 'N';
C                          w =   M**2, if COMPQ  = 'N' and JOB = 'T';
C                          w =      0, if COMPQ  = 'N' and JOB = 'E';
C                   prefer larger.
C
      CALL DHGEQZ( CMPSC, CMPQ, CMPZ, M, 1, M, B, LDB, A, LDA, ALPHAR,
     $             ALPHAI, BETA, DWORK( IQ1 ), M, DWORK( IQ2 ), M,
     $             DWORK( IWRK ), LDWORK-IWRK+1, INFO )
      IF( INFO.GT.0 ) THEN
         INFO = 1
         RETURN
      END IF
      OPTDW = MAX( MINDW, INT( DWORK( IWRK ) ) + IWRK - 1 )
C
C     Enforce the needed equalities in complex eigenvalues.
C     Count the number of found infinite eigenvalues, if necessary.
C
      J = 1
      NBETA0 = 0
C     WHILE( J.LT.M ) DO
   60 CONTINUE
      IF( J.LT.M ) THEN
         IF( ALPHAI( J ).NE.ZERO ) THEN
            IF( BETA( J ).GE.BETA( J + 1 ) ) THEN
               TMP2 = BETA( J + 1 )/BETA( J )
               TMP1 = ( ALPHAR( J )*TMP2 + ALPHAR( J+1 ) )/TWO
               TMP2 = ( ALPHAI( J )*TMP2 - ALPHAI( J+1 ) )/TWO
               BETA( J ) = BETA( J+1 )
            ELSE
               TMP2 = BETA( J )/BETA( J + 1 )
               TMP1 = ( ALPHAR( J+1 )*TMP2 + ALPHAR( J ) )/TWO
               TMP2 = ( ALPHAI( J+1 )*TMP2 - ALPHAI( J ) )/TWO
               BETA( J+1 ) = BETA( J )
            END IF
            ALPHAR( J )   =  TMP1
            ALPHAR( J+1 ) =  TMP1
            ALPHAI( J )   =  TMP2
            ALPHAI( J+1 ) = -TMP2
            J = J + 2
         ELSE
            IF( NINF.GT.0 ) THEN
               IF( BETA( J ).EQ.ZERO )
     $            NBETA0 = NBETA0 + 1
            END IF
            J = J + 1
         END IF
         GO TO 60
      ELSE IF( J.EQ.M .AND. NINF.GT.0 ) THEN
         IF( BETA( J ).EQ.ZERO )
     $      NBETA0 = NBETA0 + 1
      END IF
C     END WHILE 60
C
C     Set to infinity the largest eigenvalues, if necessary.
C
      IF( NINF.GT.0 ) THEN
         DO 80  J = 1, NINF - NBETA0
            TMP1 = ZERO
            TMP2 = ONE
            P    = 1
            DO 70 K = 1, M
               IF( BETA( K ).GT.ZERO ) THEN
                  IF( ABS( ALPHAR( K ) )*TMP2.GT.TMP1*BETA( K ) )THEN
                     TMP1 = ABS( ALPHAR( K ) )
                     TMP2 = BETA( K )
                     P    = K
                  END IF
               END IF
   70       CONTINUE
            BETA( P ) = ZERO
   80    CONTINUE
      END IF
C
      IF( LTRI ) THEN
C
C        Skew-symmetric update of D.
C
C        Workspace:    need   w + M;
C                      prefer w + M*(M-1).
C
         CALL MB01LD( 'Upper', 'Transpose', M, M, ZERO, ONE, DE( 1, 2 ),
     $                LDDE, DWORK( IQ1 ), M, DE( 1, 2 ), LDDE,
     $                DWORK( IWRK ), LDWORK-IWRK+1, INFO )
C
C        Skew-symmetric update of F.
C
         CALL MB01LD( 'Upper', 'Transpose', M, M, ZERO, ONE, FG( 1, 2 ),
     $                LDFG, DWORK( IQ1 ), M, FG( 1, 2 ), LDFG,
     $                DWORK( IWRK ), LDWORK-IWRK+1, INFO )
      END IF
C
      IF( LCMPQ ) THEN
C
C        Update Q.
C        Workspace:    need   3*M*M;
C                      prefer 4*M*M.
C
         IF( LDWORK.GE.N*N ) THEN
            CALL DGEMM(  'No Transpose', 'No Transpose', N, M, M, ONE,
     $                   Q, LDQ, DWORK( IQ2 ), M, ZERO, DWORK( IWRK ),
     $                   N )
            CALL DLACPY( 'Full', N, M, DWORK( IWRK ), N, Q, LDQ )
            CALL DGEMM(  'No Transpose', 'No Transpose', N, M, M, ONE,
     $                   Q( 1, M+1 ), LDQ, DWORK( IQ1 ), M, ZERO,
     $                   DWORK( IWRK ), N )
            CALL DLACPY( 'Full', N, M, DWORK( IWRK ), N, Q( 1, M+1 ),
     $                   LDQ )
         ELSE
            CALL DGEMM(  'No Transpose', 'No Transpose', M, M, M, ONE,
     $                   Q, LDQ, DWORK( IQ2 ), M, ZERO, DWORK( IWRK ),
     $                   M )
            CALL DLACPY( 'Full', M, M, DWORK( IWRK ), M, Q, LDQ )
            CALL DGEMM(  'No Transpose', 'No Transpose', M, M, M, ONE,
     $                   Q( M+1, 1 ), LDQ, DWORK( IQ2 ), M, ZERO,
     $                   DWORK( IWRK ), M )
            CALL DLACPY( 'Full', M, M, DWORK( IWRK ), M, Q( M+1, 1 ),
     $                   LDQ )
            CALL DGEMM(  'No Transpose', 'No Transpose', M, M, M, ONE,
     $                   Q( 1, M+1 ), LDQ, DWORK( IQ1 ), M, ZERO,
     $                   DWORK( IWRK ), M )
            CALL DLACPY( 'Full', M, M, DWORK( IWRK ), M, Q( 1, M+1 ),
     $                   LDQ )
            CALL DGEMM(  'No Transpose', 'No Transpose', M, M, M, ONE,
     $                   Q( M+1, M+1 ), LDQ, DWORK( IQ1 ), M, ZERO,
     $                   DWORK( IWRK ), M )
            CALL DLACPY( 'Full', M, M, DWORK( IWRK ), M, Q( M+1, M+1 ),
     $                   LDQ )
         END IF
      END IF
C
C     Mark as unreliable the numerically infinite eigenvalues and
C     numerically zero eigenvalues. Store their indices.
C     The pencil is assumed regular.
C
      TOLS = TEN*DLAMCH( 'Precision' )*NRMS
      TOLT = TEN*DLAMCH( 'Precision' )*NRMT
      P    = 0
      K    = 1
C     WHILE( K.LE.M ) DO
   90 CONTINUE
      IF( K.LE.M ) THEN
         IF( BETA( K ).NE.ZERO ) THEN
            IF( ALPHAI( K ).EQ.ZERO ) THEN
               SING = ABS( B( K, K ) ).LT.TOLT
               IF( SING ) THEN
                  P = P + 1
                  IWORK( P+1 ) = K
               END IF
               IF( ABS( A( K, K ) ).LT.TOLS ) THEN
                  IF( SING ) THEN
                     INFO = 2
                  ELSE
                     P = P + 1
                     IWORK( P+1 ) = K
                  END IF
               END IF
            ELSE
               X1   = B( K, K )
               X2   = B( K+1, K )
               X3   = B( K, K+1 )
               X4   = B( K+1, K+1 )
               NRM  = DLANGE( 'Frobenius', 2, 2, B( K, K ), LDB, DWORK )
               SDET = ( MAX( ABS( X1 ), ABS( X4 ) )/NRM )
     $                 *MIN( ABS( X1 ), ABS( X4 ) )*
     $                 SIGN( ONE, X1 )*SIGN( ONE, X4 ) -
     $                ( MAX( ABS( X2 ), ABS( X3 ) )/NRM )
     $                 *MIN( ABS( X2 ), ABS( X3 ) )*
     $                 SIGN( ONE, X2 )*SIGN( ONE, X3 )
               IF( NRM.GT.ONE ) THEN
                  PSNG = ABS( SDET ).LT.TOLT/NRM
               ELSE
                  PSNG = ABS( SDET )*NRM.LT.TOLT
               END IF
               IF( PSNG ) THEN
C
C                 Make a more accurate singularity test using SVD.
C
                  IF ( ABS( X1 ).GE.ABS( X4 ) ) THEN
                     CALL DLARTG( X1, X2, CO, SI, TMP1 )
                     X1   = TMP1
                     TMP1 = CO*X3 + SI*X4
                     X4   = CO*X4 - SI*X3
                     X3   = TMP1
                  ELSE
                     CALL DLARTG( X4, X2, CO, SI, TMP1 )
                     X4   = TMP1
                     TMP1 = CO*X3 + SI*X1
                     X1   = CO*X1 - SI*X3
                     X3   = TMP1
                  END IF
                  CALL DLAS2( X1, X3, X4, TMP1, TMP2 )
                  SING = TMP1.LT.TOLT
                  IF ( SING ) THEN
                     P = P + 1
                     IWORK( P+1 ) = -K
                     INFO = 2
                  END IF
               END IF
               X1   = A( K, K )
               X4   = A( K+1, K+1  )
               NRM  = DLAPY2( X1, X4 )
               SDET = ( MAX( X1, X4 )/NRM )*MIN( X1, X4 )
               IF ( ABS( SDET ).LT.TOLS ) THEN
                  IF( SING ) THEN
                     INFO = 2
                  ELSE
                     P = P + 1
                     IWORK( P+1 ) = -K
                  END IF
               END IF
               K = K + 1
            END IF
         ELSE
            IWORK( K+1 ) = 0
         END IF
         K = K + 1
         GO TO 90
      END IF
C     END WHILE 90
      IWORK( 1 ) = P
C
      DWORK( 1 ) = OPTDW
      DWORK( 2 ) = NRMS
      DWORK( 3 ) = NRMT
C
      RETURN
C *** Last line of MB04FD ***
      END


C
C**************************  FVGDDS ************************************
C
C  calculate second derivative of effective saturation with respect to
C  pressure head using van Genuchten characteristic equation
C
C***********************************************************************
C
      DOUBLE PRECISION FUNCTION FVGDDS(PSI,INOD)
C
      IMPLICIT NONE
      INCLUDE 'CATHY.H'
      INTEGER  INOD
      REAL*8   BETA,B1,B1R
      REAL*8   PSI
      INCLUDE 'SOILCHAR.H'
C
      IF (PSI .LT. -1.0D-14) THEN
         BETA=ABS((PSI/VGPSAT(INOD)))**VGN(INOD)
         B1=BETA+1.0D0
         B1R=1.0D0/B1
         FVGDDS=VGN1(INOD)*(BETA/PSI)*(1.0D0/PSI)*
     1               ((1.0D0 + VGN(INOD)*(BETA - 1.0D0))/
     2               (ABS(B1)**VGM(INOD)))*B1R*B1R
      ELSE
         FVGDDS=0.0D0
      END IF
C
      RETURN
      END


module circular

    implicit none

    complex(kind=8),allocatable :: P1(:,:), P2(:,:), &
                                   Pinv1(:,:), Pinv2(:,:)
contains

    subroutine set_pmatrix(n,nb,G,R,P,Pinv)

    use config
    use util

    implicit none

    integer(kind=4),intent(in) :: n
    integer(kind=4),intent(in) :: nb
    real(kind=8),intent(in) :: G(3)
    real(kind=8),intent(in) :: R(3)
    integer(kind=4) :: na
    integer(kind=4) :: i,j,k
    complex(kind=8),intent(out) :: P(n,n),Pinv(n,n)
    na = n/nb
    P = 0.0d0
    Pinv = 0.0d0
    do i = 1,nb
        do j = 1,nb
             do k = 1,na
                 P((i-1)*na+k,&
                   (j-1)*na+k) = &
                 exp(i_imag*dot_product(&
                 G*dble(j-1)/dble(nb),&
                 dble(i-1)*R))/sqrt(dble(nb))
            end do
        end do
    end do

    ! P is unitary matrix
    Pinv = dconjg(transpose(P))
    end subroutine set_pmatrix

    function circular_g(Es_in0,e_in1,alpha_in,&
             beta_in,convergence,&
             n,nb,nc,G1,R1,G2,R2) result(green1)

    ! We have a difference of 1d-10 compared with
    ! direct matrix inversion

    use util

    implicit none

    complex(kind=8),intent(in) :: Es_in0(:,:)
    complex(kind=8),intent(in) :: e_in1(:,:)
    complex(kind=8),intent(in) :: alpha_in(:,:)
    complex(kind=8),intent(in) :: beta_in(:,:)
    real(kind=8),intent(in) :: convergence
    integer(kind=4),intent(in) :: n, nb, nc
    real(kind=8),intent(in) :: G1(3),G2(3)
    real(kind=8),intent(in) :: R1(3),R2(3)
    integer(kind=4) :: i,j,na,nac, k
    complex(kind=8) :: Es0(size(Es_in0,1),size(Es_in0,2))
    complex(kind=8) :: e1(size(Es_in0,1),size(Es_in0,2))
    complex(kind=8) :: alpha(size(Es_in0,1),size(Es_in0,2))
    complex(kind=8) :: beta(size(Es_in0,1),size(Es_in0,2))
    complex(kind=8) :: green1(size(Es0,1),size(Es0,2))
    complex(kind=8),allocatable :: green2(:,:)
    complex(kind=8),allocatable :: Esy0(:,:)
    complex(kind=8),allocatable :: ey1(:,:)
    complex(kind=8),allocatable :: alphay(:,:)
    complex(kind=8),allocatable :: betay(:,:)

    na = n/nb
    allocate(green2(na,na),Esy0(na,na),ey1(na,na),&
             alphay(na,na),betay(na,na))

    nac = na/nc
    green1 = 0.0d0

    Es0 = fourier_transform(Es_in0,n,nb,G1,R1)
    e1 = fourier_transform(e_in1,n,nb,G1,R1)
    alpha = fourier_transform(alpha_in,n,nb,G1,R1)
    beta = fourier_transform(beta_in,n,nb,G1,R1)

    do i = 1,nb
        Esy0 = fourier_transform(Es0((i-1)*na+1:i*na,(i-1)*na+1:i*na),&
               na,nc,G2,R2)
        ey1 = fourier_transform(e1((i-1)*na+1:i*na,(i-1)*na+1:i*na),&
              na,nc,G2,R2)
        alphay = fourier_transform(alpha((i-1)*na+1:i*na,(i-1)*na+1:i*na),&
                 na,nc,G2,R2)
        betay = fourier_transform(beta((i-1)*na+1:i*na,(i-1)*na+1:i*na),&
                na,nc,G2,R2)
        green2 = 0.0d0
        do j = 1,nc
            green2((j-1)*nac+1:j*nac,(j-1)*nac+1:j*nac) = &
                 decimation(Esy0((j-1)*nac+1:j*nac,(j-1)*nac+1:j*nac),&
                 ey1((j-1)*nac+1:j*nac,(j-1)*nac+1:j*nac),&
                 alphay((j-1)*nac+1:j*nac,(j-1)*nac+1:j*nac),&
                 betay((j-1)*nac+1:j*nac,(j-1)*nac+1:j*nac),convergence)
!            do k = 1, 12
!                write(*,*) k
!                write(*,*) ey1((j-1)*nac+k,(j-1)*nac+1:j*nac)
!             write(*,*) maxval(abs(ey1((j-1)*nac+1:j*nac,(j-1)*nac+1:j*nac)-dconjg(transpose(ey1((j-1)*nac+1:j*nac,(j-1)*nac+1:j*nac)))))
!            end do
!             stop
        end do
        green1((i-1)*na+1:i*na,(i-1)*na+1:i*na) = &
            matmul(matmul(P2,green2),Pinv2)
    end do
    green1 = matmul(matmul(P1,green1),Pinv1)

    end function circular_g

    function circular_inv(H,n,nb,nc,&
             G1,R1,G2,R2) result(Hinv1)

    use util

    implicit none

    integer(kind=4),intent(in) :: n, nb, nc
    real(kind=8),intent(in) :: G1(3),G2(3)
    real(kind=8),intent(in) :: R1(3),R2(3)
    complex(kind=8),intent(in) :: H(:,:)
    complex(kind=8) :: Hinv1(size(H,1),size(H,2))
    complex(kind=8) :: Hinv2(size(H,1)/nb,size(H,2)/nb)
    complex(kind=8) :: H1(size(H,1),size(H,2))
    complex(kind=8) :: H2(size(H,1)/nb,size(H,2)/nb)
    integer(kind=4) :: i,j, na, nac

    na = n/nb
    nac = na/nc
    Hinv1 = 0.0d0

    H1 = fourier_transform(H,n,nb,G1,R1)
    do i = 1,nb
        H2 = fourier_transform(H1((i-1)*na+1:i*na,(i-1)*na+1:i*na),&
            na,nc,G2,R2)
        Hinv2 = 0.0d0
        do j = 1,nc
            Hinv2((j-1)*nac+1:j*nac,&
            (j-1)*nac+1:j*nac) = &
            inv(H2((j-1)*nac+1:j*nac,&
            (j-1)*nac+1:j*nac))
        end do
        Hinv1((i-1)*na+1:i*na,(i-1)*na+1:i*na)&
        = matmul(matmul(P2,Hinv2),Pinv2)
    end do
    Hinv1 = matmul(matmul(P1,Hinv1),Pinv1)

    end function circular_inv

    subroutine circular_eigen_axb(Ha,Hb,n,nb,nc,&
                 G1,R1,G2,R2,eigs1_diag,evs1)

    use util

    implicit none

    integer(kind=4),intent(in) :: n, nb, nc
    real(kind=8),intent(in) :: G1(3),G2(3)
    real(kind=8),intent(in) :: R1(3),R2(3)
    complex(kind=8),intent(in) :: Ha(:,:),Hb(:,:) ! Ha, Hb shares same periodicity
    complex(kind=8)            :: Ha1(size(Ha,1),size(Ha,2)),Hb1(size(Hb,1),size(Hb,2))
    complex(kind=8)            :: Ha2(size(Ha,1)/nb,size(Ha,2)/nb),Hb2(size(Hb,1)/nb,size(Hb,2)/nb)
    complex(kind=8) :: Hd2(size(Ha,1)/nb,size(Ha,2)/nb)
    complex(kind=8),intent(out) :: evs1(size(Ha,1),size(Ha,2))
    complex(kind=8) :: evs2(size(Ha,1)/nb,size(Ha,2)/nb)
    complex(kind=8),intent(out) :: eigs1_diag(size(Ha,1))
    complex(kind=8) :: eigs1(size(Ha,1),size(Ha,2))
    complex(kind=8) :: eigs2(size(Ha,1)/nb,size(Ha,2)/nb)
    complex(kind=8) :: eigs3(size(Ha,1)/nb/nc)
    complex(kind=8) :: evs3(size(Ha,1)/nb/nc,size(Ha,1)/nb/nc)
    integer(kind=4) :: i,j, na, nac

    na = n/nb
    nac = na/nc

    Ha1 = fourier_transform(Ha,n,nb,G1,R1)
    Hb1 = fourier_transform(Hb,n,nb,G1,R1)

    eigs1 = 0.0d0
    evs1 = 0.0d0

    do i = 1,nb
        Ha2 = fourier_transform(Ha1((i-1)*na+1:i*na,(i-1)*na+1:i*na),&
            na,nc,G2,R2)
        Hb2 = fourier_transform(Hb1((i-1)*na+1:i*na,(i-1)*na+1:i*na),&
            na,nc,G2,R2)
        Hd2 = matmul(Ha2,Hb2)

        eigs2 = 0.0d0
        evs2 = 0.0d0
        do j = 1,nc
            call eigen_sorting(Hd2((j-1)*nac+1:j*nac,&
            (j-1)*nac+1:j*nac),eigs3,evs3)
            eigs2((j-1)*nac+1:j*nac,&
            (j-1)*nac+1:j*nac) = diagmat(eigs3)
            evs2((j-1)*nac+1:j*nac,&
            (j-1)*nac+1:j*nac) = evs3
        end do

        eigs1((i-1)*na+1:i*na,(i-1)*na+1:i*na) = eigs2
        evs1((i-1)*na+1:i*na,(i-1)*na+1:i*na) = matmul(P2,evs2)
    end do

    evs1 = matmul(P1,evs1)

    do i = 1,n
        eigs1_diag(i) = eigs1(i,i)
    end do

    end subroutine circular_eigen_axb

    subroutine circular_eigen(H,n,nb,nc,&
                 G1,R1,G2,R2,eigs1_diag,evs1)

    use util

    implicit none

    integer(kind=4),intent(in) :: n, nb, nc
    real(kind=8),intent(in) :: G1(3),G2(3)
    real(kind=8),intent(in) :: R1(3),R2(3)
    complex(kind=8),intent(in) :: H(:,:)
    complex(kind=8)            :: H1(size(H,1),size(H,2))
    complex(kind=8) :: H2(size(H,1)/nb,size(H,2)/nb)
    complex(kind=8),intent(out) :: evs1(size(H,1),size(H,2))
    complex(kind=8) :: evs2(size(H,1)/nb,size(H,2)/nb)
    complex(kind=8),intent(out) :: eigs1_diag(size(H,1))
    complex(kind=8) :: eigs1(size(H,1),size(H,2))
    complex(kind=8) :: eigs2(size(H,1)/nb,size(H,2)/nb)
    complex(kind=8) :: eigs3(size(H,1)/nb/nc)
    complex(kind=8) :: evs3(size(H,1)/nb/nc,size(H,1)/nb/nc)
    integer(kind=4) :: i,j, na, nac

    na = n/nb
    nac = na/nc

    H1 = fourier_transform(H,n,nb,G1,R1)

    eigs1 = 0.0d0
    evs1 = 0.0d0

    do i = 1,nb
        H2 = fourier_transform(H1((i-1)*na+1:i*na,(i-1)*na+1:i*na),&
            na,nc,G2,R2)

        eigs2 = 0.0d0
        evs2 = 0.0d0

        do j = 1,nc
            call eigen_sorting(H2((j-1)*nac+1:j*nac,&
            (j-1)*nac+1:j*nac),eigs3,evs3)
            eigs2((j-1)*nac+1:j*nac,&
            (j-1)*nac+1:j*nac) = diagmat(eigs3)
            evs2((j-1)*nac+1:j*nac,&
            (j-1)*nac+1:j*nac) = evs3
        end do

        eigs1((i-1)*na+1:i*na,(i-1)*na+1:i*na) = eigs2
        evs1((i-1)*na+1:i*na,(i-1)*na+1:i*na) = matmul(P2,evs2)
    end do

    evs1 = matmul(P1,evs1)

    do i = 1,n
        eigs1_diag(i) = eigs1(i,i)
    end do

    end subroutine circular_eigen

end module circular


*DECK DBNFAC
      SUBROUTINE DBNFAC (W, NROWW, NROW, NBANDL, NBANDU, IFLAG)
C***BEGIN PROLOGUE  DBNFAC
C***SUBSIDIARY
C***PURPOSE  Subsidiary to DBINT4 and DBINTK
C***LIBRARY   SLATEC
C***TYPE      DOUBLE PRECISION (BNFAC-S, DBNFAC-D)
C***AUTHOR  (UNKNOWN)
C***DESCRIPTION
C
C  DBNFAC is the BANFAC routine from
C        * A Practical Guide to Splines *  by C. de Boor
C
C  DBNFAC is a double precision routine
C
C  Returns in  W  the LU-factorization (without pivoting) of the banded
C  matrix  A  of order  NROW  with  (NBANDL + 1 + NBANDU) bands or diag-
C  onals in the work array  W .
C
C *****  I N P U T  ****** W is double precision
C  W.....Work array of size  (NROWW,NROW)  containing the interesting
C        part of a banded matrix  A , with the diagonals or bands of  A
C        stored in the rows of  W , while columns of  A  correspond to
C        columns of  W . This is the storage mode used in  LINPACK  and
C        results in efficient innermost loops.
C           Explicitly,  A  has  NBANDL  bands below the diagonal
C                            +     1     (main) diagonal
C                            +   NBANDU  bands above the diagonal
C        and thus, with    MIDDLE = NBANDU + 1,
C          A(I+J,J)  is in  W(I+MIDDLE,J)  for I=-NBANDU,...,NBANDL
C                                              J=1,...,NROW .
C        For example, the interesting entries of A (1,2)-banded matrix
C        of order  9  would appear in the first  1+1+2 = 4  rows of  W
C        as follows.
C                          13 24 35 46 57 68 79
C                       12 23 34 45 56 67 78 89
C                    11 22 33 44 55 66 77 88 99
C                    21 32 43 54 65 76 87 98
C
C        All other entries of  W  not identified in this way with an en-
C        try of  A  are never referenced .
C  NROWW.....Row dimension of the work array  W .
C        must be  .GE.  NBANDL + 1 + NBANDU  .
C  NBANDL.....Number of bands of  A  below the main diagonal
C  NBANDU.....Number of bands of  A  above the main diagonal .
C
C *****  O U T P U T  ****** W is double precision
C  IFLAG.....Integer indicating success( = 1) or failure ( = 2) .
C     If  IFLAG = 1, then
C  W.....contains the LU-factorization of  A  into a unit lower triangu-
C        lar matrix  L  and an upper triangular matrix  U (both banded)
C        and stored in customary fashion over the corresponding entries
C        of  A . This makes it possible to solve any particular linear
C        system  A*X = B  for  X  by a
C              CALL DBNSLV ( W, NROWW, NROW, NBANDL, NBANDU, B )
C        with the solution X  contained in  B  on return .
C     If  IFLAG = 2, then
C        one of  NROW-1, NBANDL,NBANDU failed to be nonnegative, or else
C        one of the potential pivots was found to be zero indicating
C        that  A  does not have an LU-factorization. This implies that
C        A  is singular in case it is totally positive .
C
C *****  M E T H O D  ******
C     Gauss elimination  W I T H O U T  pivoting is used. The routine is
C  intended for use with matrices  A  which do not require row inter-
C  changes during factorization, especially for the  T O T A L L Y
C  P O S I T I V E  matrices which occur in spline calculations.
C     The routine should NOT be used for an arbitrary banded matrix.
C
C***SEE ALSO  DBINT4, DBINTK
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   800901  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900328  Added TYPE section.  (WRB)
C***END PROLOGUE  DBNFAC
C
      INTEGER IFLAG, NBANDL, NBANDU, NROW, NROWW, I, IPK, J, JMAX, K,
     1 KMAX, MIDDLE, MIDMK, NROWM1
      DOUBLE PRECISION W(NROWW,*), FACTOR, PIVOT
C
C***FIRST EXECUTABLE STATEMENT  DBNFAC
      IFLAG = 1
      MIDDLE = NBANDU + 1
C                         W(MIDDLE,.) CONTAINS THE MAIN DIAGONAL OF  A .
      NROWM1 = NROW - 1
      IF (NROWM1) 120, 110, 10
   10 IF (NBANDL.GT.0) GO TO 30
C                A IS UPPER TRIANGULAR. CHECK THAT DIAGONAL IS NONZERO .
      DO 20 I=1,NROWM1
        IF (W(MIDDLE,I).EQ.0.0D0) GO TO 120
   20 CONTINUE
      GO TO 110
   30 IF (NBANDU.GT.0) GO TO 60
C              A IS LOWER TRIANGULAR. CHECK THAT DIAGONAL IS NONZERO AND
C                 DIVIDE EACH COLUMN BY ITS DIAGONAL .
      DO 50 I=1,NROWM1
        PIVOT = W(MIDDLE,I)
        IF (PIVOT.EQ.0.0D0) GO TO 120
        JMAX = MIN(NBANDL,NROW-I)
        DO 40 J=1,JMAX
          W(MIDDLE+J,I) = W(MIDDLE+J,I)/PIVOT
   40   CONTINUE
   50 CONTINUE
      RETURN
C
C        A  IS NOT JUST A TRIANGULAR MATRIX. CONSTRUCT LU FACTORIZATION
   60 DO 100 I=1,NROWM1
C                                  W(MIDDLE,I)  IS PIVOT FOR I-TH STEP .
        PIVOT = W(MIDDLE,I)
        IF (PIVOT.EQ.0.0D0) GO TO 120
C                 JMAX  IS THE NUMBER OF (NONZERO) ENTRIES IN COLUMN  I
C                     BELOW THE DIAGONAL .
        JMAX = MIN(NBANDL,NROW-I)
C              DIVIDE EACH ENTRY IN COLUMN  I  BELOW DIAGONAL BY PIVOT .
        DO 70 J=1,JMAX
          W(MIDDLE+J,I) = W(MIDDLE+J,I)/PIVOT
   70   CONTINUE
C                 KMAX  IS THE NUMBER OF (NONZERO) ENTRIES IN ROW  I  TO
C                     THE RIGHT OF THE DIAGONAL .
        KMAX = MIN(NBANDU,NROW-I)
C                  SUBTRACT  A(I,I+K)*(I-TH COLUMN) FROM (I+K)-TH COLUMN
C                  (BELOW ROW  I ) .
        DO 90 K=1,KMAX
          IPK = I + K
          MIDMK = MIDDLE - K
          FACTOR = W(MIDMK,IPK)
          DO 80 J=1,JMAX
            W(MIDMK+J,IPK) = W(MIDMK+J,IPK) - W(MIDDLE+J,I)*FACTOR
   80     CONTINUE
   90   CONTINUE
  100 CONTINUE
C                                       CHECK THE LAST DIAGONAL ENTRY .
  110 IF (W(MIDDLE,NROW).NE.0.0D0) RETURN
  120 IFLAG = 2
      RETURN
      END


MODULE mod_grid_flow_direction_kernels

!Module containing flow direction finding kernels

IMPLICIT NONE

CONTAINS

FUNCTION HDgrid_fdir_kernel(orog_section) RESULT(flow_direction)

!Kernel for find the flow direction (given as a number from 1-9 according to
!the directions given by a numeric keypad on a keyboard; this number must be
!have type float64/REAL*8 even though it only ever takes integer values to
!satify type checking. If muliply mimimum occur then take the first unless
!there is another one in the centre of the cell in which case set flow to 5
!(a sink point)

!Note: should ideally replace REAL*8 with a more modern SELECT_REAL_KIND based
!kind specification

IMPLICIT NONE

!Variables with intent IN
!A 3 by 3 input orography section flattened into a single dimensional array
REAL*8, INTENT(IN), DIMENSION(1:9) :: orog_section

!Local Variables
INTEGER :: i               !A counter
INTEGER :: min_coord       !The coordinate of the minimum value
REAL*8  :: flow_direction  !The calculated flow direction to return
!The flow directions; simply an array initialised with counting numbers
REAL*8, DIMENSION(1:9) :: flow_directions = [(REAL(i,8),i=1,9)]

 !Find the location of the first minimum in orog_section
 min_coord = MINLOC(orog_section,1)
 !And use that as an index to find the flow direction
 flow_direction = flow_directions(min_coord)
 !Check if this grid cell is also a minimum
 IF ( orog_section(5) == MINVAL(orog_section) ) THEN
    flow_direction = 5
 END IF

END FUNCTION HDgrid_fdir_kernel

END MODULE mod_grid_flow_direction_kernels


SUBROUTINE TrescaSolver( Model,Solver,dt,TransientSimulation )
!------------------------------------------------------------------------------
  USE DefUtils
  IMPLICIT NONE
!------------------------------------------------------------------------------
  TYPE(Solver_t) :: Solver
  TYPE(Model_t) :: Model
  REAL(KIND=dp) :: dt
  LOGICAL :: TransientSimulation
!------------------------------------------------------------------------------
  TYPE(Variable_t), POINTER :: Stress, Tresca
  INTEGER, POINTER :: StressPerm(:), TrescaPerm(:)
  INTEGER :: i, j, nodes, StressDOFs, TrescaDOFs, ok
  REAL(KIND=dp), POINTER :: StressValues(:), TrescaValues(:)
  REAL(KIND=dp) :: StressComponent(6), Matrix(3,3), Eigs(3), Work(8)
  REAL(KIND=dp) :: SigmaMax, SigmaMin
  SAVE TrescaValues
!------------------------------------------------------------------------------

  ! Get stress tensor:
  !--------------------
  Stress => VariableGet( Solver % Mesh % Variables, 'Stress' )

  IF( ASSOCIATED(Stress) ) THEN
     StressPerm => Stress % Perm
     StressDOFs = Stress % DOFs
     StressValues => Stress % Values
  ELSE
     STOP 'Error: Stress was not found'
  END IF

  IF( StressDOFs /= 6 ) THEN
     STOP 'Error: Unexpected number of DOFs for stress'
  END IF

  nodes = SIZE( StressValues ) / StressDOFs

  ! Introduce Tresca stress:
  !--------------------------
  Tresca => VariableGet( Solver % Mesh % Variables, 'Tresca' )

  IF( .NOT.ASSOCIATED(Tresca) ) THEN
     TrescaPerm => StressPerm
     TrescaDOFs = 1
     ALLOCATE( TrescaValues( nodes ) )
     CALL VariableAdd( Solver % Mesh % Variables, Solver % Mesh, &
          Solver, 'Tresca', TrescaDOFs, TrescaValues, TrescaPerm )
  END IF

  ! Compute Tresca stress in node points:
  !--------------------------------------
  DO i = 1, nodes
     DO j = 1, StressDOFs
        StressComponent(j) = StressValues(StressDOFs*(i-1)+j)
     END DO

     Matrix(1,1) = StressComponent(1)
     Matrix(2,2) = StressComponent(2)
     Matrix(3,3) = StressComponent(3)
     Matrix(1,2) = StressComponent(4)
     Matrix(2,3) = StressComponent(5)
     Matrix(1,3) = StressComponent(6)

     CALL DSYEV('N', 'U',  3, Matrix, 3, Eigs, Work, 8, ok)

     IF( ok /= 0 ) THEN
        STOP 'Error: DSYEV failed'
     END IF

     SigmaMax = MAXVAL( Eigs )
     SigmaMin = MINVAL( Eigs )

     TrescaValues(i) = SigmaMax - SigmaMin
  END DO

END SUBROUTINE TrescaSolver
!------------------------------------------------------------------------------


C Copyright (C) 2000, International Business Machines
C Corporation and others.  All Rights Reserved.
      SUBROUTINE FD( LAFLA , PNTINT, VALUES, POLY, N,  Q, NEQCON,
     +               LPTINT, LPOLY )

*
*  ***********************************************************************
*  THIS SUBROUTINE COMPUTED FINITE DIFFERENCES FOR MULTIVARIATE
*  INTERPOLATION, USING 'Q' INTERPOLATION POINTS AND 'Q' NEWTON
*  FUNDAMENTAL POLYNOMIALS.
*
*  PARAMETERS:
*
*   N      (INPUT)  DIMENTION OF THE PROBLEM
*
*   Q      (INPUT)  NUMBER OF INTERPOLATION POINTS
*
*   PNTINT (INPUT)  LIST OF  'NIND' DATA POINTS. THE I-TH POINT OCCUPIES
*                   POSITIONS ( I - 1 ) * N + 1 TO I * N.
*   VALUES (INPUT)  VALUES OF THE OBJECTIVE FUNCTION AT THE 'NIND'
*                   DATA POINTS CONTAINED IN POINTS.
*   POLY   (INPUT)  THE ARRAY CONTAINING COEFFICIENTS OF NEWTON FUNDAMENTAL
*                   POLYNOMIALS (AS COMPUTED BY 'NBUILD')
*   NEQCON (INPUT)  NUMBER OF LINEARLY INDEP. EQUALITY CONSTRAINTS
*
*   LAFLA  (OUTPUT) THE ARRAY OF THE  FINITE DIFFERENCES
*
*  **************************************************************************
*

       INTEGER          N, Q, NEQCON, LPTINT, LPOLY

       DOUBLE PRECISION LAFLA(Q), PNTINT(LPTINT), VALUES(Q), POLY(LPOLY)

       INTRINSIC        MIN
C
C  LOCAL VARIABLES
C
       INTEGER          DD, I, K, L,  NP1, NP2, QP1
       DOUBLE PRECISION VAL

       NP1 = N + 1
       NP2 = N + 2
       DD = (NP1)*(NP2)/2.0
       QP1 = Q + 1

C
C  INITIALISE THE LAFLA, THE FINITE DIFFERENCE OPERATORS ON F
C
       DO 10 I =1,Q
         LAFLA( I ) = VALUES(I)
 10    CONTINUE
C
C  START THE MAJOR ITERATION
C

       DO 100 I=1,Q
C
C  FOR ALL MULTIINDICES ALFA (WHOSE CARDINALITY IS GREATER THAN OR EQUAL
C  TO I), UPDATE THE ASSOCIATED FUNCTION L_ALFA USING
C  THE NEWTON FUNDAMENTAL POLYNOMIALS OF DEGREE EQUAL TO THE
C  CARDINALITY OF ALFA_{I-1}
C

         IF (I.EQ.2) THEN
C
C  ALL FINITE DIFFERENCES CORRESPONDING TO DEGREES >= 1 ARE UPDATED.
C  THE NEWTON FUNDAMENTAL POLYNOMIALS OF DEGREE CARDINALITY OF ALFA_I = 0
C  ARE USED IN THE UPDATE. THE UPDATES ARE SKIPPED FOR DUMMY POLYNOMIALS
C  WHOSE INDEX IS ALWAYS HIGHER THAN NP1-NEQCON
C
           DO 110 L = 2, MIN(Q, NP1 - NEQCON)
             CALL  EVALNP( VAL, PNTINT, L, POLY, 1, N, LPTINT,
     +                     LPOLY )
             LAFLA( L ) = LAFLA( L ) - LAFLA( 1 )*VAL
 110       CONTINUE
           DO 115 L = NP2, Q
             CALL  EVALNP( VAL, PNTINT, L, POLY, 1, N, LPTINT,
     +                     LPOLY )
             LAFLA( L ) = LAFLA( L ) - LAFLA( 1 )*VAL
 115      CONTINUE

         ELSE
           IF (I.EQ.NP2) THEN
C
C  ALL FINITE DIFFERENCES CORRESPONDING TO DEGREES = 2 ARE UPDATED.
C  THE NEWTON FUNDAMENTAL POLYNOMIALS OF DEGREE CARDINALITY OF ALFA_I = 1
C  ARE USED IN THE UPDATE
C
             DO 120 L = NP2,Q
               DO 130 K = 2, NP1-NEQCON
                 CALL  EVALNP( VAL, PNTINT, L, POLY, K, N, LPTINT,
     +                         LPOLY )
                 LAFLA( L ) = LAFLA( L ) - LAFLA( K )*VAL
 130           CONTINUE
 120         CONTINUE

           ENDIF
         ENDIF
 100   CONTINUE

       RETURN
       END


!
!  Copyright 2019-2020 SALMON developers
!
!  Licensed under the Apache License, Version 2.0 (the "License");
!  you may not use this file except in compliance with the License.
!  You may obtain a copy of the License at
!
!      http://www.apache.org/licenses/LICENSE-2.0
!
!  Unless required by applicable law or agreed to in writing, software
!  distributed under the License is distributed on an "AS IS" BASIS,
!  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
!  See the License for the specific language governing permissions and
!  limitations under the License.
!
module lattice
  implicit none

contains

!===================================================================================================================================

SUBROUTINE init_lattice(system,stencil)
  use math_constants,only : pi
  use structures
  implicit none
  type(s_dft_system) :: system
  type(s_stencil)    :: stencil
  !
  real(8),dimension(3,3) :: A,B,F,wrk
  real(8) :: a1(3),a2(3),a3(3),detA,normA(3),f_uu,f_vv,f_ww,f_uv,f_uw,f_vw

! al = [ a1, a2, a3 ]
  A = system%primitive_a ! primitive lattice vectors
  a1 = A(1:3,1)
  a2 = A(1:3,2)
  a3 = A(1:3,3)
  call calc_inverse(A,wrk,detA)
  system%det_a = detA
  system%Hvol = detA/dble(system%ngrid)
  system%primitive_b = 2d0*pi* transpose(wrk) ! reciprocal primitive lattice vectors
  ! [ b1 b2 b3 ]^{T} = 2*pi* [ a1 a2 a3 ]^{-1}

  normA(1) = sqrt(sum(a1**2))
  normA(2) = sqrt(sum(a2**2))
  normA(3) = sqrt(sum(a3**2))

! cf. A. Natan et al., PRB 78, 075109 (2008).
! A = [ u, v, w ], B = A^{-1}
  A(1:3,1) = a1(1:3) / normA(1) ! u
  A(1:3,2) = a2(1:3) / normA(2) ! v
  A(1:3,3) = a3(1:3) / normA(3) ! w
  call calc_inverse(A,B,detA)

  wrk = transpose(B)
  F = matmul(B,wrk)
  f_uu = F(1,1)
  f_vv = F(2,2)
  f_ww = F(3,3)
  f_uv = F(1,2) + F(2,1)
  f_uw = F(1,3) + F(3,1)
  f_vw = F(2,3) + F(3,2)

  system%rmatrix_A = A
  system%rmatrix_B = B

  stencil%coef_F(1) = f_uu
  stencil%coef_F(2) = f_vv
  stencil%coef_F(3) = f_ww
  stencil%coef_F(4) = f_vw ! yz
  stencil%coef_F(5) = f_uw ! zx
  stencil%coef_F(6) = f_uv ! xy

  return
end SUBROUTINE init_lattice

SUBROUTINE calc_inverse(a,b,detA) ! b = a^{-1}
  implicit none
  real(8),intent(in) :: a(3,3)
  real(8)            :: b(3,3),detA

  detA=a(1,1)*a(2,2)*a(3,3)+a(2,1)*a(3,2)*a(1,3)+a(3,1)*a(1,2)*a(2,3) &
    -a(1,3)*a(2,2)*a(3,1)-a(2,3)*a(3,2)*a(1,1)-a(3,3)*a(1,2)*a(2,1)

  b(1,1)=a(2,2)*a(3,3)-a(2,3)*a(3,2)
  b(2,1)=a(2,3)*a(3,1)-a(2,1)*a(3,3)
  b(3,1)=a(2,1)*a(3,2)-a(2,2)*a(3,1)

  b(1,2)=a(1,3)*a(3,2)-a(1,2)*a(3,3)
  b(2,2)=a(1,1)*a(3,3)-a(1,3)*a(3,1)
  b(3,2)=a(1,2)*a(3,1)-a(1,1)*a(3,2)

  b(1,3)=a(1,2)*a(2,3)-a(1,3)*a(2,2)
  b(2,3)=a(1,3)*a(2,1)-a(1,1)*a(2,3)
  b(3,3)=a(1,1)*a(2,2)-a(1,2)*a(2,1)

  b=b/detA
  return
end SUBROUTINE calc_inverse

SUBROUTINE init_kvector(num_kgrid,system)
  use structures
  use sym_kvector, only: init_sym_kvector
  use parallelization, only: nproc_id_global, nproc_group_global
  use communication, only: comm_bcast, comm_sync_all, comm_is_root
  use salmon_global, only: file_kw
  implicit none
  integer            :: num_kgrid(3)
  type(s_dft_system) :: system
  !
  integer :: ix,iy,iz, i,iu
  integer :: ik,nk
  real(8) :: shift_k(3),B(3,3)  !,k(3)
  real(8),allocatable :: k(:,:), wtk(:)

  B = system%primitive_b
  shift_k(1:3) = 0.5d0

  ! Read from file_kw
  if(file_kw /= 'none') then
     if (comm_is_root(nproc_id_global)) then
        iu = 410
        open(iu, file=file_kw, status="old")
        read(iu, *) nk    !, nkxyz_dummy
        allocate( k(3,nk), wtk(nk) )
        do ik=1, nk
           read(iu, *) i, k(1:3,ik), wtk(ik)
        enddo
        close(iu)
     endif

     call comm_bcast(nk,  nproc_group_global)
     if(.not.allocated(k)) allocate( k(3,nk), wtk(nk) )
     call comm_bcast(k,  nproc_group_global)
     call comm_bcast(wtk,nproc_group_global)
     if( abs(sum(wtk(:))-1d0).ge.1d-5 ) stop "error in wtk (wight of k-point)"

     num_kgrid(:) = -1

  else
     nk = num_kgrid(1)*num_kgrid(2)*num_kgrid(3)
     allocate( k(3,nk), wtk(nk) )
     do ik=1,nk
        ix=mod(ik-1,num_kgrid(1))+1
        iy=mod((ik-1)/num_kgrid(1),num_kgrid(2))+1
        iz=mod((ik-1)/(num_kgrid(1)*num_kgrid(2)),num_kgrid(3))+1
        k(1,ik) = (dble(ix)-shift_k(1))/dble(num_kgrid(1))-0.5d0
        k(2,ik) = (dble(iy)-shift_k(2))/dble(num_kgrid(2))-0.5d0
        k(3,ik) = (dble(iz)-shift_k(3))/dble(num_kgrid(3))-0.5d0
     end do
     wtk(:)  = 1d0/dble(nk)

  endif

  system%nk = nk
  if ( allocated(system%vec_k) ) deallocate(system%vec_k)
  if ( allocated(system%wtk)   ) deallocate(system%wtk)
  allocate(system%vec_k(3,nk),system%wtk(nk))
  system%wtk  = wtk

  do ik=1,nk
    system%vec_k(1,ik) = k(1,ik)*B(1,1) + k(2,ik)*B(1,2) + k(3,ik)*B(1,3)
    system%vec_k(2,ik) = k(1,ik)*B(2,1) + k(2,ik)*B(2,2) + k(3,ik)*B(2,3)
    system%vec_k(3,ik) = k(1,ik)*B(3,1) + k(2,ik)*B(3,2) + k(3,ik)*B(3,3)
  end do
  call init_sym_kvector( system%vec_k, system%wtk, system%nk, B )

  return
end SUBROUTINE init_kvector

end module lattice


integer,allocatable :: a(:,:),b(:,:),c(:,:)
integer :: i,j,k
allocate(a(2,2),b(2,3),c(2,3))
print*,"digite a primeira matriz"
read(*,20)((a(i,j),j = 1,2),i = 1,2)
20 format(2(2(i3)))
write(*,1)((a(i,j),j=1,2),i=1,2)
1 format(2(2(2x,i3)/))
print*,"digite a segunda matriz"
read(*,25)((b(i,j),j = 1,3),i = 1,2)
25 format(2(3(i3)))
write(*,15)((b(i,j),j=1,3),i=1,2)
15 format(2(3(2x,i3)/))
do 2 i = 1,2 ; do 2 j = 1,3 ;c(i,j) = 0 ; do 2 k = 1,2
c(i,j) = c(i,j) + a(i,k)*b(k,j)
2 end do
write(*,3)((c(i,j),j=1,3),i=1,2)
3 format(2(3(2x,i3)/))
stop ; end


#include "AMYCAI.h"

SUBROUTINE BATHYMETRY

    USE FloatPrecision
    USE Parameters
    USE ArraySize
    USE Topography
    USE GRIDS
    IMPLICIT NONE
    INTEGER :: I , J , K
    INTEGER :: status , ISTAT
    CHARACTER(len=80) :: err_msg
    CHARACTER(len=14) :: HistoryFile
    REAL(fp) :: y, y1, y2, z1, z2, slope1, slope2, amp0 , PTBR
    INTEGER , DIMENSION(1) :: SEED = (/3/)
    REAL(fp) :: RANDOMDep
    INTEGER :: JJ

! - - - - - - - - - - - - - - - -
!
! Calculate the width and length of the
! computational basin. We calculate half
! of the channel, because the channel is
! symmetry!
!
! - - - - - - - - - - - - - - - -

    BT = DBLE(NU-NL)*dx
    LU = DBLE(MU-ML)*dy

! - - - - - - - - - - - - - - - -
!
! Define the initial shape of the
! computational basin
!
! - - - - - - - - - - - - - - - -

! = = = = = = = = = = = = = =
!  Linear slope case
! = = = = = = = = = = = = = =

    DO I = MU , ML , -1
        y = DBLE(MU-I)*dy
        DEP0(I,:) = Ini_land_Dep + y*Ini_Longi_slope
    END DO

    amp0 = Pertub
    slope2 = amp0/BT ! Half of the basin

    DO J = NL , NU , 1
        !IF(MOD(J,2)==0) THEN
        !    PTBR = 0.1
        !ELSE
        !    PTBR = -0.1
        !ENDIF
        DEP0(:,J) = DEP0(:,J) + slope2*DBLE(J-NL)*dx !+ PTBR
    END DO

! - - - - - - - - - - -
!   READ FROM HISTORY
! - - - - - - - - - - -

#ifdef HISTORYREAD

    WRITE(HistoryFile,'(A4,I6.6,A4)') 'Dep_',HistoryID,'.RES'
    OPEN(unit=10,file=HistoryFile,form='unformatted',status='old',iostat=istat,action='READ')
    READ(10) DEP0
    CLOSE(10)

#endif

#ifdef STRATIFICATION

    DO K = OL , OU
        STDEP(K) = - TDAMP0 + DZ*DBLE(K-OL)
    ENDDO

    DO I = ML , MU
        DO J = NL , NU
            DO K = OL , OU
                CRTAU(I,J,K) = DMAX1(0.4D0,0.4D0+(STDEP(K)-DEP0(I,J))*DCRTAU)
            ENDDO
        ENDDO
    ENDDO

#endif

! - - - - - - - - - - -
!   Output initial topography
! - - - - - - - - - - -

    OPEN(UNIT=10,FILE='BATHYMETRY0.TXT' ,form='unformatted',status='REPLACE',IOSTAT=ISTAT,ACTION='WRITE')
    WRITE(10) DEP0
    CLOSE(10)

! - - - - - - - - - - -
! Calculate Lateral distance
! - - - - - - - - - - -

        DO J = NL , NU
            XDistance(J) = dble(J-1)*dx
        END DO

    END SUBROUTINE BATHYMETRY

! = = = = = = = = = = = = = =
!  discontinuous Linear slope case
! = = = = = = = = = = = = = =

    ! Define the longitudinal shape
    !
    !                       Land region z2 = 0.5m
    !                      ------------
    !                     /
    !    z1=50m Dep      /  Intertidal region
    !                   /   linear slope 0.1%
    !       Outer Sea  /
    !     -------------
    !
    !    0-----------y1---y2--------->LU
    !
    != = = = = = = = = = = = = = = =
    !
    !    y1 = 20000.D0
    !    y2 = 25000.D0
    !
    !DO I = ML , MU
    !    y = DBLE(I-1)*dy
    !    IF(y <= y1) THEN
    !        DEP0(I,:) = z1
    !    ELSEIF(y>y1.AND.y<y2) THEN
    !        DEP0(I,:) = z1 - (y-y1)*slope1
    !    ELSEIF(y>=y2) THEN
    !        DEP0(I,:) = z2 !- (y-y2)*slope2
    !    ENDIF
    !END DO

!  cosine incision

    !JJ = 1
    !DO J  = NL , NU , 1
    !    IF(J>=JJ.AND.J<=NU+1-JJ) THEN
    !        DEP0(:,J) = DEP0(:,J) - amp0*COS(2.D0*PI/DBLE(NU+1-2*JJ)*DBLE(J-JJ)) + amp0
    !    END IF
    !END DO

! only erosion case

    !DEP0(:,:) = -1.5D0*TDAMP0
    !z1 = 1.5D0*TDAMP0
    !z2 = -TDAMP0
    !slope1 = (z1-z2)/DBLE(MU-ML)/dy
    !JJ = 3
    !DO I = ML , MU
    !    y = DBLE(I-ML)*dy
    !    DEP0(I,(NL+NU)/2-JJ:(NL+NU)/2+JJ) = z1 - slope1*y
    !END DO

! = = = = = = = = = = = = = =
!  van de wegen slope case
! = = = = = = = = = = = = = =

    !DO I = MU , ML , -1
    !    y = DBLE(MU-I)*dy
    !    IF(y<=5000.D0) THEN
    !        DEP0(I,:) = Ini_land_Dep + y*Ini_Longi_slope
    !    ELSE
    !        DEP0(I,:) = 1000.D0
    !    END IF
    !END DO
    !
    !amp0 = 0.01D0
    !
    !
    !slope2 = 2.D0*amp0/DBLE(NU-NL)*dx
    !
    !DO J = NL , (NL+NU)/2 , 1
    !    DEP0(:,J) = DEP0(:,J) + slope2*DBLE(J-NL)*dx
    !    DEP0(:,NL+NU-J) = DEP0(:,J)
    !END DO


!  Dll1.f90
!
!  FUNCTIONS/SUBROUTINES exported from Dll1.dll:
!  Dll1 - subroutine
!
subroutine logistical(amin,amax,x0,stp,output)

  ! Expose subroutine Dll1 to users of this DLL
  !
  !DEC$ ATTRIBUTES C,DLLEXPORT::    logistical
  !DEC$ ATTRIBUTES REFERENCE::      amin,amax,x0,stp,output
  ! Variables
    implicit none
    integer,intent(in)::    stp
    real,intent(in) ::      amin,amax,x0
    real(8)::       output(257,stp)
    integer::       n, ierr, n0,j1, i_var,sup1,inf1,sup2,inf2
    real(8)::       j
    real(8) ::      a(stp)

 ! Body of Dll
    n0=257
    j=(amax-amin)/(stp-1)
!        allocate(Logistical(n0,stp),a(stp))
        do j1=1,stp
            a(j1)=amin+j*(j1-1)
        enddo
        output(1,1:stp)=x0

    do n=1,n0-1
        output(n+1,:) = a(:) * output(n,:) * (1 - output(n,:))
    enddo
!    deallocate(Logistical)
!    plot(:,:)=0
!    temp = res*output
!    do j1 = 1,stp
!        sup1=max(temp(1,j1),temp(2,j1))-1
!        inf2=min(temp(1,j1),temp(2,j1))+1
!        sup2=sup1
!        inf1=inf2
!        do n = 1,n0-1
!          plot(inf1:sup1,:)=n
!            plot(inf2:sup2,:)=n
!            if (n==n0-1) exit
!            inf1=sup1+1
!            sup1=max(sup1,temp(n+2,j1))+1
!            sup2=inf2-1
!            inf2=min(inf2,temp(n+2,j1))-1
!        enddo
!    enddo
    return

end subroutine logistical


!>
!! Updates fluxes using a fifth order WENO5 scheme
!!
MODULE weno5

USE omp_lib, only : omp_get_thread_num
USE fluxes,  only : FluxI, FluxJ, FluxK, param, FluxI_Cell, FluxJ_Cell, FluxK_Cell

IMPLICIT NONE

#include <preprocessor.f90>

PRIVATE
PUBLIC :: WenoFluxes

! The following parameter are weights and coefficients used in the WENO5 scheme

DOUBLE PRECISION, PARAMETER, DIMENSION(3) :: weights_plus = (/ 0.3_8, 0.6_8, 0.1_8 /)

DOUBLE PRECISION, PARAMETER, DIMENSION(5) :: stencil_weights = (/ 2.0_8, 5.0_8, -1.0_8, -7.0_8, 11.0_8 /)*(1.0_8/6.0_8)

DOUBLE PRECISION, PARAMETER :: coeff_1 = 13.0_8/12.0_8

DOUBLE PRECISION, PARAMETER :: coeff_2 = 1.0_8/4.0_8

DOUBLE PRECISION, PARAMETER :: weno_tol = 1.0e-6_8

DOUBLE PRECISION, PARAMETER :: weno_n   = 2.0_8

CONTAINS

    !>
    !! Updates the fluxes based on a WENO5 scheme
    !! @param[in] Q Solution
    SUBROUTINE WenoFluxes(Q)

        DOUBLE PRECISION, DIMENSION(param%i_min:, param%j_min:, param%k_min:), INTENT(IN)  :: Q

        INTEGER :: thread_nr

        thread_nr = omp_get_thread_num()

#if(linear==1)
        ! Evaluate flux function (here f(q) = q) to get cell values of flux
        FluxI_Cell(:,:,:,thread_nr) = Q
        FluxJ_Cell(:,:,:,thread_nr) = Q
        FluxK_Cell(:,:,:,thread_nr) = Q
#elif(linear==0)
        ! Nonlinear advection: f(q)  = 0.5*q**2
        FluxI_Cell(:,:,:,thread_nr) = 0.5*Q*Q
        FluxJ_Cell(:,:,:,thread_nr) = 0.5*Q*Q
        FluxK_Cell(:,:,:,thread_nr) = 0.5*Q*Q
#else
        WRITE(*,*) 'Found value other than 0 or 1 for preprocessor flag <linear>. Now exiting...'
        STOP
#endif
        ! Now update interface values of horizontal and vertical flux
        CALL UpdateFluxI(Q, 1.0_8 )
        CALL UpdateFluxJ(Q, 1.0_8 )
        CALL UpdateFluxK(Q, 1.0_8 )

    END SUBROUTINE WenoFluxes

    !>
    !! Updates flux in x direction
    !! @param[in] Qcell Buffer with cell values
    !! @param[in] max_vel Maximum velocity, used for flux splitting
    SUBROUTINE UpdateFluxI(Qcell, max_vel)

        DOUBLE PRECISION, DIMENSION(param%i_min:,param%j_min:,param%k_min:), INTENT(IN) :: Qcell
        DOUBLE PRECISION,                                                    INTENT(IN) :: max_vel

        DOUBLE PRECISION, DIMENSION(6) :: Qcell_local, Fcell_local
        INTEGER :: i, j, k, thread_nr

        thread_nr = omp_get_thread_num()

        ! Out of the global fields Qcell and FluxQcell, updated interface
        ! values of the flux are computed

        DO k=param%k_start,param%k_end
            DO j=param%j_start,param%j_end

                ! Left boundary
                i=param%i_start-1

                ! Initialize "moving window" arrays
                Qcell_local(1) = Qcell(i-2,j,k)
                Qcell_local(2) = Qcell(i-1,j,k)
                Qcell_local(3) = Qcell(i+0,j,k)
                Qcell_local(4) = Qcell(i+1,j,k)
                Qcell_local(5) = Qcell(i+2,j,k)
                Qcell_local(6) = Qcell(i+3,j,k)

                Fcell_local(1) = FluxI_Cell(i-2,j,k,thread_nr)
                Fcell_local(2) = FluxI_Cell(i-1,j,k,thread_nr)
                Fcell_local(3) = FluxI_Cell(i+0,j,k,thread_nr)
                Fcell_local(4) = FluxI_Cell(i+1,j,k,thread_nr)
                Fcell_local(5) = FluxI_Cell(i+2,j,k,thread_nr)
                Fcell_local(6) = FluxI_Cell(i+3,j,k,thread_nr)

                ! Reconstruct interface value from local stencil
                FluxI(i+1,j,k,thread_nr) = ReconstructInterfaceValue(Qcell_local, Fcell_local, max_vel)

                ! Inner cells
                DO i=param%i_start,param%i_end
                        ! Update local "moving window" arrays
                        CALL ShiftLocalValues(Qcell_local, Fcell_local, Qcell(i+3,j,k), FluxI_Cell(i+3,j,k,thread_nr))
                        ! Reconstruct flux value at interface from current local window
                        FluxI(i+1,j,k,thread_nr) =  ReconstructInterfaceValue(Qcell_local, Fcell_local, max_vel)
                END DO

            END DO
        END DO

    END SUBROUTINE UpdateFluxI

    !>
    !! Updates flux in y direction
    !! @param[in] Qcell Buffer with cell values
    !! @param[in] max_vel Maximum velocity, used for flux splitting
    SUBROUTINE UpdateFluxJ(Qcell, max_vel)

        DOUBLE PRECISION, DIMENSION(param%i_min:,param%j_min:,param%k_min:), INTENT(IN) :: Qcell
        DOUBLE PRECISION,                                                    INTENT(IN) :: max_vel

        DOUBLE PRECISION, DIMENSION(6) :: Qcell_local, Fcell_local
        INTEGER :: i, j, k, thread_nr

        thread_nr = omp_get_thread_num()

        ! Out of the global fields Qcell and FluxQcell, updated interface
        ! values of the flux are computed

        DO k=param%k_start, param%k_end
            DO i=param%i_start,param%i_end

                j=param%j_start-1
                Qcell_local(1) = Qcell(i,j-2,k)
                Qcell_local(2) = Qcell(i,j-1,k)
                Qcell_local(3) = Qcell(i,j+0,k)
                Qcell_local(4) = Qcell(i,j+1,k)
                Qcell_local(5) = Qcell(i,j+2,k)
                Qcell_local(6) = Qcell(i,j+3,k)

                Fcell_local(1) = FluxJ_Cell(i,j-2,k,thread_nr)
                Fcell_local(2) = FluxJ_Cell(i,j-1,k,thread_nr)
                Fcell_local(3) = FluxJ_Cell(i,j+0,k,thread_nr)
                Fcell_local(4) = FluxJ_Cell(i,j+1,k,thread_nr)
                Fcell_local(5) = FluxJ_Cell(i,j+2,k,thread_nr)
                Fcell_local(6) = FluxJ_Cell(i,j+3,k,thread_nr)

                FluxJ(i,j+1,k,thread_nr) = ReconstructInterfaceValue(Qcell_local, Fcell_local, max_vel)

                DO j=param%j_start,param%j_end
                    CALL ShiftLocalValues(Qcell_local, Fcell_local, Qcell(i,j+3,k), FluxJ_Cell(i,j+3,k,thread_nr))
                    FluxJ(i,j+1,k,thread_nr) = ReconstructInterfaceValue(Qcell_local, Fcell_local, max_vel)
                END DO

            END DO
        END DO

    END SUBROUTINE UpdateFluxJ

    !>
    !! Updates flux in z direction
    !! @param[in] Qcell Buffer with cell values
    !! @param[in] max_vel Maximum velocity, used for flux splitting
    SUBROUTINE UpdateFluxK(Qcell, max_vel)

        DOUBLE PRECISION, DIMENSION(param%i_min:,param%j_min:,param%k_min:), INTENT(IN) :: Qcell
        DOUBLE PRECISION,                                                    INTENT(IN) :: max_vel

        DOUBLE PRECISION, DIMENSION(6) :: Qcell_local, Fcell_local
        INTEGER :: i, j, k, thread_nr

        thread_nr = omp_get_thread_num()

        ! Out of the global fields Qcell and FluxQcell, updated interface
        ! values of the flux are computed
        DO i=param%i_start,param%i_end
            DO j=param%j_start,param%j_end

                k=param%k_start-1
                Qcell_local(1) = Qcell(i,j,k-2)
                Qcell_local(2) = Qcell(i,j,k-1)
                Qcell_local(3) = Qcell(i,j,k+0)
                Qcell_local(4) = Qcell(i,j,k+1)
                Qcell_local(5) = Qcell(i,j,k+2)
                Qcell_local(6) = Qcell(i,j,k+3)

                Fcell_local(1) = FluxK_Cell(i,j,k-2,thread_nr)
                Fcell_local(2) = FluxK_Cell(i,j,k-1,thread_nr)
                Fcell_local(3) = FluxK_Cell(i,j,k+0,thread_nr)
                Fcell_local(4) = FluxK_Cell(i,j,k+1,thread_nr)
                Fcell_local(5) = FluxK_Cell(i,j,k+2,thread_nr)
                Fcell_local(6) = FluxK_Cell(i,j,k+3,thread_nr)

                FluxK(i,j,k+1,thread_nr) = ReconstructInterfaceValue(Qcell_local, Fcell_local, max_vel)

                DO k=param%k_start,param%k_end
                    CALL ShiftLocalValues(Qcell_local, Fcell_local, Qcell(i,j,k+3), FluxK_Cell(i,j,k+3,thread_nr))
                    FluxK(i,j,k+1,thread_nr) = ReconstructInterfaceValue(Qcell_local, Fcell_local, max_vel)
                END DO

            END DO
        END DO

    END SUBROUTINE UpdateFluxK

!
! Below are three auxiliary functions used by the WENO method that all operate on the
! local solution values: At each point, WENO5 uses information from a six-point wide
! stencil. The buffer Qcell_local contains the cell-values of the solution Q at these six
! points, Fcell_local contains the cell-values of the flux at these six points. Using
! the WENO procedure, from these 2x6 values a new value for Flux(I,J,K)_Int, that is
! a flux value at the interface is reconstructed.
!

    !> Moves all values in Qcell_local and Fcell_local one index down and inserts new
    !! values at index 6.
    !! @param[in] Qcell_new New cell value to be added
    !! @param[in] Fcell_new New flux value to be added
    !! @param[inout] Qcell_local Old array of cell values to which Qcell_new will be added
    !! @param[inout] Fcell_local Old array of flux values to which Fcell_new will be added
    PURE SUBROUTINE ShiftLocalValues(Qcell_local, Fcell_local, Qcell_new, Fcell_new)

    DOUBLE PRECISION, DIMENSION(6), INTENT(INOUT) :: Qcell_local, Fcell_local
    DOUBLE PRECISION,               INTENT(IN)    :: Qcell_new, Fcell_new

    INTEGER :: i

    ! Shift all values one to the left
    DO i=1,5
        Qcell_local(i) = Qcell_local(i+1)
        Fcell_local(i) = Fcell_local(i+1)
    END DO

    ! ..and fill in the new values to the right
    Qcell_local(6) = Qcell_new
    Fcell_local(6) = Fcell_new

    END SUBROUTINE ShiftLocalValues

    !> This routine performs the actual reconstruction of an interface value
    !! @param[in] Qcell_local Six cell values, three to each side of the interface
    !! @param[in] Fcell_local Six flux values, three to each side of the interface
    !! @param[in] local_vel Local velocity to be used for possible local flux splitting
    !! @param[out] Fint Reconstructed interface value
    FUNCTION ReconstructInterfaceValue(Qcell_local, Fcell_local, local_vel) RESULT(Fint)

        DOUBLE PRECISION, DIMENSION(6) :: Qcell_local, Fcell_local
        DOUBLE PRECISION               :: local_vel, Fint

        DOUBLE PRECISION, DIMENSION(5) :: Fcell_plus, Fcell_minus
        DOUBLE PRECISION               :: Fint_plus,  Fint_minus

        ! From the local values of Q and flux of Q, retrieve the positive and negative
        ! components of the flux function Fcell_plus and Fcell_minus
        CALL GetLocalFluxSplit(Qcell_local, Fcell_local, local_vel, Fcell_plus, Fcell_minus)

        ! Perform a WENO reconstruction of the interface value for the positive and negative
        ! component
        CALL GetWenoInterfaceValue(Fcell_plus, Fcell_minus, Fint_plus, Fint_minus)

        ! The final interface value is the sum of the values reconstructed from the positive
        ! and negative flux component
        Fint = Fint_plus + Fint_minus

        CONTAINS

            !> Local Lax-Friedrichs flux-splitting
            PURE SUBROUTINE GetLocalFluxSplit(Qcell_local, Fcell_local, local_vel, Fcell_plus, Fcell_minus)

                DOUBLE PRECISION, DIMENSION(6), INTENT(IN)  :: Qcell_local, Fcell_local
                DOUBLE PRECISION,               INTENT(IN)  :: local_vel
                DOUBLE PRECISION, DIMENSION(5), INTENT(OUT) :: Fcell_plus, Fcell_minus

                ! Lax-Friedrichs flux-splitting
                Fcell_plus( 1:5) = 0.5_8*( Fcell_local(1:5) + local_vel*Qcell_local(1:5) )
                Fcell_minus(1:5) = 0.5_8*( Fcell_local(2:6) - local_vel*Qcell_local(2:6) )

            END SUBROUTINE GetLocalFluxSplit

            !> In this routine, the WENO magic happens: The three candidate stencils are
            !! calculated, the smoothness measures beta and then the final weights
            PURE SUBROUTINE GetWenoInterfaceValue(Fcell_plus, Fcell_minus, Fint_plus, Fint_minus)

                DOUBLE PRECISION, DIMENSION(5), INTENT(IN)  :: Fcell_plus, Fcell_minus
                DOUBLE PRECISION,               INTENT(OUT) :: Fint_plus, Fint_minus

                DOUBLE PRECISION, DIMENSION(3) :: pol_values, beta, alpha
                DOUBLE PRECISION               :: alpha_sum_inv

                ! Compute three possible stencils with indices 1,2,3 // 2,3,4 // 3,4,5
                pol_values(1) = stencil_weights(1)*Fcell_plus(3) + stencil_weights(2)*Fcell_plus(4) + stencil_weights(3)*Fcell_plus(5)
                pol_values(2) = stencil_weights(3)*Fcell_plus(2) + stencil_weights(2)*Fcell_plus(3) + stencil_weights(1)*Fcell_plus(4)
                pol_values(3) = stencil_weights(1)*Fcell_plus(1) + stencil_weights(4)*Fcell_plus(2) + stencil_weights(5)*Fcell_plus(3)

                ! Second, compute smoothness measures (magic formula from WENO paper)
                beta(1) = coeff_1*( Fcell_plus(3) - 2.0_8*Fcell_plus(4) + Fcell_plus(5) )**2.0 + coeff_2*( 3.0_8*Fcell_plus(3) - 4.0_8*Fcell_plus(4) +     Fcell_plus(5) )**2.0
                beta(2) = coeff_1*( Fcell_plus(2) - 2.0_8*Fcell_plus(3) + Fcell_plus(4) )**2.0 + coeff_2*(       Fcell_plus(2)                       -     Fcell_plus(4) )**2.0
                beta(3) = coeff_1*( Fcell_plus(1) - 2.0_8*Fcell_plus(2) + Fcell_plus(3) )**2.0 + coeff_2*(       Fcell_plus(1) - 4.0_8*Fcell_plus(2) + 3.0_8*Fcell_plus(3) )**2.0

                ! Third, compute weights out of the smoothness measures
                alpha(1) = weights_plus(1)/( beta(1) + weno_tol )**weno_n
                alpha(2) = weights_plus(2)/( beta(2) + weno_tol )**weno_n
                alpha(3) = weights_plus(3)/( beta(3) + weno_tol )**weno_n

                ! Fourth, normalize the weights.
                alpha_sum_inv = 1.0_8/SUM(alpha)
                alpha         = alpha_sum_inv*alpha

                ! Finally, compute the superposition of the three candidate-stencil values using the computed weights
                Fint_plus = alpha(1)*pol_values(1) + alpha(2)*pol_values(2) + alpha(3)*pol_values(3)

                ! *** Now perform corresponding computation for Fcell_minus ****
                pol_values(1) = stencil_weights(5)*Fcell_minus(3) + stencil_weights(4)*Fcell_minus(4) + stencil_weights(1)*Fcell_minus(5)
                pol_values(2) = stencil_weights(1)*Fcell_minus(2) + stencil_weights(2)*Fcell_minus(3) + stencil_weights(3)*Fcell_minus(4)
                pol_values(3) = stencil_weights(3)*Fcell_minus(1) + stencil_weights(2)*Fcell_minus(2) + stencil_weights(1)*Fcell_minus(3)

                ! Smoothness measures
                beta(1) = coeff_1*(       Fcell_minus(3) - 2.0*Fcell_minus(4) +     Fcell_minus(5) )**2.0 + coeff_2*(   3.0_8*Fcell_minus(3) - 4.0_8*Fcell_minus(4) +       Fcell_minus(5) )**2.0
                beta(2) = coeff_1*(       Fcell_minus(2) - 2.0*Fcell_minus(3) +     Fcell_minus(4) )**2.0 + coeff_2*(         Fcell_minus(2)                        -       Fcell_minus(4) )**2.0
                beta(3) = coeff_1*(       Fcell_minus(1) - 2.0*Fcell_minus(2) +     Fcell_minus(3) )**2.0 + coeff_2*(         Fcell_minus(1) - 4.0_8*Fcell_minus(2) + 3.0_8*Fcell_minus(3) )**2.0

                ! Compute weights
                alpha(1) = weights_plus(3)/( beta(1) + weno_tol )**weno_n
                alpha(2) = weights_plus(2)/( beta(2) + weno_tol )**weno_n
                alpha(3) = weights_plus(1)/( beta(3) + weno_tol )**weno_n

                ! Normalize weights
                alpha_sum_inv = 1.0_8/SUM(alpha)
                alpha = alpha_sum_inv*alpha

                Fint_minus = alpha(1)*pol_values(1) + alpha(2)*pol_values(2) + alpha(3)*pol_values(3)

            END SUBROUTINE GetWenoInterfaceValue

    END FUNCTION ReconstructInterfaceValue

END MODULE WENO5


subroutine interpol_phi(ind_cell,phi_int,ncell,ilevel,icount)
  use amr_commons
  use poisson_commons, only:phi,phi_old
  implicit none
  integer::ncell,ilevel,icount
  integer ,dimension(1:nvector)::ind_cell
  real(dp),dimension(1:nvector,1:twotondim)::phi_int

  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! Routine for interpolation at level-boundaries. Interpolation is used for
  ! - boundary conditions for solving poisson equation at fine level
  ! - computing force (gradient_phi) at fine level for cells close to boundary
  ! Interpolation is performed in space (CIC) and - if adaptive timestepping is on -
  ! time (linear extrapolation of the change in phi during the last coarse step
  ! onto the first fine step)
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

  integer ,dimension(1:nvector,1:twotondim),save::nbors_father_grids
  integer ,dimension(1:nvector,1:threetondim),save::nbors_father_cells
  integer::i,ind,indice,ind_average,ind_father
  real(dp)::dx,tfrac

  real(dp)::aa,bb,cc,dd,coeff,add
  integer,dimension(1:8,1:8)::ccc
  real(dp),dimension(1:8)::bbbb

  ! CIC method constants
  aa = 1.0D0/4.0D0**ndim
  bb = 3.0D0*aa
  cc = 9.0D0*aa
  dd = 27.D0*aa
  bbbb(:)  =(/aa ,bb ,bb ,cc ,bb ,cc ,cc ,dd/)

  !sampling positions in the 3x3x3 father cell cube
  ccc(:,1)=(/1 ,2 ,4 ,5 ,10,11,13,14/)
  ccc(:,2)=(/3 ,2 ,6 ,5 ,12,11,15,14/)
  ccc(:,3)=(/7 ,8 ,4 ,5 ,16,17,13,14/)
  ccc(:,4)=(/9 ,8 ,6 ,5 ,18,17,15,14/)
  ccc(:,5)=(/19,20,22,23,10,11,13,14/)
  ccc(:,6)=(/21,20,24,23,12,11,15,14/)
  ccc(:,7)=(/25,26,22,23,16,17,13,14/)
  ccc(:,8)=(/27,26,24,23,18,17,15,14/)

  if (icount .ne. 1 .and. icount .ne. 2)then
     write(*,*), 'icount has bad value'
     call clean_stop
  endif

  !compute fraction of timesteps for interpolation
  if (dtold(ilevel-1)> 0)then
     !tfrac=0.
     tfrac=1.0*dtnew(ilevel)/dtold(ilevel-1)*(icount-1)
  else
     tfrac=0.
  end if

  ! Mesh size at level ilevel
  dx=0.5D0**ilevel
  call get3cubefather(ind_cell,nbors_father_cells,nbors_father_grids,ncell,ilevel)

  ! Third order phi interpolation
  do ind=1,twotondim
     do i=1,ncell
        phi_int(i,ind)=0d0
     end do
     do ind_average=1,twotondim
        ind_father=ccc(ind_average,ind)
        coeff=bbbb(ind_average)
        do i=1,ncell
           indice=nbors_father_cells(i,ind_father)
           if (indice==0) then
              write(*,*),'no all neighbors present in interpol_phi...'
              add=coeff*(phi(ind_cell(i))+(phi(ind_cell(i))-phi_old(ind_cell(i)))*tfrac)
              !               add=coeff*(-3d0/8d0*dx**2*boxlen*rho(ind_cell(i))+phi(ind_cell(i)))
           else
              add=coeff*(phi(indice)+(phi(indice)-phi_old(indice))*tfrac)
              !               add=coeff*(-3d0/8d0*dx**2*boxlen*rho(indice)+phi(indice))
           endif
           phi_int(i,ind)=phi_int(i,ind)+add
        end do
     end do
  end do

 end subroutine interpol_phi
!###########################################################
!###########################################################
!###########################################################
!###########################################################
subroutine save_phi_old(ilevel)
  use amr_commons
  use poisson_commons, only:phi,phi_old
  implicit none
  integer ilevel

  !save the old potential for time extrapolation in case of subcycling

  integer::i,ncache,ind,igrid,iskip,istart,ibound
  integer,allocatable,dimension(:)::ind_grid

  do ibound=1,nboundary+ncpu
     if(ibound<=ncpu)then
        ncache=numbl(ibound,ilevel)
        istart=headl(ibound,ilevel)
     else
        ncache=numbb(ibound-ncpu,ilevel)
        istart=headb(ibound-ncpu,ilevel)
     end if
     if(ncache>0)then
        allocate(ind_grid(1:ncache))
        ! Loop over level grids
        igrid=istart
        do i=1,ncache
           ind_grid(i)=igrid
           igrid=next(igrid)
        end do
        ! Loop over cells
        do ind=1,twotondim
           iskip=ncoarse+(ind-1)*ngridmax
           ! save phi
           do i=1,ncache
              phi_old(ind_grid(i)+iskip)=phi(ind_grid(i)+iskip)
           end do
        end do
        deallocate(ind_grid)
     end if
  end do

end subroutine save_phi_old


module numerical_jac_module

  use amrex_fort_module, only : rt => amrex_real
  implicit none

contains

  subroutine numerical_jac(state)

    !$acc routine seq

    use bs_rhs_module, only: f_bs_rhs
    use extern_probin_module, only: centered_diff_jac
    use sdc_type_module, only: sdc_t, SVAR_EVOLVE
    use bs_type_module, only: bs_t
    use amrex_constants_module, only: ZERO, HALF, ONE

    implicit none

    type (bs_t)    :: state
    type (bs_t)    :: state_delp, state_delm

    integer        :: m, n

    ! the choice of eps should be ~ sqrt(eps), where eps is machine epsilon.
    ! this balances truncation vs. roundoff error in the differencing
    real(rt), parameter :: eps = 1.e-8_rt, SMALL = 1.e-8_rt

    state % jac(:,:) = ZERO

    ! default
    call f_bs_rhs(state)

    if (centered_diff_jac) then

       state_delp = state
       state_delm = state

       do n = 1, SVAR_EVOLVE

          state_delp % y = state % y
          state_delp % y(n) = state % y(n) * (ONE + eps)

          call f_bs_rhs(state_delp)

          state_delm % y = state % y
          state_delm % y(n) = state % y(n) * (ONE - eps)

          call f_bs_rhs(state_delm)

          do m = 1, SVAR_EVOLVE

             state % jac(m,n) = (state_delp % ydot(m) - state_delm % ydot(m)) / ((state_delp % y(n) - state_delm % y(n)) + SMALL)

          enddo

       enddo

    else

       state_delp = state

       do n = 1, SVAR_EVOLVE

          state_delp % y = state % y
          state_delp % y(n) = state % y(n) * (ONE + eps)

          call f_bs_rhs(state_delp)

          do m = 1, SVAR_EVOLVE

             state % jac(m,n) = (state_delp % ydot(m) - state % ydot(m)) / ((state_delp % y(n) - state % y(n)) + SMALL)

          enddo

       enddo

    endif

  end subroutine numerical_jac

end module numerical_jac_module


program main
  use iso_fortran_env, only: wp => real64
  use misc, only: mysub, pi
  use runge_kutta, only: rk_wrapper
  use lib_array, only: linspace
  implicit none

  integer                       :: ii, ios
  integer, parameter            :: n = 3, num_t = 10
  real(wp)                      :: t0, tend
  real(wp), dimension(num_t)    :: t
  real(wp), dimension(n)        :: y0
  real(wp), dimension(num_t,n)  :: y

  ! Set time vector `t`
  t0   = 0.0_wp
  tend = 100._wp
  ! tend = 4_wp*pi
  call linspace(t0, tend, t)

  ! Set y vector `y` using y0
  ! y0 = [0._wp, 0.1_wp]
  ! y0 = [2._wp, 0._wp]
  ! y0 = [ 0._wp ]
  ! y0 = [0.1_wp, 10.0_wp, 10.0_wp]
  ! y0      = [1._wp, 0._wp, -1._wp]
  y0      = [1._wp, 0._wp, 0._wp]
  y(1,:)  = y0

  open(unit=22, file='raw.out', iostat=ios, status="replace", action="write")
  if ( ios /= 0 ) stop "Error opening file 22"

  write(22,*) t0, 0._wp, y0
  call rk_wrapper(n, num_t, t, y, mysub)

  close(unit=22, iostat=ios)
  if ( ios /= 0 ) stop "Error closing file unit 22"

  open(unit=21, file='data.out', iostat=ios, status="replace", action="write")
  if ( ios /= 0 ) stop "Error opening file 21"

  do ii = 1, num_t
      write(21,*) t(ii), y(ii, :)
  end do

  close(unit=21, iostat=ios)
  if ( ios /= 0 ) stop "Error closing file unit 21"

end program main


c      program DRDLNREL
c>> 1999-07-27 DRDLNREL Krogh analyz => DANAL for global analysis.
c>> 1996-07-09 DRDLNREL Krogh Moved formats up.
c>> 1994-11-02 DRDLNREL Krogh  Changes to use M77CON
c>> 1994-07-06 DRDLNREL WVS set up for chgtyp
c
c     Demonstration driver for more accurate routines from chapter 2-15.
c     To illustrate worst-case, expressions are computed little-by-
c     little.  If possible, the routine should be compiled with an
c     option that causes results not to be stored in registers from one
c     assignment to the next.  For Lahey Fortran on a PC, use /7.
c
c--D replaces "?": DR?LNREL, ?GAMMA, ?LNREL, ?RLOG1, ?RLOG, ?REXP
c--   &              ?SINPX, ?COSPX, ?SINHM, ?COSHM, ?CSHMM, ?GAM1
c--   &              ?COS1, ?SIN1, ?ANAL
      double precision DPI
      parameter (DPI = 3.141592653589793238462643383279502884197D0)
      double precision D, D1MACH, DGAMMA, U, W
      external D1MACH, DGAMMA
      double precision DLNREL, DRLOG1, DRLOG, DREXP, DSINPX, DCOSPX
      double precision DSINHM, DCOSHM, DCSHMM, DGAM1
      double precision DCOS1, DSIN1
      external DLNREL, DRLOG1, DRLOG, DREXP, DSINPX, DCOSPX
      external DSINHM, DCOSHM, DCSHMM, DGAM1
      external DCOS1, DSIN1
10    format (' Error is (relative error) / (round off level).'/
     1' Round off level is (smallest number r such that 1 + r .NE. 1).'/
     2' For the present machine, r =',1p,g13.6/
     3' Errors less than 0.5 r should be considered to be zero.')
c
c     DLNREL
      d = 1.0d0 / 2.0d0**12
      w = 1.0d0 + d
      w = log(w)
      u = dlnrel(d)
      call DANAL ('DLNREL',d,u,w)
c
c     DRLOG1
      w = d - w
      u = drlog1(d)
      call DANAL ('DRLOG1',d,u,w)
c
c     DRLOG
      w = d - 1.0d0
      w = w - log(d)
      u = drlog(d)
      call DANAL ('DRLOG ',d,u,w)
c
c     DREXP
      w = exp(d)
      w = w - 1.0d0
      u = drexp(d)
      call DANAL ('DREXP ',d,u,w)
c
c     DSINPX
      d = 25.125d0
      w = sin(d*dpi)
      u = dsinpx(d)
      call DANAL ('DSINPX',d,u,w)
c
c     DCOSPX
      w = cos(d*dpi)
      u = dcospx(d)
      call DANAL ('DCOSPX',d,u,w)
c
c     DSIN1
      d = 0.5d0**22
      w = sin(d)
      w = (d - w) / d**3
      u = dsin1(d)
      call DANAL ('DSIN1 ',d,u,w)
c
c     DCOS1
      w = cos(d)
      w = (d - w) / d**2
      u = dcos1(d)
      call DANAL ('DCOS1 ',d,u,w)
c
c     DSINHM
      d = 0.25d0
      w = sinh(d)
      w = w - d
      u = dsinhm(d)
      call DANAL ('DSINHM',d,u,w)
c
c     DCOSHM
      w = cosh(d)
      w = w - 1.0d0
      u = dcoshm(d)
      call DANAL ('DCOSHM',d,u,w)
c
c     DCSHMM
      w = cosh(d)
      w = w - 1.0d0
      w = w - 0.5*d*d
      u = dcshmm(d)
      call DANAL ('DCSHMM',d,u,w)
c
c     DGAM1
      w = 1.0d0/dgamma(1.0d0+d)
      w = w - 1.0d0
      u = dgam1(d)
      call DANAL ('DGAM1 ',d,u,w)
c
      print 10, d1mach(4)
      stop
      end

      subroutine DANAL (ROUTIN, X, U, W)
      character*6 ROUTIN
      double precision X, U, W, EW
      double precision D1MACH
      external D1MACH
      double precision ROUND
      save ROUND
      data ROUND /-1.0d0/
10    format (
     1' Function                    Result         ---- Not Using ----'/
     2' From This                   Using This     --- This Package --'/
     3' Package        Argument     Package        Result        Error')
20    format (1x,a6,5x,1p,e12.4,2x,e13.6,2x,e13.6,1x,e9.2)
      if (round .lt. 0.0d0) then
         round = d1mach(4)
         print 10
      end if
      ew = abs(w-u)/abs(u*round)
      print 20, routin,x,u,w,ew
      return
      end