      SUBROUTINE MB03ZA( COMPC, COMPU, COMPV, COMPW, WHICH, SELECT, N,
     $                   A, LDA, B, LDB, C, LDC, U1, LDU1, U2, LDU2, V1,
     $                   LDV1, V2, LDV2, W, LDW, WR, WI, M, DWORK,
     $                   LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     1. To compute, for a given matrix pair (A,B) in periodic Schur
C        form, orthogonal matrices Ur and Vr so that
C
C            T           [ A11  A12 ]     T           [ B11  B12 ]
C          Vr * A * Ur = [          ],  Ur * B * Vr = [          ], (1)
C                        [  0   A22 ]                 [  0   B22 ]
C
C        is in periodic Schur form, and the eigenvalues of A11*B11
C        form a selected cluster of eigenvalues.
C
C     2. To compute an orthogonal matrix W so that
C
C                   T  [  0  -A11 ]       [  R11   R12 ]
C                  W * [          ] * W = [            ],           (2)
C                      [ B11   0  ]       [   0    R22 ]
C
C        where the eigenvalues of R11 and -R22 coincide and have
C        positive real part.
C
C     Optionally, the matrix C is overwritten by Ur'*C*Vr.
C
C     All eigenvalues of A11*B11 must either be complex or real and
C     negative.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     COMPC   CHARACTER*1
C             = 'U':  update the matrix C;
C             = 'N':  do not update C.
C
C     COMPU   CHARACTER*1
C             = 'U':  update the matrices U1 and U2;
C             = 'N':  do not update U1 and U2.
C             See the description of U1 and U2.
C
C     COMPV   CHARACTER*1
C             = 'U':  update the matrices V1 and V2;
C             = 'N':  do not update V1 and V2.
C             See the description of V1 and V2.
C
C     COMPW   CHARACTER*1
C             Indicates whether or not the user wishes to accumulate
C             the matrix W as follows:
C             = 'N':  the matrix W is not required;
C             = 'I':  W is initialized to the unit matrix and the
C                     orthogonal transformation matrix W is returned;
C             = 'V':  W must contain an orthogonal matrix Q on entry,
C                     and the product Q*W is returned.
C
C     WHICH   CHARACTER*1
C             = 'A':  select all eigenvalues, this effectively means
C                     that Ur and Vr are identity matrices and A11 = A,
C                     B11 = B;
C             = 'S':  select a cluster of eigenvalues specified by
C                     SELECT.
C
C     SELECT  LOGICAL array, dimension (N)
C             If WHICH = 'S', then SELECT specifies the eigenvalues of
C             A*B in the selected cluster. To select a real eigenvalue
C             w(j), SELECT(j) must be set to .TRUE.. To select a complex
C             conjugate pair of eigenvalues w(j) and w(j+1),
C             corresponding to a 2-by-2 diagonal block in A, both
C             SELECT(j) and SELECT(j+1) must be set to .TRUE.; a complex
C             conjugate pair of eigenvalues must be either both included
C             in the cluster or both excluded.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrix A. N >= 0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading N-by-N part of this array must
C             contain the upper quasi-triangular matrix A of the matrix
C             pair (A,B) in periodic Schur form.
C             On exit, the leading M-by-M part of this array contains
C             the matrix R22 in (2).
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= MAX(1,N).
C
C     B       (input/output) DOUBLE PRECISION array, dimension (LDB,N)
C             On entry, the leading N-by-N part of this array must
C             contain the upper triangular matrix B of the matrix pair
C             (A,B) in periodic Schur form.
C             On exit, the leading N-by-N part of this array is
C             overwritten.
C
C     LDB     INTEGER
C             The leading dimension of the array B.  LDB >= MAX(1,N).
C
C     C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
C             On entry, if COMPC = 'U', the leading N-by-N part of this
C             array must contain a general matrix C.
C             On exit, if COMPC = 'U', the leading N-by-N part of this
C             array contains the updated matrix Ur'*C*Vr.
C             If COMPC = 'N' or WHICH = 'A', this array is not
C             referenced.
C
C     LDC     INTEGER
C             The leading dimension of the array C.  LDC >= 1.
C             LDC >= N,  if COMPC = 'U' and WHICH = 'S'.
C
C     U1      (input/output) DOUBLE PRECISION array, dimension (LDU1,N)
C             On entry, if COMPU = 'U' and WHICH = 'S', the leading
C             N-by-N part of this array must contain U1, the (1,1)
C             block of an orthogonal symplectic matrix
C             U = [ U1, U2; -U2, U1 ].
C             On exit, if COMPU = 'U' and WHICH = 'S', the leading
C             N-by-N part of this array contains U1*Ur.
C             If COMPU = 'N' or WHICH = 'A', this array is not
C             referenced.
C
C     LDU1    INTEGER
C             The leading dimension of the array U1.  LDU1 >= 1.
C             LDU1 >= N,  if COMPU = 'U' and WHICH = 'S'.
C
C     U2      (input/output) DOUBLE PRECISION array, dimension (LDU2,N)
C             On entry, if COMPU = 'U' and WHICH = 'S', the leading
C             N-by-N part of this array must contain U2, the (1,2)
C             block of an orthogonal symplectic matrix
C             U = [ U1, U2; -U2, U1 ].
C             On exit, if COMPU = 'U' and WHICH = 'S', the leading
C             N-by-N part of this array contains U2*Ur.
C             If COMPU = 'N' or WHICH = 'A', this array is not
C             referenced.
C
C     LDU2    INTEGER
C             The leading dimension of the array U2.  LDU2 >= 1.
C             LDU2 >= N,  if COMPU = 'U' and WHICH = 'S'.
C
C     V1      (input/output) DOUBLE PRECISION array, dimension (LDV1,N)
C             On entry, if COMPV = 'U' and WHICH = 'S', the leading
C             N-by-N part of this array must contain V1, the (1,1)
C             block of an orthogonal symplectic matrix
C             V = [ V1, V2; -V2, V1 ].
C             On exit, if COMPV = 'U' and WHICH = 'S', the leading
C             N-by-N part of this array contains V1*Vr.
C             If COMPV = 'N' or WHICH = 'A', this array is not
C             referenced.
C
C     LDV1    INTEGER
C             The leading dimension of the array V1.  LDV1 >= 1.
C             LDV1 >= N,  if COMPV = 'U' and WHICH = 'S'.
C
C     V2      (input/output) DOUBLE PRECISION array, dimension (LDV2,N)
C             On entry, if COMPV = 'U' and WHICH = 'S', the leading
C             N-by-N part of this array must contain V2, the (1,2)
C             block of an orthogonal symplectic matrix
C             V = [ V1, V2; -V2, V1 ].
C             On exit, if COMPV = 'U' and WHICH = 'S', the leading
C             N-by-N part of this array contains V2*Vr.
C             If COMPV = 'N' or WHICH = 'A', this array is not
C             referenced.
C
C     LDV2    INTEGER
C             The leading dimension of the array V2.  LDV2 >= 1.
C             LDV2 >= N,  if COMPV = 'U' and WHICH = 'S'.
C
C     W       (input/output) DOUBLE PRECISION array, dimension (LDW,2*M)
C             On entry, if COMPW = 'V', then the leading 2*M-by-2*M part
C             of this array must contain a matrix W.
C             If COMPW = 'I', then W need not be set on entry, W is set
C             to the identity matrix.
C             On exit, if COMPW = 'I' or 'V' the leading 2*M-by-2*M part
C             of this array is post-multiplied by the transformation
C             matrix that produced (2).
C             If COMPW = 'N', this array is not referenced.
C
C     LDW     INTEGER
C             The leading dimension of the array W.  LDW >= 1.
C             LDW >= 2*M,  if COMPW = 'I' or COMPW = 'V'.
C
C     WR      (output) DOUBLE PRECISION array, dimension (M)
C     WI      (output) DOUBLE PRECISION array, dimension (M)
C             The real and imaginary parts, respectively, of the
C             eigenvalues of R11. The eigenvalues are stored in the same
C             order as on the diagonal of R22, with
C             WR(i) = -R22(i,i) and, if R22(i:i+1,i:i+1) is a 2-by-2
C             diagonal block, WI(i) > 0 and WI(i+1) = -WI(i).
C             In exact arithmetic, these eigenvalue are the positive
C             square roots of the selected eigenvalues of the product
C             A*B. However, if an eigenvalue is sufficiently
C             ill-conditioned, then its value may differ significantly.
C
C     M       (output) INTEGER
C             The number of selected eigenvalues.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if  INFO = -28,  DWORK(1)  returns the minimum
C             value of LDWORK.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK >= MAX( 1, 4*N, 8*M ).
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             = 1:  reordering of the product A*B in Step 1 failed
C                   because some eigenvalues are too close to separate;
C             = 2:  reordering of some submatrix in Step 2 failed
C                   because some eigenvalues are too close to separate;
C             = 3:  the QR algorithm failed to compute the Schur form
C                   of some submatrix in Step 2;
C             = 4:  the condition that all eigenvalues of A11*B11 must
C                   either be complex or real and negative is
C                   numerically violated.
C
C     METHOD
C
C     Step 1 is performed using a reordering technique analogous to the
C     LAPACK routine DTGSEN for reordering matrix pencils [1,2]. Step 2
C     is an implementation of Algorithm 2 in [3]. It requires O(M*N*N)
C     floating point operations.
C
C     REFERENCES
C
C     [1] Kagstrom, B.
C         A direct method for reordering eigenvalues in the generalized
C         real Schur form of a regular matrix pair (A,B), in M.S. Moonen
C         et al (eds), Linear Algebra for Large Scale and Real-Time
C         Applications, Kluwer Academic Publ., 1993, pp. 195-218.
C
C     [2] Kagstrom, B. and Poromaa P.:
C         Computing eigenspaces with specified eigenvalues of a regular
C         matrix pair (A, B) and condition estimation: Theory,
C         algorithms and software, Numer. Algorithms, 1996, vol. 12,
C         pp. 369-407.
C
C     [3] Benner, P., Mehrmann, V., and Xu, H.
C         A new method for computing the stable invariant subspace of a
C         real Hamiltonian matrix,  J. Comput. Appl. Math., 86,
C         pp. 17-43, 1997.
C
C     CONTRIBUTORS
C
C     D. Kressner, Technical Univ. Berlin, Germany, and
C     P. Benner, Technical Univ. Chemnitz, Germany, December 2003.
C
C     REVISIONS
C
C     V. Sima, June 2008 (SLICOT version of the HAPACK routine DLABMX).
C     V. Sima, June 2015.
C
C     KEYWORDS
C
C     Hamiltonian matrix, invariant subspace.
C
C     ******************************************************************
C
C     .. Parameters ..
      INTEGER           LDQZ
      PARAMETER         ( LDQZ = 4 )
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         COMPC, COMPU, COMPV, COMPW, WHICH
      INTEGER           INFO, LDA, LDB, LDC, LDU1, LDU2, LDV1, LDV2,
     $                  LDW, LDWORK, M, N
C     .. Array Arguments ..
      LOGICAL           SELECT(*)
      DOUBLE PRECISION  A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*),
     $                  U1(LDU1,*), U2(LDU2,*), V1(LDV1,*), V2(LDV2,*),
     $                  W(LDW,*), WI(*), WR(*)
C     .. Local Scalars ..
      LOGICAL           CMPALL, INITW, PAIR, SWAP, WANTC, WANTU, WANTV,
     $                  WANTW
      INTEGER           HERE, I, IERR, IFST, ILST, K, KS, L, LEN, MM,
     $                  NB, NBF, NBL, NBNEXT, POS, PW, PWC, PWCK, PWD,
     $                  PWDL, WRKMIN
      DOUBLE PRECISION  TEMP
C     .. Local Arrays ..
      LOGICAL           LDUM(1), SELNEW(4)
      DOUBLE PRECISION  DW12(12), Q(LDQZ,LDQZ), T(LDQZ,LDQZ), WINEW(4),
     $                  WRNEW(4), Z(LDQZ,LDQZ)
      INTEGER           IDUM(1)
C     .. External Functions ..
      LOGICAL           LFDUM, LSAME
      EXTERNAL          LFDUM, LSAME
C     .. External Subroutines ..
      EXTERNAL          DCOPY, DGEES, DGEMM, DLACPY, DLASET, DSCAL,
     $                  DTRSEN, MB03WA, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         DBLE, MAX
C
C     .. Executable Statements ..
C
C     Decode and check input parameters
C
      WANTC  = LSAME( COMPC, 'U' )
      WANTU  = LSAME( COMPU, 'U' )
      WANTV  = LSAME( COMPV, 'U' )
      INITW  = LSAME( COMPW, 'I' )
      WANTW  = INITW .OR. LSAME( COMPW, 'V' )
      CMPALL = LSAME( WHICH, 'A' )
      WRKMIN = MAX( 1, 4*N )
C
      INFO = 0
      IF ( .NOT.WANTC .AND. .NOT.LSAME( COMPC, 'N' ) ) THEN
         INFO = -1
      ELSE IF ( .NOT.WANTU .AND. .NOT.LSAME( COMPU, 'N' ) ) THEN
         INFO = -2
      ELSE IF ( .NOT.WANTV .AND. .NOT.LSAME( COMPV, 'N' ) ) THEN
         INFO = -3
      ELSE IF ( .NOT.WANTW .AND. .NOT.LSAME( COMPW, 'N' ) ) THEN
         INFO = -4
      ELSE IF ( .NOT.CMPALL .AND. .NOT.LSAME( WHICH, 'S' ) ) THEN
         INFO = -5
      ELSE
         IF ( CMPALL ) THEN
            M = N
         ELSE
C
C           Set M to the dimension of the specified invariant subspace.
C
            M = 0
            PAIR = .FALSE.
            DO 10 K = 1, N
               IF ( PAIR ) THEN
                  PAIR = .FALSE.
               ELSE
                  IF ( K.LT.N ) THEN
                     IF ( A(K+1,K).EQ.ZERO ) THEN
                        IF ( SELECT(K) )
     $                     M = M + 1
                     ELSE
                        PAIR = .TRUE.
                        IF ( SELECT(K) .OR. SELECT(K+1) )
     $                     M = M + 2
                     END IF
                  ELSE
                     IF ( SELECT(N) )
     $                  M = M + 1
                  END IF
               END IF
   10       CONTINUE
         END IF
C
C        Compute workspace requirements.
C
         WRKMIN = MAX( WRKMIN, 8*M )
C
         IF ( N.LT.0 ) THEN
            INFO = -7
         ELSE IF ( LDA.LT.MAX( 1, N ) ) THEN
            INFO = -9
         ELSE IF ( LDB.LT.MAX( 1, N ) ) THEN
            INFO = -11
         ELSE IF ( LDC.LT.1  .OR. ( WANTC .AND. .NOT.CMPALL .AND.
     $                              LDC.LT.N ) ) THEN
            INFO = -13
         ELSE IF ( LDU1.LT.1 .OR. ( WANTU .AND. .NOT.CMPALL .AND.
     $                              LDU1.LT.N ) ) THEN
            INFO = -15
         ELSE IF ( LDU2.LT.1 .OR. ( WANTU .AND. .NOT.CMPALL .AND.
     $                              LDU2.LT.N ) ) THEN
            INFO = -17
         ELSE IF ( LDV1.LT.1 .OR. ( WANTV .AND. .NOT.CMPALL .AND.
     $                              LDV1.LT.N ) ) THEN
            INFO = -19
         ELSE IF ( LDV2.LT.1 .OR. ( WANTV .AND. .NOT.CMPALL .AND.
     $                              LDV2.LT.N ) ) THEN
            INFO = -21
         ELSE IF ( LDW.LT.1 .OR. ( WANTW .AND. LDW.LT.2*M ) ) THEN
            INFO = -23
         ELSE IF ( LDWORK.LT.WRKMIN ) THEN
            INFO = -28
            DWORK(1) = DBLE( WRKMIN )
         END IF
      END IF
C
C     Return if there were illegal values.
C
      IF ( INFO.NE.0 ) THEN
         CALL XERBLA( 'MB03ZA', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( N.EQ.0 ) THEN
         DWORK(1) = ONE
         RETURN
      END IF
C
C     Jump immediately to Step 2, if all eigenvalues are requested.
C
      IF ( CMPALL )
     $   GO TO 50
C
C     Step 1: Collect the selected blocks at the top-left corner of A*B.
C
      KS = 0
      PAIR = .FALSE.
      DO 40 K = 1, N
         IF ( PAIR ) THEN
            PAIR = .FALSE.
         ELSE
            SWAP = SELECT(K)
            IF  ( K.LT.N ) THEN
               IF ( A(K+1,K).NE.ZERO ) THEN
                  PAIR = .TRUE.
                  SWAP = SWAP .OR. SELECT(K+1)
               END IF
            END IF
C
            IF ( PAIR ) THEN
               NBF = 2
            ELSE
               NBF = 1
            END IF
C
            IF ( SWAP ) THEN
               KS = KS + 1
               IFST = K
C
C              Swap the K-th block to position KS.
C
               ILST = KS
               NBL = 1
               IF ( ILST.GT.1 ) THEN
                  IF ( A(ILST,ILST-1).NE.ZERO ) THEN
                     ILST = ILST - 1
                     NBL = 2
                  END IF
               END IF
C
               IF ( ILST.EQ.IFST )
     $            GO TO 30
C
               HERE = IFST
   20          CONTINUE
C
C              Swap block with next one above.
C
               IF ( NBF.EQ.1 .OR. NBF.EQ.2 ) THEN
C
C                 Current block either 1-by-1 or 2-by-2.
C
                  NBNEXT = 1
                  IF ( HERE.GE.3 ) THEN
                     IF ( A(HERE-1,HERE-2).NE.ZERO )
     $                  NBNEXT = 2
                  END IF
                  POS = HERE - NBNEXT
                  NB  = NBNEXT + NBF
                  CALL DLASET( 'All', NB, NB, ZERO, ONE, Q, LDQZ )
                  CALL DLASET( 'All', NB, NB, ZERO, ONE, Z, LDQZ )
C
                  CALL MB03WA( .TRUE., .TRUE., NBNEXT, NBF, A(POS,POS),
     $                         LDA, B(POS,POS), LDB, Q, LDQZ, Z, LDQZ,
     $                         IERR )
C
                  IF ( IERR.NE.0 ) THEN
                     DWORK(1) = DBLE( WRKMIN )
                     INFO = 1
                     RETURN
                  END IF
C
C                 Update rest of A.
C
                  IF ( POS.GT.1 ) THEN
                     CALL DGEMM( 'No Transpose', 'No Transpose', POS-1,
     $                           NB, NB, ONE, A(1,POS), LDA, Z, LDQZ,
     $                           ZERO, DWORK, N )
                     CALL DLACPY( 'All', POS-1, NB, DWORK, N, A(1,POS),
     $                            LDA )
                  END IF
                  IF ( POS+NB.LE.N ) THEN
                     CALL DGEMM( 'Transpose', 'No Transpose', NB,
     $                           N-POS-NB+1, NB, ONE, Q, LDQZ,
     $                           A(POS,POS+NB), LDA, ZERO, DWORK, NB )
                     CALL DLACPY( 'All', NB, N-POS-NB+1, DWORK, NB,
     $                            A(POS,POS+NB), LDA )
                  END IF
C
C                 Update rest of B.
C
                  IF ( POS.GT.1 ) THEN
                     CALL DGEMM( 'No Transpose', 'No Transpose', POS-1,
     $                           NB, NB, ONE, B(1,POS), LDB, Q, LDQZ,
     $                           ZERO, DWORK, N )
                     CALL DLACPY( 'All', POS-1, NB, DWORK, N, B(1,POS),
     $                            LDB )
                  END IF
                  IF ( POS+NB.LE.N ) THEN
                     CALL DGEMM( 'Transpose', 'No Transpose', NB,
     $                           N-POS-NB+1, NB, ONE, Z, LDQZ,
     $                           B(POS,POS+NB), LDB, ZERO, DWORK, NB )
                     CALL DLACPY( 'All', NB, N-POS-NB+1, DWORK, NB,
     $                            B(POS,POS+NB), LDB )
                  END IF
C
C                 Update C.
C
                  IF ( WANTC ) THEN
                     CALL DGEMM( 'No Transpose', 'No Transpose', N,
     $                           NB, NB, ONE, C(1,POS), LDC, Q, LDQZ,
     $                           ZERO, DWORK, N )
                     CALL DLACPY( 'All', N, NB, DWORK, N, C(1,POS),
     $                            LDC )
                     CALL DGEMM( 'Transpose', 'No Transpose', NB,
     $                           N, NB, ONE, Z, LDQZ, C(POS,1), LDC,
     $                           ZERO, DWORK, NB )
                     CALL DLACPY( 'All', NB, N, DWORK, NB, C(POS,1),
     $                            LDC )
                  END IF
C
C                 Update U.
C
                  IF ( WANTU ) THEN
                     CALL DGEMM( 'No Transpose', 'No Transpose', N,
     $                           NB, NB, ONE, U1(1,POS), LDU1, Z, LDQZ,
     $                           ZERO, DWORK, N )
                     CALL DLACPY( 'All', N, NB, DWORK, N, U1(1,POS),
     $                            LDU1 )
                     CALL DGEMM( 'No Transpose', 'No Transpose', N,
     $                           NB, NB, ONE, U2(1,POS), LDU2, Z, LDQZ,
     $                           ZERO, DWORK, N )
                     CALL DLACPY( 'All', N, NB, DWORK, N, U2(1,POS),
     $                            LDU2 )
                  END IF
C
C                 Update V.
C
                  IF ( WANTV ) THEN
                     CALL DGEMM( 'No Transpose', 'No Transpose', N,
     $                           NB, NB, ONE, V1(1,POS), LDV1, Q, LDQZ,
     $                           ZERO, DWORK, N )
                     CALL DLACPY( 'All', N, NB, DWORK, N, V1(1,POS),
     $                            LDV1 )
                     CALL DGEMM( 'No Transpose', 'No Transpose', N,
     $                           NB, NB, ONE, V2(1,POS), LDV2, Q, LDQZ,
     $                           ZERO, DWORK, N )
                     CALL DLACPY( 'All', N, NB, DWORK, N, V2(1,POS),
     $                            LDV2 )
                  END IF
C
                  HERE = HERE - NBNEXT
C
C                 Test if 2-by-2 block breaks into two 1-by-1 blocks.
C
                  IF ( NBF.EQ.2 ) THEN
                     IF ( A(HERE+1,HERE).EQ.ZERO )
     $                  NBF = 3
                  END IF
C
               ELSE
C
C                 Current block consists of two 1 by 1 blocks each of
C                 which must be swapped individually.
C
                  NBNEXT = 1
                  IF ( HERE.GE.3 ) THEN
                     IF ( A(HERE-1,HERE-2).NE.ZERO )
     $                  NBNEXT = 2
                  END IF
                  POS = HERE - NBNEXT
                  NB  = NBNEXT + 1
                  CALL DLASET( 'All', NB, NB, ZERO, ONE, Q, LDQZ )
                  CALL DLASET( 'All', NB, NB, ZERO, ONE, Z, LDQZ )
C
                  CALL MB03WA( .TRUE., .TRUE., NBNEXT, 1, A(POS,POS),
     $                         LDA, B(POS,POS), LDB, Q, LDQZ, Z, LDQZ,
     $                         IERR )
C
                  IF ( IERR.NE.0 ) THEN
                     DWORK(1) = DBLE( WRKMIN )
                     INFO = 1
                     RETURN
                  END IF
C
C                 Update rest of A.
C
                  IF ( POS.GT.1 ) THEN
                     CALL DGEMM( 'No Transpose', 'No Transpose', POS-1,
     $                           NB, NB, ONE, A(1,POS), LDA, Z, LDQZ,
     $                           ZERO, DWORK, N )
                     CALL DLACPY( 'All', POS-1, NB, DWORK, N, A(1,POS),
     $                            LDA )
                  END IF
                  IF ( POS+NB.LE.N ) THEN
                     CALL DGEMM( 'Transpose', 'No Transpose', NB,
     $                           N-POS-NB+1, NB, ONE, Q, LDQZ,
     $                           A(POS,POS+NB), LDA, ZERO, DWORK, NB )
                     CALL DLACPY( 'All', NB, N-POS-NB+1, DWORK, NB,
     $                            A(POS,POS+NB), LDA )
                  END IF
C
C                 Update rest of B.
C
                  IF ( POS.GT.1 ) THEN
                     CALL DGEMM( 'No Transpose', 'No Transpose', POS-1,
     $                           NB, NB, ONE, B(1,POS), LDB, Q, LDQZ,
     $                           ZERO, DWORK, N )
                     CALL DLACPY( 'All', POS-1, NB, DWORK, N, B(1,POS),
     $                            LDB )
                  END IF
                  IF ( POS+NB.LE.N ) THEN
                     CALL DGEMM( 'Transpose', 'No Transpose', NB,
     $                           N-POS-NB+1, NB, ONE, Z, LDQZ,
     $                           B(POS,POS+NB), LDB, ZERO, DWORK, NB )
                     CALL DLACPY( 'All', NB, N-POS-NB+1, DWORK, NB,
     $                            B(POS,POS+NB), LDB )
                  END IF
C
C                 Update C.
C
                  IF ( WANTC ) THEN
                     CALL DGEMM( 'No Transpose', 'No Transpose', N,
     $                           NB, NB, ONE, C(1,POS), LDC, Q, LDQZ,
     $                           ZERO, DWORK, N )
                     CALL DLACPY( 'All', N, NB, DWORK, N, C(1,POS),
     $                            LDC )
                     CALL DGEMM( 'Transpose', 'No Transpose', NB,
     $                           N, NB, ONE, Z, LDQZ, C(POS,1), LDC,
     $                           ZERO, DWORK, NB )
                     CALL DLACPY( 'All', NB, N, DWORK, NB, C(POS,1),
     $                            LDC )
                  END IF
C
C                 Update U.
C
                  IF ( WANTU ) THEN
                     CALL DGEMM( 'No Transpose', 'No Transpose', N,
     $                           NB, NB, ONE, U1(1,POS), LDU1, Z, LDQZ,
     $                           ZERO, DWORK, N )
                     CALL DLACPY( 'All', N, NB, DWORK, N, U1(1,POS),
     $                            LDU1 )
                     CALL DGEMM( 'No Transpose', 'No Transpose', N,
     $                           NB, NB, ONE, U2(1,POS), LDU2, Z, LDQZ,
     $                           ZERO, DWORK, N )
                     CALL DLACPY( 'All', N, NB, DWORK, N, U2(1,POS),
     $                            LDU2 )
                  END IF
C
C                 Update V.
C
                  IF ( WANTV ) THEN
                     CALL DGEMM( 'No Transpose', 'No Transpose', N,
     $                           NB, NB, ONE, V1(1,POS), LDV1, Q, LDQZ,
     $                           ZERO, DWORK, N )
                     CALL DLACPY( 'All', N, NB, DWORK, N, V1(1,POS),
     $                            LDV1 )
                     CALL DGEMM( 'No Transpose', 'No Transpose', N,
     $                           NB, NB, ONE, V2(1,POS), LDV2, Q, LDQZ,
     $                           ZERO, DWORK, N )
                     CALL DLACPY( 'All', N, NB, DWORK, N, V2(1,POS),
     $                            LDV2 )
                  END IF
C
                  IF ( NBNEXT.EQ.1 ) THEN
C
C                    Swap two 1-by-1 blocks.
C
                     POS = HERE
                     NB  = NBNEXT + 1
                     CALL DLASET( 'All', NB, NB, ZERO, ONE, Q, LDQZ )
                     CALL DLASET( 'All', NB, NB, ZERO, ONE, Z, LDQZ )
C
                     CALL MB03WA( .TRUE., .TRUE., NBNEXT, 1, A(POS,POS),
     $                            LDA, B(POS,POS), LDB, Q, LDQZ, Z,
     $                            LDQZ, IERR )
C
                     IF ( IERR.NE.0 ) THEN
                        DWORK(1) = DBLE( WRKMIN )
                        INFO = 1
                        RETURN
                     END IF
C
C                    Update rest of A.
C
                     IF ( POS.GT.1 ) THEN
                        CALL DGEMM( 'No Transpose', 'No Transpose',
     $                              POS-1, NB, NB, ONE, A(1,POS), LDA,
     $                              Z, LDQZ, ZERO, DWORK, N )
                        CALL DLACPY( 'All', POS-1, NB, DWORK, N,
     $                               A(1,POS), LDA )
                     END IF
                     IF ( POS+NB.LE.N ) THEN
                        CALL DGEMM( 'Transpose', 'No Transpose', NB,
     $                              N-POS-NB+1, NB, ONE, Q, LDQZ,
     $                              A(POS,POS+NB), LDA, ZERO, DWORK,
     $                              NB )
                        CALL DLACPY( 'All', NB, N-POS-NB+1, DWORK, NB,
     $                               A(POS,POS+NB), LDA )
                     END IF
C
C                    Update rest of B.
C
                     IF ( POS.GT.1 ) THEN
                        CALL DGEMM( 'No Transpose', 'No Transpose',
     $                              POS-1, NB, NB, ONE, B(1,POS), LDB,
     $                              Q, LDQZ, ZERO, DWORK, N )
                        CALL DLACPY( 'All', POS-1, NB, DWORK, N,
     $                               B(1,POS), LDB )
                     END IF
                     IF ( POS+NB.LE.N ) THEN
                        CALL DGEMM( 'Transpose', 'No Transpose', NB,
     $                              N-POS-NB+1, NB, ONE, Z, LDQZ,
     $                              B(POS,POS+NB), LDB, ZERO, DWORK,
     $                              NB )
                        CALL DLACPY( 'All', NB, N-POS-NB+1, DWORK, NB,
     $                               B(POS,POS+NB), LDB )
                     END IF
C
C                    Update C.
C
                     IF ( WANTC ) THEN
                        CALL DGEMM( 'No Transpose', 'No Transpose', N,
     $                              NB, NB, ONE, C(1,POS), LDC, Q, LDQZ,
     $                              ZERO, DWORK, N )
                        CALL DLACPY( 'All', N, NB, DWORK, N, C(1,POS),
     $                               LDC )
                        CALL DGEMM( 'Transpose', 'No Transpose', NB,
     $                              N, NB, ONE, Z, LDQZ, C(POS,1), LDC,
     $                              ZERO, DWORK, NB )
                        CALL DLACPY( 'All', NB, N, DWORK, NB, C(POS,1),
     $                               LDC )
                     END IF
C
C                    Update U.
C
                     IF ( WANTU ) THEN
                        CALL DGEMM( 'No Transpose', 'No Transpose', N,
     $                              NB, NB, ONE, U1(1,POS), LDU1, Z,
     $                              LDQZ, ZERO, DWORK, N )
                        CALL DLACPY( 'All', N, NB, DWORK, N, U1(1,POS),
     $                               LDU1 )
                        CALL DGEMM( 'No Transpose', 'No Transpose', N,
     $                              NB, NB, ONE, U2(1,POS), LDU2, Z,
     $                              LDQZ, ZERO, DWORK, N )
                        CALL DLACPY( 'All', N, NB, DWORK, N, U2(1,POS),
     $                               LDU2 )
                     END IF
C
C                    Update V.
C
                     IF ( WANTV ) THEN
                        CALL DGEMM( 'No Transpose', 'No Transpose', N,
     $                              NB, NB, ONE, V1(1,POS), LDV1, Q,
     $                              LDQZ, ZERO, DWORK, N )
                        CALL DLACPY( 'All', N, NB, DWORK, N, V1(1,POS),
     $                               LDV1 )
                        CALL DGEMM( 'No Transpose', 'No Transpose', N,
     $                              NB, NB, ONE, V2(1,POS), LDV2, Q,
     $                              LDQZ, ZERO, DWORK, N )
                        CALL DLACPY( 'All', N, NB, DWORK, N, V2(1,POS),
     $                               LDV2 )
                     END IF
C
                     HERE = HERE - 1
                  ELSE
C
C                    Recompute NBNEXT in case 2-by-2 split.
C
                     IF ( A(HERE,HERE-1).EQ.ZERO )
     $                  NBNEXT = 1
C
                     IF ( NBNEXT.EQ.2 ) THEN
C
C                       2-by-2 block did not split.
C
                        POS = HERE - 1
                        NB  = 3
                        CALL DLASET( 'All', NB, NB, ZERO, ONE, Q, LDQZ )
                        CALL DLASET( 'All', NB, NB, ZERO, ONE, Z, LDQZ )
C
                        CALL MB03WA( .TRUE., .TRUE., 2, 1, A(POS,POS),
     $                               LDA, B(POS,POS), LDB, Q, LDQZ, Z,
     $                               LDQZ, IERR )
C
                        IF ( IERR.NE.0 ) THEN
                           DWORK(1) = DBLE( WRKMIN )
                           INFO = 1
                           RETURN
                        END IF
C
C                       Update rest of A.
C
                        IF ( POS.GT.1 ) THEN
                           CALL DGEMM( 'No Transpose', 'No Transpose',
     $                                 POS-1, NB, NB, ONE, A(1,POS),
     $                                 LDA, Z, LDQZ, ZERO, DWORK, N )
                           CALL DLACPY( 'All', POS-1, NB, DWORK, N,
     $                                  A(1,POS), LDA )
                        END IF
                        IF ( POS+NB.LE.N ) THEN
                           CALL DGEMM( 'Transpose', 'No Transpose', NB,
     $                                 N-POS-NB+1, NB, ONE, Q, LDQZ,
     $                                 A(POS,POS+NB), LDA, ZERO, DWORK,
     $                                 NB )
                           CALL DLACPY( 'All', NB, N-POS-NB+1, DWORK,
     $                                  NB, A(POS,POS+NB), LDA )
                        END IF
C
C                       Update rest of B.
C
                        IF ( POS.GT.1 ) THEN
                           CALL DGEMM( 'No Transpose', 'No Transpose',
     $                                 POS-1, NB, NB, ONE, B(1,POS),
     $                                 LDB, Q, LDQZ, ZERO, DWORK, N )
                           CALL DLACPY( 'All', POS-1, NB, DWORK, N,
     $                                  B(1,POS), LDB )
                        END IF
                        IF ( POS+NB.LE.N ) THEN
                           CALL DGEMM( 'Transpose', 'No Transpose', NB,
     $                                 N-POS-NB+1, NB, ONE, Z, LDQZ,
     $                                 B(POS,POS+NB), LDB, ZERO, DWORK,
     $                                 NB )
                           CALL DLACPY( 'All', NB, N-POS-NB+1, DWORK,
     $                                  NB, B(POS,POS+NB), LDB )
                        END IF
C
C                       Update C.
C
                        IF ( WANTC ) THEN
                           CALL DGEMM( 'No Transpose', 'No Transpose',
     $                                 N, NB, NB, ONE, C(1,POS), LDC, Q,
     $                                 LDQZ, ZERO, DWORK, N )
                           CALL DLACPY( 'All', N, NB, DWORK, N,
     $                                  C(1,POS), LDC )
                           CALL DGEMM( 'Transpose', 'No Transpose', NB,
     $                                 N, NB, ONE, Z, LDQZ, C(POS,1),
     $                                 LDC, ZERO, DWORK, NB )
                           CALL DLACPY( 'All', NB, N, DWORK, NB,
     $                                  C(POS,1), LDC )
                        END IF
C
C                       Update U.
C
                        IF ( WANTU ) THEN
                           CALL DGEMM( 'No Transpose', 'No Transpose',
     $                                 N, NB, NB, ONE, U1(1,POS), LDU1,
     $                                 Z, LDQZ, ZERO, DWORK, N )
                           CALL DLACPY( 'All', N, NB, DWORK, N,
     $                                 U1(1,POS), LDU1 )
                           CALL DGEMM( 'No Transpose', 'No Transpose',
     $                                 N, NB, NB, ONE, U2(1,POS), LDU2,
     $                                 Z, LDQZ, ZERO, DWORK, N )
                           CALL DLACPY( 'All', N, NB, DWORK, N,
     $                                  U2(1,POS), LDU2 )
                        END IF
C
C                       Update V.
C
                        IF ( WANTV ) THEN
                           CALL DGEMM( 'No Transpose', 'No Transpose',
     $                                 N, NB, NB, ONE, V1(1,POS), LDV1,
     $                                 Q, LDQZ, ZERO, DWORK, N )
                           CALL DLACPY( 'All', N, NB, DWORK, N,
     $                                  V1(1,POS), LDV1 )
                           CALL DGEMM( 'No Transpose', 'No Transpose',
     $                                 N, NB, NB, ONE, V2(1,POS), LDV2,
     $                                 Q, LDQZ, ZERO, DWORK, N )
                           CALL DLACPY( 'All', N, NB, DWORK, N,
     $                                  V2(1,POS), LDV2 )
                        END IF
C
                        HERE = HERE - 2
                     ELSE
C
C                       2-by-2 block did split.
C
                        POS = HERE
                        NB = 2
                        CALL DLASET( 'All', NB, NB, ZERO, ONE, Q, LDQZ )
                        CALL DLASET( 'All', NB, NB, ZERO, ONE, Z, LDQZ )
C
                        CALL MB03WA( .TRUE., .TRUE., 2, 1, A(POS,POS),
     $                               LDA, B(POS,POS), LDB, Q, LDQZ, Z,
     $                               LDQZ, IERR )
C
                        IF ( IERR.NE.0 ) THEN
                           DWORK(1) = DBLE( WRKMIN )
                           INFO = 1
                           RETURN
                        END IF
C
C                       Update rest of A.
C
                        IF ( POS.GT.1 ) THEN
                           CALL DGEMM( 'No Transpose', 'No Transpose',
     $                                 POS-1, NB, NB, ONE, A(1,POS),
     $                                 LDA, Z, LDQZ, ZERO, DWORK, N )
                           CALL DLACPY( 'All', POS-1, NB, DWORK, N,
     $                                  A(1,POS), LDA )
                        END IF
                        IF ( POS+NB.LE.N ) THEN
                           CALL DGEMM( 'Transpose', 'No Transpose', NB,
     $                                 N-POS-NB+1, NB, ONE, Q, LDQZ,
     $                                 A(POS,POS+NB), LDA, ZERO, DWORK,
     $                                 NB )
                           CALL DLACPY( 'All', NB, N-POS-NB+1, DWORK,
     $                                  NB, A(POS,POS+NB), LDA )
                        END IF
C
C                       Update rest of B.
C
                        IF ( POS.GT.1 ) THEN
                           CALL DGEMM( 'No Transpose', 'No Transpose',
     $                                 POS-1, NB, NB, ONE, B(1,POS),
     $                                 LDB, Q, LDQZ, ZERO, DWORK, N )
                           CALL DLACPY( 'All', POS-1, NB, DWORK, N,
     $                                  B(1,POS), LDB )
                        END IF
                        IF ( POS+NB.LE.N ) THEN
                           CALL DGEMM( 'Transpose', 'No Transpose', NB,
     $                                 N-POS-NB+1, NB, ONE, Z, LDQZ,
     $                                 B(POS,POS+NB), LDB, ZERO, DWORK,
     $                                 NB )
                           CALL DLACPY( 'All', NB, N-POS-NB+1, DWORK,
     $                                  NB, B(POS,POS+NB), LDB )
                        END IF
C
C                       Update C.
C
                        IF ( WANTC ) THEN
                           CALL DGEMM( 'No Transpose', 'No Transpose',
     $                                 N, NB, NB, ONE, C(1,POS), LDC, Q,
     $                                 LDQZ, ZERO, DWORK, N )
                           CALL DLACPY( 'All', N, NB, DWORK, N,
     $                                  C(1,POS), LDC )
                           CALL DGEMM( 'Transpose', 'No Transpose', NB,
     $                                 N, NB, ONE, Z, LDQZ, C(POS,1),
     $                                 LDC, ZERO, DWORK, NB )
                           CALL DLACPY( 'All', NB, N, DWORK, NB,
     $                                  C(POS,1), LDC )
                        END IF
C
C                       Update U.
C
                        IF ( WANTU ) THEN
                           CALL DGEMM( 'No Transpose', 'No Transpose',
     $                                 N, NB, NB, ONE, U1(1,POS), LDU1,
     $                                 Z, LDQZ, ZERO, DWORK, N )
                           CALL DLACPY( 'All', N, NB, DWORK, N,
     $                                 U1(1,POS), LDU1 )
                           CALL DGEMM( 'No Transpose', 'No Transpose',
     $                                 N, NB, NB, ONE, U2(1,POS), LDU2,
     $                                 Z, LDQZ, ZERO, DWORK, N )
                           CALL DLACPY( 'All', N, NB, DWORK, N,
     $                                  U2(1,POS), LDU2 )
                        END IF
C
C                       Update V.
C
                        IF ( WANTV ) THEN
                           CALL DGEMM( 'No Transpose', 'No Transpose',
     $                                 N, NB, NB, ONE, V1(1,POS), LDV1,
     $                                 Q, LDQZ, ZERO, DWORK, N )
                           CALL DLACPY( 'All', N, NB, DWORK, N,
     $                                  V1(1,POS), LDV1 )
                           CALL DGEMM( 'No Transpose', 'No Transpose',
     $                                 N, NB, NB, ONE, V2(1,POS), LDV2,
     $                                 Q, LDQZ, ZERO, DWORK, N )
                           CALL DLACPY( 'All', N, NB, DWORK, N,
     $                                  V2(1,POS), LDV2 )
                        END IF
C
                        POS = HERE - 1
                        NB = 2
                        CALL DLASET( 'All', NB, NB, ZERO, ONE, Q, LDQZ )
                        CALL DLASET( 'All', NB, NB, ZERO, ONE, Z, LDQZ )
C
                        CALL MB03WA( .TRUE., .TRUE., 2, 1, A(POS,POS),
     $                               LDA, B(POS,POS), LDB, Q, LDQZ, Z,
     $                               LDQZ, IERR )
C
                        IF ( IERR.NE.0 ) THEN
                           DWORK(1) = DBLE( WRKMIN )
                           INFO = 1
                           RETURN
                        END IF
C
C                       Update rest of A.
C
                        IF ( POS.GT.1 ) THEN
                           CALL DGEMM( 'No Transpose', 'No Transpose',
     $                                 POS-1, NB, NB, ONE, A(1,POS),
     $                                 LDA, Z, LDQZ, ZERO, DWORK, N )
                           CALL DLACPY( 'All', POS-1, NB, DWORK, N,
     $                                  A(1,POS), LDA )
                        END IF
                        IF ( POS+NB.LE.N ) THEN
                           CALL DGEMM( 'Transpose', 'No Transpose', NB,
     $                                 N-POS-NB+1, NB, ONE, Q, LDQZ,
     $                                 A(POS,POS+NB), LDA, ZERO, DWORK,
     $                                 NB )
                           CALL DLACPY( 'All', NB, N-POS-NB+1, DWORK,
     $                                  NB, A(POS,POS+NB), LDA )
                        END IF
C
C                       Update rest of B.
C
                        IF ( POS.GT.1 ) THEN
                           CALL DGEMM( 'No Transpose', 'No Transpose',
     $                                 POS-1, NB, NB, ONE, B(1,POS),
     $                                 LDB, Q, LDQZ, ZERO, DWORK, N )
                           CALL DLACPY( 'All', POS-1, NB, DWORK, N,
     $                                  B(1,POS), LDB )
                        END IF
                        IF ( POS+NB.LE.N ) THEN
                           CALL DGEMM( 'Transpose', 'No Transpose', NB,
     $                                 N-POS-NB+1, NB, ONE, Z, LDQZ,
     $                                 B(POS,POS+NB), LDB, ZERO, DWORK,
     $                                 NB )
                           CALL DLACPY( 'All', NB, N-POS-NB+1, DWORK,
     $                                  NB, B(POS,POS+NB), LDB )
                        END IF
C
C                       Update C.
C
                        IF ( WANTC ) THEN
                           CALL DGEMM( 'No Transpose', 'No Transpose',
     $                                 N, NB, NB, ONE, C(1,POS), LDC, Q,
     $                                 LDQZ, ZERO, DWORK, N )
                           CALL DLACPY( 'All', N, NB, DWORK, N,
     $                                  C(1,POS), LDC )
                           CALL DGEMM( 'Transpose', 'No Transpose', NB,
     $                                 N, NB, ONE, Z, LDQZ, C(POS,1),
     $                                 LDC, ZERO, DWORK, NB )
                           CALL DLACPY( 'All', NB, N, DWORK, NB,
     $                                  C(POS,1), LDC )
                        END IF
C
C                       Update U.
C
                        IF ( WANTU ) THEN
                           CALL DGEMM( 'No Transpose', 'No Transpose',
     $                                 N, NB, NB, ONE, U1(1,POS), LDU1,
     $                                 Z, LDQZ, ZERO, DWORK, N )
                           CALL DLACPY( 'All', N, NB, DWORK, N,
     $                                 U1(1,POS), LDU1 )
                           CALL DGEMM( 'No Transpose', 'No Transpose',
     $                                 N, NB, NB, ONE, U2(1,POS), LDU2,
     $                                 Z, LDQZ, ZERO, DWORK, N )
                           CALL DLACPY( 'All', N, NB, DWORK, N,
     $                                  U2(1,POS), LDU2 )
                        END IF
C
C                       Update V.
C
                        IF ( WANTV ) THEN
                           CALL DGEMM( 'No Transpose', 'No Transpose',
     $                                 N, NB, NB, ONE, V1(1,POS), LDV1,
     $                                 Q, LDQZ, ZERO, DWORK, N )
                           CALL DLACPY( 'All', N, NB, DWORK, N,
     $                                  V1(1,POS), LDV1 )
                           CALL DGEMM( 'No Transpose', 'No Transpose',
     $                                 N, NB, NB, ONE, V2(1,POS), LDV2,
     $                                 Q, LDQZ, ZERO, DWORK, N )
                           CALL DLACPY( 'All', N, NB, DWORK, N,
     $                                  V2(1,POS), LDV2 )
                        END IF
C
                        HERE = HERE - 2
                     END IF
                  END IF
               END IF
C
               IF ( HERE.GT.ILST )
     $            GO TO 20
C
   30          CONTINUE
               IF ( PAIR )
     $            KS = KS + 1
            END IF
         END IF
   40 CONTINUE
C
   50 CONTINUE
C
C     Step 2: Compute an ordered Schur decomposition of
C             [ 0, -A11; B11, 0 ].
C
      IF ( INITW )
     $   CALL DLASET( 'All', 2*M, 2*M, ZERO, ONE, W, LDW )
      PWC = 1
      PWD = PWC + 2*M
      PW  = PWD + 2*M
      PAIR = .FALSE.
      NB = 1
C
      DO 80 K = 1, M
         IF ( PAIR ) THEN
            PAIR = .FALSE.
            NB = 1
         ELSE
            IF ( K.LT.N ) THEN
               IF ( A(K+1,K).NE.ZERO ) THEN
                  PAIR = .TRUE.
                  NB = 2
               END IF
            END IF
            PWCK = PWC + 2*( K - 1 )
            PWDL = PWD + 2*( K - 1 )
            CALL DLASET( 'All', NB, M-K+1, ZERO, ZERO, DWORK(PWCK), 2 )
            CALL DLACPY( 'All', NB, M-K+1, A(K,K), LDA, DWORK(PWDL), 2 )
            CALL DLASET( 'All', NB, M-K+1, ZERO, ZERO, A(K,K), LDA )
C
            L = K
C
C           WHILE L >= 1 DO
C
   60       CONTINUE
C
               IF ( K.EQ.L ) THEN
C
C                 Annihilate B(k,k).
C
                  NBL = NB
                  CALL DLASET( 'All', NB+NBL, NB+NBL, ZERO, ZERO, T,
     $                         LDQZ )
                  CALL DLACPY( 'Upper', NBL, NBL, B(L,L), LDB,
     $                         T(NB+1,1), LDQZ )
                  IF ( NB.EQ.1 ) THEN
                     DWORK(PWDL) = -DWORK(PWDL)
                  ELSE
                     CALL DSCAL( 2*NB, -ONE, DWORK(PWDL), 1 )
                  END IF
                  CALL DLACPY( 'All', NB, NB, DWORK(PWDL), 2, T(1,NB+1),
     $                         LDQZ )
               ELSE
C
C                 Annihilate B(l,k).
C
                  CALL DLASET( 'All', NBL+NB, NBL+NB, ZERO, ZERO, T,
     $                         LDQZ )
                  CALL DLACPY( 'All', NBL, NBL, A(L,L), LDA, T, LDQZ )
                  CALL DLACPY( 'All', NBL, NB, B(L,K), LDB, T(1,NBL+1),
     $                         LDQZ )
                  CALL DLACPY( 'All', NB, NB, DWORK(PWCK), 2,
     $                         T(NBL+1,NBL+1), LDQZ )
                  PWDL = PWD + 2*( L - 1 )
               END IF
C
               CALL DGEES( 'V', 'Not Sorted', LFDUM, NB+NBL, T, LDQZ,
     $                     MM, WRNEW, WINEW, Q, LDQZ, DW12, 12, LDUM,
     $                     IERR )
               IF ( IERR.NE.0 ) THEN
                  DWORK(1) = DBLE( WRKMIN )
                  INFO = 3
                  RETURN
               END IF
C
C              Reorder Schur form.
C
               MM = 0
               DO 70  I = 1, NB+NBL
                  IF ( WRNEW(I).GT.0 ) THEN
                     MM = MM + 1
                     SELNEW(I) = .TRUE.
                  ELSE
                     SELNEW(I) = .FALSE.
                  END IF
   70          CONTINUE
               IF ( MM.LT.NB ) THEN
                  DWORK(1) = DBLE( WRKMIN )
                  INFO = 4
                  RETURN
               END IF
               CALL DTRSEN( 'None', 'V', SELNEW, NB+NBL, T, LDQZ, Q,
     $                      LDQZ, WRNEW, WINEW, MM, TEMP, TEMP, DW12,
     $                      4, IDUM, 1, IERR )
               IF ( IERR.NE.0 ) THEN
                  DWORK(1) = DBLE( WRKMIN )
                  INFO = 2
                  RETURN
               END IF
C
C              Permute Q if necessary.
C
               IF ( K.NE.L ) THEN
                  CALL DLACPY( 'All', NBL, NB+NBL, Q, LDQZ, Z(NB+1,1),
     $                         LDQZ )
                  CALL DLACPY( 'All', NB, NB+NBL, Q(NBL+1,1), LDQZ,
     $                         Z, LDQZ )
                  CALL DLACPY( 'All', NB+NBL, NB+NBL, Z, LDQZ, Q, LDQZ )
               END IF
C
C              Update "diagonal" blocks.
C
               CALL DLACPY( 'All', NB, NB, T, LDQZ, DWORK(PWCK), 2 )
               CALL DLACPY( 'All', NB, NBL, T(1,NB+1), LDQZ,
     $                      DWORK(PWDL), 2 )
               IF ( NB.EQ.1 ) THEN
                  CALL DSCAL( NBL, -ONE, DWORK(PWDL), 2 )
               ELSE
                  CALL DSCAL( 2*NBL, -ONE, DWORK(PWDL), 1 )
               END IF
               CALL DLACPY( 'All', NBL, NBL, T(NB+1,NB+1), LDQZ,
     $                      A(L,L), LDA )
C
C              Update block columns of A and B.
C
               LEN = L - 1
               IF ( LEN.GT.0 ) THEN
                  CALL DGEMM( 'No Transpose', 'No Transpose', LEN, NB,
     $                        NB, ONE, B(1,K), LDB, Q, LDQZ, ZERO,
     $                        DWORK(PW), M )
                  CALL DGEMM( 'No Transpose', 'No Transpose', LEN, NBL,
     $                        NB, ONE, B(1,K), LDB, Q(1,NB+1), LDQZ,
     $                        ZERO, DWORK(PW+2*M), M )
                  CALL DGEMM( 'No Transpose', 'No Transpose', LEN, NB,
     $                        NBL, ONE, A(1,L), LDA, Q(NB+1,1), LDQZ,
     $                        ONE, DWORK(PW), M )
                  CALL DLACPY( 'All', LEN, NB, DWORK(PW), M, B(1,K),
     $                         LDB )
                  CALL DGEMM( 'No Transpose', 'No Transpose', LEN, NBL,
     $                        NBL, ONE, A(1,L), LDA, Q(NB+1,NB+1),
     $                        LDQZ, ONE, DWORK(PW+2*M), M )
                  CALL DLACPY( 'All', LEN, NBL, DWORK(PW+2*M), M,
     $                         A(1,L), LDA )
               END IF
C
C              Update block column of A.
C
               LEN = M - L - NBL + 1
               IF ( LEN.GT.0 ) THEN
                  CALL DGEMM( 'Transpose', 'No Transpose', NB, LEN, NB,
     $                        ONE, Q, LDQZ, DWORK(PWDL+2*NBL), 2, ZERO,
     $                        DWORK(PW), 2 )
                  CALL DGEMM( 'Transpose', 'No Transpose', NBL, LEN, NB,
     $                        -ONE, Q(1,NB+1), LDQZ, DWORK(PWDL+2*NBL),
     $                        2, ZERO, DWORK(PW+2*M), 2 )
                  CALL DGEMM( 'Transpose', 'No Transpose', NB, LEN, NBL,
     $                        -ONE, Q(NB+1,1), LDQZ, A(L,L+NBL), LDA,
     $                        ONE, DWORK(PW), 2 )
                  CALL DLACPY( 'All', NB, LEN, DWORK(PW), 2,
     $                         DWORK(PWDL+2*NBL), 2 )
                  CALL DGEMM( 'Transpose', 'No Transpose', NBL, LEN,
     $                        NBL, ONE, Q(NB+1,NB+1), LDQZ, A(L,L+NBL),
     $                        LDA, ONE, DWORK(PW+2*M), 2 )
                  CALL DLACPY( 'All', NBL, LEN, DWORK(PW+2*M), 2,
     $                         A(L,L+NBL), LDA )
               END IF
C
C              Update block row of B.
C
               LEN = M - K - NB + 1
               IF ( LEN.GT.0 ) THEN
                  CALL DGEMM( 'Transpose', 'No Transpose', NB, LEN, NB,
     $                        ONE, Q, LDQZ, DWORK(PWCK+2*NB), 2, ZERO,
     $                        DWORK(PW), 2 )
                  CALL DGEMM( 'Transpose', 'No Transpose', NBL, LEN, NB,
     $                        ONE, Q(1,NB+1), LDQZ, DWORK(PWCK+2*NB), 2,
     $                        ZERO, DWORK(PW+2*M), 2 )
                  CALL DGEMM( 'Transpose', 'No Transpose', NB, LEN, NBL,
     $                        ONE, Q(NB+1,1), LDQZ, B(L,K+NB), LDB, ONE,
     $                        DWORK(PW), 2 )
                  CALL DLACPY( 'All', NB, LEN, DWORK(PW), 2,
     $                         DWORK(PWCK+2*NB), 2 )
                  CALL DGEMM( 'Transpose', 'No Transpose', NBL, LEN,
     $                        NBL, ONE, Q(NB+1,NB+1), LDQZ, B(L,K+NB),
     $                        LDB, ONE, DWORK(PW+2*M), 2 )
                  CALL DLACPY( 'All', NBL, LEN, DWORK(PW+2*M), 2,
     $                         B(L,K+NB), LDB )
               END IF
C
C              Update W.
C
               IF ( WANTW ) THEN
                  IF ( INITW ) THEN
                     POS = L
                     LEN = K + NB - L
                  ELSE
                     POS = 1
                     LEN = M
                  END IF
                  CALL DGEMM( 'No Transpose', 'No Transpose', LEN, NB,
     $                        NB, ONE, W(POS,K), LDW, Q, LDQZ, ZERO,
     $                        DWORK(PW), M )
                  CALL DGEMM( 'No Transpose', 'No Transpose', LEN, NBL,
     $                        NB, ONE, W(POS,K), LDW, Q(1,NB+1), LDQZ,
     $                        ZERO, DWORK(PW+2*M), M )
                  CALL DGEMM( 'No Transpose', 'No Transpose', LEN, NB,
     $                        NBL, ONE, W(POS,M+L), LDW, Q(NB+1,1),
     $                        LDQZ, ONE, DWORK(PW), M )
                  CALL DLACPY( 'All', LEN, NB, DWORK(PW), M, W(POS,K),
     $                         LDW )
                  CALL DGEMM( 'No Transpose', 'No Transpose', LEN, NBL,
     $                        NBL, ONE, W(POS,M+L), LDW, Q(NB+1,NB+1),
     $                        LDQZ, ONE, DWORK(PW+2*M), M )
                  CALL DLACPY( 'All', LEN, NBL, DWORK(PW+2*M), M,
     $                         W(POS,M+L), LDW )
C
                  CALL DGEMM( 'No Transpose', 'No Transpose', LEN, NB,
     $                        NB, ONE, W(M+POS,K), LDW, Q, LDQZ, ZERO,
     $                        DWORK(PW), M )
                  CALL DGEMM( 'No Transpose', 'No Transpose', LEN, NBL,
     $                        NB, ONE, W(M+POS,K), LDW, Q(1,NB+1), LDQZ,
     $                        ZERO, DWORK(PW+2*M), M )
                  CALL DGEMM( 'No Transpose', 'No Transpose', LEN, NB,
     $                        NBL, ONE, W(M+POS,M+L), LDW, Q(NB+1,1),
     $                        LDQZ, ONE, DWORK(PW), M )
                  CALL DLACPY( 'All', LEN, NB, DWORK(PW), M, W(M+POS,K),
     $                         LDW )
                  CALL DGEMM( 'No Transpose', 'No Transpose', LEN, NBL,
     $                        NBL, ONE, W(M+POS,M+L), LDW, Q(NB+1,NB+1),
     $                        LDQZ, ONE, DWORK(PW+2*M), M )
                  CALL DLACPY( 'All', LEN, NBL, DWORK(PW+2*M), M,
     $                         W(M+POS,M+L), LDW )
               END IF
C
               L = L - 1
               NBL = 1
               IF ( L.GT.1 ) THEN
                  IF ( A(L,L-1).NE.ZERO ) THEN
                     NBL = 2
                     L = L - 1
                  END IF
               END IF
C
C           END WHILE L >= 1 DO
C
            IF ( L.GE.1 )
     $         GO TO 60
C
C           Copy recomputed eigenvalues.
C
            CALL DCOPY( NB, WRNEW, 1, WR(K), 1 )
            CALL DCOPY( NB, WINEW, 1, WI(K), 1 )
         END IF
   80 CONTINUE
      DWORK(1) = DBLE( WRKMIN )
      RETURN
C *** Last line of MB03ZA ***
      END
C
      LOGICAL FUNCTION LFDUM( X, Y )
C
C     Void logical function for DGEES.
C
      DOUBLE PRECISION X, Y
      LFDUM = .FALSE.
      RETURN
C *** Last line of LFDUM ***
      END


!
!  time_integr_mod.f90
!
! This module contains routines used for time integration
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
module BGKVDCF0D_time_integr_mod
use nrtype ! contains kind parameters (DP), (DP), (I4B) etc.
   implicit none

contains

! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! TimeIntegratorORK_SH_DGV
!
! This subroutine implements Optimal Runge Kutta integration in the spatially homogeneous case.
!
! It is dependent on the main program: uses variables from the
! commvar
!
! the called subroutines look up varaibles in commvar
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

SUBROUTINE TimeIntegratorORK_SH_DGV(f,dt)

USE BGKVDCF0D_commvar, only: rkmts, frhs1
USE BGKVDCF0D_spat_oper_mod

REAL (DP), DIMENSION (:), INTENT(OUT) :: f                  					! arrays to store the right hand side of the solution.
REAL (DP), intent(in) :: dt ! the time step

!!! LOCAL ARRAYS USED IN THE RK STEPS - NOT TO BE CONFUSED WITH THE SOLUTION STORAGE ARRAYS USED ELSEWHERE IN time_integrator_mod AND misc_setup_mod
REAL (DP), DIMENSION (:), ALLOCATABLE :: ft2, ft3, ft4							! auxiliary variables to keep intermediate time steps

!!! MISC. USEFUL LOCAL VARIABLES AND COUNTERS
INTEGER :: loc_alloc_stat
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SELECT CASE (rkmts)
	!!! RUNGE-KUTTA FIRST ORDER (EULER METHOD)
	CASE (1)
		CALL SpatialOperSH_DGV (f,frhs1,dt)
		f = f + frhs1
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!!! RUNGE KUTTA SECOND ORDER (OPTIMAL 2ND ORDER METHOD)
	CASE (2)
      !!! ALLOCATE THE ARRAYS NEEDED FOR THE RK STEPS
      ALLOCATE(ft2(1:size(f,1)), stat = loc_alloc_stat)
	  IF(loc_alloc_stat > 0) THEN
		PRINT *,"TimeIntegratorORK_SH_DGV: Allocation error for variable (ft2)"
	  END IF
	  !!!!! BEGIN THE RUNGE-KUTTA STEP !!!!!
	  !!! t_1:
	  CALL SpatialOperSH_DGV (f, frhs1, dt)
      !!! t_2:
	  CALL SpatialOperSH_DGV (f + frhs1*2/3.0_DP, ft2, dt)
	  !!!!
	   f = f + frhs1/4.0_DP + ft2*3.0_DP/4
	  !!!!
	  deallocate(ft2)
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !!! RUNGE KUTTA THIRD ORDER (OPTIMAL 3RD ORDER METHOD)
	CASE (3)
		!!! ALLOCATE THE ARRAYS NEEDED FOR THE RK STEPS
	  ALLOCATE(ft2(1:size(f,1)), stat = loc_alloc_stat)
	  IF(loc_alloc_stat > 0) THEN
		PRINT *,"TimeIntegratorORK_SH_DGV: Allocation error for variable (ft2)"
	  END IF
	  ALLOCATE(ft3(1:size(f,1)), stat = loc_alloc_stat)
	  IF(loc_alloc_stat > 0) THEN
		PRINT *,"TimeIntegratorORK_SH_DGV: Allocation error for variable (ft3)"
	  END IF
	  !!!!! BEGIN THE RUNGE-KUTTA STEP !!!!!
	  !!! t_1:
	  CALL SpatialOperSH_DGV (f, frhs1, dt)
	  !!! t_2:
	  CALL SpatialOperSH_DGV (f + frhs1/2.0_DP, ft2, dt)
	  !!! t_3:
	  CALL SpatialOperSH_DGV (f + ft2*3.0_DP/4, ft3, dt)

	  f = f + frhs1*2/9.0_DP + ft2*3.0_DP/9.0_DP + ft3*4/9.0_DP
	  deallocate (ft2,ft3)
	  !!! RUNGE-KUTTA FOURTH ORDER (RALSTON AND RABINOWITZ)
	CASE (4)
      !!! ALLOCATE THE ARRAYS NEEDED FOR THE RK STEPS
   	  ALLOCATE(ft2(1:size(f,1)), stat = loc_alloc_stat)
	  IF(loc_alloc_stat > 0) THEN
		PRINT *,"TimeIntegratorORK_SH_DGV: Allocation error for variable (ft2)"
	  END IF
	  ALLOCATE(ft3(1:size(f,1)), stat = loc_alloc_stat)
	  IF(loc_alloc_stat > 0) THEN
		PRINT *,"TimeIntegratorORK_SH_DGV: Allocation error for variable (ft3)"
	  END IF
      !!!!! BEGIN THE RUNGE-KUTTA STEP !!!!!
	  !!! t_1:
	  CALL SpatialOperSH_DGV (f, frhs1, dt)
      !!! t_2:
	  CALL SpatialOperSH_DGV (f + frhs1/2.0_DP, ft2, dt)
	  !!! t_3:
	  CALL SpatialOperSH_DGV (f + frhs1/4.0_DP + ft2/4.0_DP, ft3, dt)
	  !!! t_4:
	  CALL SpatialOperSH_DGV (f - ft2 + ft3*2, ft2, dt)
	  f = f + frhs1/6.0_DP + ft3*2/3.0_DP + ft2/6.0_DP  ! :2nd componenent is re-used for 4th component!
	  deallocate (ft2,ft3)
	!!! RUNGE-KUTTA FIFTH ORDER (RALSTON AND RABINOWITZ - COMPATIBLE WITH THE FOURTH ORDER)
	CASE (5)
	  !!! ALLOCATE THE ARRAYS NEEDED FOR THE RK STEPS
   	  ALLOCATE(ft2(1:size(f,1)), stat = loc_alloc_stat)
	  IF(loc_alloc_stat > 0) THEN
		PRINT *,"TimeIntegratorORK_SH_DGV: Allocation error for variable (ft2)"
	  END IF
	  ALLOCATE(ft3(1:size(f,1)), stat = loc_alloc_stat)
	  IF(loc_alloc_stat > 0) THEN
		PRINT *,"TimeIntegratorORK_SH_DGV: Allocation error for variable (ft3)"
	  END IF
      ALLOCATE(ft4(1:size(f,1)), stat = loc_alloc_stat)
	  IF(loc_alloc_stat > 0) THEN
		PRINT *,"TimeIntegratorORK_SH_DGV: Allocation error for variable (ft4)"
	  END IF
	  !!!!! BEGIN THE RUNGE-KUTTA STEP !!!!!
	  !!! t_1:
	  CALL SpatialOperSH_DGV (f, frhs1, dt)
	  print *, "1"
	  !!! t_2:
	  CALL SpatialOperSH_DGV (f + frhs1/2.0_DP, ft2, dt)
	  print *, "2"
	  !!! t_3:
	  CALL SpatialOperSH_DGV (f + frhs1/4.0_DP + ft2/4.0_DP, ft3, dt)
	  print *, "3"
	  !!! t_4:
	  CALL SpatialOperSH_DGV (f - ft2 + ft3*2.0_DP, ft4, dt)
	  print *, "4"
	  !!! WE NOW INTRODUCE SOME MEMORY SAVINGS AND REPLACE FT3 WITH -FT2/5_DP+FT3*546/625_DP THAT IS GOING TO BE USED IN STEP 6
	  ft3 = -ft2/5.0_DP+ft3*546/625.0_DP
      !!! t_5:
	  !!! ON THIS STEP, WE RE-USE ft2 TO TAKE PLACE OF ft5
	  CALL SpatialOperSH_DGV (f + frhs1*7.0_DP/27.0_DP + ft2*10.0_DP/27.0_DP + ft4/27.0_DP, ft2, dt)
	  print *, "5"
	  !!! t_6:
	  !!! ON THIS STEP, WE RE-USE ft3 TO TAKE PLACE OF ft6
	  CALL SpatialOperSH_DGV (f + frhs1*28.0_DP/625.0_DP + ft3 + ft4*54/625.0_DP - ft2*378/625.0_DP, ft3, dt)
	  print *, "6"
	  f = f + frhs1/24.0_DP + ft4*5.0_DP/48.0_DP + ft2*27.0_DP/56.0_DP + ft3*125/336.0_DP
	  deallocate (ft2,ft3,ft4)
	CASE default
			PRINT *, "Unsupported degree of Runge-Kutta method passed"
			stop

END SELECT
	   frhs1 = frhs1/dt
END SUBROUTINE TimeIntegratorORK_SH_DGV

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! TimeIntegratorMTS_SH_DGV
!
! Modified by  Alex 10/21/2011
!
! This subroutine implements Multiple Step Time integration.
!
! It is dependent on the main program: uses variables from the
! common_variables_mod
!
! the called subroutines look up varaibles in common_variables_mod
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

SUBROUTINE TimeIntegratorMTS_SH_DGV(f,dt)

USE BGKVDCF0D_commvar, only: f1,f2,f3,f4,frhs1,frhs2,frhs3,frhs4, &
                    rkmts,frhs5,time
USE BGKVDCF0D_spat_oper_mod

REAL (DP), dimension (:), intent (out) :: f ! the solution at the current time step
REAL (DP), intent (in) :: dt ! the time step.

!!!!!!!!

SELECT CASE (rkmts)
	CASE (1)
	 !!! MTS FIRST ORDER (EULER METHOD)
	 CALL SpatialOperSH_DGV (f, frhs1, dt)
	 !
	 f = f + frhs1
     !!! END MTS 1ST ORDER (EULER METHOD)
	CASE (2)
	 !!! ADAMS-BASHFORTH TWO STEP EXPLICIT METHOD
	 f1 = f; frhs2 = frhs1 !! first we need to push the solution into the storage arrays
	 CALL SpatialOperSH_DGV (f, frhs1, dt)
	 f = f + frhs1*3.0_DP/2.0_DP - dt*frhs2/2.0_DP
	 !!! END ADAMS-BASHFORTH TWO STEP EXPLICIT METHOD
	CASE (3)
	 !!! BEGIN ADAMS-BASHFORTH THREE STEP
	 f2 = f1; f1 = f; frhs3 = frhs2; frhs2 = frhs1 !! first we need to push the solution into the storage arrays
	 CALL SpatialOperSH_DGV (f, frhs1, dt)
	 f = f + frhs1*23.0_DP/12.0_DP - dt*frhs2*4/3.0_DP + dt*frhs3*5.0_DP/12.0_DP
    !!! END ADAMS-BASHFORTH THREE STEP
	CASE (4)
   	 !!! ADAMS-BASHFORTH FOUR STEP
	 f3 = f2; f2 = f1; f1 = f; frhs4 = frhs3; frhs3 = frhs2; frhs2 = frhs1 !! first we need to push the solution into the storage arrays
	 CALL SpatialOperSH_DGV (f, frhs1, dt)
	 f = f + frhs1*55.0_DP/24.0_DP - dt*frhs2*59.0_DP/24.0_DP + dt*frhs3*37.0_DP/24.0_DP - dt*frhs4*3.0_DP/8
	 !!! END ADAMS-BASHFORTH FOUR STEP
	CASE (5)
	 !!! ADAMS-BASHFORTH FIVE STEP METHOD
	 f4 = f3; f3 = f2; f2 = f1; f1 = f
	 frhs5 = frhs4; frhs4 = frhs3; frhs3 = frhs2; frhs2 = frhs1 !! first we need to push the solution into the storage arrays
	 CALL SpatialOperSH_DGV (f, frhs1, dt)
	 f = f + frhs1*(1901.0_DP/720.0_DP) - dt*frhs2*(2774.0_DP/720.0_DP) + dt*frhs3*(2616.0_DP/720.0_DP) &
	       - dt*frhs4*(1274.0_DP/720.0_DP) + dt*frhs5*(251.0_DP/720.0_DP)
	 !!! END ADAMS-BASHFORTH FIVE STEP METHOD
    CASE default
	 PRINT *, "Unsupported degree of Multiple Time Stepping method passed"
	 stop
	END SELECT
    frhs1 = frhs1/dt
    time = time + dt ! advance the time for one step
END SUBROUTINE TimeIntegratorMTS_SH_DGV

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! subroutine PrepareMTS_SH_DGV
!
! Subroutine prepares the intermediate time steps to be used in the multi-step methods.
! f stores the actual solution.
! f1, f2, f3, f4, frhs1, frhs2, frhs3, frhs4 store the value of the
!	spatial operator and the right hand side on those intermediate time steps
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SUBROUTINE PrepareMTS_SH_DGV (f, dt)

USE BGKVDCF0D_commvar, only:  f1, f2, f3, f4, frhs1, frhs2, frhs3, frhs4, &
							frhs5, rkmts, time
USE BGKVDCF0D_spat_oper_mod

REAL (DP), dimension (:) :: f ! the solution on the initial time step
REAL (DP), intent (in) :: dt ! the time step..

!!!!!! DECLARE LOCAL VARIABLES !!!!!
INTEGER :: i													! Local counters
INTEGER :: loc_alloc_stat ! to keep the allocation status
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! First, we need to allocate the storages
SELECT CASE(rkmts)
	CASE(1)
	  !!! ALLOCATE THE ARRAYS NEEDED FOR THE MTS STEPS
   	  ALLOCATE(frhs1(1:size(f,1)),f1(1:size(f,1)), stat = loc_alloc_stat)
	  IF(loc_alloc_stat > 0) THEN
		PRINT *,"PrepareMTS_SH_DGV: Allocation error for variable (frhs1)"
		stop
	  END IF
	CASE(2)
	  !!! ALLOCATE THE ARRAYS NEEDED FOR THE MTS STEPS
   	  ALLOCATE(frhs1(1:size(f,1)),frhs2(1:size(f,1)),f1(1:size(f,1)), stat = loc_alloc_stat)
	  IF(loc_alloc_stat > 0) THEN
		PRINT *,"PrepareMTS_SH_DGV: Allocation error for variable (frhs1,f1)"
		stop
	  END IF
	CASE(3)
	  !!! ALLOCATE THE ARRAYS NEEDED FOR THE MTS STEPS
   	  ALLOCATE(frhs1(1:size(f,1)),f1(1:size(f,1)), stat = loc_alloc_stat)
	  IF(loc_alloc_stat > 0) THEN
		PRINT *,"PrepareMTS_SH_DGV: Allocation error for variable (frhs1,f1)"
		stop
	  END IF
	ALLOCATE(frhs2(1:size(f,1)),frhs3(1:size(f,1)),f2(1:size(f,1)), stat = loc_alloc_stat)
	  IF(loc_alloc_stat > 0) THEN
		PRINT *,"PrepareMTS_SH_DGV: Allocation error for variable (frhs2,f2)"
		stop
	  END IF
	CASE(4)
	  !!! ALLOCATE THE ARRAYS NEEDED FOR THE MTS STEPS
   	  ALLOCATE(frhs1(1:size(f,1)),f1(1:size(f,1)), stat = loc_alloc_stat)
	  IF(loc_alloc_stat > 0) THEN
		PRINT *,"PrepareMTS_SH_DGV: Allocation error for variable (frhs1,f1)"
		stop
	  END IF
	ALLOCATE(frhs2(1:size(f,1)),f2(1:size(f,1)), stat = loc_alloc_stat)
	  IF(loc_alloc_stat > 0) THEN
		PRINT *,"PrepareMTS_SH_DGV: Allocation error for variable (frhs2,f2)"
		stop
	  END IF
	  ALLOCATE(frhs3(1:size(f,1)),frhs4(1:size(f,1)),f3(1:size(f,1)), stat = loc_alloc_stat)
	  IF(loc_alloc_stat > 0) THEN
		PRINT *,"PrepareMTS_SH_DGV: Allocation error for variable (frhs3,f3)"
		stop
	  END IF
    CASE(5)
      !!! ALLOCATE THE ARRAYS NEEDED FOR THE MTS STEPS
   	  ALLOCATE(frhs1(1:size(f,1)),f1(1:size(f,1)), stat = loc_alloc_stat)
	  IF(loc_alloc_stat > 0) THEN
		PRINT *,"PrepareMTS_SH_DGV: Allocation error for variable (frhs1,f1)"
		stop
	  END IF
	  ALLOCATE(frhs2(1:size(f,1)),f2(1:size(f,1)), stat = loc_alloc_stat)
	  IF(loc_alloc_stat > 0) THEN
		PRINT *,"PrepareMTS_SH_DGV: Allocation error for variable (frhs2,f2)"
		stop
	  END IF
	ALLOCATE(frhs3(1:size(f,1)),f3(1:size(f,1)), stat = loc_alloc_stat)
	  IF(loc_alloc_stat > 0) THEN
		PRINT *,"PrepareMTS_SH_DGV: Allocation error for variable (frhs3,f3)"
		stop
	  END IF
	  ALLOCATE(frhs4(1:size(f,1)),frhs5(1:size(f,1)),f4(1:size(f,1)), stat = loc_alloc_stat)
	  IF(loc_alloc_stat > 0) THEN
		PRINT *,"PrepareMTS_SH_DGV: Allocation error for variable (frhs4,f4)"
		stop
	  END IF
	CASE default
			PRINT *, "PrepareMTS_SH_DGV: The value of (rkmts) must be from 1 to 5. No such RK or MTS methods implemented"
			stop
END SELECT
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Now we assume that f contains the intial data. We need to set up the arrays
! If rkmts=1 - no action is needed all data is in place
! If the rkmts>2 then we need to actually prepare some arrays.
do i=2,rkmts
 !! FIRST WE NEED TO PUSH THE SOLUTION AND THE RIGHT SIDE DOWN THE STORAGE TO OPEN SOME SPACE FOR THE NEW DATA
 SELECT CASE(rkmts)
 CASE(2)
  f1=f
 CASE(3)
  f2=f1; f1=f; frhs2=frhs1
 CASE(4)
  f3=f2; f2=f1; f1=f; frhs3=frhs2; frhs2=frhs1
 CASE(5)
  f4=f3; f3=f2; f2=f1; f1=f; frhs4=frhs3; frhs3=frhs2; frhs2=frhs1
 CASE default
  PRINT *, "PrepareMTS_SH_DGV: The value of (rkmts) must be from 1 to 5. No such RK or MTS methods implemented"
  stop
 END SELECT
! now, the f contains the solution at the current time. We call the time integrator and then f will contain the next time step and
! frhs1 will contain the solution at the curent time.
 call TimeIntegratorORK_SH_DGV(f,dt)
 time = time+dt ! advance the time
end do
END SUBROUTINE PrepareMTS_SH_DGV

end module BGKVDCF0D_time_integr_mod


	subroutine swr_origtile(wt_above_tile)

!!    ~ ~ ~ PURPOSE ~ ~ ~
!!    this subroutine computes tile drainage using basic tile equations

      use tiles_data_module
      use hru_module, only : hru, ihru, qtile, sw_excess, wt_shall
      use soil_module

      implicit none

      integer :: j                          !none       |HRU number
      integer :: isdr                       !none       |pointer to tile drainage data
      real, intent (in) :: wt_above_tile    !mm         |height of water table above tiles

      j = ihru
      isdr = hru(j)%tiledrain

      !! compute tile flow using the original tile equations

      if (soil(j)%sw > soil(j)%sumfc) then
        sw_excess = (wt_above_tile / wt_shall) * (soil(j)%sw - soil(j)%sumfc)
        qtile = sw_excess * (1. - Exp(-24. / sdr(isdr)%time))
        qtile = amin1(qtile, sdr(isdr)%drain_co)
      else
        qtile = 0.
      end if

	return
	end subroutine swr_origtile


MODULE FUN_xySDIST
!!#### PURPOSE
!! Compute the signed distance from <shape_a> to <shape_b>.
!!    shape_a       shape_b
!!  -----------   -----------
!!   plane <Pn>    point <P>

!!#### USAGE
!!           d = xySDIST_PnP( Pn , P )
!
!! where Pn is a plane and P is a point.

!!#### AUTHORS|CONTACT INFO
!! W. A. Wieselquist [waw] | william.wieselquist@gmail.com

!!#### DEPENDENCIES
USE KND_IntrinsicTypes,ONLY: KIND_Rsp,KIND_Rdp !!((01-A-KND_IntrinsicTypes.f90))

!!#### DEFAULT IMPLICIT
IMPLICIT NONE

!!#### DEFAULT ACCESS
PRIVATE

!!#### PROCEDURE OVERLOADING
INTERFACE xySDIST_PnP
 MODULE PROCEDURE xySDIST_PnP_Rsp
 MODULE PROCEDURE xySDIST_PnP_Rdp
END INTERFACE

!!#### PUBLIC ACCESS LIST
PUBLIC :: xySDIST_PnP

CONTAINS

PURE FUNCTION xySDIST_PnP_Rsp( Pn , P ) RESULT( SDIST )
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "03-A-FUN_xySDIST_PnP.f90.hdr"
!!--begin--
INCLUDE "03-A-FUN_xySDIST_PnP.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION xySDIST_PnP_Rdp( Pn , P ) RESULT( SDIST )
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "03-A-FUN_xySDIST_PnP.f90.hdr"
!!--begin--
INCLUDE "03-A-FUN_xySDIST_PnP.f90.bdy"
!!--end--
END FUNCTION

END MODULE