C
C SPDX-License-Identifier: BSD-3-Clause
C
      SUBROUTINE MB03BE( K, AMAP, S, SINV, A, LDA1, LDA2 )
C
C     PURPOSE
C
C     To apply at most 20 iterations of a real single shifted
C     periodic QZ algorithm to the 2-by-2 product of matrices stored
C     in the array A.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     K       (input)  INTEGER
C             The number of factors.  K >= 1.
C
C     AMAP    (input)  INTEGER array, dimension (K)
C             The map for accessing the factors, i.e., if AMAP(I) = J,
C             then the factor A_I is stored at the J-th position in A.
C
C     S       (input)  INTEGER array, dimension (K)
C             The signature array. Each entry of S must be 1 or -1.
C
C     SINV    (input)  INTEGER
C             Signature multiplier. Entries of S are virtually
C             multiplied by SINV.
C
C     A       (input/output)  DOUBLE PRECISION array, dimension
C                             (LDA1,LDA2,K)
C             On entry, the leading 2-by-2-by-K part of this array must
C             contain a 2-by-2 product (implicitly represented by its K
C             factors) in upper Hessenberg form.
C             On exit, the leading 2-by-2-by-K part of this array
C             contains the product after at most 20 iterations of a real
C             shifted periodic QZ algorithm.
C
C     LDA1    INTEGER
C             The first leading dimension of the array A.  LDA1 >= 2.
C
C     LDA2    INTEGER
C             The second leading dimension of the array A.  LDA2 >= 2.
C
C     METHOD
C
C     Ten iterations of a real single shifted periodic QZ algorithm are
C     applied to the 2-by-2 matrix product A.
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 PLARL2.
C     V. Sima, June 2012.
C
C     KEYWORDS
C
C     Eigenvalues, QZ algorithm, periodic QZ algorithm, orthogonal
C     transformation.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO
      PARAMETER         ( ZERO = 0.0D0 )
C     .. Scalar Arguments ..
      INTEGER           K, LDA1, LDA2, SINV
C     .. Array Arguments ..
      INTEGER           AMAP(*), S(*)
      DOUBLE PRECISION  A(LDA1,LDA2,*)
C     .. Local Scalars ..
      INTEGER           I, L, AI
      DOUBLE PRECISION  CS, SN, CT, ST, TEMP, ULP
C     .. External Functions ..
      DOUBLE PRECISION  DLAMCH
      EXTERNAL          DLAMCH
C     .. External Subroutines ..
      EXTERNAL          DLARTG, DROT, MB03AD
C     .. Intrinsic Functions ..
      INTRINSIC         ABS, MAX
C
C     .. Executable Statements ..
C
      DO 20  I = 1, 20
         CALL MB03AD( 'Single', K, 2, AMAP, S, SINV, A, LDA1, LDA2,
     $                CS, SN, CT, ST )
         AI = AMAP(1)
         CALL DROT( 2, A(1,1,AI), LDA1, A(2,1,AI), LDA1, CS, SN )
C
         DO 10  L = K, 2, -1
            AI = AMAP(L)
            IF ( S(AI).EQ.SINV ) THEN
               CALL DROT( 2, A(1,1,AI), 1, A(1,2,AI), 1, CS, SN )
               TEMP = A(1,1,AI)
               CALL DLARTG( TEMP, A(2,1,AI), CS, SN, A(1,1,AI) )
               A(2,1,AI) = ZERO
               TEMP      = CS*A(1,2,AI) + SN*A(2,2,AI)
               A(2,2,AI) = CS*A(2,2,AI) - SN*A(1,2,AI)
               A(1,2,AI) = TEMP
            ELSE
               CALL DROT( 2, A(1,1,AI), LDA1, A(2,1,AI), LDA1, CS, SN )
               TEMP = A(2,2,AI)
               CALL DLARTG( TEMP, A(2,1,AI), CS, SN, A(2,2,AI) )
               A(2,1,AI) = ZERO
               SN = -SN
               TEMP      = CS*A(1,1,AI) + SN*A(1,2,AI)
               A(1,2,AI) = CS*A(1,2,AI) - SN*A(1,1,AI)
               A(1,1,AI) = TEMP
            END IF
   10    CONTINUE
C
         AI = AMAP(1)
         CALL DROT( 2, A(1,1,AI), 1, A(1,2,AI), 1, CS, SN )
C
         IF ( I.EQ.6 ) THEN
            ULP = DLAMCH( 'Precision' )
            IF ( ABS( A(2,1,AI) ).LT.ULP*( MAX( ABS( A(1,1,AI) ),
     $                                          ABS( A(1,2,AI) ),
     $                                          ABS( A(2,2,AI) ) ) ) )
     $         GO TO 30
         ELSE IF ( I.GT.10 ) THEN
            IF ( ABS( A(2,1,AI) ).LT.ULP*( MAX( ABS( A(1,1,AI) ),
     $                                          ABS( A(1,2,AI) ),
     $                                          ABS( A(2,2,AI) ) ) ) )
     $         GO TO 30
         END IF
   20 CONTINUE
C
   30 CONTINUE
C
      RETURN
C *** Last line of MB03BE ***
      END
