      SUBROUTINE MB03BD( JOB, DEFL, COMPQ, QIND, K, N, H, ILO, IHI, S,
     $                   A, LDA1, LDA2, Q, LDQ1, LDQ2, ALPHAR, ALPHAI,
     $                   BETA, SCAL, IWORK, LIWORK, DWORK, LDWORK,
     $                   IWARN, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To find the eigenvalues of the generalized matrix product
C
C                  S(1)           S(2)                 S(K)
C          A(:,:,1)     * A(:,:,2)     * ... * A(:,:,K)
C
C     where A(:,:,H) is upper Hessenberg and A(:,:,i), i <> H, is upper
C     triangular, using a double-shift version of the periodic
C     QZ method. In addition, A may be reduced to periodic Schur form:
C     A(:,:,H) is upper quasi-triangular and all the other factors
C     A(:,:,I) are upper triangular. Optionally, the 2-by-2 triangular
C     matrices corresponding to 2-by-2 diagonal blocks in A(:,:,H)
C     are so reduced that their product is a 2-by-2 diagonal matrix.
C
C     If COMPQ = 'U' or COMPQ = 'I', then the orthogonal factors are
C     computed and stored in the array Q so that for S(I) = 1,
C
C                         T
C             Q(:,:,I)(in)   A(:,:,I)(in)   Q(:,:,MOD(I,K)+1)(in)
C                                                                 T  (1)
C         =   Q(:,:,I)(out)  A(:,:,I)(out)  Q(:,:,MOD(I,K)+1)(out),
C
C     and for S(I) = -1,
C
C                                  T
C             Q(:,:,MOD(I,K)+1)(in)   A(:,:,I)(in)   Q(:,:,I)(in)
C                                                                 T  (2)
C         =   Q(:,:,MOD(I,K)+1)(out)  A(:,:,I)(out)  Q(:,:,I)(out).
C
C     A partial generation of the orthogonal factors can be realized
C     via the array QIND.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     JOB     CHARACTER*1
C             Specifies the computation to be performed, as follows:
C             = 'E': compute the eigenvalues only; A will not
C                    necessarily be put into periodic Schur form;
C             = 'S': put A into periodic Schur form, and return the
C                    eigenvalues in ALPHAR, ALPHAI, BETA, and SCAL;
C             = 'T': as JOB = 'S', but A is put into standardized
C                    periodic Schur form, that is, the general product
C                    of the 2-by-2 triangular matrices corresponding to
C                    a complex eigenvalue is diagonal.
C
C     DEFL    CHARACTER*1
C             Specifies the deflation strategy to be used, as follows:
C             = 'C': apply a careful deflation strategy, that is,
C                    the criteria are based on the magnitudes of
C                    neighboring elements and infinite eigenvalues are
C                    only deflated at the top; this is the recommended
C                    option;
C             = 'A': apply a more aggressive strategy, that is,
C                    elements on the subdiagonal or diagonal are set
C                    to zero as soon as they become smaller in magnitude
C                    than eps times the norm of the corresponding
C                    factor; this option is only recommended if
C                    balancing is applied beforehand and convergence
C                    problems are observed.
C
C     COMPQ   CHARACTER*1
C             Specifies whether or not the orthogonal transformations
C             should be accumulated in the array Q, as follows:
C             = 'N': do not modify Q;
C             = 'U': modify (update) the array Q by the orthogonal
C                    transformations that are applied to the matrices in
C                    the array A to reduce them to periodic Schur form;
C             = 'I': like COMPQ = 'U', except that each matrix in the
C                    array Q will be first initialized to the identity
C                    matrix;
C             = 'P': use the parameters as encoded in QIND.
C
C     QIND    INTEGER array, dimension (K)
C             If COMPQ = 'P', then this array describes the generation
C             of the orthogonal factors as follows:
C                If QIND(I) > 0, then the array Q(:,:,QIND(I)) is
C             modified by the transformations corresponding to the
C             i-th orthogonal factor in (1) and (2).
C                If QIND(I) < 0, then the array Q(:,:,-QIND(I)) is
C             initialized to the identity and modified by the
C             transformations corresponding to the i-th orthogonal
C             factor in (1) and (2).
C                If QIND(I) = 0, then the transformations corresponding
C             to the i-th orthogonal factor in (1), (2) are not applied.
C
C     Input/Output Parameters
C
C     K       (input)  INTEGER
C             The number of factors.  K >= 1.
C
C     N       (input)  INTEGER
C             The order of each factor in the array A.  N >= 0.
C
C     H       (input)  INTEGER
C             Hessenberg index. The factor A(:,:,H) is on entry in upper
C             Hessenberg form.  1 <= H <= K.
C
C     ILO     (input)  INTEGER
C     IHI     (input)  INTEGER
C             It is assumed that each factor in A is already upper
C             triangular in rows and columns 1:ILO-1 and IHI+1:N.
C             1 <= ILO <= IHI <= N, if N > 0;
C             ILO = 1 and IHI  = 0, if N = 0.
C
C     S       (input)  INTEGER array, dimension (K)
C             The leading K elements of this array must contain the
C             signatures of the factors. Each entry in S must be either
C             1 or -1.
C
C     A       (input/output)  DOUBLE PRECISION array, dimension
C                             (LDA1,LDA2,K)
C             On entry, the leading N-by-N-by-K part of this array
C             must contain the factors in upper Hessenberg-triangular
C             form, that is, A(:,:,H) is upper Hessenberg and the other
C             factors are upper triangular.
C             On exit, if JOB = 'S' and INFO = 0, the leading
C             N-by-N-by-K part of this array contains the factors of
C             A in periodic Schur form, that is, A(:,:,H) is upper quasi
C             triangular and the other factors are upper triangular.
C             On exit, if JOB = 'T' and INFO = 0, the leading
C             N-by-N-by-K part of this array contains the factors of
C             A as for the option JOB = 'S', but the product of the
C             triangular factors corresponding to a 2-by-2 block in
C             A(:,:,H) is diagonal.
C             On exit, if JOB = 'E', then the leading N-by-N-by-K part
C             of this array contains meaningless elements in the off-
C             diagonal blocks. Consequently, the formulas (1) and (2)
C             do not hold for the returned A and Q (if COMPQ <> 'N')
C             in this case.
C
C     LDA1    INTEGER
C             The first leading dimension of the array A.
C             LDA1 >= MAX(1,N).
C
C     LDA2    INTEGER
C             The second leading dimension of the array A.
C             LDA2 >= MAX(1,N).
C
C     Q       (input/output)  DOUBLE PRECISION array, dimension
C                             (LDQ1,LDQ2,K)
C             On entry, if COMPQ = 'U', the leading N-by-N-by-K part
C             of this array must contain the initial orthogonal factors
C             as described in (1) and (2).
C             On entry, if COMPQ = 'P', only parts of the leading
C             N-by-N-by-K part of this array must contain some
C             orthogonal factors as described by the parameters QIND.
C             If COMPQ = 'I', this array should not be set on entry.
C             On exit, if COMPQ = 'U' or COMPQ = 'I', the leading
C             N-by-N-by-K part of this array contains the modified
C             orthogonal factors as described in (1) and (2).
C             On exit, if COMPQ = 'P', only parts of the leading
C             N-by-N-by-K part contain some modified orthogonal factors
C             as described by the parameters QIND.
C             This array is not referenced if COMPQ = 'N'.
C
C     LDQ1    INTEGER
C             The first leading dimension of the array Q.  LDQ1 >= 1,
C             and, if COMPQ <> 'N', LDQ1 >= MAX(1,N).
C
C     LDQ2    INTEGER
C             The second leading dimension of the array Q.  LDQ2 >= 1,
C             and, if COMPQ <> 'N', LDQ2 >= MAX(1,N).
C
C     ALPHAR  (output) DOUBLE PRECISION array, dimension (N)
C             On exit, if INFO = 0, the leading N elements of this array
C             contain the scaled real parts of the eigenvalues of the
C             matrix product A. The i-th eigenvalue of A is given by
C
C             (ALPHAR(I) + ALPHAI(I)*SQRT(-1))/BETA(I) * BASE**SCAL(I),
C
C             where BASE is the machine base (often 2.0). Complex
C             conjugate eigenvalues appear in consecutive locations.
C
C     ALPHAI  (output) DOUBLE PRECISION array, dimension (N)
C             On exit, if INFO = 0, the leading N elements of this array
C             contain the scaled imaginary parts of the eigenvalues
C             of A.
C
C     BETA    (output) DOUBLE PRECISION array, dimension (N)
C             On exit, if INFO = 0, the leading N elements of this array
C             contain indicators for infinite eigenvalues. That is, if
C             BETA(I) = 0.0, then the i-th eigenvalue is infinite.
C             Otherwise BETA(I) is set to 1.0.
C
C     SCAL    (output) INTEGER array, dimension (N)
C             On exit, if INFO = 0, the leading N elements of this array
C             contain the scaling parameters for the eigenvalues of A.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (LIWORK)
C             On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK,
C             and if IWARN > N, the nonzero absolute values in IWORK(2),
C             ..., IWORK(N+1) are indices of the possibly inaccurate
C             eigenvalues, as well as of the corresponding 1-by-1 or
C             2-by-2 diagonal blocks of the factors in the array A.
C             The 2-by-2 blocks correspond to negative values in IWORK.
C             One negative value is stored for each such eigenvalue
C             pair. Its modulus indicates the starting index of a
C             2-by-2 block. This is also done for any value of IWARN,
C             if a 2-by-2 block is found to have two real eigenvalues.
C             On exit, if INFO = -22, IWORK(1) returns the minimum value
C             of LIWORK.
C
C     LIWORK  INTEGER
C             The length of the array IWORK.  LIWORK  >= 2*K+N.
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) returns the optimal LDWORK,
C             and DWORK(2), ..., DWORK(1+K) contain the Frobenius norms
C             of the factors of the formal matrix product used by the
C             algorithm.
C             On exit, if INFO = -24, DWORK(1) returns the minimum value
C             of LDWORK.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK >= K + MAX( 2*N, 8*K ).
C
C     Warning Indicator
C
C     IWARN   INTEGER
C             = 0        :  no warnings;
C             = 1,..,N-1 :  A is in periodic Schur form, but the
C                           algorithm was not able to reveal information
C                           about the eigenvalues from the 2-by-2
C                           blocks.
C                           ALPHAR(i), ALPHAI(i), BETA(i) and SCAL(i),
C                           can be incorrect for i = 1, ..., IWARN+1;
C             = N        :  some eigenvalues might be inaccurate;
C             = N+1      :  some eigenvalues might be inaccurate, and
C                           details can be found in IWORK.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0      :  succesful exit;
C             < 0      :  if INFO = -i, the i-th argument had an illegal
C                         value;
C             = 1,..,N :  the periodic QZ iteration did not converge.
C                         A is not in periodic Schur form, but
C                         ALPHAR(i), ALPHAI(i), BETA(i) and SCAL(i), for
C                         i = INFO+1,...,N should be correct.
C
C     METHOD
C
C     A modified version of the periodic QZ algorithm is used [1], [2].
C
C     REFERENCES
C
C     [1] Bojanczyk, A., Golub, G. H. and Van Dooren, P.
C         The periodic Schur decomposition: algorithms and applications.
C         In F.T. Luk (editor), Advanced Signal Processing Algorithms,
C         Architectures, and Implementations III, Proc. SPIE Conference,
C         vol. 1770, pp. 31-42, 1992.
C
C     [2] Kressner, D.
C         An efficient and reliable implementation of the periodic QZ
C         algorithm. IFAC Workshop on Periodic Control Systems (PSYCO
C         2001), Como (Italy), August 27-28 2001. Periodic Control
C         Systems 2001 (IFAC Proceedings Volumes), Pergamon.
C
C     NUMERICAL ASPECTS
C
C     The implemented method is numerically backward stable.
C                                 3
C     The algorithm requires 0(K N ) floating point operations.
C
C     CONTRIBUTOR
C
C     D. Kressner, Technical Univ. Berlin, Germany, June 2001.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Romania,
C     July 2009, SLICOT Library version of the routine PHGEQZ.
C     V. Sima, June 2010, July 2010, Nov. 2010, Sep. 2011, Oct. 2011,
C     Jan. 2013, Feb. 2013, July 2013, Sep. 2016, Nov. 2016, Apr. 2018.
C     Dec. 2018, Jan. 2019, Feb. 2019, Mar. 2019, Aug.-Sep. 2019, Dec.
C     2019, Jan.-Apr. 2020.
C
C     KEYWORDS
C
C     Eigenvalues, QZ algorithm, periodic QZ algorithm, orthogonal
C     transformation.
C
C     ******************************************************************
C
C     .. Parameters ..
C     .. NITER is the number of consecutive iterations for a deflated ..
C     .. subproblem before switching from implicit to explicit shifts...
C     .. MCOUNT is, similarly, the maximum number of consecutive ..
C     .. iterations before switching from explicit to implicit shifts...
C
      INTEGER           MCOUNT, NITER
      PARAMETER         ( MCOUNT = 1, NITER = 10 )
      DOUBLE PRECISION  ZERO, ONE, TEN
      PARAMETER         ( ZERO = 0.0D+0, ONE = 1.0D+0, TEN = 1.0D+1 )
C     .. Scalar Arguments ..
      CHARACTER         COMPQ, DEFL, JOB
      INTEGER           H, IHI, ILO, INFO, IWARN, K, LDA1, LDA2, LDQ1,
     $                  LDQ2, LDWORK, LIWORK, N
C     .. Array Arguments ..
      INTEGER           IWORK(*), QIND(*), S(*), SCAL(*)
      DOUBLE PRECISION  A(LDA1,LDA2,*), ALPHAI(*), ALPHAR(*), BETA(*),
     $                  DWORK(*), Q(LDQ1,LDQ2,*)
C     .. Local Arrays ..
      DOUBLE PRECISION  MACPAR(5)
C     .. Local Scalars ..
      LOGICAL           ADEFL, ISINF, LCMPQ, LINIQ, LPARQ, LSCHR, LSVD
      CHARACTER         SHFT
      INTEGER           AIND, COUNT, COUNTE, I, IERR, IFIRST, IFRSTM,
     $                  IITER, ILAST, ILASTM, IN, IO, J, J1, JDEF,
     $                  JITER, JLO, L, LDEF, LM, MAXIT, NTRA, OPTDW,
     $                  OPTIW, QI, SINV, TITER, ZITER
      DOUBLE PRECISION  A1, A2, A3, A4, BASE, CS, CS1, CS2, LGBAS, NRM,
     $                  SAFMAX, SAFMIN, SDET, SMLNUM, SN, SN1, SN2,
     $                  SVMN, TEMP, TEMP2, TOL, TOLL, ULP, W1, W2
C     .. Workspace Pointers ..
      INTEGER           MAPA, MAPH, MAPQ, PDW, PFREE, PNORM
C     .. External Functions ..
      LOGICAL           LSAME
      DOUBLE PRECISION  DLAMCH, DLANHS, DLAPY2, DLAPY3
      EXTERNAL          DLAMCH, DLANHS, DLAPY2, DLAPY3, LSAME
C     .. External Subroutines ..
      EXTERNAL          DLABAD, DLADIV, DLARTG, DLAS2, DLASET, DROT,
     $                  MA01BD, MB03AB, MB03AF, MB03BA, MB03BB, MB03BC,
     $                  MB03BF, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         ABS, DBLE, INT, LOG, MAX, MIN, MOD, SIGN, SQRT
C
C     .. Executable Statements ..
C
C     Decode the scalar input parameters.
C
      LSVD  = LSAME( JOB,   'T' )
      LSCHR = LSAME( JOB,   'S' ) .OR. LSVD
      LINIQ = LSAME( COMPQ, 'I' )
      LCMPQ = LSAME( COMPQ, 'U' ) .OR. LINIQ
      LPARQ = LSAME( COMPQ, 'P' )
      ADEFL = LSAME( DEFL,  'A' )
      IWARN = 0
      OPTDW = K + MAX( 2*N, 8*K )
      OPTIW = 2*K + N
C
C     Check the scalar input parameters.
C
      INFO = 0
      IF ( .NOT. ( LSCHR .OR. LSAME( JOB, 'E' ) ) ) THEN
         INFO = -1
      ELSE IF ( .NOT.( ADEFL .OR. LSAME( DEFL, 'C' ) ) ) THEN
         INFO = -2
      ELSE IF ( .NOT.( LCMPQ .OR. LPARQ .OR. LSAME( COMPQ, 'N' ) ) )
     $      THEN
         INFO = -3
      ELSE IF ( K.LT.1 ) THEN
         INFO = -5
      ELSE IF ( N.LT.0 ) THEN
         INFO = -6
      ELSE IF ( H.LT.1 .OR. H.GT.K ) THEN
         INFO = -7
      ELSE IF ( ILO.LT.1 ) THEN
         INFO = -8
      ELSE IF ( IHI.GT.N .OR. IHI.LT.ILO-1 ) THEN
         INFO = -9
      ELSE IF ( LDA1.LT.MAX( 1, N ) ) THEN
         INFO = -12
      ELSE IF ( LDA2.LT.MAX( 1, N ) ) THEN
         INFO = -13
      ELSE IF ( LDQ1.LT.1 .OR. ( ( LCMPQ .OR. LPARQ )
     $                             .AND. LDQ1.LT.N ) ) THEN
         INFO = -15
      ELSE IF ( LDQ2.LT.1 .OR. ( ( LCMPQ .OR. LPARQ )
     $                             .AND. LDQ2.LT.N ) ) THEN
         INFO = -16
      ELSE IF ( LIWORK.LT.OPTIW ) THEN
         IWORK(1) = OPTIW
         INFO = -22
      ELSE IF ( LDWORK.LT.OPTDW ) THEN
         DWORK(1) = DBLE( OPTDW )
         INFO = -24
      END IF
C
C     Return if there were illegal values.
C
      IF ( INFO.NE.0 ) THEN
         CALL XERBLA( 'MB03BD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( N.EQ.0 ) THEN
         DWORK(1) = ONE
         IWORK(1) = 1
         RETURN
      END IF
C
C     Compute Maps for accessing A and Q.
C
      MAPA = 0
      MAPH = 2
      MAPQ = K
      QI   = 0
      CALL MB03BA( K, H, S, SINV, IWORK(MAPA+1), IWORK(MAPQ+1) )
C
C     Machine Constants.
C
      IN = IHI + 1 - ILO
      SAFMIN = DLAMCH( 'SafeMinimum' )
      SAFMAX = ONE / SAFMIN
      ULP    = DLAMCH( 'Precision' )
      TOLL   = TEN*ULP
      CALL DLABAD( SAFMIN, SAFMAX )
      SMLNUM = SAFMIN*( IN / ULP )
      BASE   = DLAMCH( 'Base' )
      LGBAS  = LOG( BASE )
C
      MACPAR(2) = DLAMCH( 'Underflow' )
      IF ( LSVD ) THEN
         MACPAR(1) = DLAMCH( 'ORmax' )
         MACPAR(3) = SAFMIN
         MACPAR(4) = DLAMCH( 'Epsilon' )
         MACPAR(5) = BASE
      END IF
      IF ( K.GE.INT( LOG( MACPAR(2) ) / LOG( ULP ) ) ) THEN
C
C        Start Iteration with a controlled zero shift.
C
         ZITER = -1
      ELSE
         ZITER = 0
      END IF
C
C     Initialize IWORK (needed in case of loosing accuracy).
C
      DO 10  I = 2*K + 1, 2*K + N
         IWORK(I) = 0
   10 CONTINUE
C
C     Compute norms and initialize Q.
C
      PNORM = 0
      PFREE = K
      DO 20  I = 1, K
         AIND = IWORK(MAPA+I)
         DWORK(I) = DLANHS( 'Frobenius', IN, A(ILO,ILO,AIND), LDA1,
     $                      DWORK )
         J = 0
         IF ( LINIQ ) THEN
            J = I
         ELSE IF ( LPARQ ) THEN
            J = -QIND(I)
         END IF
         IF ( J.NE.0 )
     $      CALL DLASET( 'Full', N, N, ZERO, ONE, Q(1,1,J), LDQ1 )
   20 CONTINUE
C
C     Set Eigenvalues IHI+1:N.
C
      DO 30  J = IHI + 1, N
         CALL MA01BD( BASE, LGBAS, K, S, A(J,J,1), LDA1*LDA2, ALPHAR(J),
     $                BETA(J), SCAL(J) )
         ALPHAI(J) = ZERO
   30 CONTINUE
C
C     If IHI < ILO, skip QZ steps.
C
      IF ( IHI.LT.ILO )
     $   GO TO 550
C
C     MAIN PERIODIC QZ ITERATION LOOP.
C
C     Initialize dynamic indices.
C
C     Eigenvalues ILAST+1:N have been found.
C        Column operations modify rows IFRSTM:whatever.
C        Row operations modify columns whatever:ILASTM.
C
C     If only eigenvalues are being computed, then
C        IFRSTM is the row of the last splitting row above row ILAST;
C        this is always at least ILO.
C     IITER counts iterations since the last eigenvalue was found,
C        to tell when to use an observed zero or exceptional shift.
C     MAXIT is the maximum number of QZ sweeps allowed.
C
      ILAST = IHI
      IF ( LSCHR ) THEN
         IFRSTM = 1
         ILASTM = N
      ELSE
         IFRSTM = ILO
         ILASTM = IHI
      END IF
      IITER  = 0
      TITER  = 0
      COUNT  = 0
      COUNTE = 0
      MAXIT  = 120 * IN
C
      DO  540 JITER = 1, MAXIT
C
C        Special Case: ILAST = ILO.
C
         IF ( ILAST.EQ.ILO )
     $      GO TO 390
C
C        **************************************************************
C        *                     CHECK FOR DEFLATION                    *
C        **************************************************************
C
C        Test 1:  Deflation in the Hessenberg matrix.
C
         IF ( ADEFL )
     $      TOL = MAX( SAFMIN, DWORK(PNORM+1)*ULP )
         AIND = IWORK(MAPA+1)
         JLO = ILO
         DO 40  J = ILAST, ILO + 1, -1
            IF ( .NOT.ADEFL ) THEN
               TOL = ABS( A(J-1,J-1,AIND) ) + ABS( A(J,J,AIND) )
               IF ( TOL.EQ.ZERO )
     $             TOL = DLANHS( '1', J-ILO+1, A(ILO,ILO,AIND), LDA1,
     $                           DWORK )
               TOL = MAX( ULP*TOL, SMLNUM )
            END IF
            IF ( ABS( A(J,J-1,AIND) ).LE.TOL ) THEN
               A(J,J-1,AIND) = ZERO
               JLO = J
               IF ( J.EQ.ILAST )
     $            GO TO 390
               GO TO 50
            END IF
   40    CONTINUE
C
   50    CONTINUE
C
C        Test 2:  Deflation in the triangular matrices with index 1.
C
         DO 70  LDEF = 2, K
            AIND = IWORK(MAPA+LDEF)
            IF ( S(AIND).EQ.SINV ) THEN
               IF ( ADEFL )
     $            TOL = MAX( SAFMIN, DWORK(PNORM+LDEF)*ULP )
               DO 60  J = ILAST, JLO, -1
                  IF ( .NOT.ADEFL ) THEN
                     IF ( J.EQ.ILAST ) THEN
                        TOL = ABS( A(J-1,J,AIND) )
                     ELSE IF ( J.EQ.JLO ) THEN
                        TOL = ABS( A(J,J+1,AIND) )
                     ELSE
                        TOL = ABS( A(J-1,J,AIND) )
     $                      + ABS( A(J,J+1,AIND) )
                     END IF
                     IF ( TOL.EQ.ZERO )
     $                  TOL = DLANHS( '1', J-JLO+1, A(JLO,JLO,AIND),
     $                                LDA1, DWORK )
                     TOL = MAX( ULP*TOL, SMLNUM )
                  END IF
                  IF ( ABS( A(J,J,AIND) ).LE.TOL ) THEN
                     A(J,J,AIND) = ZERO
                     GO TO 170
                  END IF
   60          CONTINUE
            END IF
   70    CONTINUE
C
C        Test 3:  Deflation in the triangular matrices with index -1.
C
         DO 90  LDEF = 2, K
            AIND = IWORK(MAPA+LDEF)
            IF ( S(AIND).NE.SINV ) THEN
               IF ( ADEFL )
     $            TOL = MAX( SAFMIN, DWORK(PNORM+LDEF)*ULP )
               DO 80  J = ILAST, JLO, -1
                  IF ( .NOT.ADEFL ) THEN
                     IF ( J.EQ.ILAST ) THEN
                        TOL = ABS( A(J-1,J,AIND) )
                     ELSE IF ( J.EQ.JLO ) THEN
                        TOL = ABS( A(J,J+1,AIND) )
                     ELSE
                        TOL = ABS( A(J-1,J,AIND) )
     $                      + ABS( A(J,J+1,AIND) )
                     END IF
                     IF ( TOL.EQ.ZERO )
     $                  TOL = DLANHS( '1', J-JLO+1, A(JLO,JLO,AIND),
     $                                LDA1, DWORK )
                     TOL = MAX( ULP*TOL, SMLNUM )
                  END IF
                  IF ( ABS( A(J,J,AIND) ).LE.TOL ) THEN
                     A(J,J,AIND) = ZERO
                     GO TO 320
                  END IF
   80          CONTINUE
            END IF
   90    CONTINUE
C
C        Test 4:  Controlled zero shift.
C
         IF ( ZITER.GE.7 .OR. ZITER.LT.0 ) THEN
C
C           Make Hessenberg matrix upper triangular.
C
            AIND = IWORK(MAPA+1)
            PDW  = PFREE + 1
            DO 100 J = JLO, ILAST - 1
               TEMP = A(J,J,AIND)
               CALL DLARTG( TEMP, A(J+1,J,AIND), CS, SN, A(J,J,AIND) )
               A(J+1,J,AIND) = ZERO
               CALL DROT( ILASTM-J, A(J,J+1,AIND), LDA1,
     $                    A(J+1,J+1,AIND), LDA1, CS, SN )
               DWORK(PDW)   = CS
               DWORK(PDW+1) = SN
               PDW = PDW + 2
  100       CONTINUE
            IF ( LCMPQ ) THEN
               QI = IWORK(MAPQ+1)
            ELSE IF ( LPARQ ) THEN
               QI = ABS( QIND(IWORK(MAPQ+1)) )
            END IF
            IF ( QI.NE.0 ) THEN
               PDW = PFREE + 1
               DO 110  J = JLO, ILAST - 1
                  CS = DWORK(PDW)
                  SN = DWORK(PDW+1)
                  PDW = PDW + 2
                  CALL DROT( N, Q(1,J,QI), 1, Q(1,J+1,QI), 1, CS, SN )
  110          CONTINUE
            END IF
C
C           Propagate transformations back to A_1.
C
            DO 150  L = K, 2, -1
               AIND = IWORK(MAPA+L)
               PDW  = PFREE + 1
               IF ( ADEFL )
     $            TOL = MAX( SAFMIN, DWORK(PNORM+L)*ULP )
               IF ( S(AIND).EQ.SINV ) THEN
                  DO 120  J = JLO, ILAST - 1
                     CS = DWORK(PDW)
                     SN = DWORK(PDW+1)
                     IF ( SN.NE.ZERO ) THEN
                        CALL DROT( J+2-IFRSTM, A(IFRSTM,J,AIND), 1,
     $                             A(IFRSTM,J+1,AIND), 1, CS, SN )
C
C                       Check for deflation.
C
                        IF ( .NOT.ADEFL ) THEN
                           TOL = ABS( A(J,J,AIND) ) +
     $                           ABS( A(J+1,J+1,AIND) )
                           IF ( TOL.EQ.ZERO )
     $                        TOL = DLANHS( '1', J-JLO+2,
     $                                      A(JLO,JLO,AIND), LDA1,
     $                                      DWORK )
                           TOL = MAX( ULP*TOL, SMLNUM )
                        END IF
                        IF ( ABS( A(J+1,J,AIND) ).LE.TOL ) THEN
                           CS = ONE
                           SN = ZERO
                           A(J+1,J,AIND) = ZERO
                        END IF
                     END IF
                     IF ( SN.NE.ZERO ) THEN
                        TEMP = A(J,J,AIND)
                        CALL DLARTG( TEMP, A(J+1,J,AIND), CS, SN,
     $                               A(J,J,AIND) )
                        A(J+1,J,AIND) = ZERO
                        CALL DROT( ILASTM-J, A(J,J+1,AIND), LDA1,
     $                             A(J+1,J+1,AIND), LDA1, CS, SN )
                     END IF
                     DWORK(PDW)   = CS
                     DWORK(PDW+1) = SN
                     PDW = PDW + 2
  120             CONTINUE
               ELSE
                  DO 130  J = JLO, ILAST - 1
                     CS = DWORK(PDW)
                     SN = DWORK(PDW+1)
                     IF ( SN.NE.ZERO ) THEN
                        CALL DROT( ILASTM-J+1, A(J,J,AIND), LDA1,
     $                             A(J+1,J,AIND), LDA1, CS, SN )
C
C                       Check for deflation.
C
                        IF ( .NOT.ADEFL ) THEN
                           TOL = ABS( A(J,J,AIND) ) +
     $                           ABS( A(J+1,J+1,AIND) )
                           IF ( TOL.EQ.ZERO )
     $                        TOL = DLANHS( '1', J-JLO+2,
     $                                      A(JLO,JLO,AIND), LDA1,
     $                                      DWORK )
                           TOL = MAX( ULP*TOL, SMLNUM )
                        END IF
                        IF ( ABS( A(J+1,J,AIND) ).LE.TOL ) THEN
                           CS = ONE
                           SN = ZERO
                           A(J+1,J,AIND) = ZERO
                        END IF
                     END IF
                     IF ( SN.NE.ZERO ) THEN
                        TEMP = A(J+1,J+1,AIND)
                        CALL DLARTG( TEMP, -A(J+1,J,AIND), CS, SN,
     $                               A(J+1,J+1,AIND) )
                        A(J+1,J,AIND) = ZERO
                        CALL DROT( J+1-IFRSTM, A(IFRSTM,J,AIND), 1,
     $                             A(IFRSTM,J+1,AIND), 1, CS, SN )
                     END IF
                     DWORK(PDW)   = CS
                     DWORK(PDW+1) = SN
                     PDW = PDW + 2
  130             CONTINUE
               END IF
               IF ( LCMPQ ) THEN
                  QI = IWORK(MAPQ+L)
               ELSE IF ( LPARQ ) THEN
                  QI = ABS( QIND(IWORK(MAPQ+L)) )
               END IF
               IF ( QI.NE.0 ) THEN
                  PDW = PFREE + 1
                  DO 140  J = JLO, ILAST - 1
                     CS  = DWORK(PDW)
                     SN  = DWORK(PDW+1)
                     PDW = PDW + 2
                     IF ( SN.NE.ZERO )
     $                  CALL DROT( N, Q(1,J,QI), 1, Q(1,J+1,QI), 1, CS,
     $                             SN )
  140             CONTINUE
               END IF
  150       CONTINUE
C
C           Apply the transformations to the right hand side of the
C           Hessenberg factor.
C
            AIND = IWORK(MAPA+1)
            PDW  = PFREE + 1
            ZITER = 0
            DO 160  J = JLO, ILAST - 1
               CS = DWORK(PDW)
               SN = DWORK(PDW+1)
               PDW = PDW + 2
               IF ( SN.NE.ZERO ) THEN
                  CALL DROT( J+2-IFRSTM, A(IFRSTM,J,AIND), 1,
     $                       A(IFRSTM,J+1,AIND), 1, CS, SN )
               ELSE
                  ZITER = -1
               END IF
  160       CONTINUE
C
C           No QZ iteration.
C
            GO TO 530
         END IF
C
C        **************************************************************
C        *                     HANDLE DEFLATIONS                      *
C        **************************************************************
C
C        Case I: Deflation occurs in the Hessenberg matrix. The QZ
C                iteration is only applied to the JLO:ILAST part.
C
         IFIRST = JLO
C
C        Go to the periodic QZ steps.
C
         GO TO 420
C
C        Case II: Deflation occurs in a triangular matrix with index 1.
C
C        Do an unshifted periodic QZ step.
C
  170    CONTINUE
         JDEF = J
         AIND = IWORK(MAPA+1)
         PDW  = PFREE + 1
         DO 180  J = JLO, JDEF - 1
            TEMP = A(J,J,AIND)
            CALL DLARTG( TEMP, A(J+1,J,AIND), CS, SN, A(J,J,AIND) )
            A(J+1,J,AIND) = ZERO
            CALL DROT( ILASTM-J, A(J,J+1,AIND), LDA1, A(J+1,J+1,AIND),
     $                 LDA1, CS, SN )
            DWORK(PDW)   = CS
            DWORK(PDW+1) = SN
            PDW = PDW + 2
  180    CONTINUE
         IF ( LCMPQ ) THEN
            QI = IWORK(MAPQ+1)
         ELSE IF ( LPARQ ) THEN
            QI = ABS( QIND(IWORK(MAPQ+1)) )
         END IF
         IF ( QI.NE.0 ) THEN
            PDW = PFREE + 1
            DO 190  J = JLO, JDEF - 1
               CS  = DWORK(PDW)
               SN  = DWORK(PDW+1)
               PDW = PDW + 2
               CALL DROT( N, Q(1,J,QI), 1, Q(1,J+1,QI), 1, CS, SN )
  190       CONTINUE
         END IF
C
C        Propagate the transformations through the triangular matrices.
C        Due to the zero element on the diagonal of the LDEF-th factor,
C        the number of transformations drops by one.
C
         DO 230  L = K, 2, -1
            AIND = IWORK(MAPA+L)
            IF ( L.LT.LDEF ) THEN
               NTRA = JDEF - 2
            ELSE
               NTRA = JDEF - 1
            END IF
            PDW = PFREE + 1
            IF ( S(AIND).EQ.SINV ) THEN
               DO 200  J = JLO, NTRA
                  CS = DWORK(PDW)
                  SN = DWORK(PDW+1)
                  CALL DROT( J+2-IFRSTM, A(IFRSTM,J,AIND), 1,
     $                       A(IFRSTM,J+1,AIND), 1, CS, SN )
                  TEMP = A(J,J,AIND)
                  CALL DLARTG( TEMP, A(J+1,J,AIND), CS, SN,
     $                         A(J,J,AIND) )
                  A(J+1,J,AIND) = ZERO
                  CALL DROT( ILASTM-J, A(J,J+1,AIND), LDA1,
     $                       A(J+1,J+1,AIND), LDA1, CS, SN )
                  DWORK(PDW)   = CS
                  DWORK(PDW+1) = SN
                  PDW = PDW + 2
  200          CONTINUE
            ELSE
               DO 210  J = JLO, NTRA
                  CS = DWORK(PDW)
                  SN = DWORK(PDW+1)
                  CALL DROT( ILASTM-J+1, A(J,J,AIND), LDA1,
     $                       A(J+1,J,AIND), LDA1, CS, SN )
                  TEMP = A(J+1,J+1,AIND)
                  CALL DLARTG( TEMP, -A(J+1,J,AIND), CS, SN,
     $                         A(J+1,J+1,AIND) )
                  A(J+1,J,AIND) = ZERO
                  CALL DROT( J+1-IFRSTM, A(IFRSTM,J,AIND), 1,
     $                       A(IFRSTM,J+1,AIND), 1, CS, SN )
                  DWORK(PDW)   = CS
                  DWORK(PDW+1) = SN
                  PDW = PDW + 2
  210          CONTINUE
            END IF
            IF ( LCMPQ ) THEN
               QI = IWORK(MAPQ+L)
            ELSE IF ( LPARQ ) THEN
               QI = ABS( QIND(IWORK(MAPQ+L)) )
            END IF
            IF ( QI.NE.0 ) THEN
               PDW = PFREE + 1
               DO 220  J = JLO, NTRA
                  CS  = DWORK(PDW)
                  SN  = DWORK(PDW+1)
                  PDW = PDW + 2
                  CALL DROT( N, Q(1,J,QI), 1, Q(1,J+1,QI), 1, CS, SN )
  220          CONTINUE
            END IF
  230    CONTINUE
C
C        Apply the transformations to the right hand side of the
C        Hessenberg factor.
C
         AIND = IWORK(MAPA+1)
         PDW = PFREE + 1
         DO 240  J = JLO, JDEF - 2
            CS = DWORK(PDW)
            SN = DWORK(PDW+1)
            PDW = PDW + 2
            CALL DROT( J+2-IFRSTM, A(IFRSTM,J,AIND), 1,
     $                 A(IFRSTM,J+1,AIND), 1, CS, SN )
  240    CONTINUE
C
C        Do an unshifted periodic QZ step.
C
         PDW = PFREE + 1
         DO 250  J = ILAST, JDEF + 1, -1
            TEMP = A(J,J,AIND)
            CALL DLARTG( TEMP, -A(J,J-1,AIND), CS, SN, A(J,J,AIND) )
            A(J,J-1,AIND) = ZERO
            CALL DROT( J-IFRSTM, A(IFRSTM,J-1,AIND), 1,
     $                 A(IFRSTM,J,AIND), 1, CS, SN )
            DWORK(PDW)   = CS
            DWORK(PDW+1) = SN
            PDW = PDW + 2
  250    CONTINUE
         IF ( LCMPQ ) THEN
            QI = IWORK(MAPQ+2)
         ELSE IF ( LPARQ ) THEN
            QI = ABS( QIND(IWORK(MAPQ+2)) )
         END IF
         IF ( QI.NE.0 ) THEN
            PDW = PFREE + 1
            DO 260  J = ILAST, JDEF + 1, -1
               CS  = DWORK(PDW)
               SN  = DWORK(PDW+1)
               PDW = PDW + 2
               CALL DROT( N, Q(1,J-1,QI), 1, Q(1,J,QI), 1, CS, SN )
  260       CONTINUE
         END IF
C
C        Propagate the transformations through the triangular matrices.
C
         DO 300  L = 2, K
            AIND = IWORK(MAPA+L)
            IF ( L.GT.LDEF ) THEN
               NTRA = JDEF + 2
            ELSE
               NTRA = JDEF + 1
            END IF
            PDW = PFREE + 1
            IF ( S(AIND).NE.SINV ) THEN
               DO 270  J = ILAST, NTRA, -1
                  CS = DWORK(PDW)
                  SN = DWORK(PDW+1)
                  CALL DROT( J+1-IFRSTM, A(IFRSTM,J-1,AIND), 1,
     $                       A(IFRSTM,J,AIND), 1, CS, SN )
                  TEMP = A(J-1,J-1,AIND)
                  CALL DLARTG( TEMP, A(J,J-1,AIND), CS, SN,
     $                         A(J-1,J-1,AIND) )
                  A(J,J-1,AIND) = ZERO
                  CALL DROT( ILASTM-J+1, A(J-1,J,AIND), LDA1,
     $                       A(J,J,AIND), LDA1, CS, SN )
                  DWORK(PDW)   = CS
                  DWORK(PDW+1) = SN
                  PDW = PDW + 2
  270          CONTINUE
            ELSE
               DO 280  J = ILAST, NTRA, -1
                  CS = DWORK(PDW)
                  SN = DWORK(PDW+1)
                  CALL DROT( ILASTM-J+2, A(J-1,J-1,AIND), LDA1,
     $                       A(J,J-1,AIND), LDA1, CS, SN )
                  TEMP = A(J,J,AIND)
                  CALL DLARTG( TEMP, -A(J,J-1,AIND), CS, SN,
     $                         A(J,J,AIND) )
                  A(J,J-1,AIND) = ZERO
                  CALL DROT( J-IFRSTM, A(IFRSTM,J-1,AIND), 1,
     $                       A(IFRSTM,J,AIND), 1, CS, SN )
                  DWORK(PDW)   = CS
                  DWORK(PDW+1) = SN
                  PDW = PDW + 2
  280          CONTINUE
            END IF
            LM = MOD( L, K ) + 1
            IF ( LCMPQ ) THEN
               QI = IWORK(MAPQ+LM)
            ELSE IF ( LPARQ ) THEN
               QI = ABS( QIND(IWORK(MAPQ+LM)) )
            END IF
            IF ( QI.NE.0 ) THEN
               PDW = PFREE + 1
               DO 290  J = ILAST, NTRA, -1
                  CS  = DWORK(PDW)
                  SN  = DWORK(PDW+1)
                  PDW = PDW + 2
                  CALL DROT( N, Q(1,J-1,QI), 1, Q(1,J,QI), 1, CS, SN )
  290          CONTINUE
            END IF
  300    CONTINUE
C
C        Apply the transformations to the left hand side of the
C        Hessenberg factor.
C
         AIND = IWORK(MAPA+1)
         PDW  = PFREE + 1
         DO 310  J = ILAST, JDEF + 2, -1
            CS  = DWORK(PDW)
            SN  = DWORK(PDW+1)
            PDW = PDW + 2
            CALL DROT( ILASTM-J+2, A(J-1,J-1,AIND), LDA1, A(J,J-1,AIND),
     $                 LDA1, CS, SN )
  310    CONTINUE
C
C        No QZ iteration.
C
         GO TO 530
C
C        Case III: Deflation occurs in a triangular matrix with
C                  index -1.
C
  320    CONTINUE
         JDEF = J
         IF ( JDEF.GT.( ( ILAST - JLO + 1 )/2 ) ) THEN
C
C           Chase the zero downwards to the last position.
C
            DO 340  J1 = JDEF, ILAST - 1
               J = J1
               AIND = IWORK(MAPA+LDEF)
               TEMP = A(J,J+1,AIND)
               CALL DLARTG( TEMP, A(J+1,J+1,AIND), CS, SN,
     $                      A(J,J+1,AIND) )
               A(J+1,J+1,AIND) = ZERO
               CALL DROT( ILASTM-J-1, A(J,J+2,AIND), LDA1,
     $                    A(J+1,J+2,AIND), LDA1, CS, SN )
               LM = MOD( LDEF, K ) + 1
               IF ( LCMPQ ) THEN
                  QI = IWORK(MAPQ+LM)
               ELSE IF ( LPARQ ) THEN
                  QI = ABS( QIND(IWORK(MAPQ+LM)) )
               END IF
               IF ( QI.NE.0 )
     $            CALL DROT( N, Q(1,J,QI), 1, Q(1,J+1,QI), 1, CS, SN )
               DO 330  L = 1, K - 1
                  AIND = IWORK(MAPA+LM)
                  IF ( LM.EQ.1 ) THEN
                     CALL DROT( ILASTM-J+2, A(J,J-1,AIND), LDA1,
     $                          A(J+1,J-1,AIND), LDA1, CS, SN )
                     TEMP = A(J+1,J,AIND)
                     CALL DLARTG( TEMP, -A(J+1,J-1,AIND), CS, SN,
     $                            A(J+1,J,AIND) )
                     A(J+1,J-1,AIND) = ZERO
                     CALL DROT( J-IFRSTM+1, A(IFRSTM,J-1,AIND), 1,
     $                          A(IFRSTM,J,AIND), 1, CS, SN )
                     J = J - 1
                  ELSE IF ( S(AIND).EQ.SINV ) THEN
                     CALL DROT( ILASTM-J+1, A(J,J,AIND), LDA1,
     $                          A(J+1,J,AIND), LDA1, CS, SN )
                     TEMP = A(J+1,J+1,AIND)
                     CALL DLARTG( TEMP, -A(J+1,J,AIND), CS, SN,
     $                            A(J+1,J+1,AIND) )
                     A(J+1,J,AIND) = ZERO
                     CALL DROT( J-IFRSTM+1, A(IFRSTM,J,AIND), 1,
     $                          A(IFRSTM,J+1,AIND), 1, CS, SN )
                  ELSE
                     CALL DROT( J-IFRSTM+2, A(IFRSTM,J,AIND), 1,
     $                          A(IFRSTM,J+1,AIND), 1, CS, SN )
                     TEMP = A(J,J,AIND)
                     CALL DLARTG( TEMP, A(J+1,J,AIND), CS, SN,
     $                            A(J,J,AIND) )
                     A(J+1,J,AIND) = ZERO
                     CALL DROT( ILASTM-J, A(J,J+1,AIND), LDA1,
     $                          A(J+1,J+1,AIND), LDA1, CS, SN )
                  END IF
                  LM = MOD( LM, K ) + 1
                  IF ( LCMPQ ) THEN
                     QI = IWORK(MAPQ+LM)
                  ELSE IF ( LPARQ ) THEN
                     QI = ABS( QIND(IWORK(MAPQ+LM)) )
                  END IF
                  IF ( QI.NE.0 )
     $               CALL DROT( N, Q(1,J,QI), 1, Q(1,J+1,QI), 1, CS,
     $                          SN )
  330          CONTINUE
               AIND = IWORK(MAPA+LDEF)
               CALL DROT( J-IFRSTM+1, A(IFRSTM,J,AIND), 1,
     $                    A(IFRSTM,J+1,AIND), 1, CS, SN )
  340       CONTINUE
C
C           Deflate the last element in the Hessenberg matrix.
C
            AIND = IWORK(MAPA+1)
            J = ILAST
            TEMP = A(J,J,AIND)
            CALL DLARTG( TEMP, -A(J,J-1,AIND), CS, SN, A(J,J,AIND) )
            A(J,J-1,AIND) = ZERO
            CALL DROT( J-IFRSTM, A(IFRSTM,J-1,AIND), 1,
     $                 A(IFRSTM,J,AIND), 1, CS, SN )
            IF ( LCMPQ ) THEN
               QI = IWORK(MAPQ+2)
            ELSE IF ( LPARQ ) THEN
               QI = ABS( QIND(IWORK(MAPQ+2)) )
            END IF
            IF ( QI.NE.0 )
     $         CALL DROT( N, Q(1,J-1,QI), 1, Q(1,J,QI), 1, CS, SN )
            DO 350  L = 2, LDEF - 1
               AIND = IWORK(MAPA+L)
               IF ( S(AIND).NE.SINV ) THEN
                  CALL DROT( J+1-IFRSTM, A(IFRSTM,J-1,AIND), 1,
     $                       A(IFRSTM,J,AIND), 1, CS, SN )
                  TEMP = A(J-1,J-1,AIND)
                  CALL DLARTG( TEMP, A(J,J-1,AIND), CS, SN,
     $                         A(J-1,J-1,AIND) )
                  A(J,J-1,AIND) = ZERO
                  CALL DROT( ILASTM-J+1, A(J-1,J,AIND), LDA1,
     $                       A(J,J,AIND), LDA1, CS, SN )
               ELSE
                  CALL DROT( ILASTM-J+2, A(J-1,J-1,AIND), LDA1,
     $                       A(J,J-1,AIND), LDA1, CS, SN )
                  TEMP = A(J,J,AIND)
                  CALL DLARTG( TEMP, -A(J,J-1,AIND), CS, SN,
     $                         A(J,J,AIND) )
                  A(J,J-1,AIND) = ZERO
                  CALL DROT( J-IFRSTM, A(IFRSTM,J-1,AIND), 1,
     $                       A(IFRSTM,J,AIND), 1, CS, SN )
               END IF
               LM = L + 1
               IF ( LCMPQ ) THEN
                  QI = IWORK(MAPQ+LM)
               ELSE IF ( LPARQ ) THEN
                  QI = ABS( QIND(IWORK(MAPQ+LM)) )
               END IF
               IF ( QI.NE.0 )
     $            CALL DROT( N, Q(1,J-1,QI), 1, Q(1,J,QI), 1, CS, SN )
  350       CONTINUE
            AIND = IWORK(MAPA+LDEF)
            CALL DROT( J+1-IFRSTM, A(IFRSTM,J-1,AIND), 1,
     $                 A(IFRSTM,J,AIND), 1, CS, SN )
         ELSE
C
C           Chase the zero upwards to the first position.
C
            DO 370  J1 = JDEF, JLO + 1, -1
               J = J1
               AIND = IWORK(MAPA+LDEF)
               TEMP = A(J-1,J,AIND)
               CALL DLARTG( TEMP, -A(J-1,J-1,AIND), CS, SN,
     $                      A(J-1,J,AIND) )
               A(J-1,J-1,AIND) = ZERO
               CALL DROT( J-IFRSTM-1, A(IFRSTM,J-1,AIND), 1,
     $                    A(IFRSTM,J,AIND), 1, CS, SN )
               IF ( LCMPQ ) THEN
                  QI = IWORK(MAPQ+LDEF)
               ELSE IF ( LPARQ ) THEN
                  QI = ABS( QIND(IWORK(MAPQ+LDEF)) )
               END IF
               IF ( QI.NE.0 )
     $            CALL DROT( N, Q(1,J-1,QI), 1, Q(1,J,QI), 1, CS, SN )
               LM = LDEF - 1
               DO 360  L = 1, K - 1
                  AIND = IWORK(MAPA+LM)
                  IF ( LM.EQ.1 ) THEN
                     CALL DROT( J-IFRSTM+2, A(IFRSTM,J-1,AIND), 1,
     $                          A(IFRSTM,J,AIND), 1, CS, SN )
                     TEMP = A(J,J-1,AIND)
                     CALL DLARTG( TEMP, A(J+1,J-1,AIND), CS, SN,
     $                            A(J,J-1,AIND) )
                     A(J+1,J-1,AIND) = ZERO
                     CALL DROT( ILASTM-J+1, A(J,J,AIND), LDA1,
     $                          A(J+1,J,AIND), LDA1, CS, SN )
                     J = J + 1
                  ELSE IF ( S(AIND).NE.SINV ) THEN
                     CALL DROT( ILASTM-J+2, A(J-1,J-1,AIND), LDA1,
     $                          A(J,J-1,AIND), LDA1, CS, SN )
                     TEMP = A(J,J,AIND)
                     CALL DLARTG( TEMP, -A(J,J-1,AIND), CS, SN,
     $                            A(J,J,AIND) )
                     A(J,J-1,AIND) = ZERO
                     CALL DROT( J-IFRSTM, A(IFRSTM,J-1,AIND), 1,
     $                          A(IFRSTM,J,AIND), 1, CS, SN )
                  ELSE
                     CALL DROT( J-IFRSTM+1, A(IFRSTM,J-1,AIND), 1,
     $                          A(IFRSTM,J,AIND), 1, CS, SN )
                     TEMP = A(J-1,J-1,AIND)
                     CALL DLARTG( TEMP, A(J,J-1,AIND), CS, SN,
     $                            A(J-1,J-1,AIND) )
                     A(J,J-1,AIND) = ZERO
                     CALL DROT( ILASTM-J+1, A(J-1,J,AIND), LDA1,
     $                          A(J,J,AIND), LDA1, CS, SN )
                  END IF
                  IF ( LCMPQ ) THEN
                     QI = IWORK(MAPQ+LM)
                  ELSE IF ( LPARQ ) THEN
                     QI = ABS( QIND(IWORK(MAPQ+LM)) )
                  END IF
                  IF ( QI.NE.0 )
     $               CALL DROT( N, Q(1,J-1,QI), 1, Q(1,J,QI), 1, CS,
     $                          SN )
                  LM = LM - 1
                  IF ( LM.LE.0 )
     $               LM = K
  360          CONTINUE
               AIND = IWORK(MAPA+LDEF)
               CALL DROT( ILASTM-J+1, A(J-1,J,AIND), LDA1, A(J,J,AIND),
     $                    LDA1, CS, SN )
  370       CONTINUE
C
C           Deflate the first element in the Hessenberg matrix.
C
            AIND = IWORK(MAPA+1)
            J = JLO
            TEMP = A(J,J,AIND)
            CALL DLARTG( TEMP, A(J+1,J,AIND), CS, SN, A(J,J,AIND) )
            A(J+1,J,AIND) = ZERO
            CALL DROT( ILASTM-J, A(J,J+1,AIND), LDA1, A(J+1,J+1,AIND),
     $                 LDA1, CS, SN )
            IF ( LCMPQ ) THEN
               QI = IWORK(MAPQ+1)
            ELSE IF ( LPARQ ) THEN
               QI = ABS( QIND(IWORK(MAPQ+1)) )
            END IF
            IF ( QI.NE.0 )
     $         CALL DROT( N, Q(1,J,QI), 1, Q(1,J+1,QI), 1, CS, SN )
            DO 380  L = K, LDEF + 1, -1
               AIND = IWORK(MAPA+L)
               IF ( S(AIND).EQ.SINV ) THEN
                  CALL DROT( J+2-IFRSTM, A(IFRSTM,J,AIND), 1,
     $                       A(IFRSTM,J+1,AIND), 1, CS, SN )
                  TEMP = A(J,J,AIND)
                  CALL DLARTG( TEMP, A(J+1,J,AIND), CS, SN,
     $                         A(J,J,AIND) )
                  A(J+1,J,AIND) = ZERO
                  CALL DROT( ILASTM-J, A(J,J+1,AIND), LDA1,
     $                       A(J+1,J+1,AIND), LDA1, CS, SN )
               ELSE
                  CALL DROT( ILASTM-J+1, A(J,J,AIND), LDA1,
     $                       A(J+1,J,AIND), LDA1, CS, SN )
                  TEMP = A(J+1,J+1,AIND)
                  CALL DLARTG( TEMP, -A(J+1,J,AIND), CS, SN,
     $                         A(J+1,J+1,AIND) )
                  A(J+1,J,AIND) = ZERO
                  CALL DROT( J+1-IFRSTM, A(IFRSTM,J,AIND), 1,
     $                       A(IFRSTM,J+1,AIND), 1, CS, SN )
               END IF
               IF ( LCMPQ ) THEN
                  QI = IWORK(MAPQ+L)
               ELSE IF ( LPARQ ) THEN
                  QI = ABS( QIND(IWORK(MAPQ+L)) )
               END IF
               IF ( QI.NE.0 )
     $            CALL DROT( N, Q(1,J,QI), 1, Q(1,J+1,QI), 1, CS, SN )
  380       CONTINUE
            AIND = IWORK(MAPA+LDEF)
            CALL DROT( ILASTM-J, A(J,J+1,AIND), LDA1, A(J+1,J+1,AIND),
     $                 LDA1, CS, SN )
         END IF
C
C        No QZ iteration.
C
         GO TO 530
C
C        Special case: A 1x1 block splits off at the bottom.
C
  390    CONTINUE
         CALL MA01BD( BASE, LGBAS, K, S, A(ILAST,ILAST,1), LDA1*LDA2,
     $                ALPHAR(ILAST), BETA(ILAST), SCAL(ILAST) )
         ALPHAI(ILAST) = ZERO
C
C        Check for possible loss of accuracy.
C
         IF ( BETA(ILAST).NE.ZERO ) THEN
            DO 400  L = 1, K
               AIND = IWORK(MAPA+L)
               TEMP = A(ILAST,ILAST,AIND)
               IF ( TEMP.NE.ZERO ) THEN
                  IF ( ABS( TEMP ).LT.DWORK(L)*TOLL ) THEN
                     IWARN = N + 1
                     IWORK(2*K+ILAST) = ILAST
                     GO TO 410
                  END IF
               END IF
  400       CONTINUE
         END IF
C
C        Go to next block - exit if finished.
C
  410    CONTINUE
         ILAST = ILAST - 1
         IF ( ILAST.LT.ILO )
     $      GO TO 550
C
C        Reset iteration counters.
C
         IITER  = 0
         TITER  = 0
         COUNT  = 0
         COUNTE = 0
         IF ( ZITER.NE.-1 )
     $      ZITER = 0
         IF ( .NOT.LSCHR ) THEN
            ILASTM = ILAST
            IF ( IFRSTM.GT.ILAST )
     $         IFRSTM = ILO
         END IF
C
C        No QZ iteration.
C
         GO TO 530
C
C        **************************************************************
C        *                      PERIODIC QZ STEP                      *
C        **************************************************************
C
C        It is assumed that IFIRST < ILAST.
C
  420    CONTINUE
C
         IITER = IITER + 1
         ZITER = ZITER + 1
         IF( .NOT.LSCHR )
     $      IFRSTM = IFIRST
         IF ( IFIRST+1.EQ.ILAST ) THEN
C
C           Special case -- 2x2 block.
C
            J = ILAST - 1
            IF ( TITER.LT.2 ) THEN
               TITER = TITER + 1
C
C              Try to deflate the 2-by-2 problem.
C
               PDW = PFREE + 1
               DO 430  L = 1, K
                  DWORK(PDW  ) = A(J,J,L)
                  DWORK(PDW+1) = A(J+1,J,L)
                  DWORK(PDW+2) = A(J,J+1,L)
                  DWORK(PDW+3) = A(J+1,J+1,L)
                  PDW = PDW + 4
  430          CONTINUE
               IF ( SINV.LT.0 ) THEN
                  I = IWORK(MAPQ+1)
                  IWORK(MAPQ+1) = IWORK(MAPA+1)
               END IF
               CALL MB03BF( K, IWORK(MAPH), S, SINV, DWORK(PFREE+1),
     $                      2, 2, ULP )
               IF ( SINV.LT.0 )
     $            IWORK(MAPQ+1) = I
               I = PFREE + 4*( H - 1 )
               IF ( ABS( DWORK(I+2) ).LT.
     $              ULP*( MAX( ABS( DWORK(I+1) ), ABS( DWORK(I+3) ),
     $                         ABS( DWORK(I+4) ) ) ) ) THEN
C
C                 Construct a perfect shift polynomial. This may fail,
C                 so we try it twice (indicated by TITER).
C
                  CS1 = ONE
                  SN1 = ONE
                  DO 440  L = K, 2, -1
                     AIND = IWORK(MAPA+L)
                     TEMP = DWORK(PFREE+AIND*4)
                     IF ( S(AIND).EQ.SINV ) THEN
                        CALL DLARTG( CS1*A(J,J,AIND), SN1*TEMP, CS1,
     $                               SN1, TEMP )
                     ELSE
                        CALL DLARTG( CS1*TEMP, SN1*A(J,J,AIND), CS1,
     $                               SN1, TEMP )
                     END IF
  440             CONTINUE
                  AIND = IWORK(MAPA+1)
                  TEMP = DWORK(PFREE+AIND*4)
                  CALL DLARTG( A(J,J,AIND)*CS1-TEMP*SN1,
     $                         A(J+1,J,AIND)*CS1, CS1, SN1, TEMP )
                  GO TO 510
               END IF
            END IF
C
C           Looks like a complex block.
C           1. Compute the product SVD of the triangular matrices
C             (optionally).
C
            IF ( LSVD ) THEN
               CALL MB03BC( K, IWORK(MAPA+1), S, SINV, A(J,J,1), LDA1,
     $                      LDA2, MACPAR, DWORK(PFREE+1),
     $                      DWORK(PFREE+K+1), DWORK(PFREE+2*K+1) )
C
C              Update factors and transformations.
C
               AIND = IWORK(MAPA+1)
               CS2  = DWORK(PFREE+1)
               SN2  = DWORK(PFREE+K+1)
               CALL DROT( ILASTM-IFRSTM+1, A(IFRSTM,J,AIND), 1,
     $                    A(IFRSTM,J+1,AIND), 1, CS2, SN2 )
               DO 450  L = 2, K
                  AIND = IWORK(MAPA+L)
                  IF ( LCMPQ ) THEN
                     QI = IWORK(MAPQ+L)
                  ELSE IF ( LPARQ ) THEN
                     QI = ABS( QIND(IWORK(MAPQ+L)) )
                  END IF
                  IF ( QI.NE.0 )
     $               CALL DROT( N, Q(1,J,QI), 1, Q(1,J+1,QI), 1, CS2,
     $                          SN2 )
                  CS1 = CS2
                  SN1 = SN2
                  CS2 = DWORK(PFREE+L)
                  SN2 = DWORK(PFREE+K+L)
                  IF (S(AIND).EQ.SINV) THEN
                     CALL DROT( ILASTM-J-1, A(J,J+2,AIND), LDA1,
     $                          A(J+1,J+2,AIND), LDA1, CS1, SN1 )
                     CALL DROT( J-IFRSTM, A(IFRSTM,J,AIND), 1,
     $                          A(IFRSTM,J+1,AIND), 1, CS2, SN2 )
                  ELSE
                     CALL DROT( ILASTM-J-1, A(J,J+2,AIND), LDA1,
     $                          A(J+1,J+2,AIND), LDA1, CS2, SN2 )
                     CALL DROT( J-IFRSTM, A(IFRSTM,J,AIND), 1,
     $                          A(IFRSTM,J+1,AIND), 1, CS1, SN1 )
                  END IF
  450          CONTINUE
               IF ( LCMPQ ) THEN
                  QI = IWORK(MAPQ+1)
               ELSE IF ( LPARQ ) THEN
                  QI = ABS( QIND(IWORK(MAPQ+1)) )
               END IF
               IF ( QI.NE.0 )
     $            CALL DROT( N, Q(1,J,QI), 1, Q(1,J+1,QI), 1, CS2, SN2 )
               AIND = IWORK(MAPA+1)
               CALL DROT( ILASTM-J+1, A(J,J,AIND), LDA1,
     $                    A(J+1,J,AIND), LDA1, CS2, SN2 )
            END IF
C
C           2. Compute complex eigenvalues.
C
            CALL MB03BB( BASE, LGBAS, ULP, K, IWORK(MAPA+1), S, SINV,
     $                   A(J,J,1), LDA1, LDA2, ALPHAR(J), ALPHAI(J),
     $                   BETA(J), SCAL(J), DWORK(PFREE+1), IERR )
            IF ( IERR.EQ.1 ) THEN
C
C              The single shift periodic QZ did not converge, set
C              IWARN = J to indicate that the eigenvalues are not
C              assigned.
C
               IWARN = MAX( J, IWARN )
            ELSE IF ( IERR.EQ.2 ) THEN
C
C              Some computed eigenvalues might be inaccurate.
C
               IF ( IWARN.EQ.0 )
     $            IWARN = N
            END IF
C
C           Check for real eigenvalues and possible loss of accuracy.
C           Also, set zero or infinite eigenvalues where appropriate.
C
            DO 460  L = 1, K
               AIND = IWORK(MAPA+L)
               IF ( ALPHAI(J).EQ.ZERO .AND. BETA(J).NE.ZERO ) THEN
                  IF ( ABS( A(J,J,AIND) ).LT.DWORK(L)*TOLL ) THEN
                     IWARN = N + 1
                     IWORK(2*K+J) = -J
                     GO TO 470
                  END IF
               ELSE
                  A1  = A(J,J,AIND)
                  A3  = A(J,J+1,AIND)
                  A4  = A(J+1,J+1,AIND)
                  NRM = DLAPY3( A1, A3, A4 )
                  IF ( L.EQ.IWORK(MAPA+1) ) THEN
                     A2  = A(J+1,J,L)
                     NRM = DLAPY2( NRM, A2 )
                  END IF
                  SDET = ( MAX( ABS( A1 ), ABS( A4 ) )/NRM )
     $                    *MIN( ABS( A1 ), ABS( A4 ) )*
     $                    SIGN( ONE, A1 )*SIGN( ONE, A4 )
                  IF ( L.EQ.IWORK(MAPA+1) )
     $               SDET = SDET - ( MAX( ABS( A2 ), ABS( A3 ) )/NRM )
     $                              *MIN( ABS( A2 ), ABS( A3 ) )*
     $                              SIGN( ONE, A2 )*SIGN( ONE, A3 )
                  IF ( ABS( SDET ).LT.DWORK(L)*TOLL ) THEN
C
C                    Make a more accurate singularity test using SVD.
C
                     IF ( L.EQ.IWORK(MAPA+1) ) THEN
                        IF ( ABS( A1 ).GE.ABS( A4 ) ) THEN
                           CALL DLARTG( A1, A2, CS, SN, TEMP )
                           A1   = TEMP
                           TEMP = CS*A3 + SN*A4
                           A4   = CS*A4 - SN*A3
                           A3   = TEMP
                        ELSE
                           CALL DLARTG( A4, A2, CS, SN, TEMP )
                           A4   = TEMP
                           TEMP = CS*A3 + SN*A1
                           A1   = CS*A1 - SN*A3
                           A3   = TEMP
                        END IF
                     END IF
                     CALL DLAS2( A1, A3, A4, SVMN, TEMP )
                     IF ( SVMN.LT.DWORK(L)*TOLL ) THEN
                        IWARN = N + 1
                        IWORK(2*K+J) = -J
                        GO TO 470
                     END IF
                  END IF
               END IF
  460       CONTINUE
C
C           Go to next block and reset counters.
C
  470       CONTINUE
            ILAST = IFIRST - 1
            IF ( ILAST.LT.ILO )
     $         GO TO 550
            IITER  = 0
            TITER  = 0
            COUNT  = 0
            COUNTE = 0
            IF ( ZITER.NE.-1 )
     $         ZITER = 0
            IF ( .NOT.LSCHR ) THEN
               ILASTM = ILAST
               IF ( IFRSTM.GT.ILAST )
     $           IFRSTM = ILO
            END IF
            GO TO 530
         END IF
C
C        Now, it is assumed that ILAST-IFIRST+1 >= 3.
C
         IF ( COUNT.LT.NITER ) THEN
C
C           Use the normal periodic QZ step routine.
C           Note that the pointer to IWORK is increased by 1.
C           The fact that, for SINV = 1, IWORK(MAPQ+1) = IWORK(MAPA+1)
C           is used.
C
            COUNT = COUNT + 1
            IF ( SINV.LT.0 ) THEN
               I = IWORK(MAPQ+1)
               IWORK(MAPQ+1) = IWORK(MAPA+1)
            END IF
            CALL MB03AF( 'Double', K, ILAST-IFIRST+1, IWORK(MAPH), S,
     $                   SINV, A(IFIRST,IFIRST,1), LDA1, LDA2, CS1,
     $                   SN1, CS2, SN2 )
            IF ( SINV.LT.0 )
     $         IWORK(MAPQ+1) = I
         ELSE IF ( COUNTE.LT.MCOUNT ) THEN
C
C           Compute the two trailing eigenvalues for finding the shifts.
C           Deal with special case of infinite eigenvalues, if needed.
C
            I = ILAST - 1
            IF ( SINV.LT.0 ) THEN
               AIND = IWORK(MAPA+1)
               A1   = A(I,I,AIND)
               A2   = A(I+1,I,AIND)
               A3   = A(I,I+1,AIND)
               A4   = A(I+1,I+1,AIND)
               NRM  = DLANHS( 'Frobenius', 2, A(ILO,ILO,AIND), LDA1,
     $                        DWORK )
               SDET = (  MAX( ABS( A1 ), ABS( A4 ) )/NRM )
     $                  *MIN( ABS( A1 ), ABS( A4 ) )*
     $                  SIGN( ONE, A1 )*SIGN( ONE, A4 ) -
     $                (  MAX( ABS( A2 ), ABS( A3 ) )/NRM )
     $                  *MIN( ABS( A2 ), ABS( A3 ) )*
     $                  SIGN( ONE, A2 )*SIGN( ONE, A3 )
               ISINF = ABS( SDET ).LT.DWORK(AIND)*TOLL
               IF ( ISINF ) THEN
                  ALPHAR(I)     = ONE/DWORK(PNORM+1)
                  ALPHAR(ILAST) = ONE/DWORK(PNORM+1)
                  SCAL(I)       = 1
                  SCAL(ILAST)   = 1
               END IF
               IERR = 0
            ELSE
               ISINF = .FALSE.
            END IF
            IF ( .NOT.ISINF ) THEN
               CALL MB03BB( BASE, LGBAS, ULP, K, IWORK(MAPA+1), S, SINV,
     $                      A(I,I,1), LDA1, LDA2, ALPHAR(I), ALPHAI(I),
     $                      BETA(I), SCAL(I), DWORK(PFREE+1), IERR )
               IF ( SINV.LT.0 ) THEN
C
C                 Use the reciprocals of the eigenvalues returned above.
C
                  IF ( ALPHAI(I).EQ.ZERO ) THEN
                     ALPHAR(I)     = SIGN( ONE, ALPHAR(I) )/
     $                               MAX( SAFMIN, ABS( ALPHAR(I) ) )
                     ALPHAR(ILAST) = SIGN( ONE, ALPHAR(ILAST) )/
     $                               MAX( SAFMIN, ABS( ALPHAR(ILAST) ) )
                     SCAL(I)       = -SCAL(I)
                     SCAL(ILAST)   = -SCAL(ILAST)
                  ELSE
                     CALL DLADIV( ONE, ZERO, ALPHAR(ILAST),
     $                            -ALPHAI(ILAST), ALPHAR(I), ALPHAI(I) )
                     SCAL(I) = -SCAL(I)
                  END IF
               END IF
C
               IF ( IERR.NE.0 ) THEN
C
C                 Try an exceptional transformation if MB03BB does not
C                 converge on some special cases.
C
                  TEMP2 = BASE**SCAL(I)
                  IF ( ALPHAI(I).NE.ZERO ) THEN
                     TEMP = ( ABS( ALPHAR(I) ) + ABS( ALPHAI(I) ) )*
     $                      TEMP2
                  ELSE
                     TEMP = MAX( ABS( ALPHAR(ILAST) )*BASE**SCAL(ILAST),
     $                           ABS( ALPHAR(I) )*TEMP2 )
                  END IF
                  IF ( TEMP.LE.SQRT( ULP )*DWORK(PNORM+1) ) THEN
                     ALPHAR(I) = DWORK(PNORM+1)
                     SCAL(I)   = 1
                     ALPHAR(ILAST) = DWORK(PNORM+1)
                     SCAL(ILAST)   = 1
                     IERR = 0
                  END IF
               END IF
            END IF
C
            IF ( IERR.NE.0 ) THEN
C
C              Use the normal periodic QZ step routine.
C
               IERR = 0
               IN   = ILAST - IFIRST + 1
               IF ( SINV.LT.0 ) THEN
                  J1 = IWORK(MAPQ+1)
                  IWORK(MAPQ+1) = IWORK(MAPA+1)
               END IF
               CALL MB03AF( 'Double', K, IN, IWORK(MAPH), S, SINV,
     $                      A(IFIRST,IFIRST,1), LDA1, LDA2, CS1, SN1,
     $                      CS2, SN2 )
               IF ( SINV.LT.0 )
     $            IWORK(MAPQ+1) = J1
               COUNT  = 0
               COUNTE = 0
            ELSE
C
C              Use explict shifts.
C
               COUNTE = COUNTE + 1
               W1     = ALPHAR(I)*BASE**SCAL(I)
C
               IF ( ALPHAI(I).NE.ZERO ) THEN
C
C                 Use complex conjugate shifts.
C
                  SHFT = 'C'
                  W2   = ALPHAI(I)*BASE**SCAL(I)
C
               ELSE
C
C                 Two identical real shifts are tried first. If there is
C                 no convergence after MCOUNT/2 consecutive iterations,
C                 a single shift is applied. The eigenvalue closer to
C                 the last element of the current product is used.
C
                  W2 = ALPHAR(ILAST)*BASE**SCAL(ILAST)
C
                  CALL MA01BD( BASE, LGBAS, K, S, A(ILAST,ILAST,1),
     $                         LDA1*LDA2, TEMP, TEMP2, I )
                  TEMP = TEMP*BASE**I
                  A1   = ABS( TEMP - W1 )
                  A2   = ABS( TEMP - W2 )
C
                  IF ( COUNTE.LE.MAX( 1, MCOUNT/2 ) ) THEN
                     SHFT = 'D'
                     IF ( A1.LT.A2 ) THEN
                        W2 = W1
                     ELSE
                        W1 = W2
                     END IF
                  ELSE
                     SHFT = 'S'
                     IF ( A1.LT.A2 )
     $                  W2 = W1
                  END IF
C
               END IF
C
C              Compute an initial transformation using the selected
C              shifts.
C
               CALL MB03AB( SHFT, K, ILAST-IFIRST+1, IWORK(MAPA+1), S,
     $                      SINV, A(IFIRST,IFIRST,1), LDA1, LDA2, W1,
     $                      W2, CS1, SN1, CS2, SN2 )
            END IF
C
            IF ( COUNT+COUNTE.GE.NITER+MCOUNT ) THEN
C
C              Reset the two counters.
C
               COUNT  = 0
               COUNTE = 0
            END IF
         END IF
C
C        Do the sweeps.
C
         IF ( K.GT.1 ) THEN
C
C           The propagation of the initial transformation is processed
C           here separately.
C
            IN   = IFIRST + 1
            IO   = ILAST  - 2
            J    = IFIRST
            AIND = IWORK(MAPA+1)
            CALL DROT( ILAST-IFRSTM+1, A(IFRSTM,J+1,AIND), 1,
     $                 A(IFRSTM,J+2,AIND), 1, CS2, SN2 )
            CALL DROT( ILAST-IFRSTM+1, A(IFRSTM,J,AIND), 1,
     $                 A(IFRSTM,J+1,AIND), 1, CS1, SN1 )
            IF ( LCMPQ ) THEN
               QI = IWORK(MAPQ+2)
            ELSE IF ( LPARQ ) THEN
               QI = ABS( QIND(IWORK(MAPQ+2)) )
            END IF
            IF ( QI.NE.0 ) THEN
               CALL DROT( N, Q(1,J+1,QI), 1, Q(1,J+2,QI), 1, CS2, SN2 )
               CALL DROT( N, Q(1,J,QI), 1, Q(1,J+1,QI), 1, CS1, SN1 )
            END IF
C
C           Propagate information from the right to A_k.
C
            DO 480 L = 2, K
               AIND = IWORK(MAPA+L)
               IF ( S(AIND).EQ.SINV ) THEN
                  CALL DROT( ILASTM-J+1, A(J+1,J,AIND), LDA1,
     $                       A(J+2,J,AIND), LDA1, CS2, SN2 )
                  TEMP = A(J+2,J+2,AIND)
                  CALL DLARTG( TEMP, -A(J+2,J+1,AIND), CS2, SN2,
     $                         A(J+2,J+2,AIND) )
                  A(J+2,J+1,AIND) = ZERO
                  CALL DROT( J-IFRSTM+2, A(IFRSTM,J+1,AIND), 1,
     $                       A(IFRSTM,J+2,AIND), 1, CS2, SN2 )
C
                  CALL DROT( ILASTM-J+1, A(J,J,AIND), LDA1,
     $                       A(J+1,J,AIND), LDA1, CS1, SN1 )
                  TEMP = A(J+1,J+1,AIND)
                  CALL DLARTG( TEMP, -A(J+1,J,AIND), CS1, SN1,
     $                         A(J+1,J+1,AIND) )
                  A(J+1,J,AIND) = ZERO
                  CALL DROT( J-IFRSTM+1, A(IFRSTM,J,AIND), 1,
     $                       A(IFRSTM,J+1,AIND), 1, CS1, SN1 )
C
               ELSE
C
                  CALL DROT( J+3-IFRSTM, A(IFRSTM,J+1,AIND), 1,
     $                       A(IFRSTM,J+2,AIND), 1, CS2, SN2 )
                  TEMP = A(J+1,J+1,AIND)
                  CALL DLARTG( TEMP, A(J+2,J+1,AIND), CS2, SN2,
     $                         A(J+1,J+1,AIND) )
                  A(J+2,J+1,AIND) = ZERO
                  CALL DROT( ILASTM-J-1, A(J+1,J+2,AIND), LDA1,
     $                       A(J+2,J+2,AIND), LDA1, CS2, SN2 )
C
                  CALL DROT( J+2-IFRSTM, A(IFRSTM,J,AIND), 1,
     $                       A(IFRSTM,J+1,AIND), 1, CS1, SN1 )
                  TEMP = A(J,J,AIND)
                  CALL DLARTG( TEMP, A(J+1,J,AIND), CS1, SN1,
     $                         A(J,J,AIND) )
                  A(J+1,J,AIND) = ZERO
                  CALL DROT( ILASTM-J, A(J,J+1,AIND), LDA1,
     $                       A(J+1,J+1,AIND), LDA1, CS1, SN1 )
               END IF
               IF ( LCMPQ ) THEN
                  QI = IWORK(MAPQ+MOD(L,K)+1)
               ELSE IF ( LPARQ ) THEN
                  QI = ABS( QIND(IWORK(MAPQ+MOD(L,K)+1)) )
               END IF
               IF ( QI.NE.0 ) THEN
                  CALL DROT( N, Q(1,J+1,QI), 1, Q(1,J+2,QI), 1, CS2,
     $                       SN2 )
                  CALL DROT( N, Q(1,J,QI), 1, Q(1,J+1,QI), 1, CS1, SN1 )
               END IF
  480       CONTINUE
C
            AIND = IWORK(MAPA+1)
            CALL DROT( ILASTM-IFIRST+1, A(J+1,IFIRST,AIND), LDA1,
     $                 A(J+2,IFIRST,AIND), LDA1, CS2, SN2 )
            CALL DROT( ILASTM-IFIRST+1, A(J,IFIRST,AIND), LDA1,
     $                 A(J+1,IFIRST,AIND), LDA1, CS1, SN1 )
         ELSE
            IN = IFIRST - 1
            IO = ILAST  - 3
         END IF
C
         DO 500  J1 = IN, IO
            AIND = IWORK(MAPA+1)
            IF ( LCMPQ ) THEN
               QI = IWORK(MAPQ+1)
            ELSE IF ( LPARQ ) THEN
               QI = ABS( QIND(IWORK(MAPQ+1)) )
            END IF
C
C           Create a bulge if J1 = IFIRST - 1, otherwise chase the
C           bulge.
C
            IF ( J1.LT.IFIRST ) THEN
               J = J1 + 1
               CALL DROT( ILASTM-J+1, A(J+1,J,AIND), LDA1,
     $                    A(J+2,J,AIND), LDA1, CS2, SN2 )
               CALL DROT( ILASTM-J+1, A(J,J,AIND), LDA1,
     $                    A(J+1,J,AIND), LDA1, CS1, SN1 )
            ELSE
               IF ( K.EQ.1 ) THEN
                  J = J + 1
               ELSE
                  J = J1
               END IF
               TEMP = A(J+1,J-1,AIND)
               CALL DLARTG( TEMP, A(J+2,J-1,AIND), CS2, SN2,
     $                      TEMP2 )
               TEMP = A(J,J-1,AIND)
               CALL DLARTG( TEMP, TEMP2, CS1, SN1, A(J,J-1,AIND) )
               A(J+1,J-1,AIND) = ZERO
               A(J+2,J-1,AIND) = ZERO
               CALL DROT( ILASTM-J+1, A(J+1,J,AIND), LDA1,
     $                    A(J+2,J,AIND), LDA1, CS2, SN2 )
               CALL DROT( ILASTM-J+1, A(J,J,AIND), LDA1,
     $                    A(J+1,J,AIND), LDA1, CS1, SN1 )
            END IF
            IF ( QI.NE.0 ) THEN
               CALL DROT( N, Q(1,J+1,QI), 1, Q(1,J+2,QI), 1, CS2, SN2 )
               CALL DROT( N, Q(1,J,  QI), 1, Q(1,J+1,QI), 1, CS1, SN1 )
            END IF
C
C           Propagate information from the right to A_1.
C
            DO 490  L = K, 2, -1
               AIND = IWORK(MAPA+L)
               IF ( S(AIND).EQ.SINV ) THEN
                  CALL DROT( J+3-IFRSTM, A(IFRSTM,J+1,AIND), 1,
     $                       A(IFRSTM,J+2,AIND), 1, CS2, SN2 )
                  TEMP = A(J+1,J+1,AIND)
                  CALL DLARTG( TEMP, A(J+2,J+1,AIND), CS2, SN2,
     $                         A(J+1,J+1,AIND) )
                  A(J+2,J+1,AIND) = ZERO
                  CALL DROT( ILASTM-J-1, A(J+1,J+2,AIND), LDA1,
     $                       A(J+2,J+2,AIND), LDA1, CS2, SN2 )
                  CALL DROT( J+2-IFRSTM, A(IFRSTM,J,AIND), 1,
     $                       A(IFRSTM,J+1,AIND), 1, CS1, SN1 )
                  TEMP = A(J,J,AIND)
                  CALL DLARTG( TEMP, A(J+1,J,AIND), CS1, SN1,
     $                         A(J,J,AIND) )
                  A(J+1,J,AIND) = ZERO
                  CALL DROT( ILASTM-J, A(J,J+1,AIND), LDA1,
     $                       A(J+1,J+1,AIND), LDA1, CS1, SN1 )
               ELSE
                  CALL DROT( ILASTM-J+1, A(J+1,J,AIND), LDA1,
     $                       A(J+2,J,AIND), LDA1, CS2, SN2 )
                  TEMP = A(J+2,J+2,AIND)
                  CALL DLARTG( TEMP, -A(J+2,J+1,AIND), CS2, SN2,
     $                         A(J+2,J+2,AIND) )
                  A(J+2,J+1,AIND) = ZERO
                  CALL DROT( J+2-IFRSTM, A(IFRSTM,J+1,AIND), 1,
     $                       A(IFRSTM,J+2,AIND), 1, CS2, SN2 )
                  CALL DROT( ILASTM-J+1, A(J,J,AIND), LDA1,
     $                       A(J+1,J,AIND), LDA1, CS1, SN1 )
                  TEMP = A(J+1,J+1,AIND)
                  CALL DLARTG( TEMP, -A(J+1,J,AIND), CS1, SN1,
     $                         A(J+1,J+1,AIND) )
                  A(J+1,J,AIND) = ZERO
                  CALL DROT( J+1-IFRSTM, A(IFRSTM,J,AIND), 1,
     $                       A(IFRSTM,J+1,AIND), 1, CS1, SN1 )
               END IF
               IF ( LCMPQ ) THEN
                  QI = IWORK(MAPQ+L)
               ELSE IF ( LPARQ ) THEN
                  QI = ABS( QIND(IWORK(MAPQ+L)) )
               END IF
               IF ( QI.NE.0 ) THEN
                  CALL DROT( N, Q(1,J+1,QI), 1, Q(1,J+2,QI), 1, CS2,
     $                       SN2 )
                  CALL DROT( N, Q(1,J,QI), 1, Q(1,J+1,QI), 1, CS1, SN1 )
               END IF
  490       CONTINUE
            AIND = IWORK(MAPA+1)
            LM = MIN( J+3, ILASTM ) - IFRSTM + 1
            CALL DROT( LM, A(IFRSTM,J+1,AIND), 1,
     $                 A(IFRSTM,J+2,AIND), 1, CS2, SN2 )
            CALL DROT( LM, A(IFRSTM,J,AIND), 1,
     $                 A(IFRSTM,J+1,AIND), 1, CS1, SN1 )
  500    CONTINUE
C
C        To avoid IF statements, there is an extra piece of code for
C        the last step.
C
         J = ILAST - 1
         TEMP = A(J,J-1,AIND)
         CALL DLARTG( TEMP, A(J+1,J-1,AIND), CS1, SN1, A(J,J-1,AIND) )
         A(J+1,J-1,AIND) = ZERO
C
  510    CONTINUE
C
         CALL DROT( ILASTM-J+1, A(J,J,AIND), LDA1,
     $              A(J+1,J,AIND), LDA1, CS1, SN1 )
         IF ( LCMPQ ) THEN
            QI = IWORK(MAPQ+1)
         ELSE IF ( LPARQ ) THEN
            QI = ABS( QIND(IWORK(MAPQ+1)) )
         END IF
         IF ( QI.NE.0 )
     $      CALL DROT( N, Q(1,J,QI), 1, Q(1,J+1,QI), 1, CS1, SN1 )
C
C        Propagate information from the right to A_1.
C
         DO 520  L = K, 2, -1
            AIND = IWORK(MAPA+L)
            IF ( S(AIND).EQ.SINV ) THEN
               CALL DROT( J+2-IFRSTM, A(IFRSTM,J,AIND), 1,
     $                    A(IFRSTM,J+1,AIND), 1, CS1, SN1 )
               TEMP = A(J,J,AIND)
               CALL DLARTG( TEMP, A(J+1,J,AIND), CS1, SN1,
     $                      A(J,J,AIND) )
               A(J+1,J,AIND) = ZERO
               CALL DROT( ILASTM-J, A(J,J+1,AIND), LDA1,
     $                    A(J+1,J+1,AIND), LDA1, CS1, SN1 )
            ELSE
               CALL DROT( ILASTM-J+1, A(J,J,AIND), LDA1,
     $                    A(J+1,J,AIND), LDA1, CS1, SN1 )
               TEMP = A(J+1,J+1,AIND)
               CALL DLARTG( TEMP, -A(J+1,J,AIND), CS1, SN1,
     $                      A(J+1,J+1,AIND) )
               A(J+1,J,AIND) = ZERO
               CALL DROT( J+1-IFRSTM, A(IFRSTM,J,AIND), 1,
     $                    A(IFRSTM,J+1,AIND), 1, CS1, SN1 )
            END IF
            IF ( LCMPQ ) THEN
               QI = IWORK(MAPQ+L)
            ELSE IF ( LPARQ ) THEN
               QI = ABS( QIND(IWORK(MAPQ+L)) )
            END IF
            IF ( QI.NE.0 )
     $         CALL DROT( N, Q(1,J,QI), 1, Q(1,J+1,QI), 1, CS1, SN1 )
  520    CONTINUE
         AIND = IWORK(MAPA+1)
         CALL DROT( ILASTM-IFRSTM+1, A(IFRSTM,J,AIND), 1,
     $              A(IFRSTM,J+1,AIND), 1, CS1, SN1 )
C
C        End of iteration loop.
C
  530    CONTINUE
  540 CONTINUE
C
C     Drop through = non-convergence.
C
      INFO = ILAST
      GO TO 580
C
C     Successful completion of all QZ steps.
C
  550 CONTINUE
C
C     Set eigenvalues 1:ILO-1.
C
      DO 560  J = 1, ILO - 1
         CALL MA01BD( BASE, LGBAS, K, S, A(J,J,1), LDA1*LDA2, ALPHAR(J),
     $                BETA(J), SCAL(J) )
         ALPHAI(J) = ZERO
  560 CONTINUE
C
C     Store information about the splitted 2-by-2 blocks and possible
C     loss of accuracy.
C
      DO 570  I = 2, N + 1
         IWORK(I) = IWORK(2*K+I-1)
  570 CONTINUE
C
  580 CONTINUE
C
      DO 590  L = K + 1, 2, -1
         DWORK(PNORM+L) = DWORK(PNORM+L-1)
  590 CONTINUE
C
      DWORK(1) = DBLE( OPTDW )
      IWORK(1) = OPTIW
C
      RETURN
C *** Last line of MB03BD ***
      END


      SUBROUTINE MB04YW( QRIT, UPDATU, UPDATV, M, N, L, K, SHIFT, D, E,
     $                   U, LDU, V, LDV, DWORK )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To perform either one QR or QL iteration step onto the unreduced
C     bidiagonal submatrix Jk:
C
C              |D(l) E(l)    0  ...    0   |
C              | 0   D(l+1) E(l+1)     .   |
C         Jk = | .                     .   |
C              | .                     .   |
C              | .                   E(k-1)|
C              | 0   ...        ...   D(k) |
C
C     with k <= p and l >= 1, p = MIN(M,N), of the bidiagonal matrix J:
C
C              |D(1) E(1)  0    ...   0   |
C              | 0   D(2) E(2)        .   |
C          J = | .                    .   |.
C              | .                    .   |
C              | .                  E(p-1)|
C              | 0   ...        ...  D(p) |
C
C     Hereby, Jk is transformed to  S' Jk T with S and T products of
C     Givens rotations. These Givens rotations S (respectively, T) are
C     postmultiplied into U (respectively, V), if UPDATU (respectively,
C     UPDATV) is .TRUE..
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     QRIT    LOGICAL
C             Indicates whether a QR or QL iteration step is to be
C             taken (from larger end diagonal element towards smaller),
C             as follows:
C             = .TRUE. :  QR iteration step (chase bulge from top to
C                         bottom);
C             = .FALSE.:  QL iteration step (chase bulge from bottom to
C                         top).
C
C     UPDATU  LOGICAL
C             Indicates whether the user wishes to accumulate in a
C             matrix U the left-hand Givens rotations S, as follows:
C             = .FALSE.:  Do not form U;
C             = .TRUE. :  The given matrix U is updated (postmultiplied)
C                         by the left-hand Givens rotations S.
C
C     UPDATV  LOGICAL
C             Indicates whether the user wishes to accumulate in a
C             matrix V the right-hand Givens rotations S, as follows:
C             = .FALSE.:  Do not form V;
C             = .TRUE. :  The given matrix V is updated (postmultiplied)
C                         by the right-hand Givens rotations T.
C
C     Input/Output Parameters
C
C     M       (input) INTEGER
C             The number of rows of the matrix U.  M >= 0.
C
C     N       (input) INTEGER
C             The number of rows of the matrix V.  N >= 0.
C
C     L       (input) INTEGER
C             The index of the first diagonal entry of the considered
C             unreduced bidiagonal submatrix Jk of J.
C
C     K       (input) INTEGER
C             The index of the last diagonal entry of the considered
C             unreduced bidiagonal submatrix Jk of J.
C
C     SHIFT   (input) DOUBLE PRECISION
C             Value of the shift used in the QR or QL iteration step.
C
C     D       (input/output) DOUBLE PRECISION array, dimension (p)
C             where p = MIN(M,N)
C             On entry, D must contain the diagonal entries of the
C             bidiagonal matrix J.
C             On exit, D contains the diagonal entries of the
C             transformed bidiagonal matrix S' J T.
C
C     E       (input/output) DOUBLE PRECISION array, dimension (p-1)
C             On entry, E must contain the superdiagonal entries of J.
C             On exit, E contains the superdiagonal entries of the
C             transformed matrix S' J T.
C
C     U       (input/output) DOUBLE PRECISION array, dimension (LDU,p)
C             On entry, if UPDATU = .TRUE., U must contain the M-by-p
C             left transformation matrix.
C             On exit, if UPDATU = .TRUE., the Givens rotations S on the
C             left have been postmultiplied into U, i.e., U * S is
C             returned.
C             U is not referenced if UPDATU = .FALSE..
C
C     LDU     INTEGER
C             The leading dimension of the array U.
C             LDU >= max(1,M) if UPDATU = .TRUE.;
C             LDU >= 1        if UPDATU = .FALSE..
C
C     V       (input/output) DOUBLE PRECISION array, dimension (LDV,p)
C             On entry, if UPDATV = .TRUE., V must contain the N-by-p
C             right transformation matrix.
C             On exit, if UPDATV = .TRUE., the Givens rotations T on the
C             right have been postmultiplied into V, i.e., V * T is
C             returned.
C             V is not referenced if UPDATV = .FALSE..
C
C     LDV     INTEGER
C             The leading dimension of the array V.
C             LDV >= max(1,N) if UPDATV = .TRUE.;
C             LDV >= 1        if UPDATV = .FALSE..
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (MAX(1,LDWORK))
C             LDWORK >= 4*MIN(M,N)-4, if UPDATU = UPDATV = .TRUE.;
C             LDWORK >= 2*MIN(M,N)-2, if
C                             UPDATU = .TRUE. and UPDATV = .FALSE. or
C                             UPDATV = .TRUE. and UPDATU = .FALSE.;
C             LDWORK >= 1, if UPDATU = UPDATV = .FALSE..
C
C     METHOD
C
C     QR iterations diagonalize the bidiagonal matrix by zeroing the
C     super-diagonal elements of Jk from bottom to top.
C     QL iterations diagonalize the bidiagonal matrix by zeroing the
C     super-diagonal elements of Jk from top to bottom.
C     The routine overwrites Jk with the bidiagonal matrix S' Jk T,
C     where S and T are products of Givens rotations.
C     T is essentially the orthogonal matrix that would be obtained by
C     applying one implicit symmetric shift QR (QL) step onto the matrix
C     Jk'Jk. This step factors the matrix (Jk'Jk - shift*I) into a
C     product of an orthogonal matrix T and a upper (lower) triangular
C     matrix. See [1,Sec.8.2-8.3] and [2] for more details.
C
C     REFERENCES
C
C     [1] Golub, G.H. and Van Loan, C.F.
C         Matrix Computations.
C         The Johns Hopkins University Press, Baltimore, Maryland, 1983.
C
C     [2] Bowdler, H., Martin, R.S. and Wilkinson, J.H.
C         The QR and QL algorithms for symmetric matrices.
C         Numer. Math., 11, pp. 293-306, 1968.
C
C     [3] Demmel, J. and Kahan, W.
C         Computing small singular values of bidiagonal matrices with
C         guaranteed high relative accuracy.
C         SIAM J. Sci. Statist. Comput., 11, pp. 873-912, 1990.
C
C     NUMERICAL ASPECTS
C
C     The algorithm is backward stable.
C
C     CONTRIBUTOR
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, June 1997.
C     Supersedes Release 2.0 routines MB04QY and MB04QZ by S. Van
C     Huffel, Katholieke University Leuven, Belgium.
C     This subroutine is based on the QR/QL step implemented in LAPACK
C     routine DBDSQR.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Bidiagonal matrix, orthogonal transformation, singular values.
C
C     ******************************************************************
C
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      LOGICAL           QRIT, UPDATU, UPDATV
      INTEGER           K, L, LDU, LDV, M, N
      DOUBLE PRECISION  SHIFT
C     ..
C     .. Array Arguments ..
      DOUBLE PRECISION  D( * ), DWORK( * ), E( * ), U( LDU, * ),
     $                  V( LDV, * )
C     ..
C     .. Local Scalars ..
      INTEGER           I, IROT, NCV, NM1, NM12, NM13
      DOUBLE PRECISION  COSL, COSR, CS, F, G, H, OLDCS, OLDSN, R, SINL,
     $                  SINR, SN
C     ..
C     .. External Subroutines ..
      EXTERNAL          DLARTG, DLASR
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC         ABS, MIN, SIGN
C     ..
C     .. Executable Statements ..
C
C     For speed, no tests of the input scalar arguments are done.
C
C     Quick return if possible.
C
      NCV = MIN( M, N )
      IF ( NCV.LE.1 .OR. L.EQ.K )
     $   RETURN
C
      NM1 = NCV - 1
      NM12 = NM1 + NM1
      NM13 = NM12 + NM1
      IF ( .NOT.UPDATV ) THEN
         NM12 = 0
         NM13 = NM1
      END IF
C
C     If SHIFT = 0, do simplified QR iteration.
C
      IF( SHIFT.EQ.ZERO ) THEN
         IF( QRIT ) THEN
C
C           Chase bulge from top to bottom.
C           Save cosines and sines for later U and/or V updates,
C           if needed.
C
            CS = ONE
            OLDCS = ONE
            CALL DLARTG( D( L )*CS, E( L ), CS, SN, R )
            CALL DLARTG( OLDCS*R, D( L+1 )*SN, OLDCS, OLDSN, D( L ) )
            IF ( UPDATV ) THEN
               DWORK( 1 ) = CS
               DWORK( 1+NM1 ) = SN
            END IF
            IF ( UPDATU ) THEN
               DWORK( 1+NM12 ) = OLDCS
               DWORK( 1+NM13 ) = OLDSN
            END IF
            IROT = 1
C
            DO 110 I = L + 1, K - 1
               CALL DLARTG( D( I )*CS, E( I ), CS, SN, R )
               E( I-1 ) = OLDSN*R
               CALL DLARTG( OLDCS*R, D( I+1 )*SN, OLDCS, OLDSN, D( I ) )
               IROT = IROT + 1
               IF ( UPDATV ) THEN
                  DWORK( IROT ) = CS
                  DWORK( IROT+NM1 ) = SN
               END IF
               IF ( UPDATU ) THEN
                  DWORK( IROT+NM12 ) = OLDCS
                  DWORK( IROT+NM13 ) = OLDSN
               END IF
  110       CONTINUE
C
            H = D( K )*CS
            D( K ) = H*OLDCS
            E( K-1 ) = H*OLDSN
C
C           Update U and/or V.
C
            IF( UPDATV )
     $         CALL DLASR( 'R', 'V', 'F', N, K-L+1, DWORK( 1 ),
     $                     DWORK( NCV ), V( 1, L ), LDV )
            IF( UPDATU )
     $         CALL DLASR( 'R', 'V', 'F', M, K-L+1, DWORK( NM12+1 ),
     $                     DWORK( NM13+1 ), U( 1, L ), LDU )
C
         ELSE
C
C           Chase bulge from bottom to top.
C           Save cosines and sines for later U and/or V updates,
C           if needed.
C
            CS = ONE
            OLDCS = ONE
            CALL DLARTG( D( K )*CS, E( K-1 ), CS, SN, R )
            CALL DLARTG( OLDCS*R, D( K-1 )*SN, OLDCS, OLDSN, D( K ) )
            IF ( UPDATV ) THEN
               DWORK( K-L ) = OLDCS
               DWORK( K-L+NM1 ) = -OLDSN
            END IF
            IF ( UPDATU ) THEN
               DWORK( K-L+NM12 ) = CS
               DWORK( K-L+NM13 ) = -SN
            END IF
            IROT = K - L
C
            DO 120 I = K - 1, L + 1, -1
               CALL DLARTG( D( I )*CS, E( I-1 ), CS, SN, R )
               E( I ) = OLDSN*R
               CALL DLARTG( OLDCS*R, D( I-1 )*SN, OLDCS, OLDSN, D( I ) )
               IROT = IROT - 1
               IF ( UPDATV ) THEN
                  DWORK( IROT ) = OLDCS
                  DWORK( IROT+NM1 ) = -OLDSN
               END IF
               IF ( UPDATU ) THEN
                  DWORK( IROT+NM12 ) = CS
                  DWORK( IROT+NM13 ) = -SN
               END IF
  120       CONTINUE
C
            H = D( L )*CS
            D( L ) = H*OLDCS
            E( L ) = H*OLDSN
C
C           Update U and/or V.
C
            IF( UPDATV )
     $         CALL DLASR( 'R', 'V', 'B', N, K-L+1, DWORK( 1 ),
     $                     DWORK( NCV ), V( 1, L ), LDV )
            IF( UPDATU )
     $         CALL DLASR( 'R', 'V', 'B', M, K-L+1, DWORK( NM12+1 ),
     $                     DWORK( NM13+1 ), U( 1, L ), LDU )
         END IF
      ELSE
C
C        Use nonzero shift.
C
         IF( QRIT ) THEN
C
C           Chase bulge from top to bottom.
C           Save cosines and sines for later U and/or V updates,
C           if needed.
C
            F = ( ABS( D( L ) ) - SHIFT )*
     $          ( SIGN( ONE, D( L ) ) + SHIFT / D( L ) )
            G = E( L )
            CALL DLARTG( F, G, COSR, SINR, R )
            F = COSR*D( L ) + SINR*E( L )
            E( L ) = COSR*E( L ) - SINR*D( L )
            G = SINR*D( L+1 )
            D( L+1 ) = COSR*D( L+1 )
            CALL DLARTG( F, G, COSL, SINL, R )
            D( L ) = R
            F = COSL*E( L ) + SINL*D( L+1 )
            D( L+1 ) = COSL*D( L+1 ) - SINL*E( L )
            G = SINL*E( L+1 )
            E( L+1 ) = COSL*E( L+1 )
            IF ( UPDATV ) THEN
               DWORK( 1 ) = COSR
               DWORK( 1+NM1 ) = SINR
            END IF
            IF ( UPDATU ) THEN
               DWORK( 1+NM12 ) = COSL
               DWORK( 1+NM13 ) = SINL
            END IF
            IROT = 1
C
            DO 130 I = L + 1, K - 2
               CALL DLARTG( F, G, COSR, SINR, R )
               E( I-1 ) = R
               F = COSR*D( I ) + SINR*E( I )
               E( I ) = COSR*E( I ) - SINR*D( I )
               G = SINR*D( I+1 )
               D( I+1 ) = COSR*D( I+1 )
               CALL DLARTG( F, G, COSL, SINL, R )
               D( I ) = R
               F = COSL*E( I ) + SINL*D( I+1 )
               D( I+1 ) = COSL*D( I+1 ) - SINL*E( I )
               G = SINL*E( I+1 )
               E( I+1 ) = COSL*E( I+1 )
               IROT = IROT + 1
               IF ( UPDATV ) THEN
                  DWORK( IROT ) = COSR
                  DWORK( IROT+NM1 ) = SINR
               END IF
               IF ( UPDATU ) THEN
                  DWORK( IROT+NM12 ) = COSL
                  DWORK( IROT+NM13 ) = SINL
               END IF
  130       CONTINUE
C
            IF ( L.LT.K-1 ) THEN
               CALL DLARTG( F, G, COSR, SINR, R )
               E( K-2 ) = R
               F = COSR*D( K-1 ) + SINR*E( K-1 )
               E( K-1 ) = COSR*E( K-1 ) - SINR*D( K-1 )
               G = SINR*D( K )
               D( K ) = COSR*D( K )
               CALL DLARTG( F, G, COSL, SINL, R )
               D( K-1 ) = R
               F = COSL*E( K-1 ) + SINL*D( K )
               D( K ) = COSL*D( K ) - SINL*E( K-1 )
               IROT = IROT + 1
               IF ( UPDATV ) THEN
                  DWORK( IROT ) = COSR
                  DWORK( IROT+NM1 ) = SINR
               END IF
               IF ( UPDATU ) THEN
                  DWORK( IROT+NM12 ) = COSL
                  DWORK( IROT+NM13 ) = SINL
               END IF
            END IF
            E( K-1 ) = F
C
C           Update U and/or V.
C
            IF( UPDATV )
     $         CALL DLASR( 'R', 'V', 'F', N, K-L+1, DWORK( 1 ),
     $                     DWORK( NCV ), V( 1, L ), LDV )
            IF( UPDATU )
     $         CALL DLASR( 'R', 'V', 'F', M, K-L+1, DWORK( NM12+1 ),
     $                     DWORK( NM13+1 ), U( 1, L ), LDU )
C
         ELSE
C
C           Chase bulge from bottom to top.
C           Save cosines and sines for later U and/or V updates,
C           if needed.
C
            F = ( ABS( D( K ) ) - SHIFT )*
     $          ( SIGN( ONE, D( K ) ) + SHIFT / D( K ) )
            G = E( K-1 )
            IF ( L.LT.K-1 ) THEN
               CALL DLARTG( F, G, COSR, SINR, R )
               F = COSR*D( K ) + SINR*E( K-1 )
               E( K-1 ) = COSR*E( K-1 ) - SINR*D( K )
               G = SINR*D( K-1 )
               D( K-1 ) = COSR*D( K-1 )
               CALL DLARTG( F, G, COSL, SINL, R )
               D( K ) = R
               F = COSL*E( K-1 ) + SINL*D( K-1 )
               D( K-1 ) = COSL*D( K-1 ) - SINL*E( K-1 )
               G = SINL*E( K-2 )
               E( K-2 ) = COSL*E( K-2 )
               IF ( UPDATV ) THEN
                  DWORK( K-L ) = COSL
                  DWORK( K-L+NM1 ) = -SINL
               END IF
               IF ( UPDATU ) THEN
                  DWORK( K-L+NM12 ) = COSR
                  DWORK( K-L+NM13 ) = -SINR
               END IF
               IROT = K - L
            ELSE
               IROT = K - L + 1
            END IF
C
            DO 140 I = K - 1, L + 2, -1
               CALL DLARTG( F, G, COSR, SINR, R )
               E( I ) = R
               F = COSR*D( I ) + SINR*E( I-1 )
               E( I-1 ) = COSR*E( I-1 ) - SINR*D( I )
               G = SINR*D( I-1 )
               D( I-1 ) = COSR*D( I-1 )
               CALL DLARTG( F, G, COSL, SINL, R )
               D( I ) = R
               F = COSL*E( I-1 ) + SINL*D( I-1 )
               D( I-1 ) = COSL*D( I-1 ) - SINL*E( I-1 )
               G = SINL*E( I-2 )
               E( I-2 ) = COSL*E( I-2 )
               IROT = IROT - 1
               IF ( UPDATV ) THEN
                  DWORK( IROT ) = COSL
                  DWORK( IROT+NM1 ) = -SINL
               END IF
               IF ( UPDATU ) THEN
                  DWORK( IROT+NM12 ) = COSR
                  DWORK( IROT+NM13 ) = -SINR
               END IF
  140       CONTINUE
C
            CALL DLARTG( F, G, COSR, SINR, R )
            E( L+1 ) = R
            F = COSR*D( L+1 ) + SINR*E( L )
            E( L ) = COSR*E( L ) - SINR*D( L+1 )
            G = SINR*D( L )
            D( L ) = COSR*D( L )
            CALL DLARTG( F, G, COSL, SINL, R )
            D( L+1 ) = R
            F = COSL*E( L ) + SINL*D( L )
            D( L ) = COSL*D( L ) - SINL*E( L )
            IROT = IROT - 1
            IF ( UPDATV ) THEN
               DWORK( IROT ) = COSL
               DWORK( IROT+NM1 ) = -SINL
            END IF
            IF ( UPDATU ) THEN
               DWORK( IROT+NM12 ) = COSR
               DWORK( IROT+NM13 ) = -SINR
            END IF
            E( L ) = F
C
C           Update U and/or V if desired.
C
            IF( UPDATV )
     $         CALL DLASR( 'R', 'V', 'B', N, K-L+1, DWORK( 1 ),
     $                     DWORK( NCV ), V( 1, L ), LDV )
            IF( UPDATU )
     $         CALL DLASR( 'R', 'V', 'B', M, K-L+1, DWORK( NM12+1 ),
     $                     DWORK( NM13+1 ), U( 1, L ), LDU )
         END IF
      END IF
C
      RETURN
C *** Last line of MB04YW ***
      END


!*******************************************************************
!                                                                  *
      SUBROUTINE GRACAH1(I,J,K,L,M,N,RAC)
!                                                                  *
!   SUBROUTINE TO CALCULATE RACAH COEFFICIENTS.                    *
!   THE ARGUMENTS I,J,K,L,M,N SHOULD BE TWICE THEIR ACTUAL VALUE.  *
!   WRITTEN BY N. S. SCOTT                                         *
!   Modified by C. Froese Fischer, March 11, 1988 to use table     *
!                                                         look-up  *
!   and                                                            *
!   G. Gaigalas, September 14, 1997                                *
!   Transform to fortran 90/95 by G. Gaigalas       December 2012  *
!   The last modification made by G. Gaigalas       October  2017  *
!                                                                  *
!*******************************************************************
!
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY: DOUBLE
      USE CONS_C,          ONLY: ZERO, ONE, TWO
      USE FACTS_C
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER , INTENT(IN) :: I
      INTEGER , INTENT(IN) :: J
      INTEGER , INTENT(IN) :: K
      INTEGER , INTENT(IN) :: L
      INTEGER , INTENT(IN) :: M
      INTEGER , INTENT(IN) :: N
      REAL(DOUBLE) , INTENT(OUT) :: RAC
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: J1,J2,J3,J4,J5,J6,J7,NUMIN,NUMAX,ICOUNT,KK,KI
!-----------------------------------------------
      J1 = I+J+M
      J2 = K+L+M
      J3 = I+K+N
      J4 = J+L+N
      IF (MOD(J1,2) == 0  .AND.  MOD(J2,2) == 0   .AND. &
          MOD(J3,2) == 0  .AND.  MOD(J4,2) == 0 )  THEN
          J1 = J1/2
          J2 = J2/2
          J3 = J3/2
          J4 = J4/2
          IF (MAX(I,J,M) <= J1 .AND.  MAX(K,L,M) <= J2  .AND. &
              MAX(I,K,N) <= J3 .AND.  MAX(J,L,N) <= J4  )  THEN
              J5 = (I+J+K+L)/2
              J6 = (I+L+M+N)/2
              J7 = (J+K+M+N)/2
              NUMIN = MAX(J1, J2, J3, J4) + 1
              NUMAX = MIN(J5, J6, J7)     + 1
              RAC = ONE
              ICOUNT = 0
              DO KK = NUMIN+1,NUMAX
                KI = NUMAX - ICOUNT
                RAC = ONE - (RAC*(KI*(J5-KI+2)*(J6-KI+2)*(J7-KI+2)))/ &
                         ((KI-1-J1)*(KI-1-J2)*(KI-1-J3)*(KI-1-J4))
                ICOUNT = ICOUNT+1
              END DO
              RAC = RAC*EXP(                                          &
                    (GAM(NUMIN+1) - GAM(NUMIN-J1) - GAM(NUMIN-J2) -   &
                     GAM(NUMIN-J3) - GAM(NUMIN-J4) - GAM(J5+2-NUMIN)- &
                     GAM(J6+2-NUMIN)-GAM(J7+2-NUMIN)) +               &
                    (GAM(J1+1-I)+GAM(J1+1-J)+GAM(J1+1-M)-GAM(J1+2) +  &
                     GAM(J2+1-K)+GAM(J2+1-L)+GAM(J2+1-M)-GAM(J2+2) +  &
                     GAM(J3+1-I)+GAM(J3+1-K)+GAM(J3+1-N)-GAM(J3+2) +  &
                     GAM(J4+1-J)+GAM(J4+1-L)+GAM(J4+1-N)-GAM(J4+2))/TWO)
              IF (MOD(J5+NUMIN,2) == 0) RAC = -RAC
          ELSE
             RAC = ZERO
          END IF
      ELSE
         RAC = ZERO
      END IF
      RETURN
      END


      subroutine compute_ddlx(ctfmp,n_alpha,n_metxx,octfmp,x,Nx,hx,myzer
     &o,phys_bdy,res)
      implicit none
      integer i
      integer Nx
      real*8 hx
      real*8 myzero
      real*8 ctfmp(Nx)
      real*8 n_alpha(Nx)
      real*8 n_metxx(Nx)
      real*8 octfmp(Nx)
      real*8 x(Nx)
      integer phys_bdy(2)
      real*8 res(Nx)
      real*8 qb
      if (phys_bdy(1) .eq. 1) then
      do i=1, 1, 1
      qb = myzero * x(i)
      res(i)=qb
      end do
      endif
      do i=2, Nx-1, 1
      qb = 0.5000000000000000D0 * (n_alpha(i - 1) - 0.1D1 * n_alpha(i +
     #1)) / hx / ctfmp(i) * octfmp(i) + (0.1250000000000000D0 / n_metxx(
     #i) * (n_alpha(i - 1) - 0.1D1 * n_alpha(i + 1)) * (-0.1D1 * n_metxx
     #(i - 1) + n_metxx(i + 1)) + n_alpha(i - 1) - 0.2D1 * n_alpha(i) +
     #n_alpha(i + 1)) / ctfmp(i) ** 2 / hx ** 2
      res(i)=qb
      end do
      if (phys_bdy(2) .eq. 1) then
      do i=Nx, Nx, 1
      qb = myzero * x(i)
      res(i)=qb
      end do
      endif
      END


! **********************************************************************
module Constants
use Types
real(DPT),parameter ::  ZERO = 0.0_DPT
real(DPT),parameter ::  HALF = 0.5_DPT
real(DPT),parameter ::   ONE = 1.0_DPT
real(DPT),parameter ::   TWO = 2.0_DPT
real(DPT),parameter :: THREE = 3.0_DPT
real(DPT),parameter ::  FOUR = 4.0_DPT
complex(DPT),parameter :: ZEROC = (ZERO,ZERO)
complex(DPT),parameter ::  ONEC = (ONE,ZERO)
complex(DPT),parameter ::    IU = (ZERO,ONE)
real(DPT),parameter :: PI    = 3.141592653589793238462643383279502884197_DPT
real(DPT),parameter :: PISQRT  = 1.7724538509055160272981674833411_DPT
real(DPT),parameter :: TWOPI = TWO*PI
real(DPT),parameter :: R2D = 180.0_DPT/PI
real(DPT),parameter :: VC = 2.99792458e10_DPT
real(DPT),parameter :: VCO8PI = VC/8.0_DPT/PI
real(DPT),parameter :: amr = 1836.1_DPT
real(DPT),parameter :: CGS_Pscale=1.0e13_DPT       ! 1 MW power in CGS (erg/sec)
real(DPT),parameter :: CGS_Escale=10.0_DPT/3.0_DPT ! 1 kV/cm in CGS system
real(DPT),parameter :: CGS_Hscale=PI/2.5_DPT       ! 1 A/cm in CGS system

real(DPT),parameter::EPS_length=1.0e-8_DPT ! used in detecting identical WG vectors
end module Constants


       MODULE MOD_INTPL
       contains
       SUBROUTINE INTPL(Y,X,X1,X2,Y1,Y2)
C**************************************
C     CALLED BY INPLCS, CSTABREAD
C     WRITTEN BY MARGIT HABERREITER
C     FOR LINEAR INTERPOLATION
C     INPUT: X1,X2,Y1,Y2,X
C     OUTPUT: Y
C     SLOPE: SLP
C**************************************
!	IMPLICIT REAL*8(a-h,o-z)
	IMPLICIT NONE
	REAL*8,intent(in)::X1,X2,Y1,Y2,X
	REAL*8,intent(out)::Y
	real*8::SLP
	Y=0.
	SLP=(Y2-Y1)/(X2-X1)
	Y=Y1+(SLP*(X-X1))

	END SUBROUTINE
        END MODULE