      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.7.
C
C     Copyright (c) 2002-2020 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, June 2014.
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
      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
      EPS    = TOL( 2 )
      SMLNUM = TOL( 3 )
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


module compute_flux_module

  implicit none

  private

  public :: &
       godunov_flux_3d, &
       mol2ndord_flux_3d, &
       mol4thord_flux_3d_limited, &
       mol4thord_flux_3d_nolimit

contains

  subroutine godunov_flux_3d(lo, hi, dt, dx, &
                             phi,ph_lo,ph_hi, &
                             umac,  u_lo,  u_hi, &
                             vmac,  v_lo,  v_hi, &
                             wmac,  w_lo,  w_hi, &
                             flxx, fx_lo, fx_hi, &
                             flxy, fy_lo, fy_hi, &
                             flxz, fz_lo, fz_hi, &
                             phix, phix_y, phix_z, &
                             phiy, phiy_x, phiy_z, &
                             phiz, phiz_x, phiz_y, &
                             slope, glo, ghi, nu, uselimit)

    use slope_module, only: slopex, slopey, slopez,slopex_nolim, slopey_nolim, slopez_nolim

    integer, intent(in) :: lo(3), hi(3), glo(3), ghi(3), uselimit
    double precision, intent(in) :: dt, dx(3), nu
    integer, intent(in) :: ph_lo(3), ph_hi(3)
    integer, intent(in) ::  u_lo(3),  u_hi(3)
    integer, intent(in) ::  v_lo(3),  v_hi(3)
    integer, intent(in) ::  w_lo(3),  w_hi(3)
    integer, intent(in) :: fx_lo(3), fx_hi(3)
    integer, intent(in) :: fy_lo(3), fy_hi(3)
    integer, intent(in) :: fz_lo(3), fz_hi(3)
    double precision, intent(in   ) :: phi (ph_lo(1):ph_hi(1),ph_lo(2):ph_hi(2),ph_lo(3):ph_hi(3))
    double precision, intent(in   ) :: umac( u_lo(1): u_hi(1), u_lo(2): u_hi(2), u_lo(3): u_hi(3))
    double precision, intent(in   ) :: vmac( v_lo(1): v_hi(1), v_lo(2): v_hi(2), v_lo(3): v_hi(3))
    double precision, intent(in   ) :: wmac( w_lo(1): w_hi(1), w_lo(2): w_hi(2), w_lo(3): w_hi(3))
    double precision, intent(  out) :: flxx(fx_lo(1):fx_hi(1),fx_lo(2):fx_hi(2),fx_lo(3):fx_hi(3))
    double precision, intent(  out) :: flxy(fy_lo(1):fy_hi(1),fy_lo(2):fy_hi(2),fy_lo(3):fy_hi(3))
    double precision, intent(  out) :: flxz(fz_lo(1):fz_hi(1),fz_lo(2):fz_hi(2),fz_lo(3):fz_hi(3))
    double precision, dimension(glo(1):ghi(1),glo(2):ghi(2),glo(3):ghi(3)) :: &
         phix, phix_y, phix_z, phiy, phiy_x, phiy_z, phiz, phiz_x, phiz_y, slope

    integer :: i, j, k
    double precision :: hdtdx(3), tdtdx(3)

    hdtdx = 0.5*(dt/dx)
    tdtdx = (1.d0/3.d0)*(dt/dx)

    if(uselimit .eq. 0) then
       call slopex_nolim(glo, ghi, &
            phi, ph_lo, ph_hi, &
            slope, glo, ghi)
    else
       call slopex(glo, ghi, &
            phi, ph_lo, ph_hi, &
            slope, glo, ghi)
    endif

    ! compute phi on x faces using umac to upwind; ignore transverse terms
    do       k = lo(3)-1, hi(3)+1
       do    j = lo(2)-1, hi(2)+1
          do i = lo(1)  , hi(1)+1

             if (umac(i,j,k) .lt. 0.d0) then
                phix(i,j,k) = phi(i  ,j,k) - (0.5d0 + hdtdx(1)*umac(i,j,k))*slope(i  ,j,k)
             else
                phix(i,j,k) = phi(i-1,j,k) + (0.5d0 - hdtdx(1)*umac(i,j,k))*slope(i-1,j,k)
             end if

          end do
       end do
    end do

    if(uselimit .eq. 0) then
       call slopey_nolim(glo, ghi, &
            phi, ph_lo, ph_hi, &
            slope, glo, ghi)
    else
       call slopey(glo, ghi, &
            phi, ph_lo, ph_hi, &
            slope, glo, ghi)
    endif

    ! compute phi on y faces using vmac to upwind; ignore transverse terms
    do       k = lo(3)-1, hi(3)+1
       do    j = lo(2)  , hi(2)+1
          do i = lo(1)-1, hi(1)+1

             if (vmac(i,j,k) .lt. 0.d0) then
                phiy(i,j,k) = phi(i,j  ,k) - (0.5d0 + hdtdx(2)*vmac(i,j,k))*slope(i,j  ,k)
             else
                phiy(i,j,k) = phi(i,j-1,k) + (0.5d0 - hdtdx(2)*vmac(i,j,k))*slope(i,j-1,k)
             end if

          end do
       end do
    end do

    if(uselimit .eq. 0) then
       call slopez_nolim(glo, ghi, &
            phi, ph_lo, ph_hi, &
            slope, glo, ghi)
    else
       call slopez(glo, ghi, &
            phi, ph_lo, ph_hi, &
            slope, glo, ghi)
    endif

    ! compute phi on z faces using wmac to upwind; ignore transverse terms
    do       k = lo(3)  , hi(3)+1
       do    j = lo(2)-1, hi(2)+1
          do i = lo(1)-1, hi(1)+1

             if (wmac(i,j,k) .lt. 0.d0) then
                phiz(i,j,k) = phi(i,j,k  ) - (0.5d0 + hdtdx(3)*wmac(i,j,k))*slope(i,j,k  )
             else
                phiz(i,j,k) = phi(i,j,k-1) + (0.5d0 - hdtdx(3)*wmac(i,j,k))*slope(i,j,k-1)
             end if

          end do
       end do
    end do

    !!!!!!!!!!!!!!!!!!!!
    ! transverse terms
    !!!!!!!!!!!!!!!!!!!!

    ! update phi on x faces by adding in y-transverse terms
    do       k=lo(3)-1, hi(3)+1
       do    j=lo(2)  , hi(2)
          do i=lo(1)  , hi(1)+1

             if (umac(i,j,k) .lt. 0.d0) then
                phix_y(i,j,k) = phix(i,j,k) &
                     - tdtdx(2) * (0.5d0*(vmac(i  ,j+1,k)+vmac(i  ,j,k)) * (phiy(i  ,j+1,k)-phiy(i  ,j,k)) )
             else
                phix_y(i,j,k) = phix(i,j,k) &
                     - tdtdx(2) * (0.5d0*(vmac(i-1,j+1,k)+vmac(i-1,j,k)) * (phiy(i-1,j+1,k)-phiy(i-1,j,k)) )
             end if

          end do
       end do
    end do

    ! update phi on x faces by adding in z-transverse terms
    do       k=lo(3)  , hi(3)
       do    j=lo(2)-1, hi(2)+1
          do i=lo(1)  , hi(1)+1

             if (umac(i,j,k) .lt. 0.d0) then
                phix_z(i,j,k) = phix(i,j,k) &
                     - tdtdx(3) * (0.5d0*(wmac(i  ,j,k+1)+wmac(i  ,j,k)) * (phiz(i  ,j,k+1)-phiz(i  ,j,k)) )
             else
                phix_z(i,j,k) = phix(i,j,k) &
                     - tdtdx(3) * (0.5d0*(wmac(i-1,j,k+1)+wmac(i-1,j,k)) * (phiz(i-1,j,k+1)-phiz(i-1,j,k)) )
             end if

          end do
       end do
    end do

    ! update phi on y faces by adding in x-transverse terms
    do       k = lo(3)-1, hi(3)+1
       do    j = lo(2)  , hi(2)+1
          do i = lo(1)  , hi(1)

             if (vmac(i,j,k) .lt. 0.d0) then
                phiy_x(i,j,k) = phiy(i,j,k) &
                     - tdtdx(1) * (0.5d0*(umac(i+1,j  ,k)+umac(i,j  ,k)) * (phix(i+1,j  ,k)-phix(i,j  ,k)) )
             else
                phiy_x(i,j,k) = phiy(i,j,k) &
                     - tdtdx(1) * (0.5d0*(umac(i+1,j-1,k)+umac(i,j-1,k)) * (phix(i+1,j-1,k)-phix(i,j-1,k)) )
             end if

          end do
       end do
    end do

    ! update phi on y faces by adding in z-transverse terms
    do       k = lo(3)  , hi(3)
       do    j = lo(2)  , hi(2)+1
          do i = lo(1)-1, hi(1)+1

             if (vmac(i,j,k) .lt. 0.d0) then
                phiy_z(i,j,k) = phiy(i,j,k) &
                     - tdtdx(3) * (0.5d0*(wmac(i,j  ,k+1)+wmac(i,j  ,k)) * (phiz(i,j  ,k+1)-phiz(i,j  ,k)) )
             else
                phiy_z(i,j,k) = phiy(i,j,k) &
                     - tdtdx(3) * (0.5d0*(wmac(i,j-1,k+1)+wmac(i,j-1,k)) * (phiz(i,j-1,k+1)-phiz(i,j-1,k)) )
             end if

          end do
       end do
    end do

    ! update phi on z faces by adding in x-transverse terms
    do       k = lo(3)  , hi(3)+1
       do    j = lo(2)-1, hi(2)+1
          do i = lo(1)  , hi(1)

             if (wmac(i,j,k) .lt. 0.d0) then
                phiz_x(i,j,k) = phiz(i,j,k) &
                     - tdtdx(1) * (0.5d0*(umac(i+1,j,k  )+umac(i,j,k  )) * (phix(i+1,j,k  )-phix(i,j,k  )) )
             else
                phiz_x(i,j,k) = phiz(i,j,k) &
                     - tdtdx(1) * (0.5d0*(umac(i+1,j,k-1)+umac(i,j,k-1)) * (phix(i+1,j,k-1)-phix(i,j,k-1)) )
             end if

          end do
       end do
    end do

    ! update phi on z faces by adding in y-transverse terms
    do       k = lo(3)  , hi(3)+1
       do    j = lo(2)  , hi(2)
          do i = lo(1)-1, hi(1)+1

             if (wmac(i,j,k) .lt. 0.d0) then
                phiz_y(i,j,k) = phiz(i,j,k) &
                     - tdtdx(2) * (0.5d0*(vmac(i,j+1,k  )+vmac(i,j,k  )) * (phiy(i,j+1,k  )-phiy(i,j,k  )) )
             else
                phiz_y(i,j,k) = phiz(i,j,k) &
                     - tdtdx(2) * (0.5d0*(vmac(i,j+1,k-1)+vmac(i,j,k-1)) * (phiy(i,j+1,k-1)-phiy(i,j,k-1)) )
             end if

          end do
       end do
    end do

    !!!!!!!!!!!!!!!!!!!!
    ! final edge states
    !!!!!!!!!!!!!!!!!!!!

    ! update phi on x faces by adding in yz and zy transverse terms
    do       k = lo(3), hi(3)
       do    j = lo(2), hi(2)
          do i = lo(1), hi(1)+1

             if (umac(i,j,k) .lt. 0.d0) then
                phix(i,j,k) = phix(i,j,k) &
                     - hdtdx(2)*( 0.5d0*(vmac(i  ,j+1,k  )+vmac(i  ,j,k)) * (phiy_z(i  ,j+1,k  )-phiy_z(i  ,j,k)) ) &
                     - hdtdx(3)*( 0.5d0*(wmac(i  ,j  ,k+1)+wmac(i  ,j,k)) * (phiz_y(i  ,j  ,k+1)-phiz_y(i  ,j,k)) )
             else
                phix(i,j,k) = phix(i,j,k) &
                     - hdtdx(2)*( 0.5d0*(vmac(i-1,j+1,k  )+vmac(i-1,j,k)) * (phiy_z(i-1,j+1,k  )-phiy_z(i-1,j,k)) ) &
                     - hdtdx(3)*( 0.5d0*(wmac(i-1,j  ,k+1)+wmac(i-1,j,k)) * (phiz_y(i-1,j  ,k+1)-phiz_y(i-1,j,k)) )
             end if

             ! compute final x-fluxes
             ! including diffusive fluxes
             flxx(i,j,k) = umac(i,j,k)*phix(i,j,k) - nu*(phi(i,j,k) - phi(i-1,j,k))/dx(1)

          end do
       end do
    end do

    ! update phi on y faces by adding in xz and zx transverse terms
    do       k = lo(3), hi(3)
       do    j = lo(2), hi(2)+1
          do i = lo(1), hi(1)

             if (vmac(i,j,k) .lt. 0.d0) then
                phiy(i,j,k) = phiy(i,j,k) &
                     - hdtdx(1)*( 0.5d0*(umac(i+1,j  ,k  )+umac(i,j  ,k)) * (phix_z(i+1,j  ,k  )-phix_z(i,j  ,k)) ) &
                     - hdtdx(3)*( 0.5d0*(wmac(i  ,j  ,k+1)+wmac(i,j  ,k)) * (phiz_x(i  ,j  ,k+1)-phiz_x(i,j  ,k)) )
             else
                phiy(i,j,k) = phiy(i,j,k) &
                     - hdtdx(1)*( 0.5d0*(umac(i+1,j-1,k  )+umac(i,j-1,k)) * (phix_z(i+1,j-1,k  )-phix_z(i,j-1,k)) ) &
                     - hdtdx(3)*( 0.5d0*(wmac(i  ,j-1,k+1)+wmac(i,j-1,k)) * (phiz_x(i  ,j-1,k+1)-phiz_x(i,j-1,k)) )
             end if

             ! compute final y-fluxes
             !(including diffusive fluxes)
             flxy(i,j,k) = vmac(i,j,k)*phiy(i,j,k) - nu*(phi(i,j,k) - phi(i,j-1,k))/dx(1)

          end do
       end do
    end do

    ! update phi on z faces by adding in xy and yx transverse terms
    do       k = lo(3), hi(3)+1
       do    j = lo(2), hi(2)
          do i = lo(1), hi(1)

             if (wmac(i,j,k) .lt. 0.d0) then
                phiz(i,j,k) = phiz(i,j,k) &
                     - hdtdx(1)*( 0.5d0*(umac(i+1,j  ,k  )+umac(i  ,j,k)) * (phix_y(i+1,j  ,k  )-phix_y(i,j,k  )) ) &
                     - hdtdx(2)*( 0.5d0*(vmac(i  ,j+1,k  )+vmac(i  ,j,k)) * (phiy_x(i  ,j+1,k  )-phiy_x(i,j,k  )) )
             else
                phiz(i,j,k) = phiz(i,j,k) &
                     - hdtdx(1)*( 0.5d0*(umac(i+1,j  ,k-1)+umac(i,j,k-1)) * (phix_y(i+1,j  ,k-1)-phix_y(i,j,k-1)) ) &
                     - hdtdx(2)*( 0.5d0*(vmac(i  ,j+1,k-1)+vmac(i,j,k-1)) * (phiy_x(i  ,j+1,k-1)-phiy_x(i,j,k-1)) )
             end if

             ! compute final z-fluxes
             !(including diffusive fluxes)
             flxz(i,j,k) = wmac(i,j,k)*phiz(i,j,k) - nu*(phi(i,j,k) - phi(i,j,k-1))/dx(2)

          end do
       end do
    end do

  end subroutine godunov_flux_3d

  subroutine mol2ndord_flux_3d(lo, hi, dt, dx, &
                               phi,ph_lo,ph_hi, &
                               umac,  u_lo,  u_hi, &
                               vmac,  v_lo,  v_hi, &
                               wmac,  w_lo,  w_hi, &
                               flxx, fx_lo, fx_hi, &
                               flxy, fy_lo, fy_hi, &
                               flxz, fz_lo, fz_hi, &
                               phix, phiy,  phiz, &
                               slope, glo, ghi, nu, uselimit)

    use slope_module, only: slopex, slopey, slopez,slopex_nolim, slopey_nolim, slopez_nolim

    integer, intent(in) :: lo(3), hi(3), glo(3), ghi(3), uselimit
    double precision, intent(in) :: dt, dx(3), nu
    integer, intent(in) :: ph_lo(3), ph_hi(3)
    integer, intent(in) ::  u_lo(3),  u_hi(3)
    integer, intent(in) ::  v_lo(3),  v_hi(3)
    integer, intent(in) ::  w_lo(3),  w_hi(3)
    integer, intent(in) :: fx_lo(3), fx_hi(3)
    integer, intent(in) :: fy_lo(3), fy_hi(3)
    integer, intent(in) :: fz_lo(3), fz_hi(3)
    double precision, intent(in   ) :: phi (ph_lo(1):ph_hi(1),ph_lo(2):ph_hi(2),ph_lo(3):ph_hi(3))
    double precision, intent(in   ) :: umac( u_lo(1): u_hi(1), u_lo(2): u_hi(2), u_lo(3): u_hi(3))
    double precision, intent(in   ) :: vmac( v_lo(1): v_hi(1), v_lo(2): v_hi(2), v_lo(3): v_hi(3))
    double precision, intent(in   ) :: wmac( w_lo(1): w_hi(1), w_lo(2): w_hi(2), w_lo(3): w_hi(3))
    double precision, intent(  out) :: flxx(fx_lo(1):fx_hi(1),fx_lo(2):fx_hi(2),fx_lo(3):fx_hi(3))
    double precision, intent(  out) :: flxy(fy_lo(1):fy_hi(1),fy_lo(2):fy_hi(2),fy_lo(3):fy_hi(3))
    double precision, intent(  out) :: flxz(fz_lo(1):fz_hi(1),fz_lo(2):fz_hi(2),fz_lo(3):fz_hi(3))
    double precision, dimension(glo(1):ghi(1),glo(2):ghi(2),glo(3):ghi(3)) :: &
         phix, phiy, phiz, slope

    integer :: i, j, k

    if(uselimit .eq. 0) then
       call slopex_nolim(glo, ghi, &
            phi, ph_lo, ph_hi, &
            slope, glo, ghi)
    else
       call slopex(glo, ghi, &
            phi, ph_lo, ph_hi, &
            slope, glo, ghi)
    endif

    ! compute phi on x faces using umac to upwind
    do       k = lo(3)-1, hi(3)+1
       do    j = lo(2)-1, hi(2)+1
          do i = lo(1)  , hi(1)+1

             if (umac(i,j,k) .lt. 0.d0) then
                phix(i,j,k) = phi(i  ,j,k) - (0.5d0)*slope(i  ,j,k)
             else
                phix(i,j,k) = phi(i-1,j,k) + (0.5d0)*slope(i-1,j,k)
             end if

          end do
       end do
    end do

    if(uselimit .eq. 0) then
       call slopey_nolim(glo, ghi, &
            phi, ph_lo, ph_hi, &
            slope, glo, ghi)
    else
       call slopey(glo, ghi, &
            phi, ph_lo, ph_hi, &
            slope, glo, ghi)
    endif

    ! compute phi on y faces using vmac to upwind
    do       k = lo(3)-1, hi(3)+1
       do    j = lo(2)  , hi(2)+1
          do i = lo(1)-1, hi(1)+1

             if (vmac(i,j,k) .lt. 0.d0) then
                phiy(i,j,k) = phi(i,j  ,k) - (0.5d0)*slope(i,j  ,k)
             else
                phiy(i,j,k) = phi(i,j-1,k) + (0.5d0)*slope(i,j-1,k)
             end if

          end do
       end do
    end do

    if(uselimit .eq. 0) then
       call slopez_nolim(glo, ghi, &
            phi, ph_lo, ph_hi, &
            slope, glo, ghi)
    else
       call slopez(glo, ghi, &
            phi, ph_lo, ph_hi, &
            slope, glo, ghi)
    endif

    ! compute phi on z faces using wmac to upwind
    do       k = lo(3)  , hi(3)+1
       do    j = lo(2)-1, hi(2)+1
          do i = lo(1)-1, hi(1)+1

             if (wmac(i,j,k) .lt. 0.d0) then
                phiz(i,j,k) = phi(i,j,k  ) - (0.5d0)*slope(i,j,k  )
             else
                phiz(i,j,k) = phi(i,j,k-1) + (0.5d0)*slope(i,j,k-1)
             end if

          end do
       end do
    end do

    do       k = lo(3), hi(3)
       do    j = lo(2), hi(2)
          do i = lo(1), hi(1)+1

             ! compute final x-fluxes
             ! including diffusive fluxes
             flxx(i,j,k) = umac(i,j,k)*phix(i,j,k) - nu*(phi(i,j,k) - phi(i-1,j,k))/dx(1)

          end do
       end do
    end do

    do       k = lo(3), hi(3)
       do    j = lo(2), hi(2)+1
          do i = lo(1), hi(1)

             ! compute final y-fluxes
             !(including diffusive fluxes)
             flxy(i,j,k) = vmac(i,j,k)*phiy(i,j,k) - nu*(phi(i,j,k) - phi(i,j-1,k))/dx(2)

          end do
       end do
    end do

    ! update phi on z faces by adding in xy and yx transverse terms
    do       k = lo(3), hi(3)+1
       do    j = lo(2), hi(2)
          do i = lo(1), hi(1)

             ! compute final z-fluxes
             !(including diffusive fluxes)
             flxz(i,j,k) = wmac(i,j,k)*phiz(i,j,k) - nu*(phi(i,j,k) - phi(i,j,k-1))/dx(3)

          end do
       end do
    end do

  end subroutine mol2ndord_flux_3d

  !phi coming in is assumed to be cell-averaged
  !velocity is pointwise on faces --- this version has no limiting
  subroutine mol4thord_flux_3d_nolimit(&
       lo, hi, dt, dx, &
       phi ,ph_lo,ph_hi, &
       umac,  u_lo,  u_hi, &
       vmac,  v_lo,  v_hi, &
       wmac,  w_lo,  w_hi, &
       flxx, fx_lo, fx_hi, &
       flxy, fy_lo, fy_hi, &
       flxz, fz_lo, fz_hi, &
       fluxptx, phiptx, phiavex, &
       fluxpty, phipty, phiavey, &
       fluxptz, phiptz, phiavez, &
       phiptcc, glo, ghi, nu, &
       deblocell, debhicell, &
       hisidedebfacelo, hisidedebfacehi, &
       losidedebfacelo, losidedebfacehi, printstuff)

    integer, intent(in) :: lo(3), hi(3), glo(3), ghi(3), printstuff
    integer, intent(in) :: deblocell(3), debhicell(3)
    integer, intent(in) :: hisidedebfacelo(3), hisidedebfacehi(3)
    integer, intent(in) :: losidedebfacelo(3), losidedebfacehi(3)
    double precision, intent(in) :: dt, dx(3), nu
    integer, intent(in) :: ph_lo(3), ph_hi(3)
    integer, intent(in) ::  u_lo(3),  u_hi(3)
    integer, intent(in) ::  v_lo(3),  v_hi(3)
    integer, intent(in) ::  w_lo(3),  w_hi(3)
    integer, intent(in) :: fx_lo(3), fx_hi(3)
    integer, intent(in) :: fy_lo(3), fy_hi(3)
    integer, intent(in) :: fz_lo(3), fz_hi(3)
    double precision, intent(in   ) :: phi (ph_lo(1):ph_hi(1),ph_lo(2):ph_hi(2),ph_lo(3):ph_hi(3))
    double precision, intent(in   ) :: umac( u_lo(1): u_hi(1), u_lo(2): u_hi(2), u_lo(3): u_hi(3))
    double precision, intent(in   ) :: vmac( v_lo(1): v_hi(1), v_lo(2): v_hi(2), v_lo(3): v_hi(3))
    double precision, intent(in   ) :: wmac( w_lo(1): w_hi(1), w_lo(2): w_hi(2), w_lo(3): w_hi(3))
    double precision, intent(  out) :: flxx(fx_lo(1):fx_hi(1),fx_lo(2):fx_hi(2),fx_lo(3):fx_hi(3))
    double precision, intent(  out) :: flxy(fy_lo(1):fy_hi(1),fy_lo(2):fy_hi(2),fy_lo(3):fy_hi(3))
    double precision, intent(  out) :: flxz(fz_lo(1):fz_hi(1),fz_lo(2):fz_hi(2),fz_lo(3):fz_hi(3))
    double precision, dimension(glo(1):ghi(1),glo(2):ghi(2),glo(3):ghi(3)) :: &
         fluxptx, fluxpty, fluxptz,  phiptx, phipty, phiptz, phiavex, phiavey, phiavez, phiptcc

    double precision :: diffflux
    integer :: i, j, k

    !STEP 0
    ! 2.1 get cell-centered phi so we can compute a pointwise, fourth order gradient at faces
    ! needed  for diffusive fluxes

    do       k = lo(3)-3, hi(3)+3
       do    j = lo(2)-3, hi(2)+3
          do i = lo(1)-3, hi(1)+3
             phiptcc(i,j,k)  = phi(i,j,k) - (1.0d0/24.d0)* &
                  (phi(i+1,j  ,k  )+phi(i-1,j  ,k  )&
                  +phi(i  ,j+1,k  )+phi(i  ,j-1,k  )&
                  +phi(i  ,j  ,k+1)+phi(i  ,j  ,k-1)&
                  -6.d0*phi(i,j,k))
          end do
       end do
    end do
    ! STEP ONE--- HYPERBOLIC FLUXES
    ! compute face average phi on x faces via eqn 17 of mccorquodale, colella
    do       k = lo(3)-2, hi(3)+2
       do    j = lo(2)-2, hi(2)+2
          do i = lo(1)  , hi(1)+1

             phiavex(i,j,k)  = &
                  (7.d0/12.d0)*(phi(i  ,j,k) + phi(i-1,j,k)) &
                 -(1.d0/12.d0)*(phi(i-2,j,k) + phi(i+1,j,k))

          end do
       end do
    end do

    !same for y faces
    do       k = lo(3)-2, hi(3)+2
       do    j = lo(2)  , hi(2)+1
          do i = lo(1)-2, hi(1)+2

             phiavey(i,j,k)  = &
                  (7.d0/12.d0)*(phi(i,j  ,k) + phi(i,j-1,k)) &
                 -(1.d0/12.d0)*(phi(i,j-2,k) + phi(i,j+1,k))

          end do
       end do
    end do
    !same for z faces
    do       k = lo(3)  , hi(3)+1
       do    j = lo(2)-2, hi(2)+2
          do i = lo(1)-2, hi(1)+2

             phiavez(i,j,k)  = &
                  (7.d0/12.d0)*(phi(i,j,k  ) + phi(i,j,k-1)) &
                 -(1.d0/12.d0)*(phi(i,j,k-2) + phi(i,j,k+1))

          end do
       end do
    end do

    !now get point valued phi at faces so we can multiply by point valued velocity
    ! phipt = phiave - (h^2/24)*(lapl^2d(phi_ave))
    ! while I am at it, multiply in pointwise velocity so we get pointwise *HYPERBOLIC* flux
    !also  get pointwise diffusive fluxes using 4th order finite differences of pointwise phi

    do       k = lo(3)-1, hi(3)+1
       do    j = lo(2)-1, hi(2)+1
          do i = lo(1)  , hi(1)+1
             phiptx(i,j,k)  = phiavex(i,j,k) - (1.0d0/24.d0)* &
                  (phiavex(i,j+1,k  )+phiavex(i,j-1,k  )&
                  +phiavex(i,j  ,k+1)+phiavex(i,j  ,k-1)&
                  -4.d0*phiavex(i,j,k))

             diffflux  = (-nu/dx(1))* &
                  ((27.0d0/24.0d0)*(phiptcc(i  ,j,k) - phiptcc(i-1,j,k)) &
                  +( 1.0d0/24.0d0)*(phiptcc(i-2,j,k) - phiptcc(i+1,j,k)))

             fluxptx(i,j,k) = umac(i,j,k)*phiptx(i,j,k) + diffflux

          end do
       end do
    end do

    !same for y faces
    do       k = lo(3)-1, hi(3)+1
       do    j = lo(2)  , hi(2)+1
          do i = lo(1)-1, hi(1)+1

             phipty(i,j,k)  = phiavey(i,j,k) - (1.0d0/24.d0)* &
                  (phiavey(i+1,j,k  )+phiavey(i-1,j,k  )&
                  +phiavey(i  ,j,k+1)+phiavey(i  ,j,k-1)&
                  -4.d0*phiavey(i,j,k))

             diffflux  = (-nu/dx(2))* &
                  ((27.0d0/24.0d0)*(phiptcc(i,j  ,k) - phiptcc(i,j-1,k)) &
                  +( 1.0d0/24.0d0)*(phiptcc(i,j-2,k) - phiptcc(i,j+1,k)))

             fluxpty(i,j,k) = vmac(i,j,k)*phipty(i,j,k) + diffflux

          end do
       end do
    end do

    !same for z faces
    do       k = lo(3)  , hi(3)+1
       do    j = lo(2)-1, hi(2)+1
          do i = lo(1)-1, hi(1)+1

             phiptz(i,j,k)  = phiavez(i,j,k) - (1.0d0/24.d0)* &
                  (phiavez(i+1,j  ,k)+phiavez(i-1,j  ,k)&
                  +phiavez(i  ,j+1,k)+phiavez(i  ,j-1,k)&
                  -4.d0*phiavez(i,j,k))

             diffflux  = (-nu/dx(3))* &
                  ((27.0d0/24.0d0)*(phiptcc(i,j,k  ) - phiptcc(i,j,k-1)) &
                  +( 1.0d0/24.0d0)*(phiptcc(i,j,k-2) - phiptcc(i,j,k+1)))

             fluxptz(i,j,k) = wmac(i,j,k)*phiptz(i,j,k) + diffflux
          end do
       end do
    end do

    ! now transform pointwise  fluxes into face-averaged  fluxes
    !fluxave = fluxpt + (1/24)(Lapl2d(fluxpt))

    do       k = lo(3), hi(3)
       do    j = lo(2), hi(2)
          do i = lo(1), hi(1)+1
             flxx(i,j,k)  = fluxptx(i,j,k) + (1.0d0/24.d0)* &
                  (fluxptx(i,j+1,k  )+fluxptx(i,j-1,k  )&
                  +fluxptx(i,j  ,k+1)+fluxptx(i,j  ,k-1)&
                  -4.d0*fluxptx(i,j,k))
          end do
       end do
    end do

    do       k = lo(3), hi(3)
       do    j = lo(2), hi(2)+1
          do i = lo(1), hi(1)
             flxy(i,j,k)  = fluxpty(i,j,k) + (1.0d0/24.d0)* &
                  (fluxpty(i+1,j,k  )+fluxpty(i-1,j,k  )&
                  +fluxpty(i  ,j,k+1)+fluxpty(i  ,j,k-1)&
                  -4.d0*fluxpty(i,j,k))
          end do
       end do
    end do

    do       k = lo(3), hi(3)+1
       do    j = lo(2), hi(2)
          do i = lo(1), hi(1)
             flxz(i,j,k)  = fluxptz(i,j,k) + (1.0d0/24.d0)* &
                  (fluxptz(i+1,j  ,k)+fluxptz(i-1,j  ,k)&
                  +fluxptz(i  ,j+1,k)+fluxptz(i  ,j-1,k)&
                  -4.d0*fluxptz(i,j,k))
          end do
       end do
    end do

 end subroutine mol4thord_flux_3d_nolimit

  !phi coming in is assumed to be cell-averaged
  !velocity is pointwise on faces --- this version has  limiting
  subroutine mol4thord_flux_3d_limited(&
       lo, hi, dt, dx, &
       phi ,ph_lo,ph_hi, &
       umac,  u_lo,  u_hi, &
       vmac,  v_lo,  v_hi, &
       wmac,  w_lo,  w_hi, &
       flxx, fx_lo, fx_hi, &
       flxy, fy_lo, fy_hi, &
       flxz, fz_lo, fz_hi, &
       fluxptx, phiptx, phiavex, &
       fluxpty, phipty, phiavey, &
       fluxptz, phiptz, phiavez, &
       phiptcc, glo, ghi, nu, &
       deblocell, debhicell, &
       hisidedebfacelo, hisidedebfacehi, &
       losidedebfacelo, losidedebfacehi, printstuff)

    integer, intent(in) :: lo(3), hi(3), glo(3), ghi(3), printstuff
    integer, intent(in) :: deblocell(3), debhicell(3)
    integer, intent(in) :: hisidedebfacelo(3), hisidedebfacehi(3)
    integer, intent(in) :: losidedebfacelo(3), losidedebfacehi(3)
    double precision, intent(in) :: dt, dx(3), nu
    integer, intent(in) :: ph_lo(3), ph_hi(3)
    integer, intent(in) ::  u_lo(3),  u_hi(3)
    integer, intent(in) ::  v_lo(3),  v_hi(3)
    integer, intent(in) ::  w_lo(3),  w_hi(3)
    integer, intent(in) :: fx_lo(3), fx_hi(3)
    integer, intent(in) :: fy_lo(3), fy_hi(3)
    integer, intent(in) :: fz_lo(3), fz_hi(3)
    double precision, intent(in   ) :: phi (ph_lo(1):ph_hi(1),ph_lo(2):ph_hi(2),ph_lo(3):ph_hi(3))
    double precision, intent(in   ) :: umac( u_lo(1): u_hi(1), u_lo(2): u_hi(2), u_lo(3): u_hi(3))
    double precision, intent(in   ) :: vmac( v_lo(1): v_hi(1), v_lo(2): v_hi(2), v_lo(3): v_hi(3))
    double precision, intent(in   ) :: wmac( w_lo(1): w_hi(1), w_lo(2): w_hi(2), w_lo(3): w_hi(3))
    double precision, intent(  out) :: flxx(fx_lo(1):fx_hi(1),fx_lo(2):fx_hi(2),fx_lo(3):fx_hi(3))
    double precision, intent(  out) :: flxy(fy_lo(1):fy_hi(1),fy_lo(2):fy_hi(2),fy_lo(3):fy_hi(3))
    double precision, intent(  out) :: flxz(fz_lo(1):fz_hi(1),fz_lo(2):fz_hi(2),fz_lo(3):fz_hi(3))
    double precision, dimension(glo(1):ghi(1),glo(2):ghi(2),glo(3):ghi(3)) :: &
         fluxptx, fluxpty, fluxptz,  phiptx, phipty, phiptz, phiavex, phiavey, phiavez, phiptcc

    double precision :: diffflux
    integer :: i, j, k

    !STEP 0
    ! 2.1 get cell-centered phi so we can compute a pointwise, fourth order gradient at faces
    ! needed  for diffusive fluxes

    do       k = lo(3)-3, hi(3)+3
       do    j = lo(2)-3, hi(2)+3
          do i = lo(1)-3, hi(1)+3
             phiptcc(i,j,k)  = phi(i,j,k) - (1.0d0/24.d0)* &
                  (phi(i+1,j  ,k  )+phi(i-1,j  ,k  )&
                  +phi(i  ,j+1,k  )+phi(i  ,j-1,k  )&
                  +phi(i  ,j  ,k+1)+phi(i  ,j  ,k-1)&
                  -6.d0*phi(i,j,k))
          end do
       end do
    end do
    ! STEP ONE--- HYPERBOLIC FLUXES
    ! compute face average phi on x faces via eqn 17 of mccorquodale, colella
    do       k = lo(3)-2, hi(3)+2
       do    j = lo(2)-2, hi(2)+2
          do i = lo(1)  , hi(1)+1

             phiavex(i,j,k)  = &
                  (7.d0/12.d0)*(phi(i  ,j,k) + phi(i-1,j,k)) &
                 -(1.d0/12.d0)*(phi(i-2,j,k) + phi(i+1,j,k))

          end do
       end do
    end do

    !same for y faces
    do       k = lo(3)-2, hi(3)+2
       do    j = lo(2)  , hi(2)+1
          do i = lo(1)-2, hi(1)+2

             phiavey(i,j,k)  = &
                  (7.d0/12.d0)*(phi(i,j  ,k) + phi(i,j-1,k)) &
                 -(1.d0/12.d0)*(phi(i,j-2,k) + phi(i,j+1,k))

          end do
       end do
    end do
    !same for z faces
    do       k = lo(3)  , hi(3)+1
       do    j = lo(2)-2, hi(2)+2
          do i = lo(1)-2, hi(1)+2

             phiavez(i,j,k)  = &
                  (7.d0/12.d0)*(phi(i,j,k  ) + phi(i,j,k-1)) &
                 -(1.d0/12.d0)*(phi(i,j,k-2) + phi(i,j,k+1))

          end do
       end do
    end do

    !now get point valued phi at faces so we can multiply by point valued velocity
    ! phipt = phiave - (h^2/24)*(lapl^2d(phi_ave))
    ! while I am at it, multiply in pointwise velocity so we get pointwise *HYPERBOLIC* flux
    !also  get pointwise diffusive fluxes using 4th order finite differences of pointwise phi

    do       k = lo(3)-1, hi(3)+1
       do    j = lo(2)-1, hi(2)+1
          do i = lo(1)  , hi(1)+1
             phiptx(i,j,k)  = phiavex(i,j,k) - (1.0d0/24.d0)* &
                  (phiavex(i,j+1,k  )+phiavex(i,j-1,k  )&
                  +phiavex(i,j  ,k+1)+phiavex(i,j  ,k-1)&
                  -4.d0*phiavex(i,j,k))

             diffflux  = (-nu/dx(1))* &
                  ((27.0d0/24.0d0)*(phiptcc(i  ,j,k) - phiptcc(i-1,j,k)) &
                  +( 1.0d0/24.0d0)*(phiptcc(i-2,j,k) - phiptcc(i+1,j,k)))

             fluxptx(i,j,k) = umac(i,j,k)*phiptx(i,j,k) + diffflux

          end do
       end do
    end do

    !same for y faces
    do       k = lo(3)-1, hi(3)+1
       do    j = lo(2)  , hi(2)+1
          do i = lo(1)-1, hi(1)+1

             phipty(i,j,k)  = phiavey(i,j,k) - (1.0d0/24.d0)* &
                  (phiavey(i+1,j,k  )+phiavey(i-1,j,k  )&
                  +phiavey(i  ,j,k+1)+phiavey(i  ,j,k-1)&
                  -4.d0*phiavey(i,j,k))

             diffflux  = (-nu/dx(2))* &
                  ((27.0d0/24.0d0)*(phiptcc(i,j  ,k) - phiptcc(i,j-1,k)) &
                  +( 1.0d0/24.0d0)*(phiptcc(i,j-2,k) - phiptcc(i,j+1,k)))

             fluxpty(i,j,k) = vmac(i,j,k)*phipty(i,j,k) + diffflux

          end do
       end do
    end do

    !same for z faces
    do       k = lo(3)  , hi(3)+1
       do    j = lo(2)-1, hi(2)+1
          do i = lo(1)-1, hi(1)+1

             phiptz(i,j,k)  = phiavez(i,j,k) - (1.0d0/24.d0)* &
                  (phiavez(i+1,j  ,k)+phiavez(i-1,j  ,k)&
                  +phiavez(i  ,j+1,k)+phiavez(i  ,j-1,k)&
                  -4.d0*phiavez(i,j,k))

             diffflux  = (-nu/dx(3))* &
                  ((27.0d0/24.0d0)*(phiptcc(i,j,k  ) - phiptcc(i,j,k-1)) &
                  +( 1.0d0/24.0d0)*(phiptcc(i,j,k-2) - phiptcc(i,j,k+1)))

             fluxptz(i,j,k) = wmac(i,j,k)*phiptz(i,j,k) + diffflux
          end do
       end do
    end do

    ! now transform pointwise  fluxes into face-averaged  fluxes
    !fluxave = fluxpt + (1/24)(Lapl2d(fluxpt))

    do       k = lo(3), hi(3)
       do    j = lo(2), hi(2)
          do i = lo(1), hi(1)+1
             flxx(i,j,k)  = fluxptx(i,j,k) + (1.0d0/24.d0)* &
                  (fluxptx(i,j+1,k  )+fluxptx(i,j-1,k  )&
                  +fluxptx(i,j  ,k+1)+fluxptx(i,j  ,k-1)&
                  -4.d0*fluxptx(i,j,k))
          end do
       end do
    end do

    do       k = lo(3), hi(3)
       do    j = lo(2), hi(2)+1
          do i = lo(1), hi(1)
             flxy(i,j,k)  = fluxpty(i,j,k) + (1.0d0/24.d0)* &
                  (fluxpty(i+1,j,k  )+fluxpty(i-1,j,k  )&
                  +fluxpty(i  ,j,k+1)+fluxpty(i  ,j,k-1)&
                  -4.d0*fluxpty(i,j,k))
          end do
       end do
    end do

    do       k = lo(3), hi(3)+1
       do    j = lo(2), hi(2)
          do i = lo(1), hi(1)
             flxz(i,j,k)  = fluxptz(i,j,k) + (1.0d0/24.d0)* &
                  (fluxptz(i+1,j  ,k)+fluxptz(i-1,j  ,k)&
                  +fluxptz(i  ,j+1,k)+fluxptz(i  ,j-1,k)&
                  -4.d0*fluxptz(i,j,k))
          end do
       end do
    end do

 end subroutine mol4thord_flux_3d_limited

end module compute_flux_module


C      +----------------------+
C      !     LITT splines     !
C      +----------------------+
C                      20.03.95

C      Snoopy (entier): une seule spline.
C                       trace les derivees

       integer n,I,J,m,K
       parameter (n=29)
       parameter (m=200)
       double precision x(m+1),y(m+1),XN(n),YN(n),DN(n),W(3*n),x1,y1
       double precision vals(4),deriv(m+1,4)

       common /TG02BD/ K
C      ------------------------
C               Data
C      ------------------------

       data YN/0.0, 0.3, 0.35, 0.4, 0.6, 1.2, 1.55, 1.5,
     *         1.1, 0.65, 0.6, 0.7, 1.45, 1.5, 1.5, 1.45, 1.5,
     *         1.48, 1.44, 1.2, 1.1, 1.0, 0.8, 0.55, 0.4, 0.4,
     *         0.3, 0.2, 0.0/

       data XN/0.0 , 0.5 ,1.9, 2.0 , 2.1 , 2.5 ,
     *         3.5 , 4.0 , 5.0 , 5.8 , 5.9 ,
     *         6.0 , 7.15, 7.35, 7.5 , 7.6, 7.7, 7.8,
     *         7.9 , 8.15, 8.25, 8.5 , 9.5 ,
     *         10.0,10.25, 10.3, 10.7, 10.85, 11.0/

C      ------------------------
C           Interpolation
C      ------------------------
       call TB04AD(n,XN,YN,DN,W)

       x1=XN(1)
       do 10 I=1,m+1
          call TG02AD(1,n,XN,YN,DN,x1,vals)
          x(I)=x1
          do 20 J=1,4
             deriv(I,J)=vals(J)
20        continue
          x1=x1+(XN(n)-XN(1))/m
10     continue

       call tomat(n,m,XN,YN,x,deriv)

       end

C      ------------------------
C        Graphique -> Matlab
C      ------------------------

       subroutine tomat(n,m,XX,YY,X,DER)

       integer m,n,I
       double precision X(m+1),DER(m+1,4),XX(n),YY(n)

       open(UNIT = 2, FILE = 'snoo_derive.m')
          do 100 I=1,m+1
             write(2,*)'x(',I,')=',X(I),';'
             write(2,*)'y(',I,')=',DER(I,1),';'
             write(2,*)'d1(',I,')=',DER(I,2),';'
             write(2,*)'d2(',I,')=',DER(I,3),';'
             write(2,*)'d3(',I,')=',DER(I,4),';'
100       continue

          do 200 I=1,n
             write(2,*)'xn(',I,')=',XX(I),';'
             write(2,*)'yn(',I,')=',YY(I),';'
200       continue
          write(2,*)'figure(1)'
          write(2,*)'plot(xn,yn,''w+'',x,y,''w-'')'
          write(2,*)'figure(2)'
          write(2,*)'plot(x,d1,''w-'');grid'
          write(2,*)'title(''Derivee premiere (snoopy entier)'')'
          write(2,*)'figure(3)'
          write(2,*)'plot(x,d2,''w-'');grid'
          write(2,*)'title(''Derivee seconde (snoopy entier)'')'
          write(2,*)'figure(4)'
          write(2,*)'plot(x,d3,''w-'');grid'
          write(2,*)'title(''Derivee troisieme (snoopy entier)'')'
       close (UNIT = 2)

       return
       end


      INCLUDE 'VICMAIN_FOR'
C VICAR PROGRAM MOMLIST
C
      SUBROUTINE MAIN44

         REAL*8 DN,SIG,VIG,DNSUM,DN2SUM
         REAL*4 BEXPO, EXPOS(30)
         REAL*4 DNS(6400)

         INTEGER NAREA,AREA(4,400)
         INTEGER NI,SL,SS,NL,NS,NL2,NS2,STAT
         INTEGER OUTAREA,AREA_ARRAY(100),AREA_ARRAY_CNT,NEXP

         CHARACTER*132  MSG1
         CHARACTER*255  TABLE_DS
         CHARACTER*1    TAB

         LOGICAL ITBL

         CALL IFMESSAGE ('*** momlist version 2017-08-09 ***')

         MSG1 = ' '

C-----Open the input Light Transfer File
         CALL XVUNIT(IUNI,'INP',1,STAT,' ')
         CALL XVOPEN(IUNI,STAT,'OPEN_ACT','SA','IO_ACT','SA',' ')
C         CALL XVOPEN(IUNI,STAT,'OPEN_ACT','SA','IO_ACT','SA',
C     &             'U_FORMAT','HALF',' ')

C        Get area size fields...
         CALL XLGET (IUNI,'HISTORY','NUM_AREAS',NAREA,STAT,
     &               'FORMAT','INT','HIST','LTGEN',' ')
         CALL XLGET (IUNI,'HISTORY','AREAS',AREA,STAT,'NELEMENT',
     &               4*NAREA,'FORMAT','INT','HIST','LTGEN',' ')

         CALL XVPARM ('TABLE',TABLE_DS,ICNT,IDEF,1)

         ITBL = ICNT .GT. 0
         TAB = CHAR(9)

         IF (ITBL) THEN
            OPEN(12,FILE=TABLE_DS,STATUS='UNKNOWN',IOSTAT=JST,ERR=998)
            WRITE(12,10)
     &         'AREA',TAB,'EXPOS',TAB,'MEAN.DN',TAB,'SIGMA'
         END IF

         CALL XVPARM('AREA',AREA_ARRAY,AREA_ARRAY_CNT,IDEF,100)

         CALL XVSIZE(SL,SS,NL,NS,NL2,NS2)

	 WRITE(MSG1,12)
     &      'AREA','   ','EXPOS','   ','MEAN.DN','   ','SIGMA'

         CALL XVMESSAGE (MSG1,' ')

         CALL XLGET (IUNI,'HISTORY','NUM_EXPOS',NEXP,STAT,
     &               'FORMAT','INT','HIST','LTGEN',' ')
         CALL XLGET (IUNI,'HISTORY','EXPOSURES',EXPOS,STAT,
     &               'NELEMENT',NEXP,'FORMAT','REAL',
     &               'HIST','LTGEN',' ')

         DO 50 L=1,NL
            CALL XVREAD (IUNI,DNS,STAT,'LINE',L,'NSAMPS',NS,' ')
            NI = NINT (DNS(1))
            IF (NI .EQ. 0) THEN
               BEXPO = EXPOS(L)
               GOTO 970
            ENDIF

            DO 50 K=1,AREA_ARRAY_CNT
               IF (AREA_ARRAY(K) .GT. NAREA) THEN
                  CALL XVMESSAGE ('*** AREA INPUT OUT OF RANGE',' ')
                  WRITE(MSG1,13)
     &               '*** Max input area index =',NAREA
   13             FORMAT (A26,I4)
                  CALL XVMESSAGE (MSG1,' ')
                  CALL ABEND()
               ENDIF
 	       IB = 3 * NI * (AREA_ARRAY(K)-1)
               SL = AREA(1,AREA_ARRAY(K))
               SS = AREA(2,AREA_ARRAY(K))
               NL = AREA(3,AREA_ARRAY(K))
               NS = AREA(4,AREA_ARRAY(K))
	       OUTAREA=AREA_ARRAY(K)
               N = NI*NL*NS            !Total number of pixels in area*inputs
               DNSUM = 0.0D0
	       DN2SUM = 0.0D0

               DO I=1,NI
C              Sum of DNs across inputs
                  DNSUM = DNSUM + DBLE(DNS(IB+I+1))
C              Sum of DN*DN across inputs
                  DN2SUM = DN2SUM + DBLE(DNS(IB+I+1+NI))
	       ENDDO

               DN = DNSUM/DBLE(N)              !Average DN for area
               VIG = DN2SUM/DBLE(N) - DN*DN
               IF (VIG .LT. 0.0) THEN
                  CALL XVMESSAGE ('*** INVALID INPUT DATA FILE.',' ')
                  CALL XVMESSAGE
     &               ('*** Please make sure input has been',' ')
                  CALL XVMESSAGE
     &               ('*** correctly generated by MOMGEN.',' ')
                  CALL ABEND()
               ENDIF
               SIG = SQRT(VIG)   ! Calculate Standard Devation

	       WRITE(MSG1,11)
     &            OUTAREA,'   ',EXPOS(L),'   ',DN,'   ',SIG

               CALL XVMESSAGE (MSG1,' ')

               IF (ITBL)
     &            WRITE(12,9) OUTAREA,TAB,EXPOS(L),TAB,DN,TAB,SIG

   50   CONTINUE

         CALL XVCLOSE(IUNI,IST,' ')
         IF(ITBL) CLOSE(12)

         RETURN

    9    FORMAT(1x,I5,A1,F8.2,A1,F8.2,A1,F8.3)
   10    FORMAT(1x,A5,A1,A8,A1,A8,A1,A8)
   11    FORMAT(1x,I5,A3,F8.2,A3,F8.2,A3,F8.3)
   12    FORMAT(1x,A5,A3,A8,A3,A8,A3,A8)
  998    CALL XVMESSAGE ('ERROR OPENING TABLE FILE',' ')
         CALL PRNT(4,1,JST,'IOSTAT =.')
         GO TO 999
  970    CALL PRNT(7,1,BEXPO,'***No data for exposure=.')
         CALL XVMESSAGE
     &     ('***Run MOMGEN on this exposure and try again.',' ')
         GOTO 999
  999    CALL XVMESSAGE ('***MOMLIST task cancelled',' ')
         CALL ABEND
      END