      SUBROUTINE DHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB,
     $                   ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, WORK,
     $                   LWORK, INFO )
*
*  -- LAPACK routine (instrumented to count operations, version 3.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     June 30, 1999
*
*     .. Scalar Arguments ..
      CHARACTER          COMPQ, COMPZ, JOB
      INTEGER            IHI, ILO, INFO, LDA, LDB, LDQ, LDZ, LWORK, N
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), ALPHAI( * ), ALPHAR( * ),
     $                   B( LDB, * ), BETA( * ), Q( LDQ, * ), WORK( * ),
     $                   Z( LDZ, * )
*     ..
*     ---------------------- Begin Timing Code -------------------------
*     Common block to return operation count and iteration count
*     ITCNT is initialized to 0, OPS is only incremented
*     OPST is used to accumulate small contributions to OPS
*     to avoid roundoff error
*     .. Common blocks ..
      COMMON             / LATIME / OPS, ITCNT
*     ..
*     .. Scalars in Common ..
      DOUBLE PRECISION   ITCNT, OPS
*     ..
*     ----------------------- End Timing Code --------------------------
*
*  Purpose
*  =======
*
*  DHGEQZ implements a single-/double-shift version of the QZ method for
*  finding the generalized eigenvalues
*
*  w(j)=(ALPHAR(j) + i*ALPHAI(j))/BETAR(j)   of the equation
*
*       det( A - w(i) B ) = 0
*
*  In addition, the pair A,B may be reduced to generalized Schur form:
*  B is upper triangular, and A is block upper triangular, where the
*  diagonal blocks are either 1-by-1 or 2-by-2, the 2-by-2 blocks having
*  complex generalized eigenvalues (see the description of the argument
*  JOB.)
*
*  If JOB='S', then the pair (A,B) is simultaneously reduced to Schur
*  form by applying one orthogonal tranformation (usually called Q) on
*  the left and another (usually called Z) on the right.  The 2-by-2
*  upper-triangular diagonal blocks of B corresponding to 2-by-2 blocks
*  of A will be reduced to positive diagonal matrices.  (I.e.,
*  if A(j+1,j) is non-zero, then B(j+1,j)=B(j,j+1)=0 and B(j,j) and
*  B(j+1,j+1) will be positive.)
*
*  If JOB='E', then at each iteration, the same transformations
*  are computed, but they are only applied to those parts of A and B
*  which are needed to compute ALPHAR, ALPHAI, and BETAR.
*
*  If JOB='S' and COMPQ and COMPZ are 'V' or 'I', then the orthogonal
*  transformations used to reduce (A,B) are accumulated into the arrays
*  Q and Z s.t.:
*
*       Q(in) A(in) Z(in)* = Q(out) A(out) Z(out)*
*       Q(in) B(in) Z(in)* = Q(out) B(out) Z(out)*
*
*  Ref: C.B. Moler & G.W. Stewart, "An Algorithm for Generalized Matrix
*       Eigenvalue Problems", SIAM J. Numer. Anal., 10(1973),
*       pp. 241--256.
*
*  Arguments
*  =========
*
*  JOB     (input) CHARACTER*1
*          = 'E': compute only ALPHAR, ALPHAI, and BETA.  A and B will
*                 not necessarily be put into generalized Schur form.
*          = 'S': put A and B into generalized Schur form, as well
*                 as computing ALPHAR, ALPHAI, and BETA.
*
*  COMPQ   (input) CHARACTER*1
*          = 'N': do not modify Q.
*          = 'V': multiply the array Q on the right by the transpose of
*                 the orthogonal tranformation that is applied to the
*                 left side of A and B to reduce them to Schur form.
*          = 'I': like COMPQ='V', except that Q will be initialized to
*                 the identity first.
*
*  COMPZ   (input) CHARACTER*1
*          = 'N': do not modify Z.
*          = 'V': multiply the array Z on the right by the orthogonal
*                 tranformation that is applied to the right side of
*                 A and B to reduce them to Schur form.
*          = 'I': like COMPZ='V', except that Z will be initialized to
*                 the identity first.
*
*  N       (input) INTEGER
*          The order of the matrices A, B, Q, and Z.  N >= 0.
*
*  ILO     (input) INTEGER
*  IHI     (input) INTEGER
*          It is assumed that A is already upper triangular in rows and
*          columns 1:ILO-1 and IHI+1:N.
*          1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
*
*  A       (input/output) DOUBLE PRECISION array, dimension (LDA, N)
*          On entry, the N-by-N upper Hessenberg matrix A.  Elements
*          below the subdiagonal must be zero.
*          If JOB='S', then on exit A and B will have been
*             simultaneously reduced to generalized Schur form.
*          If JOB='E', then on exit A will have been destroyed.
*             The diagonal blocks will be correct, but the off-diagonal
*             portion will be meaningless.
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A.  LDA >= max( 1, N ).
*
*  B       (input/output) DOUBLE PRECISION array, dimension (LDB, N)
*          On entry, the N-by-N upper triangular matrix B.  Elements
*          below the diagonal must be zero.  2-by-2 blocks in B
*          corresponding to 2-by-2 blocks in A will be reduced to
*          positive diagonal form.  (I.e., if A(j+1,j) is non-zero,
*          then B(j+1,j)=B(j,j+1)=0 and B(j,j) and B(j+1,j+1) will be
*          positive.)
*          If JOB='S', then on exit A and B will have been
*             simultaneously reduced to Schur form.
*          If JOB='E', then on exit B will have been destroyed.
*             Elements corresponding to diagonal blocks of A will be
*             correct, but the off-diagonal portion will be meaningless.
*
*  LDB     (input) INTEGER
*          The leading dimension of the array B.  LDB >= max( 1, N ).
*
*  ALPHAR  (output) DOUBLE PRECISION array, dimension (N)
*          ALPHAR(1:N) will be set to real parts of the diagonal
*          elements of A that would result from reducing A and B to
*          Schur form and then further reducing them both to triangular
*          form using unitary transformations s.t. the diagonal of B
*          was non-negative real.  Thus, if A(j,j) is in a 1-by-1 block
*          (i.e., A(j+1,j)=A(j,j+1)=0), then ALPHAR(j)=A(j,j).
*          Note that the (real or complex) values
*          (ALPHAR(j) + i*ALPHAI(j))/BETA(j), j=1,...,N, are the
*          generalized eigenvalues of the matrix pencil A - wB.
*
*  ALPHAI  (output) DOUBLE PRECISION array, dimension (N)
*          ALPHAI(1:N) will be set to imaginary parts of the diagonal
*          elements of A that would result from reducing A and B to
*          Schur form and then further reducing them both to triangular
*          form using unitary transformations s.t. the diagonal of B
*          was non-negative real.  Thus, if A(j,j) is in a 1-by-1 block
*          (i.e., A(j+1,j)=A(j,j+1)=0), then ALPHAR(j)=0.
*          Note that the (real or complex) values
*          (ALPHAR(j) + i*ALPHAI(j))/BETA(j), j=1,...,N, are the
*          generalized eigenvalues of the matrix pencil A - wB.
*
*  BETA    (output) DOUBLE PRECISION array, dimension (N)
*          BETA(1:N) will be set to the (real) diagonal elements of B
*          that would result from reducing A and B to Schur form and
*          then further reducing them both to triangular form using
*          unitary transformations s.t. the diagonal of B was
*          non-negative real.  Thus, if A(j,j) is in a 1-by-1 block
*          (i.e., A(j+1,j)=A(j,j+1)=0), then BETA(j)=B(j,j).
*          Note that the (real or complex) values
*          (ALPHAR(j) + i*ALPHAI(j))/BETA(j), j=1,...,N, are the
*          generalized eigenvalues of the matrix pencil A - wB.
*          (Note that BETA(1:N) will always be non-negative, and no
*          BETAI is necessary.)
*
*  Q       (input/output) DOUBLE PRECISION array, dimension (LDQ, N)
*          If COMPQ='N', then Q will not be referenced.
*          If COMPQ='V' or 'I', then the transpose of the orthogonal
*             transformations which are applied to A and B on the left
*             will be applied to the array Q on the right.
*
*  LDQ     (input) INTEGER
*          The leading dimension of the array Q.  LDQ >= 1.
*          If COMPQ='V' or 'I', then LDQ >= N.
*
*  Z       (input/output) DOUBLE PRECISION array, dimension (LDZ, N)
*          If COMPZ='N', then Z will not be referenced.
*          If COMPZ='V' or 'I', then the orthogonal transformations
*             which are applied to A and B on the right will be applied
*             to the array Z on the right.
*
*  LDZ     (input) INTEGER
*          The leading dimension of the array Z.  LDZ >= 1.
*          If COMPZ='V' or 'I', then LDZ >= N.
*
*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
*          On exit, if INFO >= 0, WORK(1) returns the optimal LWORK.
*
*  LWORK   (input) INTEGER
*          The dimension of the array WORK.  LWORK >= max(1,N).
*
*          If LWORK = -1, then a workspace query is assumed; the routine
*          only calculates the optimal size of the WORK array, returns
*          this value as the first entry of the WORK array, and no error
*          message related to LWORK is issued by XERBLA.
*
*  INFO    (output) INTEGER
*          = 0: successful exit
*          < 0: if INFO = -i, the i-th argument had an illegal value
*          = 1,...,N: the QZ iteration did not converge.  (A,B) is not
*                     in Schur form, but ALPHAR(i), ALPHAI(i), and
*                     BETA(i), i=INFO+1,...,N should be correct.
*          = N+1,...,2*N: the shift calculation failed.  (A,B) is not
*                     in Schur form, but ALPHAR(i), ALPHAI(i), and
*                     BETA(i), i=INFO-N+1,...,N should be correct.
*          > 2*N:     various "impossible" errors.
*
*  Further Details
*  ===============
*
*  Iteration counters:
*
*  JITER  -- counts iterations.
*  IITER  -- counts iterations run since ILAST was last
*            changed.  This is therefore reset only when a 1-by-1 or
*            2-by-2 block deflates off the bottom.
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   HALF, ZERO, ONE, SAFETY
      PARAMETER          ( HALF = 0.5D+0, ZERO = 0.0D+0, ONE = 1.0D+0,
     $                   SAFETY = 1.0D+2 )
*     ..
*     .. Local Scalars ..
      LOGICAL            ILAZR2, ILAZRO, ILPIVT, ILQ, ILSCHR, ILZ,
     $                   LQUERY
      INTEGER            ICOMPQ, ICOMPZ, IFIRST, IFRSTM, IITER, ILAST,
     $                   ILASTM, IN, ISCHUR, ISTART, J, JC, JCH, JITER,
     $                   JR, MAXIT, NQ, NZ
      DOUBLE PRECISION   A11, A12, A1I, A1R, A21, A22, A2I, A2R, AD11,
     $                   AD11L, AD12, AD12L, AD21, AD21L, AD22, AD22L,
     $                   AD32L, AN, ANORM, ASCALE, ATOL, B11, B1A, B1I,
     $                   B1R, B22, B2A, B2I, B2R, BN, BNORM, BSCALE,
     $                   BTOL, C, C11I, C11R, C12, C21, C22I, C22R, CL,
     $                   CQ, CR, CZ, ESHIFT, OPST, S, S1, S1INV, S2,
     $                   SAFMAX, SAFMIN, SCALE, SL, SQI, SQR, SR, SZI,
     $                   SZR, T, TAU, TEMP, TEMP2, TEMPI, TEMPR, U1,
     $                   U12, U12L, U2, ULP, VS, W11, W12, W21, W22,
     $                   WABS, WI, WR, WR2
*     ..
*     .. Local Arrays ..
      DOUBLE PRECISION   V( 3 )
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLAMCH, DLANHS, DLAPY2, DLAPY3
      EXTERNAL           LSAME, DLAMCH, DLANHS, DLAPY2, DLAPY3
*     ..
*     .. External Subroutines ..
      EXTERNAL           DLAG2, DLARFG, DLARTG, DLASET, DLASV2, DROT,
     $                   XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, DBLE, MAX, MIN, SQRT
*     ..
*     .. Executable Statements ..
*
*     Decode JOB, COMPQ, COMPZ
*
      IF( LSAME( JOB, 'E' ) ) THEN
         ILSCHR = .FALSE.
         ISCHUR = 1
      ELSE IF( LSAME( JOB, 'S' ) ) THEN
         ILSCHR = .TRUE.
         ISCHUR = 2
      ELSE
         ISCHUR = 0
      END IF
*
      IF( LSAME( COMPQ, 'N' ) ) THEN
         ILQ = .FALSE.
         ICOMPQ = 1
         NQ = 0
      ELSE IF( LSAME( COMPQ, 'V' ) ) THEN
         ILQ = .TRUE.
         ICOMPQ = 2
         NQ = N
      ELSE IF( LSAME( COMPQ, 'I' ) ) THEN
         ILQ = .TRUE.
         ICOMPQ = 3
         NQ = N
      ELSE
         ICOMPQ = 0
      END IF
*
      IF( LSAME( COMPZ, 'N' ) ) THEN
         ILZ = .FALSE.
         ICOMPZ = 1
         NZ = 0
      ELSE IF( LSAME( COMPZ, 'V' ) ) THEN
         ILZ = .TRUE.
         ICOMPZ = 2
         NZ = N
      ELSE IF( LSAME( COMPZ, 'I' ) ) THEN
         ILZ = .TRUE.
         ICOMPZ = 3
         NZ = N
      ELSE
         ICOMPZ = 0
      END IF
*
*     Check Argument Values
*
      INFO = 0
      WORK( 1 ) = MAX( 1, N )
      LQUERY = ( LWORK.EQ.-1 )
      IF( ISCHUR.EQ.0 ) THEN
         INFO = -1
      ELSE IF( ICOMPQ.EQ.0 ) THEN
         INFO = -2
      ELSE IF( ICOMPZ.EQ.0 ) THEN
         INFO = -3
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE IF( ILO.LT.1 ) THEN
         INFO = -5
      ELSE IF( IHI.GT.N .OR. IHI.LT.ILO-1 ) THEN
         INFO = -6
      ELSE IF( LDA.LT.N ) THEN
         INFO = -8
      ELSE IF( LDB.LT.N ) THEN
         INFO = -10
      ELSE IF( LDQ.LT.1 .OR. ( ILQ .AND. LDQ.LT.N ) ) THEN
         INFO = -15
      ELSE IF( LDZ.LT.1 .OR. ( ILZ .AND. LDZ.LT.N ) ) THEN
         INFO = -17
      ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
         INFO = -19
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DHGEQZ', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( N.LE.0 ) THEN
         WORK( 1 ) = DBLE( 1 )
*        --------------------- Begin Timing Code -----------------------
         ITCNT = ZERO
*        ---------------------- End Timing Code ------------------------
         RETURN
      END IF
*
*     Initialize Q and Z
*
      IF( ICOMPQ.EQ.3 )
     $   CALL DLASET( 'Full', N, N, ZERO, ONE, Q, LDQ )
      IF( ICOMPZ.EQ.3 )
     $   CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ )
*
*     Machine Constants
*
      IN = IHI + 1 - ILO
      SAFMIN = DLAMCH( 'S' )
      SAFMAX = ONE / SAFMIN
      ULP = DLAMCH( 'E' )*DLAMCH( 'B' )
      ANORM = DLANHS( 'F', IN, A( ILO, ILO ), LDA, WORK )
      BNORM = DLANHS( 'F', IN, B( ILO, ILO ), LDB, WORK )
      ATOL = MAX( SAFMIN, ULP*ANORM )
      BTOL = MAX( SAFMIN, ULP*BNORM )
      ASCALE = ONE / MAX( SAFMIN, ANORM )
      BSCALE = ONE / MAX( SAFMIN, BNORM )
*
*     Set Eigenvalues IHI+1:N
*
      DO 30 J = IHI + 1, N
         IF( B( J, J ).LT.ZERO ) THEN
            IF( ILSCHR ) THEN
               DO 10 JR = 1, J
                  A( JR, J ) = -A( JR, J )
                  B( JR, J ) = -B( JR, J )
   10          CONTINUE
            ELSE
               A( J, J ) = -A( J, J )
               B( J, J ) = -B( J, J )
            END IF
            IF( ILZ ) THEN
               DO 20 JR = 1, N
                  Z( JR, J ) = -Z( JR, J )
   20          CONTINUE
            END IF
         END IF
         ALPHAR( J ) = A( J, J )
         ALPHAI( J ) = ZERO
         BETA( J ) = B( J, J )
   30 CONTINUE
*
*     ---------------------- Begin Timing Code -------------------------
*     Count ops for norms, etc.
      OPST = ZERO
      OPS = OPS + DBLE( 2*N**2+6*N )
*     ----------------------- End Timing Code --------------------------
*
*
*     If IHI < ILO, skip QZ steps
*
      IF( IHI.LT.ILO )
     $   GO TO 380
*
*     MAIN QZ ITERATION LOOP
*
*     Initialize dynamic indices
*
*     Eigenvalues ILAST+1:N have been found.
*        Column operations modify rows IFRSTM:whatever.
*        Row operations modify columns whatever:ILASTM.
*
*     If only eigenvalues are being computed, then
*        IFRSTM is the row of the last splitting row above row ILAST;
*        this is always at least ILO.
*     IITER counts iterations since the last eigenvalue was found,
*        to tell when to use an extraordinary shift.
*     MAXIT is the maximum number of QZ sweeps allowed.
*
      ILAST = IHI
      IF( ILSCHR ) THEN
         IFRSTM = 1
         ILASTM = N
      ELSE
         IFRSTM = ILO
         ILASTM = IHI
      END IF
      IITER = 0
      ESHIFT = ZERO
      MAXIT = 30*( IHI-ILO+1 )
*
      DO 360 JITER = 1, MAXIT
*
*        Split the matrix if possible.
*
*        Two tests:
*           1: A(j,j-1)=0  or  j=ILO
*           2: B(j,j)=0
*
         IF( ILAST.EQ.ILO ) THEN
*
*           Special case: j=ILAST
*
            GO TO 80
         ELSE
            IF( ABS( A( ILAST, ILAST-1 ) ).LE.ATOL ) THEN
               A( ILAST, ILAST-1 ) = ZERO
               GO TO 80
            END IF
         END IF
*
         IF( ABS( B( ILAST, ILAST ) ).LE.BTOL ) THEN
            B( ILAST, ILAST ) = ZERO
            GO TO 70
         END IF
*
*        General case: j<ILAST
*
         DO 60 J = ILAST - 1, ILO, -1
*
*           Test 1: for A(j,j-1)=0 or j=ILO
*
            IF( J.EQ.ILO ) THEN
               ILAZRO = .TRUE.
            ELSE
               IF( ABS( A( J, J-1 ) ).LE.ATOL ) THEN
                  A( J, J-1 ) = ZERO
                  ILAZRO = .TRUE.
               ELSE
                  ILAZRO = .FALSE.
               END IF
            END IF
*
*           Test 2: for B(j,j)=0
*
            IF( ABS( B( J, J ) ).LT.BTOL ) THEN
               B( J, J ) = ZERO
*
*              Test 1a: Check for 2 consecutive small subdiagonals in A
*
               ILAZR2 = .FALSE.
               IF( .NOT.ILAZRO ) THEN
                  TEMP = ABS( A( J, J-1 ) )
                  TEMP2 = ABS( A( J, J ) )
                  TEMPR = MAX( TEMP, TEMP2 )
                  IF( TEMPR.LT.ONE .AND. TEMPR.NE.ZERO ) THEN
                     TEMP = TEMP / TEMPR
                     TEMP2 = TEMP2 / TEMPR
                  END IF
                  IF( TEMP*( ASCALE*ABS( A( J+1, J ) ) ).LE.TEMP2*
     $                ( ASCALE*ATOL ) )ILAZR2 = .TRUE.
               END IF
*
*              If both tests pass (1 & 2), i.e., the leading diagonal
*              element of B in the block is zero, split a 1x1 block off
*              at the top. (I.e., at the J-th row/column) The leading
*              diagonal element of the remainder can also be zero, so
*              this may have to be done repeatedly.
*
               IF( ILAZRO .OR. ILAZR2 ) THEN
                  DO 40 JCH = J, ILAST - 1
                     TEMP = A( JCH, JCH )
                     CALL DLARTG( TEMP, A( JCH+1, JCH ), C, S,
     $                            A( JCH, JCH ) )
                     A( JCH+1, JCH ) = ZERO
                     CALL DROT( ILASTM-JCH, A( JCH, JCH+1 ), LDA,
     $                          A( JCH+1, JCH+1 ), LDA, C, S )
                     CALL DROT( ILASTM-JCH, B( JCH, JCH+1 ), LDB,
     $                          B( JCH+1, JCH+1 ), LDB, C, S )
                     IF( ILQ )
     $                  CALL DROT( N, Q( 1, JCH ), 1, Q( 1, JCH+1 ), 1,
     $                             C, S )
                     IF( ILAZR2 )
     $                  A( JCH, JCH-1 ) = A( JCH, JCH-1 )*C
                     ILAZR2 = .FALSE.
*
*                    --------------- Begin Timing Code -----------------
                     OPST = OPST + DBLE( 7+12*( ILASTM-JCH )+6*NQ )
*                    ---------------- End Timing Code ------------------
*
                     IF( ABS( B( JCH+1, JCH+1 ) ).GE.BTOL ) THEN
                        IF( JCH+1.GE.ILAST ) THEN
                           GO TO 80
                        ELSE
                           IFIRST = JCH + 1
                           GO TO 110
                        END IF
                     END IF
                     B( JCH+1, JCH+1 ) = ZERO
   40             CONTINUE
                  GO TO 70
               ELSE
*
*                 Only test 2 passed -- chase the zero to B(ILAST,ILAST)
*                 Then process as in the case B(ILAST,ILAST)=0
*
                  DO 50 JCH = J, ILAST - 1
                     TEMP = B( JCH, JCH+1 )
                     CALL DLARTG( TEMP, B( JCH+1, JCH+1 ), C, S,
     $                            B( JCH, JCH+1 ) )
                     B( JCH+1, JCH+1 ) = ZERO
                     IF( JCH.LT.ILASTM-1 )
     $                  CALL DROT( ILASTM-JCH-1, B( JCH, JCH+2 ), LDB,
     $                             B( JCH+1, JCH+2 ), LDB, C, S )
                     CALL DROT( ILASTM-JCH+2, A( JCH, JCH-1 ), LDA,
     $                          A( JCH+1, JCH-1 ), LDA, C, S )
                     IF( ILQ )
     $                  CALL DROT( N, Q( 1, JCH ), 1, Q( 1, JCH+1 ), 1,
     $                             C, S )
                     TEMP = A( JCH+1, JCH )
                     CALL DLARTG( TEMP, A( JCH+1, JCH-1 ), C, S,
     $                            A( JCH+1, JCH ) )
                     A( JCH+1, JCH-1 ) = ZERO
                     CALL DROT( JCH+1-IFRSTM, A( IFRSTM, JCH ), 1,
     $                          A( IFRSTM, JCH-1 ), 1, C, S )
                     CALL DROT( JCH-IFRSTM, B( IFRSTM, JCH ), 1,
     $                          B( IFRSTM, JCH-1 ), 1, C, S )
                     IF( ILZ )
     $                  CALL DROT( N, Z( 1, JCH ), 1, Z( 1, JCH-1 ), 1,
     $                             C, S )
   50             CONTINUE
*
*                 ---------------- Begin Timing Code -------------------
                  OPST = OPST + DBLE( 26+12*( ILASTM-IFRSTM )+6*
     $                   ( NQ+NZ ) )*DBLE( ILAST-J )
*                 ----------------- End Timing Code --------------------
*
                  GO TO 70
               END IF
            ELSE IF( ILAZRO ) THEN
*
*              Only test 1 passed -- work on J:ILAST
*
               IFIRST = J
               GO TO 110
            END IF
*
*           Neither test passed -- try next J
*
   60    CONTINUE
*
*        (Drop-through is "impossible")
*
         INFO = N + 1
         GO TO 420
*
*        B(ILAST,ILAST)=0 -- clear A(ILAST,ILAST-1) to split off a
*        1x1 block.
*
   70    CONTINUE
         TEMP = A( ILAST, ILAST )
         CALL DLARTG( TEMP, A( ILAST, ILAST-1 ), C, S,
     $                A( ILAST, ILAST ) )
         A( ILAST, ILAST-1 ) = ZERO
         CALL DROT( ILAST-IFRSTM, A( IFRSTM, ILAST ), 1,
     $              A( IFRSTM, ILAST-1 ), 1, C, S )
         CALL DROT( ILAST-IFRSTM, B( IFRSTM, ILAST ), 1,
     $              B( IFRSTM, ILAST-1 ), 1, C, S )
         IF( ILZ )
     $      CALL DROT( N, Z( 1, ILAST ), 1, Z( 1, ILAST-1 ), 1, C, S )
*
*        --------------------- Begin Timing Code -----------------------
         OPST = OPST + DBLE( 7+12*( ILAST-IFRSTM )+6*NZ )
*        ---------------------- End Timing Code ------------------------
*
*
*        A(ILAST,ILAST-1)=0 -- Standardize B, set ALPHAR, ALPHAI,
*                              and BETA
*
   80    CONTINUE
         IF( B( ILAST, ILAST ).LT.ZERO ) THEN
            IF( ILSCHR ) THEN
               DO 90 J = IFRSTM, ILAST
                  A( J, ILAST ) = -A( J, ILAST )
                  B( J, ILAST ) = -B( J, ILAST )
   90          CONTINUE
            ELSE
               A( ILAST, ILAST ) = -A( ILAST, ILAST )
               B( ILAST, ILAST ) = -B( ILAST, ILAST )
            END IF
            IF( ILZ ) THEN
               DO 100 J = 1, N
                  Z( J, ILAST ) = -Z( J, ILAST )
  100          CONTINUE
            END IF
         END IF
         ALPHAR( ILAST ) = A( ILAST, ILAST )
         ALPHAI( ILAST ) = ZERO
         BETA( ILAST ) = B( ILAST, ILAST )
*
*        Go to next block -- exit if finished.
*
         ILAST = ILAST - 1
         IF( ILAST.LT.ILO )
     $      GO TO 380
*
*        Reset counters
*
         IITER = 0
         ESHIFT = ZERO
         IF( .NOT.ILSCHR ) THEN
            ILASTM = ILAST
            IF( IFRSTM.GT.ILAST )
     $         IFRSTM = ILO
         END IF
         GO TO 350
*
*        QZ step
*
*        This iteration only involves rows/columns IFIRST:ILAST. We
*        assume IFIRST < ILAST, and that the diagonal of B is non-zero.
*
  110    CONTINUE
         IITER = IITER + 1
         IF( .NOT.ILSCHR ) THEN
            IFRSTM = IFIRST
         END IF
*
*        Compute single shifts.
*
*        At this point, IFIRST < ILAST, and the diagonal elements of
*        B(IFIRST:ILAST,IFIRST,ILAST) are larger than BTOL (in
*        magnitude)
*
         IF( ( IITER / 10 )*10.EQ.IITER ) THEN
*
*           Exceptional shift.  Chosen for no particularly good reason.
*           (Single shift only.)
*
            IF( ( DBLE( MAXIT )*SAFMIN )*ABS( A( ILAST-1, ILAST ) ).LT.
     $          ABS( B( ILAST-1, ILAST-1 ) ) ) THEN
               ESHIFT = ESHIFT + A( ILAST-1, ILAST ) /
     $                  B( ILAST-1, ILAST-1 )
            ELSE
               ESHIFT = ESHIFT + ONE / ( SAFMIN*DBLE( MAXIT ) )
            END IF
            S1 = ONE
            WR = ESHIFT
*
*           ------------------- Begin Timing Code ----------------------
            OPST = OPST + DBLE( 4 )
*           -------------------- End Timing Code -----------------------
*
         ELSE
*
*           Shifts based on the generalized eigenvalues of the
*           bottom-right 2x2 block of A and B. The first eigenvalue
*           returned by DLAG2 is the Wilkinson shift (AEP p.512),
*
            CALL DLAG2( A( ILAST-1, ILAST-1 ), LDA,
     $                  B( ILAST-1, ILAST-1 ), LDB, SAFMIN*SAFETY, S1,
     $                  S2, WR, WR2, WI )
*
            TEMP = MAX( S1, SAFMIN*MAX( ONE, ABS( WR ), ABS( WI ) ) )
*
*           ------------------- Begin Timing Code ----------------------
            OPST = OPST + DBLE( 57 )
*           -------------------- End Timing Code -----------------------
*
            IF( WI.NE.ZERO )
     $         GO TO 200
         END IF
*
*        Fiddle with shift to avoid overflow
*
         TEMP = MIN( ASCALE, ONE )*( HALF*SAFMAX )
         IF( S1.GT.TEMP ) THEN
            SCALE = TEMP / S1
         ELSE
            SCALE = ONE
         END IF
*
         TEMP = MIN( BSCALE, ONE )*( HALF*SAFMAX )
         IF( ABS( WR ).GT.TEMP )
     $      SCALE = MIN( SCALE, TEMP / ABS( WR ) )
         S1 = SCALE*S1
         WR = SCALE*WR
*
*        Now check for two consecutive small subdiagonals.
*
         DO 120 J = ILAST - 1, IFIRST + 1, -1
            ISTART = J
            TEMP = ABS( S1*A( J, J-1 ) )
            TEMP2 = ABS( S1*A( J, J )-WR*B( J, J ) )
            TEMPR = MAX( TEMP, TEMP2 )
            IF( TEMPR.LT.ONE .AND. TEMPR.NE.ZERO ) THEN
               TEMP = TEMP / TEMPR
               TEMP2 = TEMP2 / TEMPR
            END IF
            IF( ABS( ( ASCALE*A( J+1, J ) )*TEMP ).LE.( ASCALE*ATOL )*
     $          TEMP2 )GO TO 130
  120    CONTINUE
*
         ISTART = IFIRST
  130    CONTINUE
*
*        Do an implicit single-shift QZ sweep.
*
*        Initial Q
*
         TEMP = S1*A( ISTART, ISTART ) - WR*B( ISTART, ISTART )
         TEMP2 = S1*A( ISTART+1, ISTART )
         CALL DLARTG( TEMP, TEMP2, C, S, TEMPR )
*
*        Sweep
*
         DO 190 J = ISTART, ILAST - 1
            IF( J.GT.ISTART ) THEN
               TEMP = A( J, J-1 )
               CALL DLARTG( TEMP, A( J+1, J-1 ), C, S, A( J, J-1 ) )
               A( J+1, J-1 ) = ZERO
            END IF
*
            DO 140 JC = J, ILASTM
               TEMP = C*A( J, JC ) + S*A( J+1, JC )
               A( J+1, JC ) = -S*A( J, JC ) + C*A( J+1, JC )
               A( J, JC ) = TEMP
               TEMP2 = C*B( J, JC ) + S*B( J+1, JC )
               B( J+1, JC ) = -S*B( J, JC ) + C*B( J+1, JC )
               B( J, JC ) = TEMP2
  140       CONTINUE
            IF( ILQ ) THEN
               DO 150 JR = 1, N
                  TEMP = C*Q( JR, J ) + S*Q( JR, J+1 )
                  Q( JR, J+1 ) = -S*Q( JR, J ) + C*Q( JR, J+1 )
                  Q( JR, J ) = TEMP
  150          CONTINUE
            END IF
*
            TEMP = B( J+1, J+1 )
            CALL DLARTG( TEMP, B( J+1, J ), C, S, B( J+1, J+1 ) )
            B( J+1, J ) = ZERO
*
            DO 160 JR = IFRSTM, MIN( J+2, ILAST )
               TEMP = C*A( JR, J+1 ) + S*A( JR, J )
               A( JR, J ) = -S*A( JR, J+1 ) + C*A( JR, J )
               A( JR, J+1 ) = TEMP
  160       CONTINUE
            DO 170 JR = IFRSTM, J
               TEMP = C*B( JR, J+1 ) + S*B( JR, J )
               B( JR, J ) = -S*B( JR, J+1 ) + C*B( JR, J )
               B( JR, J+1 ) = TEMP
  170       CONTINUE
            IF( ILZ ) THEN
               DO 180 JR = 1, N
                  TEMP = C*Z( JR, J+1 ) + S*Z( JR, J )
                  Z( JR, J ) = -S*Z( JR, J+1 ) + C*Z( JR, J )
                  Z( JR, J+1 ) = TEMP
  180          CONTINUE
            END IF
  190    CONTINUE
*
*        --------------------- Begin Timing Code -----------------------
         OPST = OPST + DBLE( 6+( ILAST-ISTART )*
     $          ( 8+14+36+12*( ILASTM-IFRSTM )+6*( NQ+NZ ) ) )
*        ---------------------- End Timing Code ------------------------
*
         GO TO 350
*
*        Use Francis double-shift
*
*        Note: the Francis double-shift should work with real shifts,
*              but only if the block is at least 3x3.
*              This code may break if this point is reached with
*              a 2x2 block with real eigenvalues.
*
  200    CONTINUE
         IF( IFIRST+1.EQ.ILAST ) THEN
*
*           Special case -- 2x2 block with complex eigenvectors
*
*           Step 1: Standardize, that is, rotate so that
*
*                       ( B11  0  )
*                   B = (         )  with B11 non-negative.
*                       (  0  B22 )
*
            CALL DLASV2( B( ILAST-1, ILAST-1 ), B( ILAST-1, ILAST ),
     $                   B( ILAST, ILAST ), B22, B11, SR, CR, SL, CL )
*
            IF( B11.LT.ZERO ) THEN
               CR = -CR
               SR = -SR
               B11 = -B11
               B22 = -B22
            END IF
*
            CALL DROT( ILASTM+1-IFIRST, A( ILAST-1, ILAST-1 ), LDA,
     $                 A( ILAST, ILAST-1 ), LDA, CL, SL )
            CALL DROT( ILAST+1-IFRSTM, A( IFRSTM, ILAST-1 ), 1,
     $                 A( IFRSTM, ILAST ), 1, CR, SR )
*
            IF( ILAST.LT.ILASTM )
     $         CALL DROT( ILASTM-ILAST, B( ILAST-1, ILAST+1 ), LDB,
     $                    B( ILAST, ILAST+1 ), LDA, CL, SL )
            IF( IFRSTM.LT.ILAST-1 )
     $         CALL DROT( IFIRST-IFRSTM, B( IFRSTM, ILAST-1 ), 1,
     $                    B( IFRSTM, ILAST ), 1, CR, SR )
*
            IF( ILQ )
     $         CALL DROT( N, Q( 1, ILAST-1 ), 1, Q( 1, ILAST ), 1, CL,
     $                    SL )
            IF( ILZ )
     $         CALL DROT( N, Z( 1, ILAST-1 ), 1, Z( 1, ILAST ), 1, CR,
     $                    SR )
*
            B( ILAST-1, ILAST-1 ) = B11
            B( ILAST-1, ILAST ) = ZERO
            B( ILAST, ILAST-1 ) = ZERO
            B( ILAST, ILAST ) = B22
*
*           If B22 is negative, negate column ILAST
*
            IF( B22.LT.ZERO ) THEN
               DO 210 J = IFRSTM, ILAST
                  A( J, ILAST ) = -A( J, ILAST )
                  B( J, ILAST ) = -B( J, ILAST )
  210          CONTINUE
*
               IF( ILZ ) THEN
                  DO 220 J = 1, N
                     Z( J, ILAST ) = -Z( J, ILAST )
  220             CONTINUE
               END IF
            END IF
*
*           Step 2: Compute ALPHAR, ALPHAI, and BETA (see refs.)
*
*           Recompute shift
*
            CALL DLAG2( A( ILAST-1, ILAST-1 ), LDA,
     $                  B( ILAST-1, ILAST-1 ), LDB, SAFMIN*SAFETY, S1,
     $                  TEMP, WR, TEMP2, WI )
*
*           ------------------- Begin Timing Code ----------------------
            OPST = OPST + DBLE( 103+12*( ILASTM+ILAST-IFIRST-IFRSTM )+6*
     $             ( NQ+NZ ) )
*           -------------------- End Timing Code -----------------------
*
*           If standardization has perturbed the shift onto real line,
*           do another (real single-shift) QR step.
*
            IF( WI.EQ.ZERO )
     $         GO TO 350
            S1INV = ONE / S1
*
*           Do EISPACK (QZVAL) computation of alpha and beta
*
            A11 = A( ILAST-1, ILAST-1 )
            A21 = A( ILAST, ILAST-1 )
            A12 = A( ILAST-1, ILAST )
            A22 = A( ILAST, ILAST )
*
*           Compute complex Givens rotation on right
*           (Assume some element of C = (sA - wB) > unfl )
*                            __
*           (sA - wB) ( CZ   -SZ )
*                     ( SZ    CZ )
*
            C11R = S1*A11 - WR*B11
            C11I = -WI*B11
            C12 = S1*A12
            C21 = S1*A21
            C22R = S1*A22 - WR*B22
            C22I = -WI*B22
*
            IF( ABS( C11R )+ABS( C11I )+ABS( C12 ).GT.ABS( C21 )+
     $          ABS( C22R )+ABS( C22I ) ) THEN
               T = DLAPY3( C12, C11R, C11I )
               CZ = C12 / T
               SZR = -C11R / T
               SZI = -C11I / T
            ELSE
               CZ = DLAPY2( C22R, C22I )
               IF( CZ.LE.SAFMIN ) THEN
                  CZ = ZERO
                  SZR = ONE
                  SZI = ZERO
               ELSE
                  TEMPR = C22R / CZ
                  TEMPI = C22I / CZ
                  T = DLAPY2( CZ, C21 )
                  CZ = CZ / T
                  SZR = -C21*TEMPR / T
                  SZI = C21*TEMPI / T
               END IF
            END IF
*
*           Compute Givens rotation on left
*
*           (  CQ   SQ )
*           (  __      )  A or B
*           ( -SQ   CQ )
*
            AN = ABS( A11 ) + ABS( A12 ) + ABS( A21 ) + ABS( A22 )
            BN = ABS( B11 ) + ABS( B22 )
            WABS = ABS( WR ) + ABS( WI )
            IF( S1*AN.GT.WABS*BN ) THEN
               CQ = CZ*B11
               SQR = SZR*B22
               SQI = -SZI*B22
            ELSE
               A1R = CZ*A11 + SZR*A12
               A1I = SZI*A12
               A2R = CZ*A21 + SZR*A22
               A2I = SZI*A22
               CQ = DLAPY2( A1R, A1I )
               IF( CQ.LE.SAFMIN ) THEN
                  CQ = ZERO
                  SQR = ONE
                  SQI = ZERO
               ELSE
                  TEMPR = A1R / CQ
                  TEMPI = A1I / CQ
                  SQR = TEMPR*A2R + TEMPI*A2I
                  SQI = TEMPI*A2R - TEMPR*A2I
               END IF
            END IF
            T = DLAPY3( CQ, SQR, SQI )
            CQ = CQ / T
            SQR = SQR / T
            SQI = SQI / T
*
*           Compute diagonal elements of QBZ
*
            TEMPR = SQR*SZR - SQI*SZI
            TEMPI = SQR*SZI + SQI*SZR
            B1R = CQ*CZ*B11 + TEMPR*B22
            B1I = TEMPI*B22
            B1A = DLAPY2( B1R, B1I )
            B2R = CQ*CZ*B22 + TEMPR*B11
            B2I = -TEMPI*B11
            B2A = DLAPY2( B2R, B2I )
*
*           Normalize so beta > 0, and Im( alpha1 ) > 0
*
            BETA( ILAST-1 ) = B1A
            BETA( ILAST ) = B2A
            ALPHAR( ILAST-1 ) = ( WR*B1A )*S1INV
            ALPHAI( ILAST-1 ) = ( WI*B1A )*S1INV
            ALPHAR( ILAST ) = ( WR*B2A )*S1INV
            ALPHAI( ILAST ) = -( WI*B2A )*S1INV
*
*           ------------------- Begin Timing Code ----------------------
            OPST = OPST + DBLE( 93 )
*           -------------------- End Timing Code -----------------------
*
*           Step 3: Go to next block -- exit if finished.
*
            ILAST = IFIRST - 1
            IF( ILAST.LT.ILO )
     $         GO TO 380
*
*           Reset counters
*
            IITER = 0
            ESHIFT = ZERO
            IF( .NOT.ILSCHR ) THEN
               ILASTM = ILAST
               IF( IFRSTM.GT.ILAST )
     $            IFRSTM = ILO
            END IF
            GO TO 350
         ELSE
*
*           Usual case: 3x3 or larger block, using Francis implicit
*                       double-shift
*
*                                    2
*           Eigenvalue equation is  w  - c w + d = 0,
*
*                                         -1 2        -1
*           so compute 1st column of  (A B  )  - c A B   + d
*           using the formula in QZIT (from EISPACK)
*
*           We assume that the block is at least 3x3
*
            AD11 = ( ASCALE*A( ILAST-1, ILAST-1 ) ) /
     $             ( BSCALE*B( ILAST-1, ILAST-1 ) )
            AD21 = ( ASCALE*A( ILAST, ILAST-1 ) ) /
     $             ( BSCALE*B( ILAST-1, ILAST-1 ) )
            AD12 = ( ASCALE*A( ILAST-1, ILAST ) ) /
     $             ( BSCALE*B( ILAST, ILAST ) )
            AD22 = ( ASCALE*A( ILAST, ILAST ) ) /
     $             ( BSCALE*B( ILAST, ILAST ) )
            U12 = B( ILAST-1, ILAST ) / B( ILAST, ILAST )
            AD11L = ( ASCALE*A( IFIRST, IFIRST ) ) /
     $              ( BSCALE*B( IFIRST, IFIRST ) )
            AD21L = ( ASCALE*A( IFIRST+1, IFIRST ) ) /
     $              ( BSCALE*B( IFIRST, IFIRST ) )
            AD12L = ( ASCALE*A( IFIRST, IFIRST+1 ) ) /
     $              ( BSCALE*B( IFIRST+1, IFIRST+1 ) )
            AD22L = ( ASCALE*A( IFIRST+1, IFIRST+1 ) ) /
     $              ( BSCALE*B( IFIRST+1, IFIRST+1 ) )
            AD32L = ( ASCALE*A( IFIRST+2, IFIRST+1 ) ) /
     $              ( BSCALE*B( IFIRST+1, IFIRST+1 ) )
            U12L = B( IFIRST, IFIRST+1 ) / B( IFIRST+1, IFIRST+1 )
*
            V( 1 ) = ( AD11-AD11L )*( AD22-AD11L ) - AD12*AD21 +
     $               AD21*U12*AD11L + ( AD12L-AD11L*U12L )*AD21L
            V( 2 ) = ( ( AD22L-AD11L )-AD21L*U12L-( AD11-AD11L )-
     $               ( AD22-AD11L )+AD21*U12 )*AD21L
            V( 3 ) = AD32L*AD21L
*
            ISTART = IFIRST
*
            CALL DLARFG( 3, V( 1 ), V( 2 ), 1, TAU )
            V( 1 ) = ONE
*
*           Sweep
*
            DO 290 J = ISTART, ILAST - 2
*
*              All but last elements: use 3x3 Householder transforms.
*
*              Zero (j-1)st column of A
*
               IF( J.GT.ISTART ) THEN
                  V( 1 ) = A( J, J-1 )
                  V( 2 ) = A( J+1, J-1 )
                  V( 3 ) = A( J+2, J-1 )
*
                  CALL DLARFG( 3, A( J, J-1 ), V( 2 ), 1, TAU )
                  V( 1 ) = ONE
                  A( J+1, J-1 ) = ZERO
                  A( J+2, J-1 ) = ZERO
               END IF
*
               DO 230 JC = J, ILASTM
                  TEMP = TAU*( A( J, JC )+V( 2 )*A( J+1, JC )+V( 3 )*
     $                   A( J+2, JC ) )
                  A( J, JC ) = A( J, JC ) - TEMP
                  A( J+1, JC ) = A( J+1, JC ) - TEMP*V( 2 )
                  A( J+2, JC ) = A( J+2, JC ) - TEMP*V( 3 )
                  TEMP2 = TAU*( B( J, JC )+V( 2 )*B( J+1, JC )+V( 3 )*
     $                    B( J+2, JC ) )
                  B( J, JC ) = B( J, JC ) - TEMP2
                  B( J+1, JC ) = B( J+1, JC ) - TEMP2*V( 2 )
                  B( J+2, JC ) = B( J+2, JC ) - TEMP2*V( 3 )
  230          CONTINUE
               IF( ILQ ) THEN
                  DO 240 JR = 1, N
                     TEMP = TAU*( Q( JR, J )+V( 2 )*Q( JR, J+1 )+V( 3 )*
     $                      Q( JR, J+2 ) )
                     Q( JR, J ) = Q( JR, J ) - TEMP
                     Q( JR, J+1 ) = Q( JR, J+1 ) - TEMP*V( 2 )
                     Q( JR, J+2 ) = Q( JR, J+2 ) - TEMP*V( 3 )
  240             CONTINUE
               END IF
*
*              Zero j-th column of B (see DLAGBC for details)
*
*              Swap rows to pivot
*
               ILPIVT = .FALSE.
               TEMP = MAX( ABS( B( J+1, J+1 ) ), ABS( B( J+1, J+2 ) ) )
               TEMP2 = MAX( ABS( B( J+2, J+1 ) ), ABS( B( J+2, J+2 ) ) )
               IF( MAX( TEMP, TEMP2 ).LT.SAFMIN ) THEN
                  SCALE = ZERO
                  U1 = ONE
                  U2 = ZERO
                  GO TO 250
               ELSE IF( TEMP.GE.TEMP2 ) THEN
                  W11 = B( J+1, J+1 )
                  W21 = B( J+2, J+1 )
                  W12 = B( J+1, J+2 )
                  W22 = B( J+2, J+2 )
                  U1 = B( J+1, J )
                  U2 = B( J+2, J )
               ELSE
                  W21 = B( J+1, J+1 )
                  W11 = B( J+2, J+1 )
                  W22 = B( J+1, J+2 )
                  W12 = B( J+2, J+2 )
                  U2 = B( J+1, J )
                  U1 = B( J+2, J )
               END IF
*
*              Swap columns if nec.
*
               IF( ABS( W12 ).GT.ABS( W11 ) ) THEN
                  ILPIVT = .TRUE.
                  TEMP = W12
                  TEMP2 = W22
                  W12 = W11
                  W22 = W21
                  W11 = TEMP
                  W21 = TEMP2
               END IF
*
*              LU-factor
*
               TEMP = W21 / W11
               U2 = U2 - TEMP*U1
               W22 = W22 - TEMP*W12
               W21 = ZERO
*
*              Compute SCALE
*
               SCALE = ONE
               IF( ABS( W22 ).LT.SAFMIN ) THEN
                  SCALE = ZERO
                  U2 = ONE
                  U1 = -W12 / W11
                  GO TO 250
               END IF
               IF( ABS( W22 ).LT.ABS( U2 ) )
     $            SCALE = ABS( W22 / U2 )
               IF( ABS( W11 ).LT.ABS( U1 ) )
     $            SCALE = MIN( SCALE, ABS( W11 / U1 ) )
*
*              Solve
*
               U2 = ( SCALE*U2 ) / W22
               U1 = ( SCALE*U1-W12*U2 ) / W11
*
  250          CONTINUE
               IF( ILPIVT ) THEN
                  TEMP = U2
                  U2 = U1
                  U1 = TEMP
               END IF
*
*              Compute Householder Vector
*
               T = SQRT( SCALE**2+U1**2+U2**2 )
               TAU = ONE + SCALE / T
               VS = -ONE / ( SCALE+T )
               V( 1 ) = ONE
               V( 2 ) = VS*U1
               V( 3 ) = VS*U2
*
*              Apply transformations from the right.
*
               DO 260 JR = IFRSTM, MIN( J+3, ILAST )
                  TEMP = TAU*( A( JR, J )+V( 2 )*A( JR, J+1 )+V( 3 )*
     $                   A( JR, J+2 ) )
                  A( JR, J ) = A( JR, J ) - TEMP
                  A( JR, J+1 ) = A( JR, J+1 ) - TEMP*V( 2 )
                  A( JR, J+2 ) = A( JR, J+2 ) - TEMP*V( 3 )
  260          CONTINUE
               DO 270 JR = IFRSTM, J + 2
                  TEMP = TAU*( B( JR, J )+V( 2 )*B( JR, J+1 )+V( 3 )*
     $                   B( JR, J+2 ) )
                  B( JR, J ) = B( JR, J ) - TEMP
                  B( JR, J+1 ) = B( JR, J+1 ) - TEMP*V( 2 )
                  B( JR, J+2 ) = B( JR, J+2 ) - TEMP*V( 3 )
  270          CONTINUE
               IF( ILZ ) THEN
                  DO 280 JR = 1, N
                     TEMP = TAU*( Z( JR, J )+V( 2 )*Z( JR, J+1 )+V( 3 )*
     $                      Z( JR, J+2 ) )
                     Z( JR, J ) = Z( JR, J ) - TEMP
                     Z( JR, J+1 ) = Z( JR, J+1 ) - TEMP*V( 2 )
                     Z( JR, J+2 ) = Z( JR, J+2 ) - TEMP*V( 3 )
  280             CONTINUE
               END IF
               B( J+1, J ) = ZERO
               B( J+2, J ) = ZERO
  290       CONTINUE
*
*           Last elements: Use Givens rotations
*
*           Rotations from the left
*
            J = ILAST - 1
            TEMP = A( J, J-1 )
            CALL DLARTG( TEMP, A( J+1, J-1 ), C, S, A( J, J-1 ) )
            A( J+1, J-1 ) = ZERO
*
            DO 300 JC = J, ILASTM
               TEMP = C*A( J, JC ) + S*A( J+1, JC )
               A( J+1, JC ) = -S*A( J, JC ) + C*A( J+1, JC )
               A( J, JC ) = TEMP
               TEMP2 = C*B( J, JC ) + S*B( J+1, JC )
               B( J+1, JC ) = -S*B( J, JC ) + C*B( J+1, JC )
               B( J, JC ) = TEMP2
  300       CONTINUE
            IF( ILQ ) THEN
               DO 310 JR = 1, N
                  TEMP = C*Q( JR, J ) + S*Q( JR, J+1 )
                  Q( JR, J+1 ) = -S*Q( JR, J ) + C*Q( JR, J+1 )
                  Q( JR, J ) = TEMP
  310          CONTINUE
            END IF
*
*           Rotations from the right.
*
            TEMP = B( J+1, J+1 )
            CALL DLARTG( TEMP, B( J+1, J ), C, S, B( J+1, J+1 ) )
            B( J+1, J ) = ZERO
*
            DO 320 JR = IFRSTM, ILAST
               TEMP = C*A( JR, J+1 ) + S*A( JR, J )
               A( JR, J ) = -S*A( JR, J+1 ) + C*A( JR, J )
               A( JR, J+1 ) = TEMP
  320       CONTINUE
            DO 330 JR = IFRSTM, ILAST - 1
               TEMP = C*B( JR, J+1 ) + S*B( JR, J )
               B( JR, J ) = -S*B( JR, J+1 ) + C*B( JR, J )
               B( JR, J+1 ) = TEMP
  330       CONTINUE
            IF( ILZ ) THEN
               DO 340 JR = 1, N
                  TEMP = C*Z( JR, J+1 ) + S*Z( JR, J )
                  Z( JR, J ) = -S*Z( JR, J+1 ) + C*Z( JR, J )
                  Z( JR, J+1 ) = TEMP
  340          CONTINUE
            END IF
*
*           ------------------- Begin Timing Code ----------------------
            OPST = OPST + ( DBLE( 14+30-10+52+12*( ILASTM-IFRSTM )+6*
     $             ( NQ+NZ ) )+DBLE( ILAST-1-ISTART )*
     $             DBLE( 14+24+90+20*( ILASTM-IFRSTM )+10*( NQ+NZ ) ) )
*           -------------------- End Timing Code -----------------------
*
*           End of Double-Shift code
*
         END IF
*
         GO TO 350
*
*        End of iteration loop
*
  350    CONTINUE
*        --------------------- Begin Timing Code -----------------------
         OPS = OPS + OPST
         OPST = ZERO
*        ---------------------- End Timing Code ------------------------
*
*
  360 CONTINUE
*
*     Drop-through = non-convergence
*
  370 CONTINUE
*     ---------------------- Begin Timing Code -------------------------
      OPS = OPS + OPST
      OPST = ZERO
*     ----------------------- End Timing Code --------------------------
*
      INFO = ILAST
      GO TO 420
*
*     Successful completion of all QZ steps
*
  380 CONTINUE
*
*     Set Eigenvalues 1:ILO-1
*
      DO 410 J = 1, ILO - 1
         IF( B( J, J ).LT.ZERO ) THEN
            IF( ILSCHR ) THEN
               DO 390 JR = 1, J
                  A( JR, J ) = -A( JR, J )
                  B( JR, J ) = -B( JR, J )
  390          CONTINUE
            ELSE
               A( J, J ) = -A( J, J )
               B( J, J ) = -B( J, J )
            END IF
            IF( ILZ ) THEN
               DO 400 JR = 1, N
                  Z( JR, J ) = -Z( JR, J )
  400          CONTINUE
            END IF
         END IF
         ALPHAR( J ) = A( J, J )
         ALPHAI( J ) = ZERO
         BETA( J ) = B( J, J )
  410 CONTINUE
*
*     Normal Termination
*
      INFO = 0
*
*     Exit (other than argument error) -- return optimal workspace size
*
  420 CONTINUE
*
*     ---------------------- Begin Timing Code -------------------------
      OPS = OPS + OPST
      OPST = ZERO
      ITCNT = JITER
*     ----------------------- End Timing Code --------------------------
*
      WORK( 1 ) = DBLE( N )
      RETURN
*
*     End of DHGEQZ
*
      END


      SUBROUTINE DOSTET(ENER,IDIME,NBAND,IDEF,NTET,XE,NE,Y,Z)
C     COMPUTE A DENSITY OF STATES USING THE TETRAHEDRONS METHOD.
C     XE CONTAINS THE ENERGIES, Y AND Z RETURN THE RELATED DENSITY OF
C     STATES AND THE INTEGRATED DENSITY OF STATES, RESPECTIVELY.
      IMPLICIT REAL*8(A-H,O-Z)
      REAL*4 AVOL
      DIMENSION ENER(IDIME,1),XE(1),Y(1),Z(1),IDEF(5,1),C(4)
      EQUIVALENCE (IVOL,AVOL),(C(1),E1),(C(2),E2),(C(3),E3),(C(4),E4)
      DATA EPS/1.0D-05/
      DO 6 IX=1,NE
      Y(IX)=0.D0
    6 Z(IX)=0.D0
C
C     LOOP OVER THE TETRAHEDRONS
      DO 9 ITET=1,NTET
C
      IA=IDEF(1,ITET)
      IB=IDEF(2,ITET)
      IC=IDEF(3,ITET)
      ID=IDEF(4,ITET)
      IVOL=IDEF(5,ITET)
C
C     LOOP OVER THE BANDS
      DO 9 NB=1,NBAND
C
C *** DEFINE E1, E2, E3, E4, AS THE CORNER ENERGIES ORDERED BY
C *** DECREASING SIZE
      C(1)=ENER(NB,IA)
      C(2)=ENER(NB,IB)
      C(3)=ENER(NB,IC)
      C(4)=ENER(NB,ID)
      DO 2 I=1,4
      CC=C(I)
      J=I
    1 J=J+1
      IF(J.GT.4) GOTO 2
      IF(CC.GE.C(J)) GOTO 1
      C(I)=C(J)
      C(J)=CC
      CC=C(I)
      GOTO 1
    2 CONTINUE
      UNITE=1.0D0
      IF(E1.GT.E4) UNITE=E1-E4
      E12=(E1-E2)/UNITE
      E13=(E1-E3)/UNITE
      E14=(E1-E4)/UNITE
      E23=(E2-E3)/UNITE
      E24=(E2-E4)/UNITE
      E34=(E3-E4)/UNITE
      FACY=3.D0*DBLE(AVOL)/UNITE
      DO 9 IX=1,NE
      E=XE(IX)
      SURFAC=0.D0
      VOLUME=1.D0
      IF(E.GT.E1) GOTO 8
      VOLUME=0.D0
      IF(E.LT.E4) GOTO 8
      EE1=(E-E1)/UNITE
      IF(DABS(EE1).LT.EPS) EE1=0.D0
      EE2=(E-E2)/UNITE
      IF(DABS(EE2).LT.EPS) EE2=0.D0
      EE3=(E-E3)/UNITE
      IF(DABS(EE3).LT.EPS) EE3=0.D0
      EE4=(E-E4)/UNITE
      IF(DABS(EE4).LT.EPS) EE4=0.D0
      IF(E.GT.E3) GOTO 5
C *** E4.LE.E.AND.E.LE.E3
      IF(E4.EQ.E3) GOTO 3
      SURFAC=(EE4/E34)*(EE4/E24)
      VOLUME=SURFAC*EE4
      GOTO 8
    3 IF(E3.LT.E2) GOTO 8
      IF(E2.EQ.E1) GOTO 4
      SURFAC=1.D0/E12
      GOTO 8
    4 SURFAC=1.0D+15
      VOLUME=0.5D0
      GOTO 8
    5 IF(E.GT.E2) GOTO 7
C *** E3.LT.E.AND.E.LE.E2
      SURFAC=-(EE3*EE2/E23+EE4*EE1)/E13/E24
      VOLUME=(0.5D0*EE3*(2.D0*E13*E34+E13*EE4-E34*EE1-2.D0*EE1*EE4+
     +                 EE3*(EE3-3.D0*EE2)/E23)/E13+E34*E34)/E24
      GOTO 8
C *** E2.LT.E.AND.E.LE.E1
    7 SURFAC=(EE1/E12)*(EE1/E13)
      VOLUME=1.D0+SURFAC*EE1
    8 Y(IX)=Y(IX)+FACY*SURFAC
      Z(IX)=Z(IX)+DBLE(AVOL)*VOLUME
    9 CONTINUE
      RETURN
      END


      SUBROUTINE SB10ID( N, M, NP, A, LDA, B, LDB, C, LDC, D, LDD,
     $                   FACTOR, NK, AK, LDAK, BK, LDBK, CK, LDCK,
     $                   DK, LDDK, RCOND, IWORK, DWORK, LDWORK, BWORK,
     $                   INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute the matrices of the positive feedback controller
C
C              | Ak | Bk |
C          K = |----|----|
C              | Ck | Dk |
C
C     for the shaped plant
C
C              | A | B |
C          G = |---|---|
C              | C | D |
C
C     in the McFarlane/Glover Loop Shaping Design Procedure.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the plant.  N >= 0.
C
C     M       (input) INTEGER
C             The column size of the matrix B.  M >= 0.
C
C     NP      (input) INTEGER
C             The row size of the matrix C.  NP >= 0.
C
C     A       (input) DOUBLE PRECISION array, dimension (LDA,N)
C             The leading N-by-N part of this array must contain the
C             system state matrix A of the shaped plant.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= max(1,N).
C
C     B       (input) DOUBLE PRECISION array, dimension (LDB,M)
C             The leading N-by-M part of this array must contain the
C             system input matrix B of the shaped plant.
C
C     LDB     INTEGER
C             The leading dimension of the array B.  LDB >= max(1,N).
C
C     C       (input) DOUBLE PRECISION array, dimension (LDC,N)
C             The leading NP-by-N part of this array must contain the
C             system output matrix C of the shaped plant.
C
C     LDC     INTEGER
C             The leading dimension of the array C.  LDC >= max(1,NP).
C
C     D       (input) DOUBLE PRECISION array, dimension (LDD,M)
C             The leading NP-by-M part of this array must contain the
C             system matrix D of the shaped plant.
C
C     LDD     INTEGER
C             The leading dimension of the array D.  LDD >= max(1,NP).
C
C     FACTOR  (input) DOUBLE PRECISION
C             = 1 implies that an optimal controller is required;
C             > 1 implies that a suboptimal controller is required,
C                 achieving a performance FACTOR less than optimal.
C             FACTOR >= 1.
C
C     NK      (output) INTEGER
C             The order of the positive feedback controller.  NK <= N.
C
C     AK      (output) DOUBLE PRECISION array, dimension (LDAK,N)
C             The leading NK-by-NK part of this array contains the
C             controller state matrix Ak.
C
C     LDAK    INTEGER
C             The leading dimension of the array AK.  LDAK >= max(1,N).
C
C     BK      (output) DOUBLE PRECISION array, dimension (LDBK,NP)
C             The leading NK-by-NP part of this array contains the
C             controller input matrix Bk.
C
C     LDBK    INTEGER
C             The leading dimension of the array BK.  LDBK >= max(1,N).
C
C     CK      (output) DOUBLE PRECISION array, dimension (LDCK,N)
C             The leading M-by-NK part of this array contains the
C             controller output matrix Ck.
C
C     LDCK    INTEGER
C             The leading dimension of the array CK.  LDCK >= max(1,M).
C
C     DK      (output) DOUBLE PRECISION array, dimension (LDDK,NP)
C             The leading M-by-NP part of this array contains the
C             controller matrix Dk.
C
C     LDDK    INTEGER
C             The leading dimension of the array DK.  LDDK >= max(1,M).
C
C     RCOND   (output) DOUBLE PRECISION array, dimension (2)
C             RCOND(1) contains an estimate of the reciprocal condition
C                      number of the X-Riccati equation;
C             RCOND(2) contains an estimate of the reciprocal condition
C                      number of the Z-Riccati equation.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (max(2*N,N*N,M,NP))
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) contains the optimal value
C             of LDWORK.
C
C     LDWORK  INTEGER
C             The dimension of the array DWORK.
C             LDWORK >= 4*N*N + M*M + NP*NP + 2*M*N + N*NP + 4*N +
C                       max( 6*N*N + 5 + max(1,4*N*N+8*N), N*NP + 2*N ).
C             For good performance, LDWORK must generally be larger.
C             An upper bound of LDWORK in the above formula is
C             LDWORK >= 10*N*N + M*M + NP*NP + 2*M*N + 2*N*NP + 4*N +
C                       5 + max(1,4*N*N+8*N).
C
C     BWORK   LOGICAL array, dimension (2*N)
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:  the X-Riccati equation is not solved successfully;
C             = 2:  the Z-Riccati equation is not solved successfully;
C             = 3:  the iteration to compute eigenvalues or singular
C                   values failed to converge;
C             = 4:  the matrix Ip - D*Dk is singular;
C             = 5:  the matrix Im - Dk*D is singular;
C             = 6:  the closed-loop system is unstable.
C
C     METHOD
C
C     The routine implements the formulas given in [1].
C
C     REFERENCES
C
C     [1] McFarlane, D. and Glover, K.
C         A loop shaping design procedure using H_infinity synthesis.
C         IEEE Trans. Automat. Control, vol. AC-37, no. 6, pp. 759-769,
C         1992.
C
C     NUMERICAL ASPECTS
C
C     The accuracy of the results depends on the conditioning of the
C     two Riccati equations solved in the controller design (see the
C     output parameter RCOND).
C
C     CONTRIBUTORS
C
C     P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, October 2000.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Oct. 2000,
C     Feb. 2001.
C
C     KEYWORDS
C
C     H_infinity control, Loop-shaping design, Robust control.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
C     ..
C     .. Scalar Arguments ..
      INTEGER            INFO, LDA, LDAK, LDB, LDBK, LDC, LDCK, LDD,
     $                   LDDK, LDWORK, M, N, NK, NP
      DOUBLE PRECISION   FACTOR
C     ..
C     .. Array Arguments ..
      INTEGER            IWORK( * )
      LOGICAL            BWORK( * )
      DOUBLE PRECISION   A( LDA, * ), AK( LDAK, * ), B( LDB, * ),
     $                   BK( LDBK, * ), C( LDC, * ), CK( LDCK, * ),
     $                   D( LDD, * ), DK( LDDK, * ), DWORK( * ),
     $                   RCOND( 2 )
C     ..
C     .. Local Scalars ..
      CHARACTER*1        HINV
      INTEGER            I, I1, I2, I3, I4, I5, I6, I7, I8, I9, I10,
     $                   I11, I12, I13, INFO2, IWRK, J, LWA, LWAMAX,
     $                   MINWRK, N2, NS, SDIM
      DOUBLE PRECISION   SEP, FERR, GAMMA
C     ..
C     .. External Functions ..
      LOGICAL            SELECT
      EXTERNAL           SELECT
C     ..
C     .. External Subroutines ..
      EXTERNAL           DGEES, DGEMM, DLACPY, DLASET, DPOTRF, DPOTRS,
     $                   DSYRK, DTRSM, MB02VD, SB02RD, SB10JD, XERBLA
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC          DBLE, INT, MAX, SQRT
C     ..
C     .. Executable Statements ..
C
C     Decode and Test input parameters.
C
      INFO = 0
      IF( N.LT.0 ) THEN
         INFO = -1
      ELSE IF( M.LT.0 ) THEN
         INFO = -2
      ELSE IF( NP.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -5
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -7
      ELSE IF( LDC.LT.MAX( 1, NP ) ) THEN
         INFO = -9
      ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN
         INFO = -11
      ELSE IF( FACTOR.LT.ONE ) THEN
         INFO = -12
      ELSE IF( LDAK.LT.MAX( 1, N ) ) THEN
         INFO = -15
      ELSE IF( LDBK.LT.MAX( 1, N ) ) THEN
         INFO = -17
      ELSE IF( LDCK.LT.MAX( 1, M ) ) THEN
         INFO = -19
      ELSE IF( LDDK.LT.MAX( 1, M ) ) THEN
         INFO = -21
      END IF
C
C     Compute workspace.
C
      MINWRK = 4*N*N + M*M + NP*NP + 2*M*N + N*NP + 4*N +
     $         MAX( 6*N*N + 5 + MAX( 1, 4*N*N + 8*N ), N*NP + 2*N )
      IF( LDWORK.LT.MINWRK ) THEN
         INFO = -25
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'SB10ID', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( N.EQ.0 .OR. M.EQ.0 .OR. NP.EQ.0 ) THEN
         RCOND( 1 ) = ONE
         RCOND( 2 ) = ONE
         DWORK( 1 ) = ONE
         RETURN
      END IF
C
C     Workspace usage.
C
      I1  = N*N
      I2  = I1  + N*N
      I3  = I2  + M*N
      I4  = I3  + M*N
      I5  = I4  + M*M
      I6  = I5  + NP*NP
      I7  = I6  + NP*N
      I8  = I7  + N*N
      I9  = I8  + N*N
      I10 = I9  + N*N
      I11 = I10 + N*N
      I12 = I11 + 2*N
      I13 = I12 + 2*N
C
      IWRK = I13 + 4*N*N
C
C     Compute D'*C .
C
      CALL DGEMM( 'T', 'N', M, N, NP, ONE, D, LDD, C, LDC, ZERO,
     $            DWORK( I2+1 ), M )
C
C     Compute S = Im + D'*D .
C
      CALL DLASET( 'U', M, M, ZERO, ONE, DWORK( I4+1 ), M )
      CALL DSYRK( 'U', 'T', M, NP, ONE, D, LDD, ONE, DWORK( I4+1 ), M )
C
C     Factorize S, S = T'*T, with T upper triangular.
C
      CALL DPOTRF( 'U', M, DWORK( I4+1 ), M, INFO2 )
C
C              -1
C     Compute S  D'*C .
C
      CALL DPOTRS( 'U', M, N, DWORK( I4+1 ), M, DWORK( I2+1 ), M,
     $             INFO2 )
C
C                -1
C     Compute B*T  .
C
      CALL DLACPY( 'F', N, M, B, LDB, DWORK( I3+1 ), N )
      CALL DTRSM(  'R', 'U', 'N', 'N', N, M, ONE, DWORK( I4+1 ), M,
     $             DWORK( I3+1 ), N )
C
C     Compute R = Ip + D*D' .
C
      CALL DLASET( 'U', NP, NP, ZERO, ONE, DWORK( I5+1 ), NP )
      CALL DSYRK( 'U', 'N', NP, M, ONE, D, LDD, ONE, DWORK( I5+1 ), NP )
C
C     Factorize R, R = U'*U, with U upper triangular.
C
      CALL DPOTRF( 'U', NP, DWORK( I5+1 ), NP, INFO2 )
C
C              -T
C     Compute U  C .
C
      CALL DLACPY( 'F', NP, N, C, LDC, DWORK( I6+1 ), NP )
      CALL DTRSM(  'L', 'U', 'T', 'N', NP, N, ONE, DWORK( I5+1 ), NP,
     $             DWORK( I6+1 ), NP )
C
C                         -1
C     Compute Ar = A - B*S  D'*C .
C
      CALL DLACPY( 'F', N, N, A, LDA, DWORK( I7+1 ), N )
      CALL DGEMM( 'N', 'N', N, N, M, -ONE, B, LDB, DWORK( I2+1 ), M,
     $            ONE, DWORK( I7+1 ), N )
C
C                                            -1
C     Compute the upper triangle of Cr = C'*R  *C .
C
      CALL DSYRK( 'U', 'T', N, NP, ONE, DWORK( I6+1 ), NP, ZERO,
     $            DWORK( I8+1 ), N )
C
C                                           -1
C     Compute the upper triangle of Dr = B*S  B' .
C
      CALL DSYRK( 'U', 'N', N, M, ONE, DWORK( I3+1 ), N, ZERO,
     $            DWORK( I9+1 ), N )
C
C     Solution of the Riccati equation Ar'*X + X*Ar + Cr - X*Dr*X = 0 .
C     Workspace:    need   10*N*N + M*M + NP*NP + 2*M*N + N*NP + 4*N +
C                                   5 + max(1,4*N*N+8*N).
C                   prefer larger.
C                   AK is used as workspace.
C
      N2 = 2*N
      CALL SB02RD( 'A', 'C', HINV, 'N', 'U', 'G', 'S', 'N', 'O', N,
     $             DWORK( I7+1 ), N, DWORK( I10+1 ), N, AK, LDAK,
     $             DWORK( I9+1 ), N, DWORK( I8+1 ), N, DWORK, N, SEP,
     $             RCOND( 1 ), FERR, DWORK( I11+1 ), DWORK( I12+1 ),
     $             DWORK( I13+1 ), N2, IWORK, DWORK( IWRK+1 ),
     $             LDWORK-IWRK, BWORK, INFO2 )
      IF( INFO2.NE.0 ) THEN
         INFO = 1
         RETURN
      END IF
      LWA = INT( DWORK( IWRK+1 ) ) + IWRK
      LWAMAX = MAX( MINWRK, LWA )
C
C     Solution of the Riccati equation Ar*Z + Z*Ar' + Dr - Z*Cr*Z = 0 .
C
      CALL SB02RD( 'A', 'C', HINV, 'T', 'U', 'G', 'S', 'N', 'O', N,
     $             DWORK( I7+1 ), N, DWORK( I10+1 ), N, AK, LDAK,
     $             DWORK( I8+1 ), N, DWORK( I9+1 ), N, DWORK( I1+1 ),
     $             N, SEP, RCOND( 2 ), FERR, DWORK( I11+1 ),
     $             DWORK( I12+1 ), DWORK( I13+1 ), N2, IWORK,
     $             DWORK( IWRK+1 ), LDWORK-IWRK, BWORK, INFO2 )
      IF( INFO2.NE.0 ) THEN
         INFO = 2
         RETURN
      END IF
      LWA = INT( DWORK( IWRK+1 ) ) + IWRK
      LWAMAX = MAX( LWA, LWAMAX )
C
C                      -1        -1
C     Compute F1 = -( S  D'*C + S  B'*X ) .
C
      CALL DTRSM(  'R', 'U', 'T', 'N', N, M, ONE, DWORK( I4+1 ), M,
     $             DWORK( I3+1 ), N )
      CALL DGEMM( 'T', 'N', M, N, N, -ONE, DWORK( I3+1 ), N, DWORK, N,
     $            -ONE, DWORK( I2+1 ), M )
C
C     Compute gamma .
C
      CALL DGEMM( 'N', 'N', N, N, N, ONE, DWORK, N, DWORK( I1+1 ), N,
     $            ZERO, DWORK( I7+1 ), N )
      CALL DGEES( 'N', 'N', SELECT, N, DWORK( I7+1 ), N, SDIM,
     $            DWORK( I11+1 ), DWORK( I12+1 ), DWORK( IWRK+1 ), N,
     $            DWORK( IWRK+1 ), LDWORK-IWRK, BWORK, INFO2 )
      IF( INFO2.NE.0 ) THEN
         INFO = 3
         RETURN
      END IF
      LWA = INT( DWORK( IWRK+1 ) ) + IWRK
      LWAMAX = MAX( LWA, LWAMAX )
      GAMMA = ZERO
      DO 10 I = 1, N
         GAMMA = MAX( GAMMA, DWORK( I11+I ) )
   10 CONTINUE
      GAMMA = FACTOR*SQRT( ONE + GAMMA )
C
C     Workspace usage.
C     Workspace:    need   4*N*N + M*N + N*NP.
C
      I4 = I3 + N*N
      I5 = I4 + N*N
C
C     Compute Ac = A + B*F1 .
C
      CALL DLACPY( 'F', N, N, A, LDA, DWORK( I4+1 ), N )
      CALL DGEMM( 'N', 'N', N, N, M, ONE, B, LDB, DWORK( I2+1 ), M,
     $            ONE, DWORK( I4+1 ), N )
C
C     Compute W1' = (1-gamma^2)*In + Z*X .
C
      CALL DLASET( 'F', N, N, ZERO, ONE-GAMMA*GAMMA, DWORK( I3+1 ), N )
      CALL DGEMM( 'N', 'N', N, N, N, ONE, DWORK( I1+1 ), N, DWORK, N,
     $            ONE, DWORK( I3+1 ), N )
C
C     Compute Bcp = gamma^2*Z*C' .
C
      CALL DGEMM( 'N', 'T', N, NP, N, GAMMA*GAMMA, DWORK( I1+1 ), N, C,
     $            LDC, ZERO, BK, LDBK )
C
C     Compute C + D*F1 .
C
      CALL DLACPY( 'F', NP, N, C, LDC, DWORK( I5+1 ), NP )
      CALL DGEMM( 'N', 'N', NP, N, M, ONE, D, LDD, DWORK( I2+1 ), M,
     $            ONE, DWORK( I5+1 ), NP )
C
C     Compute Acp = W1'*Ac + gamma^2*Z*C'*(C+D*F1) .
C
      CALL DGEMM( 'N', 'N', N, N, N, ONE, DWORK( I3+1 ), N,
     $            DWORK( I4+1 ), N, ZERO, AK, LDAK )
      CALL DGEMM( 'N', 'N', N, N, NP, ONE, BK, LDBK,
     $            DWORK( I5+1 ), NP, ONE, AK, LDAK )
C
C     Compute Ccp = B'*X .
C
      CALL DGEMM( 'T', 'N', M, N, N, ONE, B, LDB, DWORK, N, ZERO,
     $             CK, LDCK )
C
C     Set Dcp = -D' .
C
      DO 30 I = 1, M
         DO 20 J = 1, NP
            DK( I, J ) = -D( J, I )
   20    CONTINUE
   30 CONTINUE
C
      IWRK = I4
C
C     Reduce the generalized state-space description to a regular one.
C     Workspace:             need   3*N*N + M*N.
C     Additional workspace:  need   2*N*N + 2*N + N*MAX(5,N+M+NP).
C                            prefer larger.
C
      CALL SB10JD( N, NP, M, AK, LDAK, BK, LDBK, CK, LDCK, DK, LDDK,
     $             DWORK( I3+1 ), N, NK, DWORK( IWRK+1 ), LDWORK-IWRK,
     $             INFO2 )
      IF( INFO2.NE.0 ) THEN
         INFO = 3
         RETURN
      END IF
      LWA = INT( DWORK( IWRK+1 ) ) + IWRK
      LWAMAX = MAX( LWA, LWAMAX )
C
C     Workspace usage.
C     Workspace:    need   4*N*N + M*M + NP*NP + 2*M*N + 2*N*NP.
C                          (NK <= N.)
C
      I2 = NP*NP
      I3 = I2 + NK*NP
      I4 = I3 + M*M
      I5 = I4 + N*M
      I6 = I5 + NP*NK
      I7 = I6 + M*N
C
      IWRK = I7 + ( N + NK )*( N + NK )
C
C     Compute Ip - D*Dk .
C
      CALL DLASET( 'Full', NP, NP, ZERO, ONE, DWORK, NP )
      CALL DGEMM( 'N', 'N', NP, NP, M, -ONE, D, LDD, DK, LDDK, ONE,
     $             DWORK, NP )
C
C                         -1
C     Compute Bk*(Ip-D*Dk)  .
C
      CALL DLACPY( 'F', NK, NP, BK, LDBK, DWORK( I2+1 ), NK )
      CALL MB02VD( 'N', NK, NP, DWORK, NP, IWORK, DWORK( I2+1 ), NK,
     $             INFO2 )
      IF( INFO2.NE.0 ) THEN
         INFO = 4
         RETURN
      END IF
C
C     Compute Im - Dk*D .
C
      CALL DLASET( 'Full', M, M, ZERO, ONE, DWORK( I3+1 ), M )
      CALL DGEMM( 'N', 'N', M, M, NP, -ONE, DK, LDDK, D, LDD, ONE,
     $             DWORK( I3+1 ), M )
C
C                        -1
C     Compute B*(Im-Dk*D)  .
C
      CALL DLACPY( 'F', N, M, B, LDB, DWORK( I4+1 ), N )
      CALL MB02VD( 'N', N, M, DWORK( I3+1 ), M, IWORK, DWORK( I4+1 ), N,
     $             INFO2 )
      IF( INFO2.NE.0 ) THEN
         INFO = 5
         RETURN
      END IF
C
C     Compute D*Ck .
C
      CALL DGEMM( 'N', 'N', NP, NK, M, ONE, D, LDD, CK, LDCK, ZERO,
     $             DWORK( I5+1 ), NP )
C
C     Compute Dk*C .
C
      CALL DGEMM( 'N', 'N', M, N, NP, ONE, DK, LDDK, C, LDC, ZERO,
     $            DWORK( I6+1 ), M )
C
C     Compute the closed-loop state matrix.
C
      CALL DLACPY( 'F', N, N, A, LDA, DWORK( I7+1 ), N+NK )
      CALL DGEMM( 'N', 'N', N, N, M, ONE, DWORK( I4+1 ), N,
     $            DWORK( I6+1 ), M, ONE, DWORK( I7+1 ), N+NK )
      CALL DGEMM( 'N', 'N', NK, N, NP, ONE, DWORK( I2+1 ), NK, C, LDC,
     $            ZERO, DWORK( I7+N+1 ), N+NK )
      CALL DGEMM( 'N', 'N', N, NK, M, ONE, DWORK( I4+1 ), N, CK, LDCK,
     $            ZERO, DWORK( I7+(N+NK)*N+1 ), N+NK )
      CALL DLACPY( 'F', NK, NK, AK, LDAK, DWORK( I7+(N+NK)*N+N+1 ),
     $             N+NK )
      CALL DGEMM( 'N', 'N', NK, NK, NP, ONE, DWORK( I2+1 ), NK,
     $            DWORK( I5+1 ), NP, ONE, DWORK( I7+(N+NK)*N+N+1 ),
     $            N+NK )
C
C     Compute the closed-loop poles.
C     Additional workspace:  need 3*(N+NK);  prefer larger.
C     The fact that M > 0, NP > 0, and NK <= N is used here.
C
      CALL DGEES( 'N', 'N', SELECT, N+NK, DWORK( I7+1 ), N+NK, SDIM,
     $            DWORK, DWORK( N+NK+1 ), DWORK( IWRK+1 ), N,
     $            DWORK( IWRK+1 ), LDWORK-IWRK, BWORK, INFO2 )
      IF( INFO2.NE.0 ) THEN
         INFO = 3
         RETURN
      END IF
      LWA = INT( DWORK( IWRK+1 ) ) + IWRK
      LWAMAX = MAX( LWA, LWAMAX )
C
C     Check the stability of the closed-loop system.
C
      NS = 0
      DO 40 I = 1, N+NK
         IF( DWORK( I ).GE.ZERO ) NS = NS + 1
   40 CONTINUE
      IF( NS.GT.0 ) THEN
         INFO = 6
         RETURN
      END IF
C
      DWORK( 1 ) = DBLE( LWAMAX )
      RETURN
C *** Last line of SB10ID ***
      END


      double precision function getet(E,px,py,pz)
c--- given (E,px,py,pz) for a four-vector, calculates the corresponding
c--- Et or Pt, depending on the parameter that is set in mdata.f
      implicit none
      double precision E,px,py,pz,etsq
      include 'useet.f'

      if (useEt) then
c--- this is the formula for Et
        etsq=px**2+py**2
        getet=dsqrt(etsq)*E/dsqrt(etsq+pz**2)
      else
c--- this is the formula for pt
        getet=dsqrt(px**2+py**2)
      endif

      return
      end


      subroutine matr(tlm,lmax,dmat,dmat1)
! ===================
!
! R=(tvec,phi)
! dmat = D(R) and dmat1 = D(R)+
!
      implicit real*8 (a-h,o-z)
!     include '../param.h'
!     parameter(jdim=2*lmaxp+2)
!
      dimension tlm(4)
      complex*16 dmat(2*(lmax+1)*(lmax+1),2*(lmax+1)*(lmax+1))
      complex*16 dmat1(2*(lmax+1)*(lmax+1),2*(lmax+1)*(lmax+1))
      complex*16 cmat(2*(lmax+1)*(lmax+1),2*(lmax+1)*(lmax+1))
      complex*16 d(2*lmax+2,2*lmax+2)
!     common/test/itest
!
      kmax=2*lmax+1
      kmymax=2*(lmax+1)*(lmax+1)
!
! Set up matrix of rotation
!
      do i=1,kmymax
      do j=1,kmymax
        dmat(i,j)=(0.d0,0.d0)
      end do
      end do
      ist=0
      do j2=1,2*lmax-1,2
        il=j2+1
        call rotmat(d,trd,il,tlm,1,lmax)
        do icase=1,2
          do m1=1,il
          do m2=1,il
            dmat(ist+m1,ist+m2)=d(il+1-m1,il+1-m2)
          end do
          end do
          ist=ist+il
        end do
      end do
      j2=2*lmax+1
      il=j2+1
      call rotmat(d,trd,il,tlm,1,lmax)
      do m1=1,il
      do m2=1,il
! fill up matrix according to ascending m index
        dmat(ist+m1,ist+m2)=d(il+1-m1,il+1-m2)
      end do
      end do
!
      do i=1,kmymax
      do j=1,kmymax
        dmat1(i,j)=dconjg(dmat(j,i))
      end do
      end do
!
c$$$  if(0.lt.4) return
c$$$  write(6,'(/'' Matrix of rotation'')')
c$$$  call outmat(dmat,kmymax,kmymax,2*(lmax+1)*(lmax+1),6)
c$$$  write(6,'(/'' Inverse'')')
c$$$  call outmat(dmat1,kmymax,kmymax,2*(lmax+1)*(lmax+1),6)
c$$$  call repl(cmat,dmat,kmymax,2*(lmax+1)*(lmax+1))
c$$$  call doubmt(cmat,dmat1,kmymax,2*(lmax+1)*(lmax+1))
c$$$  write(6,'(/'' D(R) * D(R**-1) '')')
c$$$  call outmat(cmat,kmymax,kmymax,2*(lmax+1)*(lmax+1),6)
!
c$$$  return
      end


c***********************************************************************
c	                    COORD_VH2B.F
c***********************************************************************
*     PURPOSE: Converts from Heliocentric to Barycentric coords.
*              Velocity only
*     ARGUMENTS:  Input is
*                    nbod ==> number of bodies (must be less than NBMAX)
*                             (integer)
*	             mass(*) ==>  masses (real array)
*		     vxh(*),vyh(*),vzh(*) ==> heliocentric particle velocities
*                                             (real array)
*                 Returned are
*                    vxb(*),vyb(*),vzb(*) ==> bary. particle velocities
*                                            (real array)
*                    msys              ==>  Total mass of of system
*                                            (real scalar)
*     Authors:  Hal Levison
*     ALGORITHM: Obvious
*     WRITTEN:  11/14/96
*     REVISIONS: 11/21/96

	subroutine coord_vh2b(nbod,mass,vxh,vyh,vzh,vxb,vyb,vzb,msys)

      include '../swift.inc'

c...  Inputs:
	integer nbod
	real*8 mass(nbod)
	real*8 vxh(nbod),vyh(nbod),vzh(nbod)

c...  Outputs:
	real*8 vxb(nbod),vyb(nbod),vzb(nbod)

c...  Internals:
	real*8 msys,vxtmp,vytmp,vztmp
	integer n

c----
c...  Executable code

	msys = mass(1)
	vxtmp =0.d0
	vytmp =0.d0
	vztmp =0.d0

	do n=2,nbod
	   msys = msys +mass(n)
	   vxtmp = vxtmp + mass(n)*vxh(n)
	   vytmp = vytmp + mass(n)*vyh(n)
	   vztmp = vztmp + mass(n)*vzh(n)
	enddo

	vxb(1) = -vxtmp/msys
	vyb(1) = -vytmp/msys
	vzb(1) = -vztmp/msys

	do n=2,nbod
	  vxb(n) = vxh(n) + vxb(1)
	  vyb(n) = vyh(n) + vyb(1)
	  vzb(n) = vzh(n) + vzb(1)
	enddo

	return
	end     ! coord_vh2b
c--------------------------------------------------------------------------


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

  real(8),parameter :: Pi=3.141592653589793d0

  public :: erf_salmon, &
            erfc_salmon, &
            bessel_j1_salmon, &
            matrix_inverse, &
            xjl, dxjl

  interface matrix_inverse
     module procedure matrix_inverse_double
     module procedure matrix_inverse_complex
  end interface
contains
!--------------------------------------------------------------------------------
!! Error function and its complement are implemented based on the reference
!! W. J. Cody, Math. Comp. 23 631 (1969)
  function erf_salmon(x) result(y)
    implicit none
    real(8),intent(in) :: x
    real(8) :: y
    real(8) :: xa

    xa = abs(x)
    if(xa < 0.46875d0)then
       y = sign( erf_salmon_short(xa) , x )
    else if(xa < 4d0)then
       y = erfc_salmon_mid(xa)
       y = sign(1d0 - y,x)
    else
       y = erfc_salmon_long(xa)
       y = sign(1d0 - y,x)
    end if

  end function erf_salmon
!--------------------------------------------------------------------------------
  function erfc_salmon(x) result(y)
    implicit none
    real(8),intent(in) :: x
    real(8) :: y
    real(8) :: xa

    xa = abs(x)
    if(xa < 0.46875d0)then
       y = 1d0 - erf_salmon(xa)
    else if(xa < 4d0)then
       y = erfc_salmon_mid(xa)
    else
       y = erfc_salmon_long(xa)
    end if

    if(x<0d0) y = 2d0 - y

  end function erfc_salmon
!--------------------------------------------------------------------------------
  function erf_salmon_short(x) result(y) ! 0d0 <=x<0.5d0
    implicit none
    real(8),intent(in) :: x
    real(8) :: y
    real(8) :: x2
    real(8),parameter :: &
       a(0:4) = (/  &
       & 3.209377589138469472562d3, &
       & 3.774852376853020208137d2, &
       & 1.138641541510501556495d2, &
       & 3.161123743870565596947d0, &
       & 1.857777061846031526730d-1 &
       &/), &
       b(0:4) = (/  &
       & 2.844236833439170622273d3, &
       & 1.282616526077372275645d3, &
       & 2.440246379344441733056d2, &
       & 2.360129095234412093499d1, &
       & 1d0 &
       &/)

    x2 = x**2
    y = x*(a(0) + a(1)*x2 + a(2)*x2**2 + a(3)*x2**3 + a(4)*x2**4 ) &
         /(b(0) + b(1)*x2 + b(2)*x2**2 + b(3)*x2**3 + b(4)*x2**4 )

  end function erf_salmon_short
!--------------------------------------------------------------------------------
  function erfc_salmon_mid(x) result(y) ! 0.46875d0 <x< 4d0
    implicit none
    real(8),intent(in) :: x
    real(8) :: y
    real(8) :: x2
    real(8),parameter :: &
       p(0:7) = (/  &
       & 3.004592610201616005d2, &
       & 4.519189537118729422d2, &
       & 3.393208167343436870d2, &
       & 1.529892850469404039d2, &
       & 4.316222722205673530d1, &
       & 7.211758250883093659d0, &
       & 5.641955174789739711d-1, &
       &-1.368648573827167067d-7 &
       &/), &
       q(0:7) = (/ &
       & 3.004592609569832933d2, &
       & 7.909509253278980272d2, &
       & 9.313540948506096211d2, &
       & 6.389802644656311665d2, &
       & 2.775854447439876434d2, &
       & 7.700015293522947295d1, &
       & 1.278272731962942351d1, &
       & 1d0 &
       &/)

    x2 = x**2

    y = (p(0) + p(1)*x + p(2)*x**2 + p(3)*x**3 + p(4)*x**4 &
         + p(5)*x**5 + p(6)*x**6 + p(7)*x**7)/ &
         (q(0) + q(1)*x + q(2)*x**2 + q(3)*x**3 + q(4)*x**4 &
         + q(5)*x**5 + q(6)*x**6 + q(7)*x**7)
    y = exp(-x2)*y

  end function erfc_salmon_mid
!--------------------------------------------------------------------------------
  function erfc_salmon_long(x) result(y) ! 4d0 <x
    implicit none
    real(8),intent(in) :: x
    real(8) :: y
    real(8) :: x2,x2_i
    real(8),parameter :: &
       r(0:4) = (/ &
       & -2.99610707703542174d-3, &
       & -4.94730910623250734d-2, &
       & -2.26956593539686930d-1, &
       & -2.78661308609647788d-1, &
       & -2.23192459734184686d-2  &
       &/), &
       s(0:4) = (/ &
       & 1.06209230528467918d-2, &
       & 1.91308926107829841d-1, &
       & 1.05167510706793207d0,  &
       & 1.98733201817135256d0,  &
       & 1d0 &
       &/)

    x2 = x**2

    x2_i = 1d0/x2
    y = 1d0/sqrt(pi) &
         +x2_i*(r(0) + r(1)*x2_i + r(2)*x2_i**2 + r(3)*x2_i**3 + r(4)*x2_i**4) &
         /(s(0) + s(1)*x2_i + s(2)*x2_i**2 + s(3)*x2_i**3 + s(4)*x2_i**4)
    y = exp(-x2)/x*y

  end function erfc_salmon_long

!--------------------------------------------------------------------------------
  !! 1st order Bessel function
  ! The algorithm and numerical table are implemented based on the reference:
  ! Methods and Programs for Mathematical Functions, Prentice-Hall, 1989
  real(8) function bessel_j1_salmon(x) result(y)
    implicit none
    real(8), intent(in) :: x
    real(8), parameter :: &
      &  rp(0:3) = (/ &
      & -8.999712d+08, +4.522283d+11, -7.274942d+13, +3.682957d+15  &
      & /), &
      & rq(0:8) = (/ &
      & +1.000000d+00, +6.208365d+02, +2.569873d+05, +8.351468d+07,  &
      & +2.215116d+10, +4.749141d+12, +7.843696d+14, +8.952223d+16,  &
      & +5.322786d+18 /), &
      & pp(0:6) = (/ &
      & +7.621256d-04, +7.313971d-02, +1.127196d+00, +5.112080d+00,  &
      & +8.424046d+00, +5.214516d+00, +1.000000d+00 /), &
      & pq(0:6) = (/ &
      & +5.713231d-04, +6.884559d-02, +1.105142d+00, +5.073864d+00,  &
      & +8.399856d+00, +5.209828d+00, +1.000000d+00 /), &
      & qp(0:7) = (/ &
      & +5.108626d-02, +4.982139d+00, +7.582383d+01, +3.667796d+02,  &
      & +7.108563d+02, +5.974896d+02, +2.116888d+02, +2.520702d+01  &
      & /), &
      & qq(0:7) = (/ &
      & +1.000000d+00, +7.423733d+01, +1.056449d+03, +4.986411d+03,  &
      & +9.562319d+03, +7.997042d+03, +2.826193d+03, +3.360936d+02  &
      & /)
    real(8), parameter :: z1 = +1.468197d+01
    real(8), parameter :: z2 = +4.921846d+01
    real(8), parameter :: thpio4 =  +2.356194d+00
    real(8), parameter :: sq2opi =  +7.978846d-01
    real(8) :: w, z, p, q, xn
    real(8) :: rpz, rqz, ppz, pqz, qpz, qqz

    if (x < 0) then
      w = -x
    else
      w = +x
    end if

    if( w <= 5.0 ) then
      z = x * x
      rpz = ((rp(0)*z+rp(1))*z+rp(2))*z+rp(3)
      rqz = (((((((rq(0)*z+rq(1))*z+rq(2))*z+rq(3))*z+rq(4))*z &
        & +rq(5))*z+rq(6))*z+rq(7))*z+rq(8)
      w = rpz / rqz
      w = w * x * (z - z1) * (z - z2)
      y = w
      return
    end if

    w = 5.0 / x
    z = w * w
    ppz = (((((pp(0)*z+pp(1))*z+pp(2))*z+pp(3))*z+pp(4))*z+pp(5))*z+pp(6)
    pqz = (((((pq(0)*z+pq(1))*z+pq(2))*z+pq(3))*z+pq(4))*z+pq(5))*z+pq(6)
    qpz = ((((((qp(0)*z+qp(1))*z+qp(2))*z+qp(3))*z &
    & +qp(4))*z+qp(5))*z+qp(6))*z+qp(7)
    qqz = ((((((qq(0)*z+qq(1))*z+qq(2))*z+qq(3))*z &
    & +qq(4))*z+qq(5))*z+qq(6))*z+qq(7)
    p = ppz/pqz
    q = qpz/qqz
    xn = x - thpio4
    p = p * cos(xn) - w * q * sin(xn)
    y = p * sq2opi / sqrt(x)
    return
  end function bessel_j1_salmon
!--------------------------------------------------------------------------------
  subroutine matrix_inverse_double(rmat)
    implicit none
    real(8),intent(inout) :: rmat(:,:)
    integer :: nn
! for lapack
    integer :: lwork, info
    integer, allocatable :: ipiv(:) ! dimension N
    real(8), allocatable :: work(:) ! dimension LWORK

    nn = size(rmat,dim=1)
    lwork = nn * max(nn, 64)

    allocate(ipiv(nn),work(lwork))

    call dgetrf(nn, nn, rmat, nn, ipiv, info)  ! factorize
    call dgetri(nn, rmat, nn, ipiv, work, lwork, info)  ! inverse

    deallocate(ipiv,work)

  end subroutine matrix_inverse_double
!--------------------------------------------------------------------------------
  subroutine matrix_inverse_complex(zmat)
    implicit none
    complex(8),intent(inout) :: zmat(:,:)
    integer :: nn
! for lapack
    integer :: lwork, info
    integer, allocatable :: ipiv(:) ! dimension N
    complex(8), allocatable :: zwork(:) ! dimension LWORK

    nn = size(zmat,dim=1)
    lwork = nn * max(nn, 64)

    allocate(ipiv(nn),zwork(lwork))

    call zgetrf(nn, nn, zmat, nn, ipiv, info)  ! factorize
    call zgetri(nn, zmat, nn, ipiv, zwork, lwork, info)  ! inverse

    deallocate(ipiv,zwork)

  end subroutine matrix_inverse_complex
!--------10--------20--------30--------40--------50--------60--------70--------80--------90--------100-------110-------120-------130
  real(8) function xjl(x,l) result(r_xjl)
    implicit none
!argument
    integer,intent(in) :: l
    real(8),intent(in) :: x
!local variable
    real(8),parameter :: eps=1.0d-1

    if (l >= 5) then
      write(*,*) 'xjl function not prepared for l>=5'
      stop
    endif

    if (x < eps) then
      select case(l)
      case(-1)
         r_xjl = 1.d0 - x**2/2.d0 + x**4/24.d0
      case(0)
         r_xjl = x - x**3/6.d0 + x**5/120.d0 -x**7/5040.d0 + x**9/362880.d0
      case(1)
         r_xjl = (2.d0/6.d0)*x**2 - (2.d0/60.d0)*x**4 + (1.d0/840.d0)*x**6 - (2.d0/90720.d0)*x**8
      case(2)
         r_xjl = (4.d0/60.d0)*x**3 - (4.d0/840.d0)*x**5 + (2.d0/15120.d0)*x**7 - (2.d0/997920.d0)*x**9
      case(3)
         r_xjl = (8.d0/840.d0)*x**4 - (8.d0/15120.d0)*x**6 + (4.d0/332640.d0)*x**8
      case(4)
         r_xjl = (16.d0/15120.d0)*x**5 - (16.d0/332640.d0)*x**7 + (8.d0/8648640.d0)*x**9
      end select
    else
      select case(l)
      case(-1)
         r_xjl = cos(x)
      case(0)
         r_xjl = sin(x)
      case(1)
         r_xjl = (1.d0/x)*sin(x) - cos(x)
      case(2)
         r_xjl = (3.d0/x**2 - 1.d0)*sin(x) - (3.d0/x)*cos(x)
      case(3)
         r_xjl = (15.d0/x**3 - 6.d0/x)*sin(x) - (15.d0/x**2 - 1.d0)*cos(x)
      case(4)
         r_xjl = (105.d0/x**4 - 45.d0/x**2 + 1.d0)*sin(x) - (105.d0/x**3 - 10.d0/x)*cos(x)
      end select
    end if

    return
  end function xjl
!--------10--------20--------30--------40--------50--------60--------70--------80--------90--------100-------110-------120-------130
  real(8) function dxjl(x,l) result(r_dxjl)
    implicit none
!argument
    integer,intent(in) :: l
    real(8),intent(in) :: x
!local variable
    real(8),parameter :: eps=1.0d-1

    if (l >= 5) then
      write(*,*) 'dxjl function not prepared for l>=5'
      stop
    endif

    if (x < eps) then
      select case(l)
      case(-1)
         r_dxjl = x - x**3/6.d0
      case(0)
         r_dxjl = 1.d0 - x**2/2.d0 + x**4/24.d0 - x**6/720.d0 + x**8/40320.d0
      case(1)
         r_dxjl = (2.d0/3.d0)*x**1 - (2.d0/15.d0)*x**3 + (1.d0/140.d0)*x**5 - (2.d0/11340.d0)*x**7
      case(2)
         r_dxjl = (4.d0/20.d0)*x**2 - (4.d0/168.d0)*x**4 + (2.d0/2160.d0)*x**6 - (2.d0/110880.d0)*x**7
      case(3)
         r_dxjl = (8.d0/210.d0)*x**3 - (8.d0/2520.d0)*x**5 + (4.d0/41580.d0)*x**7
      case(4)
         r_dxjl = (16.d0/3024.d0)*x**4 - (16.d0/47520.d0)*x**6 + (8.d0/960960.d0)*x**8
      end select
    else
      select case(l)
      case(-1)
         r_dxjl = -sin(x)
      case(0)
         r_dxjl = cos(x)
      case(1)
         r_dxjl = -(1.d0/x**2 - 1.d0)*sin(x) + (1.d0/x)*cos(x)
      case(2)
         r_dxjl = -(6.d0/x**3 - 3.d0/x)*sin(x) + (6.d0/x**2 - 1.d0)*cos(x)
      case(3)
         r_dxjl = -(45.d0/x**4 - 21.d0/x**2 + 1.d0)*sin(x) + (45.d0/x**3 - 6.d0/x)*cos(x)
      case(4)
         r_dxjl = -(420.d0/x**5 - 195.d0/x**3 + 10.d0/x)*sin(x) + (420.d0/x**4 - 55.d0/x**2 + 1.d0)*cos(x)
      end select
    end if

    return
  end function dxjl

end module salmon_math
!--------------------------------------------------------------------------------


!-----------------------------------------------------------------------
      program test

      include 'ceedf.h'

      integer ceed,err
      integer b
      integer p,q

      character arg*32

      call getarg(1,arg)

      call ceedinit(trim(arg)//char(0),ceed,err)
      call ceedbasiscreatetensorh1lagrange(ceed,3,1,4,5,ceed_gauss_lobatto,b,&
     & err)

      call ceedbasisgetnumnodes(b,p,err)
      call ceedbasisgetnumquadraturepoints(b,q,err)

      if (p .NE. 64) then
! LCOV_EXCL_START
        write(*,*) 'Error ',p,' != 64 '
! LCOV_EXCL_STOP
      endif
      if (q .NE. 125) then
! LCOV_EXCL_START
        write(*,*) 'Error ',q,' != 125 '
! LCOV_EXCL_STOP
      endif

      call ceedbasisdestroy(b,err)
      call ceeddestroy(ceed,err)

      end
!-----------------------------------------------------------------------


subroutine test(n, n_param, b, A, gram_matrix)
  implicit none
  integer i, j
  integer(4), intent(in) :: n
  integer(4), intent(in) :: n_param
  real(8),    intent(in) :: A(0 : n - 1, 0 : n_param - 1)
  real(8),    intent(in) :: b
  real(8),    intent(inout):: gram_matrix(0 : n - 1, 0 : n - 1)

  do i = 0 , n - 1
    do j = i + 1, n - 1
      gram_matrix(j, i) = exp(-b * dot_product((A(i, :)- A(j, :)), (A(i, :)- A(j, :))))
      gram_matrix(i, i) = 1
      gram_matrix(i, j) = gram_matrix(j, i)
    end do
  end do

  !write(*, "(a)") "** write from fortran"
  !write(*, "(i8)")n
  !write(*, "(1p3e12.4)")b

  !write(*, "(1p3e12.4)")gram_matrix(0, 0), gram_matrix(0, 1), gram_matrix(0, 2)
  !write(*, "(1p3e12.4)")gram_matrix(1, 0), gram_matrix(1, 1), gram_matrix(1, 2)
  !write(*, "(1p3e12.4)")gram_matrix(2, 0), gram_matrix(2, 1), gram_matrix(2, 2)

  !write(*, "(1p3e12.4)")A(0, 0), A(0, 1), A(0, 2)
  !write(*, "(1p3e12.4)")A(1, 0), A(1, 1), A(1, 2)
  !write(*, "(1p3e12.4)")A(2, 0), A(2, 1), A(2, 2)

end subroutine test


module model_fluid_wave_speed
#include <messenger.h>
    use mod_kinds,          only: rk
    use mod_constants,      only: HALF, ONE, TWO
    use mod_fluid,          only: Rgas, gam
    use type_model,         only: model_t
    use type_chidg_worker,  only: chidg_worker_t
    use DNAD_D
    implicit none

    !>  A model defining the maximum wave speed of the fluid system of equations.
    !!
    !!  Model Fields:
    !!      - Maximum Wave Speed
    !!
    !!  @author Nathan A. Wukie
    !!  @date   01/31/2017
    !!
    !---------------------------------------------------------------------------------------
    type, extends(model_t)  :: fluid_wave_speed_t

    contains

        procedure   :: init
        procedure   :: compute

    end type fluid_wave_speed_t
    !***************************************************************************************

contains

    !>  Initialize the model with a name and the model fields it is contributing to.
    !!
    !!  @author Nathan A. Wukie
    !!  @date   01/31/2017
    !!
    !---------------------------------------------------------------------------------------
    subroutine init(self)
        class(fluid_wave_speed_t), intent(inout)   :: self

        call self%set_name('Fluid Wave Speed')
        call self%set_dependency('f(Q-)')

        call self%add_model_field('Maximum Wave Speed')

    end subroutine init
    !***************************************************************************************

    !>  Routine for computing the Pressure and Temperature.
    !!
    !!  @author Nathan A. Wukie
    !!  @date   12/1/2016
    !!
    !--------------------------------------------------------------------------------------
    subroutine compute(self,worker)
        class(fluid_wave_speed_t),    intent(in)      :: self
        type(chidg_worker_t),   intent(inout)   :: worker

        type(AD_D), dimension(:),   allocatable :: &
            density, energy, T, P, vmag, sound_speed, wave_speed

        !
        ! Interpolate solution to quadrature nodes
        !
        density = worker%get_field('Density', 'value')
        energy  = worker%get_field('Energy',  'value')

        !
        ! Get Temperature defined by some model for equation of state
        !
        T = worker%get_field('Temperature', 'value')
        P = worker%get_field('Pressure', 'value')

        !
        ! Compute acoustic and convective wave speeds
        !   Danger computing vmag with sqrt because derivative
        !   is undefined at zero.
        !
        !vmag = sqrt((densityu**TWO + densityv**TWO + densityw**TWO)/(density*density))
        vmag = energy - (P/(gam - ONE))
        sound_speed = sqrt(gam * Rgas * T)

        !
        ! Compute maximum wave speed
        !
        wave_speed = vmag + sound_speed

        call worker%store_model_field('Maximum Wave Speed', 'value', wave_speed)

    end subroutine compute
    !***************************************************************************************

end module model_fluid_wave_speed


      complex*16 function ztan(z)
      implicit none
      complex*16 z
      ztan=sin(z)/cos(z)
      return
      end


program monte_carlo
      use types
      use mcrt_functions

      implicit none
      ! allocate variables and declare things
      real(dp), allocatable :: tau_list(:), total_scatter(:, :), mean_arr(:), angle_bins(:,:,:), position(:,:), ini_pos(:,:)
      real(dp) :: pos(3), nhat(3), old_pos(3)
      real(dp) :: r_max = 1.0, min_wt = 1e-3, albedo = 1.0_dp, p = 0.1
      real(dp) :: leng, r, tau, ran,  wt, exit_theta, exit_phi
      integer :: num_packets, len_tau, j, i, nbins = 200, u, phi_loc, theta_loc, k

      ! Parameters for the MC run
      num_packets = 1000000

      ! configure the tau that we want to see

      tau_list = [0.1, 1.0, 5.0, 10.0, 20.0, 50.0]
      len_tau = size(tau_list)

      ! allocating the memory for things
      allocate( total_scatter( len_tau, num_packets ) )
      allocate( mean_arr( len_tau ) )
      allocate( angle_bins( len_tau, nbins, nbins ) )
      allocate( position( num_packets, 3 ) )
      allocate( ini_pos( num_packets, 3 ) )

      ! begin program
      write(*,*) 'Program running!'

      do j = 1, size(tau_list)

            do i = 1, num_packets
                  wt = 1.0
                  ! r = 0.0_dp
                  tau = tau_list(j)

                  call blob_emit_bias(nhat)
                  call blob_initial_pos(pos, r_max) ! try to fix the separatrix issue and revert to old method?

                  leng = blob_initial_length(pos, nhat, r_max)
                  call mc_update(pos, nhat, leng)

                  ! force the particle to appear inside the sphere to trigger the MC simulation
                  ! this was done because of rounding errors
                  r = 0.0_dp
                  do while ((r < r_max) .and. (r >= 0.0_dp))
                        ! provided we are within the sphere
                        old_pos = pos
                        ! store the old position

                        ! generate the length
                        leng = mc_gen_L(tau, r_max)

                        ! create an nhat vector
                        if (r .ne. 0.0_dp) then ! convert into bool
                              call mc_emit(nhat)
                        end if

                        ! make it walk along the nhat vector a certain length leng
                        call mc_update(pos, nhat, leng)

                        ! if (i == 1) then
                        !       write(*,*) pos
                        ! end if

                        ! check if it will remain in the sphere
                        r = norm(pos)

                        if (r < r_max) then
                              ! calculate if we want to scatter further based on the albedo
                              ! implemented the russian roulette style giving packets an extra life before speaking to Kenny
                              ! he says it's not needed in this HW but I've included it because my simulations were run with it
                              if (ran .lt. albedo) then
                                    ! update the weight
                                    wt = albedo * wt
                                    ! let it scatter
                                    total_scatter(j,i) = total_scatter(j,i) + 1

                                    ! then do the killing of packets using the formula in the notes
                                    if (wt <= min_wt) then
                                    ! generate a random number
                                          call RANDOM_NUMBER(ran)
                                    ! either kill it or update the weight
                                          if (ran .lt. p) then
                                                wt = wt/p
                                          else
                                                continue
                                          end if
                                    end if
                              ! if we don't want to scatter then just let it continue without doing anything
                              else
                                    ! we might want to consider the fact that its then scattered straight through
                                    continue
                              end if

                        else if (r >= r_max) then
                              ! if it's outside the sphere then use the geometry to allow us to calculate the "true" length that it's travelled

                              leng = edge_length(old_pos, nhat, r_max)

                              ! now walk the particle to that location on the sphere, not to its final location
                              call mc_update(old_pos, nhat, leng)

                              ! calculate the exit angles in the far field based on the direction that the particle is going along
                              call exit_angles(nhat, exit_theta,  exit_phi)

                              ! generate a location in phi and theta as described in report
                              phi_loc = int( exit_phi/(pi)*nbins/2 + nbins/2 )
                              theta_loc = int( cos(exit_theta) * nbins/2 + nbins/2 +1)
                              ! bin the in the array
                              angle_bins(j, phi_loc, theta_loc) = angle_bins(j, phi_loc, theta_loc) + 1
                        end if
                  end do
            end do
            write(*,*) tau_list(j)
      end do

      open(newunit = u, file = "Q3/Data/angle_binning.txt", status = "replace")
      do k = 1, len_tau
              do j = 1, nbins
                  do i = 1, nbins
                        write(u,*) tau_list(k), ',', j,',',i , ',',angle_bins(k, j, i)
                  end do
            end do
      end do
end program