      SUBROUTINE MB03KB( COMPQ, WHICHQ, WS, K, NC, KSCHUR, J1, N1, N2,
     $                   N, NI, S, T, LDT, IXT, Q, LDQ, IXQ, TOL, IWORK,
     $                   DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To reorder the diagonal blocks of the formal matrix product
C
C        T22_K^S(K) * T22_K-1^S(K-1) * ... * T22_1^S(1)              (1)
C
C     of length K in the generalized periodic Schur form
C
C              [  T11_k  T12_k  T13_k  ]
C        T_k = [    0    T22_k  T23_k  ],    k = 1, ..., K,          (2)
C              [    0      0    T33_k  ]
C
C     where
C
C     - the submatrices T11_k are NI(k+1)-by-NI(k), if S(k) = 1, or
C       NI(k)-by-NI(k+1), if S(k) = -1, and contain dimension-induced
C       infinite eigenvalues,
C     - the submatrices T22_k are NC-by-NC and contain core eigenvalues,
C       which are generically neither zero nor infinite,
C     - the submatrices T33_k contain dimension-induced zero
C       eigenvalues,
C
C     such that pairs of adjacent diagonal blocks of sizes 1 and/or 2 in
C     the product (1) are swapped.
C
C     Optionally, the transformation matrices Q_1,...,Q_K from the
C     reduction into generalized periodic Schur form are updated with
C     respect to the performed reordering.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     COMPQ   CHARACTER*1
C             = 'N': do not compute any of the matrices Q_k;
C             = 'U': each coefficient of Q must contain an orthogonal
C                    matrix Q1_k on entry, and the products Q1_k*Q_k are
C                    returned, where Q_k, k = 1, ..., K, performed the
C                    reordering;
C             = 'W': the computation of each Q_k is specified
C                    individually in the array WHICHQ.
C
C     WHICHQ  INTEGER array, dimension (K)
C             If COMPQ = 'W', WHICHQ(k) specifies the computation of Q_k
C             as follows:
C             = 0:   do not compute Q_k;
C             > 0:   the kth coefficient of Q must contain an orthogonal
C                    matrix Q1_k on entry, and the product Q1_k*Q_k is
C                    returned.
C             This array is not referenced if COMPQ <> 'W'.
C
C     WS      LOGICAL
C             = .FALSE. : do not perform the strong stability tests;
C             = .TRUE.  : perform the strong stability tests; often,
C                         this is not needed, and omitting them can save
C                         some computations.
C
C     Input/Output Parameters
C
C     K       (input) INTEGER
C             The period of the periodic matrix sequences T and Q (the
C             number of factors in the matrix product).  K >= 2.
C             (For K = 1, a standard eigenvalue reordering problem is
C             obtained.)
C
C     NC      (input) INTEGER
C             The number of core eigenvalues.  0 <= NC <= min(N).
C
C     KSCHUR  (input) INTEGER
C             The index for which the matrix T22_kschur is upper quasi-
C             triangular.
C
C     J1      (input) INTEGER
C             The index of the first row and column of the first block
C             to swap in T22_k.
C             1 <= J1 <= NC-N1-N2+1.
C
C     N1      (input) INTEGER
C             The order of the first block to swap.   N1 = 0, 1 or 2.
C
C     N2      (input) INTEGER
C             The order of the second block to swap.  N2 = 0, 1 or 2.
C
C     N       (input) INTEGER array, dimension (K)
C             The leading K elements of this array must contain the
C             dimensions of the factors of the formal matrix product T,
C             such that the k-th coefficient T_k is an N(k+1)-by-N(k)
C             matrix, if S(k) = 1, or an N(k)-by-N(k+1) matrix,
C             if S(k) = -1, k = 1, ..., K, where N(K+1) = N(1).
C
C     NI      (input) INTEGER array, dimension (K)
C             The leading K elements of this array must contain the
C             dimensions of the factors of the matrix sequence T11_k.
C             N(k) >= NI(k) + NC >= 0.
C
C     S       (input) INTEGER array, dimension (K)
C             The leading K elements of this array must contain the
C             signatures (exponents) of the factors in the K-periodic
C             matrix sequence. Each entry in S must be either 1 or -1;
C             the value S(k) = -1 corresponds to using the inverse of
C             the factor T_k.
C
C     T       (input/output) DOUBLE PRECISION array, dimension (*)
C             On entry, this array must contain at position IXT(k) the
C             matrix T_k, which is at least N(k+1)-by-N(k), if S(k) = 1,
C             or at least N(k)-by-N(k+1), if S(k) = -1, in periodic
C             Schur form.
C             On exit, the matrices T_k are overwritten by the reordered
C             periodic Schur form.
C
C     LDT     INTEGER array, dimension (K)
C             The leading dimensions of the matrices T_k in the one-
C             dimensional array T.
C             LDT(k) >= max(1,N(k+1)),  if S(k) =  1,
C             LDT(k) >= max(1,N(k)),    if S(k) = -1.
C
C     IXT     INTEGER array, dimension (K)
C             Start indices of the matrices T_k in the one-dimensional
C             array T.
C
C     Q       (input/output) DOUBLE PRECISION array, dimension (*)
C             On entry, this array must contain at position IXQ(k) a
C             matrix Q_k of size at least N(k)-by-N(k), provided that
C             COMPQ = 'U', or COMPQ = 'W' and WHICHQ(k) > 0.
C             On exit, if COMPQ = 'U', or COMPQ = 'W' and WHICHQ(k) > 0,
C             Q_k is post-multiplied with the orthogonal matrix that
C             performed the reordering.
C             This array is not referenced if COMPQ = 'N'.
C
C     LDQ     INTEGER array, dimension (K)
C             The leading dimensions of the matrices Q_k in the one-
C             dimensional array Q.  LDQ(k) >= 1, and
C             LDQ(k) >= max(1,N(k)), if COMPQ = 'U', or COMPQ = 'W' and
C                                                       WHICHQ(k) > 0;
C             This array is not referenced if COMPQ = 'N'.
C
C     IXQ     INTEGER array, dimension (K)
C             Start indices of the matrices Q_k in the one-dimensional
C             array Q.
C             This array is not referenced if COMPQ = 'N'.
C
C     Tolerances
C
C     TOL     DOUBLE PRECISION array, dimension (3)
C             This array contains tolerance parameters. The weak and
C             strong stability tests use a threshold computed by the
C             formula  MAX( c*EPS*NRM, SMLNUM ),  where c is a constant,
C             NRM is the Frobenius norm of the matrix formed by
C             concatenating K pairs of adjacent diagonal blocks of sizes
C             1 and/or 2 in the T22_k submatrices from (2), which are
C             swapped, and EPS and SMLNUM are the machine precision and
C             safe minimum divided by EPS, respectively (see LAPACK
C             Library routine DLAMCH). The norm NRM is computed by this
C             routine; the other values are stored in the array TOL.
C             TOL(1), TOL(2), and TOL(3) contain c, EPS, and SMLNUM,
C             respectively. TOL(1) should normally be at least 10.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (4*K)
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) returns the optimal LDWORK.
C
C     LDWORK  INTEGER
C             The dimension of the array DWORK.
C             LDWORK >= 10*K + MN,                 if N1 = 1, N2 = 1;
C             LDWORK >= 25*K + MN,                 if N1 = 1, N2 = 2;
C             LDWORK >= MAX(23*K + MN, 25*K - 12), if N1 = 2, N2 = 1;
C             LDWORK >= MAX(42*K + MN, 80*K - 48), if N1 = 2, N2 = 2;
C             where MN = MXN, if MXN > 10, and MN = 0, otherwise, with
C             MXN = MAX(N(k),k=1,...,K).
C
C             If LDWORK = -1  a workspace query is assumed; the
C             routine only calculates the optimal size of the DWORK
C             array, returns this value as the first entry of the DWORK
C             array, and no error message is issued by XERBLA.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -22, then LDWORK is too small; appropriate
C                   value for LDWORK is returned in DWORK(1); the other
C                   arguments are not tested, for efficiency;
C             = 1:  the swap was rejected from stability reasons; the
C                   blocks are not swapped and T and Q are unchanged.
C
C     METHOD
C
C     The algorithm described in [1] is used. Both weak and strong
C     stability tests are performed.
C
C     REFERENCES
C
C     [1] Granat, R., Kagstrom, B. and Kressner, D.
C         Computing periodic deflating subspaces associated with a
C         specified set of eigenvalues.
C         BIT Numerical Mathematics, vol. 47, 763-791, 2007.
C
C     NUMERICAL ASPECTS
C
C     The implemented method is numerically backward stable.
C                                  3
C     The algorithm requires 0(K NC ) floating point operations.
C
C     CONTRIBUTOR
C
C     V. Sima, Research Institute for Informatics, Bucharest, Romania,
C     Mar. 2010, an essentially new version of the PEP routine
C     PEP_DLAEXC, by R. Granat, Umea University, Sweden, Apr. 2008.
C
C     REVISIONS
C
C     V. Sima, Apr. 2010, May 2010, July 2010, Aug. 2011.
C
C     KEYWORDS
C
C     Eigenvalues, QZ algorithm, periodic QZ algorithm, orthogonal
C     transformation.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
C     ..
C     .. Scalar Arguments ..
      CHARACTER          COMPQ
      LOGICAL            WS
      INTEGER            INFO, J1, K, KSCHUR, LDWORK, N1, N2, NC
C     ..
C     .. Array Arguments ..
      INTEGER            IWORK( * ), IXQ( * ), IXT( * ), LDQ( * ),
     $                   LDT( * ), N( * ), NI( * ), S( * ), WHICHQ( * )
      DOUBLE PRECISION   DWORK( * ), Q( * ), T( * ), TOL( * )
C     ..
C     .. Local Scalars ..
      LOGICAL            FILL21, FILL43, FILLIN, SPECQ, WANTQ, WANTQL
      INTEGER            A, B, C, I, I11, I12, I21, I22, IA, IB, IC,
     $                   II, INDF1, INDF2, INDTAU, INDTT, INDV1, INDV2,
     $                   INDVF, INDVP1, INDXC, INDXV, IP1, IPP, IQ, IS,
     $                   IT, IT2, ITAU1, ITAU2, ITAUF, ITAUF1, ITAUF2,
     $                   ITAUP1, IV1P1, IV2P1, J2, J3, J4, L, LDWKE,
     $                   LTAU, LTAU1, LTAU2, LTT, MINWRK, MN, ND, ND2,
     $                   TAU, TAU1, TAU1P1, TAU2, TAU2P1, TT, V, V1, V2,
     $                   VLOC, VLOC1, VLOC2, W, WE
      DOUBLE PRECISION   DNRM, DTAU1, DTAU2, EPS, SCALOC, SMLNUM,
     $                   STRONG, TAULOC, THRESH, TMP, TMP1, TMP2, V_1,
     $                   V_2, V_3, W_2, W_3, X_11, X_12, X_21, X_22
C     ..
C     .. Local Arrays ..
      DOUBLE PRECISION   TAUS( 2 ), TEMP( 16 ), TEMPM1( 16 )
C     ..
C     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLANGE, DLANTR, DLAPY2
      EXTERNAL           DLANGE, DLANTR, DLAPY2, LSAME
C     ..
C     .. External Subroutines ..
      EXTERNAL           DAXPY, DLACPY, DLARFG, DLARFX, DLASCL, MB03KC,
     $                   MB03KE, XERBLA
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC          ABS, DBLE, INT, MAX, MOD
C     ..
C     .. Executable Statements ..
C
C     For efficiency reasons, the parameters are not checked.
C
C     Set the machine-dependent parameters.
C
      EPS    = TOL( 2 )
      SMLNUM = TOL( 3 )
C
      IF( LDWORK.EQ.-1 ) THEN
C
C        Compute the workspace size.
C
         MN = 0
C
         DO 5 I = 1, K
            MN = MAX( MN, N( I ) )
    5    CONTINUE
C
         IF( MN.LE.10 )
     $       MN = 0
C
         IF( N1.EQ.1 .AND. N2.EQ.1 ) THEN
            WE = K * 3
            MN = K * 10 + MN
         ELSE IF( N1.EQ.1 .AND. N2.EQ.2 ) THEN
            WE = K * 7
            MN = K * 25 + MN
         ELSE IF( N1.EQ.2 .AND. N2.EQ.1 ) THEN
            WE = K * 7
            MN = K * 23 + MN
         ELSE IF( N1.EQ.2 .AND. N2.EQ.2 ) THEN
            WE = K * 12
            MN = K * 42 + MN
         END IF
C
         CALL MB03KE( .FALSE., .FALSE., -1, K, N1, N2, EPS, SMLNUM, S,
     $                T, T, T, SCALOC, DWORK, -1, INFO )
         DWORK( 1 ) = MAX( INT( DWORK( 1 ) ) + WE, MN )
         RETURN
      END IF
C
C     Set integer pointers to correct subsequences in T22_k and check
C     workspace. For simplicity, below these subsequences are denoted
C     by T11, T22 and T12 and are not to be confused with the T11_k,
C     T22_k and T12_k in (2). Also set integer pointers to be used in
C     Sylvester solver.
C
      J2  = J1  + N1
      I11 = 0
      I21 = I11 + K
      I12 = I21 + K
      I22 = I12 + K
      MN  = 0
C
      DO 10 I = 1, K
         MN  = MAX( MN, N( I ) )
         IP1 = MOD( I, K ) + 1
         IF( S( I ).EQ.1 ) THEN
            II = IXT( I ) + NI( I )*LDT( I ) + NI( IP1 ) - 1
         ELSE
            II = IXT( I ) + NI( IP1 )*LDT( I ) + NI( I ) - 1
         END IF
         IWORK( I11+I ) = II + ( J1 - 1 )*LDT( I ) + J1
         IWORK( I21+I ) = IWORK( I11+I ) + N1
         IWORK( I12+I ) = IWORK( I11+I ) + N1*LDT( I )
         IWORK( I22+I ) = IWORK( I12+I ) + N1
   10 CONTINUE
C
      IF( MN.LE.10 )
     $    MN = 0
C
C     Divide workspace into different arrays and submatrices.
C
      A = 1
      IF( N1.EQ.1 .AND. N2.EQ.1 ) THEN
         B     = A     + K
         C     = B     + K
         TAU   = C     + K
         V     = TAU   + K
         TT    = V     + K * 2
         W     = TT    + K * 4
         WE    = TAU
         MN    = MN    + K * 10
         LDWKE =         K * 5 - 4
      ELSE IF( N1.EQ.1 .AND. N2.EQ.2 ) THEN
         B     = A     + K
         C     = B     + K * 4
         TAU1  = C     + K * 2
         V1    = TAU1  + K
         TAU2  = V1    + K * 2
         V2    = TAU2  + K
         TT    = V2    + K * 2
         LTAU  = TT    + K * 9
         VLOC  = LTAU  + K
         W     = VLOC  + K * 2
         WE    = TAU1
         MN    = MN    + K * 25
         LDWKE =         K * 18 - 13
      ELSE IF( N1.EQ.2 .AND. N2.EQ.1 ) THEN
         B     = A     + K * 4
         C     = B     + K
         TAU   = C     + K * 2
         V     = TAU   + K
         TT    = V     + K * 3
         LTAU  = TT    + K * 9
         VLOC  = LTAU  + K
         W     = VLOC  + K * 2
         WE    = TAU
         MN    = MN    + K * 23
         LDWKE =         K * 18 - 13
      ELSE IF( N1.EQ.2 .AND. N2.EQ.2 ) THEN
         B     = A     + K * 4
         C     = B     + K * 4
         TAU1  = C     + K * 4
         V1    = TAU1  + K
         TAU2  = V1    + K * 3
         V2    = TAU2  + K
         TT    = V2    + K * 3
         LTAU1 = TT    + K * 16
         VLOC1 = LTAU1 + K
         LTAU2 = VLOC1 + K * 2
         VLOC2 = LTAU2 + K
         W     = VLOC2 + K * 2
         WE    = TAU1
         MN    = MN    + K * 42
         LDWKE =         K * 68 - 49
      END IF
C
      MINWRK = MAX( LDWKE + WE, MN )
C
C     Quick return if possible.
C
      IF( LDWORK.LT.MINWRK ) THEN
         DWORK( 1 ) = DBLE( MINWRK )
         INFO = -22
         CALL XERBLA( 'MB03KB', -INFO )
         RETURN
      ELSE IF( NC.LE.1 .OR. N1.LE.0 .OR. N2.LE.0 .OR. N1.GT.NC .OR.
     $         J2.GT.NC .OR. J2 + N2 - 1.GT.NC ) THEN
         RETURN
      END IF
C
C     Decode the input parameters
C
      INFO  = 0
      WANTQ = LSAME( COMPQ, 'U' )
      SPECQ = LSAME( COMPQ, 'W' )
C
C     Compute some local indices.
C
      J2 = J1 + 1
      J3 = J1 + 2
      J4 = J1 + 3
C
C     Solve the periodic Sylvester-like equation associated with
C     the swap.
C
C     Copy T11, T22 and T12 to workspace. Apply scaling to all of T22_k
C     for numerical stability.
C
      IA  = A
      IB  = B
      IC  = C
      ND  = N1 + N2
      ND2 = ND**2
C
      DNRM = ZERO
C
      DO 20 I = 1, K
         IT  = IWORK( I11+I )
         IS  = IWORK( I12+I )
         IQ  = IWORK( I22+I )
         TMP = DLANTR( 'Frobenius', 'Upper', 'NonUnit', ND, ND, T( IT ),
     $                 LDT( I ), DWORK )
         IF( I.EQ.KSCHUR ) THEN
            IF( N1.EQ.2 )
     $         TMP = DLAPY2( T( IT+1 ), TMP )
            IF( N2.EQ.2 )
     $         TMP = DLAPY2( T( IQ+1 ), TMP )
         END IF
         DNRM = DLAPY2( DNRM, TMP )
         TMP  = MAX( TMP, SMLNUM )
         IF( N1.EQ.1 ) THEN
            DWORK( IA ) = T( IT ) / TMP
            DWORK( IC ) = T( IS ) / TMP
            IF( N2.EQ.1 ) THEN
               DWORK( IB ) = T( IQ ) / TMP
            ELSE
               CALL DLACPY( 'All', N2, N2, T( IQ ), LDT( I ),
     $                      DWORK( IB ), N2 )
               CALL DLASCL( 'General', 0, 0, TMP, ONE, N2, N2,
     $                      DWORK( IB ), N2, INFO )
               DWORK( IC+1 ) = T( IS+LDT(I) ) / TMP
            END IF
         ELSE
            CALL DLACPY( 'All', N1, N1, T( IT ), LDT( I ), DWORK( IA ),
     $                   N1 )
            CALL DLASCL( 'General', 0, 0, TMP, ONE, N1, N1, DWORK( IA ),
     $                   N1, INFO )
            IF( N2.EQ.1 ) THEN
               DWORK( IB   ) = T( IQ   ) / TMP
               DWORK( IC   ) = T( IS   ) / TMP
               DWORK( IC+1 ) = T( IS+1 ) / TMP
            ELSE
               CALL DLACPY( 'All', N2, N2, T( IQ ), LDT( I ),
     $                      DWORK( IB ), N2 )
               CALL DLASCL( 'General', 0, 0, TMP, ONE, N2, N2,
     $                      DWORK( IB ), N2, INFO )
               CALL DLACPY( 'All', N1, N2, T( IS ), LDT( I ),
     $                      DWORK( IC ), N1 )
               CALL DLASCL( 'General', 0, 0, TMP, ONE, N1, N2,
     $                      DWORK( IC ), N1, INFO )
            END IF
         END IF
         IA = IA + N1**2
         IB = IB + N2**2
         IC = IC + N1*N2
   20 CONTINUE
C
C     Compute a machine-dependent threshold of the test for accepting
C     a swap.
C
      THRESH = MAX( TOL( 1 )*EPS*DNRM, SMLNUM )
C
C     Call the periodic Sylvester-like equation solver.
C     Workspace: need   WE - 1 + (4*K-3)*(N1*N2)**2 + K*N1*N2.
C
      CALL MB03KE( .FALSE., .FALSE., -1, K, N1, N2, EPS, SMLNUM, S,
     $             DWORK( A ), DWORK( B ), DWORK( C ), SCALOC,
     $             DWORK( WE ), LDWORK-WE+1, INFO )
C
C     Swap the adjacent diagonal blocks.
C
      L = N1 + N1 + N2 - 2
      GO TO ( 30, 70, 140, 210 ) L
C
   30 CONTINUE
C
C     Direct swap with N1 = 1 and N2 = 1.
C
C     Generate elementary reflectors H_i such that:
C
C     H_i( X_11_i ) = ( * ).
C        ( scale  )   ( 0 )
C
      INDXC = C
      INDXV = V
C
      DO 40 INDTAU = TAU, TAU + K - 1
         X_11 = DWORK( INDXC )
         DWORK( INDXV   ) = X_11
         DWORK( INDXV+1 ) = SCALOC
         CALL DLARFG( 2, DWORK( INDXV ), DWORK( INDXV+1 ), 1,
     $                DWORK( INDTAU ) )
         DWORK( INDXV ) = ONE
C
C        Next, do weak stability test.
C
         TAULOC = DWORK( INDTAU )
         TMP    = SCALOC * ( ONE - TAULOC ) +
     $            TAULOC * DWORK( INDXV+1 ) * X_11
         IF( ABS( TMP ).GT.THRESH )
     $      GO TO 300
         INDXC = INDXC + 1
         INDXV = INDXV + 2
   40 CONTINUE
C
      IF( WS ) THEN
C
C        The swap passed weak stability test - move on and perform the
C        swapping temporarily into TT (workspace) and perform strong
C        stability test.
C
         INDTAU = TAU
         INDXV  = V
         INDTT  = TT
C
         DO 50 I  = 1, K
            IP1    = MOD( I, K )
            INDVP1 = V   + IP1 * 2
            ITAUP1 = TAU + IP1
            CALL DLACPY( 'All', 2, 2, T( IWORK( I11+I ) ), LDT( I ),
     $                   TEMP, 2 )
            CALL DLACPY( 'All', 2, 2, TEMP, 2, DWORK( INDTT ), 2 )
            IF( S( I ).EQ.1 ) THEN
               CALL DLARFX( 'Left', 2, 2, DWORK( INDVP1 ),
     $                      DWORK( ITAUP1 ), DWORK( INDTT ), 2,
     $                      DWORK( W ) )
               CALL DLARFX( 'Right', 2, 2, DWORK( INDXV ),
     $                      DWORK( INDTAU ), DWORK( INDTT ), 2,
     $                      DWORK( W ) )
            ELSE
               CALL DLARFX( 'Right', 2, 2, DWORK( INDVP1 ),
     $                      DWORK( ITAUP1 ), DWORK( INDTT ), 2,
     $                      DWORK( W ) )
               CALL DLARFX( 'Left', 2, 2, DWORK( INDXV ),
     $                      DWORK( INDTAU ), DWORK( INDTT ), 2,
     $                      DWORK( W ) )
            END IF
C
            CALL DLACPY( 'All', 2, 2, DWORK( INDTT ), 2, TEMPM1, 2 )
            IF( S( I ).EQ.1 ) THEN
               CALL DLARFX( 'Left', 2, 2, DWORK( INDVP1 ),
     $                      DWORK( ITAUP1 ), TEMPM1, 2, DWORK( W ) )
               CALL DLARFX( 'Right', 2, 2, DWORK( INDXV ),
     $                      DWORK( INDTAU ), TEMPM1, 2, DWORK( W ) )
            ELSE
               CALL DLARFX( 'Right', 2, 2, DWORK( INDVP1 ),
     $                      DWORK( ITAUP1 ), TEMPM1, 2, DWORK( W ) )
               CALL DLARFX( 'Left', 2, 2, DWORK( INDXV ),
     $                      DWORK( INDTAU ), TEMPM1, 2, DWORK( W ) )
            END IF
            CALL DAXPY( ND2, -ONE, TEMP, 1, TEMPM1, 1 )
            STRONG = DLANGE( 'Frobenius', 2, 2, TEMPM1, 2, DWORK )
            IF( STRONG.GT.THRESH )
     $         GO TO 300
C
            INDTAU = INDTAU + 1
            INDXV  = INDXV  + 2
            INDTT  = INDTT  + 4
   50    CONTINUE
C
      END IF
C
C     The swap was accepted - now update T and Q with respect to the
C     swapping.
C
      INDTAU = TAU
      INDXV  = V
C
      DO 60 I = 1, K
         IP1 = MOD( I, K )
C
C        Apply Householder transformations from left or right depending
C        on S and accumulate transformations in matrices Q_i, i = 1:K.
C
         INDVP1 = V   + IP1 * 2
         ITAUP1 = TAU + IP1
C
         IP1 = IP1 + 1
         IT  = IWORK( I11+I ) - J1 + 1
         IF( S( I ).EQ.1 ) THEN
            CALL DLARFX( 'Left', 2, N( I )-J1+1, DWORK( INDVP1 ),
     $                   DWORK( ITAUP1 ), T( IWORK( I11+I ) ), LDT( I ),
     $                   DWORK( W ) )
            CALL DLARFX( 'Right', NI( IP1 )+J2, 2, DWORK( INDXV ),
     $                   DWORK( INDTAU ), T( IT-NI( IP1 ) ), LDT( I ),
     $                   DWORK( W ) )
         ELSE
            CALL DLARFX( 'Left', 2, N( IP1 )-J1+1, DWORK( INDXV ),
     $                   DWORK( INDTAU ), T( IWORK( I11+I ) ), LDT( I ),
     $                   DWORK( W ) )
            CALL DLARFX( 'Right', NI( I )+J2, 2, DWORK( INDVP1 ),
     $                   DWORK( ITAUP1 ), T( IT-NI( I ) ), LDT( I ),
     $                   DWORK( W ) )
         END IF
C
C        Set to zero the fill-in element T(J2,J1,I).
C
         T( IWORK( I21+I ) ) = ZERO
C
         WANTQL = WANTQ
         IF ( SPECQ )
     $      WANTQL = WHICHQ( I ).NE.0
         IF ( WANTQL ) THEN
            IQ = IXQ( I ) + ( J1 - 1 )*LDQ( I )
            CALL DLARFX( 'Right', N( I ), 2, DWORK( INDXV ),
     $                   DWORK( INDTAU ), Q( IQ ), LDQ( I ),
     $                   DWORK( W ) )
         END IF
         INDTAU = INDTAU + 1
         INDXV  = INDXV  + 2
   60 CONTINUE
C
C     Exit direct swap N1 = 1 and N2 = 1.
C
      GOTO 290
C
C     Direct swap with N1 = 1 and N2 = 2.
C
   70 CONTINUE
C
C     Generate elementary reflectors H(1)_i and H(2)_i such that
C
C     H(2)_i H(1)_i  ( X_11_i X_12_i ) = ( * * ).
C                    (  scale    0   )   ( 0 * )
C                    (   0     scale )   ( 0 0 )
C
      ITAU2 = TAU2
      INDXC = C
      INDV1 = V1
      INDV2 = V2
C
      DO 80 ITAU1 = TAU1, TAU1 + K - 1
C
C        Compute elementary reflector H(1)_i.
C
         X_11 = DWORK( INDXC )
         X_12 = DWORK( INDXC+1 )
         DWORK( INDV1   ) = X_11
         DWORK( INDV1+1 ) = SCALOC
         CALL DLARFG( 2, DWORK( INDV1 ), DWORK( INDV1+1 ), 1,
     $                DWORK( ITAU1 ) )
         DWORK( INDV1 ) = ONE
C
C        Compute elementary reflector H(2)_i.
C
         DWORK( INDV2   ) = X_12
         DWORK( INDV2+1 ) = ZERO
         CALL DLARFX( 'Left', 2, 1, DWORK( INDV1 ), DWORK( ITAU1 ),
     $                DWORK( INDV2 ), 2, DWORK( W ) )
         DWORK( INDV2   ) = DWORK( INDV2+1 )
         DWORK( INDV2+1 ) = SCALOC
         CALL DLARFG( 2, DWORK( INDV2 ), DWORK( INDV2+1 ), 1,
     $                DWORK( ITAU2 ) )
         DWORK( INDV2 ) = ONE
C
C        Next, do weak stability test.
C
         TAUS( 1 ) = DWORK( ITAU1 )
         TAUS( 2 ) = DWORK( ITAU2 )
         V_1  = DWORK( INDV1+1 )
         TMP1 = SCALOC * ( ONE - TAUS( 1 ) ) + TAUS( 1 ) * V_1 * X_11
         TMP2 = -( SCALOC * TAUS( 1 ) * V_1 + X_11 *
     $              ( ONE - TAUS( 1 ) * V_1**2 ) ) * ( ONE - TAUS( 2 ) )
     $          + TAUS( 2 ) * DWORK( INDV2+1 ) * X_12
         IF( DLAPY2( TMP1, TMP2 ).GT.THRESH )
     $      GO TO 300
         ITAU2 = ITAU2 + 1
         INDXC = INDXC + 2
         INDV1 = INDV1 + 2
         INDV2 = INDV2 + 2
   80 CONTINUE
C
C     The swap passed weak stability test - move on and perform the
C     swapping temporarily into TT (workspace).
C
      ITAU1 = TAU1
      ITAU2 = TAU2
      INDV1 = V1
      INDV2 = V2
      INDTT = TT
      LTT   = 3
C
      DO 90 I  = 1, K
         IP1    = MOD( I, K )
         IV1P1  = V1   + IP1 * 2
         IV2P1  = V2   + IP1 * 2
         TAU1P1 = TAU1 + IP1
         TAU2P1 = TAU2 + IP1
         CALL DLACPY( 'All', 3, 3, T( IWORK( I11+I ) ), LDT( I ),
     $                DWORK( INDTT ), 3 )
C
         IF( S( I ).EQ.1 ) THEN
            CALL DLARFX( 'Left', 2, 3, DWORK( IV1P1 ), DWORK( TAU1P1 ),
     $                   DWORK( INDTT ), 3, DWORK( W ) )
            CALL DLARFX( 'Left', 2, 3, DWORK( IV2P1 ), DWORK( TAU2P1 ),
     $                   DWORK( INDTT+1 ), 3, DWORK( W ) )
            CALL DLARFX( 'Right', 3, 2, DWORK( INDV1 ), DWORK( ITAU1 ),
     $                   DWORK( INDTT ), 3, DWORK( W ) )
            CALL DLARFX( 'Right', 3, 2, DWORK( INDV2 ), DWORK( ITAU2 ),
     $                   DWORK( INDTT+3 ), 3, DWORK( W ) )
         ELSE
            CALL DLARFX( 'Right', 3, 2, DWORK( IV1P1 ), DWORK( TAU1P1 ),
     $                   DWORK( INDTT ), 3, DWORK( W ) )
            CALL DLARFX( 'Right', 3, 2, DWORK( IV2P1 ), DWORK( TAU2P1 ),
     $                   DWORK( INDTT+3 ), 3, DWORK( W ) )
            CALL DLARFX( 'Left', 2, 3, DWORK( INDV1 ), DWORK( ITAU1 ),
     $                   DWORK( INDTT ), 3, DWORK( W ) )
            CALL DLARFX( 'Left', 2, 3, DWORK( INDV2 ), DWORK( ITAU2 ),
     $                   DWORK( INDTT+1 ), 3, DWORK( W ) )
         END IF
         ITAU1 = ITAU1 + 1
         ITAU2 = ITAU2 + 1
         INDV1 = INDV1 + 2
         INDV2 = INDV2 + 2
         INDTT = INDTT + 9
   90 CONTINUE
C
C     Check for fill-in elements in the new 2-by-2 block.
C
      FILLIN = .FALSE.
      INDTT  = TT + 1
      DO 100 I = 1, K
         IF( I.NE.KSCHUR .AND. ABS( DWORK( INDTT ) ).GT.THRESH )
     $      FILLIN = .TRUE.
         INDTT = INDTT + 9
  100 CONTINUE
C
C     Found fill-in elements?
C
      IF( FILLIN ) THEN
C
C        Restore periodic Schur form.
C
         CALL MB03KC( K, KSCHUR, LTT, 1, S, DWORK( TT ), LTT,
     $                DWORK( VLOC ), DWORK( LTAU ) )
      END IF
C
      IF( WS ) THEN
C
C        Perform strong stability test.
C
         ITAU1 = TAU1
         ITAU2 = TAU2
         ITAUF = LTAU
         INDV1 = V1
         INDV2 = V2
         INDVF = VLOC
         INDTT = TT
C
         DO 110 I = 1, K
            IP1 = MOD( I, K )
            CALL DLACPY( 'All', 3, 3, DWORK( INDTT ), 3, TEMPM1, 3 )
C
C           Apply possible transformations from fill-in removal.
C
            IF( FILLIN ) THEN
               INDVP1 = VLOC + IP1 * 2
               ITAUP1 = LTAU + IP1
C
C              Apply on top-left 2-by-2 block.
C
               IF( S( I ).EQ.1 ) THEN
                  CALL DLARFX( 'Left', 2, 3, DWORK( INDVP1 ),
     $                         DWORK( ITAUP1 ), TEMPM1, 3, DWORK( W ) )
                  CALL DLARFX( 'Right', 3, 2, DWORK( INDVF ),
     $                         DWORK( ITAUF ),  TEMPM1, 3, DWORK( W ) )
               ELSE
                  CALL DLARFX( 'Right', 3, 2, DWORK( INDVP1 ),
     $                         DWORK( ITAUP1 ), TEMPM1, 3, DWORK( W ) )
                  CALL DLARFX( 'Left', 2, 3, DWORK( INDVF ),
     $                         DWORK( ITAUF ),  TEMPM1, 3, DWORK( W ) )
               END IF
            END IF
C
C           Take the "large" transformations.
C
            IV1P1  = V1   + IP1 * 2
            IV2P1  = V2   + IP1 * 2
            TAU1P1 = TAU1 + IP1
            TAU2P1 = TAU2 + IP1
C
C           Apply H(1)_i+1 * H(2)_i+1 from left or right depending on S.
C           Apply H(2)_i * H(1)_i from right or left depending on S.
C
            IF( S( I ).EQ.1 ) THEN
               CALL DLARFX( 'Left', 2, 3, DWORK( IV2P1 ),
     $                      DWORK( TAU2P1 ), TEMPM1( 2 ), 3, DWORK( W )
     $                    )
               CALL DLARFX( 'Left', 2, 3, DWORK( IV1P1 ),
     $                      DWORK( TAU1P1 ), TEMPM1, 3, DWORK( W ) )
               CALL DLARFX( 'Right', 3, 2, DWORK( INDV2 ),
     $                      DWORK( ITAU2 ), TEMPM1( 4 ), 3, DWORK( W ) )
               CALL DLARFX( 'Right', 3, 2, DWORK( INDV1 ),
     $                      DWORK( ITAU1 ), TEMPM1, 3, DWORK( W ) )
            ELSE
               CALL DLARFX( 'Right', 3, 2, DWORK( IV2P1 ),
     $                      DWORK( TAU2P1 ), TEMPM1( 4 ), 3, DWORK( W )
     $                    )
               CALL DLARFX( 'Right', 3, 2, DWORK( IV1P1 ),
     $                      DWORK( TAU1P1 ), TEMPM1, 3, DWORK( W ) )
               CALL DLARFX( 'Left', 2, 3, DWORK( INDV2 ),
     $                      DWORK( ITAU2 ), TEMPM1( 2 ), 3, DWORK( W ) )
               CALL DLARFX( 'Left', 2, 3, DWORK( INDV1 ),
     $                      DWORK( ITAU1 ), TEMPM1, 3, DWORK( W ) )
            END IF
C
C           Compute residual norm.
C
            CALL DLACPY( 'All', 3, 3, T( IWORK( I11+I ) ), LDT( I ),
     $                   TEMP, 3 )
            CALL DAXPY( ND2, -ONE, TEMP, 1, TEMPM1, 1 )
            STRONG = DLANGE( 'Frobenius', 3, 3, TEMPM1, 3, DWORK )
            IF( STRONG.GT.THRESH )
     $         GO TO 300
C
            ITAU1 = ITAU1 + 1
            ITAU2 = ITAU2 + 1
            ITAUF = ITAUF + 1
            INDV1 = INDV1 + 2
            INDV2 = INDV2 + 2
            INDVF = INDVF + 2
            INDTT = INDTT + 9
  110    CONTINUE
C
      END IF
C
C     The swap was accepted - now update T and Q with respect to the
C     swapping.

      ITAU1 = TAU1
      ITAU2 = TAU2
      ITAUF = LTAU
      INDV1 = V1
      INDV2 = V2
      INDVF = VLOC
C
      DO 120 I = 1, K
         IP1 = MOD( I, K )
         IT  = IWORK( I11+I ) - J1 + 1
C
C        Apply Householder transformations from left or right depending
C        on S and accumulate transformations in matrices Q_i, i = 1:K.
C
         IV1P1  = V1   + IP1 * 2
         IV2P1  = V2   + IP1 * 2
         TAU1P1 = TAU1 + IP1
         TAU2P1 = TAU2 + IP1
         IP1    = IP1  + 1
C
         IF( S( I ).EQ.1 ) THEN
            IT  = IT - NI( IP1 )
            IT2 = IT + LDT( I )
            CALL DLARFX( 'Left', 2, N( I )-J1+1, DWORK( IV1P1 ),
     $                   DWORK( TAU1P1 ), T( IWORK( I11+I ) ), LDT( I ),
     $                   DWORK( W ) )
            CALL DLARFX( 'Left', 2, N( I )-J1+1, DWORK( IV2P1 ),
     $                   DWORK( TAU2P1 ), T( IWORK( I21+I ) ), LDT( I ),
     $                   DWORK( W ) )
            CALL DLARFX( 'Right', NI( IP1 )+J3, 2, DWORK( INDV1 ),
     $                   DWORK( ITAU1 ), T( IT ), LDT( I ), DWORK( W ) )
            CALL DLARFX( 'Right', NI( IP1 )+J3, 2, DWORK( INDV2 ),
     $                   DWORK( ITAU2 ), T( IT2 ), LDT( I ), DWORK( W )
     $                 )
         ELSE
            IT  = IT -  NI( I )
            IT2 = IT + LDT( I )
            CALL DLARFX( 'Left', 2, N( IP1 )-J1+1, DWORK( INDV1 ),
     $                   DWORK( ITAU1 ), T( IWORK( I11+I ) ), LDT( I ),
     $                   DWORK( W ) )
            CALL DLARFX( 'Left', 2, N( IP1 )-J1+1, DWORK( INDV2 ),
     $                   DWORK( ITAU2 ), T( IWORK( I21+I ) ), LDT( I ),
     $                   DWORK( W ) )
            CALL DLARFX( 'Right', NI( I )+J3, 2, DWORK( IV1P1 ),
     $                   DWORK( TAU1P1 ), T( IT ), LDT( I ), DWORK( W )
     $                 )
            CALL DLARFX( 'Right', NI( I )+J3, 2, DWORK( IV2P1 ),
     $                   DWORK( TAU2P1 ), T( IT2 ), LDT( I ), DWORK( W )
     $                 )
         END IF
C
         WANTQL = WANTQ
         IF ( SPECQ )
     $      WANTQL = WHICHQ( I ).NE.0
         IF ( WANTQL ) THEN
            IQ = IXQ( I ) + ( J1 - 1 )*LDQ( I )
            CALL DLARFX( 'Right', N( I ), 2, DWORK( INDV1 ),
     $                   DWORK( ITAU1 ), Q( IQ ), LDQ( I ),
     $                   DWORK( W ) )
            IQ = IQ + LDQ( I )
            CALL DLARFX( 'Right', N( I ), 2, DWORK( INDV2 ),
     $                   DWORK( ITAU2 ), Q( IQ ), LDQ( I ),
     $                   DWORK( W ) )
         END IF
C
C        Apply Householder transformations from fill-in removal and
C        accumulate transformations in matrices Q_i, i=1,...,K.
C
         IF ( FILLIN ) THEN
            IV1P1  = VLOC + ( IP1 - 1 ) * 2
            TAU1P1 = LTAU + ( IP1 - 1 )
C
            IF( S( I ).EQ.1 ) THEN
               CALL DLARFX( 'Left', 2, N( I )-J1+1, DWORK( IV1P1 ),
     $                      DWORK( TAU1P1 ), T( IWORK( I11+I ) ),
     $                      LDT( I ), DWORK( W ) )
               CALL DLARFX( 'Right', NI( IP1 )+J2, 2, DWORK( INDVF ),
     $                      DWORK( ITAUF ), T( IT ), LDT( I ),
     $                      DWORK( W ) )
            ELSE
               CALL DLARFX( 'Right', NI( I )+J2, 2, DWORK( IV1P1 ),
     $                      DWORK( TAU1P1 ), T( IT ), LDT( I ),
     $                      DWORK( W ) )
               CALL DLARFX( 'Left', 2, N( IP1 )-J1+1, DWORK( INDVF ),
     $                      DWORK( ITAUF ), T( IWORK( I11+I ) ),
     $                      LDT( I ), DWORK( W ) )
            END IF
C
            WANTQL = WANTQ
            IF ( SPECQ )
     $         WANTQL = WHICHQ( I ).NE.0
            IF ( WANTQL ) THEN
               IQ = IXQ( I ) + ( J1 - 1 )*LDQ( I )
               CALL DLARFX( 'Right', N( I ), 2, DWORK( INDVF ),
     $                      DWORK( ITAUF ), Q( IQ ), LDQ( I ),
     $                      DWORK( W ) )
            END IF
         END IF
C
         ITAU1 = ITAU1 + 1
         ITAU2 = ITAU2 + 1
         ITAUF = ITAUF + 1
         INDV1 = INDV1 + 2
         INDV2 = INDV2 + 2
         INDVF = INDVF + 2
  120 CONTINUE
C
C     Set to zero the fill-in elements.
C
      DO 130 I = 1, K
         T( IWORK( I21+I )+1 ) = ZERO
         T( IWORK( I22+I )+1 ) = ZERO
         IF( I.NE.KSCHUR )
     $       T( IWORK( I21+I ) ) = ZERO
  130 CONTINUE
C
C     Exit direct swap N1 = 1 and N2 = 2.
C
      GOTO 290
C
C     Direct swap with N1 = 2 and N2 = 1.
C
  140 CONTINUE
C
C     Generate elementary reflectors H_i such that:
C
C     H_i( X_11_i ) = ( * ).
C        ( X_21_i )   ( 0 )
C        (  scale )   ( 0 )
C
      INDXC = C
      INDXV = V
C
      DO 150 INDTAU = TAU, TAU + K - 1
         X_11 = DWORK( INDXC )
         X_21 = DWORK( INDXC+1 )
         DWORK( INDXV   ) = X_11
         DWORK( INDXV+1 ) = X_21
         DWORK( INDXV+2 ) = SCALOC
C
         CALL DLARFG( 3, DWORK( INDXV ), DWORK( INDXV+1 ), 1,
     $                DWORK( INDTAU ) )
         DWORK( INDXV ) = ONE
C
C        Next, do weak stability test: check that
C        ||H_11_i - X_i * H_21_i||_F <= tol, i = 1, ..., K.
C
         V_2    = DWORK( INDXV+2 )
         TAULOC = DWORK( INDTAU )
         TMP1 = SCALOC * ( ONE - TAULOC ) + TAULOC * V_2 * X_11
         TMP2 = TAULOC * ( V_2 * X_21 - SCALOC * DWORK( INDXV+1 ) )
         IF( DLAPY2( TMP1, TMP2 ).GT.THRESH )
     $      GO TO 300
         INDXC = INDXC + 2
         INDXV = INDXV + 3
  150 CONTINUE
C
C     The swap passed weak stability test - move on and perform the
C     swapping temporarily into TT (workspace).
C
      INDTAU = TAU
      INDXV  = V
      INDTT  = TT
      LTT    = 3
C
      DO 160 I  = 1, K
         IP1    = MOD( I, K )
         INDVP1 = V   + IP1 * 3
         ITAUP1 = TAU + IP1
         CALL DLACPY( 'All', 3, 3, T( IWORK( I11+I ) ), LDT( I ),
     $                DWORK( INDTT ), 3 )
C
         IF( S( I ).EQ.1 ) THEN
            CALL DLARFX( 'Left', 3, 3, DWORK( INDVP1 ), DWORK( ITAUP1 ),
     $                   DWORK( INDTT ), 3, DWORK( W ) )
            CALL DLARFX( 'Right', 3, 3, DWORK( INDXV ), DWORK( INDTAU ),
     $                   DWORK( INDTT ), 3, DWORK( W ) )
         ELSE
            CALL DLARFX( 'Right', 3, 3, DWORK( INDVP1 ),
     $                   DWORK( ITAUP1 ), DWORK( INDTT ), 3,
     $                   DWORK( W ) )
            CALL DLARFX( 'Left', 3, 3, DWORK( INDXV ),
     $                   DWORK( INDTAU ), DWORK( INDTT ), 3,
     $                   DWORK( W ) )
         END IF
         INDTAU = INDTAU + 1
         INDXV  = INDXV  + 3
         INDTT  = INDTT  + 9
  160 CONTINUE
C
C     Check for fill-in elements.
C
      FILLIN = .FALSE.
      INDTT  = TT + 5
      DO 170 I = 1, K
         IF( I.NE.KSCHUR .AND. ABS( DWORK( INDTT ) ).GT.THRESH )
     $      FILLIN = .TRUE.
         INDTT = INDTT + 9
  170 CONTINUE
C
C     Found fill-in elements?
C
      IF( FILLIN ) THEN
C
C        Restore periodic Schur form.
C
         CALL MB03KC( K, KSCHUR, LTT, 2, S, DWORK( TT ), LTT,
     $                DWORK( VLOC ), DWORK( LTAU ) )
      END IF
C
      IF( WS ) THEN
C
C        Perform strong stability test.
C
         INDTAU = TAU
         INDXV  = V
         ITAUF  = LTAU
         INDVF  = VLOC
         INDTT  = TT
C
         DO 180 I = 1, K
            IP1 = MOD( I, K )
            CALL DLACPY( 'All', 3, 3, DWORK( INDTT ), 3, TEMPM1, 3 )
            IF( FILLIN ) THEN
               INDVP1 = VLOC + IP1 * 2
               ITAUP1 = LTAU + IP1
               IF( S( I ).EQ.1 ) THEN
                  CALL DLARFX( 'Left', 2, 2, DWORK( INDVP1 ),
     $                         DWORK( ITAUP1 ), TEMPM1( 5 ), 3,
     $                         DWORK( W ) )
                  CALL DLARFX( 'Right', 3, 2, DWORK( INDVF ),
     $                         DWORK( ITAUF ), TEMPM1( 4 ), 3,
     $                         DWORK( W ) )
               ELSE
                  CALL DLARFX( 'Right', 3, 2, DWORK( INDVP1 ),
     $                         DWORK( ITAUP1 ), TEMPM1( 4 ), 3,
     $                         DWORK( W ) )
                  CALL DLARFX( 'Left', 2, 2, DWORK( INDVF ),
     $                         DWORK( ITAUF ), TEMPM1( 5 ), 3,
     $                         DWORK( W ) )
               END IF
            END IF
C
            INDVP1 = V   + IP1 * 3
            ITAUP1 = TAU + IP1
            IF( S( I ).EQ.1 ) THEN
               CALL DLARFX( 'Left', 3, 3, DWORK( INDVP1 ),
     $                      DWORK( ITAUP1 ), TEMPM1, 3, DWORK( W ) )
               CALL DLARFX( 'Right', 3, 3, DWORK( INDXV ),
     $                      DWORK( INDTAU ), TEMPM1, 3, DWORK( W ) )
            ELSE
               CALL DLARFX( 'Right', 3, 3, DWORK( INDVP1 ),
     $                      DWORK( ITAUP1 ), TEMPM1, 3, DWORK( W ) )
               CALL DLARFX( 'Left', 3, 3, DWORK( INDXV ),
     $                      DWORK( INDTAU ), TEMPM1, 3, DWORK( W ) )
            END IF
            CALL DLACPY( 'All', 3, 3, T( IWORK( I11+I ) ), LDT( I ),
     $                   TEMP, 3 )
            CALL DAXPY( ND2, -ONE, TEMP, 1, TEMPM1, 1 )
            STRONG = DLANGE( 'Frobenius', 3, 3, TEMPM1, 3, DWORK )
            IF( STRONG.GT.THRESH )
     $         GO TO 300
C
            INDTAU = INDTAU + 1
            INDXV  = INDXV  + 3
            ITAUF  = ITAUF  + 1
            INDVF  = INDVF  + 2
            INDTT  = INDTT  + 9
  180    CONTINUE
C
      END IF
C
C     The swap was accepted - now update T and Q with respect to the
C     swapping.
C
      INDTAU = TAU
      INDXV  = V
      ITAUF  = LTAU
      INDVF  = VLOC
C
      DO 190 I = 1, K
         IP1 = MOD( I, K )
         IT  = IWORK( I11+I ) - J1 + 1
C
C        Apply Householder transformations from left or right depending
C        on S and accumulate transformations in matrices Q_i, i = 1:K.
C
         INDVP1 = V   + IP1 * 3
         ITAUP1 = TAU + IP1
         IP1    = IP1 + 1
         IF( S( I ).EQ.1 ) THEN
            IT  = IT - NI( IP1 )
            CALL DLARFX( 'Left', 3, N( I )-J1+1, DWORK( INDVP1 ),
     $                  DWORK( ITAUP1 ), T( IWORK( I11+I ) ), LDT( I ),
     $                  DWORK( W ) )
            CALL DLARFX( 'Right', NI( IP1 )+J3, 3, DWORK( INDXV ),
     $                   DWORK( INDTAU ), T( IT ), LDT( I ), DWORK( W )
     $                 )
         ELSE
            IT  = IT - NI( I )
            CALL DLARFX( 'Left', 3, N( IP1 )-J1+1, DWORK( INDXV ),
     $                  DWORK( INDTAU ), T( IWORK( I11+I ) ), LDT( I ),
     $                  DWORK( W ) )
            CALL DLARFX( 'Right', NI( I )+J3, 3, DWORK( INDVP1 ),
     $                   DWORK( ITAUP1 ), T( IT ), LDT( I ), DWORK( W )
     $                 )
         END IF
         WANTQL = WANTQ
         IF ( SPECQ )
     $      WANTQL = WHICHQ( I ).NE.0
         IF ( WANTQL ) THEN
            IQ = IXQ( I ) + ( J1 - 1 )*LDQ( I )
            CALL DLARFX( 'Right', N(I), 3, DWORK( INDXV ),
     $                   DWORK( INDTAU ), Q( IQ ), LDQ( I ), DWORK( W )
     $                 )
         END IF
C
C        Apply Householder transformations from fill-in removal and
C        accumulate transformations in matrices Q_i, i=1,...,K.
C
         IF ( FILLIN ) THEN
            INDVP1 = VLOC + ( IP1 - 1 ) * 2
            ITAUP1 = LTAU +   IP1 - 1
            IT2    = IT   + LDT( I )
            IF( S( I ).EQ.1 ) THEN
               CALL DLARFX( 'Left', 2, N( I )-J1, DWORK( INDVP1 ),
     $                      DWORK( ITAUP1 ), T( IT2+J1 ), LDT( I ),
     $                      DWORK( W ) )
               CALL DLARFX( 'Right', NI( IP1 )+J3, 2, DWORK( INDVF ),
     $                      DWORK( ITAUF ), T( IT2 ), LDT( I ),
     $                      DWORK( W ) )
            ELSE
               CALL DLARFX( 'Left', 2, N( IP1 )-J1, DWORK( INDVF ),
     $                      DWORK( ITAUF ), T( IT2+J1 ), LDT( I ),
     $                      DWORK( W ) )
               CALL DLARFX( 'Right', NI( I )+J3, 2, DWORK( INDVP1 ),
     $                      DWORK( ITAUP1 ), T( IT2 ), LDT( I ),
     $                      DWORK( W ) )
            END IF
            WANTQL = WANTQ
            IF ( SPECQ )
     $         WANTQL = WHICHQ( I ).NE.0
            IF ( WANTQL ) THEN
               IQ = IXQ( I ) + J1*LDQ( I )
               CALL DLARFX( 'Right', N( I ), 2, DWORK( INDVF ),
     $                      DWORK( ITAUF ), Q( IQ ), LDQ( I ),
     $                      DWORK( W ) )
            END IF
         END IF
         INDTAU = INDTAU + 1
         INDXV  = INDXV  + 3
         ITAUF  = ITAUF  + 1
         INDVF  = INDVF  + 2
  190 CONTINUE
C
C     Set to zero the fill-in elements below the main diagonal.
C
      DO 200 I = 1, K
         IT = IWORK( I11+I ) + 1
         T( IT   ) = ZERO
         T( IT+1 ) = ZERO
         IF( I.NE.KSCHUR )
     $      T( IT+LDT( I )+1 ) = ZERO
  200 CONTINUE
C
C     Exit direct swap N1 = 2 and N2 = 1.
C
      GOTO 290
C
C     Direct swap with N1 = 2 and N2 = 2.
C
  210 CONTINUE
C
C     Generate elementary reflectors H(1)_i and H(2)_i such that
C
C     H(2)_i H(1)_i  ( X_11_i X_12_i ) = ( * * ).
C                    ( X_21_i X_22_i )   ( 0 * )
C                    (  scale    0   )   ( 0 0 )
C                    (   0     scale )   ( 0 0 )
C
      INDXC = C
      ITAU2 = TAU2
      INDV1 = V1
      INDV2 = V2
C
      DO 220 ITAU1 = TAU1, TAU1 + K - 1
         X_11  = DWORK( INDXC   )
         X_21  = DWORK( INDXC+1 )
         X_12  = DWORK( INDXC+2 )
         X_22  = DWORK( INDXC+3 )
C
C        Compute elementary reflector H(1)_i.
C
         DWORK( INDV1   ) = X_11
         DWORK( INDV1+1 ) = X_21
         DWORK( INDV1+2 ) = SCALOC
         CALL DLARFG( 3, DWORK( INDV1 ), DWORK( INDV1+1 ), 1,
     $                DWORK( ITAU1 ) )
         DWORK( INDV1 ) = ONE
C
C        Compute elementary reflector H(2)_i.
C
         DWORK( INDV2   ) = X_12
         DWORK( INDV2+1 ) = X_22
         DWORK( INDV2+2 ) = ZERO
         CALL DLARFX( 'Left', 3, 1, DWORK( INDV1 ), DWORK( ITAU1 ),
     $                DWORK( INDV2 ), 3, DWORK( W ) )
         DWORK( INDV2   ) = DWORK( INDV2+1 )
         DWORK( INDV2+1 ) = DWORK( INDV2+2 )
         DWORK( INDV2+2 ) = SCALOC
         CALL DLARFG( 3, DWORK( INDV2 ), DWORK( INDV2+1 ), 1,
     $                DWORK( ITAU2 ) )
         DWORK( INDV2 ) = ONE
C
C        Next, do weak stability test: check that
C        ||QQ_11_i - X_i * QQ_21_i||_F <= tol, i = 1, ...,K,
C        where QQ_i = H(1)_i * H(2)_i.
C
         V_2   = DWORK( INDV1+1 )
         V_3   = DWORK( INDV1+2 )
         W_2   = DWORK( INDV2+1 )
         W_3   = DWORK( INDV2+2 )
         DTAU1 = DWORK( ITAU1   )
         DTAU2 = DWORK( ITAU2   )
         TEMP( 1 ) = SCALOC*( ONE - DTAU1 ) + X_11*DTAU1*V_3
         TEMP( 3 ) = SCALOC*( DTAU2*W_2*DTAU1*V_3 -
     $                        DTAU1*V_2*( ONE - DTAU2 ) ) -
     $               X_11*( -DTAU1*V_2*V_3*( ONE - DTAU2 ) -
     $               ( ONE - DTAU1*V_3**2 )*DTAU2*W_2 ) + X_12*DTAU2*W_3
         TEMP( 2 ) = -SCALOC*DTAU1*V_2 + X_21*DTAU1*V_3
         TEMP( 4 ) =  SCALOC*( ( ONE - DTAU1*V_2**2 )*( ONE - DTAU2 ) +
     $               DTAU1*V_2*V_3*DTAU2*W_2 ) -
     $               X_21*( -DTAU1*V_2*V_3*( ONE - DTAU2 ) -
     $               ( ONE - DTAU1*V_3**2 )*DTAU2*W_2 ) + X_22*DTAU2*W_3
         IF( DLANGE( 'Frobenius', 2, 2, TEMP, 2, DWORK ).GT.THRESH )
     $       GO TO 300
         INDXC = INDXC + 4
         ITAU2 = ITAU2 + 1
         INDV1 = INDV1 + 3
         INDV2 = INDV2 + 3
  220 CONTINUE
C
C     The swap passed weak stability test - move on and perform the
C     swapping temporarily into TT (workspace).
C
      ITAU1 = TAU1
      ITAU2 = TAU2
      INDV1 = V1
      INDV2 = V2
      INDTT = TT
      LTT   = 4
C
      DO 230 I = 1, K
         IP1    = MOD( I, K )
         IV1P1  = V1   + IP1 * 3
         IV2P1  = V2   + IP1 * 3
         TAU1P1 = TAU1 + IP1
         TAU2P1 = TAU2 + IP1
         CALL DLACPY( 'All', 4, 4, T( IWORK( I11+I ) ), LDT( I ),
     $                DWORK( INDTT ), 4 )
C
         IF( S( I ).EQ.1 ) THEN
            CALL DLARFX( 'Left', 3, 4, DWORK( IV1P1 ), DWORK( TAU1P1 ),
     $                   DWORK( INDTT ), 4, DWORK( W ) )
            CALL DLARFX( 'Left', 3, 4, DWORK( IV2P1 ), DWORK( TAU2P1 ),
     $                   DWORK( INDTT+1 ), 4, DWORK( W ) )
            CALL DLARFX( 'Right', 4, 3, DWORK( INDV1 ), DWORK( ITAU1 ),
     $                   DWORK( INDTT ), 4, DWORK( W ) )
            CALL DLARFX( 'Right', 4, 3, DWORK( INDV2 ), DWORK( ITAU2 ),
     $                   DWORK( INDTT+4 ), 4, DWORK( W ) )
         ELSE
            CALL DLARFX( 'Right', 4, 3, DWORK( IV1P1 ), DWORK( TAU1P1 ),
     $                   DWORK( INDTT ), 4, DWORK( W ) )
            CALL DLARFX( 'Right', 4, 3, DWORK( IV2P1 ), DWORK( TAU2P1 ),
     $                   DWORK( INDTT+4 ), 4, DWORK( W ) )
            CALL DLARFX( 'Left', 3, 4, DWORK( INDV1 ), DWORK( ITAU1 ),
     $                   DWORK( INDTT ), 4, DWORK( W ) )
            CALL DLARFX( 'Left', 3, 4, DWORK( INDV2 ), DWORK( ITAU2 ),
     $                   DWORK( INDTT+1), 4, DWORK( W ) )
         END IF
         ITAU1 = ITAU1 + 1
         ITAU2 = ITAU2 + 1
         INDV1 = INDV1 + 3
         INDV2 = INDV2 + 3
         INDTT = INDTT + 16
  230 CONTINUE
C
C     Check for fill-in elements.
C
      FILLIN = .FALSE.
      FILL21 = .FALSE.
      INDTT  = TT + 1
      DO 240 I = 1, K
         IF( I.NE.KSCHUR .AND. ABS( DWORK( INDTT ) ).GT.THRESH ) THEN
            FILLIN = .TRUE.
            FILL21 = .TRUE.
         END IF
         INDTT = INDTT + 16
  240 CONTINUE
C
C     Found fill-in elements?
C
      IF( FILLIN ) THEN
C
C        Restore periodic Schur form.
C
         CALL MB03KC( K, KSCHUR, LTT, 1, S, DWORK( TT ), LTT,
     $                DWORK( VLOC1 ), DWORK( LTAU1 ) )
      END IF
C
C     Check for fill-in elements again.
C
      FILLIN = .FALSE.
      FILL43 = .FALSE.
      INDTT  = TT + 11
      DO 250 I = 1, K
         IF( I.NE.KSCHUR .AND. ABS( DWORK( INDTT ) ).GT.EPS ) THEN
            FILLIN = .TRUE.
            FILL43 = .TRUE.
         END IF
         INDTT = INDTT + 16
  250 CONTINUE
C
C     Found fill-in elements?
C
      IF( FILLIN ) THEN
C
C        Restore periodic Schur form.
C
         CALL MB03KC( K, KSCHUR, LTT, 3, S, DWORK( TT ), LTT,
     $                DWORK( VLOC2 ), DWORK( LTAU2 ) )
      END IF
C
      IF( WS ) THEN
C
C        Perform strong stability test.
C
         ITAU1 = TAU1
         ITAU2 = TAU2
         INDV1 = V1
         INDV2 = V2
         INDTT = TT
         IF( FILLIN ) THEN
            ITAUF1 = LTAU1
            ITAUF2 = LTAU2
            INDF1  = VLOC1
            INDF2  = VLOC2
         END IF
C
         DO 260 I = 1, K
            IP1 = MOD( I, K )
            CALL DLACPY( 'All', 4, 4, DWORK( INDTT ), 4, TEMPM1, 4 )
C
C           Apply possible transformations from fill-in removal.
C
            IF( FILLIN ) THEN
               IV1P1  = VLOC1 + IP1 * 2
               IV2P1  = VLOC2 + IP1 * 2
               TAU1P1 = LTAU1 + IP1
               TAU2P1 = LTAU2 + IP1
C
C              Apply on top-left 2-by-2 block.
C
               IF( FILL21 ) THEN
                  IF( S( I ).EQ.1 ) THEN
                     CALL DLARFX( 'Left', 2, 4, DWORK( IV1P1 ),
     $                            DWORK( TAU1P1 ), TEMPM1, 4, DWORK( W )
     $                          )
                     CALL DLARFX( 'Right', 2, 2, DWORK( INDF1 ),
     $                            DWORK( ITAUF1 ), TEMPM1, 4, DWORK( W )
     $                          )
                  ELSE
                     CALL DLARFX( 'Right', 2, 2, DWORK( IV1P1 ),
     $                            DWORK( TAU1P1 ), TEMPM1, 4, DWORK( W )
     $                          )
                     CALL DLARFX( 'Left', 2, 4, DWORK( INDF1 ),
     $                            DWORK( ITAUF1 ), TEMPM1, 4, DWORK( W )
     $                          )
                  END IF
               END IF
C
C              Apply on down-right 2-by-2 block.
C
               IF( FILL43 ) THEN
                  IF( S( I ).EQ.1 ) THEN
                     CALL DLARFX( 'Left', 2, 2, DWORK( IV2P1 ),
     $                            DWORK( TAU2P1 ), TEMPM1( 11 ), 4,
     $                            DWORK( W ) )
                     CALL DLARFX( 'Right', 4, 2, DWORK( INDF2 ),
     $                            DWORK( ITAUF2 ), TEMPM1( 9 ), 4,
     $                            DWORK( W ) )
                  ELSE
                     CALL DLARFX( 'Right', 4, 2, DWORK( IV2P1 ),
     $                            DWORK( TAU2P1 ), TEMPM1( 9 ), 4,
     $                            DWORK( W ) )
                     CALL DLARFX( 'Left', 2, 2, DWORK( INDF2 ),
     $                            DWORK( ITAUF2 ), TEMPM1( 11 ), 4,
     $                            DWORK( W ) )
                  END IF
               END IF
            END IF
C
C           Take the "large" transformations.
C
            IV1P1  = V1   + IP1 * 3
            IV2P1  = V2   + IP1 * 3
            TAU1P1 = TAU1 + IP1
            TAU2P1 = TAU2 + IP1
C
C           Apply H(2)_i+1, H(1)_i+1, H(2)_i, H(1)_i from left or right
C           depending on S.
C
            IF( S( I ).EQ.1 ) THEN
               CALL DLARFX( 'Left', 3, 4, DWORK( IV2P1 ),
     $                      DWORK( TAU2P1 ), TEMPM1( 2 ), 4, DWORK( W )
     $                    )
               CALL DLARFX( 'Left', 3, 4, DWORK( IV1P1 ),
     $                      DWORK( TAU1P1 ), TEMPM1, 4, DWORK( W ) )
               CALL DLARFX( 'Right', 4, 3, DWORK( INDV2 ),
     $                      DWORK( ITAU2 ), TEMPM1( 5 ), 4, DWORK( W ) )
               CALL DLARFX( 'Right', 4, 3, DWORK( INDV1 ),
     $                      DWORK( ITAU1 ), TEMPM1, 4, DWORK( W ) )
            ELSE
               CALL DLARFX( 'Right', 4, 3, DWORK( IV2P1 ),
     $                      DWORK( TAU2P1 ), TEMPM1( 5 ), 4, DWORK( W )
     $                    )
               CALL DLARFX( 'Right', 4, 3, DWORK( IV1P1 ),
     $                      DWORK( TAU1P1 ), TEMPM1, 4, DWORK( W ) )
               CALL DLARFX( 'Left', 3, 4, DWORK( INDV2 ),
     $                      DWORK( ITAU2 ), TEMPM1( 2 ), 4, DWORK( W ) )
               CALL DLARFX( 'Left', 3, 4, DWORK( INDV1 ),
     $                      DWORK( ITAU1 ), TEMPM1, 4, DWORK( W ) )
            END IF
C
C           Compute residual norm.
C
            CALL DLACPY( 'All', 4, 4, T( IWORK( I11+I ) ), LDT( I ),
     $                   TEMP, 4 )
            CALL DAXPY( ND2, -ONE, TEMP, 1, TEMPM1, 1 )
            STRONG = DLANGE( 'Frobenius', 4, 4, TEMPM1, 4, DWORK )
            IF( STRONG.GT.THRESH )
     $         GO TO 300
C
            ITAU1 = ITAU1 + 1
            ITAU2 = ITAU2 + 1
            INDV1 = INDV1 + 3
            INDV2 = INDV2 + 3
            INDTT = INDTT + 16
            IF( FILLIN ) THEN
               ITAUF1 = ITAUF1 + 1
               ITAUF2 = ITAUF2 + 1
               INDF1  = INDF1  + 2
               INDF2  = INDF2  + 2
            END IF
  260    CONTINUE
C
      END IF
C
C     The swap was accepted - now update T and Q with respect to the
C     swapping.
C
      ITAU1 = TAU1
      ITAU2 = TAU2
      INDV1 = V1
      INDV2 = V2
      IF( FILLIN ) THEN
         ITAUF1 = LTAU1
         ITAUF2 = LTAU2
         INDF1  = VLOC1
         INDF2  = VLOC2
      END IF
C
      DO 270 I = 1, K
         IP1 = MOD( I, K )
         IPP = IP1 + 1
         IT  = IWORK( I11+I ) - J1 + 1
C
C        Apply Householder transformations from left or right depending
C        on S and accumulate transformations in matrices Q_i, i = 1:K.
C
         IV1P1  = V1   + IP1 * 3
         IV2P1  = V2   + IP1 * 3
         TAU1P1 = TAU1 + IP1
         TAU2P1 = TAU2 + IP1
C
         IF( S( I ).EQ.1 ) THEN
            IT  = IT - NI( IPP )
            IT2 = IT + LDT( I )
            CALL DLARFX( 'Left', 3, N( I )-J1+1, DWORK( IV1P1 ),
     $                   DWORK( TAU1P1 ), T( IWORK( I11+I ) ), LDT( I ),
     $                   DWORK( W ) )
            CALL DLARFX( 'Left', 3, N( I )-J1+1, DWORK( IV2P1 ),
     $                   DWORK( TAU2P1 ), T( IWORK( I11+I )+1 ),
     $                   LDT( I ), DWORK( W ) )
            CALL DLARFX( 'Right', NI( IPP )+J4, 3, DWORK( INDV1 ),
     $                   DWORK( ITAU1 ), T( IT ), LDT( I ), DWORK( W ) )
            CALL DLARFX( 'Right', NI( IPP )+J4, 3, DWORK( INDV2 ),
     $                   DWORK( ITAU2 ), T( IT2 ), LDT( I ), DWORK( W )
     $                 )
         ELSE
            IT  = IT - NI( I )
            IT2 = IT + LDT( I )
            CALL DLARFX( 'Right', NI( I )+J4, 3, DWORK( IV1P1 ),
     $                   DWORK( TAU1P1 ), T( IT ), LDT( I ), DWORK( W )
     $                 )
            CALL DLARFX( 'Right', NI( I )+J4, 3, DWORK( IV2P1 ),
     $                   DWORK( TAU2P1 ), T( IT2 ), LDT( I ), DWORK( W )
     $                 )
            CALL DLARFX( 'Left', 3, N( IPP )-J1+1, DWORK( INDV1 ),
     $                   DWORK( ITAU1 ), T( IWORK( I11+I ) ), LDT( I ),
     $                   DWORK( W ) )
            CALL DLARFX( 'Left', 3, N( IPP )-J1+1, DWORK( INDV2 ),
     $                   DWORK( ITAU2 ), T( IWORK( I11+I )+1 ),
     $                   LDT( I ), DWORK( W ) )
         END IF
C
         WANTQL = WANTQ
         IF ( SPECQ )
     $      WANTQL = WHICHQ( I ).NE.0
         IF ( WANTQL ) THEN
            IQ = IXQ( I ) + ( J1 - 1 )*LDQ( I )
            CALL DLARFX( 'Right', N( I ), 3, DWORK( INDV1 ),
     $                   DWORK( ITAU1 ), Q( IQ ), LDQ( I ),
     $                   DWORK( W ) )
            IQ = IQ + LDQ( I )
            CALL DLARFX( 'Right', N( I ), 3, DWORK( INDV2 ),
     $                   DWORK( ITAU2 ), Q( IQ ), LDQ( I ),
     $                   DWORK( W ) )
         END IF
C
C        Apply Householder transformations from fill-in removal and
C        accumulate transformations.
C
         IF ( FILLIN ) THEN
            IV1P1  = VLOC1 + IP1 * 2
            IV2P1  = VLOC2 + IP1 * 2
            TAU1P1 = LTAU1 + IP1
            TAU2P1 = LTAU2 + IP1
C
            IF( FILL21 ) THEN
               IF( S( I ).EQ.1 ) THEN
                  CALL DLARFX( 'Left', 2, N( I )-J1+1, DWORK( IV1P1 ),
     $                         DWORK( TAU1P1 ), T( IWORK( I11+I ) ),
     $                         LDT( I ), DWORK( W ) )
                  CALL DLARFX( 'Right', NI( IPP )+J2, 2, DWORK( INDF1 ),
     $                         DWORK( ITAUF1 ), T( IT ), LDT( I ),
     $                         DWORK( W ) )
               ELSE
                  CALL DLARFX( 'Right', NI( I )+J2, 2, DWORK( IV1P1 ),
     $                         DWORK( TAU1P1 ), T( IT ), LDT( I ),
     $                         DWORK( W ) )
                  CALL DLARFX( 'Left', 2, N( IPP )-J1+1, DWORK( INDF1 ),
     $                         DWORK( ITAUF1 ), T( IWORK( I11+I ) ),
     $                         LDT( I ), DWORK( W ) )
               END IF
            END IF
C
            IF( FILL43 ) THEN
               IT  = IWORK( I22+I )
               IT2 = IT2 + LDT( I )
               IF( S( I ).EQ.1 ) THEN
                  CALL DLARFX( 'Left', 2, N( I )-J2, DWORK( IV2P1 ),
     $                         DWORK( TAU2P1 ), T( IT ), LDT( I ),
     $                         DWORK( W ) )
                  CALL DLARFX( 'Right', NI( IPP )+J4, 2, DWORK( INDF2 ),
     $                         DWORK( ITAUF2 ), T( IT2 ), LDT( I ),
     $                         DWORK( W ) )
               ELSE
                  CALL DLARFX( 'Right', NI( I )+J4, 2, DWORK( IV2P1 ),
     $                         DWORK( TAU2P1 ), T( IT2 ), LDT( I ),
     $                         DWORK( W ) )
                  CALL DLARFX( 'Left', 2, N( IPP )-J2, DWORK( INDF2 ),
     $                         DWORK( ITAUF2 ), T( IT ), LDT( I ),
     $                         DWORK( W ) )
               END IF
            END IF
C
            WANTQL = WANTQ
            IF ( SPECQ )
     $         WANTQL = WHICHQ( I ).NE.0
            IF ( WANTQL ) THEN
               IF( FILL21 ) THEN
                  IQ = IXQ( I ) + ( J1 - 1 )*LDQ( I )
                  CALL DLARFX( 'Right', N( I ), 2, DWORK( INDF1 ),
     $                         DWORK( ITAUF1 ), Q( IQ ), LDQ( I ),
     $                         DWORK( W ) )
               END IF
               IF( FILL43 ) THEN
                  IQ = IXQ( I ) + J2*LDQ( I )
                  CALL DLARFX( 'Right', N( I ), 2, DWORK( INDF2 ),
     $                         DWORK( ITAUF2 ), Q( IQ ), LDQ( I ),
     $                         DWORK( W ) )
               END IF
            END IF
         END IF
         ITAU1 = ITAU1 + 1
         ITAU2 = ITAU2 + 1
         INDV1 = INDV1 + 3
         INDV2 = INDV2 + 3
         IF( FILLIN ) THEN
            ITAUF1 = ITAUF1 + 1
            ITAUF2 = ITAUF2 + 1
            INDF1  = INDF1  + 2
            INDF2  = INDF2  + 2
         END IF
  270 CONTINUE
C
C     Set to zero the fill-in elements below the main diagonal.
C
      DO 280 I = 1, K
         IT = IWORK( I21+I )
         T( IT   ) = ZERO
         T( IT+1 ) = ZERO
         IT = IT + LDT( I )
         T( IT   ) = ZERO
         T( IT+1 ) = ZERO
         IF( I.NE.KSCHUR ) THEN
            T( IWORK( I11+I )+1 ) = ZERO
            T( IWORK( I22+I )+1 ) = ZERO
         END IF
  280 CONTINUE
C
C     Exit direct swap N1 = 2 and N2 = 2.
C
C     Normal exit.
C
  290 CONTINUE
C
C     Store optimal workspace values and return.
C
      DWORK( 1 ) = DBLE( MINWRK )
      RETURN
C
C     Exit with INFO = 1 if swap was rejected.
C
  300 CONTINUE
      INFO = 1
      RETURN
C
C *** Last line of MB03KB ***
      END


program exp
  use mod_orrb
  implicit none

  type(error_info) :: error
  integer(kind=int32) :: na, lbwa, ubwa, j
  real(kind=dp), dimension(:), allocatable :: x, rhs, res, rhs0, ur, vr, svres
  type(d_qr), allocatable :: swub
  type(d_rc), allocatable :: swbv
  type(d_ubt), allocatable :: ubta
  real(kind=dp) :: t0, t1, sigma1, sigman

  integer(kind=int32), parameter :: runs=50
  real(kind=dp) :: cond_sum, rc_time, qr_time, q_rc_time, q_qr_time, res_sum, &
       max_res, solve_time

  call initialize_errors
  ! na=100000; lbwa=5; ubwa=5
  ! na=1000000; lbwa=5; ubwa=5
  na=1000000; lbwa=5; ubwa=6
  cond_sum=0.0_dp; rc_time=0.0_dp; qr_time=0.0_dp;
  q_rc_time=0.0_dp; q_qr_time=0.0_dp; res_sum=0.0_dp
  solve_time=0.0_dp
  max_res=0.0_dp
  do j=1,runs
     print *, "j: ", j
     allocate(ur(na),vr(na),svres(na))
     rhs=d_random_vector(na)
     rhs0=rhs
     ubta=d_random_ubt(na,lbwa,ubwa,error=error)
     call cpu_time(t0)
     swbv=rc_of(ubta,error)
     call cpu_time(t1)
     rc_time=rc_time+t1-t0
     print *, "Row compression time: ", t1-t0
     call cpu_time(t0)
     rhs=trp(swbv%sw) * rhs
     call cpu_time(t1)
     q_rc_time=q_rc_time+t1-t0
     print *, "RHS times Q_rc: ", t1-t0
     call cpu_time(t0)
     swub=qr_of(swbv%bv,error)
     call cpu_time(t1)
     qr_time=qr_time+t1-t0
     print *, "QR time: ", t1-t0
     call cpu_time(t0)
     rhs=trp(swub%sw) * rhs
     call cpu_time(t1)
     q_qr_time=q_qr_time+t1-t0
     print *, "RHS times Q_qr: ", t1-t0
     call cpu_time(t0)
     x=solve(swub%ub, rhs, error)
     call cpu_time(t1)
     solve_time=solve_time+t1-t0
     print *, "solve: ", t1-t0
     sigma1=ub_max_sv(swub%ub,ur,vr,svres,1e-2_dp,1000,error)
     print *, "sigma1: ", sigma1, norm2(svres)
     sigman=ub_min_sv(swub%ub,ur,vr,svres,1e-16_dp,1000,error)
     print *, "sigman: ", sigman, norm2(svres)
     print *, norm2(swub%ub*reshape(vr,[na,1])-sigman*reshape(ur,[na,1])), norm2(swub%ub*reshape(vr,[na,1]))
     write (*, "(' Cond2: ', ES8.2)") sigma1/sigman
     cond_sum=cond_sum + sigma1/sigman
     res=reshape(ubta*reshape(x,[na,1])-reshape(rhs0,[na,1]),[na])
     print *, "Relative residual: ", norm2(res)/(sigma1*norm2(x)+norm2(rhs0))
     res_sum=res_sum+norm2(res)/(sigma1*norm2(x)+norm2(rhs0))
     max_res=max(max_res,norm2(res)/(sigma1*norm2(x)+norm2(rhs0)))
     deallocate(ur,vr,svres)
     print *
  end do
  print *, "Average residual: ", res_sum/runs
  print *, "Max residual: ", max_res
  write (*, "(' Cond2: ', ES8.2)") cond_sum/runs
  print *, "Average row compress time: ", rc_time/runs
  print *, "Averge Q_rc multiply time: ", q_rc_time/runs
  print *, "Average qr compress time: ", qr_time/runs
  print *, "Average Q_qr multiply time: ", q_qr_time/runs
  print *, "Average solve time: ", solve_time/runs

end program exp


subroutine SSA(Y0,Tfin,T,Y,info)
    !
    !   Copyright 2016, Viktor Reshiak, All rights reserved.
    !
    !   Purpose
    !   =======
    !   Find solution of a stochastic chemical system.
    !
    !
    !   Method
    !   ======
    !   Stochastic Simulation Algorithm:
    !
    !  / y1[k+1] \   / y1[k] \   / nu_1r \
    !  | y2[k+1] |   | y2[k] |   | nu_2r |
    !  |    .    | = |   .   | + |   .   |
    !  |    .    |   |   .   |   |   .   |
    !  \ yn[k+1] /   \ yn[k] /   \ nu_nr /
    !
    !   where r = Multinomial( 1, prop(y[k]) / Sum(prop_j) )
    !
    !
    !   IN
    !   ==
    !   1) num_species      - dimension of the state vector
    !   2) num_reactions      - number of reactions
    !   3) prop   - function to propensity vector
    !   4) nu     - num_species-by-num_reactions stoichiometric matrix
    !   5) Y0     - num_species-dimensional vector with initial data
    !   6) Tfin   - final time
    !
    !
    !   OUT
    !   ===
    !   7) T      - K-dimensional vector of time points
    !   8) Y      - num_species-by-K solution array. Each row in Y is the solution of the corresponding equation
    !   9) info   - structure with information about solvers
    !        time - average time of solver per time step
    !

    implicit none

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    ! dummy arguments

       real(kind=8), intent(in),    dimension(num_species)      :: Y0
       real(kind=8), intent(in)                                 :: Tfin
       real(kind=8), intent(inout), dimension(:),   allocatable :: T
       real(kind=8), intent(out),   dimension(:,:), allocatable :: Y

    type(solver_info), intent(out), optional :: info

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    real(kind=8), dimension(num_reactions)   :: a, a0

    type(solver_info) :: inf

    integer(kind=8)   :: count1, count2, count_rate
    integer(kind=4)   :: i, r, K
       real(kind=8)   :: time_old, time_new

    real(kind=8), dimension(:),   allocatable  :: tmp_arr_T
    real(kind=8), dimension(:,:), allocatable  :: tmp_arr_Y
    real(kind=8), dimension(num_species)       :: Y_new, Y_old

    logical :: all_times

    integer,      dimension(8)              :: date_time
    integer,      dimension(:), allocatable :: seed
    real(kind=8), dimension(2)              :: rnd

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    ! all_times -  track state of the system after each reaction or at fixed time instances
    if ( allocated(T) ) then
        K = size(T)
        if ( .not. allocated(Y) ) then
            allocate(Y(num_species,K))
        endif
        all_times = .false.
    else
        K = 10000
        allocate(T(K), Y(num_species,K))
        all_times = .true.
    endif

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!     ! random seed
!     call date_and_time(values=date_time)
!     call random_seed(size=i)
!     allocate(seed(1:i))
!     seed(:) = date_time(8) + omp_get_thread_num()
!     call random_seed(put=seed)

    time_new = 0.d0
    Y_new    = Y0
    if ( all_times ) then
        Y(:,1) = Y_new
        T(1)   = time_new
    else
        if ( T(1) .eq. 0.d0 ) then
            Y(:,1) = Y_new
        endif
    endif

    call system_clock(count1)
    i = 2
	do while ( time_new <= Tfin )
        ! dynamically change sizes of arrays
        if (all_times) then
            if (i > K) then
                call change_size_of_arrays()
            endif
        endif

        Y_old    = Y_new
        time_old = time_new

        ! calculate propensities
        a  = propensities(Y_old)
        a0 = cumsum(num_reactions,a)

        ! choose reaction
        call rand(2,rnd)
        !call random_number(rnd)
        time_new = time_old - log(rnd(1)) / a0(num_reactions)
        r        = minloc( a0, 1, a0 > (a0(num_reactions)*rnd(2)) )

        ! update state
        Y_new = Y_old + nu(:,r)
        if ( all_times ) then
            Y(:,i) = Y_new
            T(i)   = time_new
            i      = i + 1
        else
            do while ( i <= K .and. time_new > T(i) )
                Y(:,i) = Y_old
                i      = i + 1
            enddo
            !if ( time_new > T(i) ) then
            !    Y(:,i) = Y_old
            !    i      = i + 1
            !endif
        endif
	enddo
    !print*, i-1, K, Y(:,K)
    !print*,Tfin,T(size(T)), Y(:,size(T)), Y(:,size(T)-1), i, shape(T)
    call system_clock(count2, count_rate)
    inf%time = (count2-count1) / real(count_rate,8)

    ! remove trailing zeros
    if ( i <= K .and. all_times ) then
        K = i-1
        allocate(tmp_arr_T(K))
        allocate(tmp_arr_Y(num_species,K))
        tmp_arr_T = T(1:K)
        tmp_arr_Y = Y(:,1:K)
        deallocate(Y, T)
        call move_alloc(tmp_arr_T,T)
        call move_alloc(tmp_arr_Y,Y)
    endif

    ! interpolate solution at last time point
    if (all_times) then
        T(K)   = Tfin
    endif
    if ( T(K) > Tfin ) then
        Y(:,K) = Y(:,K-1)
    endif

    if ( present(info) ) then
        info = inf
    endif

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    contains

    subroutine change_size_of_arrays()
        allocate(tmp_arr_T(2*K))
        allocate(tmp_arr_Y(num_species,2*K))
        tmp_arr_T(1:K)   = T
        tmp_arr_Y(:,1:K) = Y
        deallocate(Y, T)
        call move_alloc(tmp_arr_T,T)
        call move_alloc(tmp_arr_Y,Y)
        K = 2*K
    end subroutine change_size_of_arrays

    function cumsum(dim,vector)
        implicit none
        integer,      intent(in)                 :: dim
        real(kind=8), intent(in), dimension(dim) :: vector
        real(kind=8),             dimension(dim) :: cumsum

        integer :: i

        cumsum(1) = vector(1)
        do i = 2,dim
            cumsum(i) = cumsum(i-1) + vector(i)
        enddo

    end function cumsum

end subroutine SSA


!---------------------------------------------------------------------!
! OWNER: Ithaca Combustion Enterprise, LLC                            !
! COPYRIGHT: © 2012, Ithaca Combustion Enterprise, LLC                !
! LICENSE: BSD 3-Clause License (The complete text of the license can !
!  be found in the `LICENSE-ICE.txt' file included in the ISAT-CK7    !
!  source directory.)                                                 !
!---------------------------------------------------------------------!

subroutine ell_chol_det( n, g, det )

!  g contains (in packed format) the lower triangular n x n matrix G.
!  The determinant of G, det, is returned.
!  If G represents an ellipsoid E, then det is the inverse of the
!  content (volume) of E.

implicit none
integer, parameter      :: k_dp = kind(1.d0)
integer, intent(in)     :: n
real(k_dp), intent(in)  :: g((n*(n+1))/2)
real(k_dp), intent(out) :: det

integer    :: j, k

det = 1.d0

k  = 1
do j = 1, n
   det = det * g(k)
   k = k + n + 1 - j
end do

return
end subroutine ell_chol_det


subroutine sistu(a, b, u)

implicit none

real, dimension(:,:), intent(in) :: a
real, dimension(:), intent(in) :: b
real, dimension(:), intent(out) :: u

integer :: n, i, j

n = size(b)

!u(n) = b(n)/a(n,n)
u(n) = b(n)

do i = n-1, 1, -1
  u(i) = b(i)
  do j = i+1, n
    u(i) = u(i) - a(i,j)*u(j)
  enddo

  !u(i) = u(i)/a(i,i)
enddo

end subroutine


      double precision a(1001,1000),b(1000),x(1000)
      double precision time(6),cray,ops,total,norma,normx
      double precision resid,residn,eps,epslon
      integer ipvt(1000)
      lda = 1001
c
c     this program was updated on 10/12/92 to correct a
c     problem with the random number generator. The previous
c     random number generator had a short period and produced
c     singular matrices occasionally.
c
      n = 1000
      cray = .056
      write(6,1)
    1 format(' Please send the results of this run to:'//
     $       ' Jack J. Dongarra'/
     $       ' Computer Science Department'/
     $       ' University of Tennessee'/
     $       ' Knoxville, Tennessee 37996-1300'//
     $       ' Fax: 615-974-8296'//
     $       ' Internet: dongarra@cs.utk.edu'/)
      ops = (2.0d0*dfloat(n)**3)/3.0d0 + 2.0d0*dfloat(n)**2
c
         call matgen(a,lda,n,b,norma)
c
c******************************************************************
c******************************************************************
c        you should replace the call to dgefa and dgesl
c        by calls to your linear equation solver.
c******************************************************************
c******************************************************************
c
         t1 = second()
         call dgefa(a,lda,n,ipvt,info)
         time(1) = second() - t1
         t1 = second()
         call dgesl(a,lda,n,ipvt,b,0)
         time(2) = second() - t1
         total = time(1) + time(2)
c******************************************************************
c******************************************************************
c
c     compute a residual to verify results.
c
         do 10 i = 1,n
            x(i) = b(i)
   10    continue
         call matgen(a,lda,n,b,norma)
         do 20 i = 1,n
            b(i) = -b(i)
   20    continue
         call dmxpy(n,b,n,lda,x,a)
         resid = 0.0
         normx = 0.0
         do 30 i = 1,n
            resid = dmax1( resid, dabs(b(i)) )
            normx = dmax1( normx, dabs(x(i)) )
   30    continue
         eps = epslon(1.0d0)
         residn = resid/( n*norma*normx*eps )
         write(6,40)
   40    format('     norm. resid      resid           machep',
     $          '         x(1)          x(n)')
         write(6,50) residn,resid,eps,x(1),x(n)
   50    format(1p5e16.8)
c
         write(6,60) n
   60    format(//'    times are reported for matrices of order ',i5)
         write(6,70)
   70    format(6x,'factor',5x,'solve',6x,'total',5x,'mflops',7x,'unit',
     $         6x,'ratio')
c
         time(3) = total
         time(4) = ops/(1.0d6*total)
         time(5) = 2.0d0/time(4)
         time(6) = total/cray
         write(6,80) lda
   80    format(' times for array with leading dimension of',i4)
         write(6,110) (time(i),i=1,6)
  110    format(6(1pe11.3))
         write(6,*)' end of tests -- this version dated 10/12/92'
c
      stop
      end
      subroutine matgen(a,lda,n,b,norma)
      integer lda,n,init(4),i,j
      double precision a(lda,1),b(1),norma,ran
c
      init(1) = 1
      init(2) = 2
      init(3) = 3
      init(4) = 1325
      norma = 0.0
      do 30 j = 1,n
         do 20 i = 1,n
            a(i,j) = ran(init) - .5
            norma = dmax1(dabs(a(i,j)), norma)
   20    continue
   30 continue
      do 35 i = 1,n
          b(i) = 0.0
   35 continue
      do 50 j = 1,n
         do 40 i = 1,n
            b(i) = b(i) + a(i,j)
   40    continue
   50 continue
      return
      end
      subroutine dgefa(a,lda,n,ipvt,info)
      integer lda,n,ipvt(1),info
      double precision a(lda,1)
c
c     dgefa factors a double precision matrix by gaussian elimination.
c
c     dgefa is usually called by dgeco, but it can be called
c     directly with a saving in time if  rcond  is not needed.
c     (time for dgeco) = (1 + 9/n)*(time for dgefa) .
c
c     on entry
c
c        a       double precision(lda, n)
c                the matrix to be factored.
c
c        lda     integer
c                the leading dimension of the array  a .
c
c        n       integer
c                the order of the matrix  a .
c
c     on return
c
c        a       an upper triangular matrix and the multipliers
c                which were used to obtain it.
c                the factorization can be written  a = l*u  where
c                l  is a product of permutation and unit lower
c                triangular matrices and  u  is upper triangular.
c
c        ipvt    integer(n)
c                an integer vector of pivot indices.
c
c        info    integer
c                = 0  normal value.
c                = k  if  u(k,k) .eq. 0.0 .  this is not an error
c                     condition for this subroutine, but it does
c                     indicate that dgesl or dgedi will divide by zero
c                     if called.  use  rcond  in dgeco for a reliable
c                     indication of singularity.
c
c     linpack. this version dated 08/14/78 .
c     cleve moler, university of new mexico, argonne national lab.
c
c     subroutines and functions
c
c     blas daxpy,dscal,idamax
c
c     internal variables
c
      double precision t
      integer idamax,j,k,kp1,l,nm1
c
c
c     gaussian elimination with partial pivoting
c
      info = 0
      nm1 = n - 1
      if (nm1 .lt. 1) go to 70
      do 60 k = 1, nm1
         kp1 = k + 1
c
c        find l = pivot index
c
         l = idamax(n-k+1,a(k,k),1) + k - 1
         ipvt(k) = l
c
c        zero pivot implies this column already triangularized
c
         if (a(l,k) .eq. 0.0d0) go to 40
c
c           interchange if necessary
c
            if (l .eq. k) go to 10
               t = a(l,k)
               a(l,k) = a(k,k)
               a(k,k) = t
   10       continue
c
c           compute multipliers
c
            t = -1.0d0/a(k,k)
            call dscal(n-k,t,a(k+1,k),1)
c
c           row elimination with column indexing
c
            do 30 j = kp1, n
               t = a(l,j)
               if (l .eq. k) go to 20
                  a(l,j) = a(k,j)
                  a(k,j) = t
   20          continue
               call daxpy(n-k,t,a(k+1,k),1,a(k+1,j),1)
   30       continue
         go to 50
   40    continue
            info = k
   50    continue
   60 continue
   70 continue
      ipvt(n) = n
      if (a(n,n) .eq. 0.0d0) info = n
      return
      end
      subroutine dgesl(a,lda,n,ipvt,b,job)
      integer lda,n,ipvt(1),job
      double precision a(lda,1),b(1)
c
c     dgesl solves the double precision system
c     a * x = b  or  trans(a) * x = b
c     using the factors computed by dgeco or dgefa.
c
c     on entry
c
c        a       double precision(lda, n)
c                the output from dgeco or dgefa.
c
c        lda     integer
c                the leading dimension of the array  a .
c
c        n       integer
c                the order of the matrix  a .
c
c        ipvt    integer(n)
c                the pivot vector from dgeco or dgefa.
c
c        b       double precision(n)
c                the right hand side vector.
c
c        job     integer
c                = 0         to solve  a*x = b ,
c                = nonzero   to solve  trans(a)*x = b  where
c                            trans(a)  is the transpose.
c
c     on return
c
c        b       the solution vector  x .
c
c     error condition
c
c        a division by zero will occur if the input factor contains a
c        zero on the diagonal.  technically this indicates singularity
c        but it is often caused by improper arguments or improper
c        setting of lda .  it will not occur if the subroutines are
c        called correctly and if dgeco has set rcond .gt. 0.0
c        or dgefa has set info .eq. 0 .
c
c     to compute  inverse(a) * c  where  c  is a matrix
c     with  p  columns
c           call dgeco(a,lda,n,ipvt,rcond,z)
c           if (rcond is too small) go to ...
c           do 10 j = 1, p
c              call dgesl(a,lda,n,ipvt,c(1,j),0)
c        10 continue
c
c     linpack. this version dated 08/14/78 .
c     cleve moler, university of new mexico, argonne national lab.
c
c     subroutines and functions
c
c     blas daxpy,ddot
c
c     internal variables
c
      double precision ddot,t
      integer k,kb,l,nm1
c
      nm1 = n - 1
      if (job .ne. 0) go to 50
c
c        job = 0 , solve  a * x = b
c        first solve  l*y = b
c
         if (nm1 .lt. 1) go to 30
         do 20 k = 1, nm1
            l = ipvt(k)
            t = b(l)
            if (l .eq. k) go to 10
               b(l) = b(k)
               b(k) = t
   10       continue
            call daxpy(n-k,t,a(k+1,k),1,b(k+1),1)
   20    continue
   30    continue
c
c        now solve  u*x = y
c
         do 40 kb = 1, n
            k = n + 1 - kb
            b(k) = b(k)/a(k,k)
            t = -b(k)
            call daxpy(k-1,t,a(1,k),1,b(1),1)
   40    continue
      go to 100
   50 continue
c
c        job = nonzero, solve  trans(a) * x = b
c        first solve  trans(u)*y = b
c
         do 60 k = 1, n
            t = ddot(k-1,a(1,k),1,b(1),1)
            b(k) = (b(k) - t)/a(k,k)
   60    continue
c
c        now solve trans(l)*x = y
c
         if (nm1 .lt. 1) go to 90
         do 80 kb = 1, nm1
            k = n - kb
            b(k) = b(k) + ddot(n-k,a(k+1,k),1,b(k+1),1)
            l = ipvt(k)
            if (l .eq. k) go to 70
               t = b(l)
               b(l) = b(k)
               b(k) = t
   70       continue
   80    continue
   90    continue
  100 continue
      return
      end
      subroutine daxpy(n,da,dx,incx,dy,incy)
c
c     constant times a vector plus a vector.
c     uses unrolled loops for increments equal to one.
c     jack dongarra, linpack, 3/11/78.
c
      double precision dx(1),dy(1),da
      integer i,incx,incy,ix,iy,m,mp1,n
c
      if(n.le.0)return
      if (da .eq. 0.0d0) return
      if(incx.eq.1.and.incy.eq.1)go to 20
c
c        code for unequal increments or equal increments
c          not equal to 1
c
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do 10 i = 1,n
        dy(iy) = dy(iy) + da*dx(ix)
        ix = ix + incx
        iy = iy + incy
   10 continue
      return
c
c        code for both increments equal to 1
c
c
c        clean-up loop
c
   20 m = mod(n,4)
      if( m .eq. 0 ) go to 40
      do 30 i = 1,m
        dy(i) = dy(i) + da*dx(i)
   30 continue
      if( n .lt. 4 ) return
   40 mp1 = m + 1
      do 50 i = mp1,n,4
        dy(i) = dy(i) + da*dx(i)
        dy(i + 1) = dy(i + 1) + da*dx(i + 1)
        dy(i + 2) = dy(i + 2) + da*dx(i + 2)
        dy(i + 3) = dy(i + 3) + da*dx(i + 3)
   50 continue
      return
      end
      double precision function ddot(n,dx,incx,dy,incy)
c
c     forms the dot product of two vectors.
c     uses unrolled loops for increments equal to one.
c     jack dongarra, linpack, 3/11/78.
c
      double precision dx(1),dy(1),dtemp
      integer i,incx,incy,ix,iy,m,mp1,n
c
      ddot = 0.0d0
      dtemp = 0.0d0
      if(n.le.0)return
      if(incx.eq.1.and.incy.eq.1)go to 20
c
c        code for unequal increments or equal increments
c          not equal to 1
c
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do 10 i = 1,n
        dtemp = dtemp + dx(ix)*dy(iy)
        ix = ix + incx
        iy = iy + incy
   10 continue
      ddot = dtemp
      return
c
c        code for both increments equal to 1
c
c
c        clean-up loop
c
   20 m = mod(n,5)
      if( m .eq. 0 ) go to 40
      do 30 i = 1,m
        dtemp = dtemp + dx(i)*dy(i)
   30 continue
      if( n .lt. 5 ) go to 60
   40 mp1 = m + 1
      do 50 i = mp1,n,5
        dtemp = dtemp + dx(i)*dy(i) + dx(i + 1)*dy(i + 1) +
     *   dx(i + 2)*dy(i + 2) + dx(i + 3)*dy(i + 3) + dx(i + 4)*dy(i + 4)
   50 continue
   60 ddot = dtemp
      return
      end
      subroutine  dscal(n,da,dx,incx)
c
c     scales a vector by a constant.
c     uses unrolled loops for increment equal to one.
c     jack dongarra, linpack, 3/11/78.
c
      double precision da,dx(1)
      integer i,incx,m,mp1,n,nincx
c
      if(n.le.0)return
      if(incx.eq.1)go to 20
c
c        code for increment not equal to 1
c
      nincx = n*incx
      do 10 i = 1,nincx,incx
        dx(i) = da*dx(i)
   10 continue
      return
c
c        code for increment equal to 1
c
c
c        clean-up loop
c
   20 m = mod(n,5)
      if( m .eq. 0 ) go to 40
      do 30 i = 1,m
        dx(i) = da*dx(i)
   30 continue
      if( n .lt. 5 ) return
   40 mp1 = m + 1
      do 50 i = mp1,n,5
        dx(i) = da*dx(i)
        dx(i + 1) = da*dx(i + 1)
        dx(i + 2) = da*dx(i + 2)
        dx(i + 3) = da*dx(i + 3)
        dx(i + 4) = da*dx(i + 4)
   50 continue
      return
      end
      integer function idamax(n,dx,incx)
c
c     finds the index of element having max. dabsolute value.
c     jack dongarra, linpack, 3/11/78.
c
      double precision dx(1),dmax
      integer i,incx,ix,n
c
      idamax = 0
      if( n .lt. 1 ) return
      idamax = 1
      if(n.eq.1)return
      if(incx.eq.1)go to 20
c
c        code for increment not equal to 1
c
      ix = 1
      dmax = dabs(dx(1))
      ix = ix + incx
      do 10 i = 2,n
         if(dabs(dx(ix)).le.dmax) go to 5
         idamax = i
         dmax = dabs(dx(ix))
    5    ix = ix + incx
   10 continue
      return
c
c        code for increment equal to 1
c
   20 dmax = dabs(dx(1))
      do 30 i = 2,n
         if(dabs(dx(i)).le.dmax) go to 30
         idamax = i
         dmax = dabs(dx(i))
   30 continue
      return
      end
      double precision function epslon (x)
      double precision x
c
c     estimate unit roundoff in quantities of size x.
c
      double precision a,b,c,eps
c
c     this program should function properly on all systems
c     satisfying the following two assumptions,
c        1.  the base used in representing dfloating point
c            numbers is not a power of three.
c        2.  the quantity  a  in statement 10 is represented to
c            the accuracy used in dfloating point variables
c            that are stored in memory.
c     the statement number 10 and the go to 10 are intended to
c     force optimizing compilers to generate code satisfying
c     assumption 2.
c     under these assumptions, it should be true that,
c            a  is not exactly equal to four-thirds,
c            b  has a zero for its last bit or digit,
c            c  is not exactly equal to one,
c            eps  measures the separation of 1.0 from
c                 the next larger dfloating point number.
c     the developers of eispack would appreciate being informed
c     about any systems where these assumptions do not hold.
c
c     *****************************************************************
c     this routine is one of the auxiliary routines used by eispack iii
c     to avoid machine dependencies.
c     *****************************************************************
c
c     this version dated 4/6/83.
c
      a = 4.0d0/3.0d0
   10 b = a - 1.0d0
      c = b + b + b
      eps = dabs(c-1.0d0)
      if (eps .eq. 0.0d0) go to 10
      epslon = eps*dabs(x)
      return
      end
      subroutine mm (a, lda, n1, n3, b, ldb, n2, c, ldc)
      double precision a(lda,*), b(ldb,*), c(ldc,*)
c
c   purpose:
c     multiply matrix b times matrix c and store the result in matrix a.
c
c   parameters:
c
c     a double precision(lda,n3), matrix of n1 rows and n3 columns
c
c     lda integer, leading dimension of array a
c
c     n1 integer, number of rows in matrices a and b
c
c     n3 integer, number of columns in matrices a and c
c
c     b double precision(ldb,n2), matrix of n1 rows and n2 columns
c
c     ldb integer, leading dimension of array b
c
c     n2 integer, number of columns in matrix b, and number of rows in
c         matrix c
c
c     c double precision(ldc,n3), matrix of n2 rows and n3 columns
c
c     ldc integer, leading dimension of array c
c
c ----------------------------------------------------------------------
c
      do 20 j = 1, n3
         do 10 i = 1, n1
            a(i,j) = 0.0
   10    continue
         call dmxpy (n2,a(1,j),n1,ldb,c(1,j),b)
   20 continue
c
      return
      end
      subroutine dmxpy (n1, y, n2, ldm, x, m)
      double precision y(*), x(*), m(ldm,*)
c
c   purpose:
c     multiply matrix m times vector x and add the result to vector y.
c
c   parameters:
c
c     n1 integer, number of elements in vector y, and number of rows in
c         matrix m
c
c     y double precision(n1), vector of length n1 to which is added
c         the product m*x
c
c     n2 integer, number of elements in vector x, and number of columns
c         in matrix m
c
c     ldm integer, leading dimension of array m
c
c     x double precision(n2), vector of length n2
c
c     m double precision(ldm,n2), matrix of n1 rows and n2 columns
c
c ----------------------------------------------------------------------
c
c   cleanup odd vector
c
      j = mod(n2,2)
      if (j .ge. 1) then
         do 10 i = 1, n1
            y(i) = (y(i)) + x(j)*m(i,j)
   10    continue
      endif
c
c   cleanup odd group of two vectors
c
      j = mod(n2,4)
      if (j .ge. 2) then
         do 20 i = 1, n1
            y(i) = ( (y(i))
     $             + x(j-1)*m(i,j-1)) + x(j)*m(i,j)
   20    continue
      endif
c
c   cleanup odd group of four vectors
c
      j = mod(n2,8)
      if (j .ge. 4) then
         do 30 i = 1, n1
            y(i) = ((( (y(i))
     $             + x(j-3)*m(i,j-3)) + x(j-2)*m(i,j-2))
     $             + x(j-1)*m(i,j-1)) + x(j)  *m(i,j)
   30    continue
      endif
c
c   cleanup odd group of eight vectors
c
      j = mod(n2,16)
      if (j .ge. 8) then
         do 40 i = 1, n1
            y(i) = ((((((( (y(i))
     $             + x(j-7)*m(i,j-7)) + x(j-6)*m(i,j-6))
     $             + x(j-5)*m(i,j-5)) + x(j-4)*m(i,j-4))
     $             + x(j-3)*m(i,j-3)) + x(j-2)*m(i,j-2))
     $             + x(j-1)*m(i,j-1)) + x(j)  *m(i,j)
   40    continue
      endif
c
c   main loop - groups of sixteen vectors
c
      jmin = j+16
      do 60 j = jmin, n2, 16
         do 50 i = 1, n1
            y(i) = ((((((((((((((( (y(i))
     $             + x(j-15)*m(i,j-15)) + x(j-14)*m(i,j-14))
     $             + x(j-13)*m(i,j-13)) + x(j-12)*m(i,j-12))
     $             + x(j-11)*m(i,j-11)) + x(j-10)*m(i,j-10))
     $             + x(j- 9)*m(i,j- 9)) + x(j- 8)*m(i,j- 8))
     $             + x(j- 7)*m(i,j- 7)) + x(j- 6)*m(i,j- 6))
     $             + x(j- 5)*m(i,j- 5)) + x(j- 4)*m(i,j- 4))
     $             + x(j- 3)*m(i,j- 3)) + x(j- 2)*m(i,j- 2))
     $             + x(j- 1)*m(i,j- 1)) + x(j)   *m(i,j)
   50    continue
   60 continue
      return
      end
      DOUBLE PRECISION FUNCTION RAN( ISEED )
*
*     modified from the LAPACK auxiliary routine 10/12/92 JD
*  -- LAPACK auxiliary routine (version 1.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     February 29, 1992
*
*     .. Array Arguments ..
      INTEGER            ISEED( 4 )
*     ..
*
*  Purpose
*  =======
*
*  DLARAN returns a random real number from a uniform (0,1)
*  distribution.
*
*  Arguments
*  =========
*
*  ISEED   (input/output) INTEGER array, dimension (4)
*          On entry, the seed of the random number generator; the array
*          elements must be between 0 and 4095, and ISEED(4) must be
*          odd.
*          On exit, the seed is updated.
*
*  Further Details
*  ===============
*
*  This routine uses a multiplicative congruential method with modulus
*  2**48 and multiplier 33952834046453 (see G.S.Fishman,
*  'Multiplicative congruential random number generators with modulus
*  2**b: an exhaustive analysis for b = 32 and a partial analysis for
*  b = 48', Math. Comp. 189, pp 331-344, 1990).
*
*  48-bit integers are stored in 4 integer array elements with 12 bits
*  per element. Hence the routine is portable across machines with
*  integers of 32 bits or more.
*
*     .. Parameters ..
      INTEGER            M1, M2, M3, M4
      PARAMETER          ( M1 = 494, M2 = 322, M3 = 2508, M4 = 2549 )
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D+0 )
      INTEGER            IPW2
      DOUBLE PRECISION   R
      PARAMETER          ( IPW2 = 4096, R = ONE / IPW2 )
*     ..
*     .. Local Scalars ..
      INTEGER            IT1, IT2, IT3, IT4
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          DBLE, MOD
*     ..
*     .. Executable Statements ..
*
*     multiply the seed by the multiplier modulo 2**48
*
      IT4 = ISEED( 4 )*M4
      IT3 = IT4 / IPW2
      IT4 = IT4 - IPW2*IT3
      IT3 = IT3 + ISEED( 3 )*M4 + ISEED( 4 )*M3
      IT2 = IT3 / IPW2
      IT3 = IT3 - IPW2*IT2
      IT2 = IT2 + ISEED( 2 )*M4 + ISEED( 3 )*M3 + ISEED( 4 )*M2
      IT1 = IT2 / IPW2
      IT2 = IT2 - IPW2*IT1
      IT1 = IT1 + ISEED( 1 )*M4 + ISEED( 2 )*M3 + ISEED( 3 )*M2 +
     $      ISEED( 4 )*M1
      IT1 = MOD( IT1, IPW2 )
*
*     return updated seed
*
      ISEED( 1 ) = IT1
      ISEED( 2 ) = IT2
      ISEED( 3 ) = IT3
      ISEED( 4 ) = IT4
*
*     convert 48-bit integer to a real number in the interval (0,1)
*
      RAN = R*( DBLE( IT1 )+R*( DBLE( IT2 )+R*( DBLE( IT3 )+R*
     $         ( DBLE( IT4 ) ) ) ) )
      RETURN
*
*     End of RAN
*
      END


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

*   Intrinsics and generics: SQRT, EXP, LOG, LOG10.

	program p
	implicit double precision (d)
	parameter(n = 21)
	integer rslts(n), expect(n)

	data d25, d36 / 25d0, 36d0 /
	data x5       / 5.0 /

c --- tests 1 - 5:    SQRT

	rslts(1) = sqrt(25.0) + .0001
	rslts(2) = .0001 + dsqrt(d36)
	rslts(3) = idnint( sqrt(d25) )
	rslts(4) = real(csqrt((-3.0, 4.0))) * 100 + .0001
	rslts(5) = nint( aimag(sqrt((-3.0, 4.0))) )

c --- tests 6 - 9:    EXP

	rslts(6) = 1000 * exp(1.0)
	rslts(7) = dexp(-1.0d0) * 1000
	rslts(8) = cexp( clog( (11.1, -13.1) ) )
	rslts(9) = aimag( exp( clog( (11.1, -13.1) ) ) )

c --- tests 10 - 13:  LOG

	rslts(10) = alog(x5 + x5) * 1000
	rslts(11) = dlog(d25 - 21) * 1000
	rslts(12) = clog( (10.0, 0.0) ) * 1000
	rslts(13) = log ( exp(-17.1d0) )

c --- tests 14 - 16:  LOG10

	rslts(14) = nint( log10(2 * x5) )
	rslts(15) = 1000 * alog10( float(2) )
	rslts(16) = dlog10( 1.001d25 )

c --- tests 17 - 18:    CDSQRT

	rslts(17) = real(cdsqrt((-3.0d0, 4.0d0))) * 100 + .0001
	rslts(18) = nint( dimag(sqrt((-3.0d0, 4.0d0))) )

c --- tests 19 - 20:    CDEXP

	rslts(19) = cdexp( cdlog( (11.1d0, -13.1d0) ) )
	rslts(20) = dimag( exp( cdlog( (11.1d0, -13.1d0) ) ) )

c --- tests 21 :  LOG

	rslts(21) = cdlog( (10.0d0, 0.0d0) ) * 1000

c --- check results:

	call check(rslts, expect, n)

	data expect / 5, 6, 5, 100, 2,
     +                2718, 367, 11, -13,
     +                2302, 1386, 2302, -17,
     +                1, 301, 25,
     +		      100,2,11,-13,2302 /
     /
	end


c     Demo using FINUFFT for double-precision 1d transforms in legacy fortran.
c     Does types 1,2,3, including math test against direct summation.
c     Default opts only (see simple1d1 for how to change opts).
c
c     A slight modification of drivers from the CMCL NUFFT, (C) 2004-2009,
c     Leslie Greengard and June-Yub Lee. See: cmcl_license.txt.
c
c     Tweaked by Alex Barnett to call FINUFFT 2/17/17.
c     dyn malloc; type 2 uses same input data fk0, 3/8/17
c     Also see: ../README.
c
c     Compile with, eg (GCC, multithreaded, static lib; paste to a single line):
c
c     gfortran nufft1d_demo.f ../directft/dirft1d.f -o nufft1d_demo
c     ../../lib-static/libfinufft.a -lstdc++ -lfftw3 -lfftw3_omp -lm -fopenmp
c
      program nufft1d_demo
      implicit none

c     our fortran-header, always needed
      include 'finufft.fh'
c
c --- local variables
c
      integer i,ier,iflag,j,k1,mx
      integer*8 ms,nj
      real*8, allocatable :: xj(:),sk(:)
      real*8 err,eps,pi
      parameter (pi=3.141592653589793238462643383279502884197d0)
      complex*16, allocatable :: cj(:),cj0(:),cj1(:),fk0(:),fk1(:)
c     for default opts, make a null pointer...
      type(nufft_opts), pointer :: defopts => null()

c
c     --------------------------------------------------
c     create some test data
c     --------------------------------------------------
      ms = 90
      nj = 128
c     first alloc everything
      allocate(fk0(ms))
      allocate(fk1(ms))
      allocate(sk(ms))
      allocate(xj(nj))
      allocate(cj(nj))
      allocate(cj0(nj))
      allocate(cj1(nj))
      do k1 = -nj/2, (nj-1)/2
         j = k1+nj/2+1
         xj(j) = pi * dcos(-pi*j/nj)
         cj(j) = dcmplx( dsin(pi*j/nj), dcos(pi*j/nj))
      enddo
c
c     --------------------------------------------------
c     start tests
c     --------------------------------------------------
c
      iflag = 1
      print*,' Start 1D testing: ', ' nj =',nj, ' ms =',ms
      do i = 1,4
         if (i.eq.1) eps=1d-4
         if (i.eq.2) eps=1d-8
         if (i.eq.3) eps=1d-12
         if (i.eq.4) eps=1d-16
	 print*,' '
  	 print*,' Requested precision eps =',eps
	 print*,' '
c
c     -----------------------
c     call 1D Type1 method
c     -----------------------
c
         call dirft1d1(nj,xj,cj,iflag, ms,fk0)
         call finufft1d1(nj,xj,cj,iflag,eps,ms,fk1,defopts,ier)
         call errcomp(fk0,fk1,ms,err)
         print *,' ier = ',ier
         print *,' type 1 error = ',err
c
c     -----------------------
c     call 1D Type2 method
c     -----------------------
c
         call dirft1d2(nj,xj,cj0,iflag, ms,fk0,ier)
         call finufft1d2(nj,xj,cj1,iflag, eps, ms,fk0,defopts,ier)
         call errcomp(cj0,cj1,nj,err)
         print *,' ier = ',ier
         print *,' type 2 error = ',err
c
c     -----------------------
c     call 1D Type3 method
c     -----------------------
         do k1 = 1, ms
            sk(k1) = 48*dcos(k1*pi/ms)
         enddo
         call dirft1d3(nj,xj,cj,iflag, ms,sk,fk0)
         call finufft1d3(nj,xj,cj,iflag,eps, ms,sk,fk1,defopts,ier)
         call errcomp(cj0,cj1,nj,err)
         print *,' ier = ',ier
         print *,' type 3 error = ',err
      enddo
      stop
      end
c
c
c
c
c
      subroutine errcomp(fk0,fk1,n,err)
      implicit none
      integer*8 k,n
      complex*16 fk0(n), fk1(n)
      real *8 salg,ealg,err
c
      ealg = 0d0
      salg = 0d0
      do k = 1, n
         ealg = ealg + cdabs(fk1(k)-fk0(k))**2
         salg = salg + cdabs(fk0(k))**2
      enddo
      err =sqrt(ealg/salg)
      return
      end


program test_spherical_bessel_yn
  use types, only: dp
  use utils, only: assert
  use special, only: spherical_bessel_yn
  implicit none

  ! check a few value against the ones computed with SciPy:
  ! note we use a rather 'large' eps - SciPy computes some the values we compare
  ! to with CEPHES whereas we use AMOS

  integer :: i
  real(dp), parameter :: eps = 1e-13_dp
  integer, parameter :: ordersReal(7) = [0,  1,  2,  3,  4,  5,  6]
  real(dp),  parameter :: xReal(7) = [1.1_dp,  3.0_dp,  10.0_dp,  2.1_dp,  5.5_dp,  1.1_dp,  2.0_dp]
  real(dp), parameter :: correctResultsRealArg(7) = [-0.4123601103868884_dp, 0.06295916360231597_dp, &
       & -0.0650693049937348_dp, -1.2845701875051379_dp, -0.10423608124826822_dp, -570.9016520477184_dp, -97.79165768518729_dp]

  ! test real argument with integer order:
  do i = 1,7
     call assert(abs(spherical_bessel_yn(ordersReal(i), xReal(i)) - correctResultsRealArg(i)) < eps)
  end do

end program test_spherical_bessel_yn