      SUBROUTINE MB04BZ( JOB, COMPQ, N, A, LDA, DE, LDDE, B, LDB, FG,
     $                   LDFG, 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 = (      H ) and H = (      H ).                           (1)
C           (  E  A  )         (  G -B  )
C
C     This routine computes the eigenvalues using an embedding to a real
C     skew-Hamiltonian/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             (                 |      T       T  )
C             (  Re(E)  -Im(E)  |  Re(A )  Im(A ) )
C             (                 |      T       T  )
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             (                 |      T       T  )
C             ( -Im(G)  -Re(G)  | -Im(B )  Re(B ) )
C             (                 |      T       T  )
C             (  Re(G)  -Im(G)  | -Re(B ) -Im(B ) )
C
C     Optionally, if JOB = 'T', the pencil aB_S - bB_H (B_H = -i*B_T) is
C     transformed by a unitary matrix Q to the structured Schur form
C
C                ( BA  BD  )              ( BB  BF  )
C       B_Sout = (       H ) and B_Hout = (       H ),               (3)
C                (  0  BA  )              (  0 -BB  )
C
C     where BA and BB are upper triangular, BD is skew-Hermitian, and
C     BF is Hermitian. The embedding doubles the multiplicities of the
C     eigenvalues of the pencil aS - bH. Optionally, if COMPQ = 'C', the
C     unitary matrix Q is computed.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     JOB     CHARACTER*1
C             Specifies the computation to be performed, as follows:
C             = 'E': compute the eigenvalues only; S and H will not
C                    necessarily be transformed as in (3).
C             = 'T': put S and H into the forms in (3) and return the
C                    eigenvalues in ALPHAR, ALPHAI and BETA.
C
C     COMPQ   CHARACTER*1
C             Specifies whether to compute the unitary transformation
C             matrix Q, as follows:
C             = 'N':  Q is not computed;
C             = 'C':  compute the unitary transformation matrix Q.
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, K)
C             where K = N/2, if JOB = 'E', and K = N, if JOB = 'T'.
C             On entry, the leading N/2-by-N/2 part of this array must
C             contain the matrix A.
C             On exit, if JOB = 'T', the leading N-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, but it is preserved.
C             If JOB = 'E', this array is unchanged on exit.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= MAX(1, K).
C
C     DE      (input/output) COMPLEX*16 array, dimension
C                            (LDDE, MIN(K+1,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 JOB = 'T', 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 JOB = 'E', this array is unchanged on exit.
C
C     LDDE    INTEGER
C             The leading dimension of the array DE.  LDDE >= MAX(1, K).
C
C     B       (input/output) COMPLEX*16 array, dimension (LDB, K)
C             On entry, the leading N/2-by-N/2 part of this array must
C             contain the matrix B.
C             On exit, if JOB = 'T', the leading N-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 JOB = 'E', this array is unchanged on exit.
C
C     LDB     INTEGER
C             The leading dimension of the array B.  LDB >= MAX(1, K).
C
C     FG      (input/output) COMPLEX*16 array, dimension
C                            (LDFG, MIN(K+1,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 JOB = 'T', 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 JOB = 'E', this array is unchanged on exit.
C
C     LDFG    INTEGER
C             The leading dimension of the array FG.  LDFG >= MAX(1, K).
C
C     Q       (output) COMPLEX*16 array, dimension (LDQ, 2*N)
C             On exit, if COMPQ = 'C', the leading 2*N-by-2*N part of
C             this array contains the unitary transformation matrix Q
C             that reduced the matrices B_S and B_H to the form in (3).
C             However, if JOB = 'E', the reduction was possibly not
C             completed: the matrix B_H may have 2-by-2 diagonal blocks,
C             and the array Q returns the orthogonal matrix that
C             performed the partial reduction.
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 (2*N+4)
C             On exit, IWORK(1) contains the number, q, of unreliable,
C             possibly inaccurate (pairs of) eigenvalues, and the
C             absolute values in IWORK(2), ..., IWORK(q+1) are their
C             indices, as well as of the corresponding 1-by-1 and 2-by-2
C             diagonal blocks of the arrays B and A on exit, if
C             JOB = 'T'. Specifically, a positive value is an index of
C             a real or purely imaginary eigenvalue, corresponding to a
C             1-by-1 block, while the absolute value of a negative entry
C             in IWORK is an index to the first eigenvalue in a pair of
C             consecutively stored eigenvalues, corresponding to a
C             2-by-2 block. Moreover, IWORK(q+2),..., IWORK(2*q+1)
C             contain pointers to the starting elements in DWORK where
C             each block pair is stored. Specifically, if IWORK(i+1) > 0
C             then DWORK(r) and DWORK(r+1) store corresponding diagonal
C             elements of T11 and S11, respectively, and if
C             IWORK(i+1) < 0, then DWORK(r:r+3) and DWORK(r+4:r+7) store
C             the elements of the block in T11 and S11, respectively
C             (see Section METHOD), where r = IWORK(q+1+i). Moreover,
C             IWORK(2*q+2) contains the number of the 1-by-1 blocks, and
C             IWORK(2*q+3) contains the number of the 2-by-2 blocks,
C             corresponding to unreliable eigenvalues. IWORK(2*q+4)
C             contains the total number t of the 2-by-2 blocks.
C             If INFO = 0, then q = 0, therefore IWORK(1) = 0.
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0 or INFO = 3, DWORK(1) returns the
C             optimal LDWORK, and DWORK(2) and DWORK(3) contain the
C             Frobenius norms of the matrices B_S and B_T. These norms
C             are used in the tests to decide that some eigenvalues are
C             considered as numerically unreliable. Moreover, DWORK(4),
C             ..., DWORK(3+2*s) contain the s pairs of values of the
C             1-by-1 diagonal elements of T11 and S11. The eigenvalue of
C             such a block pair is obtained from -i*T11(i,i)/S11(i,i).
C             Similarly, DWORK(4+2*s), ..., DWORK(3+2*s+8*t) contain the
C             t groups of pairs of 2-by-2 diagonal submatrices of T11
C             and S11, stored column-wise. The spectrum of such a block
C             pair is obtained from -i*ev, where ev are the eigenvalues
C             of (T11(i:i+1,i:i+1),S11(i:i+1,i:i+1)).
C             On exit, if INFO = -19, DWORK(1) returns the minimum value
C             of LDWORK.
C
C     LDWORK  INTEGER
C             The dimension of the array DWORK. If COMPQ = 'N',
C             LDWORK >= MAX( 3,  4*N*N + 3*N ), if   JOB = 'E';
C             LDWORK >= MAX( 3,  5*N*N + 3*N ), if   JOB = 'T';
C             LDWORK >= MAX( 3, 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 = -21, ZWORK(1) returns the minimum value
C             of LZWORK.
C
C     LZWORK  INTEGER
C             The dimension of the array ZWORK.
C             LZWORK >= 1,       if JOB = 'E'; otherwise,
C             LZWORK >= 6*N + 4, if COMPQ = 'N';
C             LZWORK >= 8*N + 4, if COMPQ = 'C'.
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 JOB = 'E';
C             LBWORK >= N, if JOB = 'T'.
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: 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     ~        T  T         (  S11  S12  )
C     B_S = J Q  J  B_S Q = (          T ) and
C                           (   0   S11  )
C
C     ~        T  T         (  T11  T12  )
C     B_T = J Q  J  B_T Q = (          T ),
C                           (   0   T11  )
C
C     where Q is real orthogonal, S11 is upper triangular, and T11 is
C     upper quasi-triangular. If JOB = 'T', then the matrices above are
C                                                        ~
C     further transformed so that the 2-by-2 blocks in i*B_T are split
C     into 1-by-1 blocks.  If COMPQ = 'C', the transformations are
C     accumulated in the unitary matrix Q.
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     The returned eigenvalues are those of the pencil (-i*T11,S11),
C     where i is the purely imaginary unit.
C
C     If JOB = 'E', the returned matrix T11 is quasi-triangular. Note
C     that the off-diagonal elements of the 2-by-2 blocks of S11 are
C     zero by construction.
C
C     If JOB = 'T', the returned eigenvalues correspond to the diagonal
C     elements of BB and BA.
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     V. Sima, Research Institute for Informatics, Bucharest, Romania,
C     Nov. 2011.
C
C     REVISIONS
C
C     V. Sima, July 2012, Sep. 2016, Nov. 2016, Apr. 2020.
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, THREE, ZERO
      PARAMETER          ( ONE = 1.0D+0, THREE = 3.0D+0, ZERO = 0.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, JOB
      INTEGER            INFO, LDA, LDB, LDDE, LDFG, LDQ, LDWORK,
     $                   LZWORK, N
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, LTRI, UNREL
      CHARACTER*14       CMPQ, JOBF
      INTEGER            I, I1, IA, IB, IDE, IEV, IFG, IQ, IQ2, IQB, IS,
     $                   IW, IW1, IWRK, J, J1, J2, JM1, JP2, K, L, M,
     $                   MINDB, MINDW, MINZW, N2, NB, NC, NN, OPTDW,
     $                   OPTZW
      DOUBLE PRECISION   NRMBS, NRMBT
      COMPLEX*16         TMP
C
C     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
C
C     .. External Subroutines ..
      EXTERNAL           DCOPY, DLACPY, DSCAL, MB04FD, XERBLA, ZGEMM,
     $                   ZGEQRF, ZHGEQZ, ZLACPY, ZSCAL
C
C     .. Intrinsic Functions ..
      INTRINSIC          DBLE, DCMPLX, DIMAG, INT, MAX, MIN, MOD
C
C     .. Executable Statements ..
C
C     Decode the input arguments.
C
      M     = N/2
      NN    = N*N
      N2    = 2*N
      LTRI  = LSAME( JOB,   'T' )
      LCMPQ = LSAME( COMPQ, 'C' )
C
      IF( LTRI ) THEN
         K = N
      ELSE
         K = M
      END IF
C
      IF( N.EQ.0 ) THEN
         MINDW = 3
         MINZW = 1
      ELSE IF( LCMPQ ) THEN
         MINDB =  8*NN + N2
         MINDW = 11*NN + N2
         MINZW =  8*N  + 4
      ELSE
         MINDB =  4*NN + N2
         IF( LTRI ) THEN
            MINDW = 5*NN + 3*N
         ELSE
            MINDW = 4*NN + 3*N
         END IF
         MINZW = 6*N + 4
      END IF
C
      LQUERY = LDWORK.EQ.-1 .OR. LZWORK.EQ.-1
C
C     Test the input arguments.
C
      INFO = 0
      IF( .NOT.( LSAME( JOB, 'E' ) .OR. LTRI ) ) THEN
         INFO = -1
      ELSE IF( .NOT.( LSAME( COMPQ, 'N' ) .OR. LCMPQ ) ) THEN
         INFO = -2
      ELSE IF( N.LT.0 .OR. MOD( N, 2 ).NE.0 ) THEN
         INFO = -3
      ELSE IF(  LDA.LT.MAX( 1, K ) ) THEN
         INFO = -5
      ELSE IF( LDDE.LT.MAX( 1, K ) ) THEN
         INFO = -7
      ELSE IF(  LDB.LT.MAX( 1, K ) ) THEN
         INFO = -9
      ELSE IF( LDFG.LT.MAX( 1, K ) ) THEN
         INFO = -11
      ELSE IF( LDQ.LT.1 .OR. ( LCMPQ .AND. LDQ.LT.N2 ) ) THEN
         INFO = -13
      ELSE IF( .NOT. LQUERY ) THEN
         IF( LDWORK.LT.MINDW ) THEN
            DWORK( 1 ) = MINDW
            INFO = -19
         ELSE IF( LZWORK.LT.MINZW ) THEN
            ZWORK( 1 ) = MINZW
            INFO = -21
         END IF
      END IF
C
      IF( INFO.NE.0) THEN
         CALL XERBLA( 'MB04BZ', -INFO )
         RETURN
      ELSE IF( N.GT.0 ) THEN
C
C        Compute optimal workspace.
C
         OPTZW = MINZW
         IF( LCMPQ ) THEN
            CMPQ = 'Initialize'
         ELSE
            CMPQ = 'No Computation'
         END IF
C
         IF( LTRI ) THEN
            JOBF = 'Triangularize'
            CALL ZGEQRF( N, N, ZWORK, N, ZWORK, ZWORK, -1, INFO )
            I  = INT( ZWORK( 1 ) )
            NB = MAX( I/N, 2 )
         ELSE
            JOBF = 'Eigenvalues'
         END IF
C
         IF( LQUERY ) THEN
            CALL MB04FD( JOBF, 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 ) ) )
            DWORK( 1 ) = OPTDW
            ZWORK( 1 ) = OPTZW
            RETURN
         END IF
      ELSE IF( LQUERY ) THEN
         DWORK( 1 ) = MINDW
         ZWORK( 1 ) = MINZW
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( N.EQ.0 ) THEN
         IWORK( 1 ) = 0
         DWORK( 1 ) = THREE
         DWORK( 2 ) = ZERO
         DWORK( 3 ) = ZERO
         ZWORK( 1 ) = CONE
         RETURN
      END IF
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 JOB = 'E' and COMPQ = 'N';
C             4*N*N + 2*N + max(3,N*N+N), if JOB = 'T' and COMPQ = 'N';
C            11*N*N + 2*N,                if               COMPQ = 'C'.
C     prefer larger.
C
      CALL MB04FD( JOBF, 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.1 ) THEN
         RETURN
      ELSE IF( INFO.EQ.2 ) THEN
         INFO = 3
      END IF
      OPTDW = MAX( MINDW, MINDB + INT( DWORK( IWRK ) ) )
      NRMBS = DWORK( IWRK+1 )
      NRMBT = DWORK( IWRK+2 )
C
C     Scale the eigenvalues.
C
      CALL DSCAL( N, -ONE, ALPHAI, 1 )
C
      IF( LCMPQ ) THEN
C
C        Set the transformation matrix.
C
         IW = IQ
         DO 180 J = 1, N2
            DO 170 I = 1, N2
               Q( I, J ) = DCMPLX( DWORK( IW ) )
               IW = IW + 1
  170       CONTINUE
  180    CONTINUE
      END IF
C
C     Count the numbers of pairs of diagonal 1-by-1 and 2-by-2 blocks of
C     B and A with possibly unreliable eigenvalues.
C
      I  = IWORK( 1 )
      IS = 0
      IW = 0
      DO 190 J = 1, I
         IF( IWORK( J+1 ).GT.0 ) THEN
            IS = IS + 1
         ELSE IF( IWORK( J+1 ).LT.0 ) THEN
            IW = IW + 1
         END IF
  190 CONTINUE
C
      I = 2*I + 2
      IWORK( I )   = IS
      IWORK( I+1 ) = IW
C
      IF( LTRI ) THEN
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 210 J = 1, N
            DO 200 I = 1, J
               A( I, J ) = DCMPLX( DWORK( IW ) )
               IW = IW + 1
  200       CONTINUE
            IW = IW + N - J
  210    CONTINUE
C
         IW = IDE + N
         DO 230 J = 1, N
            DO 220 I = 1, J - 1
               DE( I, J ) = DCMPLX( DWORK( IW ) )
               IW = IW + 1
  220       CONTINUE
            DE( J, J ) = CZERO
            IW = IW + N - J + 1
  230    CONTINUE
C
         IW = IB
         DO 250 J = 1, N
            DO 240 I = 1, MIN( J + 1, N )
               B( I, J ) = DCMPLX( DWORK( IW ) )
               IW = IW + 1
  240       CONTINUE
            IW = IW + N - J - 1
  250    CONTINUE
C
         IW = IFG + N
         DO 270 J = 1, N
            DO 260 I = 1, J - 1
               FG( I, J ) = DCMPLX( DWORK( IW ) )
               IW = IW + 1
  260       CONTINUE
            FG( J, J ) = CZERO
            IW = IW + N - J + 1
  270    CONTINUE
C
      END IF
C
C     Count the number of diagonal 2-by-2 blocks of B and A.
C
      I1 = 0
      I  = 1
C     WHILE( I.LT.N ) DO
  280 CONTINUE
      IF ( I.LT.N ) THEN
         IF( ALPHAR( I ).NE.ZERO .AND. BETA( I ).NE.ZERO .AND.
     $       ALPHAR( I ).NE.ZERO ) THEN
            I1 = I1 + 1
            I  = I  + 2
         ELSE
            I  = I  + 1
         END IF
         GO TO 280
      END IF
C     END WHILE 280
C
      I = 2*IWORK( 1 ) + 4
      IWORK( I ) = I1
C
C     Save in DWORK the pairs of diagonal 1-by-1 and 2-by-2 blocks of
C     B and A. Also, save in IWORK the pointers to the starting element
C     of each pair corresponding to unreliable eigenvalues.
C
      CALL DCOPY( N, DWORK( IA ), N+1, DWORK( IFG ), 1 )
      DWORK( 1 ) = OPTDW
      DWORK( 2 ) = NRMBS
      DWORK( 3 ) = NRMBT
C
      K  = 4
      I  = 1
      IW = IWORK( 1 )
      J  = 1
      L  = ( N - 2*I1 )*2 + K
C     WHILE( I.LE.N ) DO
  290 CONTINUE
      IF ( I.LE.N ) THEN
         IF ( J.LE.IW )
     $      UNREL = I.EQ.ABS( IWORK( J+1 ) )
         IF( ALPHAR( I ).NE.ZERO .AND. BETA( I ).NE.ZERO .AND.
     $       ALPHAI( I ).NE.ZERO ) THEN
            IF ( UNREL ) THEN
               J = J + 1
               IWORK( J+IW ) = L
               UNREL = .FALSE.
            END IF
            CALL DLACPY( 'Full', 2, 2, DWORK( IB+(I-1)*(N+1) ), N,
     $                   DWORK( L ), 2 )
            L = L + 4
            CALL DCOPY( 2, DWORK( IFG+I-1 ), 1, DWORK( L ), 3 )
            DWORK( L+1 ) = ZERO
            DWORK( L+2 ) = ZERO
            L = L + 4
            I = I + 2
         ELSE
            IF ( UNREL ) THEN
               J = J + 1
               IWORK( J+IW ) = K
               UNREL = .FALSE.
            END IF
            DWORK( K   ) = DWORK( IB+(I-1)*(N+1) )
            DWORK( K+1 ) = DWORK( IFG+I-1 )
            K = K + 2
            I = I + 1
         END IF
         GO TO 290
      END IF
C     END WHILE 290
C
      IF( .NOT.LTRI ) THEN
C
C        Return.
C
         ZWORK( 1 ) = OPTZW
         RETURN
      END IF
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, NB )
C     WHILE( J.LT.N ) DO
  300 CONTINUE
      IF( J.LT.N ) THEN
         IF( B( J+1, J ).NE.CZERO ) THEN
C
C           Triangularization step.
C           Complex workspace:    need   4*N + 6.
C           Real    workspace:    need   4*N + 5.
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( 4*N+4 ), IW )
            A( J+1, J ) = TMP
            IF( IW.GT.0 ) THEN
               INFO = 2
               RETURN
            END IF
C
C           Update A, DE, B, and FG.
C           Complex workspace:    need   6*N + 4.
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
            IF( LCMPQ ) THEN
C
C              Update Q.
C              Complex workspace:    need   8*N + 4.
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 )
            END IF
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
  310       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 310
            END IF
C           END WHILE 310
         END IF
         GO TO 300
      END IF
C     END WHILE 300
C
C     Scale B and FG by -i.
C
      DO 320 I = 1, N
         CALL ZSCAL( I, -CIMAG, B( 1, I ), 1 )
  320 CONTINUE
C
      DO 330 I = 1, N
         CALL ZSCAL( I, -CIMAG, FG( 1, I ), 1 )
  330 CONTINUE
C
      ZWORK( 1 ) = OPTZW
      RETURN
C *** Last line of MB04BZ ***
      END


!=======================================================================
!
      subroutine calll(x1,x2,y1,y2,dum,dum1,n1,n2,dipok,v1,v2,dv1d1,dv1d2,dv2d1,dv2d2)
      USE TIPrecision

IMPLICIT                        NONE

   ! Local variables.

INTEGER(4)                   :: nvar, istr,nok,nbad

REAL(DbKi)                   :: n1,n2,small,pi,pi2,r1,r2,rsq,z,x,thet1
REAL(DbKi)                   :: dipok, v1_t,v2_t, dv1d1_t,dv1d2_t,dv2d1_t,dv2d2_t
REAL(DbKi)                   :: v1,v2,dv1d1,dv1d2,dv2d1,dv2d2,x1,x2,y1,y2,dum,dum1

!
      small = 1.0D-12
      pi = dacos(-1.0d0)
      pi2 = 2.0d0*dacos(-1.0d0)
!      R1s = (x1-s1a)**2+(x2-s2a)**2
!      R2s = (x1-s1b)**2+(x2-s2b)**2
      r1 = (x1 - y1)
      r2 = (x2 - y2)
      rsq = r1**2+r2**2
      z = r1*n1+r2*n2
      x = r1*n2-r2*n1
      if(z.gt.small) then
        if(x.lt.small) then
          thet1 = datan(DBLE(z/x))+pi
        elseif(abs(x).le.small) then
          thet1 = 0.5d0*pi
        elseif(x.gt.small) then
          thet1 = datan(DBLE(z/x))
        endif
      elseif(abs(z).le.small) then
        if(x.lt.small) then
          thet1 = 0.0d0
        elseif(abs(x).le.small) then
          write(*,*) 'SHITA!'
          stop
        elseif(x.gt.small) then
!          write(*,*) 'SHITB!'
!          write(*,*) x1,x2,y1,y2
          thet1 = 0.0d0
!          stop
        endif
      else
        if(x.lt.small) then
          thet1 = datan(DBLE(z/x))-pi
        elseif(abs(x).le.small) then
          thet1 = -0.5d0*pi
        elseif(x.gt.small) then
          thet1 = datan(DBLE(z/x))
        endif
      endif
!
      dipok = -thet1/pi2
      v1_t =  z/pi2*(1.0d0/rsq)
      v2_t =  -1.0d0/pi2*(x/rsq)
      dv1d1_t = -z*x/(pi*rsq**2)
      dv1d2_t = (rsq-2.0d0*z**2)/(2.0d0*pi*rsq**2)
      dv2d1_t = dv1d2_t
      dv2d2_t = -dv1d1_t
      v1 = +n1*v2_t+n2*v1_t
      v2 =  n2*v2_t-n1*v1_t
      dv1d1 = n2**2*dv1d1_t+n1*n2*(dv1d2_t+dv2d1_t)+n1**2*dv2d2_t
      dv1d2 = n2**2*dv1d2_t-n1*n2*(dv1d1_t-dv2d2_t)-n1**2*dv2d1_t
      dv2d1 = n2**2*dv2d1_t-n1*n2*(dv1d1_t-dv2d2_t)-n1**2*dv1d2_t
      dv2d2 = n2**2*dv2d2_t-n1*n2*(dv1d2_t+dv2d1_t)+n1**2*dv1d1_t

      return
      end


C               N.B.S  APPLIED MATHEMATICS SERIES,
C                 PUBLICATION 55
C               SEE P 299, SERIES NUMBER 7.1.26
C               ACCURACY:  ERROR LT 1.5 X 10**(-7)
C
C               FOLLOWS IBM ERROR FUNCTION HANDLING--
C               I.E. ERF(-X) = -ERF(X)
C                    RANGE OF VALUES+  -1 TO +1
C
C
c       18-May-94       note! in call to DERF, "x" is NOT in
c                       units of standard deviations!  To get the
c                       integral of a Gaussian distribution out
c                       of this, divide "x" by sqrt(2.) !
c
c
c***********************************************
c
      real function derf(x)
c
c***********************************************
c
c    modified 3/22/96 by J. Dwyer for sdf_lister
c
      IMPLICIT REAL*8 (A-H,O-Z)
      XLC=X
      IF(XLC.LT.0.D0) XLC=-X
      T= 1.D0/(1.D0 + (0.3275911D0)*XLC)
      T2= T*T
      T3= T*T2
      T4= T*T3
      T5= T*T4
      EZX=DEXP(-XLC*XLC)
      DERF = 1.D0 -
     *             ((0.254829592D0)*T
     *            - (0.284496736D0)*T2
     *            + (1.421413741D0)*T3
     *            - (1.453152027D0)*T4
     *            + (1.061405429D0)*T5)*EZX
      IF(X.LT.0.D0) DERF=-DERF
      RETURN
      END     ! end derf


      SUBROUTINE svd_solve(m, n, mp, np, a, b, v, w, nw, small)
      USE stel_kinds
      IMPLICIT NONE
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER m, n, mp, np, nw
      REAL(rprec), DIMENSION(mp,np) :: a
      REAL(rprec), DIMENSION(n,n) :: v
      REAL(rprec), DIMENSION(n) :: w
      REAL(rprec), DIMENSION(m) :: b
      REAL(rprec) :: small
C-----------------------------------------------
C   L o c a l   P a r a m e t e r s
C-----------------------------------------------
!      REAL(rprec) :: small = 1.0e-10_dp
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER :: istat, i, j
      REAL(rprec), ALLOCATABLE :: u(:,:)
C-----------------------------------------------

c       Solves Matrix equation A * V = B for V using SVD method
c       Uses svd routines from numerical recipes
c       Prashant Valanju (Dec 1998) pvalanju@mail.utexas.edu

c       Almost same as SvdSolveB except this one finds
c       nw solutions V(:,i) by keeping i = 1 to nw vectors, where
c       nw is the number of vectors with nonzero weights > small

c       It also uses V internally for SVD decomposition to save space, so

c       Inputs:
c       A(M,N)   - Matrix with physical dimensions (Mp,Np)
c       B(M)     - R.H.S. of A X = B
c       M        - Number of rows of A to use
c       N        - Number of columns of A to use
c       Mp,Np    - Storage dimensions of A(Mp,Np)
c
c       Output:
c       nw      - number of vectors with normalized weights above small
c          Eventually, this will be the number of optimum weights
c          after we decide on a criterion for optimization
c       V(N,nw) - nw Solutions of A V = B, each a vector of length N
c          V(:N,iw) = solution with top iw weights kept
c          Physical dimensions of V are (N,N)
c       w(n)    - Weights in decreasing order
c

c  Allocate local arrays.
c  Note u(m,n) is enough because needed part of a(mp,np) is copied to
c  u(m,n), and a(mp,np) is never used directly. This saves space.
c  It is essential to USE a local u since svdcmp changes it

      ALLOCATE (u(m,n),  stat=istat)
      IF(istat.ne.0) STOP 'Stop: No memory in svd_nesc'

c.......................................
c  Initialize ALL to zero to wipe out effects of old CALL
      w(:n) = 0                                !Zero ALL weights
      DO j = 1, n
         u(:m,j) = a(:m,j)                  !Because U will be changed by svdcmp
         v(:n,j) = 0
      END DO

c  Do the SVD decomposition of a, i.e, of u into u, v and w
       CALL svdcmp (u, m, n, m, n, w, v)

c  Sort weights and matrices with DECREASING weights so w(1) is biggest
c  Permute weight w(i) AND column vectors U(*,i), V(*,i) at the same time
       CALL sortsvd (m, n, m, n, w, u, v)

c  Find nw = number of large weights (dcreasing ordered by sortsvd)
         DO nw = n, 1, -1          !Find first large weight and get out
            IF ( ABS(w(nw)/w(1)) .gt. small) EXIT
         END DO

c  Find nw solutions by successively adding up eigenvectors V
c     with correct weight given by (U(i) dot b)/w(i) in eq 14.3.17 (NR).
c  The coeff of ith vector V(i) is the dot product of the i-th column
c     of U with the rhs vector B, divided by w(i)
c  This does the svdbksb directly, faster than the NR svdbksub routine
c     and uses less memory due to the dual role of V
c  Note: any optimization scheme to find the 'best' nw will

c      First set the 1st vector with largest weight w(1)
       v(:n,1) = SUM(u(:m,1)*b(:m)) *v(:n,1) /w(1)
c      Next add the vectors with successive weights (in decreasing order)
         DO i = 2, nw
            j = i - 1
            v(:n,i) = v(:n,j) + SUM(u(:m,i)*b(:m)) *v(:n,i) / w(i)
         END DO
c................................................

      DEALLOCATE (u, stat=istat)

      END SUBROUTINE svd_solve


!===============================================================================
program CIJ_BandS_axes
!===============================================================================
! CIJ_BandS_axes reads constants from stdin, or from a file, and returns information
! about the tensor symmetry and the orientation of the symmetry axes, via the
! process described by Browaeys & Chvrot, GJI, 2004.

   use anisotropy_ajn

   implicit none

   logical :: all = .true., Xout = .false., iso = .false., hex = .false., &
      tet = .false., ort = .false., mon = .false., tri = .false., &
      read_file = .true., rotate = .false., symmetry = .false., sum = .false.
   real(8), dimension(6,6) :: C, Ciso, Chex, Ctet, Cort, Cmon, Ctri, CR
   real(8) :: rho, R(3,3), x1(3), x2(3), x3(3)
   character(len=500) :: file, arg, symm
   integer :: iostat, i, j

   call get_args

   if (read_file) then
      call CIJ_load(file, C, rho)
      C = C/rho
   else
      read(*,'(a)',iostat=iostat) arg
      if (iostat /= 0) call bad_read('')
      ! 36 ecs
      read(arg,*,iostat=iostat) C
      if (iostat > 0) call bad_read('36')
      if (iostat < 0) then ! EOF
         ! 21 ecs
         read(arg,*,iostat=iostat) ((C(i,j), j=i,6), i=1,6)
         if (iostat /= 0) call bad_read('21')
         do i=1,6; do j=i+1,6; C(j,i) = C(i,j); enddo; enddo
      endif
   endif

   ! Find symmetry and axes
   call CIJ_brow_chev_symm(C, CR=CR, R=R, symm=symm)
   x1 = R(:,1)
   x2 = R(:,2)
   x3 = R(:,3)

   ! If desired, rotate into optimum orientation before decomposing, otherwise leave
   if (rotate) C = CR

   call CIJ_brow_chev(C, Ciso, Chex, Ctet, Cort, Cmon, Ctri)

   if (all .or. symmetry) call write_symm(symm)

   if (.not.sum .and. any([all, iso, hex, tet, ort, mon, tri])) then
      if (all .or. iso) call write_C('Ciso:', Ciso)
      if (all .or. hex) call write_C('Chex:', Chex)
      if (all .or. tet) call write_C('Ctet:', Ctet)
      if (all .or. ort) call write_C('Cort:', Cort)
      if (all .or. mon) call write_C('Cmon:', Cmon)
      if (all .or. tri) call write_C('Ctri:', Ctri)
   endif

   if (sum) then
      C = 0._8
      if (all .or. iso) C = C + Ciso
      if (all .or. hex) C = C + Chex
      if (all .or. tet) C = C + Ctet
      if (all .or. ort) C = C + Cort
      if (all .or. mon) C = C + Cmon
      if (all .or. tri) C = C + Ctri
      call write_C('Csum:', C)
   endif

   if (all .or. Xout) call write_X(x1, x2, x3)

contains
   subroutine usage(help)
      logical, intent(in), optional :: help
      logical :: stdout
      integer :: lu
      stdout = .false.
      if (present(help)) stdout = help
      lu = 0
      if (stdout) lu = 6
      write(lu,'(a)') &
         'Usage: CIJ_BandS_axes (options) [file]', &
         'Return information about the symmetry and the symmetry axes of a tensor', &
         '   read from file <file> or from a list of Cij from stdin if <file> is "-".', &
         'The outputs are chosen as flags read on the command line and are printed', &
         '   prefaced by:', &
         '   Ciso, Chex, Ctet, Cort, Cmon, Ctri : Elastic constants from unrotated', &
         '                                        input tensor', &
         '   x1, x2, x3                         : Symmetry axes', &
         'Options:', &
         '   -a:  Return all information [default]', &
         '   -R:  Rotate elastic constants before decomposition', &
         '   -S:  Write only the sum of the desired terms (e.g., Ciso+Chex)', &
         '   -X:  Provide symmetry axes, in order x{1,2,3}, as cartesian unit vectors', &
         '   -i:  Return isotropic part', &
         '   -h:  Return hexagonal part', &
         '   -t:  Return tetragonal part', &
         '   -o:  Return orthorhombic part', &
         '   -m:  Return monoclinic part', &
         '   -r:  Return triclinic part', &
         '   -s:  Return symmetry name', &
         '   --help: Print this message'
      if (stdout) then
         stop
      else
         error stop
      endif
   end subroutine usage

   subroutine get_args
      integer :: iarg, narg, ichar
      narg = command_argument_count()
      if (narg < 1) call usage
      iarg = 1
      do while (iarg <= narg - 1)
         call get_command_argument(iarg, arg)
         if (arg == '--help') call usage(help=.true.)
         select case (arg(1:1))
            case ('-')
               ichar = 2
               do while (ichar <= len_trim(arg))
                  select case (arg(ichar:ichar))
                     case ('a'); all = .true.
                     case ('R'); rotate = .true.
                     case ('S'); sum = .true.
                     case ('X'); all = .false.; Xout = .true.
                     case ('i'); all = .false.; iso = .true.
                     case ('h'); all = .false.; hex = .true.
                     case ('t'); all = .false.; tet = .true.
                     case ('o'); all = .false.; ort = .true.
                     case ('m'); all = .false.; mon = .true.
                     case ('r'); all = .false.; tri = .true.
                     case ('s'); all = .false.; symmetry = .true.
                     case default; call usage
                  end select
                  ichar = ichar + 1
               enddo
            case default; call usage
         end select
         iarg = iarg + 1
      enddo
      call get_command_argument(narg, file)
      if (file == '-') read_file = .false.
      if (file == '--help') call usage(help=.true.)
   end subroutine get_args

   subroutine write_C(str, CC)
      character(len=*), intent(in) :: str
      real(8), intent(in) :: CC(6,6)
      write(*,'(a,36(1x,es14.7))') trim(str), CC
   end subroutine write_C

   subroutine write_X(xx1, xx2, xx3)
      real(8), intent(in), dimension(3) :: xx1, xx2, xx3
      write(*,'(a,3f10.6))') 'x1:', xx1, 'x2:', xx2, 'x3:', xx3
   end subroutine write_X

   subroutine write_symm(str)
      character(len=*), intent(in) :: str
      write(*,'(a)') 'Symmetry: ' // trim(str)
   end subroutine write_symm

   subroutine bad_read(str)
      character(len=*), intent(in) :: str
      write(0,'(a)') 'CIJ_BandS_axes: Error: Error reading ' // trim(str) // &
         ' ecs from stdin'
      error stop
   end subroutine bad_read
end program CIJ_BandS_axes
!-------------------------------------------------------------------------------


 SUBROUTINE rubber2d(pr,lb,model,stre,r1,r2,vec)

 ! calculates stiffness and stresses for rubber and elastomeric
 ! foam materials

 IMPLICIT NONE
 ! DUMMY arguments
 REAL(kind=8), INTENT(IN):: pr(12)    !(12) material constants
 REAL(kind=8), INTENT(IN OUT):: lb(3) !(3)  Principal stretches Eigenvalues of U
 INTEGER(kind=4), INTENT(IN OUT) :: model   !Model
                                    !1:      Arruda-Boyce
                                    !2:      Mooney-Rivlin
                                    !3:      Neo-Hooke
                                    !4:      Ogden (N=1)
                                    !5:      Ogden (N=2)
                                    !6:      Ogden (N=3)
                                    !7:      Polynomial (N=1)
                                    !8:      Polynomial (N=2)
                                    !9:      Polynomial (N=3)
                                    !10:     Reduced Polynomial (N=1)
                                    !11:     Reduced Polynomial (N=2)
                                    !12:     Reduced Polynomial (N=3)
                                    !13:     Van der Waals (not implemented yet)
                                    !14:     Yeoh
                                    !15:     Hyperfoam (N=1)
                                    !16:     Hyperfoam (N=2)
                                    !17:     Hyperfoam (N=3)
 REAL(kind=8), INTENT(OUT) :: stre(:)           !  2nd Piola-Kirchhoff stresses S11 S22 S12 S33
 REAL(kind=8), INTENT(IN):: r1,r2     ! first eigenvector in-plane components
 ! optional arguments
 REAL(kind=8), OPTIONAL, INTENT(OUT) :: vec(:)  !elasticity (stiffness) matrix in vector form

 ! Local variables
 REAL(kind=8)  ::      &
             lbg(3),lbb(3),  &    !principal strains of G U & U_bar
             bet(3),p, &     !Biot principal stresses and Kirchhoff press
             d(3,4),   &     ! first derivatives of invariants and auxiliar values
             dd(3,4),  &     ! second derivatives of invariants
             c(7),cc,  &     ! local elasticity matrix
             i1,i2,det,j3,j23,j32,aux,a1,a2,a3,a4,a5,i13,i23,det2, &  ! auxiliar terms
             r11,r22,r12,r1111,r2222,r1122,r1112,r1222 !,r(3,3),v(10)  !auxiliar rotation terms

 LOGICAL :: ci1, ci2     !  use first and second invariants

 INTEGER(kind=4) nterm,     & ! number of terms (sum) in the model
                 kode,      & ! model
                 i,j,k,l      ! index and pointers

 INTEGER(kind=4), PARAMETER :: ij(3,3) = (/ 1,0,0,4,2,0,5,6,3 /) !, &
        !kk(4,10) = (/1,1,1,1, 1,1,2,2, 1,1,1,2, 1,1,3,3, &
        !                      2,2,2,2, 2,2,1,2, 2,2,3,3, &
        !                               1,2,1,2, 1,2,3,3, &
        !                                        3,3,3,3  /)

 !initializes Flags
 ci1 = .TRUE.       !compute I1 invariant derivatives for model 1-3, 7-14
 ci2 = .FALSE.      !do NOT compute I2 derivatives but for model 2, 7-9
 kode  = model      !strain energy model
 SELECT CASE (kode)
 CASE (2)    !Mooney Rivlin
    ci2 = .TRUE.     !compute second invariant derivatives
 CASE (4:6)  !Ogden
    nterm = kode - 3 !number of terms to be considered
    ci1 = .FALSE.    !do not compute 1st invariant derivatives
 CASE (7:9)  !Polynomial
    nterm = kode - 6 !number of terms to be considered
    ci2 = .TRUE.     !compute second invariant derivatives
 CASE (10:12)!reduced polynomial
    nterm = kode - 9 !number of terms to be considered
 CASE (14)   !yeoh
    kode = 12        !reduced polynomial
    nterm = 3        !number of terms to be considered
 CASE (15:17) !hyperfoam (highly compressible)
    CALL runen2(' Hyperfoam not implemented yet')
    !nterm = kode - 14 !number of terms to be considered
 END SELECT

 lbg = lb**2                              !eigenvalues of C
 det = lb(1)*lb(2)*lb(3)                  !J
 det2 = det*det                           !J^2
 j23 = det2**(-1d0/3d0)                   ![J^(-1/3)]^2
 j3 = SQRT(j23)                           ![J^(-1/3)]
 lbb= lb*j3                               !deviatoric eigenvalues of U

 !  COMPUTE FIRST DERIVATIVES OF THE INVARIANTS IF NECESSARY
 IF( ci1 )THEN
   !   first derivatives of I1
   i1 =(lbg(1)+lbg(2)+lbg(3))*j23           !1st deviatoric invariant of G
   j32 = 2d0*j3    !2/j^(1/3)
   DO i=1,3
     d(i,3) = lbb(i)**2                       !lbb**2
     d(i,1) = j32*lbb(i)*(1d0-i1/3d0/d(i,3))  !I1,l1
   END DO
   IF( ci2 )THEN
     i2 =(lbg(1)*lbg(2)+lbg(1)*lbg(3)+lbg(2)*lbg(3))*j23**2 !2nd deviatoric invariant of G
     ! first derivatives of I2
     DO i=1,3
       d(i,2) = j32*lbb(i)*(i1 - d(i,3) - 2d0*i2/3d0/d(i,3))  !I2,l1
     END DO
   END IF
 END IF

 !  COMPUTE FIRST DERIVATIVE OF THE STRAIN FUNCTION ==> BET_I
 SELECT CASE (kode)
 CASE (1) !Arruda-Boyce
   ! pr(5) = Mu/5/lm^2,  pr(6) = Mu 11/350/lm^4,  pr(7) =Mu 19/1750/lm^6, ! pr(8) =Mu 519/134750/lm^8
   a1 = pr(4)+i1*(pr(5)+i1*(pr(6)+i1*(pr(7)+i1*pr(8)))) !Phi,I1
   bet = a1*d(:,1)         !principal Biot stresses
   ! pressure
   cc = 1d0/pr(3)              !inverse compresibility
   p = cc*(det2-1d0)           !kirchhoff pressure

 CASE (2) !Mooney-Rivlin
   a1 = pr(1)
   a2 = pr(2)
   bet = a1*d(:,1) + a2*d(:,2)  !principal Biot stresses
   ! pressure
   cc = 1d0/pr(3)             !inverse compresibility  & Phi,J,J
   p = cc*det*(det-1d0)       !kirchhoff pressure

 CASE (3) !Neo-Hookean
   a1 = pr(1)
   bet = a1*d(:,1)         !principal Biot stresses
   ! pressure
   cc = 1d0/pr(3)             !inverse compresibility  & Phi,J,J
   p = cc*det*(det-1d0)       !kirchhoff pressure

 CASE (4:6) !ogden
   bet = 0d0               !initializes diagonal stresses
   k = 1                                   !pointer to properties array
   DO j=1,nterm                            !for each term
     a1 = pr(k+1)                          !exponent alpha
     d(:,j) = lbb**a1           !l1^alpha_i
     d(j,4) = SUM(d(:,j))/3d0   !ap
     bet = bet + pr(k)*(d(:,j) - d(j,4))  !principal Kirchhoff stresses
     k = k+2                    !update pointer
   END DO
   bet = bet/lb                !principal Biot Stress
   ! pressure
   cc = 1d0/pr(10)            !inverse compresibility & Phi,J,J
   p = cc*det*(det-1d0)       !kirchhoff pressure

 CASE ( 7: 9) !polynomial model
   i13 = i1 - 3d0  !I1 -3
   i23 = i2 - 3d0  !I2 - 3
   a1 = pr(1)      !initializes Phi,I1
   a2 = pr(2)      !initializes Phi,I2
   ! for pressure
   aux = det - 1d0        !j-1
   a3 = aux*det*2d0       !2J*(J-1)
   p  = 1d0/pr(10)        !initializes pressure
   cc = p                 !initializes compresibility
   IF( nterm > 1 )THEN
     a1 = a1+2d0*pr(3)*i13 +     pr(4)*i23          !Phi,I1
     a2 = a2+    pr(4)*i13 + 2d0*pr(5)*i23          !Phi,I2
     aux = aux*aux               !(J-1)^2
     p  = p  + 2d0/pr(11)*aux    !pressure term
     cc = cc + 6d0/pr(11)*aux    !tangent compressibility
   END IF
   IF( nterm > 2 )THEN
     a1 = a1+3d0*pr(6)*i13*i13 +2d0*pr(7)*i13*i23+    pr(8)*i23*i23 !Phi,I1
     a2 = a2+    pr(7)*i13*i13 +    pr(8)*i13*i23+3d0*pr(9)*i23*i23 !Phi,I2
     aux = aux*aux               !(J-1)^4
     p  = p  +  3d0/pr(12)*aux   !pressure term
     cc = cc + 15d0/pr(12)*aux   !tangent compressibility
   END IF

   bet = a1*d(:,1) + a2*d(:,2) !principal Biot Stress

   p  = a3*p             !kirchhoff pressure
   cc = cc*2d0           !tangent compressibility

 CASE (10:12) !Reduced polynomial
   i13 = i1 - 3d0         !I1 -3
   a1  = pr(1)            !initializes Phi,I1
   ! for pressure
   aux = det - 1d0        !j-1
   a3 = aux*det*2d0       !2J*(J-1)
   p  = 1d0/pr(10)        !initializes pressure
   cc = p                 !initializes compresibility
   IF( nterm > 1 ) THEN
     a1 = a1 + 2d0*pr(3)*i13     !Phi,I1
     aux = aux*aux               !(J-1)^2
     p  = p  + 2d0/pr(11)*aux    !pressure term
     cc = cc + 6d0/pr(11)*aux    !tangent compressibility
   END IF
   IF( nterm > 2 ) THEN
     a1 = a1 + 3d0*pr(6)*i13**2  !Phi,I1
     aux = aux*aux               !(J-1)^4
     p  = p  +  3d0/pr(12)*aux   !pressure term
     cc = cc + 15d0/pr(12)*aux   !tangent compressibility
   END IF
   bet = a1*d(:,1)             !principal Biot Stress

   p  = a3*p             !kirchhoff pressure
   cc = cc*2d0           !tangent compressibility

 END SELECT

 !SECOND PIOLA KIRCHHOFF STRESS TENSOR
 DO i=1,3
  bet(i) = (bet(i)+p/lb(i))/lb(i)     ! S = [ Phid_i + (Li Phiv_i)/Li ]/Li
 END DO
 !bet = (bet+p/lb)/lb     ! S = [ Phid_i + (Li Phiv_i)/Li ]/Li

 r11 = r1*r1         !factors for stress and matrix computation
 r22 = r2*r2
 r12 = r1*r2

 !COMPUTE ELASTICITY MATRIX IN VECTOR FORM
 IF( PRESENT(vec) ) THEN  !to compute stiffness

   IF( ci1 )THEN
     ! Second Derivatives of First Invariant
     j32 = j32*j3/3d0     !2/3j^(2/3)
     DO i=1,3
       dd(i,i) = j32*(5d0/3d0*i1/d(i,3)-1d0)                    !I1,li,li
       DO j=i+1,3
         dd(i,j) = 2d0*j32/lbb(i)/lbb(j)*(i1/3d0-d(i,3)-d(j,3)) !I1,li,lj
       END DO
     END DO
     IF( ci2 )THEN
       !  Second Derivatives of Second Invariant
       DO i=1,3
         !d(i,4) = d(i,3)**2                                  !lbb(i)**4
         dd(i,4) = j32*(5d0*(d(i,3)-i1)+14d0/3d0*i2/d(i,3))   !I2,li,li
         DO j=i+1,3
           dd(j,i) = 4d0*j32*lbb(i)*lbb(j)* (1.5d0+d(i,3)/d(j,3)+d(j,3)/d(i,3)& !I2,li,lj
                   -(1d0/d(i,3)+1d0/d(j,3))*i1 + 2d0/3d0*i2/d(i,3)/d(j,3))
         END DO
       END DO
     END IF
   END IF

   ! compute second derivative of the distortion strain function ==> c(i)
   SELECT CASE (kode)

   CASE (1) !Arruda-Boyce
     a2 = pr(5)+i1*(2d0*pr(6)+i1*(3d0*pr(7)+i1*4d0*pr(8))) !Phi,I1,i2
     DO i=1,3
       c(i) = a1*dd(i,i) + a2*d(i,1)**2
       DO j=i+1,3
         c(ij(i,j)) = a1*dd(i,j) + a2*d(i,1)*d(j,1)
       END DO
     END DO
     cc = cc*(1d0+1d0/det2)    !Phi,J,J

   CASE (2) !Mooney-Rivlin

     DO i=1,3
       c(i) = a1*dd(i,i) + a2*dd(i,4)
       DO j=i+1,3
         c(ij(i,j)) = a1*dd(i,j) + a2*dd(j,i)
       END DO
     END DO

   CASE (3) !Neo-Hookean

     DO i=1,3
       c(i) = a1*dd(i,i)
       DO j=i+1,3
         c(ij(i,j)) = a1*dd(i,j)
       END DO
     END DO

   CASE (4:6) !ogden
     c  = 0d0                               !initializes
     k = 1                                  !initializes pointer
     DO j=1,nterm                            !for each term
       a1 = pr(k+1)/3d0                      !exponent alpha/3
       a2 = a1-1d0                           !alpha/3 -1
       a3 = a1+1d0                           !alpha/3 +1
       DO i=1,3
         c(i) = c(i)+pr(k)*(a2*d(i,j)+a3*d(j,4))
         DO l=i+1,3
           c(ij(i,l)) = c(ij(i,l)) - pr(k)*a1*(d(i,j)+d(l,j)-d(j,4))
         END DO
       END DO
       k = k+2
     END DO                                      !DS1/L1
     ! divide by lb(i)lb(j)
     DO i=1,3
       c(i) = c(i)/lbg(i)
       DO j=i+1,3
         c(ij(i,j)) = c(ij(i,j)) /lb(i)/lb(j)
       END DO
     END DO

   CASE ( 7: 9) !polynomial model
     a3 = 0           !Initializes Phi,I1,I1
     a4 = 0           !Initializes Phi,I1,I2 = Phi,I2,I1
     a5 = 0           !Initializes Phi,I22,I2
     IF( nterm > 1 )THEN
       a3 = 2d0*pr(3)    !Phi,I1,I1
       a4 =     pr(4)    !Phi,I1,I2 = Phi,I2,I1
       a5 = 2d0*pr(5)    !Phi,I22,I2
     END IF
     IF( nterm > 2 )THEN
       a3 = a3+6d0*pr(6)*i13 +2d0*pr(7)*i23  !Phi,I1,I1
       a4 = a4+2d0*pr(7)*i13 +2d0*pr(8)*i23  !Phi,I1,I2 = Phi,I2,I1
       a5 = a5+2d0*pr(8)*i13 +6d0*pr(9)*i23  !Phi,I22,I2
     END IF
     DO i=1,3
       c(i) = a1*dd(i,i) + a2*dd(i,4)             &
            + a3*d(i,1)**2 + 2d0*a4*d(i,1)*d(i,2) + a5*d(i,2)**2
       DO j=i+1,3
         c(ij(i,j)) = a1*dd(i,j) + a2*dd(j,i)     &
                    + a3*d(i,1)*d(j,1) + a4*(d(i,1)*d(j,2)+d(i,2)*d(j,1)) + a5*d(i,2)*d(j,2)
       END DO
     END DO

   CASE (10:12) !Reduced polynomial
     a3 = 0d0         !initializes Phi,I1,I1
     IF( nterm > 1 )THEN
       a3 = pr(3)*2d0     !Phi,I1,I1
     END IF
     IF( nterm > 2 )THEN
       a3 = a3 + pr(6)*6d0*i13  !Phi,I1,I1
     END IF
     DO i=1,3
       c(i) = a1*dd(i,i) + a3*d(i,1)**2
       DO j=i+1,3
         c(ij(i,j)) = a1*dd(i,j) + a3*d(i,1)*d(j,1)
       END DO
     END DO

   END SELECT

   ! from second derivative of strain function, compute elasticity matrix

   ! for pressure terms
   cc = det2*cc  !J^2 Phiv_JJ
   aux = cc+p    !J^2 Phiv_JJ + Jp

   DO i=1,3
     c(i) = (c(i) - bet(i) + cc/lbg(i))/lbg(i)                    !Diagonal terms DSi/Li
     DO j=i+1,3                                       !off-Diagonal terms
       c(ij(i,j)) = (c(ij(i,j)) + aux/lb(i)/lb(j) )/lb(i)/lb(j)   !DSi/Lj
     END DO
   END DO
   !          shear term 1-2
   IF( ABS((lb(1)-lb(2))/lb(1)) < 1e-8 )THEN      !equal eigenvalues
     c(7) = (c(1) - c(4))/2d0                   !DSij/DEij
   ELSE                                           !different eigenvalues
     c(7) = ( bet(1) - bet(2))/(lbg(1) - lbg(2))!DSij/DEij
   END IF

   ! Transform to global coordinates (21 terms)
   ! with the spectral decomposition  C(IJKL) = c(ijkl)*R(i,I)*R(j,J)*R(k,K)*R(l,L)
           !factors for matrix computation
   r1111 = r11*r11
   r2222 = r22*r22
   r1122 = r11*r22
   r1112 = r11*r12
   r1222 = r12*r22

   vec(1) = c(1)*r1111 + c(2)*r2222 + (c(4)+2d0*c(7))*r1122*2d0             !1,1,1,1
   vec(2) = (c(1)+c(2)-4d0*c(7))*r1122 + c(4)*(r1111+r2222)                 !1,1,2,2
   vec(3) = c(1)*r1112 - c(2)*r1222 - (c(4)+2d0*c(7))*(r1112-r1222)         !1,1,1,2
   vec(4) = c(5)*r11 + c(6)*r22                                             !1,1,3,3
   vec(5) = c(1)*r2222 + c(2)*r1111 + (c(4)+2d0*c(7))*r1122*2d0             !2,2,2,2
   vec(6) = c(1)*r1222 - c(2)*r1112 + (c(4)+2d0*c(7))*(r1112-r1222)         !2,2,1,2
   vec(7) = c(5)*r22 + c(6)*r11                                             !2,2,3,3
   vec(8) = (c(1)+c(2)-2d0*c(4))*r1122 + c(7)*(r1111+r2222-r1122*2d0)       !1,2,1,2
   vec(9) = (c(5)-c(6))*r12                                                 !1,2,3,3
   vec(10)= c(3)                                                            !3,3,3,3

   !  this is for test
   !r = RESHAPE( (/ r1,r2,0d0,-r2,r1,0d0,0d0,0d0,1d0 /),(/3,3/))
   !DO m=1,10
   !  i=kk(1,m) ; j=kk(2,m) ; k=kk(3,m) ; l=kk(4,m)  !index
   !  v(m) = c(1)*  r(i,1)*r(j,1)*r(k,1)*r(l,1)                                 &
   !       + c(2)*  r(i,2)*r(j,2)*r(k,2)*r(l,2)                                 &
   !       + c(3)*  r(i,3)*r(j,3)*r(k,3)*r(l,3)                                 &
   !       + c(4)* (r(i,1)*r(j,1)*r(k,2)*r(l,2) + r(i,2)*r(j,2)*r(k,1)*r(l,1) ) &
   !       + c(5)* (r(i,1)*r(j,1)*r(k,3)*r(l,3) + r(i,3)*r(j,3)*r(k,1)*r(l,1) ) &
   !       + c(6)* (r(i,2)*r(j,2)*r(k,3)*r(l,3) + r(i,3)*r(j,3)*r(k,2)*r(l,2) ) &
   !       + c(7)* (r(i,1)*r(j,2)* (r(k,1)*r(l,2) + r(k,2)*r(l,1)) +  &
   !                r(i,2)*r(j,1)* (r(k,2)*r(l,1) + r(k,1)*r(l,2)))
   !
   !END DO
   !WRITE(55,"(5e15.5)")v-vec
 ELSE
   ! store the stress vector (2nd Piola-Kirchhoff stress tensor)
   !Compute 3-D stresses with the spectral decomposition  R^T * Beta * R
   stre(1) = r11*bet(1) + r22*bet(2)    !(1,1)
   stre(2) = r22*bet(1) + r11*bet(2)    !(2,2)
   stre(3) = r12*(bet(1)-bet(2))        !(1,2)
   stre(4) = bet(3)                     !(3,3)

 END IF

 RETURN
 END SUBROUTINE rubber2d


PROGRAM mlpmn

! Code converted using TO_F90 by Alan Miller
! Date: 2004-06-28  Time: 12:58:12

!       ==========================================================
!       Purpose: This program computes the associated Legendre
!                functions Pmn(x) and their derivatives Pmn'(x)
!                using subroutine LPMN
!       Input :  x --- Argument of Pmn(x)
!                m --- Order of Pmn(x),  m = 0,1,2,...,n
!                n --- Degree of Pmn(x), n = 0,1,2,...,N
!       Output:  PM(m,n) --- Pmn(x)
!                PD(m,n) --- Pmn'(x)
!       Example: x = 0.50
!          Pmn(x):
!          m\n        1            2            3            4
!         --------------------------------------------------------
!           0      .500000     -.125000     -.437500     -.289063
!           1     -.866025    -1.299038     -.324760     1.353165
!           2      .000000     2.250000     5.625000     4.218750
!           3      .000000      .000000    -9.742786   -34.099750
!           4      .000000      .000000      .000000    59.062500

!          Pmn'(x):
!          m\n        1            2            3            4
!         --------------------------------------------------------
!           0     1.000000     1.500000      .375000    -1.562500
!           1      .577350    -1.732051    -6.278684    -5.773503
!           2      .000000    -3.000000     3.750000    33.750000
!           3      .000000      .000000    19.485572      .000000
!           4      .000000      .000000      .000000  -157.500000
!       ==========================================================

IMPLICIT DOUBLE PRECISION (p,x)
DIMENSION pm(0:100,0:100),pd(0:100,0:100)
WRITE(*,*)'  Please enter m, n and x'
!        READ(*,*) M,N,X
m=2
n=4
x=.5
WRITE(*,*)
WRITE(*,*)'  m     n      x          Pmn(x)         Pmn''(X)'
WRITE(*,*)' ---------------------------------------------------'
CALL lpmn(100,m,n,x,pm,pd)
DO  j=0,n
  WRITE(*,10)m,j,x,pm(m,j),pd(m,j)
END DO
10      FORMAT(1X,i3,3X,i3,3X,f5.1,2E17.8)
END PROGRAM mlpmn

SUBROUTINE lpmn(mm,m,n,x,pm,pd)

!       =====================================================
!       Purpose: Compute the associated Legendre functions
!                Pmn(x) and their derivatives Pmn'(x)
!       Input :  x  --- Argument of Pmn(x)
!                m  --- Order of Pmn(x),  m = 0,1,2,...,n
!                n  --- Degree of Pmn(x), n = 0,1,2,...,N
!                mm --- Physical dimension of PM and PD
!       Output:  PM(m,n) --- Pmn(x)
!                PD(m,n) --- Pmn'(x)
!       =====================================================

INTEGER, INTENT(IN OUT)                  :: mm
INTEGER, INTENT(IN)                      :: m
INTEGER, INTENT(IN)                      :: n
DOUBLE PRECISION, INTENT(IN)             :: x
DOUBLE PRECISION, INTENT(OUT)            :: pm(0:mm,0:n)
DOUBLE PRECISION, INTENT(OUT)            :: pd(0:mm,0:n)
IMPLICIT DOUBLE PRECISION (p,x)

DO  i=0,n
  DO  j=0,m
    pm(j,i)=0.0D0
    pd(j,i)=0.0D0
  END DO
END DO
pm(0,0)=1.0D0
IF (DABS(x) == 1.0D0) THEN
  DO  i=1,n
    pm(0,i)=x**i
    pd(0,i)=0.5D0*i*(i+1.0D0)*x**(i+1)
  END DO
  DO  j=1,n
    DO  i=1,m
      IF (i == 1) THEN
        pd(i,j)=1.0D+300
      ELSE IF (i == 2) THEN
        pd(i,j)=-0.25D0*(j+2)*(j+1)*j*(j-1)*x**(j+1)
      END IF
    END DO
  END DO
  RETURN
END IF
ls=1
IF (DABS(x) > 1.0D0) ls=-1
xq=DSQRT(ls*(1.0D0-x*x))
xs=ls*(1.0D0-x*x)
DO  i=1,m
  pm(i,i)=-ls*(2.0D0*i-1.0D0)*xq*pm(i-1,i-1)
END DO
DO  i=0,m
  pm(i,i+1)=(2.0D0*i+1.0D0)*x*pm(i,i)
END DO
DO  i=0,m
  DO  j=i+2,n
    pm(i,j)=((2.0D0*j-1.0D0)*x*pm(i,j-1)- (i+j-1.0D0)*pm(i,j-2))/(j-i)
  END DO
END DO
pd(0,0)=0.0D0
DO  j=1,n
  pd(0,j)=ls*j*(pm(0,j-1)-x*pm(0,j))/xs
END DO
DO  i=1,m
  DO  j=i,n
    pd(i,j)=ls*i*x*pm(i,j)/xs+(j+i) *(j-i+1.0D0)/xq*pm(i-1,j)
  END DO
END DO
RETURN
END SUBROUTINE lpmn


      PROGRAM LA_CGEEV_EXAMPLE

!  -- LAPACK95 EXAMPLE DRIVER ROUTINE (VERSION 1.0) --
!     UNI-C, DENMARK
!     DECEMBER, 1999
!
!  .. "Use Statements" ..
      USE LA_PRECISION, ONLY: WP => SP
      USE F95_LAPACK, ONLY: LA_GEEV
!  .. "Implicit Statement" ..
      IMPLICIT NONE
!  .. "Local Scalars" ..
      INTEGER :: I, J, INFO, N
      REAL(WP), ALLOCATABLE ::  WR(:), WI(:)
!  .. "Local Arrays" ..
      REAL(WP), ALLOCATABLE :: A(:,:)
      COMPLEX(WP), ALLOCATABLE :: AA(:,:), W(:), VL(:,:), VR(:,:)
!  .. "Intrinsic Functions" ..
      INTRINSIC  REAL, AIMAG, INT
!  .. "Executable Statements" ..
      WRITE (*,*) 'LA_GEEV Example Program Results'
      N = 5
      ALLOCATE( A(N,N), AA(N,N), W(N), WR(N), WI(N), VL(N,N), VR(N,N) )

      OPEN(UNIT=21,FILE='geev1.ma',STATUS='UNKNOWN')
      DO I=1,N
         DO J=1,N
            READ(21,*) A(I,J)
         ENDDO
      ENDDO
      CLOSE(21)

      WRITE(*,*)'Matrix A:'
      DO I=1,N
         WRITE(*,"(5(I3,1X))") INT(A(I,:))
      ENDDO

      WRITE(*,*) "CALL LA_GEEV( A, WR, WI ) "
      CALL LA_GEEV( A, WR, WI )

      WRITE(*,*) 'WR on exit : '
      DO I=1,N
         WRITE(*,"((F9.6,1X))") REAL(WR(I))
      ENDDO

      WRITE(*,*) 'WI on exit : '
      DO I=1,N
         WRITE(*,"((F9.5,1X))") REAL(WI(I))
      ENDDO

      WRITE(*,*)
      WRITE(*,*) ' * EXAMPLE 2 * '

      OPEN(UNIT=21,FILE='geev.ma',STATUS='UNKNOWN')
      DO I=1,N
         DO J=1,N
            READ(21,*) AA(I,J)
         ENDDO
      ENDDO
      CLOSE(21)

      WRITE(*,*)'Matrix A : '
      DO J=1,N
         WRITE(*,"(5(I3,1X,'+',I3,'i',1X,1X,1X))") INT(AA(J,1)),INT(AIMAG(AA(J,1))), &
              INT(AA(J,2)),INT(AIMAG(AA(J,2))), &
              INT(AA(J,3)),INT(AIMAG(AA(J,3))), &
              INT(AA(J,4)),INT(AIMAG(AA(J,4))), &
              INT(AA(J,5)),INT(AIMAG(AA(J,5)))
      ENDDO

      WRITE(*,*) "CALL LA_GEEV( A, W, VL, VR, INFO )"
      CALL LA_GEEV( AA, W, VL, VR, INFO )

      WRITE(*,*) ' W on exit : '
      DO I=1,N;
         WRITE(*,"('('E14.7,1X,',',1X,E14.7,')',1X)")  W(I)
      ENDDO

      WRITE(*,*)' VL on exit : '
      DO I=1,N;
         WRITE(*,"(5('('E14.7,1X,',',1X,E14.7,')',1X))")  VL(I,:)
      ENDDO;

      WRITE(*,*) ' VR on exit : '
      DO I=1,N;
         WRITE(*,"(5('('E14.7,1X,',',1X,E14.7,')',1X))")  VR(I,:)
      ENDDO;

      WRITE(*,*) ' INFO = ', INFO
      DEALLOCATE( A, AA, VL, VR )

      END PROGRAM LA_CGEEV_EXAMPLE


module linalg
  use iso_fortran_env, only: wp => real64
  implicit none

  public  :: linsolve_quick, linsolve

contains
  subroutine linsolve_quick(n, a, nrhs, b, x)

    ! Quick wrapper around linsolve

    integer,  intent(in)                          :: n, nrhs
    real(wp), intent(in),     dimension(n, n)     :: a
    real(wp), intent(in),     dimension(n, nrhs)  :: b
    real(wp), intent(out),    dimension(n, nrhs)  :: x

    integer,                  dimension(n)        :: P
    real(wp),                 dimension(n, n)     :: LU

    call linsolve (n, a, nrhs, b, x, LU, P, .False.)
    return
  end subroutine linsolve_quick

  subroutine linsolve (n, a, nrhs, b, x, LU, P, toggle)
    ! This routine is a wrapper dgesv, splitting it into its two primary
    ! components:
    !             dgetrf - Decomposes A into P*L*U
    !             dgetrs - Uses P*L*U to solve for x (Ax=b => (P*L*U)x=b)
    !
    ! Splitting these two up like this allows you to save the decomposed
    ! version of 'a' so that you don't have to do it again. If 'toggle' is
    ! equal to true, then the decomposition has already occured and LU can be
    ! trusted - OK to skip dgetrf

    ! Dummy variables
    integer,  intent(in)                          :: n, nrhs
    integer,  intent(inout),  dimension(n)        :: P
    real(wp), intent(in),     dimension(n, nrhs)  :: b
    real(wp), intent(in),     dimension(n, n)     :: a
    real(wp), intent(out),    dimension(n, nrhs)  :: x
    real(wp), intent(inout),  dimension(n, n)     :: LU
    logical,  intent(in)                          :: toggle

    ! Local variables
    integer                                       :: info
    integer,                  dimension(n)        :: my_P
    real(wp),                 dimension(n, n)     :: my_a
    real(wp),                 dimension(n, nrhs)  :: my_b

    my_a = a
    my_b = b

    if ( .not. toggle ) then
      call dgetrf (n, n, my_a, n, my_P, info)

      if ( info /= 0 ) then
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'DGETRF'
        write ( *, '(a,i8)' ) '  Factorization failed, INFO = ', info
        stop
      end if

      LU  = my_a
      P   = my_P

    end if

    call dgetrs ('No transpose', n, nrhs, LU, n, P, my_b, n, info)

    if ( info /= 0 ) then
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'DGETRS'
      write ( *, '(a,i8)' ) '  Back substitution failed, INFO = ', info
      stop
    end if

    x = my_b

    return
  end subroutine linsolve
end module linalg


module integrator
    implicit none

contains
    function verlet_step(f, x0, x1, dt) result(xn)
        interface
            function f(x) result(ddx)
                real(8), dimension(:), intent(in) :: x
                real(8), dimension(size(x)) :: ddx
            end function
        end interface
        real(8), dimension(:), intent(in) :: x0, x1
        real(8), intent(in) :: dt
        real(8), dimension(size(x0)) :: xn
        xn = 2d0 * x1 - x0 + dt**2 * f(x1)
        return
    end function
end module integrator

program main
    use ogpf
    use integrator, only: verlet_step
    implicit none

    type(gpf) :: gp
    integer, parameter :: steps = 9733
    real(8), parameter :: mu = 2d0
    real(8), dimension(2) :: x0, x1
    real(8), dimension(2, steps) :: xn
    integer :: i
    real(8) :: dt, t
    x0 = [1d0, 1d0]
    x1 = [1.05d0, 1d0]
    dt = .05d0
    t = 0d0

    ! call gp%animation_start(1)
    call gp%axis([-2d0, 2d0, -2d0, 2d0])

    do i=1, steps
        xn(:,i) = verlet_step(f, x0, x1, dt)
        x0 = x1
        x1 = xn(:,i)
        t = t + dt
        ! if (mod(100, i) == 0) then
        !     call gp%plot(xn(1,:i), xn(2,:i), 'w lines lc "blue" lw 1')
        !     ! call gp%plot(xn(1,i:i), xn(2,i:i), 'w points ps 2 lc "red"')
        ! end if
    end do

    call gp%plot(xn(1,:), xn(2,:), 'w lines lc "blue" lw 1')
    ! call gp%animation_show()

contains
    function f(x) result(ddx)
        real(8), dimension(:), intent(in) :: x
        real(8), dimension(size(x)) :: ddx
        ddx = -mu * x / sum(x**2)**(3d0/2d0)
        return
    end function
end program


! Example to debug
program main

    implicit none
    real(kind=8), dimension(6) :: v

    v = (/1, 2, 3, 5, 6, 7/)

    write(*,'(a, f10.7)') 'Self-written routine: ', norm(v)
    write(*,'(a, 3x, f10.7)') 'Intrinsic routine: ', norm2(v)
    write(*,'(a, 10x, f10.7)') 'Difference: ', norm2(v) - norm(v)

contains

    pure function norm(vector) result(res)
        real(kind=8), dimension(:), intent(in) :: vector
        real(kind=8) :: res
        integer :: i

        res = 0
        do i = 1, size(vector), 2
            res = res + vector(i) ** 2
        end do

        res = sqrt(res)

    end function norm

end program main


submodule(euler_interface_m) euler_prob_0044_m
    implicit none
    integer(int64), parameter :: dim_of_arr = 3000_int64
    integer(int64) :: pen_arr(dim_of_arr)

contains

    module character(len=20) function euler0044()
        write (euler0044, "(i20)") ans()
    end function euler0044

    integer(int64) function ans()
        integer(int64) :: i, j, minimised_d
        integer(int64) :: pm, pn

        j = 1_int64
        i = 1_int64

        do while (i <= dim_of_arr)
            if (is_pen(j)) then
                pen_arr(i) = j
                i = i + 1_int64
            end if
            j = j + 1_int64
        end do

        ! set minimised_d to a big number
        minimised_d = huge(0_int64)

        do i = 1_int64, dim_of_arr
            do j = i + 1_int64, dim_of_arr
                pm = pen_arr(i)
                pn = pen_arr(j)
                if (is_pen_sum_diff(pm, pn)) then
                    minimised_d = min(minimised_d, pn - pm)
                end if
            end do
        end do

        ans = minimised_d
    end function ans

    logical function is_pen_sum_diff(pj, pk)
        integer(int64), intent(in) :: pj, pk
        integer(int64) :: s, d

        if (pj > pk) then
            error stop "is_pen_SUM_DIFF: pj < pk"
        end if

        s = pj + pk
        d = pk - pj

        if (is_pen(s) .and. is_pen(d)) then
            is_pen_sum_diff = .true.
        else
            is_pen_sum_diff = .false.
        end if
    end function is_pen_sum_diff

    logical function is_pen(p)
        integer(int64), intent(in) :: p

        if (p <= 0) then
            error stop "is_pen: p > 0."
        end if

        associate (x => sqrt(24.0_sp*real(p) + 1.0_sp))
            if (is_int(x) .and. mod(int(x, int64), 6_int64) == 5_int64) then
                is_pen = .true.
            else
                is_pen = .false.
            end if
        end associate
    end function is_pen

    logical function is_int(n)
        real, intent(in) :: n

        is_int = .false.
        if (n - floor(n) <= tiny_sp) then
            is_int = .true.
        end if
    end function is_int

end submodule euler_prob_0044_m


module boundary

  implicit none

contains

subroutine boundarypsi(psi, m, n, b, h, w)

  integer :: m, n, b, h, w

  double precision, dimension(0:m+1, 0:n+1) :: psi

  integer :: i, j

!  Set the boundary conditions on the bottom edge

  do i = b+1, b+w-1
     psi(i, 0) = float(i-b)
  end do

  do i = b+w, m
     psi(i, 0) = float(w)
  end do

  !  Set the boundary conditions on the right hand side

  do j = 1, h

     psi(m+1,j) = float(w)

  end do

  do j = h+1, h+w-1

     psi(m+1,j) = float(w-j+h)

  end do

end subroutine boundarypsi

subroutine boundaryzet(zet, psi, m, n)

  integer :: m, n

  double precision, dimension(0:m+1, 0:n+1) :: zet, psi

  integer :: i, j

! Set the zeta boundary conditions which depend on psi

  do j = 1, n

     zet(0,  j) = 2.0*(psi(1,j) - psi(0,  j))
     zet(m+1,j) = 2.0*(psi(m,j) - psi(m+1,j))

  end do

  do i = 1, m
     zet(i,0) = 2.0*(psi(i,  1)-psi(i,0))
  end do

  do i = 1, m
     zet(i,n+1) = 2.0*(psi(i,n)-psi(i,n+1))
  end do

end subroutine boundaryzet

end module boundary


C 	Copyright restrictions apply - see stsdas$copyright.stsdas
C
        SUBROUTINE YCLCPL (RS, RP, PSIRAD, NLPMAT, ISTAT)
*
*  Module number:
*
*  Module name: YCLCPL
*
*  Keyphrase:
*  ----------
*       Polarimetry processing
*
*  Description:
*  ------------
*       Creates Mueller Matrix for Polarizer
*
*  FORTRAN name: YCLCPL
*
*  Keywords of accessed files and tables:
*  --------------------------------------
*       none
*
*  Subroutines Called:
*  -------------------
*  CDBS:
*
*  SDAS:
*
*
*  History:
*  --------
*  Version      Date    Author		  Description
*       1       Mar97   M.D. De La Pena   Original Implementation for CALFOS
*                                         based upon code from R. Allen.
*-------------------------------------------------------------------------------
*
* INPUTS:
*       RS - Reflectivity perpendicular to the plane of incidence
*       RP - Reflectivity parallel to the plane of incidence
*       PSIRAD - Polarizing axis
*
* INPUT/OUTPUT:
*       NLPMAT - Mueller matrix for the polarizer
*       ISTAT  - Modified return status
*----------------------------------------------------------------------------
C
C Passed Parameters
C RS=1.0 and RP=0.0 for a perfect polarizer
C
      DOUBLE PRECISION RS, RP, PSIRAD, NLPMAT(4,4)
      INTEGER ISTAT
C
C Local Variables
C
      DOUBLE PRECISION C2, S2, RSADRP, RSSURP, RSMURP
      DOUBLE PRECISION DHALF, DZERO, DTWO
C
      PARAMETER (DZERO = 0.0D0)
      PARAMETER (DHALF = 0.5D0)
      PARAMETER (DTWO  = 2.0D0)
C
C----------------------------------------------------------------------------
C
      C2 = DCOS(DTWO * PSIRAD)
      S2 = DSIN(DTWO * PSIRAD)
C
C Define arithmetic relationships used multiple times
C
      RSADRP = RS + RP
      RSMURP = RS * RP
      RSSURP = RS - RP
C
C Fill the matrix
C
      NLPMAT(1,1) = DHALF * RSADRP
      NLPMAT(1,2) = DHALF * C2 * RSSURP
      NLPMAT(1,3) = DHALF * S2 * RSSURP
      NLPMAT(1,4) = DZERO
      NLPMAT(2,1) = NLPMAT(1,2)
      NLPMAT(2,2) = DHALF * C2 * C2 * RSADRP + S2 * S2 * DSQRT(RSMURP)
      NLPMAT(2,3) = DHALF * C2 * S2 * RSADRP - S2 * C2 * DSQRT(RSMURP)
      NLPMAT(2,4) = DZERO
      NLPMAT(3,1) = NLPMAT(1,3)
      NLPMAT(3,2) = NLPMAT(2,3)
      NLPMAT(3,3) = DHALF * S2 * S2 * RSADRP + C2 * C2 * DSQRT(RSMURP)
      NLPMAT(3,4) = DZERO
      NLPMAT(4,1) = DZERO
      NLPMAT(4,2) = DZERO
      NLPMAT(4,3) = DZERO
      NLPMAT(4,4) = DSQRT(RSMURP)
C
      ISTAT = 0
      RETURN
      END


!*****************************************************************************************
!> author: Jacob Williams
!
!  Propagate a state using the various kepler methods and compare.

    program kepler_tests

    use kind_module,    only: wp
    use gooding_module
    use kepler_module
    use conversion_module
    use random_module
    use numbers_module

    implicit none

    real(wp),parameter :: dt1 = 0.74060940549140621E+06_wp !! time step (sec)
    real(wp),dimension(6),parameter :: rv1 = [  0.14624621707935020E+06_wp,&
                                                -0.20413097635909508E+04_wp,&
                                                -0.13806223844513239E+06_wp,&
                                                0.82912050920300651E+00_wp,&
                                                0.10284105194164532E+01_wp,&
                                                -0.19717889495193228E+01_wp ] !! initial state [km,km/s]

    logical,parameter :: run_all = .true.  !! run the full set of tests
    real(wp),parameter :: mu = 398600.0_wp !! Earth grav param.
    integer,parameter :: n_cases = 10000   !! number of cases to run
    integer,parameter :: n_methods = 4 !! number of kepler methods to test
    character(len=*),dimension(n_methods),parameter :: methods = ['gooding  ',&
                                                                  'shepperd ',&
                                                                  'goodyear ',&
                                                                  'classical'] !! method names

    integer :: i  !! counter
    real(wp) :: alpha,rp,inc,raan,w,tau,sma,per,dt
    real(wp),dimension(6) :: rv  !! cartesian state
    real(wp),dimension(6) :: e   !! universal elements
    real(wp),dimension(6) :: err !! state error estimate
    real(wp),dimension(n_methods,n_cases) :: pos_err,vel_err
    integer,dimension(n_methods,n_cases) :: istats
    integer :: imethod,istat

    pos_err = zero
    vel_err = zero
    istats  = 0

    write(*,*) ''
    write(*,*) '---------------'
    write(*,*) ' kepler_tests'
    write(*,*) '---------------'
    write(*,*) ''

    write(*,*) ''
    write(*,*) ' Unusual case ...'
    write(*,*) ''
    do imethod = 1,n_methods
        call prop_error(rv1,dt1,imethod,err,istat)
        write(*,'(A,1X,6(E30.17,1X),I5)') trim(methods(imethod))//' err:  ', err, istat
    end do
    write(*,*) ''

    if (run_all) then

        write(*,*) ''
        write(*,*) ' All cases ...'
        write(*,*) ''

        do i = 1, n_cases

            ! get random elements:
            rp = get_random_number(7000.0_wp,100000.0_wp)
            if (get_random_number(0.0_wp,1.0_wp)>0.5_wp) then
                ! ellipse
                sma = get_random_number(rp, 1000000.0_wp)
                per = twopi*sqrt(sma**3/mu)
                tau = get_random_number(0.0_wp,per)
                dt = get_random_number(0.0_wp,per)
            else
                ! hyperbola
                sma = get_random_number(-1000000.0_wp,-rp)
                tau = get_random_number(0.0_wp,10.0_wp) * day2sec
                dt = get_random_number(0.0_wp,10.0_wp) * day2sec
            end if
            alpha = mu / sma
            ! add a specific test for a parabola (a=0)
            if (i==n_cases) then  ! the last one
                alpha = zero
            end if
            inc   = get_random_number(0.0_wp, pi)
            raan  = get_random_number(0.0_wp, twopi)
            w     = get_random_number(0.0_wp, twopi)

            e = [alpha,rp,inc,raan,w,tau]

            call els3pv (mu, e, rv)

            do imethod = 1,n_methods
                call prop_error(rv,dt,imethod,err,istats(imethod,i))
                pos_err(imethod,i) = norm2(err(1:3))
                vel_err(imethod,i) = norm2(err(4:6))

                if (istats(imethod,i) /= 0 .or. pos_err(imethod,i)>one .or. vel_err(imethod,i)>one) then
                    write(*,*) ''
                    write(*,*) 'error for method: '//trim(methods(imethod))
                    write(*,*) 'i: ', i
                    write(*,'(A,1X,I6)')           'istat   =', istats(imethod,i)
                    write(*,'(A,1X,*(E30.16,1X))') 'e       =',e
                    write(*,'(A,1X,*(E30.16,1X))') 'pos err =',err(1:3)
                    write(*,'(A,1X,*(E30.16,1X))') 'vel err =',err(4:6)
                    write(*,*) ''
                    write(*,'(A,1X,*(E30.17,1X))') 'rv   (km,km/s) = ',rv
                    write(*,'(A,1X,*(E30.17))')    'dt (sec)       = ', dt
                    if (e(1)/=zero) write(*,'(A,1X,*(E30.17))')    'sma  (km)      = ', mu / e(1)
                    write(*,'(A,1X,*(E30.17))')    'rp   (km)      = ', e(2)
                    write(*,'(A,1X,*(E30.17))')    'inc  (deg)     = ', e(3) * rad2deg
                    write(*,'(A,1X,*(E30.17))')    'raan (deg)     = ', e(4) * rad2deg
                    write(*,'(A,1X,*(E30.17))')    'w    (deg)     = ', e(5) * rad2deg
                    write(*,'(A,1X,*(E30.17))')    'tau  (days)    = ', e(6) * sec2day
                    write(*,*) ''
                    !stop
                end if

            end do

        end do

        ! results:
        write(*,*) ''
        write(*,*) '-------------------'
        do imethod = 1,n_methods
            do i = 1, n_cases
                if (istats(imethod,i)/=0) &
                    write(*,'(A,E30.16,1X,I5)') trim(methods(imethod))//' pos error: ', pos_err(imethod,i), istats(imethod,i)
            end do
            write(*,*) ''
        end do
        do imethod = 1,n_methods
            do i = 1, n_cases
                if (istats(imethod,i)/=0) &
                    write(*,'(A,E30.16,1X,I5)') trim(methods(imethod))//' vel error: ', vel_err(imethod,i), istats(imethod,i)
            end do
            write(*,*) ''
        end do
        write(*,*) '-------------------'
        write(*,*) ''

        write(*,*) ''
        write(*,*) 'summary'
        do imethod = 1,n_methods
            write(*,*) '-------------------'
            write(*,'(A,E30.16)') trim(methods(imethod))//' max pos error: ', maxval(abs(pos_err(imethod,:)))
            write(*,'(A,E30.16)') trim(methods(imethod))//' max vel error: ', maxval(abs(vel_err(imethod,:)))
            write(*,*) '-------------------'
        end do
        write(*,*) ''

    end if

    contains

        subroutine prop_error(x0,dt,imethod,xerr,istat)

        !! propagate the state forward the backwards, and return
        !! the error vector.

        implicit none

        real(wp),dimension(6),intent(in)  :: x0
        real(wp),intent(in)               :: dt
        integer,intent(in)                :: imethod
        real(wp),dimension(6),intent(out) :: xerr
        integer,intent(out)               :: istat

        real(wp),dimension(6) :: rv2,rv3,rv4

        real(wp),parameter :: tol = 1.0e-15_wp !! tolerance for goodyear

        istat = 0

        select case (imethod)
        case(1)
            call propagate(mu,x0,dt,rv2)
            call propagate(mu,rv2,-dt,rv3)
        case(2)
            call kepler_shepperd(mu,x0,dt,rv2,istat)
            call kepler_shepperd(mu,rv2,-dt,rv3,istat)
        case(3)
            call kepler_goodyear_stienon_klumpp(x0,dt,mu,tol,rv2)
            call kepler_goodyear_stienon_klumpp(rv2,-dt,mu,tol,rv3)
        case(4)
            call kepler_classical(x0,dt,mu,rv2)
            call kepler_classical(rv2,-dt,mu,rv3)
        case default
            error stop 'invalid method'
        end select

        xerr = rv3 - x0

        end subroutine prop_error

    end program kepler_tests
!*****************************************************************************************


MODULE MODULE_COM

CONTAINS

  FUNCTION GEOMETRICAL_CENTER(coors, atoms_indices_serialized, atoms_series_starts, frame_indices,&
                              n_frames, n_atoms, n_atoms_indices, n_atoms_series, n_frame_indices) RESULT(center)

    IMPLICIT NONE

    INTEGER,INTENT(IN)::n_frames, n_atoms, n_atoms_indices, n_atoms_series, n_frame_indices
    DOUBLE PRECISION,DIMENSION(n_frames,n_atoms,3),INTENT(IN)::coors
    INTEGER,DIMENSION(n_atoms_indices),INTENT(IN)::atoms_indices_serialized
    INTEGER,DIMENSION(n_atoms_series+1),INTENT(IN)::atoms_series_starts
    INTEGER,DIMENSION(n_frame_indices),INTENT(IN)::frame_indices
    DOUBLE PRECISION,DIMENSION(n_atoms_indices)::weights
    DOUBLE PRECISION,DIMENSION(n_frames,n_atoms_series,3)::center

    weights(:)=1.0d0

    center=CENTER_OF_MASS(coors, atoms_indices_serialized, atoms_series_starts, weights, frame_indices,&
                          n_frames, n_atoms, n_atoms_indices, n_atoms_series, n_frame_indices)

  END FUNCTION

  FUNCTION CENTER_OF_MASS(coors, atoms_indices_serialized, atoms_series_starts, weights, frame_indices,&
                          n_frames, n_atoms, n_atoms_indices, n_atoms_series, n_frame_indices) RESULT(center)

    IMPLICIT NONE

    INTEGER,INTENT(IN)::n_frames, n_atoms, n_atoms_indices, n_atoms_series, n_frame_indices
    DOUBLE PRECISION,DIMENSION(n_frames,n_atoms,3),INTENT(IN)::coors
    INTEGER,DIMENSION(n_atoms_indices),INTENT(IN)::atoms_indices_serialized
    INTEGER,DIMENSION(n_atoms_series+1),INTENT(IN)::atoms_series_starts
    DOUBLE PRECISION,DIMENSION(n_atoms_indices),INTENT(IN)::weights
    INTEGER,DIMENSION(n_frame_indices),INTENT(IN)::frame_indices
    DOUBLE PRECISION,DIMENSION(n_frames,n_atoms_series,3)::center

    INTEGER::ii,jj,ll,frame_index,atom_index
    DOUBLE PRECISION::total_weight

    center(:,:,:)=0.0d0

    DO ii=1,n_atoms_series
        total_weight=0.0d0
        DO jj=atoms_series_starts(ii)+1,atoms_series_starts(ii+1)
            total_weight = total_weight+weights(jj)
        END DO
        DO jj=atoms_series_starts(ii)+1,atoms_series_starts(ii+1)
            atom_index = atoms_indices_serialized(jj)+1
            DO ll=1,n_frame_indices
                frame_index=frame_indices(ll)+1
                center(ll,ii,:)=center(ll,ii,:)+weights(jj)*coors(frame_index,atom_index,:)/total_weight
            END DO
        END DO
    END DO

  END FUNCTION CENTER_OF_MASS

END MODULE MODULE_COM


! =============================================================================
!
!   Angry Polynomial Interpolator (Procedure)
!
!   AUTHOR: Maciek_Bak
!   CONTACT: wsciekly.maciek@gmail.com
!   CREATED: 15-07-2020
!   LICENSE: MIT
!
! =============================================================================

module AngryPolynomialInterpolator

contains

subroutine interpolate(n, x, y, a)
  implicit none
  integer :: n, i, j, info
  real(8), dimension (:), intent(in) :: x, y
  real(8), dimension (:), intent(inout) :: a
  integer, dimension (:), allocatable :: ipiv
  real(8), dimension(:,:), allocatable :: Mat_X, Mat_B

  ! create the Vandermonde matrix:
  allocate(Mat_X(n,n))
  do i = 1,n
    do j = 1,n
      Mat_X(i,j) = x(i) ** (j - 1)
    end do
  end do

  ! reshape ipnut data into a matrix form:
  allocate (Mat_B(n,1))
  do i = 1,n
    Mat_B(i,1) = y(i)
  end do

  ! prepare an array for the pivot indices from DGETRF:
  allocate(ipiv(n))

  ! LAPACK:
  ! compute an LU factorization of a general M-by-N matrix A using
  ! partial pivoting with row interchanges
  ! http://sites.science.oregonstate.edu/~landaur/nacphy/lapack/routines/dgetrf.html
  call DGETRF(n, n, Mat_X, n, ipiv, info)

  ! LAPACK:
  ! DGETRS - solve a system of linear equations A * X = B or A' * X = B with a
  ! general N-by-N matrix A using the LU factorization computed by DGETRF
  ! http://sites.science.oregonstate.edu/~landaur/nacphy/lapack/routines/dgetrs.html
  call DGETRS("N", n, 1, Mat_X, n, ipiv, Mat_B, n, info)

  ! save the results into the argument array
  do i = 1,n
    a(i) = Mat_B(i,1)
  end do

  deallocate(ipiv)
  deallocate(Mat_X)
  deallocate(Mat_B)

end subroutine interpolate

end module AngryPolynomialInterpolator