      SUBROUTINE MB03LZ( COMPQ, ORTH, N, A, LDA, DE, LDDE, B, LDB, FG,
     $                   LDFG, NEIG, Q, LDQ, ALPHAR, ALPHAI, BETA,
     $                   IWORK, DWORK, LDWORK, ZWORK, LZWORK, BWORK,
     $                   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 complex N-by-N skew-Hamiltonian/
C     Hamiltonian pencil aS - bH, with
C
C           (  A  D  )         (  B  F  )
C       S = (        ) and H = (        ).                           (1)
C           (  E  A' )         (  G -B' )
C
C     The structured Schur form of the embedded real skew-Hamiltonian/
C     skew-Hamiltonian pencil aB_S - bB_T, defined as
C
C             (  Re(A)  -Im(A)  |  Re(D)  -Im(D)  )
C             (                 |                 )
C             (  Im(A)   Re(A)  |  Im(D)   Re(D)  )
C             (                 |                 )
C       B_S = (-----------------+-----------------) , and
C             (                 |                 )
C             (  Re(E)  -Im(E)  |  Re(A')  Im(A') )
C             (                 |                 )
C             (  Im(E)   Re(E)  | -Im(A')  Re(A') )
C                                                                    (2)
C             ( -Im(B)  -Re(B)  | -Im(F)  -Re(F)  )
C             (                 |                 )
C             (  Re(B)  -Im(B)  |  Re(F)  -Im(F)  )
C             (                 |                 )
C       B_T = (-----------------+-----------------) ,  T = i*H,
C             (                 |                 )
C             ( -Im(G)  -Re(G)  | -Im(B')  Re(B') )
C             (                 |                 )
C             (  Re(G)  -Im(G)  | -Re(B') -Im(B') )
C
C     is determined and used to compute the eigenvalues. The notation M'
C     denotes the conjugate transpose of the matrix M. Optionally,
C     if COMPQ = 'C', an orthonormal basis of the right deflating
C     subspace of the pencil aS - bH, corresponding to the eigenvalues
C     with strictly negative real part, is computed. Namely, after
C     transforming aB_S - bB_H by unitary matrices, we have
C
C                ( BA  BD  )              ( BB  BF  )
C       B_Sout = (         ) and B_Hout = (         ),               (3)
C                (  0  BA' )              (  0 -BB' )
C
C     and the eigenvalues with strictly negative real part of the
C     complex pencil aB_Sout - bB_Hout are moved to the top. The
C     embedding doubles the multiplicities of the eigenvalues of the
C     pencil aS - bH.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     COMPQ   CHARACTER*1
C             Specifies whether to compute the deflating subspace
C             corresponding to the eigenvalues of aS - bH with strictly
C             negative real part.
C             = 'N': do not compute the deflating subspace; compute the
C                    eigenvalues only;
C             = 'C': compute the deflating subspace and store it in the
C                    leading subarray of Q.
C
C     ORTH    CHARACTER*1
C             If COMPQ = 'C', specifies the technique for computing an
C             orthonormal basis of the deflating subspace, as follows:
C             = 'P':  QR factorization with column pivoting;
C             = 'S':  singular value decomposition.
C             If COMPQ = 'N', the ORTH value is not used.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the pencil aS - bH.  N >= 0, even.
C
C     A       (input/output) COMPLEX*16 array, dimension (LDA, N)
C             On entry, the leading N/2-by-N/2 part of this array must
C             contain the matrix A.
C             On exit, if COMPQ = 'C', the leading N-by-N part of this
C             array contains the upper triangular matrix BA in (3) (see
C             also METHOD). The strictly lower triangular part is not
C             zeroed; it is preserved in the leading N/2-by-N/2 part.
C             If COMPQ = 'N', this array is unchanged on exit.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= MAX(1, N).
C
C     DE      (input/output) COMPLEX*16 array, dimension (LDDE, N)
C             On entry, the leading N/2-by-N/2 lower triangular part of
C             this array must contain the lower triangular part of the
C             skew-Hermitian matrix E, and the N/2-by-N/2 upper
C             triangular part of the submatrix in the columns 2 to N/2+1
C             of this array must contain the upper triangular part of
C             the skew-Hermitian matrix D.
C             On exit, if COMPQ = 'C', the leading N-by-N part of this
C             array contains the skew-Hermitian matrix BD in (3) (see
C             also METHOD). The strictly lower triangular part of the
C             input matrix is preserved.
C             If COMPQ = 'N', this array is unchanged on exit.
C
C     LDDE    INTEGER
C             The leading dimension of the array DE.  LDDE >= MAX(1, N).
C
C     B       (input/output) COMPLEX*16 array, dimension (LDB, N)
C             On entry, the leading N/2-by-N/2 part of this array must
C             contain the matrix B.
C             On exit, if COMPQ = 'C', the leading N-by-N part of this
C             array contains the upper triangular matrix BB in (3) (see
C             also METHOD). The strictly lower triangular part is not
C             zeroed; the elements below the first subdiagonal of the
C             input matrix are preserved.
C             If COMPQ = 'N', this array is unchanged on exit.
C
C     LDB     INTEGER
C             The leading dimension of the array B.  LDB >= MAX(1, N).
C
C     FG      (input/output) COMPLEX*16 array, dimension (LDFG, N)
C             On entry, the leading N/2-by-N/2 lower triangular part of
C             this array must contain the lower triangular part of the
C             Hermitian matrix G, and the N/2-by-N/2 upper triangular
C             part of the submatrix in the columns 2 to N/2+1 of this
C             array must contain the upper triangular part of the
C             Hermitian matrix F.
C             On exit, if COMPQ = 'C', the leading N-by-N part of this
C             array contains the Hermitian matrix BF in (3) (see also
C             METHOD). The strictly lower triangular part of the input
C             matrix is preserved. The diagonal elements might have tiny
C             imaginary parts.
C             If COMPQ = 'N', this array is unchanged on exit.
C
C     LDFG    INTEGER
C             The leading dimension of the array FG.  LDFG >= MAX(1, N).
C
C     NEIG    (output) INTEGER
C             If COMPQ = 'C', the number of eigenvalues in aS - bH with
C             strictly negative real part.
C
C     Q       (output) COMPLEX*16 array, dimension (LDQ, 2*N)
C             On exit, if COMPQ = 'C', the leading N-by-NEIG part of
C             this array contains an orthonormal basis of the right
C             deflating subspace corresponding to the eigenvalues of the
C             pencil aS - bH with strictly negative real part.
C             The remaining entries are meaningless.
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, 2*N), if COMPQ = 'C'.
C
C     ALPHAR  (output) DOUBLE PRECISION array, dimension (N)
C             The real parts of each scalar alpha defining an eigenvalue
C             of the pencil aS - bH.
C
C     ALPHAI  (output) DOUBLE PRECISION array, dimension (N)
C             The imaginary parts of each scalar alpha defining an
C             eigenvalue of the pencil aS - bH.
C             If ALPHAI(j) is zero, then the j-th eigenvalue is real.
C
C     BETA    (output) DOUBLE PRECISION array, dimension (N)
C             The scalars beta that define the eigenvalues of the pencil
C             aS - bH.
C             Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and
C             beta = BETA(j) represent the j-th eigenvalue of the pencil
C             aS - bH, in the form lambda = alpha/beta. Since lambda may
C             overflow, the ratios should not, in general, be computed.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (N+1)
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) returns the optimal LDWORK.
C             On exit, if INFO = -20, DWORK(1) returns the minimum value
C             of LDWORK.
C
C     LDWORK  INTEGER
C             The dimension of the array DWORK.
C             LDWORK >= MAX( 4*N*N + 2*N + MAX(3,N) ), if COMPQ = 'N';
C             LDWORK >= MAX( 1, 11*N*N + 2*N ),        if COMPQ = 'C'.
C             For good performance LDWORK should be generally 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     ZWORK   COMPLEX*16 array, dimension (LZWORK)
C             On exit, if INFO = 0, ZWORK(1) returns the optimal LZWORK.
C             On exit, if INFO = -22, ZWORK(1) returns the minimum value
C             of LZWORK.
C
C     LZWORK  INTEGER
C             The dimension of the array ZWORK.
C             LZWORK >= 1,       if COMPQ = 'N';
C             LZWORK >= 8*N + 4, if COMPQ = 'C'.
C             For good performance LZWORK should be generally larger.
C
C             If LZWORK = -1, then a workspace query is assumed;
C             the routine only calculates the optimal size of the
C             ZWORK array, returns this value as the first entry of
C             the ZWORK array, and no error message related to LZWORK
C             is issued by XERBLA.
C
C     BWORK   LOGICAL array, dimension (LBWORK)
C             LBWORK >= 0,     if COMPQ = 'N';
C             LBWORK >= N - 1, if COMPQ = 'C'.
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 SLICOT Library routine
C                  MB04FD (QZ iteration did not converge or computation
C                  of the shifts failed);
C             = 2: QZ iteration failed in the LAPACK routine ZHGEQZ when
C                  trying to triangularize the 2-by-2 blocks;
C             = 3: the singular value decomposition failed in the LAPACK
C                  routine ZGESVD (for ORTH = 'S');
C             = 4: warning: the pencil is numerically singular.
C
C     METHOD
C
C     First, T = i*H is set. Then, the embeddings, B_S and B_T, of the
C     matrices S and T, are determined and, subsequently, the SLICOT
C     Library routine MB04FD is applied to compute the structured Schur
C     form, i.e., the factorizations
C
C     ~                     (  S11  S12  )
C     B_S = J Q' J' B_S Q = (            ) and
C                           (   0   S11' )
C
C     ~                     (  T11  T12  )           (  0  I  )
C     B_T = J Q' J' B_T Q = (            ), with J = (        ),
C                           (   0   T11' )           ( -I  0  )
C
C     where Q is real orthogonal, S11 is upper triangular, and T11 is
C     upper quasi-triangular.
C
C     Second, the SLICOT Library routine MB03JZ is applied, to compute a
C                    ~
C     unitary matrix Q, such that
C
C                        ~    ~
C       ~     ~   ~   (  S11  S12  )
C     J Q' J' B_S Q = (       ~    ) =: B_Sout,
C                     (   0   S11' )
C
C       ~        ~    ~   (  H11  H12  )
C     J Q' J'(-i*B_T) Q = (            ) =: B_Hout,
C                         (   0  -H11' )
C          ~                                               ~       ~
C     with S11, H11 upper triangular, and such that Spec_-(B_S, -i*B_T)
C     is contained in the spectrum of the 2*NEIG-by-2*NEIG leading
C                          ~
C     principal subpencil aS11 - bH11.
C
C     Finally, the right deflating subspace is computed.
C     See also page 22 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     complex floating point operations.
C
C     FURTHER COMMENTS
C
C     This routine does not perform any scaling of the matrices. Scaling
C     might sometimes be useful, and it should be done externally.
C
C     CONTRIBUTOR
C
C     Matthias Voigt, Fakultaet fuer Mathematik, Technische Universitaet
C     Chemnitz, April 20, 2009.
C     V. Sima, Aug. 2009 (SLICOT version of the routine ZHAUDF).
C
C     REVISIONS
C
C     V. Sima, Dec. 2010, Jan. 2011, Mar. 2011, Aug. 2011, Nov. 2011,
C     Aug. 2014, Jan. 2017, Apr. 2020.
C     M. Voigt, Jan. 2012.
C
C     KEYWORDS
C
C     Deflating subspace, embedded pencil, skew-Hamiltonian/Hamiltonian
C     pencil, structured Schur form.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D+0 )
      COMPLEX*16         CZERO, CONE, CIMAG
      PARAMETER          ( CZERO = ( 0.0D+0, 0.0D+0 ),
     $                      CONE = ( 1.0D+0, 0.0D+0 ),
     $                     CIMAG = ( 0.0D+0, 1.0D+0 ) )
C
C     .. Scalar Arguments ..
      CHARACTER          COMPQ, ORTH
      INTEGER            INFO, LDA, LDB, LDDE, LDFG, LDQ, LDWORK,
     $                   LZWORK, N, NEIG
C
C     .. Array Arguments ..
      LOGICAL            BWORK( * )
      INTEGER            IWORK( * )
      DOUBLE PRECISION   ALPHAI( * ), ALPHAR( * ), BETA( * ), DWORK( * )
      COMPLEX*16         A( LDA, * ), B( LDB, * ), DE( LDDE, * ),
     $                   FG( LDFG, * ), Q( LDQ, * ), ZWORK( * )
C
C     .. Local Scalars ..
      LOGICAL            LCMPQ, LQUERY, QR, QRP, SVD
      CHARACTER*14       CMPQ, JOB
      INTEGER            I, I1, IA, IB, IDE, IEV, IFG, IQ, IQ2, IQB, IS,
     $                   ITAU, IW, IW1, IWA, IWRK, J, J1, J2, JM1, JP2,
     $                   M, MINDB, MINDW, MINZW, N2, NB, NC, NN, OPTDW,
     $                   OPTZW
      DOUBLE PRECISION   EPS, NRMB, TOL
      COMPLEX*16         TMP
C
C     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           DLAMCH, LSAME
C
C     .. External Subroutines ..
      EXTERNAL           DCOPY, DLACPY, DSCAL, MB03JZ, MB04FD, XERBLA,
     $                   ZAXPY, ZGEMM, ZGEQP3, ZGEQRF, ZGESVD, ZHGEQZ,
     $                   ZLACPY, ZSCAL, ZUNGQR
C
C     .. Intrinsic Functions ..
      INTRINSIC          ABS, DBLE, DCMPLX, DIMAG, INT, MAX, MIN, MOD,
     $                   SQRT
C
C     .. Executable Statements ..
C
C     Decode the input arguments.
C     Using ORTH = 'Q' is not safe, but sometimes gives better results.
C
      M    = N/2
      NN   = N*N
      N2   = 2*N
      NEIG = 0
      LCMPQ = LSAME( COMPQ, 'C' )
      IF( LCMPQ ) THEN
         QR  = LSAME( ORTH, 'Q' )
         QRP = LSAME( ORTH, 'P' )
         SVD = LSAME( ORTH, 'S' )
      ELSE
         QR  = .FALSE.
         QRP = .FALSE.
         SVD = .FALSE.
      END IF
C
      IF( N.EQ.0 ) THEN
         MINDW = 1
         MINZW = 1
      ELSE IF( LCMPQ ) THEN
         MINDB =  8*NN + N2
         MINDW = 11*NN + N2
         MINZW =  8*N  + 4
      ELSE
         MINDB = 4*NN + N2
         MINDW = 4*NN + N2 + MAX( 3, N )
         MINZW = 1
      END IF
      LQUERY = LDWORK.EQ.-1 .OR. LZWORK.EQ.-1
C
C     Test the input arguments.
C
      INFO = 0
      IF( .NOT.( LSAME( COMPQ, 'N' ) .OR. LCMPQ ) ) THEN
         INFO = -1
      ELSE IF( LCMPQ ) THEN
         IF( .NOT.( QR .OR. QRP .OR. SVD ) )
     $      INFO = -2
      ELSE IF( N.LT.0 .OR. MOD( N, 2 ).NE.0 ) THEN
         INFO = -3
      ELSE IF(  LDA.LT.MAX( 1, N ) ) THEN
         INFO = -5
      ELSE IF( LDDE.LT.MAX( 1, N ) ) THEN
         INFO = -7
      ELSE IF(  LDB.LT.MAX( 1, N ) ) THEN
         INFO = -9
      ELSE IF( LDFG.LT.MAX( 1, N ) ) THEN
         INFO = -11
      ELSE IF( LDQ.LT.1 .OR. ( LCMPQ .AND. LDQ.LT.N2 ) ) THEN
         INFO = -14
      ELSE IF( .NOT. LQUERY ) THEN
         IF( LDWORK.LT.MINDW ) THEN
            DWORK( 1 ) = MINDW
            INFO = -20
         ELSE IF( LZWORK.LT.MINZW ) THEN
            ZWORK( 1 ) = MINZW
            INFO = -22
         END IF
      END IF
C
      IF( INFO.NE.0) THEN
         CALL XERBLA( 'MB03LZ', -INFO )
         RETURN
      ELSE IF( N.GT.0 ) THEN
C
C        Compute optimal workspace.
C
         IF( LCMPQ ) THEN
            JOB  = 'Triangularize'
            CMPQ = 'Initialize'
            CALL ZGEQRF( N, N, Q, LDQ, ZWORK, ZWORK, -1, INFO )
            I  = INT( ZWORK( 1 ) )
            NB = MAX( I/N, 2 )
         ELSE
            JOB  = 'Eigenvalues'
            CMPQ = 'No Computation'
         END IF
C
         IF( LQUERY ) THEN
            CALL MB04FD( JOB, CMPQ, N2, DWORK, N, DWORK, N, DWORK, N,
     $                   DWORK, N, DWORK, N2, ALPHAI, ALPHAR, BETA,
     $                   IWORK, DWORK, -1, INFO )
            OPTDW = MAX( MINDW, MINDB + INT( DWORK( 1 ) ) )
C
            IF( LCMPQ ) THEN
               IF( SVD ) THEN
                  CALL ZGESVD( 'O', 'N', N, N, Q, LDQ, DWORK, ZWORK, 1,
     $                         ZWORK, 1, ZWORK, -1, DWORK, INFO )
                  J = INT( ZWORK( 1 ) )
               ELSE
                  IF( QR ) THEN
                     J = M
                     CALL ZGEQRF( N, J, Q, LDQ, ZWORK, ZWORK, -1, INFO )
                  ELSE
                     J = N
                     CALL ZGEQP3( N, J, Q, LDQ, IWORK, ZWORK, ZWORK, -1,
     $                            DWORK, INFO )
                  END IF
                  CALL ZUNGQR( N, J, J, Q, LDQ, ZWORK, ZWORK( 2 ), -1,
     $                         INFO )
                  J = J + MAX( INT( ZWORK( 1 ) ), INT( ZWORK( 2 ) ) )
               END IF
               OPTZW = MAX( MINZW, I, J )
            ELSE
               OPTZW = MINZW
            END IF
            DWORK( 1 ) = OPTDW
            ZWORK( 1 ) = OPTZW
            RETURN
         ELSE
            OPTZW = MINZW
         END IF
      END IF
C
C     Quick return if possible.
C
      IF( N.EQ.0 ) THEN
         DWORK( 1 ) = ONE
         ZWORK( 1 ) = CONE
         RETURN
      END IF
C
C     Determine machine constants.
C
      EPS = DLAMCH( 'Precision' )
      TOL = SQRT( EPS )
C
C     Set up the embeddings of the matrices S and H.
C
C     Set the pointers for the inputs and outputs of MB04FD.
C     Real workspace:    need   4*N**2+2*N, if COMPQ = 'N';
C                               8*N**2+2*N, if COMPQ = 'C'.
C
      IQ = 1
      IF( LCMPQ ) THEN
         IA = IQ + N2*N2
      ELSE
         IA = 1
      END IF
C
      IDE  = IA  + NN
      IB   = IDE + NN + N
      IFG  = IB  + NN
      IWRK = IFG + NN + N
C
C     Build the embedding of A.
C
      IW = IA
      IS = IW + N*M
      DO 30 J = 1, M
         IW1 = IW
         DO 10 I = 1, M
            DWORK( IW ) = DBLE( A( I, J ) )
            IW = IW + 1
   10    CONTINUE
C
         DO 20 I = 1, M
            DWORK( IW ) =  DIMAG( A( I, J ) )
            DWORK( IS ) = -DWORK( IW )
            IW = IW + 1
            IS = IS + 1
   20    CONTINUE
         CALL DCOPY( M, DWORK( IW1 ), 1, DWORK( IS ), 1 )
         IS = IS + M
   30 CONTINUE
C
C     Build the embedding of D and E.
C
      IW = IDE
      DO 60 J = 1, M + 1
         DO 40 I = 1, M
            DWORK( IW ) = DBLE( DE( I, J ) )
            IW = IW + 1
   40    CONTINUE
C
         IW = IW + J - 1
         IS = IW
         DO 50 I = J, M
            DWORK( IW ) = DIMAG( DE( I, J ) )
            DWORK( IS ) = DWORK( IW )
            IW = IW + 1
            IS = IS + N
   50    CONTINUE
   60 CONTINUE
C
      IW1 = IW
      I1  = IW
      DO 80 J = 2, M + 1
         IS = I1
         I1 = I1 + 1
         DO 70 I = 1, J - 1
            DWORK( IW ) = -DIMAG( DE( I, J ) )
            DWORK( IS ) =  DWORK( IW )
            IW = IW + 1
            IS = IS + N
   70    CONTINUE
         IW = IW + N - J + 1
   80 CONTINUE
      CALL DLACPY( 'Full', M, M+1, DWORK( IDE ), N, DWORK( IW1-M ), N )
C
C     Build the embedding of B.
C
      IW = IB
      IS = IW + N*M
      DO 110 J = 1, M
         IW1 = IW
         DO 90 I = 1, M
            DWORK( IW ) = -DIMAG( B( I, J ) )
            IW = IW + 1
   90    CONTINUE
C
         DO 100 I = 1, M
            DWORK( IW ) =   DBLE( B( I, J ) )
            DWORK( IS ) = -DWORK( IW )
            IW = IW + 1
            IS = IS + 1
  100    CONTINUE
         CALL DCOPY( M, DWORK( IW1 ), 1, DWORK( IS ), 1 )
         IS = IS + M
  110 CONTINUE
C
C     Build the embedding of F and G.
C
      IW = IFG
      DO 140 J = 1, M + 1
         DO 120 I = 1, M
            DWORK( IW ) = -DIMAG( FG( I, J ) )
            IW = IW + 1
  120    CONTINUE
C
         IW = IW + J - 1
         IS = IW
         DO 130 I = J, M
            DWORK( IW ) =  DBLE( FG( I, J ) )
            DWORK( IS ) = DWORK( IW )
            IW = IW + 1
            IS = IS + N
  130    CONTINUE
  140 CONTINUE
C
      IW1 = IW
      I1  = IW
      DO 160 J = 2, M + 1
         IS = I1
         I1 = I1 + 1
         DO 150 I = 1, J - 1
            DWORK( IW ) = -DBLE( FG( I, J ) )
            DWORK( IS ) = DWORK( IW )
            IW = IW + 1
            IS = IS + N
  150    CONTINUE
         IW = IW + N - J + 1
  160 CONTINUE
      CALL DLACPY( 'Full', M, M+1, DWORK( IFG ), N, DWORK( IW1-M ), N )
C
C     STEP 1: Apply MB04FD to transform the extended pencil to real
C             skew-Hamiltonian/skew-Hamiltonian Schur form.
C
C             Real workspace:
C                  need   4*N*N + 2*N + MAX( 3, N ), if COMPQ = 'N';
C                         8*N*N + 2*N + 3*N*N,       if COMPQ = 'C'.
C                  prefer larger.
C
      CALL MB04FD( JOB, CMPQ, N2, DWORK( IA ), N, DWORK( IDE ), N,
     $             DWORK( IB ), N, DWORK( IFG ), N, DWORK( IQ ), N2,
     $             ALPHAI, ALPHAR, BETA, IWORK, DWORK( IWRK ),
     $             LDWORK-IWRK+1, INFO )
      IF( INFO.EQ.2 ) THEN
         IWA = 4
      ELSE IF( INFO.GT.0 ) THEN
         RETURN
      ELSE
         IWA = 0
      END IF
      OPTDW = MAX( MINDW, MINDB + INT( DWORK( IWRK ) ) )
C
C     Scale the eigenvalues.
C
      CALL DSCAL( N, -ONE, ALPHAI, 1 )
C
C     Return if only the eigenvalues are desired.
C
      IF( .NOT.LCMPQ ) THEN
         DWORK( 1 ) = OPTDW
         ZWORK( 1 ) = OPTZW
         INFO = IWA
         RETURN
      END IF
C
C     Convert the results to complex datatype. D and F start in the
C     first column of DE and FG, respectively.
C
      IW = IA
      DO 180 J = 1, N
         DO 170 I = 1, J
            A( I, J ) = DCMPLX( DWORK( IW ) )
            IW = IW + 1
  170    CONTINUE
         IF( J.GE.M .AND. J.LT.N )
     $      A( J+1, J ) = CZERO
         IW = IW + N - J
  180 CONTINUE
C
      IW = IDE + N
      DO 200 J = 1, N
         DO 190 I = 1, J - 1
            DE( I, J ) = DCMPLX( DWORK( IW ) )
            IW = IW + 1
  190    CONTINUE
         DE( J, J ) = CZERO
         IF( J.GE.M .AND. J.LT.N )
     $      DE( J+1, J ) = CZERO
         IW = IW + N - J + 1
  200 CONTINUE
C
      IW = IB
      DO 220 J = 1, N
         DO 210 I = 1, MIN( J + 1, N )
            B( I, J ) = DCMPLX( DWORK( IW ) )
            IW = IW + 1
  210    CONTINUE
         IW = IW + N - J - 1
  220 CONTINUE
C
      IW = IFG + N
      DO 240 J = 1, N
         DO 230 I = 1, J - 1
            FG( I, J ) = DCMPLX( DWORK( IW ) )
            IW = IW + 1
  230    CONTINUE
         FG( J, J ) = CZERO
         IF( J.GE.M .AND. J.LT.N )
     $      FG( J+1, J ) = CZERO
         IW = IW + N - J + 1
  240 CONTINUE
C
      IW = IQ
      DO 260 J = 1, N2
         DO 250 I = 1, N2
            Q( I, J ) = DCMPLX( DWORK( IW ) )
            IW = IW + 1
  250    CONTINUE
  260 CONTINUE
C
C     Triangularize the 2-by-2 diagonal blocks in B using the complex
C     version of the QZ algorithm.
C
C     Set up pointers on the outputs of ZHGEQZ.
C     A block algorithm is used for large N.
C
      IQ2  = 1
      IEV  = 5
      IQ   = 9
      IWRK = IQ + 4*( N - 1 )
C
      J  = 1
      J1 = 1
      J2 = MIN( N, J1 + NB - 1 )
C     WHILE( J.LT.N ) DO
  270 CONTINUE
      IF( J.LT.N ) THEN
         NRMB = ABS( B( J, J ) ) + ABS( B( J+1, J+1 ) )
         IF( ABS( B( J+1, J ) ).GT.NRMB*EPS ) THEN
C
C           Triangularization step.
C           Workspace:    need   8*N + 4.
C
            NC  = MAX( J2-J-1, 0 )
            JM1 = MAX( J-1, 1 )
            JP2 = MIN( J+2, N )
            TMP         =  A( J+1, J )
            A( J+1, J ) = CZERO
            CALL ZHGEQZ( 'Schur Form', 'Initialize', 'Initialize', 2, 1,
     $                   2, B( J, J ), LDB, A( J, J ), LDA,
     $                   ZWORK( IEV ), ZWORK( IEV+2 ), ZWORK( IQ ), 2,
     $                   ZWORK( IQ2 ), 2, ZWORK( IWRK ), LZWORK-IWRK+1,
     $                   DWORK, INFO )
            A( J+1, J ) = TMP
            IF( INFO.GT.0 ) THEN
               INFO = 2
               RETURN
            END IF
C
C           Update A.
C
            CALL ZGEMM(  'No Transpose', 'No Transpose', J-1, 2, 2,
     $                   CONE, A( 1, J ), LDA, ZWORK( IQ2 ), 2, CZERO,
     $                   ZWORK( IWRK ), JM1 )
            CALL ZLACPY( 'Full', J-1, 2, ZWORK( IWRK ), JM1, A( 1, J ),
     $                   LDA )
            CALL ZGEMM(  'Conjugate Transpose', 'No Transpose', 2, NC,
     $                   2, CONE, ZWORK( IQ ), 2, A( J, JP2 ), LDA,
     $                   CZERO, ZWORK( IWRK ), 2 )
            CALL ZLACPY( 'Full', 2, NC, ZWORK( IWRK ), 2, A( J, JP2 ),
     $                   LDA )
C
C           Update DE.
C
            TMP          =  DE( J+1, J )
            DE( J+1, J ) = -DE( J, J+1 )
            CALL ZGEMM(  'No Transpose', 'No Transpose', J+1, 2, 2,
     $                   CONE, DE( 1, J ), LDDE, ZWORK( IQ ), 2, CZERO,
     $                   ZWORK( IWRK ), J+1 )
            CALL ZLACPY( 'Full', J+1, 2, ZWORK( IWRK ), J+1, DE( 1, J ),
     $                   LDDE )
            CALL ZGEMM(  'Conjugate Transpose', 'No Transpose', 2,
     $                   J2-J+1, 2, CONE, ZWORK( IQ ), 2, DE( J, J ),
     $                   LDDE, CZERO, ZWORK( IWRK ), 2 )
            CALL ZLACPY( 'Full', 2, J2-J+1, ZWORK( IWRK ), 2,
     $                   DE( J, J ), LDDE )
            DE( J+1, J ) = TMP
C
C           Update B.
C
            CALL ZGEMM(  'No Transpose', 'No Transpose', J-1, 2, 2,
     $                   CONE, B( 1, J ), LDB, ZWORK( IQ2 ), 2, CZERO,
     $                   ZWORK( IWRK ), JM1 )
            CALL ZLACPY( 'Full', J-1, 2, ZWORK( IWRK ), JM1, B( 1, J ),
     $                   LDB )
            CALL ZGEMM(  'Conjugate Transpose', 'No Transpose', 2, NC,
     $                   2, CONE, ZWORK( IQ ), 2, B( J, JP2 ), LDB,
     $                   CZERO, ZWORK( IWRK ), 2 )
            CALL ZLACPY( 'Full', 2, NC, ZWORK( IWRK ), 2, B( J, JP2 ),
     $                   LDB )
C
C           Update FG.
C
            TMP          =  FG( J+1, J )
            FG( J+1, J ) = -FG( J, J+1 )
            CALL ZGEMM(  'No Transpose', 'No Transpose', J+1, 2, 2,
     $                   CONE, FG( 1, J ), LDFG, ZWORK( IQ ), 2, CZERO,
     $                   ZWORK( IWRK ), J+1 )
            CALL ZLACPY( 'Full', J+1, 2, ZWORK( IWRK ), J+1, FG( 1, J ),
     $                   LDFG )
            CALL ZGEMM(  'Conjugate Transpose', 'No Transpose', 2,
     $                   J2-J+1, 2, CONE, ZWORK( IQ ), 2, FG( J, J ),
     $                   LDFG, CZERO, ZWORK( IWRK ), 2 )
            CALL ZLACPY( 'Full', 2, J2-J+1, ZWORK( IWRK ), 2,
     $                   FG( J, J ), LDFG )
            FG( J+1, J ) = TMP
C
C           Update Q.
C
            CALL ZGEMM(  'No Transpose', 'No Transpose', N2, 2, 2, CONE,
     $                   Q( 1, J ), LDQ, ZWORK( IQ2 ), 2, CZERO,
     $                   ZWORK( IWRK ), N2 )
            CALL ZLACPY( 'Full', N2, 2, ZWORK( IWRK ), N2, Q( 1, J ),
     $                   LDQ )
            CALL ZGEMM(  'No Transpose', 'No Transpose', N2, 2, 2, CONE,
     $                   Q( 1, N+J ), LDQ, ZWORK( IQ ), 2, CZERO,
     $                   ZWORK( IWRK ), N2 )
            CALL ZLACPY( 'Full', N2, 2, ZWORK( IWRK ), N2, Q( 1, N+J ),
     $                   LDQ )
C
            BWORK( J ) = .TRUE.
            J  = J  + 2
            IQ = IQ + 4
         ELSE
            BWORK( J )  = .FALSE.
            B( J+1, J ) = CZERO
            J = J + 1
         END IF
C
         IF( J.GE.J2 ) THEN
            J1 = J2 + 1
            J2 = MIN( N, J1 + NB - 1 )
            NC = J2 - J1 + 1
C
C           Update the columns J1 to J2 of A, DE, B, and FG for previous
C           transformations.
C
            I   = 1
            IQB = 9
C           WHILE( I.LT.J ) DO
  280       CONTINUE
            IF( I.LT.J ) THEN
               IF( BWORK( I ) ) THEN
                  CALL ZGEMM(  'Conjugate Transpose', 'No Transpose', 2,
     $                         NC, 2, CONE, ZWORK( IQB ), 2, A( I, J1 ),
     $                         LDA, CZERO, ZWORK( IWRK ), 2 )
                  CALL ZLACPY( 'Full', 2, NC, ZWORK( IWRK ), 2,
     $                         A( I, J1 ), LDA )
C
                  CALL ZGEMM(  'Conjugate Transpose', 'No Transpose', 2,
     $                         NC, 2, CONE, ZWORK( IQB ), 2,
     $                         DE( I, J1 ), LDDE, CZERO, ZWORK( IWRK ),
     $                         2 )
                  CALL ZLACPY( 'Full', 2, NC, ZWORK( IWRK ), 2,
     $                         DE( I, J1 ), LDDE )
C
                  CALL ZGEMM(  'Conjugate Transpose', 'No Transpose', 2,
     $                         NC, 2, CONE, ZWORK( IQB ), 2, B( I, J1 ),
     $                         LDB, CZERO, ZWORK( IWRK ), 2 )
                  CALL ZLACPY( 'Full', 2, NC, ZWORK( IWRK ), 2,
     $                         B( I, J1 ), LDB )
C
                  CALL ZGEMM(  'Conjugate Transpose', 'No Transpose', 2,
     $                         NC, 2, CONE, ZWORK( IQB ), 2,
     $                         FG( I, J1 ), LDFG, CZERO, ZWORK( IWRK ),
     $                         2 )
                  CALL ZLACPY( 'Full', 2, NC, ZWORK( IWRK ), 2,
     $                         FG( I, J1 ), LDFG )
                  IQB = IQB + 4
C
                  I = I + 2
               ELSE
                  I = I + 1
               END IF
               GO TO 280
            END IF
C           END WHILE 280
         END IF
         GO TO 270
      END IF
C     END WHILE 270
C
C     Scale B and FG by -i.
C
      DO 290 I = 1, N
         CALL ZSCAL( I, -CIMAG, B( 1, I ), 1 )
  290 CONTINUE
C
      DO 300 I = 1, N
         CALL ZSCAL( I, -CIMAG, FG( 1, I ), 1 )
  300 CONTINUE
C
C     STEP 2: Apply MB03JZ to reorder the eigenvalues with strictly
C             negative real part to the top.
C
      CMPQ = 'Update'
      CALL MB03JZ( CMPQ, N2, A, LDA, DE, LDDE, B, LDB, FG, LDFG, Q, LDQ,
     $             NEIG, TOL, INFO )
C
      IF( QR )
     $   NEIG = NEIG/2
      ITAU = 1
      IWRK = NEIG + 1
C
C     STEP 3: Compute the right deflating subspace corresponding to
C             the eigenvalues with strictly negative real part.
C
      IF( NEIG.LE.M ) THEN
         DO 310 I = 1, NEIG
            CALL ZAXPY( M, CIMAG, Q( M+1, I ), 1, Q( 1, I ), 1 )
  310    CONTINUE
         CALL ZLACPY( 'Full', M, NEIG, Q( N+1, 1 ), LDQ, Q( M+1, 1 ),
     $                LDQ )
         DO 320 I = 1, NEIG
            CALL ZAXPY( M, CIMAG, Q( M+N+1, I ), 1, Q( M+1, I ), 1 )
  320    CONTINUE
      ELSE
         DO 330 I = 1, M
            CALL ZAXPY( M, CIMAG, Q( M+1, I ), 1, Q( 1, I ), 1 )
  330    CONTINUE
         CALL ZLACPY( 'Full', M, M, Q( N+1, 1 ), LDQ, Q( M+1, 1 ), LDQ )
         DO 340 I = 1, M
            CALL ZAXPY( M, CIMAG, Q( M+N+1, I ), 1, Q( M+1, I ), 1 )
  340    CONTINUE
C
         DO 350 I = 1, NEIG - M
            CALL ZAXPY( M, CIMAG, Q( M+1, M+I ), 1, Q( 1, M+I ), 1 )
  350    CONTINUE
         CALL ZLACPY( 'Full', M, NEIG-M, Q( N+1, M+1 ), LDQ,
     $                Q( M+1, M+1 ), LDQ )
         DO 360 I = 1, NEIG - M
            CALL ZAXPY( M, CIMAG, Q( M+N+1, M+I ), 1, Q( M+1, M+I ), 1 )
  360    CONTINUE
      END IF
C
C     Orthogonalize the basis given in Q(1:n,1:neig).
C
      IF( SVD ) THEN
C
C        Workspace:          need   3*N;
C                            prefer larger.
C        Real workspace:     need   6*N.
C
         CALL ZGESVD( 'Overwrite', 'No V', N, NEIG, Q, LDQ, DWORK,
     $                ZWORK, 1, ZWORK, 1, ZWORK, LZWORK,
     $                DWORK( IWRK ), INFO )
         IF( INFO.GT.0 ) THEN
            INFO = 3
            RETURN
         END IF
         OPTZW = MAX( OPTZW, INT( ZWORK( 1 ) ) )
         NEIG  = NEIG/2
C
      ELSE
         IF( QR ) THEN
C
C           Workspace:          need   N;
C                               prefer M+M*NB, where NB is the optimal
C                                              blocksize.
C
            CALL ZGEQRF( N, NEIG, Q, LDQ, ZWORK( ITAU ), ZWORK( IWRK ),
     $                   LZWORK-IWRK+1, INFO )
            OPTZW = MAX( OPTZW, INT( ZWORK( IWRK ) ) + IWRK - 1 )
         ELSE
C
C           Workspace:          need   2*N+1;
C                               prefer N+(N+1)*NB.
C           Real workspace:     need   2*N.
C
            DO 370 J = 1, NEIG
               IWORK( J ) = 0
  370       CONTINUE
            CALL ZGEQP3( N, NEIG, Q, LDQ, IWORK, ZWORK, ZWORK( IWRK ),
     $                   LZWORK-IWRK+1, DWORK, INFO )
            OPTZW = MAX( OPTZW, INT( ZWORK( IWRK ) ) + IWRK - 1 )
         END IF
C
C        Workspace:     need   2*N;
C                       prefer N+N*NB.
C
         CALL ZUNGQR( N, NEIG, NEIG, Q, LDQ, ZWORK( ITAU ),
     $                ZWORK( IWRK ), LZWORK-IWRK+1, INFO )
         OPTZW = MAX( OPTZW, INT( ZWORK( IWRK ) ) + IWRK - 1 )
         IF( QRP )
     $      NEIG = NEIG/2
      END IF
C
      DWORK( 1 ) = OPTDW
      ZWORK( 1 ) = OPTZW
      INFO = IWA
      RETURN
C *** Last line of MB03LZ ***
      END


subroutine rupope(ndime,ngaus,posgp,weigp)

!-----------------------------------------------------------------------
!
!     This routine sets up the integration constants of open rules for
!     PRYSMS
!
!             NDIME = 3
!
!          NGAUS  EXACT POL.
!          -----  ----------
!            1       p1
!            6       p2
!
!-----------------------------------------------------------------------

  use      typre
  implicit none

  integer(ip), intent(in)  :: ndime,ngaus
  real(rp),    intent(out) :: posgp(ndime,ngaus),weigp(ngaus)
  integer(ip)              :: istop

  istop=0
!
! Volume integral (triangles)
!
  if(ndime==3) then
     if(ngaus==1) then
        posgp(1,1)= 1.0_rp/3.0_rp
        posgp(2,1)= 1.0_rp/3.0_rp
        posgp(3,1)= 1.0_rp/2.0_rp
        weigp(  1)= 1.0_rp/2.0_rp
     else if(ngaus==6) then
        posgp(1,1)= 2.0_rp/3.0_rp
        posgp(2,1)= 1.0_rp/6.0_rp
        posgp(3,1)= 0.21132486540518711774542560974902_rp
        posgp(1,2)= 1.0_rp/6.0_rp
        posgp(2,2)= 2.0_rp/3.0_rp
        posgp(3,2)= 0.21132486540518711774542560974902_rp
        posgp(1,3)= 1.0_rp/6.0_rp
        posgp(2,3)= 1.0_rp/6.0_rp
        posgp(3,3)= 0.21132486540518711774542560974902_rp
        posgp(1,4)= 2.0_rp/3.0_rp
        posgp(2,4)= 1.0_rp/6.0_rp
        posgp(3,4)= 0.78867513459481288225457439025098_rp
        posgp(1,5)= 1.0_rp/6.0_rp
        posgp(2,5)= 2.0_rp/3.0_rp
        posgp(3,5)= 0.78867513459481288225457439025098_rp
        posgp(1,6)= 1.0_rp/6.0_rp
        posgp(2,6)= 1.0_rp/6.0_rp
        posgp(3,6)= 0.78867513459481288225457439025098_rp
        weigp(  1)= 1.0_rp/12.0_rp
        weigp(  2)= 1.0_rp/12.0_rp
        weigp(  3)= 1.0_rp/12.0_rp
        weigp(  4)= 1.0_rp/12.0_rp
        weigp(  5)= 1.0_rp/12.0_rp
        weigp(  6)= 1.0_rp/12.0_rp
     else
        istop=1
     end if
  else
!     istop=1   ! WARNING: Lo he puesto pq viene aqui por boundary shape functions
  end if
!
! Errors
!
  if(istop==1) call runend('RUTOPE: NOT AVAILABLE QUADRATURE')

end subroutine rupope


      subroutine qpot(am,x,ntraj,ndim)
      implicit real*8(a-h,o-z)
      integer*4  :: Ntraj,Ndim
      real*8     :: w(Ntraj),x(Ndim,Ntraj),am(Ndim)
      real*8     :: qf(Ndim,Ntraj),qp(Ntraj)
      real*8 :: f(Ndim+1,Ntraj),r(Ndim,Ntraj)
	real*8 :: s(Ndim+1,Ndim+1),c(Ndim+1,Ndim)
!----- define c matrix ------------

	c=0d0
	do j=1,Ndim
	  c(j,j)=-0.5d0
	enddo

! basis vector f = (1,x(1),x(2),...,x(Ndim)) for each trajectory
	f=0d0
      do i=1,Ntraj
	  do j=1,Ndim
            f(j,i)=x(j,i)
	  enddo
          f(Ndim+1,i)=1d0
      enddo

! Matrix S=f X f [Ndim+1,Ndim+1]
        s = 0d0
        do k1=1,Ndim+1
          do k2=1,Ndim+1
            do i=1,Ntraj
              s(k1,k2)=w(i)*f(k1,i)*f(k2,i)+s(k1,k2)
            enddo
          enddo
        enddo

!-------- calculate matrix c(t) --------------------
        call DPOSV('U',Ndim+1,Ndim,s,Ndim+1,c,Ndim+1,INFO)
        if(INFO/=0) then
        print *, "info=",info
        print *, "matrix fails"
        stop
        end if

!------------- the momentum operator r=cf-------------
	r=0d0
	qp=0d0
!	qf=0d0

      do i=1,Ntraj
        do j=1,Ndim
          r(j,i) = 0d0
	    do n=1,Ndim+1
              r(j,i)=c(n,j)*f(n,i)+r(j,i)
        !r(2,i)=c(1,2)*x(1,i)+c(2,2)*x(2,i)+c(3,2)
	    enddo
! calculate quantum potential
            qp(i)=-r(j,i)**2/(2d0*am(j))
     &            -c(j,j)/(2d0*am(j))+qp(i)
	  enddo
	enddo

! quantum force
	do i=1,Ntraj
        do j=1,Ndim
          qf(j,i) = 0d0
	    do n=1,Ndim
        !qfx(i)=rx(i)*c(1,1)/m1+ry(i)*c(1,2)/m2
        !qfy(i)=rx(i)*c(2,1)/m1+ry(i)*c(2,2)/m2
	      qf(j,i)=r(n,i)*c(j,n)/am(n)+qf(j,i)
	!qf(2,i)=r(2,i)*c(2,1)/m(1)+r(2,i)*c(2,2)/m(2)
	    enddo
        enddo
	enddo

      return
      end subroutine


      subroutine fvtMCdiag(CpLam,CpU, Cp)
C-----------------------------------------------------------------------
C -- diagonalize covariance matrix Cp and return
C -- matrix CpU = {eigen vectors} and CpLam = sqrt(eigen values}
C --
      implicit none
      double precision CpLam(5),CpU(5,5), Cp(5,5)
      real AR(5,5), WR(5), ZR(5,5), WORK(5)
      integer i0, i1, ierr

      do i0 = 1, 5
      do i1 = 1, 5
        AR(i0,i1) = REAL(Cp(i0,i1))
      end do
      end do

      call EISRS1(5, 5, AR, WR, ZR, IERR, WORK)

      do i0 = 1, 5
      if (WR(i0) .GE. 0.) then
        CpLam(i0) = DBLE(sqrt(WR(i0)))
      else
        CpLam(i0) = 0d0
        call fvError('sqrt of negative number in fvtMCdiag')
      end if
      do i1 = 1, 5
        CpU(i0,i1) = DBLE(ZR(i0,i1))
      end do
      end do

      return
      end


      SUBROUTINE slECEQ (DL, DB, DATE, DR, DD)
*+
*     - - - - - -
*      E C E Q
*     - - - - - -
*
*  Transformation from ecliptic coordinates to
*  J2000.0 equatorial coordinates (double precision)
*
*  Given:
*     DL,DB       dp      ecliptic longitude and latitude
*                           (mean of date, IAU 1980 theory, radians)
*     DATE        dp      TDB (loosely ET) as Modified Julian Date
*                                              (JD-2400000.5)
*  Returned:
*     DR,DD       dp      J2000.0 mean RA,Dec (radians)
*
*  Called:
*     slDS2C, slECMA, slDIMV, slPREC, slEPJ, slDC2S,
*     slDA2P, slDA1P
*
*  P.T.Wallace   Starlink   March 1986
*
*  Copyright (C) 1995 Rutherford Appleton Laboratory
*
*  License:
*    This program is free software; you can redistribute it and/or modify
*    it under the terms of the GNU General Public License as published by
*    the Free Software Foundation; either version 2 of the License, or
*    (at your option) any later version.
*
*    This program is distributed in the hope that it will be useful,
*    but WITHOUT ANY WARRANTY; without even the implied warranty of
*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
*    GNU General Public License for more details.
*
*    You should have received a copy of the GNU General Public License
*    along with this program (see SLA_CONDITIONS); if not, write to the
*    Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
*    Boston, MA  02110-1301  USA
*
*  Copyright (C) 1995 Association of Universities for Research in Astronomy Inc.
*-

      IMPLICIT NONE

      DOUBLE PRECISION DL,DB,DATE,DR,DD

      DOUBLE PRECISION slEPJ,slDA2P,slDA1P

      DOUBLE PRECISION RMAT(3,3),V1(3),V2(3)

*  Spherical to Cartesian
      CALL slDS2C(DL,DB,V1)

*  Ecliptic to equatorial
      CALL slECMA(DATE,RMAT)
      CALL slDIMV(RMAT,V1,V2)

*  Mean of date to J2000
      CALL slPREC(2000D0,slEPJ(DATE),RMAT)
      CALL slDIMV(RMAT,V2,V1)

*  Cartesian to spherical
      CALL slDC2S(V1,DR,DD)

*  Express in conventional ranges
      DR=slDA2P(DR)
      DD=slDA1P(DD)

      END


module riemann_mod

use constants_mod

contains

pure function xriemann(uL,uR) result(sf)

    use equations_mod, only: flux => xflux
    use equations_mod, only: lambdaMax => xlambdaMax

    real(dp), intent(in) :: uL(N_VARS), uR(N_VARS)
    real(dp)             :: sf(N_VARS)

    real(dp) :: FL(N_VARS), FR(N_VARS), lmax

    FL = flux(uL)
    FR = flux(uR)

    lMax = max(lambdaMax(uL),lambdaMax(uR))

    sf = 0.5_dp*(FL + FR + lMax*(uL - uR))

end function

! pure function xriemann(uL, uR) result(sf)
!
!     use two_point_flux_mod, only: flux => xflux
!     use equations_mod, only: lambdaMax => xlambdaMax
!
!     real(dp), intent(in) :: uL(N_VARS), uR(N_VARS)
!     real(dp)             :: sf(N_VARS)
!     real(dp) :: lmax
!
!     lMax = max(lambdaMax(uL),lambdaMax(uR))
!
!     sf = (flux(uL,uR) + 0.5_dp*lMax*(uL - uR))
!
! end function

pure function yriemann(uL,uR) result(sf)

    use equations_const_mod

    real(dp), intent(in) :: uL(N_VARS), uR(N_VARS)
    real(dp)             :: sf(N_VARS)

    real(dp) :: ruL(N_VARS), ruR(N_VARS), rf(N_VARS) !! rotated

    ruL(DENS_VAR) = uL(DENS_VAR)
    ruL(MOMX_VAR) = uL(MOMY_VAR)
    ruL(MOMY_VAR) = uL(MOMZ_VAR)
    ruL(MOMZ_VAR) = uL(MOMX_VAR)
    ruL(ENER_VAR) = uL(ENER_VAR)

    ruR(DENS_VAR) = uR(DENS_VAR)
    ruR(MOMX_VAR) = uR(MOMY_VAR)
    ruR(MOMY_VAR) = uR(MOMZ_VAR)
    ruR(MOMZ_VAR) = uR(MOMX_VAR)
    ruR(ENER_VAR) = uR(ENER_VAR)

    rf = xriemann(ruL,ruR)

    sf(DENS_VAR) = rf(DENS_VAR)
    sf(MOMX_VAR) = rf(MOMZ_VAR)
    sf(MOMY_VAR) = rf(MOMX_VAR)
    sf(MOMZ_VAR) = rf(MOMY_VAR)
    sf(ENER_VAR) = rf(ENER_VAR)

end function

pure function zriemann(uL,uR) result(sf)

    use equations_const_mod

    real(dp), intent(in) :: uL(N_VARS), uR(N_VARS)
    real(dp)             :: sf(N_VARS)

    real(dp) :: ruL(N_VARS), ruR(N_VARS), rf(N_VARS) !! rotated

    ruL(DENS_VAR) = uL(DENS_VAR)
    ruL(MOMX_VAR) = uL(MOMZ_VAR)
    ruL(MOMY_VAR) = uL(MOMX_VAR)
    ruL(MOMZ_VAR) = uL(MOMY_VAR)
    ruL(ENER_VAR) = uL(ENER_VAR)

    ruR(DENS_VAR) = uR(DENS_VAR)
    ruR(MOMX_VAR) = uR(MOMZ_VAR)
    ruR(MOMY_VAR) = uR(MOMX_VAR)
    ruR(MOMZ_VAR) = uR(MOMY_VAR)
    ruR(ENER_VAR) = uR(ENER_VAR)

    rf = xriemann(ruL,ruR)

    sf(DENS_VAR) = rf(DENS_VAR)
    sf(MOMX_VAR) = rf(MOMY_VAR)
    sf(MOMY_VAR) = rf(MOMZ_VAR)
    sf(MOMZ_VAR) = rf(MOMX_VAR)
    sf(ENER_VAR) = rf(ENER_VAR)

end function

end module


module modfnn
  use iso_fortran_env
  implicit none
  type matptr
    real(8), dimension(:, :), pointer :: p
  end type
  type network
    type(matptr), allocatable :: W(:)     ! 重み
    type(matptr), allocatable :: b(:)     ! バイアス
    integer, allocatable :: layerSize(:)  ! 各レイヤのサイズ
  end type
  interface disp
    module procedure disp_m
    module procedure disp_iv
    module procedure disp_r
    module procedure disp_u8
    module procedure disp_u32
  end interface
contains
  function relu(x) result(r)
    real(8) :: x, r
    r = max(x, 0d0)
  end function
  subroutine disp_m(mat)
    real(8) mat(:, :)
    integer i
    do i = 1, size(mat, 1)
      write(*, "(100e12.4)") mat(i, 1:)
    end do
  end subroutine
  subroutine disp_iv(v)
    integer v(:)
    write(*, *) v
  end subroutine
  subroutine disp_r(r)
    real(8) r
    write(*, *) r
  end subroutine
  subroutine disp_u8(r)
    integer (int8) r
    write(*, *) r
  end subroutine
  subroutine disp_u32(r)
    integer (int32) r
    write(*, *) r
  end subroutine
  function random_integer(vmin, vmax) result(r)
    integer, intent(in) :: vmin, vmax
    integer :: r
    real(8) tmp
    call random_number(tmp)
    r = floor(tmp * (vmax - vmin + 1)) + vmin
  end function
  function random_integer_array(vmin, vmax, len) result(r)
    integer, intent(in) :: vmin, vmax
    integer :: len, r(len)
    integer :: i
    do i = 1, len
      r(i) = random_integer(vmin, vmax)
    end do
  end function
  subroutine allocRandomMatrix(m, ys, xs)
    real(8), intent(inout), allocatable :: m(:,:)
    integer, intent(in) :: ys, xs
    integer :: c, seedsize
    integer, allocatable :: seed(:)
    if (allocated(m)) then
      deallocate(m)
    end if
    allocate(m(ys,xs))
    call system_clock(count=c)
    call random_seed(size=seedsize)
    allocate(seed(seedsize))
    seed = c
    call random_seed(put=seed)
    call random_number(m)
  end subroutine
  subroutine setRandomMatrixAllocated(p, ys, xs)
    real(8), intent(out), pointer :: p(:, :)
    real(8), allocatable, target :: m(:,:)
    integer, intent(in) :: ys, xs
    call allocRandomMatrix(m, ys, xs)
    p => m
  end subroutine
  subroutine tic(t1)
    integer, intent(inout) :: t1
    call system_clock(t1)
  end subroutine tic
  subroutine toc(t1)
    integer, intent(inout) :: t1
    integer :: t2, t_rate, t_max, diff
    call system_clock(t2,t_rate,t_max)
    if (t2 < t1) then
    diff = (t_max - t1) + t2 + 1
    else
    diff = t2 - t1
    end if
    write(*,*) "Time = ", diff/dble(t_rate)
    t1 = diff
  end subroutine toc
  function sigmoid(m) result(r)
    real(8), intent(in) :: m
    real(8) :: r
    r = 1d0 / (1d0 + exp(-m))
  end function
  function sigmoid_m(m) result(r)
    ! 新たにallocして返す。
    real(8), intent(in) :: m(:, :)
    !
    integer :: y, x
    integer :: xs, ys
    real(8), allocatable :: r(:, :)
    !
    xs = size(m, 2)
    ys = size(m, 1)
    allocate(r(ys, xs))
    do y = 1, ys
      do x = 1, xs
        r(y, x) = sigmoid(m(y, x))
      end do
    end do
  end function
  function sigmoid_v(v) result(r)
    ! 新たにallocして返す。
    real(8), intent(in) :: v(:)
    !
    integer :: i
    integer :: s
    real(8), allocatable :: r(:)
    !
    s = size(v)
    allocate(r(s))
    do i = 1, s
        r(i) = sigmoid(v(i))
    end do
  end function
  function softmax_m(m) result(r)
    ! 新たにallocして返す。
    real(8), intent(in) :: m(:, :)
    !
    integer :: y, x
    integer :: xs, ys
    real(8), allocatable :: r(:, :)
    real(8) :: vs
    !
    xs = size(m, 2)
    ys = size(m, 1)
    allocate(r(ys, xs))
    r = m
    ! オーバーフロー対策
    vs = maxval(r)
    do y = 1, ys
      do x = 1, xs
        r(y, x) = r(y, x) - vs
      end do
    end do
    ! 本来の計算
    do y = 1, ys
      do x = 1, xs
        r(y, x) = exp(r(y, x))
      end do
    end do
    vs = sum(r)
    do y = 1, ys
      do x = 1, xs
        r(y, x) = r(y, x) / vs
      end do
    end do
  end function
  function mean_squared_error(v, t) result(rv)
    real(8), intent(in) :: v(:)
    real(8), intent(in) :: t(:)
    !
    integer :: i, cnt
    real(8), allocatable :: r(:)
    real(8) :: rv
    !
    cnt = size(v, 1)
    allocate(r(cnt))
    r = v - t
    r = r * r
    rv = sum(r) * 0.5d0
    deallocate(r)
  end function
  function cross_entropy_error(m, t) result(rv)
    real(8), intent(in) :: m(:, :)
    real(8), intent(in) :: t(:, :)
    !
    real(8) :: rv, delta = 1d-7
    !
    rv = -sum(t * log(m + delta)) / size(m, 1)
  end function
  subroutine num_grad_of_network(net, f, px, m, t, grad)
    ! net: network data
    ! f: loss function
    ! px: input matrix
    ! m: network matrix(Weight or bias)
    ! t: train matrix
    ! grad: grad matrix (same shape of m, return value)
    type(network), intent(in) :: net
    interface
      real(8) function f(net, x, t) result(rv)
        import network
        type(network), intent(in) :: net
        real(8), intent(in) :: x(:, :)
        real(8), intent(in) :: t(:, :)
      end function
    end interface
    real(8) :: h = 1d-4
    real(8), allocatable, intent(out) :: grad(:, :)
    real(8), intent(inout) :: px(:, :)
    real(8), intent(inout) :: m(:, :)
    real(8), intent(in):: t(:, :)
    real(8) :: org_val, fxh1, fxh2
    integer :: size_x, size_y, x, y
    allocate(grad(size(m, 1), size(m, 2)))

    size_y = size(m, 1)
    size_x = size(m, 2)
    do y = 1, size_y
      do x = 1, size_x
        org_val = m(y, x)
        ! calc f(x + h)
        m(y, x) = org_val + h
        fxh1 = f(net, px, t)
        ! calc f(x - h)
        m(y, x) = org_val - h
        fxh2 = f(net, px, t)
        ! calc grad
        grad(y, x) = (fxh1 - fxh2) / (2 * h)
        m(y, x) = org_val
      end do
    end do

  end subroutine
  subroutine initWithTwoLayer(net, isize, hsize, osize)
    type(network), allocatable, intent(out) :: net
    integer, intent(in) :: isize, hsize, osize
    allocate(net)
    allocate(net%W(2))
    allocate(net%b(2))
    allocate(net%layerSize(3))

    net%layerSize(1) = isize
    net%layerSize(2) = hsize
    net%layerSize(3) = osize

    call setRandomMatrixAllocated(net%W(1)%p, isize, hsize)
    call setRandomMatrixAllocated(net%b(1)%p, 1, hsize)
    call setRandomMatrixAllocated(net%W(2)%p, hsize, osize)
    call setRandomMatrixAllocated(net%b(2)%p, 1, osize)
  end subroutine
  function predictWithTwoLayer(net, x) result(y)
    type(network), intent(in) :: net
    real(8) :: x(:, :)
    real(8) :: a1(size(x, 1), net%layerSize(2))
    real(8) :: a2(size(x, 1), net%layerSize(3))
    real(8) :: y(size(x, 1), net%layerSize(3))
    a1 = matmul(x, net%W(1)%p) + net%b(1)%p
    a1 = sigmoid_m(a1)
    a2 = matmul(a1, net%W(2)%p) + net%b(2)%p
    y = softmax_m(a2)
  end function
  function lossWithTwoLayer(net, x, t) result(v)
    ! t is train data
    type(network), intent(in) :: net
    real(8), intent(in) :: x(:, :)
    real(8), intent(in) :: t(:, :)
    real(8) :: v
    real(8) :: y(1, net%layerSize(3))
    y = predictWithTwoLayer(net, x)
    v = cross_entropy_error(y, t)
  end function
  subroutine getBatchFromIndexList(base, batch, indexList)
    type(matptr), intent(in) :: base(:)
    real(8), allocatable, intent(out):: batch(:, :)
    integer, intent(in) :: indexList(:)
    integer :: i, bsize
    bsize = size(indexList)
    allocate(batch(bsize, size(base(1)%p, 2)))
    do i = 1, bsize
      batch(i, :) = base(indexList(i))%p(1, :)
    end do
  end subroutine
  function accuracyForBatch(net, binput, btrain) result(r)
    type(network), intent(in) :: net
    real(8), intent(in) :: binput(:, :)
    real(8), allocatable :: predicted(:, :)
    real(8), intent(in) :: btrain(:, :)
    integer :: i
    real(8) :: r
    allocate(predicted(size(btrain, 1), size(btrain, 2)))
    r = 0
    predicted = predictWithTwoLayer(net, binput)
    do i = 1, size(binput, 1)
      if(maxloc(predicted(i, :), 1) .eq. maxloc(btrain(i, :), 1)) then
        r = r + 1
      end if
    end do
    r = r / size(binput, 1)
  end function
  function read_uint8(fp) result(v)
    integer (int8) :: v8
    integer v;
    integer, intent(in) :: fp;
    read(fp) v8
    v = v8
    if(v < 0) then
      v = 256 + v
    end if
  end function
  subroutine read_MNIST(n, imgs, labels)
    ! To use this function,
    ! get data from http://yann.lecun.com/exdb/mnist/
    ! and place files:
    !   'train-images-idx3-ubyte'
    !   'train-labels-idx1-ubyte'
    ! into:
    !   './data/'
    integer, intent(in) :: n
    integer :: fp_img, fp_label
    integer :: x, y, i
    type(matptr), allocatable :: imgs(:)
    type(matptr), allocatable :: labels(:)
    allocate(imgs(n))
    allocate(labels(n))
    fp_img = 10
    fp_label = 11
    open(fp_img, file="data/train-images-idx3-ubyte", &
      form="unformatted", access="stream")
    open(fp_label, file="data/train-labels-idx1-ubyte", &
      form="unformatted", access="stream")
    ! Skip headers
    do x = 1, 16
      i = read_uint8(fp_img)
      !call disp(i)
    end do
    do x = 1, 8
      i = read_uint8(fp_label)
      !call disp(i)
    end do
    ! Read
    do i = 1, n
      allocate(imgs(i)%p(1, 28 * 28))
      do x = 1, 28*28
          imgs(i)%p(1, x) = read_uint8(fp_img) / 255d0
      end do
      allocate(labels(i)%p(1, 10))
      labels(i)%p = 0
      labels(i)%p(1, read_uint8(fp_label) + 1) = 1
      !call disp(labels(i)%p)
      !call disp_MNISTimg(imgs(i)%p)
    end do
    print '("read ",I8," datas from MNIST")', n
    close(fp_label)
    close(fp_img)
  end subroutine
  subroutine disp_MNISTimg(m0)
    real(8) :: m0(:, :)
    real(8) :: m(28, 28)
    integer x, y
    m = reshape(m0, (/28, 28/))
    do x = 1, size(m, 2)
      do y = 1, size(m, 1)
        if(m(y, x) .eq. 0) then
          write(*, fmt='(A2)', advance='no') " "
        else if(m(y, x) < 0.25d0) then
          write(*, fmt='(A2)', advance='no') "."
        else if(m(y, x) < 0.5d0) then
          write(*, fmt='(A2)', advance='no') ","
        else if(m(y, x) < 0.75d0) then
          write(*, fmt='(A2)', advance='no') "x"
        else
          write(*, fmt='(A2)', advance='no') "#"
        end if
      end do
      write(*, fmt='()')
    end do
      write(*, fmt='()')
  end subroutine
end module


c     program DRSBI0K0
c>> 1996-05-28 DRSBI0K0 Krogh Moved formats up.
c>> 1994-10-19 DRSBI0K0 Krogh  Changes to use M77CON
c>> 1992-03-18 DRSBI0K0 CLL Added "c" to "program" line above.
c>> 1990-11-21 WVS (edited by CLL)
c     Demonstration driver for single precision hyperbolic Bessel
c     function subprograms.
c
c     Compute the Wronskian relation
c
c     z = x * (I1(x)*K0(x) + I0(x)*K1(x)) - 1.0
c
c     z should be approximately zero.
c
c     ------------------------------------------------------------------
c--S replaces "?": DR?BI0K0, ?BI0K0, ?BI1K1
c     ------------------------------------------------------------------
      real             X, BI0, BK0, BI1, BK1, Z
      integer IX, INFO
c
100   format (3x,a1,7x,4(a5,8x),a1/3x,'-',7x,4('-----',8x),'-')
150   format (1x,f4.1,1x,2(f12.8,1x),4x,'INFINITY',5x,'INFINITY')
200   format (1x,f4.1,1x,4(f12.8,1x),1x,g9.2)
c
      print 100, 'X', 'I0(X)','I1(X)','K0(X)','K1(X)','Z'
c
      x = 0.0e0
      call sbi0k0 (x, bi0, bk0, 1, info)
      call sbi1k1 (x, bi1, bk1, 1, info)
      print 150, x, bi0, bi1
      do 300 ix = 5, 50, 5
         x = ix / 10.0e0
         call sbi0k0 (x, bi0, bk0, -3, info)
         call sbi1k1 (x, bi1, bk1, -3, info)
         z = x * (bi1*bk0 + bi0*bk1) - 1.0e0
         print 200, x, bi0, bi1, bk0, bk1, z
300   continue
      stop
      end


!   _______________________________________________________________________
!
!   DAKOTA: Design Analysis Kit for Optimization and Terascale Applications
!   Copyright 2014 Sandia Corporation.
!   This software is distributed under the GNU Lesser General Public License.
!   For more information, see the README file in the top Dakota directory.
!   _______________________________________________________________________
!
! Author: Shannon L. Brown <slbrow@sandia.gov>
!
! This is the declaration of the bvls_module created for use by the
! bvls_wrapper subroutine added at the bottom of this file.  The BVLS
! subroutine has been made part of this module using the CONTAINS
! keyword.  It is _NOT_ part of the lawson_hanson2.F file distributed by
! NETLIB; it is the first of two additions made to the original (along
! with the second addition at the bottom of this file).  See the second
! addition for more details.
!
      MODULE bvls_module
      CONTAINS
!=======================================================================
!  -----------------------------------------------------------------
!  -----------------------------------------------------------------
!  From http://www.netlib.org/lawson-hanson/all
!
!  Modified by MSE and SLB for DAKOTA:
!  > Free format replaced with fixed format for consistency in
!    compiler options (pgf90 requires -Mfree option for free format)
!
!  -----------------------------------------------------------------
!  -----------------------------------------------------------------
      SUBROUTINE BVLS (A, B, BND, X, RNORM, NSETP, W, INDEX, IERR)

!   Given an M by N matrix, A, and an M-vector, B,  compute an
!   N-vector, X, that solves the least-squares problem A *X = B
!   subject to X(J) satisfying  BND(1,J)  <=  X(J)  <=  BND(2,J)
!
!   The values BND(1,J) = -huge(ONE) and BND(2,J) = huge(ONE) are
!   suggested choices to designate that there is no constraint in that
!   direction.  The parameter ONE is 1.0 in the working precision.
!
!   This algorithm is a generalization of  NNLS, that solves
!   the least-squares problem,  A * X = B,  subject to all X(J)  >=  0.
!   The subroutine NNLS appeared in 'SOLVING LEAST SQUARES PROBLEMS,'
!   by Lawson and Hanson, Prentice-Hall, 1974.  Work on BVLS was started
!   by C. L. Lawson and R. J. Hanson at Jet Propulsion Laboratory,
!   1973 June 12.  Many modifications were subsequently made.
!   This Fortran 90 code was completed in April, 1995 by R. J. Hanson.
!   Assumed shape arrays, automatic arrays, array operations, internal
!   subroutines and F90 elemental functions are used.  Comments are
!   prefixed with !  More than 72 characters appear on some lines.
!   The BVLS package is an additional item for the reprinting of the book
!   by SIAM Publications and the distribution of the code package
!   using netlib and Internet or network facilities.

!INTERFACE
!   SUBROUTINE BVLS (A, B, BND, X, RNORM, NSETP, W, INDEX, IERR)
!    REAL(KIND(1E0)) A(:,:), B(:), BND(:,:), X(:), RNORM, W(:)
!    INTEGER NSETP, INDEX(:), IERR
!   END SUBROUTINE
!END INTERFACE

!   A(:,:)     [INTENT(InOut)]
!   	On entry A() contains the M by N matrix, A.
!   	On return A() contains the product matrix, Q*A, where
!   	Q is an M by M orthogonal matrix generated by this
!   	subroutine.  The dimensions are M=size(A,1) and N=size(A,2).
!
!   B(:)     [INTENT(InOut)]
!   	On entry B() contains the M-vector, B.
!   	On return, B() contains Q*B.  The same Q multiplies A.
!
!   BND(:,:)  [INTENT(In)]
!   	BND(1,J) is the lower bound for X(J).
!   	BND(2,J) is the upper bound for X(J).
!   	Require:  BND(1,J)  <=  BND(2,J).
!
!   X(:)    [INTENT(Out)]
!   	On entry X() need not be initialized.  On return,
!   	X() will contain the solution N-vector.
!
!   RNORM    [INTENT(Out)]
!   	The Euclidean norm of the residual vector, b - A*X.
!
!   NSETP    [INTENT(Out)]
!   	Indicates the number of components of the solution
!   	vector, X(), that are not at their constraint values.
!
!   W(:)     [INTENT(Out)]
!   	An N-array.  On return, W() will contain the dual solution
!   	vector.   Using Set definitions below:
!   	W(J) = 0 for all j in Set P,
!   	W(J)  <=  0 for all j in Set Z, such that X(J) is at its
!   	lower bound, and
!   	W(J)  >=  0 for all j in Set Z, such that X(J) is at its
!   	upper bound.
!   	If BND(1,J) = BND(2,J), so the variable X(J) is fixed,
!   	then W(J) will have an arbitrary value.
!
!   INDEX(:)    [INTENT(Out)]
!   	An INTEGER working array of size N.  On exit the contents
!   	of this array define the sets P, Z, and F as follows:
!
!   INDEX(1)   through INDEX(NSETP) =  Set P.
!   INDEX(IZ1) through INDEX(IZ2)      = Set Z.
!   INDEX(IZ2+1) through INDEX(N)     = Set F.
!   IZ1 = NSETP + 1 = NPP1
!   	Any of these sets may be empty.  Set F is those components
!   	that are constrained to a unique value by the given
!   	constraints.   Sets P and Z are those that are allowed a non-
!   	zero range of values.  Of these, set Z are those whose final
!   	value is a constraint value, while set P are those whose
!   	final value is not a constraint.  The value of IZ2 is not returned.
!...	It is computable as the number of bounds constraining a component
!...	of X uniquely.
!
!   IERR    [INTENT(Out)]
!   Indicates status on return.
!  	= 0   Solution completed.
!   	= 1   M  <=  0 or N  <=  0
!   	= 2   B(:), X(:), BND(:,:), W(:), or INDEX(:) size or shape violation.
!   	= 3   Input bounds are inconsistent.
!   	= 4   Exceed maximum number of iterations.
!
!   Selected internal variables:
!   EPS [real(kind(one))]
!   	Determines the relative linear dependence of a column vector
!   	for a variable moved from its initial value.  This is used in
!   	one place with the default value EPS=EPSILON(ONE).  Other
!   	values, larger or smaller may be needed for some problems.
!   	Library software will likely make this an optional argument.
!
!   ITMAX  [integer]
!   	Set to 3*N.  Maximum number of iterations permitted.
!   	This is usually larger than required.  Library software will
!   	likely make this an optional argument.
!   ITER   [integer]
!   	Iteration counter.

      implicit none
      logical FIND, HITBND, FREE1, FREE2, FREE
      integer IERR, M, N
      integer I, IBOUND, II, IP, ITER, ITMAX, IZ, IZ1, IZ2
      integer J, JJ, JZ, L, LBOUND, NPP1, NSETP

      integer INDEX(:)
!
!   Z()     [Scratch]  An M-array (automatic) of working space.
!   S()     [Scratch]  An N-array (automatic) of working space.
!
      real(kind(1D0)), parameter :: ZERO = 0D0, ONE=1D0, TWO = 2D0
      real(kind(one)) :: A(:,:), B(:), S(SIZE(A,2)), X(:), W(:),
     &                   Z(SIZE(A,1)), BND(:,:)
      real(kind(one)) ALPHA, ASAVE, CC, EPS, RANGE, RNORM
      real(kind(one)) NORM, SM, SS, T, UNORM, UP, ZTEST

      CALL  INITIALIZE
!
!   The above call will set IERR.
      LOOPA: DO
!
!   Quit on error flag, or if all coefficients are already in the
!   solution, .or. if M columns of A have been triangularized.
         IF  (IERR  /=   0  .or.  IZ1  > IZ2 .or. NSETP >= M) exit LOOPA
!
         CALL  SELECT_ANOTHER_COEFF_TO!_SOLVE_FOR
!
!   See if no index was found to be moved from set Z to set P.
!   Then go to termination.
         IF  ( .not. FIND ) exit LOOPA
!
         CALL  MOVE_J_FROM_SET_Z_TO_SET_P
!
         CALL  TEST_SET_P_AGAINST_CONSTRAINTS
!
!   The above call may set IERR.
!   All coefficients in set P are strictly feasible.  Loop back.
      END DO LOOPA
!
      CALL  TERMINATION
      RETURN

      CONTAINS  ! These are internal subroutines.
      SUBROUTINE INITIALIZE
      M=size(A,1); N=size(A,2)
      IF  (M  <=  0 .or. N  <=  0) then
         IERR = 1
         RETURN
      END IF
!
! Check array sizes for consistency and with M and N.
      IF(SIZE(X) < N) THEN
         IERR=2
         RETURN
      END IF
      IF(SIZE(B) < M) THEN
         IERR=2
         RETURN
      END IF
      IF(SIZE(BND,1) /= 2) THEN
         IERR=2
         RETURN
      END IF
      IF(SIZE(BND,2) < N) THEN
         IERR=2
         RETURN
      END IF
      IF(SIZE(W) < N) THEN
         IERR=2
         RETURN
      END IF
      IF(SIZE(INDEX) < N) THEN
         IERR=2
         RETURN
      END IF

      IERR = 0
!   The next two parameters can be changed to be optional for library software.
      EPS = EPSILON(ONE)
      ITMAX=3*N
      ITER=0
!   Initialize the array index().
      DO I=1,N
         INDEX(I)=I
      END DO
!
      IZ2=N
      IZ1=1
      NSETP=0
      NPP1=1
!
!   Begin:  Loop on IZ to initialize  X().
      IZ=IZ1
      DO
         IF  (IZ  >  IZ2 ) EXIT
         J=INDEX(IZ)
         IF  ( BND(1,J)   <=   -huge(ONE)) then
            IF  (BND(2,J)   >=    huge(ONE)) then
               X(J) = ZERO
            else
               X(J) = min(ZERO,BND(2,J))
            END IF
         ELSE  IF  ( BND(2,J)   >=   huge(ONE)) then
            X(J) = max(ZERO,BND(1,J))
         else
            RANGE = BND(2,J) - BND(1,J)
            IF  ( RANGE   <=   ZERO ) then
!
!   Here X(J) is constrained to a single value.
               INDEX(IZ)=INDEX(IZ2)
               INDEX(IZ2)=J
               IZ=IZ-1
               IZ2=IZ2-1
               X(J)=BND(1,J)
               W(J)=ZERO
            ELSE  IF  ( RANGE  >  ZERO) then
!
!   The following statement sets X(J) to 0 if the constraint interval
!   includes 0, and otherwise sets X(J) to the endpoint of the
!   constraint interval that is closest to 0.
!
               X(J) = max(BND(1,J), min(BND(2,J),ZERO))
            else
               IERR = 3
               RETURN
            END IF! ( RANGE:.)
         END IF
!
         IF  ( abs(X(J))   >   ZERO ) then
!
!   Change B() to reflect a nonzero starting value for X(J).
            B(1:M)=B(1:M)-A(1:M,J)*X(J)
         END IF
         IZ=IZ+1
      END DO! ( IZ   <=   IZ2 )
      END SUBROUTINE! ( INITIALIZE )

      SUBROUTINE  SELECT_ANOTHER_COEFF_TO!_SOLVE_FOR
!
!   1. Search through set z for a new coefficient to solve for.
!   First select a candidate that is either an unconstrained
!   coefficient or else a constrained coefficient that has room
!   to move in the direction consistent with the sign of its dual
!   vector component.  Components of the dual (negative gradient)
!   vector will be computed as needed.
!   2. For each candidate start the transformation to bring this
!   candidate into the triangle, and then do two tests:  Test size
!   of new diagonal value to avoid extreme ill-conditioning, and
!   the value of this new coefficient to be sure it moved in the
!   expected direction.
!   3. If some coefficient passes all these conditions, set FIND = true,
!   The index of the selected coefficient is J = INDEX(IZ).
!   4. If no coefficient is selected, set FIND = false.
!
      FIND = .FALSE.
      DO IZ=IZ1,IZ2
         J=INDEX(IZ)
!
!   Set FREE1 = true if X(J) is not at the left end-point of its
!   constraint region.
!   Set FREE2 = true if X(J) is not at the right end-point of its
!   constraint region.
!   Set FREE = true if X(J) is not at either end-point of its
!   constraint region.
!
         FREE1 = X(J)   >   BND(1,J)
         FREE2 = X(J)   <   BND(2,J)
         FREE = FREE1 .and. FREE2

         IF  ( FREE ) then
            CALL TEST_COEF_J_FOR_DIAG!_ELT_AND_DIRECTION_OF_CHANGE
         else
!   Compute dual coefficient W(J).
            W(J)=dot_product(A(NPP1:M,J),B(NPP1:M))
!
!   Can X(J) move in the direction indicated by the sign of W(J)?
!
            IF  ( W(J)   <  ZERO ) then
               IF  ( FREE1 )
     &              CALL TEST_COEF_J_FOR_DIAG !_ELT_AND_DIRECTION_OF_CHANGE
            ELSE  IF  ( W(J)   >  ZERO ) then
               IF  ( FREE2 )
     &              CALL TEST_COEF_J_FOR_DIAG !_ELT_AND_DIRECTION_OF_CHANGE
            END IF
         END IF
         IF  ( FIND ) RETURN
      END DO!  IZ
      END SUBROUTINE! ( SELECT ANOTHER COEF TO SOLVE FOR )

      SUBROUTINE TEST_COEF_J_FOR_DIAG!_ELT_AND_DIRECTION_OF_CHANGE
!
!   The sign of W(J) is OK for J to be moved to set P.
!   Begin the transformation and check new diagonal element to avoid
!   near linear dependence.
!
      ASAVE=A(NPP1,J)
      call HTC (NPP1, A(1:M,J), UP)
      UNORM = NRM2(A(1:NSETP,J))
      IF  ( abs(A(NPP1,J)) > EPS * UNORM) then
!
!   Column J is sufficiently independent.  Copy b into Z, update Z.
         Z(1:M)=B(1:M)
! Compute product of transormation and updated right-hand side.
         NORM=A(NPP1,J); A(NPP1,J)=UP
         IF(ABS(NORM) > ZERO) THEN
            SM=DOT_PRODUCT(A(NPP1:M,J)/NORM, Z(NPP1:M))/UP
            Z(NPP1:M)=Z(NPP1:M)+SM*A(NPP1:M,J)
            A(NPP1,J)=NORM
         END IF

         IF  (abs(X(J)) >  ZERO) Z(1:NPP1)=Z(1:NPP1)+A(1:NPP1,J)*X(J)
!   Adjust Z() as though X(J) had been reset to zero.
         IF  ( FREE ) then
            FIND = .TRUE.
         else
!
!   Solve for ZTEST ( proposed new value for X(J) ).
!   Then set FIND to indicate if ZTEST has moved away from X(J) in
!   the expected direction indicated by the sign of W(J).
            ZTEST=Z(NPP1)/A(NPP1,J)
            FIND = ( W(J)  <  ZERO  .and.  ZTEST   <  X(J) )  .or.
     &           ( W(J)  >  ZERO  .and.  ZTEST  >  X(J) )
         END IF
      END IF
!
!   If J was not accepted to be moved from set Z to set P,
!   restore A(NNP1,J).  Failing these tests may mean the computed
!   sign of W(J) is suspect, so here we set W(J) = 0.  This will
!   not affect subsequent computation, but cleans up the W() array.
      IF  ( .not. FIND ) then
         A(NPP1,J)=ASAVE
         W(J)=ZERO
      END IF! ( .not. FIND )
      END SUBROUTINE !TEST_COEF_J_FOR_DIAG!_ELT_AND_DIRECTION_OF_CHANGE

      SUBROUTINE MOVE_J_FROM_SET_Z_TO_SET_P
!
!   The index  J=index(IZ)  has been selected to be moved from
!   set Z to set P.  Z() contains the old B() adjusted as though X(J) = 0.
!   A(*,J) contains the new Householder transformation vector.
      B(1:M)=Z(1:M)
!
      INDEX(IZ)=INDEX(IZ1)
      INDEX(IZ1)=J
      IZ1=IZ1+1
      NSETP=NPP1
      NPP1=NPP1+1
!   The following loop can be null or not required.
      NORM=A(NSETP,J); A(NSETP,J)=UP
      IF(ABS(NORM) > ZERO) THEN
         DO JZ=IZ1,IZ2
            JJ=INDEX(JZ)
            SM=DOT_PRODUCT(A(NSETP:M,J)/NORM, A(NSETP:M,JJ))/UP
            A(NSETP:M,JJ)=A(NSETP:M,JJ)+SM*A(NSETP:M,J)
         END DO
         A(NSETP,J)=NORM
      END IF
!   The following loop can be null.
      DO L=NPP1,M
         A(L,J)=ZERO
      END DO!  L
!
      W(J)=ZERO
!
!   Solve the triangular system.  Store this solution temporarily in Z().
      DO I = NSETP, 1, -1
         IF  (I  /=  NSETP) Z(1:I)=Z(1:I)-A(1:I,II)*Z(I+1)
         II=INDEX(I)
         Z(I)=Z(I)/A(I,II)
      END DO
      END SUBROUTINE! ( MOVE J FROM SET Z TO SET P )

      SUBROUTINE TEST_SET_P_AGAINST_CONSTRAINTS
!
      LOOPB: DO
!   The solution obtained by solving the current set P is in the array Z().
!
      ITER=ITER+1
      IF  (ITER   >  ITMAX) then
         IERR = 4
         exit LOOPB
      END IF
!
      CALL SEE_IF_ALL_CONSTRAINED_COEFFS!_ARE_FEASIBLE
!
!   The above call sets HITBND.  If HITBND = true then it also sets
!   ALPHA, JJ, and IBOUND.
      IF  ( .not. HITBND ) exit LOOPB
!
!   Here ALPHA will be between 0 and 1 for interpolation
!   between the old X() and the new Z().
      DO IP=1,NSETP
         L=INDEX(IP)
         X(L)=X(L)+ALPHA*(Z(IP)-X(L))
      END DO
!
      I=INDEX(JJ)
!   Note:  The exit test is done at the end of the loop, so the loop
!   will always be executed at least once.
      DO
!
!   Modify A(*,*), B(*) and the index arrays to move coefficient I
!   from set P to set Z.
!
         CALL  MOVE_COEF_I_FROM_SET_P_TO_SET_Z
!
         IF  (NSETP  <=  0) exit LOOPB
!
!   See if the remaining coefficients in set P are feasible.  They should
!   be because of the way ALPHA was determined.  If any are infeasible
!   it is due to round-off error.  Any that are infeasible or on a boundary
!   will be set to the boundary value and moved from set P to set Z.
!
         IBOUND = 0
         DO JJ=1,NSETP
            I=INDEX(JJ)
            IF  ( X(I)  <=  BND(1,I)) then
               IBOUND=1
               EXIT
            ELSE IF ( X(I)  >=  BND(2,I)) then
               IBOUND=2
               EXIT
            END IF
         END DO
         IF  (IBOUND   <=   0)   EXIT
      END DO
!
!   Copy B( ) into Z( ).  Then solve again and loop back.
      Z(1:M)=B(1:M)
!
      DO I = NSETP, 1, -1
         IF  (I  /=  NSETP) Z(1:I)=Z(1:I)-A(1:I,II)*Z(I+1)
         II=INDEX(I)
         Z(I)=Z(I)/A(I,II)
      END DO
      END DO LOOPB

!   The following loop can be null.
      DO IP=1,NSETP
         I=INDEX(IP)
         X(I)=Z(IP)
      END DO

      END SUBROUTINE! ( TEST SET P AGAINST CONSTRAINTS)

      SUBROUTINE  SEE_IF_ALL_CONSTRAINED_COEFFS!_ARE_FEASIBLE
!
!   See if each coefficient in set P is strictly interior to its constraint region.
!   If so, set HITBND = false.
!   If not, set HITBND = true, and also set ALPHA, JJ, and IBOUND.
!   Then ALPHA will satisfy  0.  < ALPHA  <=  1.
!
      ALPHA=TWO
      DO IP=1,NSETP
         L=INDEX(IP)
         IF  (Z(IP)  <=  BND(1,L)) then
!   Z(IP) HITS LOWER BOUND
            LBOUND=1
         ELSE  IF  (Z(IP)  >=  BND(2,L)) then
!   Z(IP) HITS UPPER BOUND
            LBOUND=2
         else
            LBOUND = 0
         END IF
!
         IF  ( LBOUND   /=   0 ) then
            T=(BND(LBOUND,L)-X(L))/(Z(IP)-X(L))
            IF  (ALPHA   >  T) then
               ALPHA=T
               JJ=IP
               IBOUND=LBOUND
            END IF! ( LBOUND )
         END IF! ( ALPHA   >  T )
      END DO
      HITBND = abs(ALPHA   -  TWO) > ZERO
      END SUBROUTINE!( SEE IF ALL CONSTRAINED COEFFS ARE FEASIBLE )

      SUBROUTINE MOVE_COEF_I_FROM_SET_P_TO_SET_Z
!
      X(I)=BND(IBOUND,I)
      IF  (abs(X(I))   >  ZERO .and.  JJ > 0) B(1:JJ)=B(1:JJ)-A(1:JJ,I)*
     &     X(I)

!   The following loop can be null.
      DO J = JJ+1, NSETP
         II=INDEX(J)
         INDEX(J-1)=II
         call ROTG (A(J-1,II),A(J,II),CC,SS)
         SM=A(J-1,II)
!
!   The plane rotation is applied to two rows of A and the right-hand
!   side.  One row is moved to the scratch array S and then the updates
!   are computed.  The intent is for array operations to be performed
!   and minimal extra data movement.  One extra rotation is applied
!   to column II in this approach.
         S=A(J-1,1:N)
         A(J-1,1:N)=CC*S+SS*A(J,1:N)
         A(J,1:N)=CC*A(J,1:N)-SS*S
         A(J-1,II)=SM
         A(J,II)=ZERO
         SM=B(J-1)
         B(J-1)=CC*SM+SS*B(J)
         B(J)=CC*B(J)-SS*SM
      END DO
!
      NPP1=NSETP
      NSETP=NSETP-1
      IZ1=IZ1-1
      INDEX(IZ1)=I
      END SUBROUTINE! ( MOVE COEF I FROM SET P TO SET Z )

      SUBROUTINE TERMINATION
!
      IF  (IERR   <=   0) then
!
!   Compute the norm of the residual vector.
         SM=ZERO
         IF  (NPP1   <=   M) then
            SM=NRM2(B(NPP1:M))
         else
            W(1:N)=ZERO
         END IF
         RNORM=SM
      END IF! ( IERR...)
      END SUBROUTINE! ( TERMINATION )

      SUBROUTINE ROTG(SA,SB,C,S)
!
      REAL(KIND(ONE)) SA,SB,C,S,ROE,SCALE,R
!
      ROE = SB
      IF( ABS(SA) .GT. ABS(SB) ) ROE = SA
      SCALE = ABS(SA) + ABS(SB)
      IF( SCALE .LE. ZERO ) THEN
         C = ONE
         S = ZERO
         RETURN
      END IF
      R = SCALE*SQRT((SA/SCALE)**2 + (SB/SCALE)**2)
      IF(ROE < ZERO)R=-R
      C = SA/R
      S = SB/R
      SA = R
      RETURN
      END SUBROUTINE !ROTG

      REAL(KIND(ONE)) FUNCTION NRM2 (X)
!
!   NRM2 returns the Euclidean norm of a vector via the function
!   name, so that
!
!   NRM2 := sqrt( x'*x )
!
      REAL(KIND(ONE)) ABSXI, X(:), NORM, SCALE, SSQ
      INTEGER N, IX
      N=SIZE(X)
      IF( N < 1)THEN
         NORM  = ZERO
      ELSE IF( N == 1 )THEN
         NORM  = ABS( X( 1 ) )
      ELSE
         SCALE = ZERO
         SSQ   = ONE
!
         DO IX = 1, N
            ABSXI = ABS( X( IX ) )
            IF(ABSXI > ZERO )THEN
               IF( SCALE < ABSXI )THEN
                  SSQ   = ONE + SSQ*( SCALE/ABSXI )**2
                  SCALE = ABSXI
               ELSE
                  SSQ   = SSQ + ( ABSXI/SCALE )**2
               END IF
            END IF
         END DO
         NORM  = SCALE * SQRT( SSQ )
      END IF
!
      NRM2 = NORM
      RETURN
      END FUNCTION

      SUBROUTINE HTC (P, U, UP)
!
!   Construct a Householder transormation.
      INTEGER P
      REAL(KIND(ONE)) U(:)
      REAL(KIND(ONE)) UP, VNORM
      VNORM=NRM2(U(P:SIZE(U)))
      IF(U(P) > ZERO) VNORM=-VNORM
      UP=U(P)-VNORM
      U(P)=VNORM
      END SUBROUTINE ! HTC

      END SUBROUTINE ! BVLS
!=======================================================================
!
! Author: Shannon L. Brown <slbrow@sandia.gov>
!
! This fixed-source Fortran 90 wrapper handles converting the explicit-
! shape arrays (e.g., A(M,N)) that arise in mixed-language processing to
! the assumed-shape arrays (e.g., A(:,:)) that the BVLS subroutine is
! expecting.  It is _NOT_ part of the lawson_hanson2.F file distributed
! by NETLIB; it is the second addition (along with the first addition at
! the top of this file).  Both additions are in fixed format.
!
! The module declaring that it CONTAINS the BVLS subroutine has been
! added at the top of this file, and the wrapper subroutine using it is
! defined here (at the bottom of the file).  Both additions are
! separated from the original file by two fence lines formatted using:
! FORMAT('!',72('='),/)
!
      END MODULE bvls_module
      SUBROUTINE bvls_wrapper(a, m, n, b, bnd, x, rnorm, nsetp, w,
     &                        index, ierr)
!
! The bvls_module is defined below as a wrapping module on the top-level
! subroutine in this file (BVLS in the original file).
!
      USE bvls_module
      IMPLICIT NONE
!
! Clarifying what variables are purely input, locally modified and
! returned via call-by-reference or purely output by the bvls subroutine
! using the INTENT keyword in F90.
!
      INTEGER :: m, n
      INTEGER, INTENT(OUT) :: ierr, nsetp
      INTEGER, DIMENSION(n), INTENT(OUT) :: index
      REAL(KIND(1D0)), INTENT(OUT) :: rnorm
      REAL(KIND(1D0)), DIMENSION(m,n), INTENT(INOUT) :: a
      REAL(KIND(1D0)), DIMENSION(m), INTENT(INOUT) :: b
      REAL(KIND(1D0)), DIMENSION(2,n), INTENT(IN) :: bnd
      REAL(KIND(1D0)), DIMENSION(n), INTENT(OUT) :: x, w
      CALL bvls(a, b, bnd, x, rnorm, nsetp, w, index, ierr)
      END SUBROUTINE bvls_wrapper
!=======================================================================


c---------------------------------------------------------------------
c---------------------------------------------------------------------

       subroutine lhsx(c)

c---------------------------------------------------------------------
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c This function computes the left hand side for the three x-factors
c---------------------------------------------------------------------

       include 'header.h'

       double precision ru1
       integer          i, j, k, c

c---------------------------------------------------------------------
c      treat only cell c
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c      first fill the lhs for the u-eigenvalue
c---------------------------------------------------------------------
       do  k = start(3,c), cell_size(3,c)-end(3,c)-1
          do  j = start(2,c), cell_size(2,c)-end(2,c)-1
             do  i = start(1,c)-1, cell_size(1,c)-end(1,c)
                ru1 = c3c4*rho_i(i,j,k,c)
                cv(i) = us(i,j,k,c)
                rhon(i) = dmax1(dx2+con43*ru1,
     >                          dx5+c1c5*ru1,
     >                          dxmax+ru1,
     >                          dx1)
             end do

             do  i = start(1,c), cell_size(1,c)-end(1,c)-1
                lhs(i,j,k,1,c) =   0.0d0
                lhs(i,j,k,2,c) = - dttx2 * cv(i-1) - dttx1 * rhon(i-1)
                lhs(i,j,k,3,c) =   1.0d0 + c2dttx1 * rhon(i)
                lhs(i,j,k,4,c) =   dttx2 * cv(i+1) - dttx1 * rhon(i+1)
                lhs(i,j,k,5,c) =   0.0d0
             end do
          end do
       end do

c---------------------------------------------------------------------
c      add fourth order dissipation
c---------------------------------------------------------------------
       if (start(1,c) .gt. 0) then
          i = 1
          do   k = start(3,c), cell_size(3,c)-end(3,c)-1
             do   j = start(2,c), cell_size(2,c)-end(2,c)-1
                lhs(i,j,k,3,c) = lhs(i,j,k,3,c) + comz5
                lhs(i,j,k,4,c) = lhs(i,j,k,4,c) - comz4
                lhs(i,j,k,5,c) = lhs(i,j,k,5,c) + comz1

                lhs(i+1,j,k,2,c) = lhs(i+1,j,k,2,c) - comz4
                lhs(i+1,j,k,3,c) = lhs(i+1,j,k,3,c) + comz6
                lhs(i+1,j,k,4,c) = lhs(i+1,j,k,4,c) - comz4
                lhs(i+1,j,k,5,c) = lhs(i+1,j,k,5,c) + comz1
             end do
          end do
       endif

       do   k = start(3,c), cell_size(3,c)-end(3,c)-1
          do   j = start(2,c), cell_size(2,c)-end(2,c)-1
             do   i=3*start(1,c), cell_size(1,c)-3*end(1,c)-1
                lhs(i,j,k,1,c) = lhs(i,j,k,1,c) + comz1
                lhs(i,j,k,2,c) = lhs(i,j,k,2,c) - comz4
                lhs(i,j,k,3,c) = lhs(i,j,k,3,c) + comz6
                lhs(i,j,k,4,c) = lhs(i,j,k,4,c) - comz4
                lhs(i,j,k,5,c) = lhs(i,j,k,5,c) + comz1
             end do
          end do
       end do

       if (end(1,c) .gt. 0) then
          i = cell_size(1,c)-3
          do   k = start(3,c), cell_size(3,c)-end(3,c)-1
             do   j = start(2,c), cell_size(2,c)-end(2,c)-1
                lhs(i,j,k,1,c) = lhs(i,j,k,1,c) + comz1
                lhs(i,j,k,2,c) = lhs(i,j,k,2,c) - comz4
                lhs(i,j,k,3,c) = lhs(i,j,k,3,c) + comz6
                lhs(i,j,k,4,c) = lhs(i,j,k,4,c) - comz4

                lhs(i+1,j,k,1,c) = lhs(i+1,j,k,1,c) + comz1
                lhs(i+1,j,k,2,c) = lhs(i+1,j,k,2,c) - comz4
                lhs(i+1,j,k,3,c) = lhs(i+1,j,k,3,c) + comz5
             end do
          end do
       endif

c---------------------------------------------------------------------
c      subsequently, fill the other factors (u+c), (u-c) by a4ing to
c      the first
c---------------------------------------------------------------------
       do   k = start(3,c), cell_size(3,c)-end(3,c)-1
          do   j = start(2,c), cell_size(2,c)-end(2,c)-1
             do   i = start(1,c), cell_size(1,c)-end(1,c)-1
                lhs(i,j,k,1+5,c)  = lhs(i,j,k,1,c)
                lhs(i,j,k,2+5,c)  = lhs(i,j,k,2,c) -
     >                            dttx2 * speed(i-1,j,k,c)
                lhs(i,j,k,3+5,c)  = lhs(i,j,k,3,c)
                lhs(i,j,k,4+5,c)  = lhs(i,j,k,4,c) +
     >                            dttx2 * speed(i+1,j,k,c)
                lhs(i,j,k,5+5,c) = lhs(i,j,k,5,c)
                lhs(i,j,k,1+10,c) = lhs(i,j,k,1,c)
                lhs(i,j,k,2+10,c) = lhs(i,j,k,2,c) +
     >                            dttx2 * speed(i-1,j,k,c)
                lhs(i,j,k,3+10,c) = lhs(i,j,k,3,c)
                lhs(i,j,k,4+10,c) = lhs(i,j,k,4,c) -
     >                            dttx2 * speed(i+1,j,k,c)
                lhs(i,j,k,5+10,c) = lhs(i,j,k,5,c)
             end do
          end do
       end do

       return
       end


! Program performing analytic continuations using an average of different Pade approximants.
! Written by Johan Schott and Elin Lundin.
! Given input data zin, f(zin) and complex points zout, the main output is f(zout).

! The file pade.in has four columns: Re[zin], Im[zin], Re[f(zin)] and Im[f(zin)]
! The file pade.par contains the input parameters.

! Computational time considerations:
! The number of independent continuations is denoted by the variable ns.
! The computational task for doing the continuations scales O(ns).
! Constructing deviation matrix between different continuations scales O(ns^2).
! Both performing the continuations and the deviation matrix can be parallelized.
! But it is not done since the serial program is not very slow.
!------------------------------------------------------------------------------------------------------

program main
use loadsavetxt
use padem
implicit none
complex(kind=16),allocatable :: zin(:),fin(:)
complex(kind=16),allocatable :: zout(:)
complex(kind=8),allocatable  :: fout(:)

! Read zin and f(zin) from file pade.in
call readinputdata(zin,fin)

! Construct zout by reading from parameter file pade.par
call readzoutdata(zout)

! Perform the analytical continuation and return fout.
call pade(zin,fin,zout,fout)

! Save the output function in file pade_fout and the spectral function in file pade_A
call savefout(zout,fout)

! Deallocate variables
if(allocated(zin))  deallocate(zin)
if(allocated(fin))  deallocate(fin)
if(allocated(zout)) deallocate(zout)
if(allocated(fout)) deallocate(fout)

write(*,'(a)') "Averaging Pade approximant program successfully finished."

end program


C Copyright(C) 1999-2020 National Technology & Engineering Solutions
C of Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C NTESS, the U.S. Government retains certain rights in this software.
C
C See packages/seacas/LICENSE for details

C=======================================================================
*DECK,VOL
      SUBROUTINE VOL (ITYPE,XX,YY,ZZ,VOLUME)

C     ******************************************************************

C     SUBROUTINE TO FIND THE VOLUME OF AN ELEMENT

C     Called by ELTON3, ELTOND

C     ******************************************************************

      DIMENSION XX(*), YY(*), ZZ(*)

C     ******************************************************************

      IF (ITYPE .EQ. 3) THEN

C 4-node quad

        A1 = XX(1) - XX(3)
        B1 = YY(1) - YY(3)
        A2 = XX(2) - XX(4)
        B2 = YY(2) - YY(4)
        CCR = (A1 * B2) - (A2 * B1)
        VOLUME = 0.5 * ABS(CCR)

        RETURN

      ELSE IF (ITYPE .EQ. 10) THEN

C 8-node hex

        GR1 = ( YY(2)*(ZZ(6)-ZZ(3)-ZZ(4)+ZZ(5)) + YY(3)*(ZZ(2)-ZZ(4))
     &        + YY(4)*(ZZ(3)-ZZ(8)-ZZ(5)+ZZ(2))
     &        + YY(5)*(ZZ(8)-ZZ(6)-ZZ(2)+ZZ(4))
     &        + YY(6)*(ZZ(5)-ZZ(2)) + YY(8)*(ZZ(4)-ZZ(5)) ) / 12.

        GR2 = ( YY(3)*(ZZ(7)-ZZ(4)-ZZ(1)+ZZ(6)) + YY(4)*(ZZ(3)-ZZ(1))
     &        + YY(1)*(ZZ(4)-ZZ(5)-ZZ(6)+ZZ(3))
     &        + YY(6)*(ZZ(5)-ZZ(7)-ZZ(3)+ZZ(1))
     &        + YY(7)*(ZZ(6)-ZZ(3)) + YY(5)*(ZZ(1)-ZZ(6)) ) / 12.

        GR3 = ( YY(4)*(ZZ(8)-ZZ(1)-ZZ(2)+ZZ(7)) + YY(1)*(ZZ(4)-ZZ(2))
     &        + YY(2)*(ZZ(1)-ZZ(6)-ZZ(7)+ZZ(4))
     &        + YY(7)*(ZZ(6)-ZZ(8)-ZZ(4)+ZZ(2))
     &        + YY(8)*(ZZ(7)-ZZ(4)) + YY(6)*(ZZ(2)-ZZ(7)) ) / 12.

        GR4 = ( YY(1)*(ZZ(5)-ZZ(2)-ZZ(3)+ZZ(8)) + YY(2)*(ZZ(1)-ZZ(3))
     &        + YY(3)*(ZZ(2)-ZZ(7)-ZZ(8)+ZZ(1))
     &        + YY(8)*(ZZ(7)-ZZ(5)-ZZ(1)+ZZ(3))
     &        + YY(5)*(ZZ(8)-ZZ(1)) + YY(7)*(ZZ(3)-ZZ(8)) ) / 12.

        GR5 = ( YY(8)*(ZZ(4)-ZZ(7)-ZZ(6)+ZZ(1)) + YY(7)*(ZZ(8)-ZZ(6))
     &        + YY(6)*(ZZ(7)-ZZ(2)-ZZ(1)+ZZ(8))
     &        + YY(1)*(ZZ(2)-ZZ(4)-ZZ(8)+ZZ(6))
     &        + YY(4)*(ZZ(1)-ZZ(8)) + YY(2)*(ZZ(6)-ZZ(1)) ) / 12.

        GR6 = ( YY(5)*(ZZ(1)-ZZ(8)-ZZ(7)+ZZ(2)) + YY(8)*(ZZ(5)-ZZ(7))
     &        + YY(7)*(ZZ(8)-ZZ(3)-ZZ(2)+ZZ(5))
     &        + YY(2)*(ZZ(3)-ZZ(1)-ZZ(5)+ZZ(7))
     &        + YY(1)*(ZZ(2)-ZZ(5)) + YY(3)*(ZZ(7)-ZZ(2)) ) / 12.

        GR7 = ( YY(6)*(ZZ(2)-ZZ(5)-ZZ(8)+ZZ(3)) + YY(5)*(ZZ(6)-ZZ(8))
     &        + YY(8)*(ZZ(5)-ZZ(4)-ZZ(3)+ZZ(6))
     &        + YY(3)*(ZZ(4)-ZZ(2)-ZZ(6)+ZZ(8))
     &        + YY(2)*(ZZ(3)-ZZ(6)) + YY(4)*(ZZ(8)-ZZ(3)) ) / 12.

        GR8 = ( YY(7)*(ZZ(3)-ZZ(6)-ZZ(5)+ZZ(4)) + YY(6)*(ZZ(7)-ZZ(5))
     &        + YY(5)*(ZZ(6)-ZZ(1)-ZZ(4)+ZZ(7))
     &        + YY(4)*(ZZ(1)-ZZ(3)-ZZ(7)+ZZ(5))
     &        + YY(3)*(ZZ(4)-ZZ(7)) + YY(1)*(ZZ(5)-ZZ(4)) ) / 12.

        VOLUME = XX(1) * GR1 + XX(2) * GR2 + XX(3) * GR3 + XX(4) * GR4
     &         + XX(5) * GR5 + XX(6) * GR6 + XX(7) * GR7 + XX(8) * GR8

        RETURN

      ELSE IF (ITYPE .EQ. 13) THEN

C 4-node shell, ignore curvature

        A1 = XX(1) - XX(3)
        B1 = YY(1) - YY(3)
        C1 = ZZ(1) - ZZ(3)
        A2 = XX(2) - XX(4)
        B2 = YY(2) - YY(4)
        C2 = ZZ(2) - ZZ(4)

        ACR = (B1 * C2) - (B2 * C1)
        BCR = (A1 * C2) - (A2 * C1)
        CCR = (A1 * B2) - (A2 * B1)

        VOLUME = 0.5 * SQRT(ACR*ACR + BCR*BCR + CCR*CCR)

        RETURN
      ELSE IF (ITYPE .EQ. 6) THEN

C 4-node tet
C (process Key's 8-node tet the same way using first 4 nodes)

        Y12 = YY(1) - YY(2)
        Y13 = YY(1) - YY(3)
        Y14 = YY(1) - YY(4)
        Y24 = YY(2) - YY(4)
        Y34 = YY(3) - YY(4)
        Z12 = ZZ(1) - ZZ(2)
        Z13 = ZZ(1) - ZZ(3)
        Z14 = ZZ(1) - ZZ(4)
        Z24 = ZZ(2) - ZZ(4)
        Z34 = ZZ(3) - ZZ(4)

        BX1 = (Y34*Z24 - Y24*Z34) / 6.0
        BX2 = (Y13*Z14 - Y14*Z13) / 6.0
        BX3 = (Y14*Z12 - Y12*Z14) / 6.0
        BX4 = (Y12*Z13 - Y13*Z12) / 6.0

        VOLUME = BX1*XX(1) + BX2*XX(2) + BX3*XX(3) + BX4*XX(4)
      ELSE
        CALL ERROR('VOL','ELEMENT TYPE',' ',ITYPE,
     &             'NOT YET IMPLEMENTED',0,' ',' ',1)
      END IF
      RETURN
      END


      MODULE m_divi
      CONTAINS
      SUBROUTINE divi(
     >                nkpt,rltv,film,nop,nop2,
     <                n)

      IMPLICIT NONE

      INTEGER, INTENT (IN) :: nkpt      ! maximum number of k-points
      INTEGER, INTENT (IN) :: nop,nop2  ! number of symmetry operations (3D,2D)
      REAL,    INTENT (IN) :: rltv(3,3) ! reciprocal lattice axes
      LOGICAL, INTENT (IN) :: film      ! .true. -> 2D k-points
      INTEGER, INTENT(OUT) :: n(3)      ! # of k-points in each direction

      INTEGER ntes,i,ntot
      REAL    b(3)

      DO i = 1,3
        b(i) = sqrt( rltv(i,1)**2 + rltv(i,2)**2 + rltv(i,3)**2 )
      ENDDO

      IF (film) THEN
        ntot = nkpt * nop2
      ELSE
        ntot = nkpt * nop
      ENDIF

      IF (film) THEN
        ntes = ntot
  5     n(1) = nint( sqrt( ntes*b(1)/b(2) ) )
        n(2) = nint( n(1)*b(2)/b(1) )
        IF (n(1)*n(2).GT.ntot) THEN
          n(2) = nint(  sqrt( ntes*b(2)/b(1) ) )
          n(1) = nint( n(2)*b(1)/b(2) )
          IF (n(1)*n(2).GT.ntot) THEN
            ntes = ntes - 1
            GOTO 5
          ENDIF
        ENDIF
        n(3) = 0
        IF (nop2.GE.4) THEN
          n(1) = MAX(2*NINT(n(1)/2.0+0.1),1)
          n(2) = MAX(2*NINT(n(2)/2.0+0.1),1)
        ENDIF
        n(1) = MAX(n(1),1)
        n(2) = MAX(n(2),1)
        WRITE (*,*) n(1),n(2),n(1)*n(2)
      ELSE
        ntes = ntot
 10     n(1) = nint( (ntes*b(1)**2/(b(2)*b(3)))**(1./3.) )
        n(2) = nint( n(1)*b(2)/b(1) )
        n(3) = nint( n(1)*b(3)/b(1) )
        IF (n(1)*n(2)*n(3).GT.ntot) THEN
          n(2) = nint( (ntes*b(2)**2/(b(1)*b(3)))**(1./3.) )
          n(1) = nint( n(2)*b(1)/b(2) )
          n(3) = nint( n(2)*b(3)/b(2) )
          IF (n(1)*n(2)*n(3).GT.ntot) THEN
            n(3) = nint( (ntes*b(3)**2/(b(1)*b(2)))**(1./3.) )
            n(2) = nint( n(3)*b(2)/b(3) )
            n(1) = nint( n(3)*b(1)/b(3) )
            IF (n(1)*n(2)*n(3).GT.ntot) THEN
              ntes = ntes - 1
              GOTO 10
            ENDIF
          ENDIF
        ENDIF
        IF (nop.GE.8) THEN
          n(1) = MAX(2*NINT(n(1)/2.0-0.1),1)
          n(2) = MAX(2*NINT(n(2)/2.0-0.1),1)
          n(3) = MAX(2*NINT(n(3)/2.0-0.1),1)
        ENDIF
        n(1) = MAX(n(1),1)
        n(2) = MAX(n(2),1)
        n(3) = MAX(n(3),1)
        WRITE (*,*) n(1),n(2),n(3),n(1)*n(2)*n(3)
      ENDIF

      RETURN
      END SUBROUTINE divi
      END MODULE m_divi


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

!> @brief Performs the Newton Rapson algorithm.
!! @author Ilario Mazzieri
!> @date September, 2013
!> @version 1.0
!> @param[in] xnod x-coord of the point
!> @param[in] ynod y-coord of the point
!> @param[in] znod z-coord of the point
!> @param[in] alfa11 costant for the bilinear map
!> @param[in] alfa12 costant for the bilinear map
!> @param[in] alfa13 costant for the bilinear map
!> @param[in] alfa21 costant for the bilinear map
!> @param[in] alfa22 costant for the bilinear map
!> @param[in] alfa23 costant for the bilinear map
!> @param[in] alfa31 costant for the bilinear map
!> @param[in] alfa32 costant for the bilinear map
!> @param[in] alfa33 costant for the bilinear map
!> @param[in] beta11 costant for the bilinear map
!> @param[in] beta12 costant for the bilinear map
!> @param[in] beta13 costant for the bilinear map
!> @param[in] beta21 costant for the bilinear map
!> @param[in] beta22 costant for the bilinear map
!> @param[in] beta23 costant for the bilinear map
!> @param[in] beta31 costant for the bilinear map
!> @param[in] beta32 costant for the bilinear map
!> @param[in] beta33 costant for the bilinear map
!> @param[in] gamma1  costant for the bilinear map
!> @param[in] gamma2  costant for the bilinear map
!> @param[in] gamma3  costant for the bilinear map
!> @param[in] delta1  costant for the bilinear map
!> @param[in] delta2  costant for the bilinear map
!> @param[in] delta3  costant for the bilinear map
!> @param[in] tt   1 if the node belongs to the element, 0 otherwise
!> @param[in] nofi  number of iterations (dummy)
!> @param[in] id_mpi  mpi processor identity
!> @param[in] ipiu control parameter (dummy)
!> @param[in] imeno control parameter (dummy)
!> @param[in] toll1 fixed tolerance
!> @param[in] toll2  fixed tolerance
!> @param[in] flag  control parameter
!> @param[out] csi_s x-coordinate in the reference element of xnod,ynod,znod
!> @param[out] eta_s y-coordinate in the reference element of xnod,ynod,znod
!> @param[out] zeta_s z-coordinate in the reference element of xnod,ynod,znod

     subroutine NEWTON_RAPSON(xnod, ynod, znod, &
                           alfa11,alfa12,alfa13, &
                           alfa21,alfa22,alfa23, &
                           alfa31,alfa32,alfa33, &
                           beta11,beta12,beta13, &
                           beta21,beta22,beta23, &
                           beta31,beta32,beta33, &
                           gamma1,gamma2,gamma3, &
                           delta1,delta2,delta3, &
                           tt, csi_s, eta_s, zeta_s, nofi, id_mpi,&
                           ipiu, imeno, toll1, toll2 , flag)

      implicit none

      integer*4 :: nofiter
      integer*4 :: per_csi, per_eta, per_zeta
      integer*4 ::  iic, il,ih
      integer*4, intent(out) :: tt
      integer*4, intent(in) :: nofi,id_mpi,ipiu,imeno, flag

      real*8 :: ll,lm ,xvt1,yvt1,xvt2,yvt2,xvc1,yvc1,xvc2,yvc2
      real*8 :: a1,a2,a3,b1,b2,b3,c1,c2,c3,d1,d2,d3
      real*8 :: e1,e2,e3,f1,f2,f3,g1,g2,g3,h1,h2,h3
      real*8 :: delta_csi, delta_eta, delta_zeta
      real*8 :: A,B,C,D,E,F,G,H,P, det
      real*8 :: a11, a12, a13, a21, a22, a23, a31, a32, a33
      real*8 :: FF1, FF2, FF3
      real*8 :: alfa11,alfa12,alfa13,alfa21,alfa22,alfa23,alfa31,alfa32,alfa33
      real*8 :: beta11,beta12,beta13,beta21,beta22,beta23,beta31,beta32,beta33
      real*8 :: gamma1,gamma2,gamma3,delta1,delta2,delta3
      real*8, intent(in) :: xnod, ynod, znod, toll1, toll2
      real*8, intent(out) ::  csi_s, eta_s, zeta_s

      a1 = 8.d0*gamma1
      a2 = 8.d0*gamma2
      a3 = 8.d0*gamma3
      b1 = 8.d0*beta13
      b2 = 8.d0*beta23
      b3 = 8.d0*beta33
      c1 = 8.d0*beta11
      c2 = 8.d0*beta21
      c3 = 8.d0*beta31
      d1 = 8.d0*beta12
      d2 = 8.d0*beta22
      d3 = 8.d0*beta32
      e1 = 8.d0*alfa11
      e2 = 8.d0*alfa21
      e3 = 8.d0*alfa31
      f1 = 8.d0*alfa12
      f2 = 8.d0*alfa22
      f3 = 8.d0*alfa32
      g1 = 8.d0*alfa13
      g2 = 8.d0*alfa23
      g3 = 8.d0*alfa33
      h1 = 8.d0*delta1
      h2 = 8.d0*delta2
      h3 = 8.d0*delta3

      csi_s = 0.d0
      eta_s = 0.d0
      zeta_s = 0.d0
      delta_csi = 0.0d0
      delta_eta = 0.0d0
      delta_zeta = 0.0d0

      tt = 0
      nofiter = 2000

      per_csi = 0
      per_eta = 0
      per_zeta = 0

      do il = 1, nofiter

        A = a1*eta_s*zeta_s + b1*eta_s + d1*zeta_s + e1
        B = a1*csi_s*zeta_s + b1*csi_s + c1*zeta_s + f1
        C = a1*csi_s*eta_s + c1*eta_s + d1*csi_s + g1

        D = a2*eta_s*zeta_s + b2*eta_s + d2*zeta_s + e2
        E = a2*csi_s*zeta_s + b2*csi_s + c2*zeta_s + f2
        F = a2*csi_s*eta_s + c2*eta_s + d2*csi_s + g2

        G = a3*eta_s*zeta_s + b3*eta_s + d3*zeta_s + e3
        H = a3*csi_s*zeta_s + b3*csi_s + c3*zeta_s + f3
        P = a3*csi_s*eta_s + c3*eta_s + d3*csi_s + g3

        det = A*(E*P - F*H) - B*(D*P - F*G) + C*(D*H -E*G)

        if(det .eq. 0.d0) then
          return
        endif

        a11 = E*P - F*H
        a12 = -D*P + F*G
        a13 = D*H - E*G
        a21 = -B*P + C*H
        a22 = A*P - C*G
        a23 = -A*H + B*G
        a31 = B*F - C*E
        a32 = -A*F + C*D
        a33 = A*E - B*D

        FF1 = a1*csi_s*eta_s*zeta_s + b1*csi_s*eta_s + c1*eta_s*zeta_s + d1*csi_s*zeta_s &
                                   + e1*csi_s + f1*eta_s + g1*zeta_s + h1 -8.d0*xnod

        FF2 = a2*csi_s*eta_s*zeta_s + b2*csi_s*eta_s + c2*eta_s*zeta_s + d2*csi_s*zeta_s &
                                   + e2*csi_s + f2*eta_s + g2*zeta_s + h2 -8.d0*ynod

        FF3 = a3*csi_s*eta_s*zeta_s + b3*csi_s*eta_s + c3*eta_s*zeta_s + d3*csi_s*zeta_s &
                                   + e3*csi_s + f3*eta_s + g3*zeta_s + h3 -8.d0*znod

        delta_csi = (-1.d0/det)*(a11*FF1 + a21*FF2 + a31*FF3)

        delta_eta = (-1.d0/det)*(a12*FF1 + a22*FF2 + a32*FF3)

        delta_zeta = (-1.d0/det)*(a13*FF1 + a23*FF2 + a33*FF3)

        if (abs(delta_csi).le. toll1 .and. abs(delta_eta).le. toll1 .and. abs(delta_zeta).le. toll1 ) then
            tt = 1

           if(flag.eq.1) then
              if (dabs(csi_s) .gt. toll2 .or. dabs(eta_s) .gt. toll2 .or. dabs(zeta_s).gt. toll2 ) then
              tt = 0
              return
            endif
          endif

          return
        endif

        csi_s = csi_s + delta_csi
        eta_s = eta_s + delta_eta
        zeta_s = zeta_s + delta_zeta

        if (csi_s .gt. 1.d0 .AND. csi_s .lt. 2.d0 .AND. per_csi .eq. 0) then
            csi_s = 1.d0
            per_csi = 1
        endif

        if (csi_s .lt. -1.d0 .AND. csi_s .gt. -2.d0 .AND. per_csi .eq. 0) then
            csi_s = -1.d0
            per_csi = 1
        endif

        if (eta_s .gt. 1.d0 .AND. eta_s .lt. 2.d0 .AND. per_eta .eq. 0) then
            eta_s = 1.d0
            per_eta = 1
        endif

        if (eta_s .lt. -1.d0 .AND. eta_s .gt. -2.d0 .AND. per_eta .eq. 0) then
            eta_s = -1.d0
            per_eta = 1
        endif

        if (zeta_s .gt. 1.d0 .AND. zeta_s .lt. 2.d0 .AND. per_zeta .eq. 0) then
            zeta_s = 1.d0
            per_zeta = 1
        endif

        if (zeta_s .lt. -1.d0 .AND. zeta_s .gt. -2.d0 .AND. per_zeta .eq. 0) then
            zeta_s = -1.d0
            per_zeta = 1
        endif

      enddo

      if(il .ge. nofiter) then
        tt = 0
        return
      endif

     end subroutine NEWTON_RAPSON