      SUBROUTINE MB05MY( BALANC, N, A, LDA, WR, WI, R, LDR, Q, LDQ,
     $                   DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute, for an N-by-N real nonsymmetric matrix A, the
C     orthogonal matrix Q reducing it to real Schur form T, the
C     eigenvalues, and the right eigenvectors of T.
C
C     The right eigenvector r(j) of T satisfies
C                      T * r(j) = lambda(j) * r(j)
C     where lambda(j) is its eigenvalue.
C
C     The matrix of right eigenvectors R is upper triangular, by
C     construction.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     BALANC  CHARACTER*1
C             Indicates how the input matrix should be diagonally scaled
C             to improve the conditioning of its eigenvalues as follows:
C             = 'N':  Do not diagonally scale;
C             = 'S':  Diagonally scale the matrix, i.e. replace A by
C                     D*A*D**(-1), where D is a diagonal matrix chosen
C                     to make the rows and columns of A more equal in
C                     norm. Do not permute.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrix A.  N >= 0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading N-by-N part of this array must
C             contain the given matrix A.
C             On exit, the leading N-by-N upper quasi-triangular part of
C             this array contains the real Schur canonical form of A.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= max(1,N).
C
C     WR      (output) DOUBLE PRECISION array, dimension (N)
C     WI      (output) DOUBLE PRECISION array, dimension (N)
C             WR and WI contain the real and imaginary parts,
C             respectively, of the computed eigenvalues. Complex
C             conjugate pairs of eigenvalues appear consecutively
C             with the eigenvalue having the positive imaginary part
C             first.
C
C     R       (output) DOUBLE PRECISION array, dimension (LDR,N)
C             The leading N-by-N upper triangular part of this array
C             contains the matrix of right eigenvectors R, in the same
C             order as their eigenvalues. The real and imaginary parts
C             of a complex eigenvector corresponding to an eigenvalue
C             with positive imaginary part are stored in consecutive
C             columns. (The corresponding conjugate eigenvector is not
C             stored.) The eigenvectors are not backward transformed
C             for balancing (when BALANC = 'S').
C
C     LDR     INTEGER
C             The leading dimension of array R.  LDR >= max(1,N).
C
C     Q       (output) DOUBLE PRECISION array, dimension (LDQ,N)
C             The leading N-by-N part of this array contains the
C             orthogonal matrix Q which has reduced A to real Schur
C             form.
C
C     LDQ     INTEGER
C             The leading dimension of array Q.  LDQ >= MAX(1,N).
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) returns the optimal LDWORK.
C             If BALANC = 'S' and LDWORK > 0, DWORK(2),...,DWORK(N+1)
C             return the scaling factors used for balancing.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.  LDWORK >= max(1,4*N).
C             For good performance, LDWORK must generally be 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     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             > 0:  if INFO = i, the QR algorithm failed to compute all
C                   the eigenvalues, and no eigenvectors have been
C                   computed; elements i+1:N of WR and WI contain
C                   eigenvalues which have converged.
C
C     METHOD
C
C     This routine uses the QR algorithm to obtain the real Schur form
C     T of matrix A. Then, the right eigenvectors of T are computed,
C     but they are not backtransformed into the eigenvectors of A.
C     MB05MY is a modification of the LAPACK driver routine DGEEV.
C
C     REFERENCES
C
C     [1] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J.,
C         Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A.,
C         Ostrouchov, S., and Sorensen, D.
C         LAPACK Users' Guide: Second Edition.
C         SIAM, Philadelphia, 1995.
C
C     NUMERICAL ASPECTS
C                               3
C     The algorithm requires 0(N ) operations.
C
C     CONTRIBUTOR
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1997.
C     Supersedes Release 2.0 routine MB05AY.
C
C     REVISIONS
C
C     V. Sima, April 25, 2003, Feb. 15, 2004, Aug. 2011.
C
C     KEYWORDS
C
C     Eigenvalue, eigenvector decomposition, real Schur form.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         BALANC
      INTEGER           INFO, LDA, LDQ, LDR, LDWORK, N
C     ..
C     .. Array Arguments ..
      DOUBLE PRECISION  A( LDA, * ), DWORK( * ), Q( LDQ, * ),
     $                  R( LDR, * ), WI( * ), WR( * )
C     ..
C     .. Local Scalars ..
      LOGICAL           LQUERY, SCALE, SCALEA
      INTEGER           IBAL, IERR, IHI, ILO, ITAU, JWORK, K, MAXWRK,
     $                  MINWRK, NOUT
      DOUBLE PRECISION  ANRM, BIGNUM, CSCALE, EPS, SMLNUM
C     ..
C     .. Local Arrays ..
      LOGICAL           SELECT( 1 )
      DOUBLE PRECISION  DUM( 1 )
C     ..
C     .. External Functions ..
      LOGICAL           LSAME
      DOUBLE PRECISION  DLAMCH, DLANGE
      EXTERNAL          DLAMCH, DLANGE, LSAME
C     ..
C     .. External Subroutines ..
      EXTERNAL          DGEBAL, DGEHRD, DHSEQR, DLABAD, DLACPY, DLASCL,
     $                  DORGHR, DTREVC, XERBLA
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC         INT, MAX, MIN, SQRT
C     ..
C     .. Executable Statements ..
C
C     Test the input scalar arguments.
C
      INFO  = 0
      SCALE = LSAME( BALANC, 'S' )
      IF( .NOT.( LSAME( BALANC, 'N' ) .OR. SCALE ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -4
      ELSE IF( LDR.LT.MAX( 1, N ) ) THEN
         INFO = -8
      ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
         INFO = -10
      ELSE
C
C        Compute workspace.
C        (Note: Comments in the code beginning "Workspace:" describe the
C        minimal amount of workspace needed at that point in the code,
C        as well as the preferred amount for good performance.
C        NB refers to the optimal block size for the immediately
C        following subroutine, as returned by ILAENV.
C        HSDWOR refers to the workspace preferred by DHSEQR; it is
C        computed assuming ILO=1 and IHI=N, the worst case.)
C
         MINWRK = MAX( 1, 4*N )
         LQUERY = LDWORK.EQ.-1
         IF( LDWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
            INFO = -12
         ELSE IF( LQUERY ) THEN
            CALL DGEHRD( N, 1, N, A, LDA, DWORK, DWORK, -1, INFO )
            MAXWRK = INT( DWORK( 1 ) )
            CALL DORGHR( N, 1, N, Q, LDQ, DWORK, DWORK, -1, INFO )
            MAXWRK = 2*N + MAX( MAXWRK, INT( DWORK( 1 ) ) )
            CALL DHSEQR( 'S', 'V', N, 1, N, A, LDA, WR, WI, Q, LDQ,
     $                  DWORK,  -1, INFO )
            MAXWRK = MAX( MAXWRK, N + INT( DWORK( 1 ) ), MINWRK )
         END IF
      END IF
C
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'MB05MY', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         DWORK( 1 ) = MAXWRK
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( N.EQ.0 ) THEN
         DWORK( 1 ) = ONE
         RETURN
      END IF
C
C     Get machine constants.
C
      EPS = DLAMCH( 'P' )
      SMLNUM = DLAMCH( 'S' )
      BIGNUM = ONE / SMLNUM
      CALL DLABAD( SMLNUM, BIGNUM )
      SMLNUM = SQRT( SMLNUM ) / EPS
      BIGNUM = ONE / SMLNUM
C
C     Scale A if max element outside range [SMLNUM,BIGNUM].
C
      ANRM = DLANGE( 'M', N, N, A, LDA, DUM )
      SCALEA = .FALSE.
      IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
         SCALEA = .TRUE.
         CSCALE = SMLNUM
      ELSE IF( ANRM.GT.BIGNUM ) THEN
         SCALEA = .TRUE.
         CSCALE = BIGNUM
      END IF
      IF( SCALEA )
     $   CALL DLASCL( 'G', 0, 0, ANRM, CSCALE, N, N, A, LDA, IERR )
C
C     Balance the matrix, if requested. (Permutation is not possible.)
C     (Workspace: need N)
C
      IBAL = 1
      CALL DGEBAL( BALANC, N, A, LDA, ILO, IHI, DWORK( IBAL ), IERR )
C
C     Reduce to upper Hessenberg form.
C     (Workspace: need 3*N, prefer 2*N+N*NB)
C
      ITAU  = IBAL + N
      JWORK = ITAU + N
      CALL DGEHRD( N, ILO, IHI, A, LDA, DWORK( ITAU ), DWORK( JWORK ),
     $             LDWORK-JWORK+1, IERR )
      MAXWRK = INT( DWORK( JWORK ) )
C
C     Compute right eigenvectors of T.
C     Copy Householder vectors to Q.
C
      CALL DLACPY( 'Lower', N, N, A, LDA, Q, LDQ )
C
C     Generate orthogonal matrix in Q.
C     (Workspace: need 3*N-1, prefer 2*N+(N-1)*NB)
C
      CALL DORGHR( N, ILO, IHI, Q, LDQ, DWORK( ITAU ), DWORK( JWORK ),
     $             LDWORK-JWORK+1, IERR )
      MAXWRK = 2*N + MAX( MAXWRK, INT( DWORK( JWORK ) ) )
C
C     Perform QR iteration, accumulating Schur vectors in Q.
C     (Workspace: need N+1, prefer N+HSDWOR (see comments) )
C
      JWORK = ITAU
      CALL DHSEQR( 'S', 'V', N, ILO, IHI, A, LDA, WR, WI, Q, LDQ,
     $             DWORK( JWORK ), LDWORK-JWORK+1, INFO )
      MAXWRK = MAX( MAXWRK, N + INT( DWORK( JWORK ) ), MINWRK )
C
C     If INFO > 0 from DHSEQR, then quit.
C
      IF( INFO.GT.0 )
     $   GO TO 10
C
C     Compute right eigenvectors of T in R.
C     (Workspace: need 4*N)
C
      CALL DTREVC( 'Right', 'All', SELECT, N, A, LDA, DUM, 1, R, LDR, N,
     $             NOUT, DWORK( JWORK ), IERR )
C
C     Undo scaling if necessary.
C
   10 CONTINUE
      IF( SCALEA ) THEN
         CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, N-INFO, 1, WR( INFO+1 ),
     $                MAX( N-INFO, 1 ), IERR )
         CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, N-INFO, 1, WI( INFO+1 ),
     $                MAX( N-INFO, 1 ), IERR )
         IF( INFO.GT.0 ) THEN
            CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, ILO-1, 1, WR, N,
     $                   IERR )
            CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, ILO-1, 1, WI, N,
     $                   IERR )
         END IF
      END IF
C
      IF ( SCALE ) THEN
         DO 20 K = N, 1, -1
            DWORK( K+1 ) = DWORK( K )
   20    CONTINUE
      END IF
      DWORK( 1 ) = MAXWRK
C
      RETURN
C *** Last line of MB05MY ***
      END


program plotter
use gnuplot_fortran
implicit none

integer, parameter :: n=100
double precision, dimension(0:n) :: x,y  ! index goes from 0 to n
double precision :: x_start = 0.0, x_end = 20, dx
integer :: i

! make x array
dx = (x_end - x_start )/n
x(0:n) = [ (i*dx,i=0,n  ) ]

! make y array
y = sin(x)/(x+1)

! generate data for plot
call plot(x,y)

end program plotter


      SUBROUTINE MB04AD( JOB, COMPQ1, COMPQ2, COMPU1, COMPU2, N, Z, LDZ,
     $                   H, LDH, Q1, LDQ1, Q2, LDQ2, U11, LDU11, U12,
     $                   LDU12, U21, LDU21, U22, LDU22, T, LDT, ALPHAR,
     $                   ALPHAI, BETA, IWORK, LIWORK, DWORK, LDWORK,
     $                   INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute the eigenvalues of a real N-by-N skew-Hamiltonian/
C     Hamiltonian pencil aS - bH with
C
C                                      (  0  I  )
C       S = T Z = J Z' J' Z, where J = (        ),                   (1)
C                                      ( -I  0  )
C
C     via generalized symplectic URV decomposition. That is, orthogonal
C     matrices Q1 and Q2 and orthogonal symplectic matrices U1 and U2
C     are computed such that
C
C                                   ( T11  T12 )
C       Q1' T U1 = Q1' J Z' J' U1 = (          ) = Tout,
C                                   (  0   T22 )
C
C                  ( Z11  Z12 )
C       U2' Z Q2 = (          ) = Zout,                              (2)
C                  (  0   Z22 )
C
C                  ( H11  H12 )
C       Q1' H Q2 = (          ) = Hout,
C                  (  0   H22 )
C
C     where T11, T22', Z11, Z22', H11 are upper triangular and H22' is
C     upper quasi-triangular. The notation M' denotes the transpose of
C     the matrix M.
C     Optionally, if COMPQ1 = 'I' or COMPQ1 = 'U', the orthogonal
C     transformation matrix Q1 will be computed.
C     Optionally, if COMPQ2 = 'I' or COMPQ2 = 'U', the orthogonal
C     transformation matrix Q2 will be computed.
C     Optionally, if COMPU1 = 'I' or COMPU1 = 'U', the orthogonal
C     symplectic transformation matrix
C
C            (  U11  U12  )
C       U1 = (            )
C            ( -U12  U11  )
C
C     will be computed.
C     Optionally, if COMPU2 = 'I' or COMPU2 = 'U', the orthogonal
C     symplectic transformation matrix
C
C            (  U21  U22  )
C       U2 = (            )
C            ( -U22  U21  )
C
C     will be computed.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     JOB     CHARACTER*1
C             Specifies the computation to be performed, as follows:
C             = 'E': compute the eigenvalues only; Z, T, and H will not
C                    necessarily be put into the forms in (2); H22' is
C                    upper Hessenberg;
C             = 'T': put Z, T, and H into the forms in (2), and return
C                    the eigenvalues in ALPHAR, ALPHAI and BETA.
C
C     COMPQ1  CHARACTER*1
C             Specifies whether to compute the orthogonal transformation
C             matrix Q1, as follows:
C             = 'N': Q1 is not computed;
C             = 'I': the array Q1 is initialized internally to the unit
C                    matrix, and the orthogonal matrix Q1 is returned;
C             = 'U': the array Q1 contains an orthogonal matrix Q01 on
C                    entry, and the product Q01*Q1 is returned, where Q1
C                    is the product of the orthogonal transformations
C                    that are applied to the pencil aT*Z - bH on the
C                    left to reduce T, Z, and H to the forms in (2),
C                    for COMPQ1 = 'I'.
C
C     COMPQ2  CHARACTER*1
C             Specifies whether to compute the orthogonal transformation
C             matrix Q2, as follows:
C             = 'N': Q2 is not computed;
C             = 'I': the array Q2 is initialized internally to the unit
C                    matrix, and the orthogonal matrix Q2 is returned;
C             = 'U': the array Q2 contains an orthogonal matrix Q02 on
C                    entry, and the product Q02*Q2 is returned, where Q2
C                    is the product of the orthogonal transformations
C                    that are applied to the pencil aT*Z - bH on the
C                    right to reduce T, Z, and H to the forms in (2),
C                    for COMPQ2 = 'I'.
C
C     COMPU1  CHARACTER*1
C             Specifies whether to compute the orthogonal symplectic
C             transformation matrix U1, as follows:
C             = 'N': U1 is not computed;
C             = 'I': the arrays U11 and U12 are initialized internally
C                    to the unit and zero matrices, respectively, and
C                    the corresponding submatrices of the orthogonal
C                    symplectic matrix U1 are returned;
C             = 'U': the arrays U11 and U12 contain the corresponding
C                    submatrices of an orthogonal symplectic matrix U01
C                    on entry, and the updated submatrices U11 and U12
C                    of the matrix product U01*U1 are returned, where U1
C                    is the product of the orthogonal symplectic
C                    transformations that are applied to the pencil
C                    aT*Z - bH to reduce T, Z, and H to the forms in
C                    (2), for COMPU1 = 'I'.
C
C     COMPU2  CHARACTER*1
C             Specifies whether to compute the orthogonal symplectic
C             transformation matrix U2, as follows:
C             = 'N': U2 is not computed;
C             = 'I': the arrays U21 and U22 are initialized internally
C                    to the unit and zero matrices, respectively, and
C                    the corresponding submatrices of the orthogonal
C                    symplectic matrix U2 are returned;
C             = 'U': the arrays U21 and U22 contain the corresponding
C                    submatrices of an orthogonal symplectic matrix U02
C                    on entry, and the updated submatrices U21 and U22
C                    of the matrix product U02*U2 are returned, where U2
C                    is the product of the orthogonal symplectic
C                    transformations that are applied to the pencil
C                    aT*Z - bH to reduce T, Z, and H to the forms in
C                    (2), for COMPU2 = 'I'.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the pencil aS - bH.  N >= 0, even.
C
C     Z       (input/output) DOUBLE PRECISION array, dimension (LDZ, N)
C             On entry, the leading N-by-N part of this array must
C             contain the matrix Z.
C             On exit, if JOB = 'T', the leading N-by-N part of this
C             array contains the matrix Zout; otherwise, it contains the
C             matrix Z obtained just before the application of the
C             periodic QZ algorithm.
C             The elements of the (2,1) block, i.e., in the rows N/2+1
C             to N and in the columns 1 to N/2 are not set to zero, but
C             are unchanged on exit.
C
C     LDZ     INTEGER
C             The leading dimension of the array Z.  LDZ >= MAX(1, N).
C
C     H       (input/output) DOUBLE PRECISION array, dimension (LDH, N)
C             On entry, the leading N-by-N part of this array must
C             contain the Hamiltonian matrix H (H22 = -H11', H12 = H12',
C             H21 = H21').
C             On exit, if JOB = 'T', the leading N-by-N part of this
C             array contains the matrix Hout; otherwise, it contains the
C             matrix H obtained just before the application of the
C             periodic QZ algorithm.
C
C     LDH     INTEGER
C             The leading dimension of the array H.  LDH >= MAX(1, N).
C
C     Q1      (input/output) DOUBLE PRECISION array, dimension (LDQ1, N)
C             On entry, if COMPQ1 = 'U', then the leading N-by-N part of
C             this array must contain a given matrix Q01, and on exit,
C             the leading N-by-N part of this array contains the product
C             of the input matrix Q01 and the transformation matrix Q1
C             used to transform the matrices Z, T and H.
C             On exit, if COMPQ1 = 'I', then the leading N-by-N part of
C             this array contains the orthogonal transformation matrix
C             Q1.
C             If COMPQ1 = 'N', this array is not referenced.
C
C     LDQ1    INTEGER
C             The leading dimension of the array Q1.
C             LDQ1 >= 1,         if COMPQ1 = 'N';
C             LDQ1 >= MAX(1, N), if COMPQ1 = 'I' or COMPQ1 = 'U'.
C
C     Q2      (input/output) DOUBLE PRECISION array, dimension (LDQ2, N)
C             On entry, if COMPQ2 = 'U', then the leading N-by-N part of
C             this array must contain a given matrix Q02, and on exit,
C             the leading N-by-N part of this array contains the product
C             of the input matrix Q02 and the transformation matrix Q2
C             used to transform the matrices Z, T and H.
C             On exit, if COMPQ2 = 'I', then the leading N-by-N part of
C             this array contains the orthogonal transformation matrix
C             Q2.
C             If COMPQ2 = 'N', this array is not referenced.
C
C     LDQ2    INTEGER
C             The leading dimension of the array Q2.
C             LDQ2 >= 1,         if COMPQ2 = 'N';
C             LDQ2 >= MAX(1, N), if COMPQ2 = 'I' or COMPQ2 = 'U'.
C
C     U11     (input/output) DOUBLE PRECISION array, dimension
C                            (LDU11, N/2)
C             On entry, if COMPU1 = 'U', then the leading N/2-by-N/2
C             part of this array must contain the upper left block of a
C             given matrix U01, and on exit, the leading N/2-by-N/2 part
C             of this array contains the updated upper left block U11 of
C             the product of the input matrix U01 and the transformation
C             matrix U1 used to transform the matrices Z, T, and H.
C             On exit, if COMPU1 = 'I', then the leading N/2-by-N/2 part
C             of this array contains the upper left block U11 of the
C             orthogonal symplectic transformation matrix U1.
C             If COMPU1 = 'N' this array is not referenced.
C
C     LDU11   INTEGER
C             The leading dimension of the array U11.
C             LDU11 >= 1,           if COMPU1 = 'N';
C             LDU11 >= MAX(1, N/2), if COMPU1 = 'I' or COMPU1 = 'U'.
C
C     U12     (input/output) DOUBLE PRECISION array, dimension
C                            (LDU12, N/2)
C             On entry, if COMPU1 = 'U', then the leading N/2-by-N/2
C             part of this array must contain the upper right block of a
C             given matrix U01, and on exit, the leading N/2-by-N/2 part
C             of this array contains the updated upper right block U12
C             of the product of the input matrix U01 and the
C             transformation matrix U1 used to transform the matrices
C             Z, T, and H.
C             On exit, if COMPU1 = 'I', then the leading N/2-by-N/2 part
C             of this array contains the upper right block U12 of the
C             orthogonal symplectic transformation matrix U1.
C             If COMPU1 = 'N' this array is not referenced.
C
C     LDU12   INTEGER
C             The leading dimension of the array U12.
C             LDU12 >= 1,           if COMPU1 = 'N';
C             LDU12 >= MAX(1, N/2), if COMPU1 = 'I' or COMPU1 = 'U'.
C
C     U21     (input/output) DOUBLE PRECISION array, dimension
C                            (LDU21, N/2)
C             On entry, if COMPU2 = 'U', then the leading N/2-by-N/2
C             part of this array must contain the upper left block of a
C             given matrix U02, and on exit, the leading N/2-by-N/2 part
C             of this array contains the updated upper left block U21 of
C             the product of the input matrix U02 and the transformation
C             matrix U2 used to transform the matrices Z, T, and H.
C             On exit, if COMPU2 = 'I', then the leading N/2-by-N/2 part
C             of this array contains the upper left block U21 of the
C             orthogonal symplectic transformation matrix U2.
C             If COMPU2 = 'N' this array is not referenced.
C
C     LDU21   INTEGER
C             The leading dimension of the array U21.
C             LDU21 >= 1,           if COMPU2 = 'N';
C             LDU21 >= MAX(1, N/2), if COMPU2 = 'I' or COMPU2 = 'U'.
C
C     U22     (input/output) DOUBLE PRECISION array, dimension
C                            (LDU22, N/2)
C             On entry, if COMPU2 = 'U', then the leading N/2-by-N/2
C             part of this array must contain the upper right block of a
C             given matrix U02, and on exit, the leading N/2-by-N/2 part
C             of this array contains the updated upper right block U22
C             of the product of the input matrix U02 and the
C             transformation matrix U2 used to transform the matrices
C             Z, T, and H.
C             On exit, if COMPU2 = 'I', then the leading N/2-by-N/2 part
C             of this array contains the upper right block U22 of the
C             orthogonal symplectic transformation matrix U2.
C             If COMPU2 = 'N' this array is not referenced.
C
C     LDU22   INTEGER
C             The leading dimension of the array U22.
C             LDU22 >= 1,           if COMPU2 = 'N';
C             LDU22 >= MAX(1, N/2), if COMPU2 = 'I' or COMPU2 = 'U'.
C
C     T       (output) DOUBLE PRECISION array, dimension (LDT, N)
C             If JOB = 'T', the leading N-by-N part of this array
C             contains the matrix Tout; otherwise, it contains the
C             matrix T obtained just before the application of the
C             periodic QZ algorithm.
C
C     LDT     INTEGER
C             The leading dimension of the array T.  LDT >= MAX(1, N).
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 defining 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             As a consequence, pairs of complex eigenvalues, stored in
C             consecutive locations, are not complex conjugate.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (LIWORK)
C             On exit, if INFO = 3, IWORK(1) contains the number of
C             (pairs of) possibly inaccurate eigenvalues, q <= N/2, and
C             IWORK(2), ..., IWORK(q+1) indicate their indices.
C             Specifically, a positive value is an index of a real or
C             purely imaginary eigenvalue, corresponding to a 1-by-1
C             block, while the absolute value of a negative entry in
C             IWORK is an index to the first eigenvalue in a pair of
C             consecutively stored eigenvalues, corresponding to a
C             2-by-2 block. A 2-by-2 block may have two complex, two
C             real, two purely imaginary, or one real and one purely
C             imaginary eigenvalue.
C             For i = q+2, ..., 2*q+1, IWORK(i) contains a pointer to
C             the starting location in DWORK of the i-th quadruple of
C             1-by-1 blocks, if IWORK(i-q) > 0, or 2-by-2 blocks,
C             if IWORK(i-q) < 0, defining unreliable eigenvalues.
C             IWORK(2*q+2) contains the number of the 1-by-1 blocks, and
C             IWORK(2*q+3) contains the number of the 2-by-2 blocks,
C             corresponding to unreliable eigenvalues. IWORK(2*q+4)
C             contains the total number t of the 2-by-2 blocks.
C             If INFO = 0, then q = 0, therefore IWORK(1) = 0.
C
C     LIWORK  INTEGER
C             The dimension of the array IWORK.   LIWORK >= N+18.
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0 or INFO = 3, DWORK(1) returns the
C             optimal LDWORK, and DWORK(2), ..., DWORK(7) contain the
C             Frobenius norms of the factors of the formal matrix
C             product used by the algorithm. In addition, DWORK(8), ...,
C             DWORK(7+6*s) contain the s sextuple values corresponding
C             to the 1-by-1 blocks. Their eigenvalues are real or purely
C             imaginary. Such an eigenvalue is obtained from
C             -i*sqrt((a1/a2/a3)*(a4/a5/a6)), but always taking a
C             positive sign, where a1, ..., a6 are the corresponding
C             sextuple values.
C             Moreover, DWORK(8+6*s), ..., DWORK(7+6*s+24*t) contain the
C             t groups of sextuple 2-by-2 matrices corresponding to the
C             2-by-2 blocks. Their eigenvalue pairs are either complex,
C             or placed on the real and imaginary axes. Such an
C             eigenvalue pair is obtained as -1i*sqrt(ev), but taking
C             positive imaginary parts, where ev are the eigenvalues of
C             the product A1*inv(A2)*inv(A3)*A4*inv(A5)*inv(A6), where
C             A1, ..., A6 define the corresponding 2-by-2 matrix
C             sextuple.
C             On exit, if INFO = -31, DWORK(1) returns the minimum value
C             of LDWORK.
C
C     LDWORK  INTEGER
C             The dimension of the array DWORK.
C             If JOB = 'E' and COMPQ1 = 'N' and COMPQ2 = 'N' and
C             COMPU1 = 'N' and COMPU2 = 'N', then
C                   LDWORK >= 3/2*N**2 + MAX(6*N,54);
C             else, LDWORK >=   3*N**2 + MAX(6*N,54).
C             For good performance LDWORK should generally be larger.
C
C             If LDWORK = -1, then 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 related to LDWORK is issued by
C             XERBLA.
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 periodic QZ algorithm was not able to reveal
C                  information about the eigenvalues from the 2-by-2
C                  blocks in the SLICOT Library routine MB03BD;
C             = 2: the periodic QZ algorithm did not converge in the
C                  SLICOT Library routine MB03BD;
C             = 3: some eigenvalues might be inaccurate, and details can
C                  be found in IWORK and DWORK. This is a warning.
C
C     METHOD
C
C     The algorithm uses Givens rotations and Householder reflections to
C     annihilate elements in T, Z, and H such that T11, T22', Z11, Z22',
C     and H11 are upper triangular and H22' is upper Hessenberg. Finally
C     the periodic QZ algorithm is applied to transform H22' to upper
C     quasi-triangular form while T11, T22', Z11, Z22', and H11 stay in
C     upper triangular form.
C     See also page 17 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 ) real
C     floating point operations.
C
C     CONTRIBUTOR
C
C     Matthias Voigt, Fakultaet fuer Mathematik, Technische Universitaet
C     Chemnitz, December 03, 2008.
C     V. Sima, Dec. 2009 (SLICOT version of the routine DGEURV).
C
C     REVISIONS
C
C     V. Sima, Feb. 2010, Nov. 2010, Aug. 2011, Nov. 2011, July 2012,
C     Oct. 2012, July 2013, Aug. 2014, Mar. 2020, Apr. 2020, May 2020.
C     M. Voigt, Jan. 2012.
C
C     KEYWORDS
C
C     generalized symplectic URV decomposition, periodic QZ algorithm,
C     upper (quasi-)triangular matrix.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO, HALF, ONE, SEVEN
      PARAMETER          ( ZERO  = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0,
     $                     SEVEN = 7.0D+0 )
C
C     .. Scalar Arguments ..
      CHARACTER          COMPQ1, COMPQ2, COMPU1, COMPU2, JOB
      INTEGER            INFO, LDH, LDQ1, LDQ2, LDT, LDU11, LDU12,
     $                   LDU21, LDU22, LDWORK, LDZ, LIWORK, N
C
C     .. Array Arguments ..
      INTEGER            IWORK( * )
      DOUBLE PRECISION   ALPHAI( * ), ALPHAR( * ), BETA( * ),
     $                   DWORK( * ), H( LDH, * ), Q1( LDQ1, * ),
     $                   Q2( LDQ2, * ), T( LDT, * ), U11( LDU11, * ),
     $                   U12( LDU12, * ), U21( LDU21, * ),
     $                   U22( LDU22, * ), Z( LDZ, * )
C
C     .. Local Scalars ..
      LOGICAL            LCMPQ1, LCMPQ2, LCMPU1, LCMPU2, LINIQ1, LINIQ2,
     $                   LINIU1, LINIU2, LQUERY, LTRI, LUPDQ1, LUPDQ2,
     $                   LUPDU1, LUPDU2, UNREL
      CHARACTER*16       CMPQ, CMPSC
      INTEGER            EMAX, EMIN, I, I11, I22, I2X2, IMAT, IQ, ITAU,
     $                   IW, IWARN, IWRK, J, K, L, M, MINDW, MM, NBETA0,
     $                   NINF, OPTDW, P
      DOUBLE PRECISION   BASE, CO, SI, TEMP, TMP1, TMP2
      COMPLEX*16         EIG
C
C     .. Local Arrays ..
      INTEGER            IDUM( 1 )
      DOUBLE PRECISION   DUM(  6 )
C
C     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            IDAMAX
      DOUBLE PRECISION   DLAMCH, DLANTR, DLAPY2
      EXTERNAL           DLAMCH, DLAPY2, IDAMAX, LSAME
C
C     .. External Subroutines ..
      EXTERNAL           DCOPY, DGEMM, DGEQRF, DGERQF, DLACPY, DLARTG,
     $                   DLASET, DORMQR, DORMRQ, DROT, DSCAL, DSWAP,
     $                   MA02AD, MB03BD, XERBLA
C
C     .. Intrinsic Functions ..
      INTRINSIC          ABS, DBLE, DCMPLX, DIMAG, INT, MAX, MOD, SQRT
C
C     .. Executable Statements ..
C
C     Decode the input arguments.
C
      M  = N/2
      MM = M*M
C
      LTRI   = LSAME( JOB,    'T' )
      LINIQ1 = LSAME( COMPQ1, 'I' )
      LUPDQ1 = LSAME( COMPQ1, 'U' )
      LINIQ2 = LSAME( COMPQ2, 'I' )
      LUPDQ2 = LSAME( COMPQ2, 'U' )
      LINIU1 = LSAME( COMPU1, 'I' )
      LUPDU1 = LSAME( COMPU1, 'U' )
      LINIU2 = LSAME( COMPU2, 'I' )
      LUPDU2 = LSAME( COMPU2, 'U' )
      LCMPQ1 = LINIQ1 .OR. LUPDQ1
      LCMPQ2 = LINIQ2 .OR. LUPDQ2
      LCMPU1 = LINIU1 .OR. LUPDU1
      LCMPU2 = LINIU2 .OR. LUPDU2
      IF( N.EQ.0 ) THEN
         MINDW = 7
      ELSE IF( LTRI .OR. LCMPQ1 .OR. LCMPQ2 .OR. LCMPU1 .OR. LCMPU2 )
     $   THEN
         MINDW = 12*MM + MAX( 6*N, 54 )
      ELSE
         MINDW =  6*MM + MAX( 6*N, 54 )
      END IF
      LQUERY = LDWORK.EQ.-1
C
C     Test the input arguments.
C
      INFO = 0
      IF( .NOT.( LSAME( JOB, 'E' ) .OR. LTRI ) ) THEN
         INFO = -1
      ELSE IF( .NOT.( LSAME( COMPQ1, 'N' ) .OR. LCMPQ1 ) ) THEN
         INFO = -2
      ELSE IF( .NOT.( LSAME( COMPQ2, 'N' ) .OR. LCMPQ2 ) ) THEN
         INFO = -3
      ELSE IF( .NOT.( LSAME( COMPU1, 'N' ) .OR. LCMPU1 ) ) THEN
         INFO = -4
      ELSE IF( .NOT.( LSAME( COMPU2, 'N' ) .OR. LCMPU2 ) ) THEN
         INFO = -5
      ELSE IF( N.LT.0 .OR. MOD( N, 2 ).NE.0 ) THEN
         INFO = -6
      ELSE IF( LDZ.LT.MAX( 1, N ) ) THEN
         INFO = -8
      ELSE IF( LDH.LT.MAX( 1, N ) ) THEN
         INFO = -10
      ELSE IF( LDQ1.LT.1  .OR. ( LCMPQ1 .AND.  LDQ1.LT.N ) ) THEN
         INFO = -12
      ELSE IF( LDQ2.LT.1  .OR. ( LCMPQ2 .AND.  LDQ2.LT.N ) ) THEN
         INFO = -14
      ELSE IF( LDU11.LT.1 .OR. ( LCMPU1 .AND. LDU11.LT.M ) ) THEN
         INFO = -16
      ELSE IF( LDU12.LT.1 .OR. ( LCMPU1 .AND. LDU12.LT.M ) ) THEN
         INFO = -18
      ELSE IF( LDU21.LT.1 .OR. ( LCMPU2 .AND. LDU21.LT.M ) ) THEN
         INFO = -20
      ELSE IF( LDU22.LT.1 .OR. ( LCMPU2 .AND. LDU22.LT.M ) ) THEN
         INFO = -22
      ELSE IF( LDT.LT.MAX( 1, N ) ) THEN
         INFO = -24
      ELSE IF( LIWORK.LT.N+18 ) THEN
         INFO = -29
      ELSE IF( .NOT.LQUERY .AND. LDWORK.LT.MINDW ) THEN
         DWORK( 1 ) = MINDW
         INFO = -31
      END IF
C
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'MB04AD', -INFO )
         RETURN
      ELSE IF( N.GT.0 ) THEN
C
C        Compute optimal workspace.
C
         IF( LQUERY ) THEN
            CALL DORMQR( 'Left', 'Transpose', N, N, M, T, LDT, DWORK, T,
     $                   LDT, DWORK, -1, INFO )
            CALL DORMRQ( 'Right', 'Transpose', N, M, M, Z, LDZ, DWORK,
     $                   H, LDH, DUM, -1, INFO )
            I = INT( DUM( 1 ) )
            OPTDW = MAX( INT( DWORK( 1 ) ), I )
            CALL DGERQF( M, M, DWORK, M, DWORK, DWORK, -1, INFO )
            CALL DORMRQ( 'Left', 'No Transpose', M, N, M, DWORK, M,
     $                   DWORK, H, LDH, DUM, -1, INFO )
            OPTDW = M + MAX( OPTDW, MM + MAX( INT( DWORK( 1 ) ),
     $                                        INT( DUM( 1 ) ) ) )
            IF( LCMPQ1 )
     $         OPTDW = MAX( OPTDW, M + MM + I )
            CALL DGEQRF( N, M, DWORK, N, DWORK, DWORK, -1, INFO )
            CALL DORMQR( 'Right', 'No Transpose', N, N, M, DWORK, N,
     $                   DWORK, H, LDH, DUM, -1, INFO )
            OPTDW = MAX( OPTDW, M + M*N + MAX( INT( DWORK( 1 ) ),
     $                                         INT( DUM( 1 ) ) ) )
            IF( LCMPQ2 ) THEN
               CALL DORMQR( 'Left', 'No Transpose', N, N, M, DWORK, N,
     $                      DWORK, Q2, LDQ2, DWORK, -1, INFO )
               OPTDW = MAX( OPTDW, M + M*N + INT( DWORK( 1 ) ) )
            END IF
            DWORK( 1 ) = MAX( OPTDW, MINDW )
            RETURN
         END IF
      END IF
C
C     Quick return if possible.
C
      DUM( 1 ) = ZERO
C
      IF( N.EQ.0 ) THEN
         IWORK( 1 ) = 0
         DWORK( 1 ) = SEVEN
         CALL DCOPY( 6, DUM, 0, DWORK( 2 ), 1 )
         RETURN
      END IF
C
C     Determine machine constants.
C
      BASE = DLAMCH( 'Base' )
      EMIN = INT( DLAMCH( 'Minimum Exponent' ) )
      EMAX = INT( DLAMCH( 'Largest Exponent' ) )
C
C     Find half of the number of infinite eigenvalues if Z is diagonal.
C     Otherwise, find a lower bound of this number.
C
      NINF = 0
      IF( N.EQ.1 ) THEN
         IF( Z( 1, 1 ).EQ.ZERO )
     $      NINF = 1
      ELSE
         IF( DLANTR( 'Max', 'Lower', 'No-diag', N-1, N-1, Z( 2, 1 ),
     $                                LDZ, DWORK ).EQ.ZERO .AND.
     $       DLANTR( 'Max', 'Upper', 'No-diag', N-1, N-1, Z( 1, 2 ),
     $                                LDZ, DWORK ).EQ.ZERO ) THEN
            DO 10 J = 1, M
               IF( Z( J, J ).EQ.ZERO .OR. Z( J+M, J+M ).EQ.ZERO )
     $            NINF = NINF + 1
   10       CONTINUE
         ELSE
            DO 20 J = 1, M
               I = IDAMAX( N, Z( 1, J ),   1 )
               K = IDAMAX( N, Z( 1, M+J ), 1 )
               L = IDAMAX( N, Z( J, 1 ),   LDZ )
               P = IDAMAX( N, Z( M+J, 1 ), LDZ )
               IF( Z( I, J ).EQ.ZERO .OR. Z( K, M+J ).EQ.ZERO .OR.
     $             Z( J, L ).EQ.ZERO .OR. Z( M+J, P ).EQ.ZERO )
     $            NINF = NINF + 1
   20       CONTINUE
         END IF
      END IF
C
C     Initializations.
C
C     Set T = J Z' J'.
C
      CALL MA02AD( 'Full', M, M, Z( M+1, M+1 ), LDZ, T, LDT )
      CALL MA02AD( 'Full', M, M, Z( 1, M+1 ), LDZ, T( 1, M+1 ), LDT )
C
      DO 30 I = 1, M
         CALL DSCAL( M, -ONE, T( 1, M+I ), 1 )
   30 CONTINUE
C
      CALL MA02AD( 'Full', M, M, Z( M+1, 1 ), LDZ, T( M+1, 1 ), LDT )
C
      DO 40 I = 1, M
         CALL DSCAL( M, -ONE, T( M+1, I ), 1 )
   40 CONTINUE
C
      CALL MA02AD( 'Full', M, M, Z, LDZ, T( M+1, M+1 ), LDT )
C
      IF( LINIQ1 )
     $   CALL DLASET( 'Full', N, N, ZERO, ONE, Q1, LDQ1 )
C
      IF( LINIQ2 )
     $   CALL DLASET( 'Full', N, N, ZERO, ONE, Q2, LDQ2 )
C
      IF( LINIU1 ) THEN
         CALL DLASET( 'Full', M, M, ZERO,  ONE, U11, LDU11 )
         CALL DLASET( 'Full', M, M, ZERO, ZERO, U12, LDU12 )
      END IF
C
      IF( LINIU2 ) THEN
         CALL DLASET( 'Full', M, M, ZERO,  ONE, U21, LDU21 )
         CALL DLASET( 'Full', M, M, ZERO, ZERO, U22, LDU22 )
      END IF
C
C     STEP 1: Block triangularize T and Z.
C
C     (Note: Comments in the code beginning "Workspace:" describe the
C     minimal amount of real workspace needed at that point in the
C     code, as well as the preferred amount for good performance.
C     NB refers to the optimal block size for the immediately
C     following subroutine, as returned by ILAENV.)
C
      ITAU = 1
      IWRK = ITAU + M
C
C                                 ( T11 )
C     Perform a QR decomposition, (     ) = Q1*R1.
C                                 ( T21 )
C
C     Workspace:    need   IWRK + M - 1;
C                   prefer IWRK + M*NB - 1.
C
      CALL DGEQRF( N, M, T, LDT, DWORK( ITAU ), DWORK( IWRK ),
     $             LDWORK-IWRK+1, INFO )
C
C            ( T12 )
C     Update (     ).
C            ( T22 )
C
C     Workspace:    need   IWRK + M - 1;
C                   prefer IWRK + M*NB - 1.
C
      CALL DORMQR( 'Left', 'Transpose', N, M, M, T, LDT, DWORK( ITAU ),
     $             T( 1, M+1 ), LDT, DWORK( IWRK ), LDWORK-IWRK+1, INFO
     $           )
C
C     Update H.
C
C     Workspace:    need   IWRK + N - 1;
C                   prefer IWRK + N*NB - 1.
C
      CALL DORMQR( 'Left', 'Transpose', N, N, M, T, LDT, DWORK( ITAU ),
     $             H, LDH, DWORK( IWRK ), LDWORK-IWRK+1, INFO )
      OPTDW = MAX( MINDW, INT( DWORK( IWRK ) ) + IWRK - 1 )
C
      IF( LCMPQ1 ) THEN
C
C        Update Q1.
C
         CALL DORMQR( 'Right', 'No Transpose', N, N, M, T, LDT,
     $                DWORK( ITAU ), Q1, LDQ1, DWORK( IWRK ),
     $                LDWORK-IWRK+1, INFO )
      END IF
C
C     Set the strictly lower triangular part of [ T11; T21 ] to zero.
C
      CALL DLASET( 'Lower', N-1, M, ZERO, ZERO, T( 2, 1 ), LDT )
C
C     Perform an RQ decomposition, T22 = R2*Q2.
C
C     Workspace:    need   IWRK + M - 1;
C                   prefer IWRK + M*NB - 1.
C
      ITAU = MM   + 1
      IWRK = ITAU + M
      CALL MA02AD( 'Full', M, M, T( M+1, M+1 ), LDT, DWORK, M )
      CALL DGERQF( M, M, DWORK, M, DWORK( ITAU ), DWORK( IWRK ),
     $             LDWORK-IWRK+1, INFO )
      OPTDW = MAX( OPTDW, INT( DWORK( IWRK ) ) + IWRK - 1 )
      CALL MA02AD( 'Upper', M, M, DWORK, M, T( M+1, M+1 ), LDT )
C
C     Set the strictly upper triangular part of T22 to zero.
C
      IF( M.GT.1 )
     $   CALL DLASET( 'Upper', M-1, M-1, ZERO, ZERO, T( M+1, M+2 ), LDT
     $              )
C
C     Update H.
C
C     Workspace:    need   IWRK + N - 1;
C                   prefer IWRK + N*NB - 1.
C
      CALL DORMRQ( 'Left', 'No Transpose', M, N, M, DWORK, M,
     $             DWORK( ITAU ), H( M+1, 1 ), LDH, DWORK( IWRK ),
     $             LDWORK-IWRK+1, INFO )
      OPTDW = MAX( OPTDW, INT( DWORK( IWRK ) ) + IWRK - 1 )
C
      IF( LCMPQ1 ) THEN
C
C        Update Q1.
C
         CALL DORMRQ( 'Right', 'Transpose', N, M, M, DWORK, M,
     $                DWORK( ITAU ), Q1( 1, M+1 ), LDQ1, DWORK( IWRK ),
     $                LDWORK-IWRK+1, INFO )
         OPTDW = MAX( OPTDW, INT( DWORK( IWRK ) ) + IWRK - 1 )
      END IF
C
C     Perform a QR decomposition, ( Z21  Z22 )' = Q3*R3.
C
C     Workspace:    need   IWRK + M - 1;
C                   prefer IWRK + M*NB - 1.
C
      ITAU = M*N  + 1
      IWRK = ITAU + M
      CALL MA02AD( 'Full', M, N, Z( M+1, 1 ), LDZ, DWORK, N )
      CALL DGEQRF( N, M, DWORK, N, DWORK( ITAU ), DWORK( IWRK ),
     $             LDWORK-IWRK+1, INFO )
      OPTDW = MAX( OPTDW, INT( DWORK( IWRK ) ) + IWRK - 1 )
C
C     Update ( Z11  Z12 ).
C
      CALL DORMQR( 'Right', 'No Transpose', M, N, M, DWORK, N,
     $             DWORK( ITAU ), Z, LDZ, DWORK( IWRK ),
     $             LDWORK-IWRK+1, INFO )
      CALL MA02AD( 'Upper', M, M, DWORK, N, Z( M+1, M+1 ), LDZ )
C
C     Set the strictly upper triangular part of Z22 to zero.
C
      IF( M.GT.1 )
     $   CALL DLASET( 'Upper', M-1, M-1, ZERO, ZERO, Z( M+1, M+2 ), LDZ
     $              )
C
C     Update H.
C
      CALL DORMQR( 'Right', 'No Transpose', N, N, M, DWORK, N,
     $             DWORK( ITAU ), H, LDH, DWORK( IWRK ), LDWORK-IWRK+1,
     $             INFO )
      OPTDW = MAX( OPTDW, INT( DWORK( IWRK ) ) + IWRK - 1 )
C
      DO 50 I = 1, M
         CALL DSWAP( N, H( 1, I ), 1, H( 1, M+I ), 1 )
   50 CONTINUE
C
      IF( LCMPQ2 ) THEN
C
C        Update Q2.
C
         CALL DORMQR( 'Right', 'No Transpose', N, N, M, DWORK, N,
     $                DWORK( ITAU ), Q2, LDQ2, DWORK( IWRK ),
     $                LDWORK-IWRK+1, INFO )
         OPTDW = MAX( OPTDW, INT( DWORK( IWRK ) ) + IWRK - 1 )
C
         DO 60 I = 1, M
            CALL DSWAP( N, Q2( 1, I ), 1, Q2( 1, M+I ), 1 )
   60    CONTINUE
      END IF
C
C     Perform an RQ decomposition Z12 = R4*Q4.
C
      ITAU = 1
      IWRK = ITAU + M
      CALL DGERQF( M, M, Z( 1, M+1 ), LDZ, DWORK( ITAU ), DWORK( IWRK ),
     $             LDWORK-IWRK+1, INFO )
C
C     Update H.
C
      CALL DORMRQ( 'Right', 'Transpose', N, M, M, Z( 1, M+1 ), LDZ,
     $             DWORK( ITAU ), H, LDH, DWORK( IWRK ), LDWORK-IWRK+1,
     $             INFO )
      OPTDW = MAX( OPTDW, INT( DWORK( IWRK ) ) + IWRK - 1 )
C
      IF( LCMPQ2 ) THEN
C
C        Update Q2.
C
         CALL DORMRQ( 'Right', 'Transpose', N, M, M, Z( 1, M+1 ), LDZ,
     $                DWORK( ITAU ), Q2, LDQ2, DWORK( IWRK ),
     $                LDWORK-IWRK+1, INFO )
      END IF
C
C     Exchange Z11 and Z12 and set the strictly lower triangular part
C     of Z11 to zero.
C
      DO 70 I = 1, M - 1
         CALL DSWAP(  M, Z( 1, I ), 1, Z( 1, M+I ), 1 )
         CALL DCOPY( M-I, DUM, 0, Z( I+1, I ), 1 )
   70 CONTINUE
C
      CALL DSWAP( M, Z( 1, M ), 1, Z( 1, N ), 1 )
C
C     STEP 2: Eliminations in H.
C
      DO 120 K = 1, M
C
C        I. Annihilate H(m+k:n-1,k).
C
         DO 80 J = K, M-1
C
C           Determine a Givens rotation to annihilate H(m+j,k) from the
C           left.
C
            CALL DLARTG( H( M+J+1, K ), H( M+J, K ), CO, SI, TMP1 )
C
C           Update H.
C
            H( M+J+1, K ) = TMP1
            H(   M+J, K ) = ZERO
            CALL DROT( N-K, H( M+J+1, K+1 ), LDH, H( M+J, K+1 ), LDH,
     $                 CO, SI )
C
C           Update T.
C
            CALL DROT( J+1, T( M+J+1, M+1 ), LDT, T( M+J, M+1 ), LDT,
     $                 CO, SI )
C
            IF( LCMPQ1 ) THEN
C
C              Update Q1.
C
               CALL DROT( N, Q1( 1, M+J+1 ), 1, Q1( 1, M+J ), 1, CO, SI
     $                  )
            END IF
C
C           Determine a Givens rotation to annihilate T(m+j,m+j+1) from
C           the right.
C
            CALL DLARTG( T( M+J, M+J ), T( M+J, M+J+1 ), CO, SI, TMP1 )
C
C           Update T.
C
            CALL DROT( M, T( 1, M+J ), 1, T( 1, M+J+1 ), 1, CO , SI )
            T( M+J, M+J   ) = TMP1
            T( M+J, M+J+1 ) = ZERO
            CALL DROT( M-J, T( M+J+1, M+J ), 1, T( M+J+1, M+J+1 ), 1,
     $                 CO, SI )
            CALL DROT( J+1, T( 1, J ), 1, T( 1, J+1 ), 1, CO, SI )
C
            IF( LCMPU1 ) THEN
C
C              Update U11 and U12.
C
               CALL DROT( M, U11( 1, J ), 1, U11( 1, J+1 ), 1, CO, SI )
               CALL DROT( M, U12( 1, J ), 1, U12( 1, J+1 ), 1, CO, SI )
            END IF
C
C           Determine a Givens rotation to annihilate T(j+1,j) from the
C           left.
C
            CALL DLARTG( T( J, J ), T( J+1, J ), CO, SI, TMP1 )
C
C           Update T.
C
            T(   J, J ) = TMP1
            T( J+1, J ) = ZERO
            CALL DROT( N-J, T( J, J+1 ), LDT, T( J+1, J+1 ), LDT, CO, SI
     $               )
C
C           Update H.
C
            CALL DROT( N-K+1, H( J, K ), LDH, H( J+1, K ), LDH, CO, SI )
C
            IF( LCMPQ1 ) THEN
C
C              Update Q1.
C
               CALL DROT( N, Q1( 1, J ), 1, Q1( 1, J+1 ), 1, CO, SI )
            END IF
   80    CONTINUE
C
C        II. Annihilate H(n,k).
C
C        Determine a Givens rotation to annihilate H(n,k) form the left.
C
         CALL DLARTG( H( M, K ), H( N, K ), CO, SI, TMP1 )
C
C        Update H.
C
         H( M, K ) = TMP1
         H( N, K ) = ZERO
         CALL DROT( N-K, H( M, K+1 ), LDH, H( N, K+1 ), LDH, CO, SI )
C
C        Update T.
C
         CALL DROT( M, T( M, M+1 ), LDT, T( N, M+1 ), LDT, CO, SI )
         TMP1 =      -SI*T( M, M )
         T( M, M ) =  CO*T( M, M )
C
         IF( LCMPQ1 ) THEN
C
C           Update Q1.
C
            CALL DROT( N, Q1( 1, M ), 1, Q1( 1, N ), 1, CO, SI )
         END IF
C
C        Determine a Givens rotation to annihilate T(n,m) from the
C        right.
C
         CALL DLARTG( T( N, N ), TMP1, CO, SI, TMP2 )
C
C        Update T.
C
         CALL DROT( M, T( 1, N ), 1, T( 1, M ), 1, CO, SI )
         T( N, N ) = TMP2
C
         IF( LCMPU1 ) THEN
C
C           Update U11 and U12.
C
            CALL DROT( M, U12( 1, M ), 1, U11( 1, M ), 1, CO, SI )
         END IF
C
C        III. Annihilate H(k+1:m,k).
C
         DO 90 J = M, K+1, -1
C
C           Determine a Givens rotation to annihilate H(j,k) from the
C           left.
C
            CALL DLARTG( H( J-1, K ), H( J, K ), CO, SI, TMP1 )
C
C           Update H.
C
            H( J-1, K ) = TMP1
            H( J,   K ) = ZERO
            CALL DROT( N-K, H( J-1, K+1 ), LDH, H( J, K+1 ), LDH, CO, SI
     $               )
C
C           Update T.
C
            CALL DROT( N-J+2, T( J-1, J-1 ), LDT, T( J, J-1 ), LDT, CO,
     $                 SI )
C
            IF( LCMPQ1 ) THEN
C
C              Update Q1.
C
               CALL DROT( N, Q1( 1, J-1 ), 1, Q1( 1, J ), 1, CO, SI )
            END IF
C
C           Determine a Givens rotation to annihilate T(j,j-1) from the
C           right.
C
            CALL DLARTG( T( J, J ), T( J, J-1 ), CO, SI, TMP1 )
C
C           Update T.
C
            CALL DROT( M, T( 1, M+J ), 1, T( 1, M+J-1 ), 1, CO, SI )
            CALL DROT( M-J+2, T( M+J-1, M+J ), 1, T( M+J-1, M+J-1 ), 1,
     $                 CO, SI )
            T( J, J   ) = TMP1
            T( J, J-1 ) = ZERO
            CALL DROT( J-1, T( 1, J ), 1, T( 1, J-1 ), 1, CO, SI )
C
            IF( LCMPU1 ) THEN
C
C              Update U11 and U12.
C
               CALL DROT( M, U11( 1, J ), 1, U11( 1, J-1 ), 1, CO, SI )
               CALL DROT( M, U12( 1, J ), 1, U12( 1, J-1 ), 1, CO, SI )
            END IF
C
C           Determine a Givens rotation to annihilate T(m+j-1,m-j) from
C           the left.
C
            CALL DLARTG( T( M+J, M+J ), T( M+J-1, M+J ), CO, SI, TMP1 )
C
C           Update T.
C
            T( M+J,   M+J ) = TMP1
            T( M+J-1, M+J ) = ZERO
            CALL DROT( J-1, T( M+J, M+1 ), LDT, T( M+J-1, M+1 ), LDT,
     $                 CO, SI )
C
C           Update H.
C
            CALL DROT( N-K+1, H( M+J, K ), LDH, H( M+J-1, K ), LDH, CO,
     $                 SI )
C
            IF( LCMPQ1 ) THEN
C
C              Update Q1.
C
               CALL DROT( N, Q1( 1, M+J ), 1, Q1( 1, M+J-1 ), 1, CO, SI
     $                  )
            END IF
   90    CONTINUE
C
C        IV. Annihilate H(m+k,k+1:m-1).
C
         DO 100 J = K+1, M-1
C
C           Determine a Givens rotation to annihilate H(m+k,j) from the
C           right.
C
            CALL DLARTG( H( M+K, J+1 ), H( M+K, J ), CO, SI, TMP1 )
C
C           Update H.
C
            CALL DROT( M, H( 1, J+1 ), 1, H( 1, J ), 1, CO, SI )
            H( M+K, J+1 ) = TMP1
            H( M+K, J   ) = ZERO
            CALL DROT( M-K, H( M+K+1, J+1 ), 1, H( M+K+1, J ), 1, CO, SI
     $               )
C
C           Update Z.
C
            CALL DROT( J+1, Z( 1, J+1 ), 1, Z( 1, J ), 1, CO, SI )
C
            IF( LCMPQ2 ) THEN
C
C              Update Q2.
C
               CALL DROT( N, Q2( 1, J+1 ), 1, Q2( 1, J ), 1, CO, SI )
            END IF
C
C           Determine a Givens rotation to annihilate Z(j+1,j) from the
C           left.
C
            CALL DLARTG( Z( J, J ), Z( J+1, J ), CO, SI, TMP1 )
C
C           Update Z.
C
            Z( J,   J ) = TMP1
            Z( J+1, J ) = ZERO
            CALL DROT( N-J, Z( J, J+1 ), LDZ, Z( J+1, J+1 ), LDZ, CO, SI
     $               )
            CALL DROT( J+1, Z( M+J, M+1 ), LDZ, Z( M+J+1, M+1 ), LDZ,
     $                 CO, SI )
C
            IF( LCMPU2 ) THEN
C
C              Update U21 and U22.
C
               CALL DROT( M, U21( 1, J ), 1, U21( 1, J+1 ), 1, CO, SI )
               CALL DROT( M, U22( 1, J ), 1, U22( 1, J+1 ), 1, CO, SI )
            END IF
C
C           Determine a Givens rotation to annihilate Z(m+j,m+j+1) from
C           the right.
C
            CALL DLARTG( Z( M+J, M+J ), Z( M+J, M+J+1 ), CO, SI, TMP1 )
C
C           Update Z.
C
            Z( M+J, M+J   ) = TMP1
            Z( M+J, M+J+1 ) = ZERO
            CALL DROT( M, Z( 1, M+J ), 1, Z( 1, M+J+1 ), 1, CO, SI )
            CALL DROT( M-J, Z( M+J+1, M+J ), 1, Z( M+J+1, M+J+1 ), 1,
     $                 CO, SI )
C
C           Update H.
C
            CALL DROT( M, H( 1, M+J ), 1, H( 1, M+J+1 ), 1, CO, SI )
            CALL DROT( M-K+1, H( M+K, M+J ), 1, H( M+K, M+J+1 ), 1, CO,
     $                 SI )
C
            IF( LCMPQ2 ) THEN
C
C              Update Q2.
C
               CALL DROT( N, Q2( 1, M+J ), 1, Q2( 1, M+J+1 ), 1, CO, SI
     $                  )
            END IF
  100    CONTINUE
C
C        V. Annihilate H(m+k,m).
C
         IF( K.LT.M ) THEN
C
C           Determine a Givens rotation to annihilate H(m+k,m) from the
C           right.
C
            CALL DLARTG( H( M+K, N ), H( M+K, M ), CO, SI, TMP1 )
C
C           Update H.
C
            H( M+K, N ) = TMP1
            H( M+K, M ) = ZERO
            CALL DROT( M, H( 1, N ), 1, H( 1, M ), 1, CO, SI )
            CALL DROT( M-K, H( M+K+1, N ), 1, H( M+K+1, M ), 1, CO, SI )
C
C           Update Z.
C
            CALL DROT( M, Z( 1, N ), 1, Z( 1, M ), 1, CO, SI )
            TMP1 = -SI*Z( N, N )
            Z( N, N ) = CO*Z( N, N )
C
            IF( LCMPQ2 ) THEN
C
C              Update Q2.
C
               CALL DROT( N, Q2( 1, N ), 1, Q2( 1, M ), 1, CO, SI )
            END IF
C
C           Determine a Givens rotation to annihilate Z(n,m) from the
C           left.
C
            CALL DLARTG( Z( M, M ), TMP1, CO, SI, TMP2 )
C
C           Update Z.
C
            CALL DROT( M, Z( M, M+1 ), LDZ, Z( N, M+1 ), LDZ, CO, SI )
            Z( M, M ) = TMP2
C
            IF( LCMPU2 ) THEN
C
C              Update U2.
C
               CALL DROT( M, U21( 1, M ), 1, U22( 1, M ), 1, CO, SI )
            END IF
         ELSE
C
C           Determine a Givens rotation to annihilate H(n,m) from the
C           left.
C
            CALL DLARTG( H( M, M ), H( N, M ), CO, SI, TMP1 )
C
C           Update H.
C
            H( M, M ) = TMP1
            H( N, M ) = ZERO
            CALL DROT( M, H( M, M+1 ), LDH, H( N, M+1 ), LDH, CO, SI )
C
C           Update T.
C
            CALL DROT( M, T( M, M+1 ), LDT, T( N, M+1 ), LDT, CO, SI )
            T( M, M ) = CO*T( M, M )
C
            IF( LCMPQ1 ) THEN
C
C              Update Q1.
C
               CALL DROT( N, Q1( 1, M ), 1, Q1( 1, N ), 1, CO, SI )
            END IF
C
C           Determine a Givens rotation to annihilate T( N, M ) from the
C           right.
C
            CALL DLARTG( T( N, N ), -SI*T( M, M ), CO, SI, TMP2 )
C
C           Update T.
C
            CALL DROT( M, T( 1, N ), 1, T( 1, M ), 1, CO, SI )
            T( N, N ) = TMP2
C
            IF( LCMPU1 ) THEN
C
C              Update U1.
C
               CALL DROT( M, U12( 1, M ), 1, U11( 1, M ), 1, CO, SI )
            END IF
         END IF
C
C        VI. Annihilate H(m+k,m+k+2:n).
C
         DO 110 J = M, K+2, -1
C
C           Determine a Givens rotation to annihilate H(m+k,m+j) from
C           the right.
C
            CALL DLARTG( H( M+K, M+J-1 ), H( M+K, M+J ), CO, SI, TMP1 )
C
C           Update H.
C
            CALL DROT( M, H( 1, M+J-1 ), 1, H( 1, M+J ), 1, CO, SI )
            H( M+K, M+J-1 ) = TMP1
            H( M+K, M+J   ) = ZERO
            CALL DROT( M-K, H( M+K+1, M+J-1 ), 1, H( M+K+1, M+J ), 1,
     $                 CO, SI )
C
C           Update Z.
C
            CALL DROT( M, Z( 1, M+J-1 ), 1, Z( 1, M+J ), 1, CO, SI )
            CALL DROT( M-J+2, Z( M+J-1, M+J-1 ), 1, Z( M+J-1, M+J ), 1,
     $                 CO, SI )
C
            IF( LCMPQ2 ) THEN
C
C              Update Q2.
C
               CALL DROT( N, Q2( 1, M+J-1 ), 1, Q2( 1, M+J ), 1, CO, SI
     $                  )
            END IF
C
C           Determine a Givens rotation to annihilate Z(m+j-1,m+j) from
C           the left.
C
            CALL DLARTG( Z( M+J, M+J ), Z( M+J-1, M+J ), CO, SI, TMP1 )
C
C           Update Z.
C
            Z( M+J,   M+J ) = TMP1
            Z( M+J-1, M+J ) = ZERO
            CALL DROT( J-1, Z( M+J, M+1 ), LDZ, Z( M+J-1, M+1 ), LDZ,
     $                 CO, SI )
            CALL DROT( N-J+2, Z( J, J-1 ), LDZ, Z( J-1, J-1 ), LDZ, CO,
     $                 SI )
C
            IF( LCMPU2 ) THEN
C
C              Update U2.
C
               CALL DROT( M, U21( 1, J ), 1, U21( 1, J-1 ), 1, CO, SI )
               CALL DROT( M, U22( 1, J ), 1, U22( 1, J-1 ), 1, CO, SI )
            END IF
C
C           Determine a Givens rotation to annihilate Z(j,j-1) from the
C           right.
C
            CALL DLARTG( Z( J, J ), Z( J, J-1 ), CO, SI, TMP1 )
C
C           Update Z.
C
            Z( J, J   ) = TMP1
            Z( J, J-1 ) = ZERO
            CALL DROT( J-1, Z( 1, J ), 1, Z( 1, J-1 ), 1, CO, SI )
C
C           Update H.
C
            CALL DROT( M, H( 1, J ), 1, H( 1, J-1 ), 1, CO, SI )
            CALL DROT( M-K+1, H( M+K, J ), 1, H( M+K, J-1 ), 1, CO, SI )
C
            IF( LCMPQ2 ) THEN
C
C              Update Q2.
C
               CALL DROT( N, Q2( 1, J ), 1, Q2( 1, J-1 ), 1, CO, SI )
            END IF
  110    CONTINUE
C
  120 CONTINUE
C
C     Now T, Z, H are in block forms (1) and H22' is upper Hessenberg.
C
C     STEP 3: Apply periodic QZ algorithm to the generalized matrix
C
C                            -1    -1        -1    -1
C             product H22 T22   T11   H11 Z11   Z22   to transform H22'
C             to upper quasi-triangular form while T11, T22', Z11, Z22',
C             and H11 stay in upper triangular form.
C
C     Determine the mode of computations.
C
      IQ = 1
      IF( LTRI .OR. LCMPQ1 .OR. LCMPQ2 .OR. LCMPU1 .OR. LCMPU2 ) THEN
         CMPQ = 'Initialize'
         IMAT =  6*MM + 1
         IWRK = 12*MM + 1
      ELSE
         CMPQ = 'No Computation'
         IMAT = 1
         IWRK = 6*MM + 1
      END IF
C
      IF( LTRI ) THEN
         CMPSC = 'Schur Form'
      ELSE
         CMPSC = 'Eigenvalues Only'
      END IF
C
C     Save matrices in structure that is required by MB03BD.
C
      CALL MA02AD( 'Lower', M, M, H( M+1, M+1 ), LDH, DWORK( IMAT ), M )
      CALL DCOPY(  M-1, H( M+1, M+2 ), LDH+1, DWORK( IMAT+1 ), M+1 )
      CALL DLASET( 'Lower', M-2, M-2, ZERO, ZERO, DWORK( IMAT+2 ), M )
      CALL MA02AD( 'Lower', M, M, T( M+1, M+1 ), LDT, DWORK( IMAT+MM ),
     $             M )
      CALL DLASET( 'Lower', M-1, M-1, ZERO, ZERO, DWORK( IMAT+MM+1 ),
     $             M )
      CALL DLACPY( 'Upper', M, M, T, LDT, DWORK( IMAT+2*MM ), M )
      CALL DLASET( 'Lower', M-1, M-1, ZERO, ZERO, DWORK( IMAT+2*MM+1 ),
     $             M )
      CALL DLACPY( 'Upper', M, M, H, LDH, DWORK( IMAT+3*MM ), M )
      CALL DLASET( 'Lower', M-1, M-1, ZERO, ZERO, DWORK( IMAT+3*MM+1 ),
     $             M )
      CALL DLACPY( 'Upper', M, M, Z, LDZ, DWORK( IMAT+4*MM ), M )
      CALL DLASET( 'Lower', M-1, M-1, ZERO, ZERO, DWORK( IMAT+4*MM+1 ),
     $             M )
      CALL MA02AD( 'Lower', M, M, Z( M+1, M+1 ), LDZ,
     $             DWORK( IMAT+5*MM ), M )
      CALL DLASET( 'Lower', M-1, M-1, ZERO, ZERO, DWORK( IMAT+5*MM+1 ),
     $             M )
C
      IWORK( 1 ) =  1
      IWORK( 2 ) = -1
      IWORK( 3 ) = -1
      IWORK( 4 ) =  1
      IWORK( 5 ) = -1
      IWORK( 6 ) = -1
C
C     Apply periodic QZ algorithm.
C     Workspace:          need   IWRK + MAX( N, 48 ) + 5.
C     Integer workspace:  need   N + 18.
C
      CALL MB03BD( CMPSC, 'Careful', CMPQ, IDUM, 6, M, 1, 1, M, IWORK,
     $             DWORK( IMAT ), M, M, DWORK( IQ ), M, M, ALPHAR,
     $             ALPHAI, BETA, IWORK( 7 ), IWORK( M+7 ),
     $             LIWORK-( M+6 ), DWORK( IWRK ), LDWORK-IWRK+1, IWARN,
     $             INFO )
      IF( IWARN.GT.0 .AND. IWARN.LT.M ) THEN
         INFO = 1
         RETURN
      ELSE IF( IWARN.EQ.M+1 ) THEN
         INFO = 3
      ELSE IF( INFO.GT.0 ) THEN
         INFO = 2
         RETURN
      END IF
      NBETA0 = 0
      I11    = 0
      I22    = 0
      I2X2   = 0
C
C     Compute the "non-negative" eigenvalues of the pencil aTZ - bH.
C     These are the eigenvalues with positive real parts or with
C     non-negative imaginary parts, when real parts are zero.
C     Also, count the number of 2-by-2 diagonal blocks, I2X2, and the
C     number of 1-by-1 and 2-by-2 blocks with unreliable eigenvalues,
C     I11 and I22, respectively.
C
      I = 1
C     WHILE( I.LE.M ) DO
  130 CONTINUE
      IF( I.LE.M ) THEN
         IF( NINF.GT.0 ) THEN
            IF( BETA( I ).EQ.ZERO )
     $         NBETA0 = NBETA0 + 1
         END IF
         IF( IWORK( I+6 ).GE.2*EMIN .AND. IWORK( I+6 ).LE.2*EMAX ) THEN
C
C           B = SQRT(BASE**IWORK(i+6)) is between underflow and overflow
C           threshold, BETA(i) is divided by B.
C
            BETA( I ) = BETA( I )/BASE**( HALF*IWORK( I+6 ) )
            IF( BETA( I ).NE.ZERO ) THEN
               IF( IWORK( M+I+7 ).LT.0 ) THEN
                  I22 = I22 + 1
               ELSE IF( IWORK( M+I+7 ).GT.0 ) THEN
                  I11 = I11 + 1
               END IF
               EIG = SQRT( DCMPLX( ALPHAR( I ), ALPHAI( I ) ) )
               ALPHAR( I ) = DIMAG( EIG )
               ALPHAI( I ) = DBLE(  EIG )
               IF( ALPHAR( I ).LT.ZERO )
     $             ALPHAR( I ) = -ALPHAR( I )
               IF( ALPHAI( I ).LT.ZERO )
     $             ALPHAI( I ) = -ALPHAI( I )
               IF( ALPHAR( I ).NE.ZERO .AND. ALPHAI( I ).NE.ZERO ) THEN
                  ALPHAR( I+1 ) = -ALPHAR( I )
                  ALPHAI( I+1 ) =  ALPHAI( I )
                  BETA(   I+1 ) =  BETA(   I )
                  I2X2 = I2X2 + 1
                  I    = I    + 1
               END IF
            END IF
         ELSE IF( IWORK( I+6 ).LT.2*EMIN ) THEN
C
C           Set to zero the numerator part of the eigenvalue.
C
            ALPHAR( I ) = ZERO
            ALPHAI( I ) = ZERO
            I11 = I11 + 1
         ELSE
C
C           Set an infinite eigenvalue.
C
            IF( NINF.GT.0 )
     $         NBETA0 = NBETA0 + 1
            BETA( I ) = ZERO
            I11 = I11 + 1
         END IF
         I = I + 1
         GO TO 130
      END IF
C     END WHILE 130
C
      IWORK( 1 ) = I11 + I22
C
C     Set to infinity the largest eigenvalues, if necessary.
C
      L = 0
      IF( NINF.GT.0 ) THEN
         DO 150  J = 1, NINF - NBETA0
            TMP1 = ZERO
            TMP2 = ONE
            P    = 1
            DO 140 I = 1, M
               IF( BETA( I ).GT.ZERO ) THEN
                  TEMP = DLAPY2( ALPHAR( I ), ALPHAI( I ) )
                  IF( TEMP.GT.TMP1 .AND. TMP2.GE.BETA( I ) ) THEN
                     TMP1 = TEMP
                     TMP2 = BETA( I )
                     P    = I
                  END IF
               END IF
  140       CONTINUE
            L = L + 1
            BETA( P ) = ZERO
  150    CONTINUE
C
         IF( L.EQ.IWORK( 1 ) ) THEN
C
C           All unreliable eigenvalues found have been set to infinity.
C
            INFO = 0
            I11  = 0
            I22  = 0
            IWORK( 1 ) = 0
         END IF
      END IF
C
C     Save the norms of the factors.
C
      CALL DCOPY( 6, DWORK( IWRK+1 ), 1, DUM, 1 )
C
C     Save the sextuples of the 1-by-1 and 2-by-2 diagonal blocks.
C     All 1-by-1 diagonal blocks come first.
C     Save also information about blocks with possible loss of accuracy.
C
C     Workspace:  IWRK+w-1, where w = 6 if M = 1, or w = 6*N, otherwise.
C
      K  = IWRK
      IW = IWORK( 1 )
      I  = 1
      J  = 1
      L  = 6*( M - 2*I2X2 ) + K
C
C     WHILE( I.LE.N ) DO
      UNREL = .FALSE.
  160 CONTINUE
      IF( I.LE.M ) THEN
         IF( J.LE.IW )
     $      UNREL = I.EQ.ABS( IWORK( M+I+7 ) )
         IF( ALPHAR( I ).NE.ZERO .AND. BETA( I ).NE.ZERO .AND.
     $       ALPHAI( I ).NE.ZERO ) THEN
            IF( UNREL ) THEN
               J = J + 1
               IWORK( J )    = IWORK( M+I+7 )
               IWORK( IW+J ) = L - IWRK + 1
               UNREL = .FALSE.
            END IF
            CALL DLACPY( 'Full', 2, 2, DWORK( IMAT+(M+1)*(I-1) ), M,
     $                   DWORK( L ), 2 )
            CALL DLACPY( 'Full', 2, 2, DWORK( IMAT+(M+1)*(I-1)+MM ), M,
     $                   DWORK( L+4 ), 2 )
            CALL DLACPY( 'Full', 2, 2, DWORK( IMAT+(M+1)*(I-1)+2*MM ),
     $                   M, DWORK( L+8 ), 2 )
            CALL DLACPY( 'Full', 2, 2, DWORK( IMAT+(M+1)*(I-1)+3*MM ),
     $                   M, DWORK( L+12 ), 2 )
            CALL DLACPY( 'Full', 2, 2, DWORK( IMAT+(M+1)*(I-1)+4*MM ),
     $                   M, DWORK( L+16 ), 2 )
            CALL DLACPY( 'Full', 2, 2, DWORK( IMAT+(M+1)*(I-1)+5*MM ),
     $                   M, DWORK( L+20 ), 2 )
            L = L + 24
            I = I + 2
         ELSE
            IF ( UNREL ) THEN
               J = J + 1
               IWORK( J )    = I
               IWORK( IW+J ) = K - IWRK + 1
               UNREL = .FALSE.
            END IF
            CALL DCOPY( 6, DWORK( IMAT+(M+1)*(I-1) ), MM, DWORK( K ),
     $                  1 )
            K = K + 6
            I = I + 1
         END IF
         GO TO 160
      END IF
C     END WHILE 160
C
      IWORK( 2*IW+2 ) = I11
      IWORK( 2*IW+3 ) = I22
      IWORK( 2*IW+4 ) = I2X2
C
      IF( LTRI ) THEN
C
C        Update H.
C
         CALL DLACPY( 'Upper', M, M, DWORK( IMAT+3*MM ), M, H, LDH )
         CALL MA02AD( 'Full', M, M, DWORK( IMAT ), M, H( M+1, M+1 ),
     $                LDH )
         CALL DGEMM( 'Transpose', 'No Transpose', M, M, M, ONE,
     $               DWORK( IQ+3*MM ), M, H( 1, M+1 ), LDH, ZERO,
     $               DWORK( IMAT ), M )
         CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE,
     $               DWORK( IMAT ), M, DWORK, M, ZERO, H( 1, M+1 ),
     $               LDH )
C
C        Update T.
C
         CALL DLACPY( 'Upper', M, M, DWORK( IMAT+2*MM ), M, T, LDT )
         CALL DGEMM( 'Transpose', 'No Transpose', M, M, M, ONE,
     $               DWORK( IQ+3*MM ), M, T( 1, M+1 ), LDT, ZERO,
     $               DWORK( IMAT ), M )
         CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE,
     $               DWORK( IMAT ), M, DWORK( IQ+2*MM ), M, ZERO,
     $               T( 1, M+1 ), LDT )
         CALL MA02AD( 'Upper', M, M, DWORK( IMAT+MM ), M, T( M+1, M+1 ),
     $                LDT )
C
C        Update Z.
C
         CALL DLACPY( 'Upper', M, M, DWORK( IMAT+4*MM ), M, Z, LDZ )
         CALL DGEMM( 'Transpose', 'No Transpose', M, M, M, ONE,
     $               DWORK( IQ+5*MM ), M, Z( 1, M+1 ), LDZ, ZERO,
     $               DWORK( IMAT ), M )
         CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE,
     $               DWORK( IMAT ), M, DWORK, M, ZERO, Z( 1, M+1 ),
     $               LDZ )
         CALL MA02AD( 'Upper', M, M, DWORK( IMAT+5*MM ), M,
     $                Z( M+1, M+1 ), LDZ )
C
         IF( LCMPQ1 ) THEN
C
C           Update Q1.
C
            CALL DGEMM( 'No Transpose', 'No Transpose', N, M, M, ONE,
     $                  Q1, LDQ1, DWORK( IQ+3*MM ), M, ZERO,
     $                  DWORK( IMAT ), N )
            CALL DLACPY( 'Full', N, M, DWORK( IMAT ), N, Q1, LDQ1 )
            CALL DGEMM( 'No Transpose', 'No Transpose', N, M, M, ONE,
     $                  Q1( 1, M+1 ), LDQ1, DWORK( IQ+MM ), M, ZERO,
     $                  DWORK( IMAT ), N )
            CALL DLACPY( 'Full', N, M, DWORK( IMAT ), N, Q1( 1, M+1 ),
     $                   LDQ1 )
         END IF
C
         IF( LCMPQ2 ) THEN
C
C           Update Q2.
C
            CALL DGEMM( 'No Transpose', 'No Transpose', N, M, M, ONE,
     $                  Q2, LDQ2, DWORK( IQ+4*MM ), M, ZERO,
     $                  DWORK( IMAT ), N )
            CALL DLACPY( 'Full', N, M, DWORK( IMAT ), N, Q2, LDQ2 )
            CALL DGEMM( 'No Transpose', 'No Transpose', N, M, M, ONE,
     $                  Q2( 1, M+1 ), LDQ2, DWORK, M, ZERO,
     $                  DWORK( IMAT ), N )
            CALL DLACPY( 'Full', N, M, DWORK( IMAT ), N, Q2( 1, M+1 ),
     $                   LDQ2 )
         END IF
C
         IF( LCMPU1 ) THEN
C
C           Update U11 and U12.
C
            CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE,
     $                  U11, LDU11, DWORK( IQ+2*MM ), M, ZERO,
     $                  DWORK( IMAT ), M )
            CALL DLACPY( 'Full', M, M, DWORK( IMAT ), M, U11, LDU11 )
            CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE,
     $                  U12, LDU12, DWORK( IQ+2*MM ), M, ZERO,
     $                  DWORK( IMAT ), M )
            CALL DLACPY( 'Full', M, M, DWORK( IMAT ), M, U12, LDU12 )
         END IF
C
         IF( LCMPU2 ) THEN
C
C           Update U21 and U22.
C
            CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE,
     $                  U21, LDU21, DWORK( IQ+5*MM ), M, ZERO,
     $                  DWORK( IMAT ), M )
            CALL DLACPY( 'Full', M, M, DWORK( IMAT ), M, U21, LDU21 )
            CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE,
     $                  U22, LDU22, DWORK( IQ+5*MM ), M, ZERO,
     $                  DWORK( IMAT ), M )
            CALL DLACPY( 'Full', M, M, DWORK( IMAT ), M, U22, LDU22 )
         END IF
      END IF
C
C     Move the norms, and the sextuples of 1-by-1 and 2-by-2 blocks
C     in front.
C
      K = 6*( M - 2*I2X2 ) + 24*I2X2
      CALL DCOPY( K, DWORK( IWRK ), 1, DWORK( 8 ), 1 )
      CALL DCOPY( 6, DUM, 1, DWORK( 2 ), 1 )
C
      DWORK( 1 ) = OPTDW
      RETURN
C *** Last line of MB04AD ***
      END


program test_transfer
use iso_fortran_env, only: int64, real64
implicit none
type :: point
   real :: a,b
end type point
real :: x(2)
complex :: z
type(point) :: p
integer(kind=int64) :: i
real(kind=real64)   :: d
character(8) :: s
z = (3.0,4.0)
x = transfer(z,x) ! copy complex to 2 reals
print*,x ! 3.0 4.0
p = transfer(x,p) ! copy 2 reals to type(point)
print*,p ! 3.0 4.0
x = transfer(p,x) ! copy type(point) to 2 reals
print*,x ! 3.0 4.0
i = huge(i)
! converting from int64 to real64 and back using
! nint and real does not work for huge(1_int64)
print*,i,nint(real(i,kind=real64),kind=real64)
! transferring from int64 to real64 and back works
print*,i,transfer(transfer(i,d),i)
! transfer character (len=8) to real64 and back
s = "aeio+-*/"
print*,s // " " // transfer(transfer(s,d),s)
end program test_transfer
! output:
!    3.00000000       4.00000000
!    3.00000000       4.00000000
!    3.00000000       4.00000000
!   9223372036854775807 -9223372036854775808
!   9223372036854775807  9223372036854775807
!  aeio+-*/ aeio+-*/


submodule(euler_interface_m) euler_prob_0031_m
    implicit none

contains

    module character(len=20) function euler0031()
        write (euler0031, "(i20)") ans(200)
    end function euler0031

    integer function ans(n)
        integer, intent(in) :: n
        integer :: coins(0:7), i, j
        integer :: ans_arr(0:7, 0:n)

        coins = [1, 2, 5, 10, 20, 50, 100, 200]
        ans_arr(1:7, :) = 0
        ans_arr(0, :) = 1

        outer: do j = 0, n
            inner: do i = 1, 7
                associate (next => ans_arr(i, j), prev => ans_arr(i - 1, j))
                    if (j < coins(i)) then
                        next = prev
                    else
                        next = prev + ans_arr(i, j - coins(i))
                    end if
                end associate
            end do inner
        end do outer
        ans = ans_arr(7, n)
    end function ans

end submodule euler_prob_0031_m


!
! Copyright (C) 2004-2006 Quantum ESPRESSO group
! This file is distributed under the terms of the
! GNU General Public License. See the file `License'
! in the root directory of the present distribution,
! or http://www.gnu.org/copyleft/gpl.txt .
!
!---------------------------------------------------------------------------
MODULE splinelib
  !---------------------------------------------------------------------------
  !
  USE kinds, ONLY : DP
  !
  IMPLICIT NONE
  !
  PRIVATE
  !
  PUBLIC :: dosplineint, spline, splint, splint_deriv
  !
  INTERFACE dosplineint
     !
     MODULE PROCEDURE dosplineint_1D, dosplineint_2D
     !
  END INTERFACE
  !
  CONTAINS
    !
    !------------------------------------------------------------------------
    SUBROUTINE spline( xdata, ydata, startu, startd, d2y )
      !------------------------------------------------------------------------
      !
      IMPLICIT NONE
      !
      REAL(DP), INTENT(IN)  :: xdata(:), ydata(:), startu, startd
      REAL(DP), INTENT(OUT) :: d2y(:)
      !
      INTEGER               :: i, k, ydim
      REAL(DP)              :: p, sig
      REAL(DP), ALLOCATABLE :: u(:)
      !
      !
      ydim = SIZE( ydata )
      !
      ALLOCATE( u( ydim ) )
      !
      u(1)   = startu
      d2y(1) = startd
      !
      DO  i = 2, ydim - 1
         !
         sig    = ( xdata(i) - xdata(i-1) ) / ( xdata(i+1) - xdata(i-1) )
         p      = sig * d2y(i- 1) + 2.0_DP
         d2y(i) = ( sig - 1.0_DP ) / p
         u(i)   = ( 6.0_DP * ( ( ydata(i+1) - ydata(i) ) / &
                    ( xdata(i+1) - xdata(i) ) - ( ydata(i) - ydata(i-1) ) / &
                    ( xdata(i) - xdata(i-1) ) ) / &
                    ( xdata(i+1) - xdata(i-1) ) - sig * u(i-1) ) / p
         !
      END DO
      !
      d2y(ydim) = 0
      !
      DO  k = ydim - 1, 1, -1
         !
         d2y(k) = d2y(k) * d2y(k+1) + u(k)
         !
      END DO
      !
      DEALLOCATE( u )
      !
    END SUBROUTINE spline
    !
    !------------------------------------------------------------------------
    FUNCTION splint( xdata, ydata, d2y, x )
      !------------------------------------------------------------------------
      !
      IMPLICIT NONE
      !
      REAL(DP), INTENT(IN) :: xdata(:), ydata(:), d2y(:)
      REAL(DP), INTENT(IN) :: x
      !
      REAL(DP) :: splint
      INTEGER  :: khi, klo, xdim
      REAL(DP) :: a, b, h
      !
      !
      xdim = SIZE( xdata )
      !
      klo = 1
      khi = xdim
      !
      klo = MAX( MIN( locate( xdata, x ), ( xdim - 1 ) ), 1 )
      !
      khi = klo + 1
      !
      h = xdata(khi) - xdata(klo)
      !
      a = ( xdata(khi) - x ) / h
      b = ( x - xdata(klo) ) / h
      !
      splint = a * ydata(klo) + b * ydata(khi) + &
               ( ( a**3 - a ) * d2y(klo) + ( b**3 - b ) * d2y(khi) ) * &
               ( h**2 ) / 6.0_DP

      END FUNCTION splint

    !------------------------------------------------------------------------
    FUNCTION splint_deriv( xdata, ydata, d2y, x )
      !------------------------------------------------------------------------
      !
      IMPLICIT NONE
      !
      REAL(DP), INTENT(IN) :: xdata(:), ydata(:), d2y(:)
      REAL(DP), INTENT(IN) :: x
      !
      REAL(DP) :: splint_deriv
      INTEGER  :: khi, klo, xdim
      REAL(DP) :: a, b, da, db, h
      !
      !
      xdim = SIZE( xdata )
      !
      klo = 1
      khi = xdim
      !
      klo = MAX( MIN( locate( xdata, x ), ( xdim - 1 ) ), 1 )
      !
      khi = klo + 1
      !
      h = xdata(khi) - xdata(klo)
      !
      a = ( xdata(khi) - x ) / h
      b = ( x - xdata(klo) ) / h
      da = -1.0_DP / h
      db = 1.0_DP / h
      !
      splint_deriv = da * ydata(klo) + db * ydata(khi) + &
               ( ( 3.0_DP*a**2 - 1.0_DP ) * da * d2y(klo) + &
                 ( 3.0_DP*b**2 - 1.0_DP ) * db * d2y(khi) ) * &
               ( h**2 ) / 6.0_DP

      END FUNCTION splint_deriv

         !-------------------------------------------------------------------
         FUNCTION locate( xx, x )
           !-------------------------------------------------------------------
           !
           IMPLICIT NONE
           !
           REAL(DP), INTENT(IN) :: xx(:)
           REAL(DP), INTENT(IN) :: x
           !
           INTEGER :: locate
           INTEGER :: n, jl, jm, ju
           LOGICAL :: ascnd
           !
           !
           n     = SIZE( xx )
           ascnd = ( xx(n) >= xx(1) )
           jl    = 0
           ju    = n + 1
           !
           main_loop: DO
              !
              IF ( ( ju - jl ) <= 1 ) EXIT main_loop
              !
              jm = ( ju + jl ) / 2
              !
              IF ( ascnd .EQV. ( x >= xx(jm) ) ) THEN
                 !
                 jl = jm
                 !
              ELSE
                 !
                 ju = jm
                 !
              END IF
              !
           END DO main_loop
           !
           IF ( x == xx(1) ) THEN
              !
              locate = 1
              !
           ELSE IF ( x == xx(n) ) THEN
              !
              locate = n - 1
              !
           ELSE
              !
              locate = jl
              !
           END IF
           !
         END FUNCTION locate
         !
    !
    !------------------------------------------------------------------------
    SUBROUTINE dosplineint_1D( old_mesh, old_vec, new_mesh, new_vec )
      !------------------------------------------------------------------------
      !
      IMPLICIT NONE
      !
      REAL (DP), INTENT(IN)  :: old_mesh(:), new_mesh(:)
      REAL (DP), INTENT(IN)  :: old_vec(:)
      REAL (DP), INTENT(OUT) :: new_vec(:)
      !
      REAL (DP), ALLOCATABLE :: d2y(:)
      INTEGER                :: i
      INTEGER                :: old_dim, new_dim
      !
      !
      old_dim = SIZE( old_vec )
      new_dim = SIZE( new_vec )
      !
      IF ( old_dim /= SIZE( old_mesh ) ) &
         CALL errore( 'dosplineint', &
                      'dimensions of old_mesh and old_vec do not match', 1 )
      !
      IF ( new_dim /= SIZE( new_mesh ) ) &
         CALL errore( 'dosplineint', &
                      'dimensions of new_mesh and new_vec do not match', 1 )
      !
      ALLOCATE( d2y( old_dim ) )
      !
      d2y = 0
      !
      CALL spline( old_mesh , old_vec(:), 0.0_DP, 0.0_DP, d2y  )
      !
      DO i = 1, new_dim
         !
         new_vec(i) = splint( old_mesh, old_vec(:), d2y, new_mesh(i) )
         !
      END DO
      !
      DEALLOCATE( d2y )
      !
    END SUBROUTINE dosplineint_1D
    !
    !------------------------------------------------------------------------
    SUBROUTINE dosplineint_2D( old_mesh, old_vec, new_mesh, new_vec )
      !------------------------------------------------------------------------
      !
      IMPLICIT NONE
      !
      REAL (DP), INTENT(IN)  :: old_mesh(:), new_mesh(:)
      REAL (DP), INTENT(IN)  :: old_vec(:,:)
      REAL (DP), INTENT(OUT) :: new_vec(:,:)
      !
      REAL (DP), ALLOCATABLE :: d2y(:)
      INTEGER                :: dim, i, j
      INTEGER                :: old_dim, new_dim
      !
      !
      dim = SIZE( old_vec, 1 )
      !
      IF( dim /= SIZE( new_vec, 1 ) ) &
         CALL errore( 'dosplineint', &
                      'dimensions of old_vec and new_vec do not match', 1 )
      !
      old_dim = SIZE( old_vec, 2 )
      new_dim = SIZE( new_vec, 2 )
      !
      IF ( old_dim /= SIZE( old_mesh, 1 ) ) &
         CALL errore( 'dosplineint', &
                      'dimensions of old_mesh and old_vec do not match', 1 )
      !
      IF ( new_dim /= SIZE( new_mesh, 1 ) ) &
         CALL errore( 'dosplineint', &
                      'dimensions of new_mesh and new_vec do not match', 1 )
      !
      ALLOCATE( d2y( old_dim ) )
      !
      DO i = 1, dim
         !
         d2y = 0
         !
         CALL spline( old_mesh , old_vec(i,:), 0.0_DP, 0.0_DP, d2y  )
         !
         DO j = 1, new_dim
            !
            new_vec(i,j) = splint( old_mesh, old_vec(i,:), d2y, new_mesh(j) )
            !
         END DO
         !
      END DO
      !
      DEALLOCATE( d2y )
      !
    END SUBROUTINE dosplineint_2D
    !
END MODULE splinelib


      subroutine dplog(u,n,gg)
!----------------------------------------------------------------------
!
!                                                     m
!   Purpose           - calculates derivatives (-d/du) [ln(1+u)/u]
!
!----------------------------------------------------------------------
      implicit          real (16) (a-h,o-z)
      parameter         (lenl=200,lenl2=3*lenl)
      dimension         gg(0:lenl2),ff(0:lenl2)
      real (16), parameter :: zero = 0.0q0
      real (16), parameter :: one  = 1.0q0
      real (16), parameter :: threshold  = 0.05q0

      epsm = epsilon(one)
      au = abs(u)
!
      if (au > threshold) then
         uinv = one/u
         u1inv = one/(one+u)
         ff(0) = log(one+u)
         ff(1) = -u1inv
         gg(0) = ff(0)*uinv
         gg(1) = uinv*(gg(0)+ff(1))
         do i=2,n
            ff(i) = (i-1)*ff(i-1)*u1inv
            gg(i) = uinv*(i*gg(i-1)+ff(i))
         end do
      else if (au == zero) then
         u1inv = one
         ff(0) = zero
         ff(1) = -u1inv
         do i=2,n+1
            ff(i) = (i-1)*ff(i-1)
         end do
!
         do i=n+1,1,-1
            gg(i-1) = -ff(i)/i
         end do
      else
         nadd = int(log(epsm)/log(au))+5
         if (n+nadd > lenl2) then
            write (*,*) 'Error!!! Insufficient array length in DPLOG!'
            stop
         end if
!
         u1inv = one/(one+u)
         ff(0) = log(one+u)
         ff(1) = -u1inv
         do i=2,n+nadd
            ff(i) = (i-1)*ff(i-1)*u1inv
         end do
!
         gg(n+nadd) = one
         do i=n+nadd,1,-1
            gg(i-1) = (u*gg(i)-ff(i))/i
         end do
      end if
!
      return
      end


chapter xvi, example 3. two parametrizations of some data
c  from  * a practical guide to splines *  by c. de boor
calls  splint(bsplvb,banfac/slv),bsplpp(bsplvb*),banslv*,ppvalu(interv)
c     parameter k=4,kpkm1=7, n=8,npk=12, npiece=6,npoint=21
c     integer i,icount,iflag,kp1,l
c     real bcoef(n),break(npiece),ds,q(n,kpkm1),s(n),scrtch(k,k)
c    *    ,ss,t(npk),x(n),xcoef(k,npiece),xx(npoint),y(n)
c    *    ,ycoef(k,npiece),yy(npoint)
      integer i,icount,iflag,k,kpkm1,kp1,l,n,npoint
      data k,kpkm1,n,npoint /4,7,8,21/
      real bcoef(8),break(6),ds,q(8,7),s(8),scrtch(4,4)
     *    ,ss,t(12),x(8),xcoef(4,6),xx(21),y(8)
     *    ,ycoef(4,6),yy(21)
      data x /0.,.1,.2,.3,.301,.4,.5,.6/
c  *** compute y-component and set 'natural' parametrization
      do 1 i=1,n
         y(i) = (x(i)-.3)**2
    1    s(i) = x(i)
      print 601
  601 format(26h 'natural' parametrization/6x,1hx,11x,1hy)
      icount = 1
c  *** convert data abscissae to knots. note that second and second
c     last data abscissae are not knots.
    5 do 6 i=1,k
         t(i) = s(1)
    6    t(n+i) = s(n)
      kp1 = k+1
      do 7 i=kp1,n
    7    t(i) = s(i+2-k)
c  *** interpolate to x-component
      call splint(s,x,t,n,k,q,bcoef,iflag)
      call bsplpp(t,bcoef,n,k,scrtch,break,xcoef,l)
c  *** interpolate to y-component. since data abscissae and knots are
c     the same for both components, we only need to use backsubstitution
      do 10 i=1,n
   10    bcoef(i) = y(i)
      call banslv(q,kpkm1,n,k-1,k-1,bcoef)
      call bsplpp(t,bcoef,n,k,scrtch,break,ycoef,l)
c  *** evaluate curve at some points near the potential trouble spot,
c     the fourth and fifth data points.
      ss = s(3)
      ds = (s(6)-s(3))/float(npoint-1)
      do 20 i=1,npoint
         xx(i) = ppvalu(break,xcoef,l,k,ss,0)
         yy(i) = ppvalu(break,ycoef,l,k,ss,0)
   20    ss = ss + ds
      print 620,(xx(i),yy(i),i=1,npoint)
  620 format(2f12.7)
      if (icount .ge. 2)                stop
c  *** now repeat the whole process with uniform parametrization
      icount = icount + 1
      do 30 i=1,n
   30    s(i) = float(i)
      print 630
  630 format(/26h 'uniform' parametrization/6x,1hx,11x,1hy)
                                        go to 5
      end


    Program zhgeqz_example

!     ZHGEQZ Example Program Text

!     Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!     For licence see
!       https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

!     .. Use Statements ..
      Use lapack_example_aux, Only: nagf_sort_realvec_rank, &
        nagf_file_print_matrix_complex_gen_comp, &
        nagf_sort_cmplxvec_rank_rearrange
      Use lapack_interfaces, Only: zgeqrf, zggbal, zgghd3, zhgeqz, zunmqr
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter :: nin = 5, nout = 6
!     .. Local Scalars ..
      Integer :: i, ifail, ihi, ilo, info, irows, jwork, lda, ldb, ldq, ldz, &
        lwork, n, ni
      Character (1) :: compq, compz, job
!     .. Local Arrays ..
      Complex (Kind=dp), Allocatable :: a(:, :), alpha(:), b(:, :), beta(:), &
        e(:), q(:, :), tau(:), work(:), z(:, :)
      Real (Kind=dp), Allocatable :: emod(:), lscale(:), rscale(:), rwork(:)
      Integer, Allocatable :: irank(:)
      Character (1) :: clabs(1), rlabs(1)
!     .. Intrinsic Procedures ..
      Intrinsic :: abs, aimag, nint, real
!     .. Executable Statements ..
      Write (nout, *) 'ZHGEQZ Example Program Results'
      Flush (nout)

!     Skip heading in data file

      Read (nin, *)
      Read (nin, *) n
      ldq = 1
      ldz = 1
      lda = n
      ldb = n
      lwork = 6*n
      Allocate (a(lda,n), alpha(n), b(ldb,n), beta(n), q(ldq,ldq), tau(n), &
        work(lwork), z(ldz,ldz), lscale(n), rscale(n), rwork(6*n))

!     READ matrix A from data file
      Read (nin, *)(a(i,1:n), i=1, n)

!     READ matrix B from data file
      Read (nin, *)(b(i,1:n), i=1, n)

!     Balance matrix pair (A,B)
      job = 'B'
      Call zggbal(job, n, a, lda, b, ldb, ilo, ihi, lscale, rscale, rwork, &
        info)

!     Matrix A after balancing

!     ifail: behaviour on error exit
!             =0 for hard exit, =1 for quiet-soft, =-1 for noisy-soft
      ifail = 0
      Call nagf_file_print_matrix_complex_gen_comp('General', ' ', n, n, a, &
        lda, 'Bracketed', 'F7.4', 'Matrix A after balancing', 'Integer', &
        rlabs, 'Integer', clabs, 80, 0, ifail)

      Write (nout, *)
      Flush (nout)

!     Matrix B after balancing

      ifail = 0
      Call nagf_file_print_matrix_complex_gen_comp('General', ' ', n, n, b, &
        ldb, 'Bracketed', 'F7.4', 'Matrix B after balancing', 'Integer', &
        rlabs, 'Integer', clabs, 80, 0, ifail)

      Write (nout, *)
      Flush (nout)

!     Reduce B to triangular form using QR
      irows = ihi + 1 - ilo

      Call zgeqrf(irows, irows, b(ilo,ilo), ldb, tau, work, lwork, info)

!     Apply the orthogonal transformation to A
      Call zunmqr('L', 'C', irows, irows, irows, b(ilo,ilo), ldb, tau, &
        a(ilo,ilo), lda, work, lwork, info)

!     Compute the generalized Hessenberg form of (A,B) -> (H,T)
      compq = 'N'
      compz = 'N'

      Call zgghd3(compq, compz, irows, 1, irows, a(ilo,ilo), lda, b(ilo,ilo), &
        ldb, q, ldq, z, ldz, work, lwork, info)

!     Matrix A (H) in generalized Hessenberg form
      ifail = 0
      Call nagf_file_print_matrix_complex_gen_comp('General', ' ', n, n, a, &
        lda, 'Bracketed', 'F7.3', 'Matrix A in Hessenberg form', 'Integer', &
        rlabs, 'Integer', clabs, 80, 0, ifail)

      Write (nout, *)
      Flush (nout)

!     Matrix B (T) in generalized Hessenberg form
      ifail = 0
      Call nagf_file_print_matrix_complex_gen_comp('General', ' ', n, n, b, &
        ldb, 'Bracketed', 'F7.3', 'Matrix B is triangular', 'Integer', rlabs, &
        'Integer', clabs, 80, 0, ifail)

!     Routine ZHGEQZ
!     Workspace query: jwork = -1

      jwork = -1
      job = 'E'
      Call zhgeqz(job, compq, compz, n, ilo, ihi, a, lda, b, ldb, alpha, beta, &
        q, ldq, z, ldz, work, jwork, rwork, info)
      Write (nout, *)
      Write (nout, 100) nint(real(work(1)))
      Write (nout, 110) lwork
      Write (nout, *)
      Write (nout, 120)
      Write (nout, *)
      Flush (nout)

!     Compute the generalized Schur form
!     if the workspace lwork is adequate

      If (nint(real(work(1)))<=lwork) Then

        Call zhgeqz(job, compq, compz, n, ilo, ihi, a, lda, b, ldb, alpha, &
          beta, q, ldq, z, ldz, work, lwork, rwork, info)

!       Print the generalized eigenvalues in descending size order
!       Note: the actual values of beta are real and non-negative

!       Calculate the moduli of the finite eigenvalues.
        Allocate (e(n), emod(n), irank(n))
        ni = 0
        Do i = 1, n
          If (real(beta(i))/=0.0_dp) Then
            ni = ni + 1
            e(ni) = alpha(i)/beta(i)
            emod(ni) = abs(e(ni))
          Else
            Write (nout, 130) i
          End If
        End Do

!       Rearrange the finite eigenvalues in descending order of modulus.
        ifail = 0
        Call nagf_sort_realvec_rank(emod, 1, ni, 'Descending', irank, ifail)
        ifail = 0
        Call nagf_sort_cmplxvec_rank_rearrange(e, 1, ni, irank, ifail)

        Write (nout, 140)(i, '(', real(e(i)), ',', aimag(e(i)), ')', i=1, ni)
      Else
        Write (nout, 150)
      End If

100   Format (1X, 'Minimal required LWORK = ', I6)
110   Format (1X, 'Actual value of  LWORK = ', I6)
120   Format (1X, 'Generalized eigenvalues')
130   Format (1X, I4, 5X, 'Infinite eigenvalue')
140   Format (1X, I4, 5X, A, F7.3, A, F7.3, A)
150   Format (1X, 'Insufficient workspace allocated for call to ZHGEQZ')
    End Program