      SUBROUTINE MB03LD( COMPQ, ORTH, N, A, LDA, DE, LDDE, B, LDB, FG,
     $                   LDFG, NEIG, Q, LDQ, ALPHAR, ALPHAI, BETA,
     $                   IWORK, LIWORK, DWORK, LDWORK, BWORK, INFO )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To compute the relevant eigenvalues of a real N-by-N skew-
C     Hamiltonian/Hamiltonian pencil aS - bH, with
C
C           (  A  D  )         (  B  F  )
C       S = (        ) and H = (        ),                           (1)
C           (  E  A' )         (  G -B' )
C
C     where the notation M' denotes the transpose of the matrix M.
C     Optionally, if COMPQ = 'C', an orthogonal basis of the right
C     deflating subspace of aS - bH corresponding to the eigenvalues
C     with strictly negative real part is computed.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     COMPQ   CHARACTER*1
C             Specifies whether to compute the right deflating subspace
C             corresponding to the eigenvalues of aS - bH with strictly
C             negative real part.
C             = 'N':  do not compute the deflating subspace;
C             = 'C':  compute the deflating subspace and store it in the
C                     leading subarray of Q.
C
C     ORTH    CHARACTER*1
C             If COMPQ = 'C', specifies the technique for computing the
C             orthogonal basis of the deflating subspace, as follows:
C             = 'P':  QR factorization with column pivoting;
C             = 'S':  singular value decomposition.
C             If COMPQ = 'N', the ORTH value is not used.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the pencil aS - bH.  N >= 0, even.
C
C     A       (input/output) DOUBLE PRECISION array, dimension
C                            (LDA, N/2)
C             On entry, the leading N/2-by-N/2 part of this array must
C             contain the matrix A.
C             On exit, if COMPQ = 'C', the leading N/2-by-N/2 part of
C             this array contains the upper triangular matrix Aout
C             (see METHOD); otherwise, it contains the upper triangular
C             matrix A obtained just before the application of the
C             periodic QZ algorithm (see SLICOT Library routine MB04BD).
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= MAX(1, N/2).
C
C     DE      (input/output) DOUBLE PRECISION array, dimension
C                            (LDDE, N/2+1)
C             On entry, the leading N/2-by-N/2 lower triangular part of
C             this array must contain the lower triangular part of the
C             skew-symmetric matrix E, and the N/2-by-N/2 upper
C             triangular part of the submatrix in the columns 2 to N/2+1
C             of this array must contain the upper triangular part of the
C             skew-symmetric matrix D.
C             The entries on the diagonal and the first superdiagonal of
C             this array need not be set, but are assumed to be zero.
C             On exit, if COMPQ = 'C', the leading N/2-by-N/2 lower
C             triangular part and the first superdiagonal contain the
C             transpose of the upper quasi-triangular matrix C2out (see
C             METHOD), and the (N/2-1)-by-(N/2-1) upper triangular part
C             of the submatrix in the columns 3 to N/2+1 of this array
C             contains the strictly upper triangular part of the
C             skew-symmetric matrix Dout (see METHOD), without the main
C             diagonal, which is zero.
C             On exit, if COMPQ = 'N', the leading N/2-by-N/2 lower
C             triangular part and the first superdiagonal contain the
C             transpose of the upper Hessenberg matrix C2, and the
C             (N/2-1)-by-(N/2-1) upper triangular part of the submatrix
C             in the columns 3 to N/2+1 of this array contains the
C             strictly upper triangular part of the skew-symmetric
C             matrix D (without the main diagonal) just before the
C             application of the periodic QZ algorithm.
C
C     LDDE    INTEGER
C             The leading dimension of the array DE.
C             LDDE >= MAX(1, N/2).
C
C     B       (input/output) DOUBLE PRECISION array, dimension
C                            (LDB, N/2)
C             On entry, the leading N/2-by-N/2 part of this array must
C             contain the matrix B.
C             On exit, if COMPQ = 'C', the leading N/2-by-N/2 part of
C             this array contains the upper triangular matrix C1out
C             (see METHOD); otherwise, it contains the upper triangular
C             matrix C1 obtained just before the application of the
C             periodic QZ algorithm.
C
C     LDB     INTEGER
C             The leading dimension of the array B.  LDB >= MAX(1, N/2).
C
C     FG      (input/output) DOUBLE PRECISION array, dimension
C                            (LDFG, N/2+1)
C             On entry, the leading N/2-by-N/2 lower triangular part of
C             this array must contain the lower triangular part of the
C             symmetric matrix G, and the N/2-by-N/2 upper triangular
C             part of the submatrix in the columns 2 to N/2+1 of this
C             array must contain the upper triangular part of the
C             symmetric matrix F.
C             On exit, if COMPQ = 'C', the leading N/2-by-N/2 part of
C             the submatrix in the columns 2 to N/2+1 of this array
C             contains the matrix Vout (see METHOD); otherwise, it
C             contains the matrix V obtained just before the application
C             of the periodic QZ algorithm.
C
C     LDFG    INTEGER
C             The leading dimension of the array FG.
C             LDFG >= MAX(1, N/2).
C
C     NEIG    (output) INTEGER
C             If COMPQ = 'C', the number of eigenvalues in aS - bH with
C             strictly negative real part.
C
C     Q       (output) DOUBLE PRECISION array, dimension (LDQ, 2*N)
C             On exit, if COMPQ = 'C', the leading N-by-NEIG part of
C             this array contains an orthogonal basis of the right
C             deflating subspace corresponding to the eigenvalues of
C             aA - bB with strictly negative real part. The remaining
C             part of this array is used as workspace.
C             If COMPQ = 'N', this array is not referenced.
C
C     LDQ     INTEGER
C             The leading dimension of the array Q.
C             LDQ >= 1,           if COMPQ = 'N';
C             LDQ >= MAX(1, 2*N), if COMPQ = 'C'.
C
C     ALPHAR  (output) DOUBLE PRECISION array, dimension (N/2)
C             The real parts of each scalar alpha defining an eigenvalue
C             of the pencil aS - bH.
C
C     ALPHAI  (output) DOUBLE PRECISION array, dimension (N/2)
C             The imaginary parts of each scalar alpha defining an
C             eigenvalue of the pencil aS - bH.
C             If ALPHAI(j) is zero, then the j-th eigenvalue is real.
C
C     BETA    (output) DOUBLE PRECISION array, dimension (N/2)
C             The scalars beta that define the eigenvalues of the pencil
C             aS - bH.
C             Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and
C             beta = BETA(j) represent the j-th eigenvalue of the pencil
C             aS - bH, in the form lambda = alpha/beta. Since lambda may
C             overflow, the ratios should not, in general, be computed.
C             Due to the skew-Hamiltonian/Hamiltonian structure of the
C             pencil, for every eigenvalue lambda, -lambda is also an
C             eigenvalue, and thus it has only to be saved once in
C             ALPHAR, ALPHAI and BETA.
C             Specifically, only eigenvalues with imaginary parts
C             greater than or equal to zero are stored; their conjugate
C             eigenvalues are not stored. If imaginary parts are zero
C             (i.e., for real eigenvalues), only positive eigenvalues
C             are stored. The remaining eigenvalues have opposite signs.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (LIWORK)
C             On exit, if INFO = -19, IWORK(1) returns the minimum value
C             of LIWORK.
C
C     LIWORK  INTEGER
C             The dimension of the array IWORK.
C             LIWORK >= MAX( N/2 + 32, 2*N + 1 ).
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) returns the optimal LDWORK.
C             On exit, if INFO = -21, DWORK(1) returns the minimum value
C             of LDWORK.
C
C     LDWORK  INTEGER
C             The dimension of the array DWORK.
C             LDWORK >= 3*(N/2)**2 + N**2 + MAX( N, 32 ),
C                                                        if COMPQ = 'N';
C             LDWORK >= 8*N**2 + MAX( 8*N + 32, N/2 + 168, 272 ),
C                                                        if COMPQ = 'C'.
C             For good performance LDWORK should be generally larger.
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     BWORK   LOGICAL array, dimension (N/2)
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0: succesful exit;
C             < 0: if INFO = -i, the i-th argument had an illegal value;
C             = 1: periodic QZ iteration failed in the SLICOT Library
C                  routines MB04BD or MB04HD (QZ iteration did not
C                  converge or computation of the shifts failed);
C             = 2: standard QZ iteration failed in the SLICOT Library
C                  routines MB04HD or MB03DD (called by MB03JD);
C             = 3: a numerically singular matrix was found in the SLICOT
C                  Library routine MB03HD (called by MB03JD);
C             = 4: the singular value decomposition failed in the LAPACK
C                  routine DGESVD (for ORTH = 'S').
C
C     METHOD
C
C     First, the decompositions of S and H are computed via orthogonal
C     transformations Q1 and Q2 as follows:
C
C                       (  Aout  Dout  )
C       Q1' S J Q1 J' = (              ),
C                       (   0    Aout' )
C
C                       (  Bout  Fout  )
C       J' Q2' J S Q2 = (              ) =: T,                       (2)
C                       (   0    Bout' )
C
C                  (  C1out  Vout  )            (  0  I  )
C       Q1' H Q2 = (               ), where J = (        ),
C                  (  0     C2out' )            ( -I  0  )
C
C     and Aout, Bout, C1out are upper triangular, C2out is upper quasi-
C     triangular and Dout and Fout are skew-symmetric.
C
C     Then, orthogonal matrices Q3 and Q4 are found, for the extended
C     matrices
C
C            (  Aout   0  )          (    0   C1out )
C       Se = (            ) and He = (              ),
C            (   0   Bout )          ( -C2out   0   )
C
C     such that S11 := Q4' Se Q3 is upper triangular and
C     H11 := Q4' He Q3 is upper quasi-triangular. The following matrices
C     are computed:
C
C                  (  Dout   0  )                   (   0   Vout )
C       S12 := Q4' (            ) Q4 and H12 := Q4' (            ) Q4.
C                  (   0   Fout )                   ( Vout'   0  )
C
C     Then, an orthogonal matrix Q is found such that the eigenvalues
C     with strictly negative real parts of the pencil
C
C         (  S11  S12  )     (  H11  H12  )
C       a (            ) - b (            )
C         (   0   S11' )     (   0  -H11' )
C
C     are moved to the top of this pencil.
C
C     Finally, an orthogonal basis of the right deflating subspace
C     corresponding to the eigenvalues with strictly negative real part
C     is computed. See also page 12 in [1] for more details.
C
C     REFERENCES
C
C     [1] Benner, P., Byers, R., Losse, P., Mehrmann, V. and Xu, H.
C         Numerical Solution of Real Skew-Hamiltonian/Hamiltonian
C         Eigenproblems.
C         Tech. Rep., Technical University Chemnitz, Germany,
C         Nov. 2007.
C
C     NUMERICAL ASPECTS
C                                                               3
C     The algorithm is numerically backward stable and needs O(N )
C     floating point operations.
C
C     FURTHER COMMENTS
C
C     This routine does not perform any scaling of the matrices. Scaling
C     might sometimes be useful, and it should be done externally.
C
C     CONTRIBUTOR
C
C     V. Sima, Research Institute for Informatics, Bucharest, Romania,
C     Oct. 2010.
C
C     REVISIONS
C
C     V. Sima, Nov. 2010, Dec. 2010, Mar. 2011, Aug. 2011, Nov. 2011,
C     Oct. 2012.
C     M. Voigt, Jan. 2012.
C
C     KEYWORDS
C
C     Deflating subspace, embedded pencil, skew-Hamiltonian/Hamiltonian
C     pencil, structured Schur form.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE, TWO
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 )
C
C     .. Scalar Arguments ..
      CHARACTER          COMPQ, ORTH
      INTEGER            INFO, LDA, LDB, LDDE, LDFG, LDQ, LDWORK,
     $                   LIWORK, N, NEIG
C
C     .. Array Arguments ..
      LOGICAL            BWORK( * )
      INTEGER            IWORK( * )
      DOUBLE PRECISION   A( LDA, * ), ALPHAI( * ), ALPHAR( * ),
     $                   B( LDB, * ), BETA( * ), DE( LDDE, * ),
     $                   DWORK( * ), FG( LDFG, * ), Q( LDQ, * )
C
C     .. Local Scalars ..
      LOGICAL            LINIQ, LQUERY, QR, QRP, SVD
      CHARACTER*14       CMPQ
      INTEGER            IB, IC2, IFO, IH11, IH12, IQ1, IQ2, IQ3, IQ4,
     $                   IRT, IS11, IS12, IWRK, J, M, MINDW, MINIW, MM,
     $                   N2, NM, NMM, NN, OPTDW
C
C     .. Local Arrays ..
      DOUBLE PRECISION   DUM( 4 )
C
C     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
C
C     .. External Subroutines ..
      EXTERNAL           DAXPY, DCOPY, DGEMM, DGEQP3, DGEQRF, DGESVD,
     $                   DLACPY, DORGQR, DSCAL, DSYR2K, DTRMM, MA02AD,
     $                   MB01KD, MB01LD, MB03JD, MB04BD, MB04HD, XERBLA
C
C     .. Intrinsic Functions ..
      INTRINSIC          INT, MAX, MOD, SQRT
C
C     .. Executable Statements ..
C
C     Decode the input arguments.
C
      M   = N/2
      N2  = N*2
      NN  = N*N
      MM  = M*M
      NEIG  = 0
      LINIQ = LSAME( COMPQ, 'C' )
      IF( LINIQ ) THEN
         QR  = LSAME( ORTH, 'Q' )
         QRP = LSAME( ORTH, 'P' )
         SVD = LSAME( ORTH, 'S' )
      END IF
      MINIW = MAX( M + 32, N2 + 1 )
      IF( N.EQ.0 ) THEN
         MINDW = 1
      ELSE IF( LINIQ ) THEN
         MINDW = 8*NN + MAX( 8*N + 32, M + 168, 272 )
      ELSE
         MINDW = 3*M**2 + NN + MAX( N, 32 )
      END IF
      LQUERY = LDWORK.EQ.-1
C
C     Test the input arguments.
C
      INFO = 0
      IF( .NOT.( LSAME( COMPQ, 'N' ) .OR. LINIQ ) ) THEN
         INFO = -1
      ELSE IF( LINIQ ) THEN
         IF( .NOT.( QR .OR. QRP .OR. SVD ) )
     $      INFO = -2
      ELSE IF( N.LT.0 .OR. MOD( N, 2 ).NE.0 ) THEN
         INFO = -3
      ELSE IF(  LDA.LT.MAX( 1, M ) ) THEN
         INFO = -5
      ELSE IF( LDDE.LT.MAX( 1, M ) ) THEN
         INFO = -7
      ELSE IF(  LDB.LT.MAX( 1, M ) ) THEN
         INFO = -9
      ELSE IF( LDFG.LT.MAX( 1, M ) ) THEN
         INFO = -11
      ELSE IF( LDQ.LT.1 .OR. ( LINIQ .AND. LDQ.LT.N2 ) ) THEN
         INFO = -14
      ELSE IF( LIWORK.LT.MINIW ) THEN
         IWORK( 1 ) = MINIW
         INFO = -19
      ELSE IF( .NOT. LQUERY .AND. LDWORK.LT.MINDW ) THEN
         DWORK( 1 ) = MINDW
         INFO = -21
      END IF
C
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'MB03LD', -INFO )
         RETURN
      ELSE IF( N.GT.0 ) THEN
C
C        Compute optimal workspace.
C
         IF( LQUERY ) THEN
            IF( LINIQ ) THEN
               CALL MB04HD( 'I', 'I', N, DWORK, N, DWORK, N, DWORK, N,
     $                      DWORK, N, IWORK, LIWORK, DUM, -1, BWORK,
     $                      INFO )
               IF( SVD ) THEN
                  CALL DGESVD( 'O', 'N', N, N, Q, LDQ, DWORK, DWORK,
     $                         LDQ, DWORK, 1, DUM( 2 ), -1, INFO )
                  J = N + INT( DUM( 2 ) )
               ELSE
                  IF( QR ) THEN
                     CALL DGEQRF( N, M, Q, LDQ, DWORK, DUM( 2 ), -1,
     $                            INFO )
                     J = M
                  ELSE
                     CALL DGEQP3( N, N, Q, LDQ, IWORK, DWORK, DUM( 2 ),
     $                            -1, INFO )
                     J = N
                  END IF
                  CALL DORGQR( N, J, J, Q, LDQ, DWORK, DUM( 3 ), -1,
     $                         INFO )
                  J = J + MAX( INT( DUM( 2 ) ), INT( DUM( 3 ) ) )
               END IF
               OPTDW = MAX( MINDW, 6*NN + INT( DUM( 1 ) ), J )
            ELSE
               OPTDW = MINDW
            END IF
            DWORK( 1 ) = OPTDW
            RETURN
         END IF
      END IF
C
C     Quick return if possible.
C
      IF( N.EQ.0 ) THEN
         IWORK( 1 ) = 1
         DWORK( 1 ) = ONE
         RETURN
      END IF
C
      IFO = 1
C
C     STEP 1: Apply MB04BD to transform the pencil to real
C             skew-Hamiltonian/Hamiltonian Schur form.
C
C     Set the computation option and pointers for the inputs and outputs
C     of MB04BD. If possible, array Q is used as vectorized workspace.
C
C     Real workspace:     need   w1 + w0 + MAX(N,32), where
C                                w1 = 2*N**2, w0 = 2*N**2, if COMPQ = 'C';
C                                w1 = 3*M**2, w0 =   N**2, if COMPQ = 'N'.
C     Integer workspace:  need   M + 12.
C
      IF( LINIQ ) THEN
         CMPQ = 'Initialize'
         IQ1  = 1
         IQ2  = IQ1 + NN
         IWRK = IQ2 + NN
         IF( MOD( M, 4 ).EQ.0 ) THEN
            IC2 = M/4
         ELSE
            IC2 = INT( M/4 ) + 1
         END IF
         IB   = 2*IC2 + 1
         IC2  =   IC2 + 1
         CALL MB04BD( 'Triangularize', CMPQ, CMPQ, N, A, LDA, DE, LDDE,
     $                B, LDB, FG, LDFG, DWORK( IQ1 ), N, DWORK( IQ2 ),
     $                N, Q( 1, IB ), M, Q( 1, IFO ), M, Q( 1, IC2 ), M,
     $                ALPHAR, ALPHAI, BETA, IWORK, LIWORK,
     $                DWORK( IWRK ), LDWORK-IWRK+1, INFO )
      ELSE
         CMPQ = 'No Computation'
         IB   = IFO + MM
         IC2  = IB  + MM
         IWRK = IC2 + MM
         CALL MB04BD( 'Eigenvalues', CMPQ, CMPQ, N, A, LDA, DE, LDDE, B,
     $                LDB, FG, LDFG, DWORK, N, DWORK, N, DWORK( IB ), M,
     $                DWORK( IFO ), M, DWORK( IC2 ), M, ALPHAR, ALPHAI,
     $                BETA, IWORK, LIWORK, DWORK( IWRK ), LDWORK-IWRK+1,
     $                INFO )
      END IF
      OPTDW = MAX( MINDW, INT( DWORK( IWRK ) ) + IWRK - 1 )
C
      IF( INFO.GT.0 ) THEN
         INFO = 1
         RETURN
      END IF
C
      IF( .NOT.LINIQ ) THEN
         CALL MA02AD( 'Upper', M, M, DWORK( IC2 ), M, DE, LDDE )
         CALL DCOPY(  M-1, DWORK( IC2+1 ), M+1, DE( 1, 2 ), LDDE+1 )
         DWORK( 1 ) = OPTDW
         RETURN
      END IF
C
C     STEP 2: Build the needed parts of the extended matrices Se and He,
C     and compute the transformed matrices and the orthogonal matrices
C     Q3 and Q4.
C
C     Real workspace:     need   w1 + w2 + 2*N**2 + MAX(M+168,272), with
C                                w2 = 4*N**2 (COMPQ = 'C');
C                         prefer larger.
C     Integer workspace:  need   M + 32.
C
      NM   = N*M
      NMM  = NM + M
      IQ3  = IWRK
      IQ4  = IQ3  + NN
      IS11 = IQ4  + NN
      IH11 = IS11 + NN
      IWRK = IH11 + NN
C
      CALL DLACPY( 'Full', M, M, A, LDA, DWORK( IS11 ), N )
      CALL DLACPY( 'Full', M, M, Q( 1, IB ), M, DWORK( IS11+NMM ), N )
      CALL DSCAL(  MM, -ONE, Q( 1, IC2 ), 1 )
      CALL DLACPY( 'Full', M, M, Q( 1, IC2 ), M, DWORK( IH11+M ), N )
      CALL DLACPY( 'Full', M, M, B, LDB, DWORK( IH11+NM ), N )
C
      CALL MB04HD( CMPQ, CMPQ, N, DWORK( IS11 ), N, DWORK( IH11 ), N,
     $             DWORK( IQ3 ), N, DWORK( IQ4 ), N, IWORK, LIWORK,
     $             DWORK( IWRK ), LDWORK-IWRK+1, BWORK, INFO )
      IF( INFO.GT.0 ) THEN
         IF( INFO.GT.2 )
     $      INFO = 2
         RETURN
      END IF
      OPTDW = MAX( OPTDW, INT( DWORK( IWRK ) ) + IWRK - 1 )
C
C     STEP 3: Update S12 and H12, building the upper triangular parts,
C     and exploiting the structure. Note that S12 is skew-symmetric and
C     H12 is symmetric.
C
C     Real workspace:     need   w1 + w2 + w3, where
C                                w3 = N**2 + M**2.
C
      IS12 = IWRK
      IH12 = IS12 + NN
      IWRK = IH12
C
      IF( M.GT.1 ) THEN
C
C                                                   [ Qa  Qc ]
C        Compute Qa'*Do*Qc + Qb'*Fo*Qd, where Q4 =: [        ],
C                                                   [ Qb  Qd ]
C        with Do := Dout, etc.
C        Compute also Qc'*Do*Qc + Qd'*Fo*Qd, using MB01KD.
C        Part of the array Q and DWORK(IS12) are used as workspace.
C
         CALL DLACPY( 'Full', M-1, M, DWORK( IQ4+NM+1 ), N,
     $                DWORK( IS12 ), M )
         CALL DLACPY( 'Full', M-1, M, DWORK( IQ4+NM ), N, Q( 2, IB ),
     $                M )
         CALL DTRMM(  'Left', 'Upper', 'No Transpose', 'Non-Unit', M-1,
     $                M, ONE, DE( 1, 3 ), LDDE, DWORK( IS12 ), M )
C
         CALL MB01KD( 'Upper', 'Transpose', M, M-1, ONE,
     $                DWORK( IQ4+NM ), N, DWORK( IS12 ), M, ZERO,
     $                DWORK( IS12+NMM ), N, INFO )
C
         CALL DTRMM(  'Left', 'Upper', 'Transpose', 'Non-Unit', M-1, M,
     $                -ONE, DE( 1, 3 ), LDDE, Q( 2, IB ), M )
         DUM( 1 ) = ZERO
         CALL DCOPY( M, DUM, 0, DWORK( IS12+M-1 ), M )
         CALL DCOPY( M, DUM, 0, Q( 1, IB ), M )
         CALL DAXPY( MM, ONE, Q( 1, IB ), 1, DWORK( IS12 ), 1 )
C
         CALL DLACPY( 'Full', M-1, M, DWORK( IQ4+NMM+1 ), N,
     $                DWORK( IWRK ), M )
         CALL DLACPY( 'Full', M-1, M, DWORK( IQ4+NMM ), N, Q( 2, IB ),
     $                M )
         CALL DTRMM(  'Left', 'Upper', 'No Transpose', 'Non-Unit', M-1,
     $                M, ONE, Q( M+1, IFO ), M, DWORK( IWRK ), M )
C
         CALL MB01KD( 'Upper', 'Transpose', M, M-1, ONE,
     $                DWORK(  IQ4+NMM ), N, DWORK( IWRK ), M, ONE,
     $                DWORK( IS12+NMM ), N, INFO )
C
         CALL DTRMM(  'Left', 'Upper', 'Transpose', 'Non-Unit', M-1,
     $                M, -ONE, Q( M+1, IFO ), M, Q( 2, IB ), M )
         CALL DCOPY( M, DUM, 0, DWORK( IWRK+M-1 ), M )
         CALL DAXPY( MM, ONE, Q( 1, IB ), 1, DWORK( IWRK ), 1 )
C
         CALL DGEMM( 'Transpose', 'No Transpose', M, M, M, ONE,
     $               DWORK( IQ4 ), N, DWORK( IS12 ), M, ZERO,
     $               DWORK( IS12+NM ), N )
         CALL DGEMM( 'Transpose', 'No Transpose', M, M, M, ONE,
     $               DWORK( IQ4+M ), N, DWORK( IWRK ), M, ONE,
     $               DWORK( IS12+NM ), N )
C
C        Compute Qa'*Do*Qa + Qb'*Fo*Qb.
C
         CALL MB01LD( 'Upper', 'Transpose', M, M, ZERO, ONE,
     $                DWORK( IS12 ), N, DWORK( IQ4 ), N, DE( 1, 2 ),
     $                LDDE, DWORK( IWRK ), LDWORK-IWRK+1, INFO )
         CALL MB01LD( 'Upper', 'Transpose', M, M, ONE, ONE,
     $                DWORK( IS12 ), N, DWORK( IQ4+M ), N, Q( 1, IFO ),
     $                M, DWORK( IWRK ), LDWORK-IWRK+1, INFO )
      END IF
C
C     Compute Qb'*Vo'*Qc + Qa'*Vo*Qd.
C     Real workspace:     need   w1 + w2 + w3, where
C                                w3 = 2*N**2.
C
      CALL DGEMM( 'Transpose', 'No Transpose', M, M, M, ONE,
     $            FG( 1, 2 ), LDFG, DWORK( IQ4+NM ), N, ZERO,
     $            Q( 1, IFO ), M )
      CALL DGEMM( 'Transpose', 'No Transpose', M, M, M, ONE,
     $            FG( 1, 2 ), LDFG, DWORK( IQ4 ), N, ZERO,
     $            DWORK( IH12+NMM ), N )
      CALL DGEMM( 'Transpose', 'No Transpose', M, M, M, ONE,
     $            DWORK( IQ4+M ), N, Q( 1, IFO ), M, ZERO,
     $            DWORK( IH12+NM ), N )
      CALL DGEMM( 'Transpose', 'No Transpose', M, M, M, ONE,
     $            DWORK( IH12+NMM ), N, DWORK( IQ4+NMM ), N, ONE,
     $            DWORK( IH12+NM ), N )
C
C     Compute the upper triangle of Qa'*Vo*Qb + (Qa'*Vo*Qb)'.
C
      CALL DSYR2K( 'Upper', 'Transpose', M, M, ONE, DWORK( IH12+NMM ),
     $             N, DWORK( IQ4+M ), N, ZERO, DWORK( IH12 ), N )
C
C     Compute the upper triangle of Qc'*Vo*Qd + (Qc'*Vo*Qd)'.
C
      CALL DSYR2K( 'Upper', 'Transpose', M, M, ONE, Q( 1, IFO ), M,
     $             DWORK( IQ4+NMM ), N, ZERO, DWORK( IH12+NMM ), N )
C
C     Return C2out.
C
      CALL DSCAL(  MM, -ONE, Q( 1, IC2 ), 1 )
      CALL MA02AD( 'Upper', M, M, Q( 1, IC2 ), M, DE, LDDE )
      CALL DCOPY(  M-1, Q( 2, IC2 ), M+1, DE( 1, 2 ), LDDE+1 )
C
C     STEP 4: Apply MB03JD to reorder the eigenvalues with strictly
C             negative real part to the top.
C
C     Real workspace:     need   w1 + w2 + w3 + MAX(8*N+32,108),
C                                w3 = 2*N**2.
C     Integer workspace:  need   2*N + 1.
C
      IWRK = IH12 + NN
C
      CALL MB03JD( CMPQ, N2, DWORK( IS11 ), N, DWORK( IS12 ), N,
     $             DWORK( IH11 ), N, DWORK( IH12 ), N, Q, LDQ, NEIG,
     $             IWORK, LIWORK, DWORK( IWRK ), LDWORK-IWRK+1, INFO )
      IF( INFO.GT.0 ) THEN
         INFO = INFO + 1
         RETURN
      END IF
C
C     STEP 5: Compute the deflating subspace corresponding to the
C             eigenvalues with strictly negative real part.
C
C     Real workspace:     need   w2 + 3*N**2, if ORTH = 'QR'.
C                                w2 + 4*N**2, otherwise.
C
      IWRK = IS11
      IF( QR )
     $   NEIG = NEIG/2
C
C     Compute [ J*Q1*J' Q2 ].
C
      CALL DLACPY( 'Full', M, M, DWORK( IQ1+NMM ), N, DWORK( IWRK ), N )
      CALL DLACPY( 'Full', M, M, DWORK( IQ1+NM ), N, DWORK( IWRK+M ),
     $             N )
      DO 10 J = 1, M
         CALL DSCAL( M, -ONE, DWORK( IWRK+M+(J-1)*N ), 1 )
   10 CONTINUE
      CALL DLACPY( 'Full', M, M, DWORK( IQ1+M ), N, DWORK( IWRK+NM ),
     $             N )
      DO 20 J = 1, M
         CALL DSCAL( M, -ONE, DWORK( IWRK+NM+(J-1)*N ), 1 )
   20 CONTINUE
      CALL DLACPY( 'Full', M, M, DWORK( IQ1 ), N, DWORK( IWRK+NMM ), N )
C
      CALL DLACPY( 'Full', N, N, DWORK( IQ2 ), N, DWORK( IWRK+NN ), N )
C
C     Compute the first NEIG columns of P*[ Q3  0; 0 Q4 ]*Q.
C
      IRT = IWRK + N*N2
      CALL DGEMM( 'No Transpose', 'No Transpose', M, NEIG, N, ONE,
     $            DWORK( IQ3 ), N, Q, LDQ, ZERO, DWORK( IRT ), N2 )
      CALL DGEMM( 'No Transpose', 'No Transpose', M, NEIG, N, ONE,
     $            DWORK( IQ4 ), N, Q( N+1, 1 ), LDQ, ZERO,
     $            DWORK( IRT+M ), N2 )
      CALL DGEMM( 'No Transpose', 'No Transpose', M, NEIG, N, ONE,
     $            DWORK( IQ3+M ), N, Q, LDQ, ZERO, DWORK( IRT+N ), N2 )
      CALL DGEMM( 'No Transpose', 'No Transpose', M, NEIG, N, ONE,
     $            DWORK( IQ4+M ), N, Q( N+1, 1 ), LDQ, ZERO,
     $            DWORK( IRT+N+M ), N2 )
C
C     Compute the deflating subspace.
C
      CALL DGEMM( 'No Transpose', 'No Transpose', N, NEIG, N2,
     $            SQRT( TWO )/TWO, DWORK( IWRK ), N, DWORK( IRT ), N2,
     $            ZERO, Q, LDQ )
C
C     Orthogonalize the basis given in Q(1:n,1:neig).
C
      IWRK = NEIG + 1
      IF( SVD ) THEN
C
C        Real workspace:     need   N + MAX(1,5*N);
C                            prefer larger.
C
         CALL DGESVD( 'Overwrite', 'No V', N, NEIG, Q, LDQ, DWORK,
     $                DWORK, 1,  DWORK, 1, DWORK( IWRK ), LDWORK-IWRK+1,
     $                INFO )
         IF( INFO.GT.0 ) THEN
            INFO = 4
            RETURN
         END IF
         OPTDW = MAX( OPTDW, INT( DWORK( IWRK ) ) + IWRK - 1 )
         NEIG = NEIG/2
C
      ELSE
         IF( QR ) THEN
C
C           Real workspace:     need   N;
C                               prefer M+M*NB, where NB is the optimal
C                                              blocksize.
C
            CALL DGEQRF( N, NEIG, Q, LDQ, DWORK, DWORK( IWRK ),
     $                   LDWORK-IWRK+1, INFO )
         ELSE
C
C           Real workspace:     need   4*N+1;
C                               prefer 3*N+(N+1)*NB.
C
            DO 30 J = 1, NEIG
               IWORK( J ) = 0
   30       CONTINUE
            CALL DGEQP3( N, NEIG, Q, LDQ, IWORK, DWORK, DWORK( IWRK ),
     $                   LDWORK-IWRK+1, INFO )
         END IF
         OPTDW = MAX( OPTDW, INT( DWORK( IWRK ) ) + IWRK - 1 )
C
C        Real workspace:     need   2*NEIG;
C                            prefer NEIG + NEIG*NB.
C
         CALL DORGQR( N, NEIG, NEIG, Q, LDQ, DWORK, DWORK( IWRK ),
     $                LDWORK-IWRK+1, INFO )
         OPTDW = MAX( OPTDW, INT( DWORK( IWRK ) ) + IWRK - 1 )
         IF( QRP )
     $      NEIG = NEIG/2
      END IF
C
      DWORK( 1 ) = OPTDW
      RETURN
C *** Last line of MB03LD ***
      END


      function sum(x,nx)
c-------------------------------------------------------------------
c      finds the sum of the first nx elements of vector x
c-------------------------------------------------------------------
      dimension x(nx)
      sum=0.0
      do 100 i=1,nx
  100 sum=sum+x(i)
      return
      end

c $Id$


!==============================================================================!
!                                    neu_hex                                   !
!                                                                              !
!                      7---(11)----8             7-----------8                 !
!                     /|          /|            /|          /|                 !
!                  (12)        (10)|           /           / |                 !
!                   /  |        /  |          / (8)       / (7)                !
!                  5----(9)----6   |         5-----------6   |                 !
!                  |   |       |   |         |   |       |   |                 !
!                  |   3- - (3)|- -4         |   3- - - -|- -4                 !
!                  |  /        |  /         (5) /       (6) /                  !
!                  |(4)        |(2)          |           | /                   !
!                  |/          |/            |/          |/                    !
!                  1----(1)----2             1-----------2                     !
!                                                                              !
!------------------------------------------------------------------------------!
!                                   neu_tet                                    !
!                                                                              !
!                          4-----3                   4-(6)-3                   !
!                         / \  .'|                  / \  .'|                   !
!                        /   \'  |                 /   \'  |                   !
!                       /  (3)\ (2)              (4) .'(5) |                   !
!                      / .'    \ |               / .'    \ |                   !
!                     /.'       \|              /.'       \|                   !
!                    1----(1)----2             1-----------2                   !
!                                                                              !
!------------------------------------------------------------------------------!
!                                  neu_wed                                     !
!                                                                              !
!                        6.                        6.                          !
!                       /| `.                     /| `.                        !
!                     (9)   (8)                  /     `.                      !
!                     /  |     `.               / (6)    `.                    !
!                    4----(7)----5             4-----------5                   !
!                    |   |       |             |   |       |                   !
!                    |   3.      |             |   3.      |                   !
!                    |  /  '.    |            (4) /  `.   (5)                  !
!                    |(3)   (2)  |             |       `.  |                   !
!                    |/        `.|             |/        `.|                   !
!                    1----(1)----2             1-----------2                   !
!                                                                              !
!------------------------------------------------------------------------------!
!                                   neu_pyr                                    !
!                                                                              !
!                                     .5.                                      !
!                                   .'/ \`.                                    !
!                                 .' /   \ `.                                  !
!                               (7) /     \ (8)                                !
!                             .'   /       \   `.                              !
!                           3' - -/- -(3)- -\- - `4                            !
!                           |   (5)         (6)   |                            !
!                           |   /             \   |                            !
!                          (4) /               \ (2)                           !
!                           | /                 \ |                            !
!                           |/                   \|                            !
!                           1---------(1)---------2                            !
!                                                                              !
!------------------------------------------------------------------------------!
!   Note:
!
!   neu_tet, neu_pyr, neu_wed and neu_hex hold -1 where unused
!==============================================================================!

  ! tet cell faces nodal connections
  integer, parameter, dimension(12, 2) ::    neu_tet =      &
                               transpose(reshape( (/ 1, 2,  &
                                                     2, 3,  &
                                                     3, 1,  &
                                                     1, 4,  &
                                                     2, 4,  &
                                                     3, 4,  &
                                                    -1,-1,  &
                                                    -1,-1,  &
                                                    -1,-1,  &
                                                    -1,-1,  &
                                                    -1,-1,  &
                                                    -1,-1  /), (/2, 12/) ))

  ! hex cell faces nodal connections
  integer, parameter, dimension(12, 2) ::    neu_hex =      &
                               transpose(reshape( (/ 1, 2,  &
                                                     2, 4,  &
                                                     4, 3,  &
                                                     3, 1,  &
                                                     1, 5,  &
                                                     2, 6,  &
                                                     3, 7,  &
                                                     4, 8,  &
                                                     5, 6,  &
                                                     6, 8,  &
                                                     8, 7,  &
                                                     7, 5  /), (/2, 12/) ))

  ! wed cell faces nodal connections
  integer, parameter, dimension(12, 2) ::    neu_wed =       &
                               transpose(reshape( (/ 1, 2,  &
                                                     2, 3,  &
                                                     3, 1,  &
                                                     1, 4,  &
                                                     2, 5,  &
                                                     3, 6,  &
                                                     4, 5,  &
                                                     5, 6,  &
                                                     6, 4,  &
                                                    -1,-1,  &
                                                    -1,-1,  &
                                                    -1,-1  /), (/2, 12/) ))

  ! pyr cell faces nodal connections
  integer, parameter, dimension(12, 2) ::    neu_pyr =      &
                               transpose(reshape( (/ 1, 2,  &
                                                     2, 4,  &
                                                     4, 3,  &
                                                     3, 1,  &
                                                     1, 5,  &
                                                     2, 5,  &
                                                     3, 5,  &
                                                     4, 5,  &
                                                    -1,-1,  &
                                                    -1,-1,  &
                                                    -1,-1,  &
                                                    -1,-1  /), (/2, 12/) ))


module stats2
    implicit none
    save
    private
    public :: f, g, h, &
              c, dc, d2c, &
              setf, setg, seth, &
              setc, setdc, setd2c, &
              subproblem, iteration, armijo, norm, angle, &
              initstat, printheader, printstat, setmethod

    interface
        function f_t(x)
            double precision, intent(in) :: x(:)
            double precision             :: f_t
        end function f_t

        subroutine g_t(gx, x)
            double precision, intent(in)  :: x(:)
            double precision, intent(out) :: gx(:)
        end subroutine g_t

        subroutine h_t(hx, x)
            double precision, intent(in)  :: x(:)
            double precision, intent(out) :: hx(:, :)
        end subroutine h_t

        subroutine c_t(cx, x)
            double precision, intent(in)  :: x(:)
            double precision, intent(out) :: cx(:)
        end subroutine c_t

        subroutine dc_t(dcx, x)
            double precision, intent(in)  :: x(:)
            double precision, intent(out) :: dcx(:, :)
        end subroutine dc_t

        subroutine d2c_t(d2cx, x)
            double precision, intent(in)  :: x(:)
            double precision, intent(out) :: d2cx(:, :, :)
        end subroutine d2c_t
    end interface

    procedure   (f_t), pointer ::   f_ptr => null()
    procedure   (g_t), pointer ::   g_ptr => null()
    procedure   (h_t), pointer ::   h_ptr => null()
    procedure   (c_t), pointer ::   c_ptr => null()
    procedure  (dc_t), pointer ::  dc_ptr => null()
    procedure (d2c_t), pointer :: d2c_ptr => null()

    integer          :: n, m
    integer          :: nsub, nit, narm, nnor, nang
    integer          :: nf, ng, nh
    integer          :: nc, ndc, nd2c
    character(len=8) :: method

contains
    subroutine initstat(n_, m_)
        integer, intent(in) :: n_, m_

        n = n_
        m = m_
        nsub = 0
        nit  = 0
        narm = 0
        nnor = 0
        nang = 0
        nf   = 0
        nh   = 0
        ng   = 0

        method = ""
          f_ptr => null()
          g_ptr => null()
          h_ptr => null()
          c_ptr => null()
         dc_ptr => null()
        d2c_ptr => null()
    end subroutine initstat

    subroutine setf(p)
        procedure (f_t) :: p
        f_ptr => p
    end subroutine setf

    subroutine setg(p)
        procedure (g_t) :: p
        g_ptr => p
    end subroutine setg

    subroutine seth(p)
        procedure (h_t) :: p
        h_ptr => p
    end subroutine seth

    subroutine setc(p)
        procedure (c_t) :: p
        c_ptr => p
    end subroutine setc

    subroutine setdc(p)
        procedure (dc_t) :: p
        dc_ptr => p
    end subroutine setdc

    subroutine setd2c(p)
        procedure (d2c_t) :: p
        d2c_ptr => p
    end subroutine setd2c

    function f(x)
        double precision, intent(in) :: x(:)
        double precision             :: f

        nf = nf + 1

        f = f_ptr(x)
    end function f

    subroutine g(gx, x)
        double precision, intent(in)  :: x(:)
        double precision, intent(out) :: gx(:)

        ng = ng + 1

        call g_ptr(gx, x)
    end subroutine g

    subroutine h(hx, x)
        double precision, intent(in)  :: x(:)
        double precision, intent(out) :: hx(:, :)

        nh = nh + 1

        call h_ptr(hx, x)
    end subroutine h

    subroutine c(cx, x)
        double precision, intent(in)  :: x(:)
        double precision, intent(out) :: cx(:)

        nc = nc + 1

        call c_ptr(cx, x)
    end subroutine c

    subroutine dc(dcx, x)
        double precision, intent(in)  :: x(:)
        double precision, intent(out) :: dcx(:, :)

        ndc = ndc + 1

        call dc_ptr(dcx, x)
    end subroutine dc

    subroutine d2c(d2cx, x)
        double precision, intent(in)  :: x(:)
        double precision, intent(out) :: d2cx(:, :, :)

        nd2c = nd2c + 1

        call d2c_ptr(d2cx, x)
    end subroutine d2c

    subroutine subproblem()
        nsub = nsub + 1
        nit = 0
    end subroutine subproblem

    subroutine iteration()
        nit = nit + 1

        if (nit > 1000000) then
            print '(a8, a10)', method, "FC"
            write (57, *), method, " & ", "FC", " \\"
            call exit(1)
        end if
    end subroutine iteration

    subroutine armijo()
        narm = narm + 1
    end subroutine armijo

    subroutine norm()
        nnor = nnor + 1
    end subroutine norm

    subroutine angle()
        nang = nang + 1
    end subroutine angle

    subroutine printheader()
        print '(a22, a16, a10, a10, a12, a13, a10, a10, a11)', "‖c(x)‖", "‖∇L‖", "sub", "f", "∇f", "∇²f", &
                                                           "armijo", "norma", "ângulo"
    end subroutine printheader

    subroutine printstat(x, mu)
        double precision, intent(in) :: x(:)
        double precision, intent(in) :: mu

        double precision, allocatable :: cx(:)
        double precision, allocatable :: dcx(:, :)
        double precision, allocatable :: gx(:)
        double precision, allocatable :: dL(:)

        integer :: i, k

        allocate(cx(m))
        allocate(dcx(m, n))
        allocate(gx(n))
        allocate(dL(n))

        call c_ptr(cx, x)
        call dc_ptr(dcx, x)
        call g_ptr(gx, x)

        dL(:) = gx(:)
        do k = 1, m
            do i = 1, n
                dL(i) = dL(i) + cx(k)*dcx(k, i)/mu
            end do
        end do
        print '(a8, 2e10.2, 7i10)', method, norm2(cx), norm2(dL), nsub, nf, ng, nh, narm, nnor, nang
        write (57,'(2a)',advance='no'), method, " & "
        write (57,'(e10.2, a)',advance='no'), norm2(cx), " & "
        write (57,'(e10.2, a)',advance='no'), norm2(dL), " & "
        write (57,'(i10,a)',advance='no'), nsub, " & "
        write (57,'(i10,a)',advance='no'), nf, " & "
        write (57,'(i10,a)',advance='no'), ng, " & "
        write (57,'(i10,a)',advance='no'), nh, " & "
        write (57,'(i10,a)',advance='no'), narm, " & "
        write (57,'(i10,a)',advance='no'), nnor, " & "
        write (57, *), nang, " \\"

        deallocate(cx)
        deallocate(dcx)
        deallocate(gx)
        deallocate(dL)
    end subroutine printstat

    subroutine setmethod(name)
        character(len=*) :: name

        method = name
    end subroutine setmethod

end module stats2


!>
!! Provides an MPI-based implementation of the parallel-in-time Parareal method introduced by Lions, Maday and Turinici in 2001.
!! Denote the fine propagator by \\( F \\) and the coarse propagator by \\( G \\). Then the Parareal iteration reads
!!
!! \\( y^{k+1}_{n+1} = G(y^{k+1}_{n}) + F(y^k_n) - G(y^k_n) \\)
!!
!! Here, communication of \\( y^{k+1}_{n+1} \\) to the next time slice is done via MPI.
MODULE parareal_mpi

USE timestepper, only : Euler, Rk3Ssp, InitializeTimestepper, FinalizeTimestepper

IMPLICIT NONE

INCLUDE 'mpif.h'

PRIVATE
PUBLIC :: InitializePararealMPI, FinalizePararealMPI, PararealMPI

!> For the MPI version, each MPI process runs only a single OpenMP thread
INTEGER, PARAMETER :: Nthreads = 1

INTEGER, PARAMETER :: order_adv_c = 1, order_diff_c = 2, order_adv_f = 5, order_diff_f = 4

!> Three buffers for the solution used in Parareal
DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:) :: Q, GQ, Qend

!> Time step of the coarse propagator
DOUBLE PRECISION :: dt_coarse

!> Time step of the fine propagator
DOUBLE PRECISION :: dt_fine

!> Length of each time slice
DOUBLE PRECISION :: dt_slice

!> Start point of the time slice handled by this MPI process
DOUBLE PRECISION :: tstart_myslice

!> End time of the time slice handled by this MPI process
DOUBLE PRECISION :: tend_myslice

! Internal variables to be used for timers.
DOUBLE PRECISION :: timer_coarse, timer_fine, timer_comm, timer_all, T0, T1

! A number of MPI-related status variables
INTEGER :: mpi_thread_provided, dim, ierr, k, Nproc, myrank, recv_status(MPI_STATUS_SIZE), send_status(MPI_STATUS_SIZE)

CHARACTER(len=64) :: filename

TYPE parareal_parameter
    INTEGER Nx, Ny, Nz
END TYPE

TYPE(parareal_parameter) :: param

CONTAINS

  !> Initialize the Parareal module and all used modules
  SUBROUTINE InitializePararealMPI(nu, Nx, Ny, Nz)
    DOUBLE PRECISION, INTENT(IN) :: nu
    INTEGER, INTENT(IN) :: Nx, Ny, Nz

    CALL InitializeTimestepper(nu, Nx, Ny, Nz, Nthreads)
    ALLOCATE(Q(   -2:Nx+3,-2:Ny+3,-2:Nz+3))
    ALLOCATE(Qend(-2:Nx+3,-2:Ny+3,-2:Nz+3))
    ALLOCATE(GQ(  -2:Nx+3,-2:Ny+3,-2:Nz+3))

    dim = SIZE(Q,1)*SIZE(Q,2)*SIZE(Q,3)

    param%Nx = Nx
    param%Ny = Ny
    param%Nz = Nz

  END SUBROUTINE InitializePararealMPI

  !> Finalize Parareal and used modules
  SUBROUTINE FinalizePararealMPI()
    DEALLOCATE(Q)
    DEALLOCATE(GQ)
    DEALLOCATE(Qend)
    CALL FinalizeTimestepper()
  END SUBROUTINE FinalizePararealMPI

  !> Key routine to run Parareal with MPI.
  !> @param[in] Q_initial Initial value
  !> @param[in] Tend Final simulation time
  !> @param[in] N_fine Number of fine steps *per time slice*
  !> @param[in] N_coarse Number of coarse steps *per time slice*
  !> @param[in] Niter Number of Parareal iterations
  !> @param[in] do_io Whether to perform IO or not
  !> @param[in] be_verbose If true, Parareal gives several status messages that can aid in debugging
  SUBROUTINE PararealMPI(Q_initial, Tend, N_fine, N_coarse, Niter, dx, dy, dz, do_io, be_verbose)

    DOUBLE PRECISION, DIMENSION(-2:,-2:,-2:), INTENT(INOUT) :: Q_initial
    DOUBLE PRECISION,                         INTENT(IN) :: Tend, dx, dy, dz
    INTEGER,                                  INTENT(IN)    :: N_fine, N_coarse, Niter
    LOGICAL,                                  INTENT(IN)    :: do_io, be_verbose

    CALL MPI_COMM_SIZE(MPI_COMM_WORLD, Nproc, ierr)
    CALL MPI_COMM_RANK(MPI_COMM_WORLD, myrank, ierr)

    ! Output
    IF ((myrank==0) .AND. (be_verbose)) THEN
      WRITE(*,'(A, I2)') '--- Running MPI parareal, no. of processes: ', Nproc
    END IF

    ! Divide time interval [0,T] into Nproc many timeslices
    dt_slice  = Tend/DBLE(Nproc)
    dt_fine   = dt_slice/DBLE(N_fine)
    dt_coarse = dt_slice/DBLE(N_coarse)

    tstart_myslice = DBLE(myrank)*dt_slice
    tend_myslice   = DBLE(myrank+1)*dt_slice

    IF (be_verbose) THEN
        WRITE(*,'(A, I2, A, F5.3, A, F5.3)') 'Process ', myrank, ' from ', tstart_myslice, ' to ', tend_myslice
        CALL MPI_BARRIER(MPI_COMM_WORLD, ierr)
        IF (myrank==0) THEN
            WRITE(*,'(A, F9.5)') 'Time slice length:  ', dt_slice
            WRITE(*,'(A, F9.5)') 'Fine step length:   ', dt_fine
            WRITE(*,'(A, F9.5)') 'Coarse step length: ', dt_coarse
        END IF
    END IF

    ! --- START PARAREAL --- !

    timer_all    = MPI_WTIME()
    timer_fine   = 0.0
    timer_coarse = 0.0
    timer_comm   = 0.0

    T0 = MPI_WTIME()

    ! Q <- y^0_0
    Q = Q_initial

    IF (myrank>0) THEN
        ! coarse predictor to get initial guess at beginning of slice
        ! Q <- y^0_n = G(y^0_(n-1)) = G(G(y^0_(n-2))) = ...
        CALL Euler(Q, DBLE(0.0), tstart_myslice, myrank*N_coarse, dx, dy, dz, order_adv_c, order_diff_c)
    END IF

    ! one more coarse step to get coarse value at end of slice
    ! GQ <- G(y^0_n)
    GQ = Q

    CALL Euler(GQ, tstart_myslice, tend_myslice, N_coarse, dx, dy, dz, order_adv_c, order_diff_c)

    ! Qend <- G(y^0_n) = y^0_(n+1)
    Qend = GQ

    T1 = MPI_WTIME()
    timer_coarse = timer_coarse + (T1-T0)

    DO k=1,Niter   ! Parareal iteration

      ! Initial state:
      ! Q     <- y^(k-1)_n
      ! GQ    <- G(y^(k-1)_n)
      ! Qend  <- y(k-1)_(n+1)
      !
      ! End state:
      ! Q     <- y^k_n
      ! GQ    <- G(y^k_n)
      ! Qend  <- y^k_(n+1)

      T0 = MPI_WTIME()

      ! Run fine integrator:
      ! Q <- F(y^(k-1)_n)
      CALL Rk3SSp(Q, tstart_myslice, tend_myslice, N_fine, dx, dy, dz, order_adv_f, order_diff_f)

      ! Compute difference fine minus coarse
      ! Qend <- F(y^(k-1)_n) - G(y^(k-1)_n)
      Qend = Q - GQ

      T1 = MPI_WTIME()
      timer_fine = timer_fine + (T1-T0)

      ! Fetch updated value from previous process
      IF(myrank>0) THEN

        ! Q <- y^k_n
        T0 = MPI_WTIME()
        CALL MPI_RECV(Q, dim, MPI_DOUBLE_PRECISION, myrank-1, 0, MPI_COMM_WORLD, recv_status, ierr)
        T1 = MPI_WTIME()
        timer_comm = timer_comm + (T1-T0)

      ELSE IF (myrank==0) THEN

        ! Fetch initial value again
        ! Q <- y^k_n with n=0
        T0 = MPI_WTIME()
        Q = Q_initial
        T1 = MPI_WTIME()
        timer_comm = timer_comm + (T1-T0)

      ELSE
        WRITE(*,*) 'Found negative value for myrank, now exiting.'
        STOP
      END IF

      ! GQ <- y^k_n
      GQ = Q

      ! Run correction
      ! GQ <- G(y^k_n)
      T0 = MPI_WTIME()
      CALL Euler(GQ, tstart_myslice, tend_myslice, N_coarse, dx, dy, dz, order_adv_c, order_diff_c)
      T1 = MPI_WTIME()

      ! Correct
      ! Qend <- G(y^k_n) + F(y^(k-1))_n - G(y^(k-1)_n) = y^k_(n+1)
      Qend = GQ + Qend

      timer_coarse = timer_coarse + (T1-T0)

      ! Send forward updated value
      IF(myrank<Nproc-1) THEN
        T0 = MPI_WTIME()
        CALL MPI_SEND(Qend, dim, MPI_DOUBLE_PRECISION, myrank+1, 0, MPI_COMM_WORLD, send_status, ierr)
        T1 = MPI_WTIME()
        timer_comm = timer_comm + (T1-T0)
      END IF

      ! Final state:
      ! Q    <- y^k_n
      ! GQ   <- G(y^k_n)
      ! Qend <- y^k_(n+1)

    END DO ! End of parareal loop

    ! --- END PARAREAL --- !

    ! Return final value in Q_initial
    Q_initial = Qend

    timer_all = MPI_WTIME() - timer_all

    IF(do_io) THEN
        WRITE(filename, '(A,I0.2,A,I0.2,A,I0.2,A)') 'q_final_', Niter, '_', myrank, '_', Nproc, '_mpi.dat'
        OPEN(UNIT=myrank, FILE=filename, ACTION='write', STATUS='replace')
        WRITE(myrank, '(F35.25)') Qend(1:param%Nx, 1:param%Ny, 1:param%Nz)
        CLOSE(myrank)
    END IF

    WRITE(filename, '(A,I0.2,A,I0.2,A,I0.2,A)') 'timings_mpi', Niter, '_', myrank, '_', Nproc, '.dat'
    OPEN(UNIT=myrank, FILE=filename, ACTION='write', STATUS='replace')
    WRITE(myrank, '(F8.2)') timer_all
    WRITE(myrank, '(F8.2)') timer_fine
    WRITE(myrank, '(F8.2)') timer_coarse
    WRITE(myrank, '(F8.2)') timer_comm
    CLOSE(myrank)

  END SUBROUTINE PararealMPI

END MODULE parareal_mpi


C FORTRAN test file to test CASE constructs
C This file tests one-to-one comparison with characters

      PROGRAM MAIN

      IMPLICIT NONE

      CHARACTER*1 :: VAR = 'B'
      INTEGER :: X = 40
      INTEGER :: Y
      INTEGER :: Z = 2

      SELECT CASE(VAR)
        CASE('A')
          Y = X/4
         WRITE(*,10) 'The variable is A and Y is: ', Y, Y*Z
        CASE('G')
          Y = X/10
          WRITE(*,10) 'The variable is G and Y is: ', Y, Y*Z
        CASE DEFAULT
          WRITE(*,20) 'Invalid Argument!'

      END SELECT

 10   format(A, I2, I4)
 20   format(A)

      END PROGRAM MAIN


      program demo_anyscalar_to_real
      use, intrinsic :: iso_fortran_env, only : int8, int16, int32, int64
      use, intrinsic :: iso_fortran_env, only : real32, real64, real128
      implicit none
         ! call same function with many scalar input types
         write(*,*)squarei(2_int8)
         write(*,*)squarei(2_int16)
         write(*,*)squarei(2_int32)
         write(*,*)squarei(2_int64)
         write(*,*)squarei(2.0_real32)
         write(*,*)squarei(2.0_real64)
         write(*,*)squarei(2.0_real128)
      contains

      function squarei(invalue) result (dvalue)
      use M_anything, only : anyscalar_to_real
      class(*),intent(in)  :: invalue
      real                 :: invalue_local
      real                 :: dvalue
         invalue_local=anyscalar_to_real(invalue)
         dvalue=invalue_local*invalue_local
      end function squarei

      end program demo_anyscalar_to_real


program TEST
    integer :: n,m,i,j,k(18500)
    character (len=4) :: zzformat
    zzformat ='(I1)'
    !real :: pr
    m=0
    k(1)=0
    k(2)=2
    !pr = 2.7
    ! init tableau
    do j=3,18500
      k(j)=1
    end do
    write (*,'(A3)',advance='no') '2.7'
    !calc
    do n=18499,8,-1
      do i=n+1,2,-1
        k(i) = mod(m,i)
        m = 10*k((i-1)) + m/i
      end do
      if(n<18499) then
        write (*,zzformat,advance='no') m
      end if
    end do
    stop
end program TEST


      SUBROUTINE MB03FZ( COMPQ, COMPU, ORTH, N, Z, LDZ, B, LDB, FG,
     $                   LDFG, NEIG, D, LDD, C, LDC, Q, LDQ, U, LDU,
     $                   ALPHAR, ALPHAI, BETA, IWORK, LIWORK, DWORK,
     $                   LDWORK, ZWORK, LZWORK, BWORK, INFO )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To compute the eigenvalues of a complex N-by-N skew-Hamiltonian/
C     Hamiltonian pencil aS - bH, with
C
C                             (  B  F  )      (  Z11  Z12  )
C       S = J Z' J' Z and H = (        ), Z = (            ),
C                             (  G -B' )      (  Z21  Z22  )
C                                                                   (1)
C           (  0  I  )
C       J = (        ).
C           ( -I  0  )
C
C     The structured Schur form of the embedded real skew-Hamiltonian/
C
C     skew-Hamiltonian pencil, aB_S - bB_T, with B_S = J B_Z' J' B_Z,
C
C             (  Re(Z11)  -Im(Z11)  |  Re(Z12)  -Im(Z12)  )
C             (                     |                     )
C             (  Im(Z11)   Re(Z11)  |  Im(Z12)   Re(Z12)  )
C             (                     |                     )
C       B_Z = (---------------------+---------------------) ,
C             (                     |                     )
C             (  Re(Z21)  -Im(Z21)  |  Re(Z22)  -Im(Z22)  )
C             (                     |                     )
C             (  Im(Z21)   Re(Z21)  |  Im(Z22)   Re(Z22)  )
C                                                                    (2)
C             ( -Im(B)  -Re(B)  | -Im(F)  -Re(F)  )
C             (                 |                 )
C             (  Re(B)  -Im(B)  |  Re(F)  -Im(F)  )
C             (                 |                 )
C       B_T = (-----------------+-----------------) ,  T = i*H,
C             (                 |                 )
C             ( -Im(G)  -Re(G)  | -Im(B')  Re(B') )
C             (                 |                 )
C             (  Re(G)  -Im(G)  | -Re(B') -Im(B') )
C
C     is determined and used to compute the eigenvalues. Optionally, if
C     COMPQ = 'C', an orthonormal basis of the right deflating subspace,
C     Def_-(S, H), of the pencil aS - bH in (1), corresponding to the
C     eigenvalues with strictly negative real part, is computed. Namely,
C     after transforming aB_S - bB_H, in the factored form, by unitary
C     matrices, we have B_Sout = J B_Zout' J' B_Zout,
C
C                ( BA  BD  )              ( BB  BF  )
C       B_Zout = (         ) and B_Hout = (         ),               (3)
C                (  0  BC  )              (  0 -BB' )
C
C     and the eigenvalues with strictly negative real part of the
C     complex pencil aB_Sout - bB_Hout are moved to the top. The
C     notation M' denotes the conjugate transpose of the matrix M.
C     Optionally, if COMPU = 'C', an orthonormal basis of the companion
C     subspace, range(P_U) [1], which corresponds to the eigenvalues
C     with negative real part, is computed. The embedding doubles the
C     multiplicities of the eigenvalues of the pencil aS - bH.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     COMPQ   CHARACTER*1
C             Specifies whether to compute the right deflating subspace
C             corresponding to the eigenvalues of aS - bH with strictly
C             negative real part.
C             = 'N': do not compute the deflating subspace;
C             = 'C': compute the deflating subspace and store it in the
C                    leading subarray of Q.
C
C     COMPU   CHARACTER*1
C             Specifies whether to compute the companion subspace
C             corresponding to the eigenvalues of aS - bH with strictly
C             negative real part.
C             = 'N': do not compute the companion subspace;
C             = 'C': compute the companion subspace and store it in the
C                    leading subarray of U.
C
C     ORTH    CHARACTER*1
C             If COMPQ = 'C' or COMPU = 'C', specifies the technique for
C             computing the orthonormal bases of the deflating subspace
C             and companion subspace, as follows:
C             = 'P':  QR factorization with column pivoting;
C             = 'S':  singular value decomposition.
C             If COMPQ = 'N' and COMPU = 'N', the ORTH value is not
C             used.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             Order of the pencil aS - bH.  N >= 0, even.
C
C     Z       (input/output) COMPLEX*16 array, dimension (LDZ, N)
C             On entry, the leading N-by-N part of this array must
C             contain the non-trivial factor Z in the factorization
C             S = J Z' J' Z of the skew-Hamiltonian matrix S.
C             On exit, if COMPQ = 'C' or COMPU = 'C', the leading
C             N-by-N part of this array contains the upper triangular
C             matrix BA in (3) (see also METHOD). The strictly lower
C             triangular part is not zeroed.
C             If COMPQ = 'N' and COMPU = 'N', this array is unchanged
C             on exit.
C
C     LDZ     INTEGER
C             The leading dimension of the array Z.  LDZ >= MAX(1, N).
C
C     B       (input/output) COMPLEX*16 array, dimension (LDB, N)
C             On entry, the leading N/2-by-N/2 part of this array must
C             contain the matrix B.
C             On exit, if COMPQ = 'C' or COMPU = 'C', the leading
C             N-by-N part of this array contains the upper triangular
C             matrix BB in (3) (see also METHOD). The strictly lower
C             triangular part is not zeroed.
C             If COMPQ = 'N' and COMPU = 'N', this array is unchanged
C             on exit.
C
C     LDB     INTEGER
C             The leading dimension of the array B.  LDB >= MAX(1, N).
C
C     FG      (input/output) COMPLEX*16 array, dimension (LDFG, N)
C             On entry, the leading N/2-by-N/2 lower triangular part of
C             this array must contain the lower triangular part of the
C             Hermitian matrix G, and the N/2-by-N/2 upper triangular
C             part of the submatrix in the columns 2 to N/2+1 of this
C             array must contain the upper triangular part of the
C             Hermitian matrix F.
C             On exit, if COMPQ = 'C' or COMPU = 'C', the leading
C             N-by-N part of this array contains the Hermitian matrix
C             BF in (3) (see also METHOD). The strictly lower triangular
C             part of the input matrix is preserved. The diagonal
C             elements might have tiny imaginary parts.
C             If COMPQ = 'N' and COMPU = 'N', this array is unchanged
C             on exit.
C
C     LDFG    INTEGER
C             The leading dimension of the array FG.  LDFG >= MAX(1, N).
C
C     NEIG    (output) INTEGER
C             If COMPQ = 'C' or COMPU = 'C', the number of eigenvalues
C             in aS - bH with strictly negative real part.
C
C     D       (output) COMPLEX*16 array, dimension (LDD, N)
C             If COMPQ = 'C' or COMPU = 'C', the leading N-by-N part of
C             this array contains the matrix BD in (3) (see METHOD).
C             If COMPQ = 'N' and COMPU = 'N', this array is not
C             referenced.
C
C     LDD     INTEGER
C             The leading dimension of the array D.
C             LDD >= 1,         if COMPQ = 'N' and COMPU = 'N';
C             LDD >= MAX(1, N), if COMPQ = 'C' or  COMPU = 'C'.
C
C     C       (output) COMPLEX*16 array, dimension (LDC, N)
C             If COMPQ = 'C' or COMPU = 'C', the leading N-by-N part of
C             this array contains the lower triangular matrix BC in (3)
C             (see also METHOD). The strictly upper triangular part is
C             not zeroed.
C             If COMPQ = 'N' and COMPU = 'N', this array is not
C             referenced.
C
C     LDC     INTEGER
C             The leading dimension of the array C.
C             LDC >= 1,         if COMPQ = 'N' and COMPU = 'N';
C             LDC >= MAX(1, N), if COMPQ = 'C' or  COMPU = 'C'.
C
C     Q       (output) COMPLEX*16 array, dimension (LDQ, 2*N)
C             On exit, if COMPQ = 'C', the leading N-by-NEIG part of
C             this array contains an orthonormal basis of the right
C             deflating subspace corresponding to the eigenvalues of the
C             pencil aS - bH with strictly negative real part.
C             The remaining entries are meaningless.
C             If COMPQ = 'N', this array is not referenced.
C
C     LDQ     INTEGER
C             The leading dimension of the array Q.
C             LDQ >= 1,           if COMPQ = 'N';
C             LDQ >= MAX(1, 2*N), if COMPQ = 'C'.
C
C     U       (output) COMPLEX*16 array, dimension (LDU, 2*N)
C             On exit, if COMPU = 'C', the leading N-by-NEIG part of
C             this array contains an orthonormal basis of the companion
C             subspace corresponding to the eigenvalues of the
C             pencil aS - bH with strictly negative real part. The
C             remaining entries are meaningless.
C             If COMPU = 'N', this array is not referenced.
C
C     LDU     INTEGER
C             The leading dimension of the array U.
C             LDU >= 1,         if COMPU = 'N';
C             LDU >= MAX(1, N), if COMPU = 'C'.
C
C     ALPHAR  (output) DOUBLE PRECISION array, dimension (N)
C             The real parts of each scalar alpha defining an eigenvalue
C             of the pencil aS - bH.
C
C     ALPHAI  (output) DOUBLE PRECISION array, dimension (N)
C             The imaginary parts of each scalar alpha defining an
C             eigenvalue of the pencil aS - bH.
C             If ALPHAI(j) is zero, then the j-th eigenvalue is real.
C
C     BETA    (output) DOUBLE PRECISION array, dimension (N)
C             The scalars beta that define the eigenvalues of the pencil
C             aS - bH.
C             Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and
C             beta = BETA(j) represent the j-th eigenvalue of the pencil
C             aS - bH, in the form lambda = alpha/beta. Since lambda may
C             overflow, the ratios should not, in general, be computed.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (LIWORK)
C
C     LIWORK  INTEGER
C             The dimension of the array IWORK.  LIWORK >= N+9.
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) returns the optimal LDWORK.
C             On exit, if INFO = -26, DWORK(1) returns the minimum
C             value of LDWORK.
C
C     LDWORK  INTEGER
C             The dimension of the array DWORK.
C             LDWORK >= c*N**2 + N + MAX(2*N, 24), where
C                       c = 18, if                 COMPU = 'C';
C                       c = 16, if COMPQ = 'C' and COMPU = 'N';
C                       c = 13, if COMPQ = 'N' and COMPU = 'N'.
C             For good performance LDWORK should be generally larger.
C
C             If LDWORK = -1, then a workspace query is assumed;
C             the routine only calculates the optimal size of the
C             DWORK array, returns this value as the first entry of
C             the DWORK array, and no error message related to LDWORK
C             is issued by XERBLA.
C
C     ZWORK   COMPLEX*16 array, dimension (LZWORK)
C             On exit, if INFO = 0, ZWORK(1) returns the optimal LZWORK.
C             On exit, if INFO = -28, ZWORK(1) returns the minimum
C             value of LZWORK.
C
C     LZWORK  INTEGER
C             The dimension of the array ZWORK.
C             LZWORK >= 8*N + 28, if COMPQ = 'C';
C             LZWORK >= 6*N + 28, if COMPQ = 'N' and COMPU = 'C';
C             LZWORK >= 1,        if COMPQ = 'N' and COMPU = 'N'.
C             For good performance LZWORK should be generally larger.
C
C             If LZWORK = -1, then a workspace query is assumed;
C             the routine only calculates the optimal size of the
C             ZWORK array, returns this value as the first entry of
C             the ZWORK array, and no error message related to LZWORK
C             is issued by XERBLA.
C
C     BWORK   LOGICAL array, dimension (LBWORK)
C             LBWORK >= 0, if COMPQ = 'N' and COMPU = 'N';
C             LBWORK >= N, if COMPQ = 'C' or  COMPU = 'C'.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0: succesful exit;
C             < 0: if INFO = -i, the i-th argument had an illegal value;
C             = 1: the algorithm was not able to reveal information
C                  about the eigenvalues from the 2-by-2 blocks in the
C                  SLICOT Library routine MB03BD (called by MB04ED);
C             = 2: periodic QZ iteration failed in the SLICOT Library
C                  routines MB03BD or MB03BZ when trying to
C                  triangularize the 2-by-2 blocks;
C             = 3: the singular value decomposition failed in the LAPACK
C                  routine ZGESVD (for ORTH = 'S').
C
C     METHOD
C
C     First T = i*H is set. Then, the embeddings, B_Z and B_T, of the
C     matrices S and T, are determined and, subsequently, the SLICOT
C     Library routine MB04ED is applied to compute the structured Schur
C     form, i.e., the factorizations
C
C     ~                (  BZ11  BZ12  )
C     B_Z = U' B_Z Q = (              ) and
C                      (    0   BZ22  )
C
C     ~                     (  T11  T12  )
C     B_T = J Q' J' B_T Q = (            ),
C                           (   0   T11' )
C
C     where Q is real orthogonal, U is real orthogonal symplectic, BZ11,
C     BZ22' are upper triangular and T11 is upper quasi-triangular.
C
C     Second, the SLICOT Library routine MB03IZ is applied, to compute a
C                    ~                                 ~
C     unitary matrix Q and a unitary symplectic matrix U, such that
C
C                   ~    ~
C     ~  ~   ~   (  Z11  Z12  )
C     U' B_Z Q = (       ~    ) =: B_Zout,
C                (   0   Z22  )
C
C       ~        ~    ~   (  H11  H12  )
C     J Q' J'(-i*B_T) Q = (            ) =: B_Hout,
C                         (   0  -H11' )
C          ~    ~
C     with Z11, Z22', H11 upper triangular, and such that the spectrum
C
C              ~       ~       ~
C     Spec_-(J B_Z' J' B_Z, -i*B_T) is contained in the spectrum of the
C                                                   ~    ~
C     2*NEIG-by-2*NEIG leading principal subpencil aZ22'*Z11 - bH11.
C
C     Finally, the right deflating subspace and the companion subspace
C     are computed. See also page 21 in [1] for more details.
C
C     REFERENCES
C
C     [1] Benner, P., Byers, R., Mehrmann, V. and Xu, H.
C         Numerical Computation of Deflating Subspaces of Embedded
C         Hamiltonian Pencils.
C         Tech. Rep. SFB393/99-15, Technical University Chemnitz,
C         Germany, June 1999.
C
C     NUMERICAL ASPECTS
C                                                               3
C     The algorithm is numerically backward stable and needs O(N )
C     complex floating point operations.
C
C     FURTHER COMMENTS
C
C     This routine does not perform any scaling of the matrices. Scaling
C     might sometimes be useful, and it should be done externally.
C
C     CONTRIBUTOR
C
C     Matthias Voigt, Fakultaet fuer Mathematik, Technische Universitaet
C     Chemnitz, April 30, 2009
C     V. Sima, Aug. 2009 (SLICOT version of the routine ZHAFDF).
C
C     REVISIONS
C     V. Sima, Jan. 2011, Mar. 2011, Aug. 2011, Nov. 2011.
C     M. Voigt, Jan. 2012.
C
C     KEYWORDS
C
C     Deflating subspace, embedded pencil, skew-Hamiltonian/Hamiltonian
C     pencil, structured Schur form.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D+0 )
      COMPLEX*16         CZERO, CONE, CIMAG
      PARAMETER          ( CZERO = ( 0.0D+0, 0.0D+0 ),
     $                      CONE = ( 1.0D+0, 0.0D+0 ),
     $                     CIMAG = ( 0.0D+0, 1.0D+0 ) )
C
C     .. Scalar Arguments ..
      CHARACTER          COMPQ, COMPU, ORTH
      INTEGER            INFO, LDB, LDC, LDD, LDFG, LDQ, LDU, LDWORK,
     $                   LDZ, LIWORK, LZWORK, N, NEIG
C
C     .. Array Arguments ..
      LOGICAL            BWORK( * )
      INTEGER            IWORK( * )
      DOUBLE PRECISION   ALPHAI( * ), ALPHAR( * ), BETA( * ), DWORK( * )
      COMPLEX*16         B( LDB, * ), C( LDC, * ), D( LDD, * ),
     $                   FG( LDFG, * ), Q( LDQ, * ), U( LDU, * ),
     $                   Z( LDZ, * ), ZWORK( * )
C
C     .. Local Scalars ..
      LOGICAL            LCMP, LCMPQ, LCMPU, LQUERY, QR, QRP, SVD
      CHARACTER*14       CMPQ, CMPU, JOB
      INTEGER            I, I1, IB, IEV, IFG, IQ, IQ2, IQB, IS, ITAU,
     $                   IU, IUB, IW, IW1, IWRK, IZ11, IZ22, J, J1, J2,
     $                   J3, JM1, JP2, M, MINDB, MINDW, MINZW, N2, NB,
     $                   NC, NJ1, NN, OPTDW, OPTZW
      DOUBLE PRECISION   EPS, NRMB, TOL
      COMPLEX*16         TMP
C
C     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           DLAMCH, LSAME
C
C     .. External Subroutines ..
      EXTERNAL           DCOPY, DLACPY, DSCAL, MB03BZ, MB03IZ, MB04ED,
     $                   XERBLA, ZAXPY, ZGEMM, ZGEQP3, ZGEQRF, ZGESVD,
     $                   ZLACPY, ZSCAL, ZUNGQR
C
C     .. Intrinsic Functions ..
      INTRINSIC          ABS, CONJG, DBLE, DCMPLX, DIMAG, INT, MAX, MIN,
     $                   MOD, SQRT
C
C     .. Executable Statements ..
C
C     Decode the input arguments.
C
      M    = N/2
      NN   = N*N
      N2   = 2*N
      NEIG = 0
      LCMPQ = LSAME( COMPQ, 'C' )
      LCMPU = LSAME( COMPU, 'C' )
      LCMP  = LCMPQ .OR. LCMPU
      IF( LCMP ) THEN
         QR  = LSAME( ORTH, 'Q' )
         QRP = LSAME( ORTH, 'P' )
         SVD = LSAME( ORTH, 'S' )
      ELSE
         QR  = .FALSE.
         QRP = .FALSE.
         SVD = .FALSE.
      END IF
C
      IF( N.EQ.0 ) THEN
         MINDW = 1
         MINZW = 1
      ELSE
         IF( .NOT.LCMPU ) THEN
            I = 10
            IF( .NOT.LCMPQ ) THEN
               J = 13
               MINZW = 1
            ELSE
               J = 16
               MINZW = 4*N2 + 28
            END IF
         ELSE
            I = 12
            J = 18
            IF( LCMPQ ) THEN
               MINZW = 4*N2 + 28
            ELSE
               MINZW = 3*N2 + 28
            END IF
         END IF
         MINDB = I*NN + N
         MINDW = J*NN + N + MAX( N2, 24 )
      END IF
      LQUERY = LDWORK.EQ.-1 .OR. LZWORK.EQ.-1
C
C     Test the input arguments.
C
      INFO = 0
      IF( .NOT.( LSAME( COMPQ, 'N' ) .OR. LCMPQ ) ) THEN
         INFO = -1
      ELSE IF( .NOT.( LSAME( COMPU, 'N' ) .OR. LCMPU ) ) THEN
         INFO = -2
      ELSE IF( LCMP .AND. .NOT. ( QR .OR. QRP .OR. SVD ) ) THEN
         INFO = -3
      ELSE IF( N.LT.0 .OR. MOD( N, 2 ).NE.0 ) THEN
         INFO = -4
      ELSE IF(  LDZ.LT.MAX( 1, N ) ) THEN
         INFO = -6
      ELSE IF(  LDB.LT.MAX( 1, N ) ) THEN
         INFO = -8
      ELSE IF( LDFG.LT.MAX( 1, N ) ) THEN
         INFO = -10
      ELSE IF(  LDD.LT.1 .OR. (  LCMP .AND. LDD.LT.N  ) ) THEN
         INFO = -13
      ELSE IF(  LDC.LT.1 .OR. (  LCMP .AND. LDC.LT.N  ) ) THEN
         INFO = -15
      ELSE IF(  LDQ.LT.1 .OR. ( LCMPQ .AND. LDQ.LT.N2 ) ) THEN
         INFO = -17
      ELSE IF(  LDU.LT.1 .OR. ( LCMPU .AND. LDU.LT.N  ) ) THEN
         INFO = -19
      ELSE IF( LIWORK.LT.N+9 ) THEN
         INFO = -24
      ELSE IF( .NOT. LQUERY ) THEN
         IF( LDWORK.LT.MINDW ) THEN
            DWORK( 1 ) = MINDW
            INFO = -26
         ELSE IF( LZWORK.LT.MINZW ) THEN
            ZWORK( 1 ) = MINZW
            INFO = -28
         END IF
      END IF
C
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'MB03FZ', -INFO )
         RETURN
      ELSE IF( N.GT.0 ) THEN
C
C        Compute optimal workspace.
C
         IF( LCMPQ ) THEN
            CMPQ = 'Initialize'
         ELSE
            CMPQ = 'No Computation'
         END IF
C
         IF( LCMPU ) THEN
            CMPU = 'Initialize'
         ELSE
            CMPU = 'No Computation'
         END IF
C
         IF( LCMP ) THEN
            JOB = 'Triangularize'
            CALL ZGEQRF( N, N, Z, LDZ, ZWORK, ZWORK, -1, INFO )
            I  = INT( ZWORK( 1 ) )
            NB = MAX( I/N, 2 )
         ELSE
            JOB = 'Eigenvalues'
         END IF
C
         IF( LQUERY ) THEN
            CALL MB04ED( JOB, CMPQ, CMPU, N2, DWORK, N2, DWORK, N,
     $                   DWORK, N, DWORK, N2, DWORK, N, DWORK, N,
     $                   ALPHAI, ALPHAR, BETA, IWORK, LIWORK, DWORK,
     $                   -1, INFO )
            OPTDW = MAX( MINDW, MINDB + INT( DWORK( 1 ) ) )
C
            IF( LCMP ) THEN
               IF( SVD ) THEN
                  CALL ZGESVD( 'O', 'N', N, N, Q, LDQ, DWORK, ZWORK, 1,
     $                         ZWORK, 1, ZWORK, -1, DWORK, INFO )
                  J = INT( ZWORK( 1 ) )
               ELSE
                  IF( QR ) THEN
                     J = M
                     CALL ZGEQRF( N, J, Q, LDQ, ZWORK, ZWORK, -1, INFO )
                  ELSE
                     J = N
                     CALL ZGEQP3( N, J, Q, LDQ, IWORK, ZWORK, ZWORK, -1,
     $                            DWORK, INFO )
                  END IF
                  CALL ZUNGQR( N, J, J, Q, LDQ, ZWORK, ZWORK( 2 ), -1,
     $                         INFO )
                  J = J + MAX( INT( ZWORK( 1 ) ), INT( ZWORK( 2 ) ) )
               END IF
               OPTZW = MAX( MINZW, I, J )
            ELSE
               OPTZW = MINZW
            END IF
            DWORK( 1 ) = OPTDW
            ZWORK( 1 ) = OPTZW
            RETURN
         ELSE
            OPTZW = MINZW
         END IF
      END IF
C
C     Quick return if possible.
C
      IF( N.EQ.0 ) THEN
         DWORK( 1 ) = ONE
         ZWORK( 1 ) = CONE
         RETURN
      END IF
C
C     Determine machine constants.
C
      EPS = DLAMCH( 'Precision' )
      TOL = SQRT( EPS )
C
C     Set up the embeddings of the matrices Z and H.
C     Real workspace:    need   w1, where
C                        w1 = 12*N**2+N, if COMPU = 'C';
C                        w1 = 10*N**2+N, if COMPU = 'N'.
C
      IQ = 1
      IF( LCMPU ) THEN
         IU   = IQ + N2*N2
         IZ11 = IU + N2*N
      ELSE
         IU   = 1
         IZ11 = IQ + N2*N2
      END IF
      IB   = IZ11 + N2*N2
      IFG  = IB   + NN
      IWRK = IFG  + NN + N
C
C     Build the embedding of Z.
C
      IW = IZ11
      IS = IW + N2*M
      DO 50 J = 1, N
         IW1 = IW
         DO 10 I = 1, M
            DWORK( IW ) = DBLE( Z( I, J ) )
            IW = IW + 1
   10    CONTINUE
C
         DO 20 I = 1, M
            DWORK( IW ) =  DIMAG( Z( I, J ) )
            DWORK( IS ) = -DWORK( IW )
            IW = IW + 1
            IS = IS + 1
   20    CONTINUE
         CALL DCOPY( M, DWORK( IW1 ), 1, DWORK( IS ), 1 )
         IW1 = IW
         IS  = IS + M
C
         DO 30 I = M + 1, N
            DWORK( IW ) = DBLE( Z( I, J ) )
            IW = IW + 1
   30    CONTINUE
C
         DO 40 I = M + 1, N
            DWORK( IW ) =  DIMAG( Z( I, J ) )
            DWORK( IS ) = -DWORK( IW )
            IW = IW + 1
            IS = IS + 1
   40    CONTINUE
C
         CALL DCOPY( M, DWORK( IW1 ), 1, DWORK( IS ), 1 )
         IW1 = IW
         IS  = IS + M
         IF( MOD( J, M ).EQ.0 ) THEN
            IW = IW + N2*M
            IS = IS + N2*M
         END IF
   50 CONTINUE
C
C     Build the embedding of B.
C
      IW = IB
      IS = IW + N*M
      DO 80 J = 1, M
         IW1 = IW
         DO 60 I = 1, M
            DWORK( IW ) = -DIMAG( B( I, J ) )
            IW = IW + 1
   60    CONTINUE
C
         DO 70 I = 1, M
            DWORK( IW ) =   DBLE( B( I, J ) )
            DWORK( IS ) = -DWORK( IW )
            IW = IW + 1
            IS = IS + 1
   70    CONTINUE
         CALL DCOPY( M, DWORK( IW1 ), 1, DWORK( IS ), 1 )
         IS = IS + M
   80 CONTINUE
C
C     Build the embeddings of F and G.
C
      IW = IFG
      DO 110 J = 1, M + 1
         DO 90 I = 1, M
            DWORK( IW ) = -DIMAG( FG( I, J ) )
            IW = IW + 1
   90    CONTINUE
C
         IW = IW + J - 1
         IS = IW
         DO 100 I = J, M
            DWORK( IW ) =  DBLE( FG( I, J ) )
            DWORK( IS ) = DWORK( IW )
            IW = IW + 1
            IS = IS + N
  100    CONTINUE
  110 CONTINUE
C
      IW1 = IW
      I1  = IW
      DO 130 J = 2, M + 1
         IS = I1
         I1 = I1 + 1
         DO 120 I = 1, J - 1
            DWORK( IW ) = -DBLE( FG( I, J ) )
            DWORK( IS ) = DWORK( IW )
            IW = IW + 1
            IS = IS + N
  120    CONTINUE
         IW = IW + N - J + 1
  130 CONTINUE
      CALL DLACPY( 'Full', M, M+1, DWORK( IFG ), N, DWORK( IW1-M ), N )
C
C     STEP 1: Apply MB04ED to transform the extended pencil to real
C             skew-Hamiltonian/skew-Hamiltonian Schur form.
C
C     Real workspace:    need   w1 + w2, where
C                        w2 = 6*N**2+MAX(2*N, 24),
C                                        if COMPQ = 'C' or  COMPU = 'C';
C                        w2 = 3*N**2+MAX(2*N, 24),
C                                        if COMPQ = 'N' and COMPU = 'N';
C                        prefer larger.
C     Integer workspace: need   N+9.
C
      CALL MB04ED( JOB, CMPQ, CMPU, N2, DWORK( IZ11 ), N2, DWORK( IB ),
     $             N, DWORK( IFG ), N, DWORK( IQ ), N2, DWORK( IU ), N,
     $             DWORK( IU+NN ), N, ALPHAI, ALPHAR, BETA, IWORK,
     $             LIWORK, DWORK( IWRK ), LDWORK-IWRK+1, INFO )
      IF( INFO.GT.0 )
     $   RETURN
      OPTDW = MAX( MINDW, MINDB + INT( DWORK( IWRK ) ) )
C
C     Scale the eigenvalues.
C
      CALL DSCAL( N, -ONE, ALPHAI, 1 )
C
C     Return if only the eigenvalues are desired.
C
      IF( .NOT.LCMP ) THEN
         DWORK( 1 ) = OPTDW
         ZWORK( 1 ) = OPTZW
         RETURN
      END IF
C
C     Convert the results to complex datatype.
C
      IW = IZ11
      DO 150 J = 1, N
         DO 140 I = 1, J
            Z( I, J ) = DCMPLX( DWORK( IW ) )
            IW = IW + 1
  140    CONTINUE
         IW = IW + N2 - J
  150 CONTINUE
C
      IW = IZ11 + N2*N
      DO 180 J = 1, N
         DO 160 I = 1, N
            D( I, J ) = DCMPLX( DWORK( IW ) )
            IW = IW + 1
  160    CONTINUE
         IW = IW + J - 1
C
         DO 170 I = J, N
            C( I, J ) = DCMPLX( DWORK( IW ) )
            IW = IW + 1
  170    CONTINUE
  180 CONTINUE
C
      IW = IB
      DO 200 J = 1, N
         DO 190 I = 1, MIN( J + 1, N )
            B( I, J ) = DCMPLX( DWORK( IW ) )
            IW = IW + 1
  190    CONTINUE
         IW = IW + N - J - 1
  200 CONTINUE
C
      IW = IFG + N
      DO 220 J = 1, N
         DO 210 I = 1, J - 1
            FG( I, J ) = DCMPLX( DWORK( IW ) )
            IW = IW + 1
  210    CONTINUE
         FG( J, J ) = CZERO
         IW = IW + N - J + 1
  220 CONTINUE
C
      IF( LCMPQ ) THEN
         IW = IQ
         DO 240 J = 1, N2
            DO 230 I = 1, N2
               Q( I, J ) = DCMPLX( DWORK( IW ) )
               IW = IW + 1
  230      CONTINUE
  240    CONTINUE
      END IF
C
      IF( LCMPU ) THEN
         IW = IU
         DO 260 J = 1, N2
            DO 250 I = 1, N
               U( I, J ) = DCMPLX( DWORK( IW ) )
               IW = IW + 1
  250      CONTINUE
  260    CONTINUE
      END IF
C
C     Triangularize the 2-by-2 diagonal blocks in B using the complex
C     version of the periodic QZ algorithm.
C
C     Set up pointers on the inputs and outputs of MB03BZ.
C     A block algorithm is used for updating the matrices for large N.
C
      IQ2  = 1
      IQ   = IQ2  + 4
      IU   = IQ   + 4
      IB   = IU   + 4
      IZ11 = IB   + 4
      IZ22 = IZ11 + 4
      IEV  = IZ22 + 4
      IQB  = IEV  + 4
      IUB  = IQB  + 4*M
      IWRK = IUB  + 4*M
C
C     Set the signatures of the input matrices of MB03BZ.
C
      IWORK( 1 ) =  1
      IWORK( 2 ) = -1
      IWORK( 3 ) = -1
C
      J  = 1
      J1 = 1
      J2 = MIN( N, NB )
C     WHILE( J.LT.N ) DO
  270 CONTINUE
      IF( J.LT.N ) THEN
         NRMB = ABS( B( J, J ) ) + ABS( B( J+1, J+1 ) )
         IF( ABS( B( J+1, J ) ).GT.NRMB*EPS ) THEN
C
C           Triangularization step. Row transformations are blocked.
C           Workspace:            need   8*N + 28, if COMPQ = 'C';
C                                        6*N + 28, if COMPQ = 'N'.
C           Real workspace:       need   2.
C           Integer workspace:    need   5.
C
            NC  = MAX( J2-J-1,  0 )
            J3  = MIN( J2-J1+1, J-1 )
            JM1 = MAX( J-1, 1 )
            JP2 = MIN( J+2, N )
            NJ1 = MAX( N-J-1, 1 )
            CALL ZLACPY( 'Full',  2, 2, B( J, J ), LDB, ZWORK( IB ), 2 )
            CALL ZLACPY( 'Upper', 2, 2, Z( J, J ), LDZ, ZWORK( IZ11 ),
     $                   2 )
            ZWORK( IZ11+1 ) = CZERO
            ZWORK( IZ22 )   = CONJG( C( J, J ) )
            ZWORK( IZ22+1 ) = CZERO
            ZWORK( IZ22+2 ) = CONJG( C( J+1, J ) )
            ZWORK( IZ22+3 ) = CONJG( C( J+1, J+1 ) )
C
            CALL MB03BZ( 'Schur form', 'Initialize', 3, 2, 1, 2, IWORK,
     $                   ZWORK( IB ), 2, 2, ZWORK( IQ2 ), 2, 2,
     $                   ZWORK( IEV ), ZWORK( IEV+2 ), IWORK( 4 ),
     $                   DWORK, LDWORK, ZWORK( IWRK ), LZWORK-IWRK+1,
     $                   INFO )
            IF( INFO.GT.0 ) THEN
               INFO = 2
               RETURN
            END IF
C
C           Update a panel of Z.
C
            CALL ZGEMM(  'No Transpose', 'No Transpose', J-1, 2, 2,
     $                   CONE, Z( 1, J ), LDZ, ZWORK( IQ ), 2, CZERO,
     $                   ZWORK( IWRK ), JM1 )
            CALL ZLACPY( 'Full', J-1, 2, ZWORK( IWRK ), JM1, Z( 1, J ),
     $                   LDZ )
            CALL ZLACPY( 'Upper', 2, 2, ZWORK( IZ11 ), 2, Z( J, J ),
     $                   LDZ )
            Z( J+1, J ) = CZERO
            CALL ZGEMM(  'Conjugate Transpose', 'No Transpose', 2, NC,
     $                   2, CONE, ZWORK( IU ), 2, Z( J, JP2 ), LDZ,
     $                   CZERO, ZWORK( IWRK ), 2 )
            CALL ZLACPY( 'Full', 2, NC, ZWORK( IWRK ), 2, Z( J, JP2 ),
     $                   LDZ )
C
C           Update the columns J and J+1 of D.
C           The transformations on rows are made outside this loop.
C
            CALL ZGEMM(  'No Transpose', 'No Transpose', N, 2, 2, CONE,
     $                   D( 1, J ), LDD, ZWORK( IQ2 ), 2, CZERO,
     $                   ZWORK( IWRK ), N )
            CALL ZLACPY( 'Full', N, 2, ZWORK( IWRK ), N, D( 1, J ),
     $                   LDD )
C
C           Similarly, update C.
C
            C( J,   J   ) = CONJG( ZWORK( IZ22 ) )
            C( J+1, J   ) = CONJG( ZWORK( IZ22+2 ) )
            C( J,   J+1 ) = CZERO
            C( J+1, J+1 ) = CONJG( ZWORK( IZ22+3 ) )
            CALL ZGEMM(  'No Transpose', 'No Transpose', N-J-1, 2, 2,
     $                   CONE, C( JP2, J ), LDC, ZWORK( IQ2 ), 2, CZERO,
     $                   ZWORK( IWRK ), NJ1 )
            CALL ZLACPY( 'Full', N-J-1, 2, ZWORK( IWRK ), NJ1,
     $                   C( JP2, J ), LDC )
C
C           Update a panel of B.
C
            CALL ZGEMM(  'No Transpose', 'No Transpose', J-1, 2, 2,
     $                   CONE, B( 1, J ), LDB, ZWORK( IQ ), 2, CZERO,
     $                   ZWORK( IWRK ), JM1 )
            CALL ZLACPY( 'Full', J-1, 2, ZWORK( IWRK ), JM1, B( 1, J ),
     $                   LDB )
            CALL ZLACPY( 'Upper', 2, 2, ZWORK( IB ), 2, B( J, J ),
     $                   LDB )
            B( J+1, J ) = CZERO
            CALL ZGEMM(  'Conjugate Transpose', 'No Transpose', 2, NC,
     $                   2, CONE, ZWORK( IQ2 ), 2, B( J, JP2 ), LDB,
     $                   CZERO, ZWORK( IWRK ), 2 )
            CALL ZLACPY( 'Full', 2, NC, ZWORK( IWRK ), 2, B( J, JP2 ),
     $                   LDB )
C
C           Update a panel of F.
C
            TMP          =  FG( J+1, J )
            FG( J+1, J ) = -FG( J, J+1 )
            CALL ZGEMM(  'No Transpose', 'No Transpose', J+1, 2, 2,
     $                   CONE, FG( 1, J ), LDFG, ZWORK( IQ2 ), 2, CZERO,
     $                   ZWORK( IWRK ), J+1 )
            CALL ZLACPY( 'Full', J+1, 2, ZWORK( IWRK ), J+1, FG( 1, J ),
     $                   LDFG )
            CALL ZGEMM(  'Conjugate Transpose', 'No Transpose', 2,
     $                   J2-J+1, 2, CONE, ZWORK( IQ2 ), 2, FG( J, J ),
     $                   LDFG, CZERO, ZWORK( IWRK ), 2 )
            CALL ZLACPY( 'Full', 2, J2-J+1, ZWORK( IWRK ), 2,
     $                   FG( J, J ), LDFG )
            FG( J+1, J ) = TMP
C
            IF( LCMPQ ) THEN
C
C              Update Q.
C
               CALL ZGEMM(  'No Transpose', 'No Transpose', N2, 2, 2,
     $                      CONE, Q( 1, J ), LDQ, ZWORK( IQ ), 2, CZERO,
     $                      ZWORK( IWRK ), N2 )
               CALL ZLACPY( 'Full', N2, 2, ZWORK( IWRK ), N2,
     $                      Q( 1, J ), LDQ )
               CALL ZGEMM(  'No Transpose', 'No Transpose', N2, 2, 2,
     $                      CONE, Q( 1, N+J ), LDQ, ZWORK( IQ2 ), 2,
     $                      CZERO, ZWORK( IWRK ), N2 )
               CALL ZLACPY( 'Full', N2, 2, ZWORK( IWRK ), N2,
     $                      Q( 1, N+J ), LDQ )
            END IF
C
            IF( LCMPU ) THEN
C
C              Update U.
C
               CALL ZGEMM(  'No Transpose', 'No Transpose', N, 2, 2,
     $                      CONE, U( 1, J ), LDU, ZWORK( IU ), 2, CZERO,
     $                      ZWORK( IWRK ), N )
               CALL ZLACPY( 'Full', N, 2, ZWORK( IWRK ), N, U( 1, J ),
     $                      LDU )
               CALL ZGEMM(  'No Transpose', 'No Transpose', N, 2, 2,
     $                      CONE, U( 1, N+J ), LDU, ZWORK( IU ), 2,
     $                      CZERO, ZWORK( IWRK ), N )
               CALL ZLACPY( 'Full', N, 2, ZWORK( IWRK ), N, U( 1, N+J ),
     $                      LDU )
            END IF
C
C           Save the needed transformations.
C
            BWORK( J ) = .TRUE.
            J = J + 2
            CALL ZLACPY( 'Full', 2, 2, ZWORK( IQ2 ), 2, ZWORK( IQB ),
     $                   2 )
            CALL ZLACPY( 'Full', 2, 2, ZWORK( IU ), 2, ZWORK( IUB ), 2 )
            IQB = IQB + 4
            IUB = IUB + 4
         ELSE
            BWORK( J )  = .FALSE.
            B( J+1, J ) = CZERO
            J = J + 1
         END IF
C
         IF( J.GE.J2 .AND. J.LE.N ) THEN
            IQB = IEV + 4
            IUB = IQB + 4*M
C
C           Start to update the next panel of Z, B, and F for previous
C           transformations on rows.
C
            I  = 1
            J1 = J2 + 1
            J2 = MIN( N, J1 + NB - 1 )
            NC = J2 - J1 + 1
C           WHILE( I.LT.J-1 ) DO
  280       CONTINUE
            IF( I.LT.J-1 ) THEN
               IF( BWORK( I ) ) THEN
                  CALL ZGEMM(  'Conjugate Transpose', 'No Transpose', 2,
     $                         NC, 2, CONE, ZWORK( IUB ), 2, Z( I, J1 ),
     $                         LDZ, CZERO, ZWORK( IWRK ), 2 )
                  CALL ZLACPY( 'Full', 2, NC, ZWORK( IWRK ), 2,
     $                         Z( I, J1 ), LDZ )
C
                  CALL ZGEMM(  'Conjugate Transpose', 'No Transpose', 2,
     $                         NC, 2, CONE, ZWORK( IQB ), 2, B( I, J1 ),
     $                         LDB, CZERO, ZWORK( IWRK ), 2 )
                  CALL ZLACPY( 'Full', 2, NC, ZWORK( IWRK ), 2,
     $                         B( I, J1 ), LDB )
C
                  CALL ZGEMM(  'Conjugate Transpose', 'No Transpose', 2,
     $                         NC, 2, CONE, ZWORK( IQB ), 2,
     $                         FG( I, J1 ), LDFG, CZERO, ZWORK( IWRK ),
     $                         2 )
                  CALL ZLACPY( 'Full', 2, NC, ZWORK( IWRK ), 2,
     $                         FG( I, J1 ), LDFG )
                  IQB = IQB + 4
                  IUB = IUB + 4
C
                  I = I + 2
               ELSE
                  I = I + 1
               END IF
               GO TO 280
            END IF
C           END WHILE 280
         END IF
         GO TO 270
      END IF
C     END WHILE 270
C
      J1 = 1
      J2 = MIN( N, NB )
C     WHILE( MAX( J1, J2 ).LE.N ) DO
  290 CONTINUE
      IF( MAX( J1, J2 ).LE.N ) THEN
         IQB = IEV + 4
         IUB = IQB + 4*M
C
C        Update the panel of columns J1 to J2 of D and C for the
C        transformations on rows.
C
         I  = 1
         NC = J2 - J1 + 1
C        WHILE( I.LT.N ) DO
  300    CONTINUE
         IF( I.LT.N ) THEN
            IF( BWORK( I ) ) THEN
               CALL ZGEMM(  'Conjugate Transpose', 'No Transpose', 2,
     $                     NC, 2, CONE, ZWORK( IUB ), 2, D( I, J1 ),
     $                     LDD, CZERO, ZWORK( IWRK ), 2 )
               CALL ZLACPY( 'Full', 2, NC, ZWORK( IWRK ), 2, D( I, J1 ),
     $                      LDD )
C
               IF( I.GT.J1 ) THEN
                  J3 = MIN( NC, I - J1 )
                  CALL ZGEMM(  'Conjugate Transpose', 'No Transpose', 2,
     $                         J3, 2, CONE, ZWORK( IUB ), 2, C( I, J1 ),
     $                         LDC, CZERO, ZWORK( IWRK ), 2 )
                  CALL ZLACPY( 'Full', 2, J3, ZWORK( IWRK ), 2,
     $                         C( I, J1 ), LDC )
               END IF
C
               IQB = IQB + 4
               IUB = IUB + 4
C
               I = I + 2
            ELSE
               I = I + 1
            END IF
            GO TO 300
         END IF
C        END WHILE 300
         J1 = J2 + 1
         J2 = MIN( N, J1 + NB - 1 )
         GO TO 290
C        END WHILE 290
      END IF
C
C     Scale B and F by -i.
C
      DO 310 I = 1, N
         CALL ZSCAL( I, -CIMAG, B( 1, I ), 1 )
  310 CONTINUE
C
      DO 320 I = 1, N
         CALL ZSCAL( I, -CIMAG, FG( 1, I ), 1 )
  320 CONTINUE
C
C     STEP 2: Apply MB03IZ to reorder the eigenvalues with strictly
C             negative real part to the top.
C
C     Determine mode of computation.
C
      IF( LCMPQ )
     $   CMPQ = 'Update'
      IF( LCMPU )
     $   CMPU = 'Update'
C
      CALL MB03IZ( CMPQ, CMPU, N2, Z, LDZ, C, LDC, D, LDD, B, LDB, FG,
     $             LDFG, Q, LDQ, U, LDU, U( 1, N+1 ), LDU, NEIG, TOL,
     $             INFO )
C
      IF( QR )
     $   NEIG = NEIG/2
      ITAU = 1
      IWRK = NEIG + 1
C
      IF( LCMPQ ) THEN
C
C        STEP 3: Compute the right deflating subspace corresponding to
C                the eigenvalues with strictly negative real part.
C
         IF( NEIG.LE.M ) THEN
            DO 330 I = 1, NEIG
               CALL ZAXPY( M, CIMAG, Q( M+1, I ), 1, Q( 1, I ), 1 )
  330       CONTINUE
            CALL ZLACPY( 'Full', M, NEIG, Q( N+1, 1 ), LDQ, Q( M+1, 1 ),
     $                   LDQ )
            DO 340 I = 1, NEIG
               CALL ZAXPY( M, CIMAG, Q( M+N+1, I ), 1, Q( M+1, I ), 1 )
  340       CONTINUE
         ELSE
            DO 350 I = 1, M
               CALL ZAXPY( M, CIMAG, Q( M+1, I ), 1, Q( 1, I ), 1 )
  350       CONTINUE
            CALL ZLACPY( 'Full', M, M, Q( N+1, 1 ), LDQ, Q( M+1, 1 ),
     $                   LDQ )
            DO 360 I = 1, M
               CALL ZAXPY( M, CIMAG, Q( M+N+1, I ), 1, Q( M+1, I ), 1 )
  360       CONTINUE
C
            DO 370 I = 1, NEIG - M
               CALL ZAXPY( M, CIMAG, Q( M+1, M+I ), 1, Q( 1, M+I ), 1 )
  370       CONTINUE
            CALL ZLACPY( 'Full', M, NEIG-M, Q( N+1, M+1 ), LDQ,
     $                   Q( M+1, M+1 ), LDQ )
            DO 380 I = 1, NEIG - M
               CALL ZAXPY( M, CIMAG, Q( M+N+1, M+I ), 1, Q( M+1, M+I ),
     $                     1 )
  380       CONTINUE
         END IF
C
C        Orthogonalize the basis given in Q(1:n,1:neig).
C
         IF( SVD ) THEN
C
C           Workspace:          need   3*N;
C                               prefer larger.
C           Real workspace:     need   6*N.
C
            CALL ZGESVD( 'Overwrite', 'No V', N, NEIG, Q, LDQ, DWORK,
     $                   ZWORK, 1, ZWORK, 1, ZWORK, LZWORK,
     $                   DWORK( IWRK ), INFO )
            IF( INFO.GT.0 ) THEN
               INFO = 3
               RETURN
            END IF
            OPTZW = MAX( OPTZW, INT( ZWORK( 1 ) ) )
            IF( .NOT.LCMPU )
     $         NEIG = NEIG/2
C
         ELSE
            IF( QR ) THEN
C
C              Workspace:          need   N;
C                                  prefer M+M*NB, where NB is the optimal
C                                                 blocksize.
C
               CALL ZGEQRF( N, NEIG, Q, LDQ, ZWORK( ITAU ),
     $                      ZWORK( IWRK ), LZWORK-IWRK+1, INFO )
            ELSE
C
C              Workspace:          need   2*N+1;
C                                  prefer N+(N+1)*NB.
C              Real workspace:     need   2*N.
C
               DO 390 J = 1, NEIG
                  IWORK( J ) = 0
  390          CONTINUE
               CALL ZGEQP3( N, NEIG, Q, LDQ, IWORK, ZWORK,
     $                      ZWORK( IWRK ), LZWORK-IWRK+1, DWORK, INFO )
            END IF
            OPTZW = MAX( OPTZW, INT( ZWORK( IWRK ) ) + IWRK - 1 )
C
C           Workspace:     need   2*N;
C                          prefer N+N*NB.
C
            CALL ZUNGQR( N, NEIG, NEIG, Q, LDQ, ZWORK( ITAU ),
     $                   ZWORK( IWRK ), LZWORK-IWRK+1, INFO )
            OPTZW = MAX( OPTZW, INT( ZWORK( IWRK ) ) + IWRK - 1 )
            IF( QRP .AND. .NOT.LCMPU )
     $         NEIG = NEIG/2
         END IF
      END IF
C
      IF( LCMPU ) THEN
C
C        STEP 4: Compute the companion subspace corresponding to the
C                eigenvalues with strictly negative real part.
C
         IF( NEIG.LE.M ) THEN
            DO 400 I = 1, NEIG
               CALL ZAXPY( M, CIMAG, U( M+1, I ), 1, U( 1, I ), 1 )
  400       CONTINUE
            CALL ZLACPY( 'Full', M, NEIG, U( 1, N+1 ), LDU, U( M+1, 1 ),
     $                   LDU )
            DO 410 I = 1, NEIG
               CALL ZAXPY( M, CIMAG, U( M+1, N+I ), 1, U( M+1, I ), 1 )
  410       CONTINUE
         ELSE
            DO 420 I = 1, M
               CALL ZAXPY( M, CIMAG, U( M+1, I ), 1, U( 1, I ), 1 )
  420       CONTINUE
            CALL ZLACPY( 'Full', M, NEIG, U( 1, N+1 ), LDU, U( M+1, 1 ),
     $                   LDU )
            DO 430 I = 1, M
               CALL ZAXPY( M, CIMAG, U( M+1, N+I ), 1, U( M+1, I ), 1 )
  430       CONTINUE
C
            DO 440 I = 1, NEIG - M
               CALL ZAXPY( M, CIMAG, U( M+1, M+I ), 1, U( 1, M+I ), 1 )
  440       CONTINUE
            CALL ZLACPY( 'Full', M, NEIG-M, U( 1, N+M+1 ), LDU,
     $                   U( M+1, M+1 ), LDU )
            DO 450 I = 1, NEIG - M
               CALL ZAXPY( M, CIMAG, U( M+1, N+M+I ), 1, U( M+1, M+I ),
     $                     1 )
  450       CONTINUE
         END IF
         DO 470 J = 1, NEIG
            DO 460 I = M + 1, N
               U( I, J ) = -U( I, J )
  460       CONTINUE
  470    CONTINUE
C
C        Orthogonalize the basis given in U(1:n,1:neig).
C
         IF( SVD ) THEN
C
C           Workspace:          need   3*N;
C                               prefer larger.
C           Real workspace:     need   6*N.
C
            CALL ZGESVD( 'Overwrite', 'No V', N, NEIG, U, LDU, DWORK,
     $                   ZWORK, 1, ZWORK, 1, ZWORK, LZWORK,
     $                   DWORK( IWRK ), INFO )
            IF( INFO.GT.0 ) THEN
               INFO = 3
               RETURN
            END IF
            OPTZW = MAX( OPTZW, INT( ZWORK( 1 ) ) )
            NEIG = NEIG/2
C
         ELSE
            IF( QR ) THEN
C
C              Workspace:          need   N;
C                                  prefer M+M*NB, where NB is the optimal
C                                                 blocksize.
C
               CALL ZGEQRF( N, NEIG, U, LDU, ZWORK( ITAU ),
     $                      ZWORK( IWRK ), LZWORK-IWRK+1, INFO )
            ELSE
C
C              Workspace:          need   2*N+1;
C                                  prefer N+(N+1)*NB.
C              Real workspace:     need   2*N.
C
               DO 480 J = 1, NEIG
                  IWORK( J ) = 0
  480          CONTINUE
               CALL ZGEQP3( N, NEIG, U, LDU, IWORK, ZWORK,
     $                      ZWORK( IWRK ), LZWORK-IWRK+1, DWORK, INFO )
            END IF
            OPTZW = MAX( OPTZW, INT( ZWORK( IWRK ) ) + IWRK - 1 )
C
C           Workspace:     need   2*N;
C                          prefer N+N*NB.
C
            CALL ZUNGQR( N, NEIG, NEIG, U, LDU, ZWORK( ITAU ),
     $                   ZWORK( IWRK ), LZWORK-IWRK+1, INFO )
            OPTZW = MAX( OPTZW, INT( ZWORK( IWRK ) ) + IWRK - 1 )
            IF( QRP )
     $         NEIG = NEIG/2
         END IF
      END IF
C
      DWORK( 1 ) = OPTDW
      ZWORK( 1 ) = OPTZW
C *** Last line of MB03FZ ***
      END