      SUBROUTINE SG03AD( DICO, JOB, FACT, TRANS, UPLO, N, A, LDA, E,
     $                   LDE, Q, LDQ, Z, LDZ, X, LDX, SCALE, SEP, FERR,
     $                   ALPHAR, ALPHAI, BETA, IWORK, DWORK, LDWORK,
     $                   INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To solve for X either the generalized continuous-time Lyapunov
C     equation
C
C             T                T
C        op(A)  X op(E) + op(E)  X op(A) = SCALE * Y,                (1)
C
C     or the generalized discrete-time Lyapunov equation
C
C             T                T
C        op(A)  X op(A) - op(E)  X op(E) = SCALE * Y,                (2)
C
C     where op(M) is either M or M**T for M = A, E and the right hand
C     side Y is symmetric. A, E, Y, and the solution X are N-by-N
C     matrices. SCALE is an output scale factor, set to avoid overflow
C     in X.
C
C     Estimates of the separation and the relative forward error norm
C     are provided.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     DICO    CHARACTER*1
C             Specifies which type of the equation is considered:
C             = 'C':  Continuous-time equation (1);
C             = 'D':  Discrete-time equation (2).
C
C     JOB     CHARACTER*1
C             Specifies if the solution is to be computed and if the
C             separation is to be estimated:
C             = 'X':  Compute the solution only;
C             = 'S':  Estimate the separation only;
C             = 'B':  Compute the solution and estimate the separation.
C
C     FACT    CHARACTER*1
C             Specifies whether the generalized real Schur
C             factorization of the pencil A - lambda * E is supplied
C             on entry or not:
C             = 'N':  Factorization is not supplied;
C             = 'F':  Factorization is supplied.
C
C     TRANS   CHARACTER*1
C             Specifies whether the transposed equation is to be solved
C             or not:
C             = 'N':  op(A) = A,    op(E) = E;
C             = 'T':  op(A) = A**T, op(E) = E**T.
C
C     UPLO    CHARACTER*1
C             Specifies whether the lower or the upper triangle of the
C             array X is needed on input:
C             = 'L':  Only the lower triangle is needed on input;
C             = 'U':  Only the upper triangle is needed on input.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrix A.  N >= 0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, if FACT = 'F', then the leading N-by-N upper
C             Hessenberg part of this array must contain the
C             generalized Schur factor A_s of the matrix A (see
C             definition (3) in section METHOD). A_s must be an upper
C             quasitriangular matrix. The elements below the upper
C             Hessenberg part of the array A are not referenced.
C             If FACT = 'N', then the leading N-by-N part of this
C             array must contain the matrix A.
C             On exit, the leading N-by-N part of this array contains
C             the generalized Schur factor A_s of the matrix A. (A_s is
C             an upper quasitriangular matrix.)
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= MAX(1,N).
C
C     E       (input/output) DOUBLE PRECISION array, dimension (LDE,N)
C             On entry, if FACT = 'F', then the leading N-by-N upper
C             triangular part of this array must contain the
C             generalized Schur factor E_s of the matrix E (see
C             definition (4) in section METHOD). The elements below the
C             upper triangular part of the array E are not referenced.
C             If FACT = 'N', then the leading N-by-N part of this
C             array must contain the coefficient matrix E of the
C             equation.
C             On exit, the leading N-by-N part of this array contains
C             the generalized Schur factor E_s of the matrix E. (E_s is
C             an upper triangular matrix.)
C
C     LDE     INTEGER
C             The leading dimension of the array E.  LDE >= MAX(1,N).
C
C     Q       (input/output) DOUBLE PRECISION array, dimension (LDQ,N)
C             On entry, if FACT = 'F', then the leading N-by-N part of
C             this array must contain the orthogonal matrix Q from
C             the generalized Schur factorization (see definitions (3)
C             and (4) in section METHOD).
C             If FACT = 'N', Q need not be set on entry.
C             On exit, the leading N-by-N part of this array contains
C             the orthogonal matrix Q from the generalized Schur
C             factorization.
C
C     LDQ     INTEGER
C             The leading dimension of the array Q.  LDQ >= MAX(1,N).
C
C     Z       (input/output) DOUBLE PRECISION array, dimension (LDZ,N)
C             On entry, if FACT = 'F', then the leading N-by-N part of
C             this array must contain the orthogonal matrix Z from
C             the generalized Schur factorization (see definitions (3)
C             and (4) in section METHOD).
C             If FACT = 'N', Z need not be set on entry.
C             On exit, the leading N-by-N part of this array contains
C             the orthogonal matrix Z from the generalized Schur
C             factorization.
C
C     LDZ     INTEGER
C             The leading dimension of the array Z.  LDZ >= MAX(1,N).
C
C     X       (input/output) DOUBLE PRECISION array, dimension (LDX,N)
C             On entry, if JOB = 'B' or 'X', then the leading N-by-N
C             part of this array must contain the right hand side matrix
C             Y of the equation. Either the lower or the upper
C             triangular part of this array is needed (see mode
C             parameter UPLO).
C             If JOB = 'S', X is not referenced.
C             On exit, if JOB = 'B' or 'X', and INFO = 0, 3, or 4, then
C             the leading N-by-N part of this array contains the
C             solution matrix X of the equation.
C             If JOB = 'S', X is not referenced.
C
C     LDX     INTEGER
C             The leading dimension of the array X.  LDX >= MAX(1,N).
C
C     SCALE   (output) DOUBLE PRECISION
C             The scale factor set to avoid overflow in X.
C             (0 < SCALE <= 1)
C
C     SEP     (output) DOUBLE PRECISION
C             If JOB = 'S' or JOB = 'B', and INFO = 0, 3, or 4, then
C             SEP contains an estimate of the separation of the
C             Lyapunov operator.
C
C     FERR    (output) DOUBLE PRECISION
C             If JOB = 'B', and INFO = 0, 3, or 4, then FERR contains an
C             estimated forward error bound for the solution X. If XTRUE
C             is the true solution, FERR estimates the relative error
C             in the computed solution, measured in the Frobenius norm:
C             norm(X - XTRUE) / norm(XTRUE)
C
C     ALPHAR  (output) DOUBLE PRECISION array, dimension (N)
C     ALPHAI  (output) DOUBLE PRECISION array, dimension (N)
C     BETA    (output) DOUBLE PRECISION array, dimension (N)
C             If FACT = 'N' and INFO = 0, 3, or 4, then
C             (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, are the
C             eigenvalues of the matrix pencil A - lambda * E.
C             If FACT = 'F', ALPHAR, ALPHAI, and BETA are not
C             referenced.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (N**2)
C             IWORK is not referenced if JOB = 'X'.
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) returns the optimal value
C             of LDWORK.
C
C     LDWORK  INTEGER
C             The length of the array DWORK. The following table
C             contains the minimal work space requirements depending
C             on the choice of JOB and FACT.
C
C                    JOB        FACT    |  LDWORK
C                    -------------------+-------------------
C                    'X'        'F'     |  MAX(1,N)
C                    'X'        'N'     |  MAX(1,4*N)
C                    'B', 'S'   'F'     |  MAX(1,2*N**2)
C                    'B', 'S'   'N'     |  MAX(1,2*N**2,4*N)
C
C             For optimum performance, LDWORK should be larger.
C
C             If LDWORK = -1, then a workspace query is assumed; the
C             routine only calculates the optimal size of the DWORK
C             array, returns this value as the first entry of the DWORK
C             array, and no error message related to LDWORK is issued by
C             XERBLA.
C
C     Error indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             = 1:  FACT = 'F' and the matrix contained in the upper
C                   Hessenberg part of the array A is not in upper
C                   quasitriangular form;
C             = 2:  FACT = 'N' and the pencil A - lambda * E cannot be
C                   reduced to generalized Schur form: LAPACK routine
C                   DGEGS (or DGGES) has failed to converge;
C             = 3:  DICO = 'D' and the pencil A - lambda * E has a
C                   pair of reciprocal eigenvalues. That is, lambda_i =
C                   1/lambda_j for some i and j, where lambda_i and
C                   lambda_j are eigenvalues of A - lambda * E. Hence,
C                   equation (2) is singular;  perturbed values were
C                   used to solve the equation (but the matrices A and
C                   E are unchanged);
C             = 4:  DICO = 'C' and the pencil A - lambda * E has a
C                   degenerate pair of eigenvalues. That is, lambda_i =
C                   -lambda_j for some i and j, where lambda_i and
C                   lambda_j are eigenvalues of A - lambda * E. Hence,
C                   equation (1) is singular;  perturbed values were
C                   used to solve the equation (but the matrices A and
C                   E are unchanged).
C
C     METHOD
C
C     A straightforward generalization [3] of the method proposed by
C     Bartels and Stewart [1] is utilized to solve (1) or (2).
C
C     First the pencil A - lambda * E is reduced to real generalized
C     Schur form A_s - lambda * E_s by means of orthogonal
C     transformations (QZ-algorithm):
C
C        A_s = Q**T * A * Z   (upper quasitriangular)                (3)
C
C        E_s = Q**T * E * Z   (upper triangular).                    (4)
C
C     If FACT = 'F', this step is omitted. Assuming SCALE = 1 and
C     defining
C
C              ( Z**T * Y * Z   :   TRANS = 'N'
C        Y_s = <
C              ( Q**T * Y * Q   :   TRANS = 'T'
C
C
C              ( Q**T * X * Q    if TRANS = 'N'
C        X_s = <                                                     (5)
C              ( Z**T * X * Z    if TRANS = 'T'
C
C     leads to the reduced Lyapunov equation
C
C               T                      T
C        op(A_s)  X_s op(E_s) + op(E_s)  X_s op(A_s) = Y_s,          (6)
C
C     or
C               T                      T
C        op(A_s)  X_s op(A_s) - op(E_s)  X_s op(E_s) = Y_s,          (7)
C
C     which are equivalent to (1) or (2), respectively. The solution X_s
C     of (6) or (7) is computed via block back substitution (if TRANS =
C     'N') or block forward substitution (if TRANS = 'T'), where the
C     block order is at most 2. (See [1] and [3] for details.)
C     Equation (5) yields the solution matrix X.
C
C     For fast computation the estimates of the separation and the
C     forward error are gained from (6) or (7) rather than (1) or
C     (2), respectively. We consider (6) and (7) as special cases of the
C     generalized Sylvester equation
C
C        R * X * S + U * X * V = Y,                                  (8)
C
C     whose separation is defined as follows
C
C        sep = sep(R,S,U,V) =   min   || R * X * S + U * X * V || .
C                            ||X|| = 1                           F
C                                 F
C
C     Equation (8) is equivalent to the system of linear equations
C
C        K * vec(X) = (kron(S**T,R) + kron(V**T,U)) * vec(X) = vec(Y),
C
C     where kron is the Kronecker product of two matrices and vec
C     is the mapping that stacks the columns of a matrix. If K is
C     nonsingular then
C
C        sep = 1 / ||K**(-1)|| .
C                             2
C
C     We estimate ||K**(-1)|| by a method devised by Higham [2]. Note
C     that this method yields an estimation for the 1-norm but we use it
C     as an approximation for the 2-norm. Estimates for the forward
C     error norm are provided by
C
C        FERR = 2 * EPS * ||A_s||  * ||E_s||  / sep
C                                F          F
C
C     in the continuous-time case (1) and
C
C        FERR = EPS * ( ||A_s|| **2 + ||E_s|| **2 ) / sep
C                              F             F
C
C     in the discrete-time case (2).
C     The reciprocal condition number, RCOND, of the Lyapunov equation
C     can be estimated by FERR/EPS.
C
C     REFERENCES
C
C     [1] Bartels, R.H., Stewart, G.W.
C         Solution of the equation A X + X B = C.
C         Comm. A.C.M., 15, pp. 820-826, 1972.
C
C     [2] Higham, N.J.
C         FORTRAN codes for estimating the one-norm of a real or complex
C         matrix, with applications to condition estimation.
C         A.C.M. Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, 1988.
C
C     [3] Penzl, T.
C         Numerical solution of generalized Lyapunov equations.
C         Advances in Comp. Math., vol. 8, pp. 33-48, 1998.
C
C     NUMERICAL ASPECTS
C
C     The number of flops required by the routine is given by the
C     following table. Note that we count a single floating point
C     arithmetic operation as one flop. c is an integer number of modest
C     size (say 4 or 5).
C
C                   |  FACT = 'F'            FACT = 'N'
C        -----------+------------------------------------------
C        JOB = 'B'  |  (26+8*c)/3 * N**3     (224+8*c)/3 * N**3
C        JOB = 'S'  |  8*c/3 * N**3          (198+8*c)/3 * N**3
C        JOB = 'X'  |  26/3 * N**3           224/3 * N**3
C
C     The algorithm is backward stable if the eigenvalues of the pencil
C     A - lambda * E are real. Otherwise, linear systems of order at
C     most 4 are involved into the computation. These systems are solved
C     by Gauss elimination with complete pivoting. The loss of stability
C     of the Gauss elimination with complete pivoting is rarely
C     encountered in practice.
C
C     The Lyapunov equation may be very ill-conditioned. In particular,
C     if DICO = 'D' and the pencil A - lambda * E has a pair of almost
C     reciprocal eigenvalues, or DICO = 'C' and the pencil has an almost
C     degenerate pair of eigenvalues, then the Lyapunov equation will be
C     ill-conditioned. Perturbed values were used to solve the equation.
C     Ill-conditioning can be detected by a very small value of the
C     reciprocal condition number RCOND.
C
C     CONTRIBUTOR
C
C     T. Penzl, Technical University Chemnitz, Germany, Aug. 1998.
C
C     REVISIONS
C
C     V. Sima, Sep. 1998, Dec. 1998, July 2011, Oct. 2017, May 2020.
C
C     KEYWORDS
C
C     Lyapunov equation
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ONE, TWO, ZERO
      PARAMETER         ( ONE = 1.0D+0, TWO = 2.0D+0, ZERO = 0.0D+0 )
C     .. Scalar Arguments ..
      CHARACTER         DICO, FACT, JOB, TRANS, UPLO
      DOUBLE PRECISION  FERR, SCALE, SEP
      INTEGER           INFO, LDA, LDE, LDQ, LDWORK, LDX, LDZ, N
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), ALPHAI(*), ALPHAR(*), BETA(*),
     $                  DWORK(*), E(LDE,*), Q(LDQ,*), X(LDX,*),
     $                  Z(LDZ,*)
      INTEGER           IWORK(*)
C     .. Local Scalars ..
      CHARACTER         ETRANS
      DOUBLE PRECISION  EST, EPS, NORMA, NORME, SCALE1
      INTEGER           I, INFO1, KASE, MINGG, MINWRK, OPTWRK
      LOGICAL           ISDISC, ISFACT, ISTRAN, ISUPPR, LQUERY, WANTBH,
     $                  WANTSP, WANTX
C     .. Local Arrays ..
      LOGICAL           BWORK(1)
      INTEGER           ISAVE( 3 )
C     .. External Functions ..
      DOUBLE PRECISION  DLAMCH, DNRM2
      LOGICAL           DELCTG, LSAME
      EXTERNAL          DELCTG, DLAMCH, DNRM2, LSAME
C     .. External Subroutines ..
      EXTERNAL          DCOPY, DGEGS, DGGES, DLACN2, MB01RD, MB01RW,
     $                  SG03AX, SG03AY, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         DBLE, INT, MAX, MIN
C     .. Executable Statements ..
C
C     Decode input parameters.
C
      ISDISC = LSAME( DICO,  'D' )
      WANTX  = LSAME( JOB,   'X' )
      WANTSP = LSAME( JOB,   'S' )
      WANTBH = LSAME( JOB,   'B' )
      ISFACT = LSAME( FACT,  'F' )
      ISTRAN = LSAME( TRANS, 'T' )
      ISUPPR = LSAME( UPLO,  'U' )
      LQUERY = LDWORK.EQ.-1
C
C     Check the scalar input parameters.
C
      INFO = 0
      IF ( .NOT.( ISDISC .OR. LSAME( DICO,  'C' ) ) ) THEN
         INFO = -1
      ELSEIF ( .NOT.( WANTX .OR. WANTSP .OR. WANTBH ) ) THEN
         INFO = -2
      ELSEIF ( .NOT.( ISFACT .OR. LSAME( FACT,  'N' ) ) ) THEN
         INFO = -3
      ELSEIF ( .NOT.( ISTRAN .OR. LSAME( TRANS, 'N' ) ) ) THEN
         INFO = -4
      ELSEIF ( .NOT.( ISUPPR .OR. LSAME( UPLO,  'L' ) ) ) THEN
         INFO = -5
      ELSEIF ( N .LT. 0 ) THEN
         INFO = -6
      ELSEIF ( LDA .LT. MAX( 1, N ) ) THEN
         INFO = -8
      ELSEIF ( LDE .LT. MAX( 1, N ) ) THEN
         INFO = -10
      ELSEIF ( LDQ .LT. MAX( 1, N ) ) THEN
         INFO = -12
      ELSEIF ( LDZ .LT. MAX( 1, N ) ) THEN
         INFO = -14
      ELSEIF ( LDX .LT. MAX( 1, N ) ) THEN
         INFO = -16
      ELSE
C
C        Compute minimal and optimal workspace.
C
         IF ( WANTX ) THEN
            IF ( ISFACT ) THEN
               MINWRK = MAX( N, 1 )
            ELSE
               MINWRK = MAX( 4*N, 1 )
            END IF
         ELSE
            IF ( ISFACT ) THEN
               MINWRK = MAX( 2*N*N, 1 )
            ELSE
               MINWRK = MAX( 2*N*N, 4*N, 1 )
            END IF
         END IF
         MINGG = MAX( MINWRK, 8*N + 16 )
         IF( LQUERY ) THEN
            IF ( ISFACT ) THEN
               OPTWRK = MINGG
            ELSE
               CALL DGGES( 'Vectors', 'Vectors', 'Not ordered', DELCTG,
     $                     N, A, LDA, E, LDE, I, ALPHAR, ALPHAI, BETA,
     $                     Q, LDQ, Z, LDZ, DWORK, -1, BWORK, INFO1 )
               OPTWRK = MAX( MINGG, INT( DWORK(1) ), N*N )
            END IF
         ELSE IF ( MINWRK .GT. LDWORK ) THEN
            INFO = -25
         END IF
      END IF
C
      IF ( INFO .NE. 0 ) THEN
         CALL XERBLA( 'SG03AD', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         DWORK(1) = OPTWRK
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( N .EQ. 0 ) THEN
         SCALE = ONE
         IF ( .NOT.WANTX ) SEP = ZERO
         IF ( WANTBH ) FERR = ZERO
         DWORK(1) = ONE
         RETURN
      END IF
C
      IF ( ISFACT ) THEN
C
C        Make sure the upper Hessenberg part of A is quasitriangular.
C
         DO 20 I = 1, N-2
            IF ( A(I+1,I).NE.ZERO .AND. A(I+2,I+1).NE.ZERO ) THEN
               INFO = 1
               RETURN
            END IF
   20    CONTINUE
      END IF
C
      IF ( .NOT.ISFACT ) THEN
C
C        Reduce A - lambda * E to generalized Schur form.
C
C           A := Q**T * A * Z   (upper quasitriangular)
C           E := Q**T * E * Z   (upper triangular)
C
         IF ( LDWORK .LT. MINGG ) THEN
C
C           Use DGEGS for backward compatibilty with LDWORK value.
C           ( Workspace: >= MAX(1,4*N) )
C
            CALL DGEGS( 'Vectors', 'Vectors', N, A, LDA, E, LDE, ALPHAR,
     $                  ALPHAI, BETA, Q, LDQ, Z, LDZ, DWORK, LDWORK,
     $                  INFO1 )
         ELSE
C
C           Use DGGES. The workspace is increased to avoid an error
C           return, while it should not really be larger than above.
C           ( Workspace: >= MAX(1,8*N+16) )
C
            CALL DGGES( 'Vectors', 'Vectors', 'Not ordered', DELCTG, N,
     $                  A, LDA, E, LDE, I, ALPHAR, ALPHAI, BETA, Q, LDQ,
     $                  Z, LDZ, DWORK, LDWORK, BWORK, INFO1 )
         END IF
         IF ( INFO1 .NE. 0 ) THEN
            INFO = 2
            RETURN
         END IF
         OPTWRK = INT( DWORK(1) )
      ELSE
         OPTWRK = 0
      END IF
C
      IF ( WANTBH .OR. WANTX ) THEN
C
C        Transform right hand side.
C
C           X := Z**T * X * Z  or  X := Q**T * X * Q
C
C        Use BLAS 3 if there is enough workspace. Otherwise, use BLAS 2.
C
C        ( Workspace: >= N )
C
         IF ( LDWORK .LT. N*N ) THEN
            IF ( ISTRAN ) THEN
               CALL MB01RW( UPLO, 'Transpose', N, N, X, LDX, Q, LDQ,
     $                      DWORK, INFO1 )
            ELSE
               CALL MB01RW( UPLO, 'Transpose', N, N, X, LDX, Z, LDZ,
     $                      DWORK, INFO1 )
            END IF
         ELSE
            IF ( ISTRAN ) THEN
               CALL MB01RD( UPLO, 'Transpose', N, N, ZERO, ONE, X, LDX,
     $                      Q, LDQ, X, LDX, DWORK, LDWORK, INFO )
            ELSE
               CALL MB01RD( UPLO, 'Transpose', N, N, ZERO, ONE, X, LDX,
     $                      Z, LDZ, X, LDX, DWORK, LDWORK, INFO )
            END IF
         END IF
         IF ( .NOT.ISUPPR ) THEN
            DO 40 I = 1, N-1
               CALL DCOPY( N-I, X(I+1,I), 1, X(I,I+1), LDX )
   40       CONTINUE
         END IF
         OPTWRK = MAX( OPTWRK, N*N )
C
C        Solve reduced generalized Lyapunov equation.
C
         IF ( ISDISC ) THEN
            CALL SG03AX( TRANS, N, A, LDA, E, LDE, X, LDX, SCALE, INFO1)
            IF ( INFO1 .NE. 0 )
     $         INFO = 3
         ELSE
            CALL SG03AY( TRANS, N, A, LDA, E, LDE, X, LDX, SCALE, INFO1)
            IF ( INFO1 .NE. 0 )
     $         INFO = 4
         END IF
C
C        Transform the solution matrix back.
C
C           X := Q * X * Q**T  or  X := Z * X * Z**T.
C
C        Use BLAS 3 if there is enough workspace. Otherwise, use BLAS 2.
C
C        ( Workspace: >= N )
C
         IF ( LDWORK .LT. N*N ) THEN
            IF ( ISTRAN ) THEN
               CALL MB01RW( 'Upper', 'NoTranspose', N, N, X, LDX, Z,
     $                      LDZ, DWORK, INFO1 )
            ELSE
               CALL MB01RW( 'Upper', 'NoTranspose', N, N, X, LDX, Q,
     $                      LDQ, DWORK, INFO1 )
            END IF
         ELSE
            IF ( ISTRAN ) THEN
               CALL MB01RD( 'Upper', 'NoTranspose', N, N, ZERO, ONE, X,
     $                      LDX, Z, LDZ, X, LDX, DWORK, LDWORK, INFO )
            ELSE
               CALL MB01RD( 'Upper', 'NoTranspose', N, N, ZERO, ONE, X,
     $                      LDX, Q, LDQ, X, LDX, DWORK, LDWORK, INFO )
            END IF
         END IF
         DO 60 I = 1, N-1
            CALL DCOPY( N-I, X(I,I+1), LDX, X(I+1,I), 1 )
   60    CONTINUE
      END IF
C
      IF ( WANTBH .OR. WANTSP ) THEN
C
C        Estimate the 1-norm of the inverse Kronecker product matrix
C        belonging to the reduced generalized Lyapunov equation.
C
C        ( Workspace: 2*N*N )
C
         EST = ZERO
         KASE = 0
   80    CONTINUE
         CALL DLACN2( N*N, DWORK(N*N+1), DWORK, IWORK, EST, KASE, ISAVE
     $              )
         IF ( KASE .NE. 0 ) THEN
            IF ( ( KASE.EQ.1 .AND. .NOT.ISTRAN ) .OR.
     $           ( KASE.NE.1 .AND. ISTRAN ) ) THEN
               ETRANS = 'N'
            ELSE
               ETRANS = 'T'
            END IF
            IF ( ISDISC ) THEN
               CALL SG03AX( ETRANS, N, A, LDA, E, LDE, DWORK, N, SCALE1,
     $                      INFO1 )
               IF ( INFO1 .NE. 0 )
     $            INFO = 3
            ELSE
               CALL SG03AY( ETRANS, N, A, LDA, E, LDE, DWORK, N, SCALE1,
     $                      INFO1 )
               IF ( INFO1 .NE. 0 )
     $            INFO = 4
            END IF
         GOTO 80
         END IF
         SEP = SCALE1/EST
      END IF
C
C     Estimate the relative forward error.
C
C     ( Workspace: 2*N )
C
      IF ( WANTBH ) THEN
         EPS = DLAMCH( 'Precision' )
         DO 100 I = 1, N
            DWORK(I) = DNRM2( MIN( I+1, N ), A(1,I), 1 )
            DWORK(N+I) = DNRM2( I, E(1,I), 1 )
  100    CONTINUE
         NORMA = DNRM2( N, DWORK, 1 )
         NORME = DNRM2( N, DWORK(N+1), 1 )
         IF ( ISDISC ) THEN
            FERR = ( NORMA**2 + NORME**2 )*EPS/SEP
         ELSE
            FERR = TWO*NORMA*NORME*EPS/SEP
         END IF
      END IF
C
      DWORK(1) = DBLE( MAX( OPTWRK, MINWRK ) )
      RETURN
C *** Last line of SG03AD ***
      END


      function planck(t,x)
      implicit real*4 (d)
      a=1.43880/x
      c=(1.1910627e-5/x)/x**4
      entry black(t)
      alpha=a/t
      if(alpha-2.e-4.lt.0.) goto 2
      planck=c/(exp(alpha)-1.)
   1  black=planck
      return
   2  planck=c/alpha
      goto 1
      entry dplnck(dt,dx)
      da=1.43880d0/dx
      dc=(1.1910627d-5/dx)/dx**4
      entry dblack(dt)
      dalpha=da/dt
      if(dalpha-1.d-8.lt.0.d0) goto 4
      dplnck=dc/(exp(dalpha)-1.0)
   3  dblack=dplnck
      return
   4  dplnck=dc/dalpha
      goto 3
      entry tplck(p,x)
      tplck=(1.43880/x)/alog(1.+(1.1910627e-5/x)/(p*x**4))
      return
      entry dtplck(dp,dx)
      dtplck=(1.43880d0/dx)/dlog(1.d0+(1.1910627d-5/dx)/(dp*dx**4))
      return
      end


      SUBROUTINE EKTRMD (NTYPE)
C
C     THIS SUBROUTINE CALCULATES THE STIFFNESS MATRIX FOR THE
C     TRIANGULAR MEMBRANE ELEMENT
C
C     DOUBLE PRECISION VERSION
C
C     ECPT LIST
C                                                      IN
C                                                      THIS
C       ECPT       DESCRIPTION                         ROUTINE   TYPE
C     ******************************************************************
C       ECPT( 1) = ELEMENT ID                          NECPT(1)  INTEGER
C       ECPT( 2) = GRID POINT A                        NGRID(1)  INTEGER
C       ECPT( 3) = GRID POINT B                        NGRID(2)  INTEGER
C       ECPT( 4) = GRID POINT C                        NGRID(3)  INTEGER
C       ECPT( 5) = THETA = ANGLE OF MATERIAL           ANGLE     REAL
C       ECPT( 6) = MATERIAL ID                         MATID     INTEGER
C       ECPT( 7) = T                                   T         REAL
C       ECPT( 8) = NON-STRUCTURAL MASS                 FMU       REAL
C       ECPT( 9) = COORD. SYSTEM ID 1                  NECPT(9)  INTEGER
C       ECPT(10) = X1                                  X1        REAL
C       ECPT(11) = Y1                                  Y1        REAL
C       ECPT(12) = Z1                                  Z1        REAL
C       ECPT(13) = COORD. SYSTEM ID 2                  NECPT(13) INTEGER
C       ECPT(14) = X2                                  X2        REAL
C       ECPT(15) = Y2                                  Y2        REAL
C       ECPT(16) = Z2                                  Z2        REAL
C       ECPT(17) = COORD. SYSTEM ID 3                  NECPT(17) INTEGER
C       ECPT(18) = X3                                  X3        REAL
C       ECPT(19) = Y3                                  Y3        REAL
C       ECPT(20) = Z3                                  Z3        REAL
C       ECPT(21) = ELEMENT TEMPERATURE                 ELTEMP    REAL
C
C     IF NTYPE = 0  COMPLETE MEMBRANE COMPUTATION IS PERFORMED
C     IF NTYPE = 1  9  3X3 MATRICES FOR THE GRID POINTS  IN ECPT
C
C
      LOGICAL          NOGO,HEAT
      INTEGER          NECPT(21)
      REAL             ECPT(21),MATBUF
      DOUBLE PRECISION G(9),C(18),TT(2),TI(9),TEMPAR(27),E,K,KOUT,KIJ,
     1                 A,PROD9,TEMP9,XSUBB,XSUBC,YSUBC,DICT5
      DOUBLE PRECISION TEMP,VOL,REELMU,FLAMDA,DELTA
      COMMON /EMGTRX/  A(225),PROD9(9),TEMP9(9),XSUBB,XSUBC,YSUBC,DICT5,
     1                 E(18),K(324),KOUT(324),KIJ(81)
      COMMON /SYSTEM/  KSYSTM(60)
      COMMON /CONDAS/  CONSTS(5)
      COMMON /EMGPRM/  DUM(19),NOGO, HEAT
      COMMON /EMGEST/  MECPT(1),NGRID(3),ANGLE,MATID1,T,FMU,DUMMY1,X1,
     1                 Y1,Z1,DUMMY2,X2,Y2,Z2,DUMMY3,X3,Y3,Z3,DUMB(80)
      COMMON /MATIN /  MATID,INFLAG,ELTEMP,STRESS,SINTH,COSTH
      COMMON /MATOUT/  G11,G12,G13,G22,G23,G33,RHO,ALPHA1,ALPHA2,ALP12,
     1                 T SUB 0,G SUB E,SIGTEN,SIGCOM,SIGSHE,
     2                 G2X211,G2X212,G2X222
      COMMON /HMTOUT/  MATBUF(4)
      EQUIVALENCE      (CONSTS(4),DEGRA),(ECPT(1),NECPT(1),MECPT(1)),
     1                 (KSYSTM(2),IOUTPT),(KSYSTM(56),IHEAT)
C
C     SET UP THE E MATRIX WHICH IS (3X2) FOR THE TRI-MEMBRANE
C
C     E(1), E(3), E(5) WILL BE THE I-VECTOR
C     E(2), E(4), E(6) WILL BE THE J-VECTOR
C     E(7), E(8), E(9) WILL BE THE K-VECTOR NOT USED IN E FOR MEMBRANE
C
C     FIRST FIND I-VECTOR = RSUBB - RSUBA  (NON-NORMALIZED)
C
      E(1) = DBLE(X2) - DBLE(X1)
      E(3) = DBLE(Y2) - DBLE(Y1)
      E(5) = DBLE(Z2) - DBLE(Z1)
C
C     NOW FIND LENGTH = X-SUB-B   COORD. IN ELEMENT SYSTEM
C
      XSUBB = DSQRT(E(1)**2 + E(3)**2 + E(5)**2)
      IF (XSUBB .LE. 1.D-6) GO TO 7770
C
C  20 NOW NORMALIZE I-VECTOR WITH X-SUB-B
C
      E(1) = E(1)/XSUBB
      E(3) = E(3)/XSUBB
      E(5) = E(5)/XSUBB
C
C     HERE WE NOW TAKE RSUBC - RSUBA AND STORE TEMPORARILY IN
C     E(2), E(4), E(6) WHICH IS WHERE THE J-VECTOR WILL FIT LATER
C
      E(2) = DBLE(X3) - DBLE(X1)
      E(4) = DBLE(Y3) - DBLE(Y1)
      E(6) = DBLE(Z3) - DBLE(Z1)
C
C     X-SUB-C  =  I . (RSUBC - RSUBA), THUS
C
      XSUBC = E(1)*E(2) + E(3)*E(4) + E(5)*E(6)
C
C     AND CROSSING THE I-VECTOR TO (RSUBC-RSUBA) GIVES THE K-VECTOR
C     (NON-NORMALIZED)
C
      E(7) = E(3)*E(6) - E(5)*E(4)
      E(8) = E(5)*E(2) - E(1)*E(6)
      E(9) = E(1)*E(4) - E(3)*E(2)
C
C
C     THE LENGTH OF THE K-VECTOR IS NOW FOUND AND EQUALS Y-SUB-C
C     COORD. IN ELEMENT SYSTEM
C
      YSUBC = DSQRT(E(7)**2 + E(8)**2 + E(9)**2)
      IF (YSUBC .LE. 1.D-6) GO TO 7780
C
C  25 NOW NORMALIZE K-VECTOR WITH YSUBC JUST FOUND
C
      E(7) = E(7)/YSUBC
      E(8) = E(8)/YSUBC
      E(9) = E(9)/YSUBC
C
C     J VECTOR = K CROSS I
C     STORE IN THE SPOT FOR J
C
      E(2) = E(5)*E(8) - E(3)*E(9)
      E(4) = E(1)*E(9) - E(5)*E(7)
      E(6) = E(3)*E(7) - E(1)*E(8)
C
C     AND JUST FOR COMPUTER EXACTNESS NORMALIZE J-VECTOR TO MAKE SURE.
C
      TEMP = DSQRT (E(2)**2 + E(4)**2 + E(6)**2)
      IF (TEMP  .LE. 0.D0) GO TO 7790
      E(2) = E(2)/TEMP
      E(4) = E(4)/TEMP
      E(6) = E(6)/TEMP
C
C     VOLUME OF ELEMENT, THETA, MU, LAMDA, AND DELTA
C
      VOL    = XSUBB*YSUBC*T/2.D0
      REELMU = 1.D0/XSUBB
      FLAMDA = 1.D0/YSUBC
      DELTA  = XSUBC/XSUBB - 1.D0
C
C     NOW FORM THE  C MATRIX   (3X6) PARTITIONED AS FOLLOWS HERE.
C         CSUBA = (3X2) STORED IN C( 1) THRU C( 6) BY ROWS
C         CSUBB = (3X2) STORED IN C( 7) THRU C(12) BY ROWS
C         CSUBC = (3X2) STORED IN C(13) THRU C(18) BY ROWS
C
      C(1)  =-REELMU
      C(2)  = 0.
      C(3)  = 0.
      C(4)  =  FLAMDA*DELTA
      C(5)  =  C(4)
      C(6)  =-REELMU
      C(7)  =  REELMU
      C(8)  = 0.
      C(9)  = 0.
      C(10) =-FLAMDA*REELMU*XSUBC
      C(11) = C(10)
      C(12) = REELMU
      C(13) = 0.
      C(14) = 0.
      C(15) = 0.
      C(16) = FLAMDA
      C(17) = FLAMDA
      C(18) = 0.
C
      IF (NTYPE .EQ. 1) GO TO 30
C
      THETA = ANGLE*DEGRA
      SINTH = SIN(THETA)
      COSTH = COS(THETA)
   30 IF (ABS(SINTH) .LT. 1.E-6) SINTH = 0.
C
C     BRANCH ON -HEAT- PROBLEM AT THIS POINT.
C
      IF (HEAT) GO TO 300
      ELTEMP = ECPT(21)
      MATID  = MATID1
      INFLAG = 2
      CALL MAT (ECPT(1))
C
C     FILL G-MATRIX WITH OUTPUT FROM MAT ROUTINE
C
      G(1) = G11
      G(2) = G12
      G(3) = G13
      G(4) = G12
      G(5) = G22
      G(6) = G23
      G(7) = G13
      G(8) = G23
      G(9) = G33
C
C     AT 50 G, E, AND C MATRICES ARE COMPLETE
C
C     AT THIS POINT THE FOLLOWING EQUATION CAN BE SOLVED FOR K-SUB-IJ
C
C                     T        T             T
C       K   = VOL . T  * E * C  * G * C  * E  * T
C        IJ          I        I        J         J
C
C     T-SUB-I WILL BE USED IN THE ABOVE ONLY IF THE PIVOT COORDINATE
C     SYSTEM ID IS NOT ZERO, OTHERWISE IT IS ASSUMED TO BE THE
C     IDENTITY MATRIX.
C
C     THE I SUBSCRIPT IMPLIES THE PIVOT POINT  1,2, OR 3 (ELEMENT SYST)
C     THE J SUBSCRIPT IMPLIES  1 THRU 3  FOR EACH CALL TO THIS ROUTINE.
C
C     DO COMPUTATIONS FOR EACH POINT IN ECPT LIST
C
      DO 60 I = 1,81
   60 KIJ(I) = 0.
      DO 200 NPVT = 1,3
      KA = 4*NPVT + 5
      NPOINT = 6*NPVT - 5
C
C                     T
C     COMPUTE   E * C   * G       AND STORE IN TEMPAR( 1 THRU 9 )
C                    I
C
      CALL GMMATD (E,  3,2,0, C(NPOINT), 3,2,1,  TEMPAR(10))
      CALL GMMATD (TEMPAR(10),3,3,0,  G, 3,3,0,  TEMPAR(1) )
C
C     NCOM WILL ALWAYS POINT TO THE COMMON 3 X 3 PRODUCT ABOVE
C     NPT1 WILL POINT TO FREE WORKING SPACE LENGTH 9
C
      NCOM = 1
      NPT1 = 10
C
C     MULTIPLY COMMON PRODUCT BY SCALER VOL
C
      DO 90 I = 1,9
   90 TEMPAR(I) = TEMPAR(I)*VOL
C
C     CHECK FOR PIVOT  CSID = 0, IF ZERO SKIP TRANSFORMATION TSUBI.
C
      IF (NECPT(KA) .EQ. 0)  GO TO 110
C
C     NOT-ZERO THUS GET TI
C
      CALL TRANSD (NECPT(KA),TI)
C
C     INTRODUCE TI INTO THE COMMON PRODUCT AND STORE AT
C     TEMPAR(10 THRU 18)
C
      CALL GMMATD (TI,3,3,1, TEMPAR(1),3,3,0, TEMPAR(10))
C
C     COMMON PRODUCT NOW STARTS AT TEMPAR(10) THUS CHANGE NCOM AND NPT1
C
      NCOM = 10
      NPT1 =  1
C
C
C  80 NOW HAVE COMMON PRODUCT STORED BEGINNING TEMPAR(NCOM),  (3X3).
C     NPT1 POINTS TO FREE WORKING SPACE LENGTH 9.
C
C     PROCEED NOW AND RUN OUT THE 3 6X6 MATRICES KIJ-SUB-1,2,3.
C
  110 NSAVE  = NPT1
      NPOINT = (NPVT-1)*27
C
C     INSERT G INTO TEMPAR
C
      DO 115 I = 1,9
115   TEMPAR(I+18) = G(I)
      DO 190 I = 1,3
      CALL GMMATD (C(6*I-5),3,2,0, E,3,2,1, TEMPAR(NSAVE))
C
C     NPT2 IS SET TO POINT TO THE BEGINNING OF THE PRODUCT  C * E * T
C                                                            J       J
C
      NPT2 = NSAVE
      NPT1 = 19
C
C     CHECK FOR ZERO CSID IN WHICH CASE TJ IS NOT NEEDED
C
      IF (NECPT(4*I +5) .EQ. 0) GO TO 120
C
C     COMMING HERE IMPLIES NEED FOR TJ
C     WILL STORE TJ IN TI
C
      CALL TRANSD (NECPT(4*I+5),TI)
      CALL GMMATD (TEMPAR(NPT2),3,3,0, TI,3,3,0, TEMPAR(19))
      NPT1 = NPT2
      NPT2 = 19
C
C  60 AT THIS POINT COMPLETE COMPUTATION FOR  K-SUB-I,J
C
  120 CALL GMMATD (TEMPAR(NCOM),3,3,0, TEMPAR(NPT2),3,3,0, TEMPAR(NPT1)
     X)
      NPT36 = NPT1 + 35
C
      DO 140 J = 1,9
      NPOINT = NPOINT + 1
      NPT2 = NPT1 + J - 1
  140 KIJ(NPOINT) = TEMPAR(NPT2)
  190 CONTINUE
  200 CONTINUE
C
      DICT5 = GSUBE
      RETURN
C
C     HEAT PROBLEM LOGIC PICKS UP HERE.  CALL HMAT FOR MATERIAL DATA.
C
  300 INFLAG = 2
      MATID  = NECPT(6)
      ELTEMP = ECPT(21)
      CALL HMAT (NECPT)
      G(1) = MATBUF(1)
      G(2) = MATBUF(2)
      G(3) = MATBUF(2)
      G(4) = MATBUF(3)
C
C     CONDENSE C MATRIX FOR HEAT PROBLEM (FORMED ABOVE)  C IS (2X3)
C
      C(2) = C( 4)
      C(3) = C( 7)
      C(4) = C(10)
      C(5) = C(13)
      C(6) = C(16)
C
C     DETERMINE THE PIVOT POINT.
C
      KQ   = 3
      KMAX = KQ*3
      DO 320 I = 1,KMAX
  320 KIJ(I) = 0.
      DO 400 NPVT = 1,3
C
C     PIVOT C MATRIX TIMES VOLUME (STORED INTO TT(1) AND TT(2).)
C
      TT(1) = VOL*C(2*NPVT-1)
      TT(2) = VOL*C(2*NPVT)
C
C     OUTPUT THE CONDUCTIVITY MATRICES
C
      NPOINT = (NPVT-1)*KQ
C
      DO 380 I = 1,3
      N2 = 2*I
      N1 = N2 - 1
      TEMPAR(1) = (G(1)*C(N1) + G(2)*C(N2))*TT(1) +
     1            (G(3)*C(N1) + G(4)*C(N2))*TT(2)
C
C     SUB-TRIANGLE (RETURN 3X3-S AS ABOVE IN STIFFNESS PORTION)
C
      KIJ(NPOINT+1) = TEMPAR(1)
      NPOINT = NPOINT + 1
  380 CONTINUE
  400 CONTINUE
      RETURN
C
C     ERROR  EXITS
C
 7770 CALL MESAGE (30,31,NECPT(1))
 7777 NOGO = .TRUE.
      RETURN
 7780 CALL MESAGE (30,32,NECPT(1))
      GO TO 7777
 7790 CALL MESAGE (30,26,NECPT(1))
      GO TO 7777
C
      END


      SUBROUTINE STABLZ(M1,M2,M3,SP)
*
*
*       Zare stability parameter.
*       -------------------------
*
*       Computes the stability parameter (SP) of a 3-body hierarchical
*       binary system with (M1,M2) constituting the inner binary.
*       The system is stable if SP > 1 is returned.
*       Reference:- K. Zare, Celestial Mechanics 16, 35 (1977).
*       Developed by Murray Alexander 1984.
*
      IMPLICIT REAL*8  (A-H,M,O-Z)
      COMMON/AZREG/  TIME3,TMAX,Q(8),P(8),R1,R2,R3,ENERGY,M(3),X3(3,3),
     &               XDOT3(3,3),CM(10),C11,C12,C19,C20,C24,C25,
     &               NSTEP3,NAME3(3),KZ15,KZ27
      REAL*8  M1,M2,M3,AM(3),A(6)
      INTEGER  IC(3,2)
      DATA  IC/2,3,1,3,1,2/
      DATA  ERR/1.0D-6/
*
*
*       Evaluate the total angular momentum.
      DO 10 IA = 1,3
          AM(IA) = 0.0D0
   10 CONTINUE
      DO 30 IA = 1,3
          JA = IC(IA,1)
          KA = IC(IA,2)
          DO 20 I = 1,3
              AM(IA) = AM(IA) + M(I)*(X3(JA,I)*XDOT3(KA,I) -
     &                                X3(KA,I)*XDOT3(JA,I))
   20     CONTINUE
   30 CONTINUE
*
*       Set the bifurcation parameter h*c**2 (note ENERGY = 2*h).
      C1 = 0.5D0*ENERGY*(AM(1)**2 + AM(2)**2 + AM(3)**2)
      A(1) = M3 + M1
      A(2) = 3.0D0*M3 + 2.0D0*M1
      A(3) = 3.0D0*M3 + M1
      A(4) = - A(3)
      A(5) = - (3.0D0*M2 + 2.0D0*M1)
      A(6) = - (M2 + M1)
*
*       Solve quintic equation for the central collinear configuration.
      ICOUNT = 0
      X = 1.0D0
   50 F1 = A(1)
      FP1 = F1*5.0D0
      DO 60 I = 2,5
          F1 = F1*X + A(I)
          FP1 = FP1*X + (6-I)*A(I)
   60 CONTINUE
*
      F1 = F1*X + A(6)
      DX = -F1/FP1
      IF (ABS(DX).GT.ERR) THEN
          X = X + DX
          ICOUNT = ICOUNT + 1
          IF (ICOUNT.LT.20) GO TO 50
          WRITE (6,70)  X
   70     FORMAT (5X,'WARNING!   NO CONVERGENCE IN STABLZ   X =',F8.4)
      END IF
*
*       Compute critical value CCRIT of C1.
      Y = 1.0D0 + X
      FX = M1*M3 + M2*(M3/Y + M1/X)
      GX = M1*M3 + M2*(M3*Y**2 + M1*X**2)
      CCRIT = -0.5D0*FX**2*GX/(M1 + M2 + M3)
*
*       Form stability parameter SP.
      SP = C1/CCRIT
*
      RETURN
*
      END


      SUBROUTINE SVDCMP(A,M,N,MP,NP,W,V)
      PARAMETER (NMAX=100)
      DIMENSION A(MP,NP),W(NP),V(NP,NP),RV1(NMAX)
      G=0.0
      SCALE=0.0
      ANORM=0.0
      DO 25 I=1,N
        L=I+1
        RV1(I)=SCALE*G
        G=0.0
        S=0.0
        SCALE=0.0
        IF (I.LE.M) THEN
          DO 11 K=I,M
            SCALE=SCALE+ABS(A(K,I))
11        CONTINUE
          IF (SCALE.NE.0.0) THEN
            DO 12 K=I,M
              A(K,I)=A(K,I)/SCALE
              S=S+A(K,I)*A(K,I)
12          CONTINUE
            F=A(I,I)
            G=-SIGN(SQRT(S),F)
            H=F*G-S
            A(I,I)=F-G
            IF (I.NE.N) THEN
              DO 15 J=L,N
                S=0.0
                DO 13 K=I,M
                  S=S+A(K,I)*A(K,J)
13              CONTINUE
                F=S/H
                DO 14 K=I,M
                  A(K,J)=A(K,J)+F*A(K,I)
14              CONTINUE
15            CONTINUE
            ENDIF
            DO 16 K= I,M
              A(K,I)=SCALE*A(K,I)
16          CONTINUE
          ENDIF
        ENDIF
        W(I)=SCALE *G
        G=0.0
        S=0.0
        SCALE=0.0
        IF ((I.LE.M).AND.(I.NE.N)) THEN
          DO 17 K=L,N
            SCALE=SCALE+ABS(A(I,K))
17        CONTINUE
          IF (SCALE.NE.0.0) THEN
            DO 18 K=L,N
              A(I,K)=A(I,K)/SCALE
              S=S+A(I,K)*A(I,K)
18          CONTINUE
            F=A(I,L)
            G=-SIGN(SQRT(S),F)
            H=F*G-S
            A(I,L)=F-G
            DO 19 K=L,N
              RV1(K)=A(I,K)/H
19          CONTINUE
            IF (I.NE.M) THEN
              DO 23 J=L,M
                S=0.0
                DO 21 K=L,N
                  S=S+A(J,K)*A(I,K)
21              CONTINUE
                DO 22 K=L,N
                  A(J,K)=A(J,K)+S*RV1(K)
22              CONTINUE
23            CONTINUE
            ENDIF
            DO 24 K=L,N
              A(I,K)=SCALE*A(I,K)
24          CONTINUE
          ENDIF
        ENDIF
        ANORM=MAX(ANORM,(ABS(W(I))+ABS(RV1(I))))
25    CONTINUE
      DO 32 I=N,1,-1
        IF (I.LT.N) THEN
          IF (G.NE.0.0) THEN
            DO 26 J=L,N
              V(J,I)=(A(I,J)/A(I,L))/G
26          CONTINUE
            DO 29 J=L,N
              S=0.0
              DO 27 K=L,N
                S=S+A(I,K)*V(K,J)
27            CONTINUE
              DO 28 K=L,N
                V(K,J)=V(K,J)+S*V(K,I)
28            CONTINUE
29          CONTINUE
          ENDIF
          DO 31 J=L,N
            V(I,J)=0.0
            V(J,I)=0.0
31        CONTINUE
        ENDIF
        V(I,I)=1.0
        G=RV1(I)
        L=I
32    CONTINUE
      DO 39 I=N,1,-1
        L=I+1
        G=W(I)
        IF (I.LT.N) THEN
          DO 33 J=L,N
            A(I,J)=0.0
33        CONTINUE
        ENDIF
        IF (G.NE.0.0) THEN
          G=1.0/G
          IF (I.NE.N) THEN
            DO 36 J=L,N
              S=0.0
              DO 34 K=L,M
                S=S+A(K,I)*A(K,J)
34            CONTINUE
              F=(S/A(I,I))*G
              DO 35 K=I,M
                A(K,J)=A(K,J)+F*A(K,I)
35            CONTINUE
36          CONTINUE
          ENDIF
          DO 37 J=I,M
            A(J,I)=A(J,I)*G
37        CONTINUE
        ELSE
          DO 38 J= I,M
            A(J,I)=0.0
38        CONTINUE
        ENDIF
        A(I,I)=A(I,I)+1.0
39    CONTINUE
      DO 49 K=N,1,-1
        DO 48 ITS=1,30
          DO 41 L=K,1,-1
            NM=L-1
            IF ((ABS(RV1(L))+ANORM).EQ.ANORM)  GO TO 2
            IF ((ABS(W(NM))+ANORM).EQ.ANORM)  GO TO 1
41        CONTINUE
1         C=0.0
          S=1.0
          DO 43 I=L,K
            F=S*RV1(I)
            IF ((ABS(F)+ANORM).NE.ANORM) THEN
              G=W(I)
              H=SQRT(F*F+G*G)
              W(I)=H
              H=1.0/H
              C= (G*H)
              S=-(F*H)
              DO 42 J=1,M
                Y=A(J,NM)
                Z=A(J,I)
                A(J,NM)=(Y*C)+(Z*S)
                A(J,I)=-(Y*S)+(Z*C)
42            CONTINUE
            ENDIF
43        CONTINUE
2         Z=W(K)
          IF (L.EQ.K) THEN
            IF (Z.LT.0.0) THEN
              W(K)=-Z
              DO 44 J=1,N
                V(J,K)=-V(J,K)
44            CONTINUE
            ENDIF
            GO TO 3
          ENDIF
          IF (ITS.EQ.30) PAUSE 'No convergence in 30 iterations'
          X=W(L)
          NM=K-1
          Y=W(NM)
          G=RV1(NM)
          H=RV1(K)
          F=((Y-Z)*(Y+Z)+(G-H)*(G+H))/(2.0*H*Y)
          G=SQRT(F*F+1.0)
          F=((X-Z)*(X+Z)+H*((Y/(F+SIGN(G,F)))-H))/X
          C=1.0
          S=1.0
          DO 47 J=L,NM
            I=J+1
            G=RV1(I)
            Y=W(I)
            H=S*G
            G=C*G
            Z=SQRT(F*F+H*H)
            RV1(J)=Z
            C=F/Z
            S=H/Z
            F= (X*C)+(G*S)
            G=-(X*S)+(G*C)
            H=Y*S
            Y=Y*C
            DO 45 NM=1,N
              X=V(NM,J)
              Z=V(NM,I)
              V(NM,J)= (X*C)+(Z*S)
              V(NM,I)=-(X*S)+(Z*C)
45          CONTINUE
            Z=SQRT(F*F+H*H)
            W(J)=Z
            IF (Z.NE.0.0) THEN
              Z=1.0/Z
              C=F*Z
              S=H*Z
            ENDIF
            F= (C*G)+(S*Y)
            X=-(S*G)+(C*Y)
            DO 46 NM=1,M
              Y=A(NM,J)
              Z=A(NM,I)
              A(NM,J)= (Y*C)+(Z*S)
              A(NM,I)=-(Y*S)+(Z*C)
46          CONTINUE
47        CONTINUE
          RV1(L)=0.0
          RV1(K)=F
          W(K)=X
48      CONTINUE
3       CONTINUE
49    CONTINUE
      RETURN
      END


module riemann_mod

use constants_mod

contains

!! Euler flux
pure function xflux(u,pres) result(f)

    use equations_const_mod

    real(dp), intent(in)    :: u(N_VARS), pres
    real(dp)                :: f(N_VARS)

    real(dp) :: velx

    velx = u(MOMX_VAR)/u(DENS_VAR)

    f(DENS_VAR) = u(MOMX_VAR)
    f(MOMX_VAR) = velx * u(MOMX_VAR) + pres
    f(MOMY_VAR) = velx * u(MOMY_VAR)
    f(MOMZ_VAR) = velx * u(MOMZ_VAR)
    f(ENER_VAR) = velx * (u(ENER_VAR) + pres)

end function

pure function xriemann(U_L,U_R) result(F)

    use equations_const_mod
    use setup_config_mod, only: kappa
    use equations_mod, only: pressure

    real(dp), intent(in) :: U_L(N_VARS), U_R(N_VARS)
    real(dp)             :: F(N_VARS)

    real(dp) :: F_L(N_VARS), F_R(N_VARS)
    real(dp) :: F_HLLE(N_VARS), F_ROEF(N_VARS)

    real(dp) :: p_L,p_R !! pressure
    real(dp) :: c_L,c_R !! pressure
    real(dp) :: H_L,H_R !! enthalpy
    real(dp) :: S_L,S_R !! signal wave speed
    real(dp) :: V_L(N_DIMS),V_R(N_DIMS) !! velocities

    real(dp) :: sqrtrho_L, sqrtrho_R, ssqrtrho
    real(dp) :: roevel(N_DIMS),roeh,roec,absvel,RoeDens

    real(dp) :: dU(N_VARS)      !! jumps
    real(dp) :: alpha(N_VARS)   !! wave strenghts

    real(dp) :: lambda(N_VARS), a_L(N_VARS), a_R(N_VARS), da !! roe eigenvalues
    real(dp) :: r1(N_VARS),r2(N_VARS),r3(N_VARS),r4(N_VARS),r5(N_VARS)  !! roe eigenvectors

    real(dp) :: smooth

    integer :: h

    !! velocities
    V_L = U_L(MOMX_VAR:MOMZ_VAR)/U_L(DENS_VAR)
    V_R = U_R(MOMX_VAR:MOMZ_VAR)/U_R(DENS_VAR)

    !! pressures
    p_L = pressure(U_L)
    p_R = pressure(U_R)

    !! sound speeds
    c_L = SQRT(kappa*p_L/U_L(DENS_VAR))
    c_R = SQRT(kappa*p_R/U_R(DENS_VAR))

    !! enthalpy
    H_L = (U_L(ENER_VAR) + p_L)/U_L(DENS_VAR)
    H_R = (U_R(ENER_VAR) + p_R)/U_R(DENS_VAR)

    !! central fluxes
    F_L = xflux(U_L,p_L)
    F_R = xflux(U_R,p_R)

    !! ---------------------------------------------------------------------- !!

    !! auxiliaries for Roe averages
    SqrtRho_L = SQRT(U_L(DENS_VAR))
    SqrtRho_R = SQRT(U_R(DENS_VAR))
    sSqrtRho  = 1.0_dp/(SqrtRho_L+SqrtRho_R)

    !! Roe averages
    RoeVel    = (SqrtRho_R*V_R + SqrtRho_L*V_L) * sSqrtRho
    absVel    = DOT_PRODUCT(RoeVel,RoeVel)

    !! Roe averages
    RoeH      = (SqrtRho_R*H_R+SqrtRho_L*H_L) * sSqrtRho
    RoeC      = SQRT((kappa-1)*(RoeH-0.5_dp*absVel))

    RoeDens   = SQRT(U_L(DENS_VAR)*U_R(DENS_VAR))

    !! ---------------------------------------------------------------------- !!
    !! Signal velocity estimates by Davis (1988) and Einfeldt (1988)

    S_L = RoeVel(X_DIR) - RoeC
    S_R = RoeVel(X_DIR) + RoeC

    if (S_L .GE. 0.0_dp) then
        F_HLLE = F_L
    elseif (S_R .LE. 0.0_dp) then
        F_HLLE = F_R
    else
        F_HLLE = (S_R*F_L - S_L*F_R + S_L*S_R*(U_R - U_L)) / (S_R - S_L)
    end if

    !! ---------------------------------------------------------------------- !!
    !! eigenvalues

    lambda  = (/ RoeVel(X_DIR)-RoeC,RoeVel(X_DIR),RoeVel(X_DIR),RoeVel(X_DIR),RoeVel(X_DIR)+RoeC/)

    !! eigenvectors
    r1 = (/ 1.0_dp,     lambda(1),  RoeVel(2),  RoeVel(3),  RoeH-RoeVel(1)*Roec /)
    r2 = (/ 1.0_dp,     RoeVel(1),  RoeVel(2),  RoeVel(3),  0.5*absVel          /)
    r3 = (/ 0.0_dp,     0.0_dp,     1.0_dp,     0.0_dp,     RoeVel(2)           /)
    r4 = (/ 0.0_dp,     0.0_dp,     0.0_dp,     1.0_dp,     RoeVel(3)           /)
    r5 = (/ 1.0_dp,     lambda(4),  RoeVel(2),  RoeVel(3),  RoeH+RoeVel(1)*Roec /)

    !! jumps
    dU(1)   = U_R(DENS_VAR) - U_L(DENS_VAR)
    dU(2:4) = V_R - V_L
    dU(5)   = p_R - p_L

    !! wave strenghts
    Alpha(1) = 0.5_dp/(Roec*Roec)*(dU(5) - RoeDens*Roec*dU(2))
    Alpha(2) = dU(1) - dU(5)/(Roec*Roec)
    Alpha(3) = RoeDens*dU(3)
    Alpha(4) = RoeDens*dU(4)
    Alpha(5) = 0.5_dp/(Roec*Roec)*(dU(5) + RoeDens*Roec*dU(2))

    !! entropy fix
    a_L(1) = V_L(X_DIR) - c_L
    a_L(2) = V_L(X_DIR)
    a_L(3) = V_L(X_DIR)
    a_L(4) = V_L(X_DIR)
    a_L(5) = V_L(X_DIR) + c_L

    a_R(1) = V_R(X_DIR) - c_R
    a_R(2) = V_R(X_DIR)
    a_R(3) = V_R(X_DIR)
    a_R(4) = V_R(X_DIR)
    a_R(5) = V_R(X_DIR) + c_R

    do h = 1,N_VARS
        da = max(0.0_dp, lambda(h) - a_L(h), a_R(h) - lambda(h))
        if (abs(lambda(h)) .lt. da) then
            lambda(h) = 0.5_dp*(lambda(h)*lambda(h)/da + da)
        else
            lambda(h) = abs(lambda(h))
        end if
    end do

    !! assemble flux
    F_ROEF = 0.5_dp*((F_L + F_R) - &
           Alpha(1)*lambda(1)*r1 - &
           Alpha(2)*lambda(2)*r2 - &
           Alpha(3)*lambda(3)*r3 - &
           Alpha(4)*lambda(4)*r4 - &
           Alpha(5)*lambda(5)*r5)

    !! ---------------------------------------------------------------------- !!

    smooth = SQRT(abs(p_L - p_R)/(p_L + p_R))
    !smooth = SQRT(abs(p_L/U_L(DENS_VAR) - p_R/U_R(DENS_VAR))/(p_L/U_L(DENS_VAR) + p_R/U_R(DENS_VAR)))

    F = smooth*F_HLLE + (1.0_dp-smooth)*F_ROEF

end function

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

    use equations_const_mod

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

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

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

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

    rf = xriemann(ruL,ruR)

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

end function

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

    use equations_const_mod

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

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

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

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

    rf = xriemann(ruL,ruR)

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

end function

end module


      subroutine runCY_000000(k,l,Xtwiddle,Gtwiddle,Shat6zzzz,N0)
      implicit none
C---  Expression for C0000 obtained from 5.50, following the comment after
C     5.50 on how to add adcing adcitional "00" pairs
C---  Calculates C0000
C---  Small terms of order Xtwiddle(0,k)*C00i,Xtwiddle(0,0)*C00ii
C---  Denominator Gtwiddle(k,l)
      include 'pvCnames.f'
      include 'pvCv.f'
      include 'Carraydef.f'
      include 'Carrays.f'
      integer ep,N0,k,l,np
      parameter(np=2)
      double precision Xtwiddle(0:np,0:np),Gtwiddle(np,np)
      double complex Shat6zzzz(np,z1max,-2:0)

      do ep=-2,0
         Cv(cc000000+N0,ep) =
     . -(-(Gtwiddle(k,1)*Shat6zzzz(1,l,ep)
     .    +Gtwiddle(k,2)*Shat6zzzz(2,l,ep)
     .    +Xtwiddle(k,0)*Cv(czzzzi(l)+N0,ep)
     .    -Xtwiddle(0,0)*Cv(czzzzii(z2(k,l))+N0,ep)
     .        ))/(2d0*Gtwiddle(k,l))

      enddo

      return
      end


!***********************************************************************
!                                                                      *
      SUBROUTINE BRKT
!                                                                      *
!   This subroutine calculates the initial and final state             *
!   radial overlap matrix                                              *
!                                                                      *
!   Written by Per Jonsson                                             *
!                                                                      *
!***********************************************************************
!...Translated by Pacific-Sierra Research 77to90  4.3E  14:08:49   1/ 6/07
!...Modified by Charlotte Froese Fischer
!                     Gediminas Gaigalas  10/05/17
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  DOUBLE
      USE grid_C
      USE tatb_C
      USE biorb_C
      USE wave_C, ONLY:  mfii, pfii, qfii, mfff, pfff, qfff
!-----------------------------------------------
!   I n t e r f a c e   B l o c k s
!-----------------------------------------------
      USE quad_I
      IMPLICIT NONE
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: I, J, L
      REAL(DOUBLE), DIMENSION(NNNW,NNNW) :: BRAKET
      REAL(DOUBLE) :: RESULT
!-----------------------------------------------
!

      DO I = 1, NWII
         DO J = 1, NWFF
            IF (NAKII(I) /= NAKFF(J)) CYCLE
!
!   Determine the maximum tabulation point for the integrand
!
            MTP = MIN(MFII(I),MFFF(J))
!
!   Tabulate the integrand as required for SUBROUTINE QUAD; the
!   value at the first tabulation point is arbitrary
!
            TA = 0.0D0
!            TA(1)=0.D0
            DO L = 2, MTP
               TA(L) = (PFII(L,I)*PFFF(L,J) + QFII(L,I)*QFFF(L,J))*RP(L)
            END DO
!
!   Perform the quadrature
!
            CALL QUAD (RESULT)

            BRAKET(I,J) = RESULT

            WRITE (*, 9) '<', NPII(I), NHII(I), '|', NPFF(J), NHFF(J), '> =', &
               BRAKET(I,J)
         END DO
      END DO
!
    9 FORMAT(A,I2,A,A,I2,A,A,E20.13)

      RETURN
      END SUBROUTINE BRKT


C
C**************************  BASIS  ************************************
C
C  calculates  the local basis function coefficients.
C  basis function coefficients are divided by 6.
C
C***********************************************************************
C
      subroutine basis3d(IP4,TETRAL,X,Y,Z,BIL,CIL,DIL)

      implicit none
      INTEGER   I,J,M,II,NN,LC,LR
      INTEGER   IP3(3,3)
      INTEGER   IP4(4,4),TETRAL(5)
      REAL*8    A2,A3,DELTA
      REAL*8    X(*),Y(*),Z(*),BIL(4),CIL(4),DIL(4)
      REAL*8    AMEN(5)
      DATA      AMEN/-1.0D0,1.0D0,-1.0D0,1.0D0,-1.0D0/
C
      DO NN=1,4
         DO II=2,4
            IP3(II-1,1)=IP4(II,NN)
         END DO
         DO LC=2,3
            DO 7 LR=1,3
               IF(LR.EQ.3) IP3(LR,LC)=IP3(1,LC-1)
               IF(LR.EQ.3) GO TO 7
               IP3(LR,LC)=IP3(LR+1,LC-1)
    7       CONTINUE
         END DO
         A2=0.0D0
         A3=0.0D0
         DO II=1,3
            I=TETRAL(IP3(II,1))
            J=TETRAL(IP3(II,2))
            M=TETRAL(IP3(II,3))
            A3=Y(I)*Z(J)+A3
            A2=Y(I)*Z(M)+A2
         END DO
         DELTA=A3-A2
         BIL(NN)=AMEN(NN)*DELTA/6.0D0
         A2=0.0D0
         A3=0.0D0
         DO II=1,3
            I=TETRAL(IP3(II,1))
            J=TETRAL(IP3(II,2))
            M=TETRAL(IP3(II,3))
            A3=X(I)*Z(J)+A3
            A2=X(I)*Z(M)+A2
         END DO
         DELTA=A3-A2
         CIL(NN)=AMEN(NN+1)*DELTA/6.0D0
         A2=0.0D0
         A3=0.0D0
         DO II=1,3
            I=TETRAL(IP3(II,1))
            J=TETRAL(IP3(II,2))
            M=TETRAL(IP3(II,3))
            A3=X(I)*Y(J)+A3
            A2=X(I)*Y(M)+A2
         END DO
         DELTA=A3-A2
         DIL(NN)=AMEN(NN)*DELTA/6.0D0
      END DO

      return
      end


use booklib, only: interp

implicit none

integer, parameter	:: n=3
real			  	:: x(n),y(n),xx(n)
real 				:: yy(n)
integer				:: i,error
real	            :: result

x(1:3)= (/1.,2.,3./)
y(1:3)= (/1.,1.,1./)

xx(1:3)= (/1.,2.,3./)

do i=1,3
	call interp(x,y,n,xx(i),result,error)
	write(*,*) xx(i),result,error
enddo

end


c Extract needed information from the layered velocity model.

	subroutine vmodel(nl, v, top, depth, vsq, thk, jl, tkj)

	implicit none

	include "hypoDD.inc"

c	Parameters:
	integer	nl
	real	v(MAXLAY)
	real	vsq(MAXLAY)
	real	top(MAXLAY)
	real	depth
	real	thk(MAXLAY)
	integer	jl
	real	tkj

c  input:     nl - number of layers
c           v(l) - velocity of layer l
c	     top - depth to top of layer l
c          depth - depth of event

c         vsq(l) = v(l) ** 2
c         thk(l) - thickness of layer l
c             jl - event layer
c            tkj - depth of event from top of event layer

c	Local variables:
	integer	i

c	compute square of layer velocity
	do 10 i=1,nl
   10	vsq(i)=v(i)*v(i)

c	determine layer thickness and
c	find layer containing event,

	jl=nl

	do 20 i=1,nl

c	Important note:  if (depth.lt.top(i)) will
c	lead to incorrect results for traveltime
	if (depth.le.top(i)) then
	jl=i-1
	goto 25
	endif
   20	continue
   25	continue

	do 30 i=1,nl-1
   30	thk(i)=top(i+1)-top(i)

c	compute depth from top of layer to source

	tkj=depth-top(jl)

	return
c *****	end of subroutine vmodel *****
	end


! =========================================================
subroutine rp1(maxmx,meqn,mwaves,maux,mbc,mx,ql,qr,auxl,auxr,wave,s,amdq,apdq)
! =========================================================

! Solve Riemann problems for the 1D shallow water equations
!   (h)_t + (u h)_x = 0
!   (uh)_t + ( uuh + .5*gh^2 )_x = 0
! using Roe's approximate Riemann solver with entropy fix for
! transonic rarefractions.

! waves: 2
! equations: 2

! Conserved quantities:
!       1 depth
!       2 momentum

! This function solves the Riemann problem at all interfaces in one call

! On input, ql contains the state vector at the left edge of each cell
!           qr contains the state vector at the right edge of each cell
! On output, wave contains the waves,
!            s the speeds,
!            amdq the  left-going flux difference  A^- \Delta q
!            apdq the right-going flux difference  A^+ \Delta q

! Note that the i'th Riemann problem has left state qr(:,i-1)
!                                    and right state ql(:,i)
! From the basic clawpack routine step1, rp is called with ql = qr = q.

    implicit double precision (a-h,o-z)

    dimension   ql(meqn,           1-mbc:maxmx+mbc)
    dimension   qr(meqn,           1-mbc:maxmx+mbc)
    dimension    s(mwaves,         1-mbc:maxmx+mbc)
    dimension wave(meqn,   mwaves, 1-mbc:maxmx+mbc)
    dimension amdq(meqn,           1-mbc:maxmx+mbc)
    dimension apdq(meqn,           1-mbc:maxmx+mbc)

!     # Gravity constant set in the shallow1D.py file
    common /cparam/ grav

!     # Local storage
!     ---------------
    dimension delta(2)
    logical :: efix

    data efix /.true./    !# Use entropy fix for transonic rarefactions

!     # Main loop of the Riemann solver.
    do 30 i=2-mbc,mx+mbc

    !     # compute  Roe-averaged quantities:
        ubar = (qr(2,i-1)/dsqrt(qr(1,i-1)) + ql(2,i)/dsqrt(ql(1,i)))/ &
        ( dsqrt(qr(1,i-1)) + dsqrt(ql(1,i)) )
        cbar=dsqrt(0.5d0*grav*(qr(1,i-1) + ql(1,i)))

    !     # delta(1)=h(i)-h(i-1) and  delta(2)=hu(i)-hu(i-1)
        delta(1) = ql(1,i) - qr(1,i-1)
        delta(2) = ql(2,i) - qr(2,i-1)

    !     # Compute coeffs in the evector expansion of delta(1),delta(2)
        a1 = 0.5d0*(-delta(2) + (ubar + cbar) * delta(1))/cbar
        a2 = 0.5d0*( delta(2) - (ubar - cbar) * delta(1))/cbar

    !     # Finally, compute the waves.
        wave(1,1,i) = a1
        wave(2,1,i) = a1*(ubar - cbar)
        s(1,i) = ubar - cbar

        wave(1,2,i) = a2
        wave(2,2,i) = a2*(ubar + cbar)
        s(2,i) = ubar + cbar

    30 END DO

!     # Compute Godunov flux f0:
!     --------------------------

    if (efix) go to 110

!     # No entropy fix
!     ----------------------------------------------
!     # amdq = SUM s*wave   over left-going waves
!     # apdq = SUM s*wave   over right-going waves

    do 100 m=1,2
        do 100 i=2-mbc, mx+mbc
            amdq(m,i) = 0.d0
            apdq(m,i) = 0.d0
            do 90 mw=1,mwaves
                if (s(mw,i) < 0.d0) then
                    amdq(m,i) = amdq(m,i) + s(mw,i)*wave(m,mw,i)
                else
                    apdq(m,i) = apdq(m,i) + s(mw,i)*wave(m,mw,i)
                endif
            90 END DO
    100 END DO
    go to 900

!    -----------------------------------------------

    110 continue

!     # With entropy fix
!     ------------------

!    # compute flux differences amdq and apdq.
!    # First compute amdq as sum of s*wave for left going waves.
!    # Incorporate entropy fix by adding a modified fraction of wave
!    # if s should change sign.

    do 200 i=2-mbc,mx+mbc

    ! ------------------------------------------------------
    !        # check 1-wave:
    !        ---------------

    !        # u-c in left state (cell i-1)
        s0 = qr(2,i-1)/qr(1,i-1) - dsqrt(grav*qr(1,i-1))

    !        # check for fully supersonic case:
        if (s0 >= 0.d0 .AND. s(1,i) > 0.d0)  then
        !            # everything is right-going
            do 60 m=1,2
                amdq(m,i) = 0.d0
            60 END DO
            go to 200
        endif

    !        # u-c to right of 1-wave
        hr1  = qr(1,i-1) + wave(1,1,i)
        uhr1 = qr(2,i-1) + wave(2,1,i)
        s1 =  uhr1/hr1 - dsqrt(grav*hr1)

        if (s0 < 0.d0 .AND. s1 > 0.d0) then
        !            # transonic rarefaction in the 1-wave
            sfract = s0 * (s1-s(1,i)) / (s1-s0)
        else if (s(1,i) < 0.d0) then
        !	     # 1-wave is leftgoing
            sfract = s(1,i)
        else
        !	     # 1-wave is rightgoing
            sfract = 0.d0   !# this shouldn't happen since s0 < 0
        endif

        do 120 m=1,2
            amdq(m,i) = sfract*wave(m,1,i)
        120 END DO

    ! -------------------------------------------------------
    !        # check 2-wave:
    !        ---------------
    !        # u+c in right state  (cell i)
        s3 = ql(2,i)/ql(1,i) + dsqrt(grav*ql(1,i))

    !        # u+c to left of 2-wave
        hl2  = ql(1,i) - wave(1,2,i)
        uhl2 = ql(2,i) - wave(2,2,i)
        s2 = uhl2/hl2 + dsqrt(grav*hl2)

        if (s2 < 0.d0 .AND. s3 > 0.d0) then
        !            # transonic rarefaction in the 2-wave
            sfract = s2 * (s3-s(2,i)) / (s3-s2)
        else if (s(2,i) < 0.d0) then
        !            # 2-wave is leftgoing
            sfract = s(2,i)
        else
        !            # 2-wave is rightgoing
            go to 200
        endif

        do 160 m=1,2
            amdq(m,i) = amdq(m,i) + sfract*wave(m,2,i)
        160 END DO
    200 END DO

!     # compute the rightgoing flux differences:
!     # df = SUM s*wave   is the total flux difference and apdq = df - amdq

    do 220 m=1,2
        do 220 i = 2-mbc, mx+mbc
            df = 0.d0
            do 210 mw=1,mwaves
                df = df + s(mw,i)*wave(m,mw,i)
            210 END DO
            apdq(m,i) = df - amdq(m,i)
    220 END DO

    900 continue
    return
    end subroutine rp1


  SUBROUTINE stre14(stran,sigma,cm,prop,b,d,varin,ierr,nvar, &
                    plast,elast,curve,np,vms,yieldf,pflag)

   ! computes stresses for plane stress model
   USE mat_dba, ONLY : inte_cr
     IMPLICIT NONE
   ! dummy arguments
   INTEGER (kind=4), INTENT(IN) :: nvar,   & !number of variables per Gauss point
                                   np,     & !number of points in CURVE
                                   yieldf    !yield function type
   INTEGER (kind=4), INTENT(OUT) :: ierr     !flag to indicate error
   REAL (kind=8), INTENT(IN) :: stran(:),  & !(3) log strains
                                cm(:),     & !(4) elasticity coeffs.
                                b(:),d(:), & !yield and potential coefficients
                                prop(:)      !(5) material properties
   REAL (kind=8), INTENT(IN OUT) :: varin(:) !(0-4-7) internal variables
   REAL (kind=8), INTENT(OUT) :: sigma(:),vms!(3) stress & von Mises stress
   REAL (kind=8), POINTER :: curve(:,:)      !(3,np) yield stress
   LOGICAL, INTENT(IN) :: plast,elast
   LOGICAL, INTENT(OUT) :: pflag

   REAL (kind=8), PARAMETER ::  toler=0.55d-2, toler1=0.5d-2, &
                                r23=1.15470053837925153
   INTEGER (kind=4), PARAMETER :: miter=15  !too much

   !local
   REAL (kind=8) :: e11,e22,e12,           & !elastic strains
                    tau(2),                & !transverse shear stresses
                    efpst,                 & !effec plastic strain
                    dstpl(3)                 !plastic strain

   REAL (kind=8) :: c0,c1,c2,c3,yield,aprim,h,hs
   INTEGER(kind=4) :: isohd, i, kinhd

 ! substract plastic strain
 IF( elast )THEN  !no internal variables
   e11 = stran(1)
   e22 = stran(2)
   e12 = stran(3)
 ELSE
   e11 = stran(1) - varin(1)
   e22 = stran(2) - varin(2)
   e12 = stran(3) - varin(3)
 END IF
 ! compute elastic trial stresses in the component local system
 tau = sigma(1:2)
 sigma(1) = cm(1)*e11 + cm(2)*e22
 sigma(2) = cm(2)*e11 + cm(3)*e22
 sigma(3) = cm(4)*e12
 ! check plasticity condition
 IF( plast )THEN
   !    compute material constants
   c0   = prop(1)        !C0 constant or Initial Yield
   c1   = prop(2)        !Efref or Hardening constant
   c2   = prop(3)        !exponent
   c3   = prop(4)        !residual flow stress
   isohd = INT(prop(5))  !isotropic hardening type

   efpst = varin(nvar+1)    !effective plastic strain (last converged)
   IF( isohd == 5 ) THEN        !for points defined yield value
     i = 1   !begin at first interval
     yield = inte_cr (curve,np,efpst,i)
     aprim = curve(3,i)
   ELSE
     CALL isoha14(isohd,yield,aprim,efpst,c0,c1,c2,c3)
   END IF
   IF( prop(6) > 0d0 ) THEN
     h = prop(6)*2.75d0     !?????
     kinhd = 2
     IF( prop(7) > 0d0 ) THEN
       hs = prop(7)*2.5d0   !?????
       kinhd = 3
     END IF
   ELSE
     kinhd = 1
   END IF

   SELECT CASE (yieldf)
   CASE (2,3)
     CALL corr14(sigma(1),sigma(2),sigma(3),efpst,cm(:),b(:),d(:), &
                 ierr,dstpl,yield,aprim,vms,tau(1),tau(2),kinhd,h,hs,varin(:))
   CASE (4)
     CALL corr14_79(sigma(1),sigma(2),sigma(3),efpst,cm(:),d(:), &
                 ierr,dstpl,yield,aprim,vms,tau(1),tau(2))
   CASE (5)
     CALL corr14_90(sigma(1),sigma(2),sigma(3),efpst,cm(:),d(:),b(:), &
                 ierr,dstpl,yield,aprim,vms,tau(1),tau(2))
   END SELECT
   IF(efpst > 0d0 )THEN   !if plastic step, update internal variables
     varin(1:3) = varin(1:3) + dstpl
     varin(nvar+1) =  efpst  + varin(nvar+1)  !total (explicit)
     pflag = .TRUE.
   END IF
 ELSE
   vms = SQRT(sigma(1)**2+sigma(2)**2-sigma(1)*sigma(2)+3d0*(sigma(3)**2+tau(1)**2+tau(2)**2))
 END IF

 RETURN

 CONTAINS

 SUBROUTINE corr14(st11,st22,st12,efpst,c,b,d,ierr,dstpl,yield,aprim, &
                   fi,tx,ty,kinhd,h,hs,varin)
 !-------------------------------------------------------------------
 !
 !     Hill 48 Planar and transversal Anisotropy (Mises as a special case)
 !     Associative and non-Associative
 !     with Isotropic/Kinematic hardening
 !
 !-------------------------------------------------------------------
 IMPLICIT NONE

 REAL (kind=8),INTENT(IN) :: c(:),      & !elasticity matrix (orthotropic)
                             b(:),      & !flow rule matrix
                             d(:),      & !yield function derivative
                             tx,ty,     & !transverse shear stresses
                             h,hs         !kinematic hardening modulus
 REAL (kind=8),INTENT(IN OUT) :: st11,st22,st12   !trial and corrected stresses
 REAL (kind=8),INTENT(IN OUT) :: efpst,  &    !effective plastic strain
                             yield,aprim,&!isotropic hardening parameters
                             varin(:)     !internal variables
                                          !(IN) present   (OUT) increment
 REAL (kind=8),INTENT(OUT) :: dstpl(3),fi !increment in plastic strains & vms
 INTEGER (kind=4), INTENT(OUT) :: ierr    !error flag (0: O.K., 1:error)
 INTEGER (kind=4), INTENT(IN) :: kinhd    !kinematic hardening(1,2,3)

 !local variables

  REAL (kind=8) :: s11,s22,s12,epbar,f0,a1,a2,a3,txy, &
                   ap,ddl,de,det,r1,r2,r3,po,bs(3)

  INTEGER (kind=4) k

 !------------ begin

  !     calculate initial effective stress
  !   keep original stresses to compute plastic strain increments
  IF( kinhd == 1 )THEN
   s11 = st11
   s22 = st22
   s12 = st12
  ELSE
   s11 = st11 - varin(5)
   s22 = st22 - varin(6)
   s12 = st12 - varin(7)
  END IF

  ! derivative of yield function  (initial flow rule)
  a1 = (d(1)*s11 + d(2)*s22)
  a2 = (d(2)*s11 + d(3)*s22)
  a3 =  d(4)*s12
  txy=  d(5)*tx*tx+d(6)*ty*ty
  fi = SQRT(a1*s11+a2*s22+a3*s12+txy)

  !     check initial yield FUNCTION

  f0 = fi-yield
  IF((f0-toler*fi) <=  0d0) THEN

     !   IF the point is elastic

    efpst = 0d0          !no plastic flow

  ELSE

    !   start iteration for satisfying consistency condition
    !dl = 0d0
    epbar = 0
    DO k = 1,miter
      ! derivative of yield function  A s
      a1 = a1/fi
      a2 = a2/fi
      a3 = a3/fi
      ! compute flow rule
      r1 = (b(1)*s11 + b(2)*s22)
      r2 = (b(2)*s11 + b(3)*s22)
      r3 =  b(4)*s12
      po = SQRT(r1*s11+r2*s22+r3*s12)   !potencial
      r1 = r1/po
      r2 = r2/po
      r3 = r3/po
      ! compute d eps/ d lambda
      !     based on the standard definition of equivalent plastic strain
      de = r23*SQRT(r1*r1+r2*r2+r1*r2+r3*r3/4d0)  !d eps/ d lambda
      !     based on the plastic work
      !de = po/fi         !ratio of equivalent stress (potential/yield)
      !IF( kinhd > 1 ) de = de + (r1*varin(5)+r2*varin(6)+r3*varin(7))/fi    !r . alpha / fi
      ap = de*aprim      !A' = d Yield_Stress/ d lambda
      IF( kinhd > 1 )THEN
        ap = ap + (a1*r1 + a2*r2 + a3*r3/2d0)*h  ! A' + H r.a
        IF( kinhd == 3 )  ap = ap - de*(a1*varin(5)+a2*varin(6)+a3*varin(7))*hs ! - Hs * deps * a . alpha
      END IF
      ddl = f0/(c(1)*r1*a1+2d0*c(2)*r1*a2+c(3)*r2*a2+c(4)*r3*a3+ap)
      !  updates effective stresses
      s11 = s11 - ddl*(c(1)*r1+c(2)*r2)
      s22 = s22 - ddl*(c(2)*r1+c(3)*r2)
      s12 = s12 - ddl*c(4)*r3
      IF( kinhd > 1 )THEN
        bs(1) =  ddl*h*r1       !increments in back stress
        bs(2) =  ddl*h*r2
        bs(3) =  ddl*h*r3/2d0
        IF( kinhd == 3 ) bs(1:3) = bs(1:3) - ddl*de*hs*varin(5:7)  !use present back stress
        s11 = s11 - bs(1)       !new deviatoric strees
        s22 = s22 - bs(2)
        s12 = s12 - bs(3)
        varin(5:7) = varin(5:7) + bs(1:3)  !update back stress
      END IF
      !   calculate the effective plastic strain
      epbar = epbar + ddl*de
      !   update the radius of the yield surface
      yield = yield + aprim*ddl*de
      ! derivative of yield function
      a1 = (d(1)*s11 + d(2)*s22)
      a2 = (d(2)*s11 + d(3)*s22)
      a3 =  d(4)*s12
      fi = SQRT(a1*s11+a2*s22+a3*s12+txy)
      f0 = fi-yield     !yield function
      !  IF consistency condition is satisfied exit loop
      IF( ABS(f0/yield) <= toler1 )EXIT
    END DO

    IF( k <= miter )THEN
      IF( kinhd > 1)THEN
        s11 = s11 + varin(5)
        s22 = s22 + varin(6)
        s12 = s12 + varin(7)
      END IF
      !  stress change
      a1 = st11 - s11
      a2 = st22 - s22
      a3 = st12 - s12
      !  assign corrected stresses
      st11 = s11
      st22 = s22
      st12 = s12
      ! increments in plastic strains
      det = c(1)*c(3) - c(2)*c(2)
      dstpl(1) = (a1*c(3)-c(2)*a2)/det
      dstpl(2) = (a2*c(1)-c(2)*a1)/det
      dstpl(3) = a3/c(4)
      efpst = epbar                      !increment in effective plastic strain

    ELSE
      !        IF the iterations are greater than maximum STOP
      WRITE(*,*)' NO convergence in constitutive equation * STOP *'
      ierr=1                    !set flag to error in plastic integration
    END IF
  END IF

  RETURN

 END SUBROUTINE corr14

 SUBROUTINE corr14_79(st11,st22,st12,efpst,c,d,ierr,dstpl,yield,aprim,fi,tx,ty)
 !-------------------------------------------------------------------
 !
 !     Hill 79 transversal Anisotropy
 !
 !-------------------------------------------------------------------
 IMPLICIT NONE

 REAL (kind=8),INTENT(IN) :: c(:),      & !elasticity matrix (orthotropic)
                             d(:),      & !yield function constants
                             tx,ty        !transverse shear stresses
 REAL (kind=8),INTENT(IN OUT) :: st11,st22,st12   !trial and corrected stresses
 REAL (kind=8),INTENT(IN OUT) :: efpst,  &    !effective plastic strain
                             yield,aprim  !isotropic hardening parameters
                                          !(IN) present   (OUT) increment
 REAL (kind=8),INTENT(OUT) :: dstpl(3),fi !increment in plastic strains & vms
 INTEGER (kind=4), INTENT(OUT) :: ierr    !error flag (0: O.K., 1:error)

 !local variables

  REAL (kind=8) :: s11,s22,s12,epbar,f0,fm,a1,a2,a3,txy, &
                   ddl,det,r2,summ,diff,m,mp,mq,k1,k2,fact,aa,atca !,rr

  INTEGER (kind=4) k

 !------------ begin

  m  = d(1)        !Hill exponent
  mp = (1d0-m)/m   !auxiliar
  mq = m/2d0-1d0   !auxiliar
  k1 = d(2)        !a
  k2 = d(3)        !b

  !     calculate initial effective stress
  s11 = st11
  s22 = st22
  s12 = st12

  summ = s11+s22
  diff = s11-s22
  txy = 4d0*(tx*tx+ty*ty)
  r2 = diff*diff + 4d0*s12*s12 + txy           !radius (squared)
  fm = k1 * ((ABS(summ))**m) + k2 * r2**(m/2d0)
  fi = fm**(1d0/m)                             !equivalent stress

  !     check initial yield FUNCTION

  f0 = fi-yield                                !yield function
  IF((f0-toler*fi) <=  0d0) THEN

     !   IF the point is elastic

    efpst = 0d0          !no plastic flow

  ELSE

    !   start iteration for satisfying consistency condition
    epbar = 0
    DO k = 1,miter
      ! Compute flow rule
      fact = fm**mp / m
      aa = k2 * m * r2**mq

      a2 = m * k1 * summ * (ABS(summ)**(m-2d0))
      a1 = (a2 + aa * diff) *fact
      a2 = (a2 - aa * diff) *fact
      a3 = (4d0 * aa * s12) *fact

      atca = (c(1)*a1*a1+2d0*c(2)*a1*a2+c(3)*a2*a2+c(4)*a3*a3) !  Tr(a):C:a
      ddl = f0/(atca + aprim)  !Initial value for dlam
      ! correct stresses
      s11 = s11 - ddl*(c(1)*a1+c(2)*a2)
      s22 = s22 - ddl*(c(2)*a1+c(3)*a2)
      s12 = s12 - ddl*c(4)*a3
      !   calculate the effective plastic strain
      epbar = epbar + ddl
      !   update the radius of the yield surface
      yield = yield + aprim*ddl
      !   compute the yield function
      summ = s11+s22
      diff = s11-s22
      r2 = diff*diff + 4d0*s12*s12 + txy                 !radius (squared)
      fm = k1 * ((ABS(summ))**m) + k2 * r2**(m/2d0)
      fi = fm**(1d0/m)
      !     check yield FUNCTION
      f0 = fi-yield     !yield function
      !  IF consistency condition is satisfied exit loop
      IF( ABS(f0/yield) <= toler1 )EXIT
    END DO

    IF( k <= miter )THEN
      !  stress change
      a1 = st11 - s11
      a2 = st22 - s22
      a3 = st12 - s12
      !  assign corrected stresses
      st11 = s11
      st22 = s22
      st12 = s12
      ! increments in plastic strains
      det = c(1)*c(3) - c(2)*c(2)
      dstpl(1) = (a1*c(3)-c(2)*a2)/det
      dstpl(2) = (a2*c(1)-c(2)*a1)/det
      dstpl(3) = a3/c(4)
      efpst = epbar                      !increment in effective plastic strain

    ELSE
      !        IF the iterations are greater than maximum STOP
      WRITE(*,*)' NO convergence in constitutive equation * STOP *'
      ierr=1                    !set flag to error in plastic integration
    END IF
  END IF

  RETURN

 END SUBROUTINE corr14_79

 SUBROUTINE corr14_90(st11,st22,st12,efpst,c,d,b,ierr,dstpl,yield,aprim,fi,tx,ty)
 !-------------------------------------------------------------------
 !
 !     Hill 90 Planar and transversal Anisotropy
 !
 !-------------------------------------------------------------------
 IMPLICIT NONE

 REAL (kind=8),INTENT(IN) :: c(:),      & !elasticity matrix (orthotropic)
                             d(:),      & !yield function constants
                             b(:),      & !yield function constants
                             tx,ty        !transverse shear stresses
 REAL (kind=8),INTENT(IN OUT) :: st11,st22,st12   !trial and corrected stresses
 REAL (kind=8),INTENT(IN OUT) :: efpst,  &    !effective plastic strain
                             yield,aprim  !isotropic hardening parameters
                                          !(IN) present   (OUT) increment
 REAL (kind=8),INTENT(OUT) :: dstpl(3),fi !increment in plastic strains & vms
 INTEGER (kind=4), INTENT(OUT) :: ierr    !error flag (0: O.K., 1:error)

 !local variables

  REAL (kind=8) :: s11,s22,s12,epbar,f0,fm,a1,a2,a3,af,bf,kf,bi,mp,fact,f1, &
                   ddl,det,r2,r2b,summ,diff,s2,m,m21,m22,m2,aa,bb,atca,rr,c0,txy,txy2

  INTEGER (kind=4) k

 !------------ begin

  m  = d(1)        !Hill exponent
  kf = d(2)        !(sigma/tau)^m
  af = d(3)        !a
  bf = d(4)        !b
  bi  = b(1)       !2do*biuni
  m21 = b(2)       !m/2d0-1d0  !auxiliar

  !     calculate initial effective stress
  s11 = st11
  s22 = st22
  s12 = st12
  !     compute yield function
  summ = s11+s22  !sum of normal stresses
  diff = s11-s22  !diff of normal stresses
  txy = 4d0*(tx*tx+ty*ty)
  txy2= txy/2d0
  r2  = diff*diff + 4d0*s12*s12 + txy     !Diameter of Circle (squared)
  r2b = s11*s11 + s22*s22 + 2d0*s12*s12 + txy2  !auxiliar value (squared)
  s2  = s11*s11  - s22*s22                !difference of squared normal stresses
  fm = (ABS(summ))**m + kf * r2**(m/2d0)  !first two component of yield function
  rr = -2d0*af*s2 + bf*diff*diff          !auxiliar
  IF (r2b > 0d0)  fm = fm + r2b**m21 * rr
  fi = fm**(1d0/m)/bi                     !equivalent stress (rolling dir)

  !     check initial yield FUNCTION
  f0 = fi-yield                           !yield function
  IF((f0-toler*fi) <=  0d0) THEN

     !   IF the point is elastic

    efpst = 0d0          !no plastic flow

  ELSE

    !   start iteration for satisfying consistency condition
    m22 = m21-1d0    !m/2-2    !auxiliar exponent
    c0 = b(3)        !ep/e0
    m2  = b(4)       !m-2      !auxiliar exponent
    mp = 1d0/m-1d0   !1/m -1   !auxiliar exponent
    epbar = 0        !initializes increment in equivalent plastic strain
    DO k = 1,miter   !iterate until convergence
      ! compute flow rule
      fact = fm**mp  /m /bi   !g^(1/m-1)/(m 2bi)
      aa = kf * m * r2**m21           !c*n*(D^2)^(m/2-1)
      a2 = m * summ * (ABS(summ)**m2) !first term of derivative
      a1 = a2 + aa * diff             !add second term
      a2 = a2 - aa * diff
      a3 = 4d0 * aa * s12
      ! until now the terms from Hill 79
      aa = m21 * r2b**m22 * 2d0 * rr
      bb = r2b**m21
      a1 = (a1 + aa * s11 - bb * (4d0*af*s11 - 2d0 * bf * diff))*fact
      a2 = (a2 + aa * s22 + bb * (4d0*af*s22 - 2d0 * bf * diff))*fact
      a3 = (a3 + aa * 2d0 * s12 )*fact
      atca = (c(1)*a1*a1+2d0*c(2)*a1*a2+c(3)*a2*a2+c(4)*a3*a3) !Tr(a):C:a
      f1 = SQRT((a1*a1+a2*a2+a1*a2+a3*a3/4d0)*1.333333333333333)/c0
      ddl = f0/(atca + aprim*f1)  !increment in consistency parameter
      s11 = s11 - ddl*(c(1)*a1+c(2)*a2)
      s22 = s22 - ddl*(c(2)*a1+c(3)*a2)
      s12 = s12 - ddl*c(4)*a3

      !   calculate the effective plastic strain
      ddl = ddl*f1           !increment in effective plastic strain (rolling)
      epbar = epbar + ddl    !
      !   update the radius of the yield surface
      yield = yield + aprim*ddl
      !   calculate the effective stress
      summ = s11+s22
      diff = s11-s22
      r2  = diff*diff + 4d0*s12*s12 + txy            !radius (squared)
      r2b = s11*s11 + s22*s22 + 2d0*s12*s12 + txy2
      s2  = s11*s11  - s22*s22
      fm = (ABS(summ))**m + kf * r2**(m/2d0)
      rr = -2d0*af*s2 + bf*diff*diff
      IF (r2b > 0d0)  fm = fm + r2b**m21 * rr
      fi = fm**(1d0/m)/bi                           !equivalent stress
      !     check yield FUNCTION
      f0 = fi-yield              !yield function
      !  IF consistency condition is satisfied exit loop
      IF( ABS(f0/yield) <= toler1 )EXIT
    END DO

    IF( k <= miter )THEN
      !  stress change
      a1 = st11 - s11
      a2 = st22 - s22
      a3 = st12 - s12
      !  assign corrected stresses
      st11 = s11
      st22 = s22
      st12 = s12
      ! increments in plastic strains
      det = c(1)*c(3) - c(2)*c(2)
      dstpl(1) = (a1*c(3)-c(2)*a2)/det
      dstpl(2) = (a2*c(1)-c(2)*a1)/det
      dstpl(3) = a3/c(4)
      efpst = epbar                      !increment in effective plastic strain

    ELSE
      !        IF the iterations are greater than maximum STOP
      WRITE(*,*)' NO convergence in constitutive equation * STOP *'
      ierr=1                    !set flag to error in plastic integration
    END IF
  END IF

  RETURN

 END SUBROUTINE corr14_90

 END SUBROUTINE stre14


!+
MODULE Atmosphere1976
! ---------------------------------------------------------------------------
! PURPOSE - Compute properties of the U.S. Standard Atmosphere 1976
! AUTHORS - Steven S. Pietrobon.
!           Ralph L. Carmichael, Public Domain Aeronautical Software
!
!     REVISION HISTORY
!   DATE  VERS PERSON  STATEMENT OF CHANGES
! 28Feb95  0.1   RLC   Assembled several old codes
!  1Aug00  0.2   RLC   Copied from old Tables76
! 23Aug00  0.3   RLC   Added NitrogenNumber using QUANC8
! 24Aug00  0.4   RLC   Added KineticTemperatureGradient
! 30Aug00  0.5   RLC   Corrected numerous errors
! 30Dec00  0.6   RLC   Adapted UpperAtmosphere from Pietrobon's Unofficial
!                        Australian Standard Atmosphere
!----------------------------------------------------------------------------
IMPLICIT NONE
  CHARACTER(LEN=*),PUBLIC,PARAMETER:: ATM76_VERSION = "0.6 (12 Sept 2000)"
  real(8),PRIVATE,PARAMETER:: PI = 3.14159265
  real(8),PARAMETER:: REARTH = 6356.766               ! radius of the Earth (km)
  real(8),PARAMETER:: GMR = 34.163195                             ! gas constant
  real(8),PARAMETER:: GZERO = 9.80665 !  accel. of gravity, m/sec^2

!  real(8),PARAMETER:: FT2METERS = 0.3048       ! mult. ft. to get meters (exact)
!  real(8),PARAMETER:: KELVIN2RANKINE = 1.8             ! mult K to get deg R
!  real(8),PARAMETER:: PSF2NSM = 47.880258          ! mult lb/sq.ft to get N/sq.m
!  real(8),PARAMETER:: SCF2KCM = 515.379         ! mult slug/cu.ft to get kg/cu.m
  real(8),PARAMETER:: TZERO = 288.15                ! temperature at sealevel, K
  real(8),PARAMETER:: PZERO = 101325.0            ! pressure at sealevel, N/sq.m
  real(8),PARAMETER:: RHOZERO = 1.2250            ! density at sealevel, kg/cu.m
  real(8),PARAMETER:: RSTAR = 8314.32       ! perfect gas constant, N-m/(kmol-K)
  real(8),PARAMETER:: ASOUNDZERO = 340.294   ! speed of sound at sealevel, m/sec

  real(8),PARAMETER:: BETAVISC = 1.458E-6    ! viscosity term, N s/(sq.m sqrt(K)
  real(8),PARAMETER:: SUTH = 110.4                    ! Sutherland's constant, K

  real(8),PARAMETER:: MZERO      = 28.9644 ! molecular weight of air at sealevel
!  real(8),PARAMETER:: AVOGADRO =  6.022169E26        ! 1/kmol, Avogadro constant
!  real(8),PARAMETER:: BOLTZMANN = 1.380622E-23        ! Nm/K, Boltzmann constant

! TABLE 5 - DEFINITION OF KINETIC TEMPERATURE FROM 86 km to 1000 km
  real(8),PARAMETER:: Z7 =  86.0,  T7=186.8673
  real(8),PARAMETER:: z8 =  91.0,  T8=T7
  real(8),PARAMETER:: Z9 = 110.0,  T9=240.0
  real(8),PARAMETER:: Z10= 120.0, T10=360.0
!  real(8),PARAMETER:: Z11= 500.0, T11=999.2356   ! not used
  real(8),PARAMETER:: Z12=1000.0, T12=1000.0

  real(8),PARAMETER:: FT2METERS = 0.3048               ! mult. ft. to get meters (exact)
  real(8),PARAMETER:: KELVIN2RANKINE = 1.8             ! mult deg K to get deg R
  real(8),PARAMETER:: PSF2NSM = 47.880258          ! mult lb/sq.ft to get N/sq.m
  real(8),PARAMETER:: SCF2KCM = 515.379         ! mult slug/cu.ft to get kg/cu.m

CONTAINS

!+
FUNCTION EvaluateCubic(a,fa,fpa, b,fb,fpb, u) RESULT(fu)
! ---------------------------------------------------------------------------
! PURPOSE - Evaluate a cubic polynomial defined by the function and the
!   1st derivative at two points
  real(8),INTENT(IN):: u   ! point where function is to be evaluated
  real(8),INTENT(IN):: a,fa,fpa   ! a, f(a), f'(a)  at first point
  real(8),INTENT(IN):: b,fb,fpb   ! b, f(b), f'(b)  at second point
  real(8):: fu                    ! computed value of f(u)

  real(8):: d,t,p
!----------------------------------------------------------------------------
  d=(fb-fa)/(b-a)
  t=(u-a)/(b-a)
  p=1.0-t

  fu = p*fa + t*fb - p*t*(b-a)*(p*(d-fpa)-t*(d-fpb))
  RETURN
END Function EvaluateCubic   ! ----------------------------------------------

!+
FUNCTION KineticTemperature(z) RESULT(t)
!   -------------------------------------------------------------------------
! PURPOSE - Compute kinetic temperature above 86 km.

  real(8),INTENT(IN)::  z     ! geometric altitude, km.
  real(8):: t     ! kinetic temperature, K

  real(8),PARAMETER:: C1 = -76.3232  ! uppercase A in document
  real(8),PARAMETER:: C2 = 19.9429   ! lowercase a in document
  real(8),PARAMETER:: C3 = 12.0
  real(8),PARAMETER:: C4 = 0.01875   ! lambda in document
  real(8),PARAMETER:: TC = 263.1905

  real(8):: xx,yy
!----------------------------------------------------------------------------
  IF (z <= Z8) THEN
    t=T7
  ELSE IF (z < Z9) THEN
    xx=(z-Z8)/C2                        ! from Appendix B, p.223
    yy=SQRT(1.0-xx*xx)
    t=TC+C1*yy
  ELSE IF (z <= Z10) THEN
    t=T9+C3*(z-Z9)
  ELSE
    xx=(REARTH+Z10)/(REARTH+z)
    yy=(T12-T10)*EXP(-C4*(z-Z10)*xx)
    t=T12-yy
  END IF

  RETURN
END Function KineticTemperature   ! -----------------------------------------

!+
SUBROUTINE UpperAtmosphere(alt, sigma, delta, theta)
!   -------------------------------------------------------------------------
! PURPOSE - Compute the properties of the 1976 standard atmosphere from
!   86 km. to 1000 km.

  IMPLICIT NONE
!============================================================================
!     A R G U M E N T S                                                     |
!============================================================================
  real(8),INTENT(IN)::  alt    ! geometric altitude, km.
!  real(8),INTENT(INOUT)
real(8):: sigma  ! density/sea-level standard density
!  real(8),INTENT(INOUT)
real(8):: delta  ! pressure/sea-level standard pressure
!  real(8),INTENT(INOUT)
real(8):: theta  ! temperature/sea-level standard temperature
!============================================================================
!     L O C A L   C O N S T A N T S                                         |
!============================================================================

! altitude table (m)
  real(8),PARAMETER,DIMENSION(23):: Z = (/      &
     86.,  93., 100., 107., 114., &
    121., 128., 135., 142., 150., &
    160., 170., 180., 190., 200., &
    250., 300., 400., &
    500., 600., 700., 800., 1000. /)

! pressure table  (Pa)
!  real(8),PARAMETER,DIMENSION(SIZE(Z)):: P = (/                                &
!    3.7338e-1, 1.0801e-1, 3.2011e-2, 1.0751E-2, 4.4473e-3, &
!    2.3402e-3, 1.4183e-3, 9.3572e-4, 6.5297e-4, 4.5422e-4, &
!    3.0397e-4, 2.1212e-4, 1.5273e-4, 1.1267e-4, 8.4743e-5, &
!    2.4767e-5, 8.7704e-6, 1.4518e-6, &
!    3.0236e-7, 8.2130e-8, 3.1908e-8, 1.7036e-8, 7.5138e-9 /)

! density table  kg/m**3
!  real(8),PARAMETER,DIMENSION(SIZE(Z)):: RHO = (/                              &
!    6.9579e-06, 1.9997e-06, 5.6041e-07, 1.6426E-07, 4.9752e-08, &
!    1.9768e-08, 9.7173e-09, 5.4652e-09, 3.3580e-09, 2.0757e-09, &
!    1.2332e-09, 7.8155e-10, 5.1944e-10, 3.5808e-10, 2.5409e-10, &
!    6.0732e-11, 1.9160e-11, 2.8031e-12, &
!    5.2159e-13, 1.1369e-13, 3.0698e-14, 1.1361e-14, 3.5614e-15 /)

!fit2000
  real(8),PARAMETER,DIMENSION(SIZE(Z)):: LOGP = (/               &
  -0.985159,  -2.225531,  -3.441676,  -4.532756,  -5.415458,  &
  -6.057519,  -6.558296,  -6.974194,  -7.333980,  -7.696929,  &
  -8.098581,  -8.458359,  -8.786839,  -9.091047,  -9.375888,  &
 -10.605998, -11.644128, -13.442706, -15.011647, -16.314962,  &
 -17.260408, -17.887938, -18.706524 /)

 real(8),PARAMETER,DIMENSION(SIZE(Z)):: DLOGPDZ = (/             &
 -11.875633, -13.122514, -14.394597, -15.621816, -16.816216,  &
 -17.739201, -18.449358, -19.024864, -19.511921, -19.992968,  &
 -20.513653, -20.969742, -21.378269, -21.750265, -22.093332,  &
 -23.524549, -24.678196, -26.600296, -28.281895, -29.805302,  &
 -31.114578, -32.108589, -33.268623 /)

  real(8),PARAMETER,DIMENSION(SIZE(Z)):: LOGRHO = (/             &
  -0.177700,  -0.176950,  -0.167294,  -0.142686,  -0.107868,  &
  -0.079313,  -0.064668,  -0.054876,  -0.048264,  -0.042767,  &
  -0.037847,  -0.034273,  -0.031539,  -0.029378,  -0.027663,  &
  -0.022218,  -0.019561,  -0.016734,  -0.014530,  -0.011315,  &
  -0.007673,  -0.005181,  -0.003500 /)

  real(8),PARAMETER,DIMENSION(SIZE(Z)):: DLOGRHODZ = (/          &
  -0.177900,  -0.180782,  -0.178528,  -0.176236,  -0.154366,  &
  -0.113750,  -0.090551,  -0.075044,  -0.064657,  -0.056087,  &
  -0.048485,  -0.043005,  -0.038879,  -0.035637,  -0.033094,  &
  -0.025162,  -0.021349,  -0.017682,  -0.016035,  -0.014330,  &
  -0.011626,  -0.008265,  -0.004200 /)

!============================================================================
!     L O C A L   V A R I A B L E S                                         |
!============================================================================
  INTEGER:: i,j,k                                                  ! counters
!  real(8):: h                                       ! geopotential altitude (km)
!  real(8):: tgrad, tbase      ! temperature gradient and base temp of this layer
!  real(8):: tlocal                                           ! local temperature
!  real(8):: deltah                             ! height above base of this layer

  real(8):: p,rho
!----------------------------------------------------------------------------

  IF (alt >= Z(SIZE(Z))) THEN          ! trap altitudes greater than 1000 km.
    delta=1E-20
    sigma=1E-21
    theta=1000.0/TZERO
    RETURN
  END IF

  i=1
  j=SIZE(Z)                                    ! setting up for binary search
  DO
    k=(i+j)/2                                              ! integer division
    IF (alt < Z(k)) THEN
      j=k
    ELSE
      i=k
    END IF
    IF (j <= i+1) EXIT
  END DO

  p=EXP(EvaluateCubic(Z(i),LOGP(i),DLOGPDZ(i), &
                      Z(i+1),LOGP(i+1),DLOGPDZ(i+1), alt))
  delta=p/PZERO

  rho=EXP(EvaluateCubic(Z(i),LOGRHO(i),DLOGRHODZ(i), &
                      Z(i+1),LOGRHO(i+1),DLOGRHODZ(i+1), alt))
  sigma=rho/RHOZERO

  theta=KineticTemperature(alt)/TZERO
  RETURN
END Subroutine UpperAtmosphere   ! ------------------------------------------

!+
SUBROUTINE LowerAtmosphere(alt, sigma, delta, theta)
!   -------------------------------------------------------------------------
! PURPOSE - Compute the properties of the 1976 standard atmosphere to 86 km.

  IMPLICIT NONE
!============================================================================
!     A R G U M E N T S                                                     |
!============================================================================
  real(8),INTENT(IN)::  alt    ! geometric altitude, km.
  real(8),INTENT(INOUT):: sigma  ! density/sea-level standard density
  real(8),INTENT(INOUT):: delta  ! pressure/sea-level standard pressure
  real(8),INTENT(INOUT):: theta  ! temperature/sea-level standard temperature
!============================================================================
!     L O C A L   C O N S T A N T S                                         |
!============================================================================
  real(8),PARAMETER:: REARTH = 6369.0                 ! radius of the Earth (km)
  real(8),PARAMETER:: GMR = 34.163195                             ! gas constant
  INTEGER,PARAMETER:: NTAB=8       ! number of entries in the defining tables
!============================================================================
!     L O C A L   V A R I A B L E S                                         |
!============================================================================
  INTEGER:: i,j,k                                                  ! counters
  real(8):: h                                       ! geopotential altitude (km)
  real(8):: tgrad, tbase      ! temperature gradient and base temp of this layer
  real(8):: tlocal                                           ! local temperature
  real(8):: deltah                             ! height above base of this layer
!============================================================================
!     L O C A L   A R R A Y S   ( 1 9 7 6   S T D.  A T M O S P H E R E )   |
!============================================================================
  real(8),DIMENSION(NTAB),PARAMETER:: htab= &
                          (/0.0, 11.0, 20.0, 32.0, 47.0, 51.0, 71.0, 84.852/)
  real(8),DIMENSION(NTAB),PARAMETER:: ttab= &
          (/288.15, 216.65, 216.65, 228.65, 270.65, 270.65, 214.65, 186.946/)
  real(8),DIMENSION(NTAB),PARAMETER:: ptab= &
               (/1.0, 2.233611E-1, 5.403295E-2, 8.5666784E-3, 1.0945601E-3, &
                                     6.6063531E-4, 3.9046834E-5, 3.68501E-6/)
  real(8),DIMENSION(NTAB),PARAMETER:: gtab= &
                                (/-6.5, 0.0, 1.0, 2.8, 0.0, -2.8, -2.0, 0.0/)
!----------------------------------------------------------------------------
  h=alt*REARTH/(alt+REARTH)      ! convert geometric to geopotential altitude

  i=1
  j=NTAB                                  ! setting up for binary search
  DO
    k=(i+j)/2                                              ! integer division
    IF (h < htab(k)) THEN
      j=k
    ELSE
      i=k
    END IF
    IF (j <= i+1) EXIT
  END DO

  tgrad=gtab(i)                                     ! i will be in 1...NTAB-1
  tbase=ttab(i)
  deltah=h-htab(i)
  tlocal=tbase+tgrad*deltah
  theta=tlocal/ttab(1)                                    ! temperature ratio

  IF (tgrad == 0.0) THEN                                     ! pressure ratio
    delta=ptab(i)*EXP(-GMR*deltah/tbase)
  ELSE
    delta=ptab(i)*(tbase/tlocal)**(GMR/tgrad)
  END IF

  sigma=delta/theta                                           ! density ratio
  RETURN
END Subroutine LowerAtmosphere   ! ------------------------------------------

!+
SUBROUTINE SimpleAtmosphere(alt,sigma,delta,theta)
!   -------------------------------------------------------------------------
! PURPOSE - Compute the characteristics of the atmosphere below 20 km.

! NOTES-Correct to 20 km. Only approximate above there

  IMPLICIT NONE
!============================================================================
!     A R G U M E N T S                                                     |
!============================================================================
  real(8),INTENT(IN)::  alt    ! geometric altitude, km.
  real(8),INTENT(OUT):: sigma  ! density/sea-level standard density
  real(8),INTENT(OUT):: delta  ! pressure/sea-level standard pressure
  real(8),INTENT(OUT):: theta  ! temperature/sea-level standard temperature
!============================================================================
!     L O C A L   C O N S T A N T S                                         |
!============================================================================
  real(8),PARAMETER:: REARTH = 6369.0                ! radius of the Earth (km)
  real(8),PARAMETER:: GMR = 34.163195                            ! gas constant
!============================================================================
!     L O C A L   V A R I A B L E S                                         |
!============================================================================
  real(8):: h   ! geopotential altitude
!----------------------------------------------------------------------------
  h=alt*REARTH/(alt+REARTH)      ! convert geometric to geopotential altitude

  IF (h < 11.0) THEN
    theta=1.0+(-6.5/288.15)*h                                   ! Troposphere
    delta=theta**(GMR/6.5)
  ELSE
    theta=216.65/288.15                                        ! Stratosphere
    delta=0.2233611*EXP(-GMR*(h-11.0)/216.65)
  END IF

  sigma=delta/theta
  RETURN
END Subroutine SimpleAtmosphere   ! -----------------------------------------

!+
FUNCTION Viscosity(theta) RESULT(visc)
!   -------------------------------------------------------------------------
! PURPOSE - Compute viscosity using Sutherland's formula.
!        Returns viscosity in kg/(meter-sec)

  IMPLICIT NONE
  real(8),INTENT(IN) :: theta                ! temperature/sea-level temperature
  real(8):: visc
  real(8):: temp                              ! temperature in deg Kelvin
!----------------------------------------------------------------------------
  temp=TZERO*theta
  visc=BETAVISC*Sqrt(temp*temp*temp)/(temp+SUTH)
  RETURN
END Function Viscosity   ! --------------------------------------------

!+
SUBROUTINE Atmosphere(alt,sigma,delta,theta)
!   -------------------------------------------------------------------------
! PURPOSE - Compute the characteristics of the U.S. Standard Atmosphere 1976

  IMPLICIT NONE
  real(8),INTENT(IN)::  alt    ! geometric altitude, km.
!  real(8),INTENT(OUT)
real(8):: sigma  ! density/sea-level standard density
!  real(8),INTENT(OUT)
real(8):: delta  ! pressure/sea-level standard pressure
!  real(8),INTENT(OUT)
real(8):: theta  ! temperature/sea-level standard temperature
!============================================================================
  IF (alt > 86.0) THEN
    CALL UpperAtmosphere(alt,sigma,delta,theta)
  ELSE
    CALL LowerAtmosphere(alt,sigma,delta,theta)
  END IF
  RETURN
END Subroutine Atmosphere   ! -----------------------------------------------

END Module Atmosphere1976   ! ===============================================