      SUBROUTINE MB04BD( JOB, COMPQ1, COMPQ2, N, A, LDA, DE, LDDE, C1,
     $                   LDC1, VW, LDVW, Q1, LDQ1, Q2, LDQ2, B, LDB, F,
     $                   LDF, C2, LDC2, ALPHAR, ALPHAI, BETA, IWORK,
     $                   LIWORK, DWORK, LDWORK, 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 real N-by-N skew-Hamiltonian/
C     Hamiltonian pencil aS - bH with
C
C           (  A  D  )         (  C  V  )
C       S = (        ) and H = (        ).                           (1)
C           (  E  A' )         (  W -C' )
C
C     Optionally, if JOB = 'T', decompositions of S and H will be
C     computed via orthogonal 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. The notation M'
C     denotes the transpose of the matrix M.
C     Optionally, if COMPQ1 = 'I' or COMPQ1 = 'U', then the orthogonal
C     transformation matrix Q1 will be computed.
C     Optionally, if COMPQ2 = 'I' or COMPQ2 = 'U', then the orthogonal
C     transformation matrix Q2 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; S and H will not
C                    necessarily be transformed as in (2).
C             = 'T': put S and H into the forms in (2) and return the
C                    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 Q on
C                     entry, and the product Q*Q1 is returned, where Q1
C                     is the product of the orthogonal transformations
C                     that are applied to the pencil aS - bH to reduce
C                     S and H to the forms in (2), 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':  on exit, the array Q2 contains the orthogonal
C                     matrix Q2;
C             = 'U':  on exit, the array Q2 contains the matrix product
C                     J*Q*J'*Q2, where Q2 is the product of the
C                     orthogonal transformations that are applied to
C                     the pencil aS - bH to reduce S and H to the forms
C                     in (2), for COMPQ2 = 'I'.
C                     Setting COMPQ2 <> 'N' assumes COMPQ2 = COMPQ1.
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 JOB = 'T', the leading N/2-by-N/2 part of this
C             array contains the matrix Aout; otherwise, it contains the
C             upper triangular matrix A obtained just before the
C             application of the periodic QZ algorithm.
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 strictly lower triangular
C             part of this array must contain the strictly lower
C             triangular part of the skew-symmetric matrix E, and the
C             N/2-by-N/2 strictly upper triangular part of the submatrix
C             in the columns 2 to N/2+1 of this array must contain the
C             strictly upper triangular part of the skew-symmetric
C             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 JOB = 'T', the leading N/2-by-N/2 strictly
C             upper triangular part of the submatrix in the columns
C             2 to N/2+1 of this array contains the strictly upper
C             triangular part of the skew-symmetric matrix Dout.
C             If JOB = 'E', the leading N/2-by-N/2 strictly upper
C             triangular part of the submatrix in the columns 2 to N/2+1
C             of this array contains the strictly upper triangular part
C             of the skew-symmetric matrix D just before the application
C             of the periodic QZ algorithm. The remaining entries are
C             meaningless.
C
C     LDDE    INTEGER
C             The leading dimension of the array DE.
C             LDDE >= MAX(1, N/2).
C
C     C1      (input/output) DOUBLE PRECISION array, dimension
C                            (LDC1, N/2)
C             On entry, the leading N/2-by-N/2 part of this array must
C             contain the matrix C1 = C.
C             On exit, if JOB = 'T', the leading N/2-by-N/2 part of this
C             array contains the matrix C1out; otherwise, it contains the
C             upper triangular matrix C1 obtained just before the
C             application of the periodic QZ algorithm.
C
C     LDC1    INTEGER
C             The leading dimension of the array C1.
C             LDC1 >= MAX(1, N/2).
C
C     VW      (input/output) DOUBLE PRECISION array, dimension
C                            (LDVW, 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 W, 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 V.
C             On exit, if JOB = 'T', the N/2-by-N/2 part in the columns
C             2 to N/2+1 of this array contains the matrix Vout.
C             If JOB = 'E', the N/2-by-N/2 part in the columns 2 to
C             N/2+1 of this array contains the matrix V just before the
C             application of the periodic QZ algorithm.
C
C     LDVW    INTEGER
C             The leading dimension of the array VW.
C             LDVW >= MAX(1, N/2).
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 Q, and on exit,
C             the leading N-by-N part of this array contains the product
C             of the input matrix Q and the transformation matrix Q1
C             used to transform the matrices S 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      (output) DOUBLE PRECISION array, dimension (LDQ2, N)
C             On exit, if COMPQ2 = 'U', then the leading N-by-N part of
C             this array contains the product of the matrix J*Q*J' and
C             the transformation matrix Q2 used to transform the
C             matrices S 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     B       (output) DOUBLE PRECISION array, dimension (LDB, N/2)
C             On exit, if JOB = 'T', the leading N/2-by-N/2 part of this
C             array contains the matrix Bout; otherwise, it contains the
C             upper triangular matrix B obtained just before the
C             application of the periodic QZ algorithm.
C
C     LDB     INTEGER
C             The leading dimension of the array B.  LDB >= MAX(1, N/2).
C
C     F       (output) DOUBLE PRECISION array, dimension (LDF, N/2)
C             On exit, if JOB = 'T', the leading N/2-by-N/2 strictly
C             upper triangular part of this array contains the strictly
C             upper triangular part of the skew-symmetric matrix Fout.
C             If JOB = 'E', the leading N/2-by-N/2 strictly upper
C             triangular part of this array contains the strictly upper
C             triangular part of the skew-symmetric matrix F just before
C             the application of the periodic QZ algorithm.
C             The entries on the leading N/2-by-N/2 lower triangular
C             part of this array are not referenced.
C
C     LDF     INTEGER
C             The leading dimension of the array F.  LDF >= MAX(1, N/2).
C
C     C2      (output) DOUBLE PRECISION array, dimension (LDC2, N/2)
C             On exit, if JOB = 'T', the leading N/2-by-N/2 part of this
C             array contains the matrix C2out; otherwise, it contains
C             the upper Hessenberg matrix C2 obtained just before the
C             application of the periodic QZ algorithm.
C
C     LDC2    INTEGER
C             The leading dimension of the array C2.
C             LDC2 >= MAX(1, N/2).
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
C     LIWORK  INTEGER
C             The dimension of the array IWORK.
C             LIWORK >= N/2+12.
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 = -27, DWORK(1) returns the minimum
C             value of LDWORK.
C
C     LDWORK  INTEGER
C             The dimension of the array DWORK.
C             If JOB = 'E' and COMPQ1 = 'N' and COMPQ2 = 'N',
C                LDWORK >= N**2 + MAX(N,32);
C             if JOB = 'T' or COMPQ1 <> 'N' or COMPQ2 <> 'N',
C                LDWORK >= 2*N**2 + MAX(N,32).
C             For good performance LDWORK should generally be larger.
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: problem during computation of the eigenvalues;
C             = 2: periodic QZ algorithm did not converge in the SLICOT
C                  Library subroutine MB03BD.
C
C     METHOD
C
C     The algorithm uses Givens rotations and Householder reflections to
C     annihilate elements in S, T, and H such that A, B, and C1 are
C     upper triangular and C2 is upper Hessenberg. Finally, the periodic
C     QZ algorithm is applied to transform C2 to upper quasi-triangular
C     form while A, B, and C1 stay in upper triangular form.
C     See also page 27 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, October 16, 2008.
C
C     REVISIONS
C
C     V. Sima, Oct. 2009 (SLICOT version of the routine DHAUTR).
C     V. Sima, Nov. 2010, Feb. 2011, Oct. 2011, Oct. 2012.
C     M. Voigt, Jan. 2012.
C
C     KEYWORDS
C
C     periodic QZ algorithm, upper (quasi-)triangular matrix,
C     skew-Hamiltonian/Hamiltonian pencil.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO, HALF, ONE, TWO
      PARAMETER          ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0,
     $                     TWO  = 2.0D+0 )
C
C     .. Scalar Arguments ..
      CHARACTER          COMPQ1, COMPQ2, JOB
      INTEGER            INFO, LDA, LDB, LDC1, LDC2, LDDE, LDF, LDQ1,
     $                   LDQ2, LDVW, LDWORK, LIWORK, N
C
C     .. Array Arguments ..
      INTEGER            IWORK( * )
      DOUBLE PRECISION   A( LDA, * ), ALPHAI( * ), ALPHAR( * ),
     $                   B( LDB, * ), BETA( * ), C1( LDC1, * ),
     $                   C2( LDC2, * ), DE( LDDE, * ), DWORK( * ),
     $                   F( LDF, * ), Q1( LDQ1, * ), Q2( LDQ2, * ),
     $                   VW( LDVW, * )
C
C     .. Local Scalars ..
      LOGICAL            LCMPQ1, LCMPQ2, LINIQ1, LINIQ2, LTRI, LUPDQ1,
     $                   LUPDQ2
      CHARACTER*16       CMPQ, CMPSC
      INTEGER            I, IMAT, IWARN, IWRK, J, K, M, MJ1, MJ2, MJ3,
     $                   MK1, MK2, MK3, MM, OPTDW
      DOUBLE PRECISION   BASE, CO, EMAX, EMIN, MU, NU, PREC, SI, TMP1,
     $                   TMP2
      COMPLEX*16         EIG
C
C     .. Local Arrays ..
      INTEGER            IDUM( 1 )
      DOUBLE PRECISION   DUM( 1 )
C
C     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DDOT, DLAMCH, DLAPY2
      EXTERNAL           DDOT, DLAMCH, DLAPY2, LSAME
C
C     .. External Subroutines ..
      EXTERNAL           DAXPY, DCOPY, DGEMM, DLACPY, DLARF, DLARFG,
     $                   DLARTG, DLASET, DROT, DSYMV, DSYR2, MA02AD,
     $                   MB01LD, MB01MD, MB01ND, MB03BD, XERBLA
C
C     .. Intrinsic Functions ..
      INTRINSIC          ABS, DBLE, DCMPLX, DIMAG, INT, MAX, MIN, MOD,
     $                   SQRT
C
C     .. Executable Statements ..
C
C     Decode the input arguments.
C
      M  = N/2
      MM = M*M
      LTRI   = LSAME( JOB,    'T' )
      LINIQ1 = LSAME( COMPQ1, 'I' )
      LINIQ2 = LSAME( COMPQ2, 'I' )
      LUPDQ1 = LSAME( COMPQ1, 'U' )
      LUPDQ2 = LSAME( COMPQ2, 'U' )
      LCMPQ1 = LUPDQ1 .OR. LINIQ1
      LCMPQ2 = LUPDQ2 .OR. LINIQ2
      IF( LTRI .OR. LCMPQ1 .OR. LCMPQ2 ) THEN
         OPTDW = 8*MM + MAX( N, 32 )
      ELSE
         OPTDW = 4*MM + MAX( N, 32 )
      END IF
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( ( LINIQ2 .AND. .NOT.LINIQ1 ) .OR.
     $         ( LUPDQ2 .AND. .NOT.LUPDQ1 ) ) THEN
         INFO = -3
      ELSE IF( N.LT.0 .OR. MOD( N, 2 ).NE.0 ) THEN
         INFO = -4
      ELSE IF(  LDA.LT.MAX( 1, M ) ) THEN
         INFO = -6
      ELSE IF( LDDE.LT.MAX( 1, M ) ) THEN
         INFO = -8
      ELSE IF( LDC1.LT.MAX( 1, M ) ) THEN
         INFO = -10
      ELSE IF( LDVW.LT.MAX( 1, M ) ) THEN
         INFO = -12
      ELSE IF( LDQ1.LT.1 .OR. ( LCMPQ1 .AND. LDQ1.LT.N ) ) THEN
         INFO = -14
      ELSE IF( LDQ2.LT.1 .OR. ( LCMPQ2 .AND. LDQ2.LT.N ) ) THEN
         INFO = -16
      ELSE IF(  LDB.LT.MAX( 1, M ) ) THEN
         INFO = -18
      ELSE IF(  LDF.LT.MAX( 1, M ) ) THEN
         INFO = -20
      ELSE IF( LDC2.LT.MAX( 1, M ) ) THEN
         INFO = -22
      ELSE IF( LIWORK.LT.M+12 ) THEN
         INFO = -27
      ELSE IF( LDWORK.LT.OPTDW ) THEN
         INFO = -29
      END IF
      IF( INFO.NE.0) THEN
         CALL XERBLA( 'MB04BD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( N.EQ.0 ) THEN
         DWORK( 1 ) = ONE
         RETURN
      END IF
C
C     Determine machine constants.
C
      BASE = DLAMCH( 'Base' )
      EMIN = DLAMCH( 'Minimum Exponent' )
      EMAX = DLAMCH( 'Largest Exponent' )
      PREC = DLAMCH( 'Precision' )*DBLE( N )
C
C     STEP 1: Reduce S to skew-Hamiltonian triangular form.
C
      IF( LINIQ1 )
     $   CALL DLASET( 'Full', N, N, ZERO, ONE, Q1, LDQ1 )
C
      DUM( 1 ) = ZERO
C
      DO 10 K = 1, M - 1
C
C        Generate elementary reflector H(k) = I - nu * v * v' to
C        annihilate E(k+2:m,k).
C
         MK2  = MIN( K+2, M )
         MK3  = MK2 + 1
         TMP1 = DE( K+1, K )
         CALL DLARFG( M-K, TMP1, DE( MK2, K ), 1, NU )
         IF( NU.NE.ZERO ) THEN
            DE( K+1, K ) = ONE
C
C           Apply H(k) from both sides to E(k+1:m,k+1:m).
C           Compute  x := nu * E(k+1:m,k+1:m) * v.
C
            CALL MB01MD( 'Lower', M-K, NU, DE( K+1, K+1 ), LDDE,
     $                   DE( K+1, K ), 1, ZERO, DWORK, 1 )
C
C           Compute  w := x - 1/2 * nu * (x'*v) * v in x.
C
            MU = -HALF*NU*DDOT( M-K, DWORK, 1, DE( K+1, K ), 1 )
            CALL DAXPY( M-K, MU, DE( K+1, K ), 1, DWORK, 1 )
C
C           Apply the transformation as a skew-symmetric rank-2 update:
C                E := E + v * w' - w * v'.
C
            CALL MB01ND( 'Lower', M-K, ONE, DE( K+1, K ), 1, DWORK, 1,
     $                   DE( K+1, K+1 ), LDDE )
C
C           Apply H(k) to W(k+1:m,1:k) from the left (and implicitly to
C           W(1:k,k+1:m) from the right).
C
            CALL DLARF( 'Left', M-K, K, DE( K+1, K ), 1, NU,
     $                  VW( K+1, 1 ), LDVW, DWORK )
C
C           Apply H(k) from both sides to W(k+1:m,k+1:m).
C           Compute  x := nu * W(k+1:m,k+1:m) * v.
C
            CALL DSYMV( 'Lower', M-K, NU, VW( K+1, K+1 ), LDVW,
     $                  DE( K+1, K ), 1, ZERO, DWORK, 1 )
C
C           Compute  w := x - 1/2 * nu * (x'*v) * v.
C
            MU = -HALF*NU*DDOT( M-K, DWORK, 1, DE( K+1, K ), 1 )
            CALL DAXPY( M-K, MU, DE( K+1, K ), 1, DWORK, 1 )
C
C           Apply the transformation as a rank-2 update:
C                W := W - v * w' - w * v'.
C
            CALL DSYR2( 'Lower', M-K, -ONE, DE( K+1, K ), 1, DWORK, 1,
     $                  VW( K+1, K+1 ), LDVW )
C
C           Apply H(k) from the right hand side to A(1:m,k+1:m) and
C           C1(1:m,k+1:m).
C
            CALL DLARF( 'Right', M, M-K, DE( K+1, K ), 1, NU,
     $                  A( 1, K+1 ), LDA, DWORK )
            CALL DLARF( 'Right', M, M-K, DE( K+1, K ), 1, NU,
     $                  C1( 1, K+1 ), LDC1, DWORK )
C
            IF( LCMPQ1 ) THEN
C
C              Apply H(k) from the right hand side to Q1(1:n,m+k+1:n).
C
               CALL DLARF( 'Right', N, M-K, DE( K+1, K ), 1, NU,
     $                     Q1( 1, M+K+1 ), LDQ1, DWORK )
            END IF
            DE( K+1, K ) = TMP1
         END IF
C
C        Determine a Givens rotation to annihilate E(k+1,k) from the
C        left.
C
         TMP2 = A( K+1, K )
         CALL DLARTG( TMP2, DE( K+1, K ), CO, SI, A( K+1, K ) )
C
C        Update A, E and D.
C
         CALL DROT( M-K-1, DE( MK2, K+1 ), 1, A( K+1, MK2 ), LDA, CO,
     $              SI )
         CALL DROT( K, A( 1, K+1 ), 1, DE( 1, K+2 ), 1, CO, SI )
         CALL DROT( M-K-1, DE( K+1, MK3 ), LDDE, A( MK2, K+1 ), 1, CO,
     $              SI )
C
C        Update C1, W and V.
C
         CALL DROT( K, VW( K+1, 1 ), LDVW, C1( K+1, 1 ), LDC1, CO, -SI )
         CALL DROT( M-K-1, VW( MK2, K+1 ), 1, C1( K+1, MK2 ), LDC1, CO,
     $              -SI )
         CALL DROT( K, C1( 1, K+1 ), 1, VW( 1, K+2 ), 1, CO, SI )
         CALL DROT( M-K-1, VW( K+1, MK3 ), LDVW, C1( MK2, K+1 ), 1, CO,
     $              -SI )
C
C        Fix the diagonal part.
C
         TMP1 = C1( K+1, K+1 )
         TMP2 = VW( K+1, K+2 )
         C1( K+1, K+1 ) = ( CO - SI )*( CO + SI )*TMP1 +
     $                    CO*SI*( VW( K+1, K+1 ) + TMP2 )
         TMP1 = TWO*CO*SI*TMP1
         VW( K+1, K+2 ) = CO**2*TMP2 - SI**2*VW( K+1, K+1 ) - TMP1
         VW( K+1, K+1 ) = CO**2*VW( K+1, K+1 ) - SI**2*TMP2 - TMP1
C
         IF( LCMPQ1 ) THEN
C
C           Update Q1.
C
            CALL DROT( N, Q1( 1, K+1 ), 1, Q1( 1, M+K+1 ), 1, CO, SI )
         END IF
C
C        Generate elementary reflector P(k) to annihilate A(k+1:m,k).
C
         TMP1 = A( K, K )
         CALL DLARFG( M-K+1, TMP1, A( K+1, K ), 1, NU )
         IF( NU.NE.ZERO ) THEN
            A( K, K ) = ONE
C
C           Apply P(k) from the left hand side to A(k:m,k+1:m).
C
            CALL DLARF( 'Left', M-K+1, M-K, A( K, K ), 1, NU,
     $                  A( K, K+1 ), LDA, DWORK )
C
C           Apply P(k) to D(1:k-1,k:m) from the right (and implicitly
C           to D(k:m,1:k-1) from the left).
C
            CALL DLARF( 'Right', K-1, M-K+1, A( K, K ), 1, NU,
     $                  DE( 1, K+1 ), LDDE, DWORK )
C
C           Apply P(k) from both sides to D(k:m,k:m).
C           Compute  x := nu * D(k:m,k:m) * v.
C
            CALL MB01MD( 'Upper', M-K+1, NU, DE( K, K+1 ), LDDE,
     $                   A( K, K ), 1, ZERO, DWORK, 1 )
C
C           Compute  w := x - 1/2 * nu * (x'*v) * v in x.
C
            MU = -HALF*NU*DDOT( M-K+1, DWORK, 1, A( K, K ), 1 )
            CALL DAXPY( M-K+1, MU, A( K, K ), 1, DWORK, 1 )
C
C           Apply the transformation as a skew-symmetric rank-2 update:
C                D := D + v * w' - w * v'.
C
            CALL MB01ND( 'Upper', M-K+1, ONE, A( K, K ), 1, DWORK, 1,
     $                   DE( K, K+1 ), LDDE )
C
C           Apply P(k) from the left hand side to C1(k:m,1:m).
C
            CALL DLARF( 'Left', M-K+1, M, A( K, K ), 1, NU, C1( K, 1 ),
     $                  LDC1, DWORK )
C
C           Apply P(k) to V(1:k-1,k:m) from the right (and implicitly
C           to V(k:m,1:k-1) from the left).
C
            CALL DLARF( 'Right', K-1, M-K+1, A( K, K ), 1, NU,
     $                  VW( 1, K+1 ), LDVW, DWORK )
C
C           Apply P(k) from both sides to V(k:m,k:m).
C           Compute  x := nu * V(k:m,k:m) * v.
C
            CALL DSYMV( 'Upper', M-K+1, NU, VW( K, K+1 ), LDVW,
     $                  A( K, K ), 1, ZERO, DWORK, 1 )
C
C           Compute  w := x - 1/2 * nu * (x'*v) * v.
C
            MU = -HALF*NU*DDOT( M-K+1, DWORK, 1, A( K, K ), 1 )
            CALL DAXPY( M-K+1, MU, A( K, K ), 1, DWORK, 1 )
C
C           Apply the transformation as a rank-2 update:
C                V := V - v * w' - w * v'.
C
            CALL DSYR2( 'Upper', M-K+1, -ONE, A( K, K ), 1, DWORK, 1,
     $                  VW( K, K+1 ), LDVW )
C
            IF( LCMPQ1 ) THEN
C
C              Apply P(k) from the right hand side to Q1(1:n,k:m).
C
               CALL DLARF( 'Right', N, M-K+1, A( K, K ), 1, NU,
     $                     Q1( 1, K ), LDQ1, DWORK )
            END IF
            A( K, K ) = TMP1
         END IF
C
C        Set A(k+1:m,k) to zero in order to be able to apply MB03BD.
C
         CALL DCOPY( M-K, DUM, 0, A( K+1, K ), 1 )
   10 CONTINUE
C
C     The following operations do not preserve the Hamiltonian structure
C     of H. -C1 is copied to C2. The lower triangular part of W(1:m,1:m)
C     and its transpose are stored in DWORK. Then, the transpose of the
C     upper triangular part of V(1:m,1:m) is saved in the lower
C     triangular part of VW(1:m,2:m+1).
C
      CALL DLACPY( 'Full', M, M, A, LDA, B, LDB )
      CALL DLACPY( 'Upper', M, M, DE( 1, 2 ), LDDE, F, LDF )
C
      DO 30 J = 1, M
         DO 20 I = 1, M
            C2( I, J ) = -C1( I, J )
   20    CONTINUE
   30 CONTINUE
C
      CALL DLACPY( 'Lower', M, M, VW, LDVW, DWORK, M )
      CALL MA02AD( 'Lower', M, M, VW, LDVW, DWORK, M )
C
      CALL MA02AD( 'Upper', M, M, VW( 1, 2 ), LDVW, VW( 1, 2 ), LDVW )
C
      IF ( LCMPQ2 ) THEN
         CALL DLACPY( 'Full', M, M, Q1( M+1, M+1 ), LDQ1, Q2, LDQ2 )
C
         DO 50 J = 1, M
            DO 40 I = M + 1, N
               Q2( I, J ) = -Q1( I-M, J+M )
   40       CONTINUE
   50    CONTINUE
C
         DO 70 J = M + 1, N
            DO 60 I = 1, M
               Q2( I, J ) = -Q1( I+M, J-M )
   60       CONTINUE
   70    CONTINUE
C
         CALL DLACPY( 'Full', M, M, Q1, LDQ1, Q2( M+1, M+1 ), LDQ2 )
      END IF
C
C     STEP 2: Eliminations in H.
C
      DO 120 K = 1, M
         MK1 = MIN( K+1, M )
C
C        I. Annihilate W(k:m-1,k).
C
         DO 80 J = K, M - 1
            MJ3  = MIN( J+3, M+1 )
C
C           Determine a Givens rotation to annihilate W(j,k) from the
C           left.
C
            CALL DLARTG( DWORK( ( K-1 )*M+J+1 ), DWORK( ( K-1 )*M+J ),
     $                   CO, SI, TMP1 )
C
C           Update C2 and W.
C
            CALL DROT( M, C2( 1, J+1 ), 1, C2( 1, J ), 1, CO, SI )
            DWORK( ( K-1 )*M+J+1 ) = TMP1
            DWORK( ( K-1 )*M+J )   = ZERO
            CALL DROT( M-K, DWORK( K*M+J+1 ), M, DWORK( K*M+J ), M, CO,
     $                 SI )
C
C           Update A.
C
            CALL DROT( J, A( 1, J+1 ), 1, A( 1, J ), 1, CO, SI )
            TMP1          = -SI*A( J+1, J+1 )
            A( J+1, J+1 ) =  CO*A( J+1, J+1 )
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 A(j+1,j) from the
C           left.
C
            CALL DLARTG( A( J, J ), TMP1, CO, SI, TMP2 )
C
C           Update A and D.
C
            A( J, J ) = TMP2
            CALL DROT( M-J, A( J, J+1 ), LDA, A( J+1, J+1 ), LDA, CO, SI
     $                  )
            CALL DROT( J-1, DE( 1, J+1 ), 1, DE( 1, J+2 ), 1, CO, SI )
            CALL DROT( M-J-1, DE( J, MJ3 ), LDDE, DE( J+1, MJ3 ), LDDE,
     $                 CO, SI )
C
C           Update C1 and V.
C
            CALL DROT( M-K+1, C1( J, K ), LDC1, C1( J+1, K ), LDC1, CO,
     $                 SI )
            CALL DROT( M, VW( J, 2 ), LDVW, VW( J+1, 2 ), LDVW, 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 W(m,k).
C
C        Determine a Givens rotation to annihilate W(m,k) from the left.
C
         CALL DLARTG( C1( M, K ), DWORK( M*K ), CO, SI, TMP1 )
C
C        Update C1 and W.
C
         C1( M, K )   = TMP1
         DWORK( M*K ) = ZERO
         CALL DROT( M-K, C1( M, MK1 ), LDC1, DWORK( M*MK1 ), M, CO, SI )
         CALL DROT( M, VW( M, 2 ), LDVW, C2( 1, M ), 1, CO, SI )
C
C        Update A and D.
C
         CALL DROT( M-1, A( 1, M ), 1, DE( 1, M+1 ), 1, CO, SI )
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        III. Annihilate C1(k+1:m,k).
C
         DO 90 J = M, K + 1, -1
            MJ2  = MIN( J+2, M+1 )
C
C           Determine a Givens rotation to annihilate C1(j,k) from the
C           left.
C
            CALL DLARTG( C1( J-1, K ), C1( J, K ), CO, SI, TMP1 )
C
C           Update C1 and V.
C
            C1( J-1, K ) = TMP1
            C1( J, K )   = ZERO
            CALL DROT( M-K, C1( J-1, MK1 ), LDC1, C1( J, MK1 ), LDC1,
     $                 CO, SI )
            CALL DROT( M, VW( J-1, 2 ), LDVW, VW( J, 2 ), LDVW , CO, SI
     $                  )
C
C           Update A and D.
C
            TMP1          = -SI*A( J-1, J-1 )
            A( J-1, J-1 ) =  CO*A( J-1, J-1 )
            CALL DROT( M-J+1, A( J-1, J ), LDA, A( J, J ), LDA, CO, SI )
            CALL DROT( J-2, DE( 1, J ), 1, DE( 1, J+1 ), 1, CO, SI )
            CALL DROT( M-J, DE( J-1, MJ2 ), LDDE, DE( J, MJ2 ), LDDE,
     $                 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 A(j,j-1) from the
C           right.
C
            CALL DLARTG( A( J, J ), TMP1, CO, SI, TMP2 )
C
C           Update A.
C
            A( J, J ) = TMP2
            CALL DROT( J-1, A( 1, J ), 1, A( 1, J-1 ), 1, CO, SI )
C
C           Update C2 and W.
C
            CALL DROT( M, C2( 1, J ), 1, C2( 1, J-1 ), 1, CO, SI )
            CALL DROT( M-K+1, DWORK( ( K-1 )*M+J ), M,
     $                 DWORK( ( K-1)*M+J-1 ), M, 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 W(k,k+1:m-1).
C
         DO 100 J = K + 1, M - 1
            MJ2  = MIN( J+2, M )
C
C           Determine a Givens rotation to annihilate W(k,j) from the
C           right.
C
            CALL DLARTG( DWORK( J*M+K ), DWORK( ( J-1 )*M+K ), CO,
     $                   SI, TMP1 )
C
C           Update C1 and W.
C
            CALL DROT( M, C1( 1, J+1 ), 1, C1( 1, J ), 1, CO, SI )
            DWORK( ( J-1 )*M+K ) = ZERO
            DWORK( J*M+K )       = TMP1
            CALL DROT( M-K, DWORK( J*M+MK1 ), 1, DWORK( ( J-1 )*M+K+1 ),
     $                 1, CO, SI )
C
C           Update B.
C
            CALL DROT( J, B( 1, J+1 ), 1, B( 1, J ), 1, CO, SI )
            TMP1          = -SI*B( J+1, J+1 )
            B( J+1, J+1 ) =  CO*B( J+1, J+1 )
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 B(j+1,j) from the
C           left.
C
            CALL DLARTG( B( J, J ), TMP1, CO, SI, TMP2 )
C
C           Update B and F.
C
            B( J, J ) = TMP2
            CALL DROT( M-J, B( J, J+1 ), LDB, B( J+1, J+1 ), LDB, CO, SI
     $                  )
            CALL DROT( J-1, F( 1, J ), 1, F( 1, J+1 ), 1, CO, SI )
            CALL DROT( M-J-1, F( J, MJ2 ), LDF, F( J+1, MJ2 ), LDF, CO,
     $                 SI )
C
C           Update C2 and V.
C
            CALL DROT( M-K+1, C2( J, K ), LDC2, C2( J+1, K ), LDC2, CO,
     $                 SI )
            CALL DROT( M, VW( 1, J+1 ), 1, VW( 1, J+2 ), 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 W(k,m).
C
         IF( K.LT.M ) THEN
C
C           Determine a Givens rotation to annihilate W(k,m) from the
C           right.
C
            CALL DLARTG( C2( M, K ), DWORK( ( M-1 )*M+K ), CO, SI, TMP1
     $                    )
C
C           Update C1, C2, W and V.
C
            CALL DROT( M, VW( 1, M+1 ), 1, C1( 1, M ), 1, CO, SI )
            C2( M, K )           = TMP1
            DWORK( ( M-1 )*M+K ) = ZERO
            CALL DROT( M-K, C2( M, K+1 ), LDC2, DWORK( ( M-1 )*M+K+1 ),
     $                 1, CO, SI )
C
C           Update B and F.
C
            CALL DROT( M-1, F( 1, M ), 1, B( 1, M ), 1, CO, SI )
C
            IF( LCMPQ2 ) THEN
C
C               Update Q2.
C
                CALL DROT( N, Q2( 1, N ), 1, Q2( 1, M ), 1, CO, SI )
            END IF
         ELSE
C
C           Determine a Givens rotation to annihilate W(m,m) from the
C           left.
C
            CALL DLARTG( C1( M, M ), DWORK( MM ), CO, SI, TMP1 )
C
C           Update C1, C2, W and V.
C
            C1( M, M )  = TMP1
            DWORK( MM ) = ZERO
            CALL DROT( M, VW( M, 2 ), LDVW, C2( 1, M ), 1, CO, SI )
C
C           Update A and D.
C
            CALL DROT( M-1, A( 1, M ), 1, DE( 1, M+1 ), 1, CO, SI )
C
            IF( LCMPQ1 ) THEN
C
C              Update Q1.
C
               CALL DROT( N, Q1( 1, M ), 1, Q1( 1, N ), 1, CO, SI )
            END IF
         END IF
C
C        VI. Annihilate C2(k+2:m,k).
C
         DO 110 J = M, K + 2, -1
            MJ1 = MIN( J+1, M )
C
C           Determine a Givens rotation to annihilate C2(j,k) from the
C           left.
C
            CALL DLARTG( C2( J-1, K ), C2( J, K ), CO, SI, TMP1 )
C
C           Update C2 and V.
C
            C2( J-1, K ) = TMP1
            C2( J, K )   = ZERO
            CALL DROT( M-K, C2( J-1, MK1 ), LDC2, C2( J, MK1 ), LDC2,
     $                 CO, SI )
            CALL DROT( M, VW( 1, J ), 1, VW( 1, J+1 ), 1, CO, SI )
C
C           Update B and F.
C
            CALL DROT( M-J+1, B( J-1, J ), LDB, B( J, J ), LDB, CO, SI )
            TMP1          = -SI*B( J-1, J-1 )
            B( J-1, J-1 ) =  CO*B( J-1, J-1 )
            CALL DROT( J-2, F( 1, J-1 ), 1, F( 1, J ), 1, CO, SI )
            CALL DROT( M-J, F( J-1, MJ1 ), LDF, F( J, MJ1 ), LDF, 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 B(j,j-1) from the
C           right.
C
            CALL DLARTG( B( J, J ), TMP1, CO, SI, TMP2 )
            B( J, J ) = TMP2
C
C           Update B.
C
            CALL DROT( J-1, B( 1, J ), 1, B( 1, J-1 ), 1, CO, SI )
C
C           Update C1 and W.
C
            CALL DROT( M, C1( 1, J ), 1, C1( 1, J-1 ), 1, CO, SI )
            CALL DROT( M-K+1, DWORK( ( J-1 )*M+K ), 1,
     $                 DWORK( ( J-2 )*M+K ), 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
  120 CONTINUE
C
C                     (  A1  D1  )      (  B1  F1  )      (  C11  V1  )
C     Now we have S = (          ), T = (          ), H = (           ),
C                     (   0  A1' )      (   0  B1' )      (   0  C21' )
C
C     where A1, B1, and C11 are upper triangular, C21 is upper
C     Hessenberg, and D1 and F1 are skew-symmetric.
C
C     STEP 3: Apply the periodic QZ algorithm to the generalized matrix
C
C                           -1       -1
C             product C21 A1   C11 B1   in order to make C21 upper
C             quasi-triangular.
C
C     Determine the mode of computations.
C
      IF( LTRI .OR. LCMPQ1 .OR. LCMPQ2 ) THEN
         CMPQ = 'Initialize'
         IMAT = 4*MM + 1
         IWRK = 8*MM + 1
      ELSE
         CMPQ = 'No Computation'
         IMAT = 1
         IWRK = 4*MM + 1
      END IF
C
      IF( LTRI ) THEN
         CMPSC = 'Schur Form'
      ELSE
         CMPSC = 'Eigenvalues Only'
      END IF
C
C     Save matrices in the form that is required by MB03BD.
C
      CALL DLACPY( 'Full', M, M, C2, LDC2, DWORK( IMAT ),      M )
      CALL DLACPY( 'Full', M, M, A,  LDA,  DWORK( IMAT+MM ),   M )
      CALL DLACPY( 'Full', M, M, C1, LDC1, DWORK( IMAT+2*MM ), M )
      CALL DLACPY( 'Full', M, M, B,  LDB,  DWORK( IMAT+3*MM ), M )
      IWORK( 1 ) =  1
      IWORK( 2 ) = -1
      IWORK( 3 ) =  1
      IWORK( 4 ) = -1
C
C     Apply periodic QZ algorithm.
C     Workspace:    need   OPTDW;
C                   prefer larger.
C
      CALL MB03BD( CMPSC, 'Careful', CMPQ, IDUM, 4, M, 1, 1, M, IWORK,
     $             DWORK( IMAT ), M, M, DWORK, M, M, ALPHAR, ALPHAI,
     $             BETA, IWORK( 5 ), IWORK( M+5 ), LIWORK-( M+4 ),
     $             DWORK( IWRK ), LDWORK-IWRK+1, IWARN, INFO )
      IF( IWARN.GT.0 .AND. IWARN.LT.M ) THEN
         INFO = 1
         RETURN
      ELSE IF( INFO.GT.0 ) THEN
         INFO = 2
         RETURN
      END IF
      OPTDW = MAX( OPTDW, INT( DWORK( IWRK ) ) + IWRK - 1 )
C
C     Compute the eigenvalues with nonnegative imaginary parts of the
C     pencil aS - bH.
C
      DO 130 I = 1, M
         IF( IWORK( I+4 ).GE.2*EMIN .AND. IWORK( I+4 ).LE.2*EMAX ) THEN
C
C           B = SQRT(BASE**IWORK(i+4)) is between underflow and overflow
C           threshold, BETA(i) is divided by B.
C           Set to zero negligible real and imaginary parts.
C
            BETA( I ) = BETA( I )/BASE**( HALF*IWORK( I+4 ) )
            EIG = SQRT( DCMPLX( ALPHAR( I ), ALPHAI( I ) ) )
            ALPHAR( I ) = DIMAG( EIG )
            ALPHAI( I ) = DBLE(  EIG )
            TMP2 = PREC*DLAPY2( ALPHAR( I ), ALPHAI( I ) )
            IF( ABS( ALPHAR( I ) ).LT.TMP2 ) THEN
               ALPHAR( I ) = ZERO
               IF( ALPHAI( I ).LT.ZERO )
     $             ALPHAI( I ) = -ALPHAI( I )
            END IF
            IF( ABS( ALPHAI( I ) ).LT.TMP2 ) THEN
               ALPHAI( I ) = ZERO
               IF( ALPHAR( I ).LT.ZERO )
     $             ALPHAR( I ) = -ALPHAR( I )
            END IF
         ELSE
C
C           Error.
C
            INFO = 1
            RETURN
         END IF
  130 CONTINUE
C
      IF( LTRI ) THEN
C
C        Update C1 and C2.
C
         CALL DLACPY( 'Upper', M, M, DWORK( IMAT+2*MM ), M, C1, LDC1 )
         CALL DLACPY( 'Full',  M, M, DWORK( IMAT ), M, C2, LDC2 )
C
C        Update V.
C
         CALL DGEMM( 'Transpose', 'No Transpose', M, M, M, ONE,
     $               DWORK( 2*MM+1 ), M, VW( 1, 2 ), LDVW, ZERO,
     $               DWORK( IMAT ), M )
         CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE,
     $               DWORK( IMAT ), M, DWORK, M, ZERO, VW( 1, 2 ),
     $               LDVW )
C
C        Update A.
C
         CALL DLACPY( 'Upper', M, M, DWORK( IMAT+MM ), M, A, LDA )
C
C        Skew-symmetric update of D.
C
         CALL MB01LD( 'Upper', 'Transpose', M, M, ZERO, ONE, DE( 1, 2 ),
     $                LDDE, DWORK( 2*MM+1 ), M, DE( 1, 2 ), LDDE,
     $                DWORK( IMAT ), LDWORK-IMAT+1, INFO )
C
C        Update B.
C
         CALL DLACPY( 'Upper', M, M, DWORK( IMAT+3*MM ), M, B, LDB )
C
C        Skew-symmetric update of F.
C
         CALL MB01LD( 'Upper', 'Transpose', M, M, ZERO, ONE, F, LDF,
     $                DWORK, M, F, LDF, DWORK( IMAT ), LDWORK-IMAT+1,
     $                INFO )
C
         IF( LCMPQ1 ) THEN
C
C           Update Q1.
C
            CALL DGEMM( 'No Transpose', 'No Transpose', N, M, M, ONE,
     $                  Q1, LDQ1, DWORK( 2*MM+1 ), 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( MM+1 ), 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( 3*MM+1 ), 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
      END IF
C
      DWORK( 1 ) = OPTDW
      RETURN
C *** Last line of MB04BD ***
      END


***
      SUBROUTINE kick(kw,m1,m1n,m2,ecc,sep,jorb,v,ffb,ECS,mfin)
      implicit none
*
      integer kw,k
      INTEGER idum
      COMMON /VALUE3/ idum
      INTEGER idum2,iy,ir(32)
      COMMON /RAND3/ idum2,iy,ir
      real*8 m1,m2,m1n,ecc,sep,jorb,ecc2,mrem,mean_ej
      real*8 pi,twopi,gmrkm,yearsc,rsunkm
      parameter(yearsc=3.1557d+07,rsunkm=6.96d+05)
      real*8 mm,em,dif,der,del,r
      real*8 u1,u2,vk,v(4),s,theta,phi,ss
      real*8 sphi,cphi,stheta,ctheta,salpha,calpha
      real*8 vr,vr2,vk2,vn2,hn2
      real*8 mu,cmu,vs(3),v1,v2,mx1,mx2
      real*8 maxwellian
      real*8 sigma1,sigma2,mxns
      integer bhflag
      COMMON /VALUE4/ sigma1,sigma2,mxns,bhflag
      real ran3,xx
      external ran3
*
      INTEGER ceflag,tflag,ifflag,nsflag,wdflag,piflag
      COMMON /FLAGS/ ceflag,tflag,ifflag,nsflag,wdflag,piflag
*
      INTEGER ECS
      real*8 ffb,mfin
*
      do k = 1,3
         vs(k) = 0.d0
      enddo
*     if(kw.eq.14.and.bhflag.eq.0) goto 95
*
* To take into account the ECS
      if(ECS .eq. 1)then
* Check if the supernova is driven by electron-cupture...
          maxwellian = sigma2
      else
* ... or iron core collapse.
          maxwellian = sigma1
      endif
*
      pi = ACOS(-1.d0)
      twopi = 2.d0*pi
* Conversion factor to ensure velocities are in km/s using mass and
* radius in solar units.
      gmrkm = 1.906125d+05
*
* Find the initial separation by randomly choosing a mean anomaly.
      if(sep.gt.0.d0.and.ecc.ge.0.d0)then
         xx = RAN3(idum)
         mm = xx*twopi
         em = mm
 2       dif = em - ecc*SIN(em) - mm
         if(ABS(dif/mm).le.1.0d-04) goto 3
         der = 1.d0 - ecc*COS(em)
         del = dif/der
         em = em - del
         goto 2
 3       continue
         r = sep*(1.d0 - ecc*COS(em))
*
* Find the initial relative velocity vector.
         salpha = SQRT((sep*sep*(1.d0-ecc*ecc))/(r*(2.d0*sep-r)))
         calpha = (-1.d0*ecc*SIN(em))/SQRT(1.d0-ecc*ecc*COS(em)*COS(em))
         vr2 = gmrkm*(m1+m2)*(2.d0/r - 1.d0/sep)
         vr = SQRT(vr2)
      else
         vr = 0.d0
         vr2 = 0.d0
         salpha = 0.d0
         calpha = 0.d0
      endif
*
* Generate Kick Velocity using Maxwellian Distribution (Phinney 1992).
* Use Henon''s method for pairwise components (Douglas Heggie 22/5/97).
      do 20 k = 1,2
         u1 = RAN3(idum)
         u2 = RAN3(idum)
* Generate two velocities from polar coordinates S & THETA.
* way to avoid negative values in LOG
         ss = 1.d0 - u1
         if(ss.le.0.d0)then
            ss = 1.d-6
         endif
         s = maxwellian*SQRT(-2.d0*LOG(ss))
         theta = twopi*u2
         v(2*k-1) = s*COS(theta)
         v(2*k) = s*SIN(theta)
 20   continue
      vk2 = v(1)**2 + v(2)**2 + v(3)**2
      vk = SQRT(vk2)
      v(4) = vk
*
***
* Generate Kick Velocity for Black Holes...
* Standard case
      if(kw.eq.14.and.bhflag.eq.1)then
         mrem = m1n
         vk = vk*(1.d0 - ffb)
         vk2 = vk*vk
*     ... if they are generated via direct collapse vk = 0
***
* Generate Kick Velocity for Black Holes and Neutron Stars
* Fallback case
      elseif((kw.eq.14.or.kw.eq.13).and.(bhflag.eq.2))then
         mrem = m1n
         vk = vk*(1.d0 - ffb)
         vk2 = vk*vk
***
* Generate Kick Velocity for Black Holes and Neutron Stars
* Mass Ejected case:
*   vk = vk*(mej/<mej>)*(1.2/mrem)
      elseif((kw.eq.14.or.kw.eq.13).and.(bhflag.eq.3))then
         mrem = m1n
*
         if(kw.eq.14 .and. ffb.eq.1.d0)then
            mfin = mrem
         endif
* mean mass ejected <mej> in Msun (in a population of 10^6 single stars)
* model 1
         if(nsflag.eq.2) mean_ej = 9.d0
         if(nsflag.eq.3) mean_ej = 7.5d0
         vk = vk*((mfin-mrem)/mean_ej)*(1.2d0/mrem)
         vk2 = vk*vk
***
* Generate Kick Velocity for Black Holes and Neutron Stars
* FULL KICK FOR BOTH NS AND BH
      elseif((kw.eq.14.or.kw.eq.13).and.(bhflag.eq.4))then
         mrem = m1n
         vk = vk
         vk2 = vk*vk
***
      elseif((kw.eq.14.and.bhflag.eq.0).or.kw.lt.0)then
         vk2 = 0.d0
         vk = 0.d0
         if(kw.lt.0) kw = 13
*
      else
         write(66,*)'We have a problem in kicks.f'
      endif
***
*     rescale base on new vk
      do k = 1,3
         v(k) = v(k)*vk/v(4)
      end do
      v(4) = vk
*
*  Correction (Noticed by Peter & Mirek)
      u1 = RAN3(idum)
      u2 = RAN3(idum)
      theta = twopi*u2
***
      sphi = -1.d0 + 2.d0*u1
      phi = ASIN(sphi)
      cphi = COS(phi)
      stheta = SIN(theta)
      ctheta = COS(theta)
      if(sep.le.0.d0.or.ecc.lt.0.d0) goto 90
*
* Determine the magnitude of the new relative velocity.
* (NG 12/17: there was a wrong sign in the brackets)
      vn2 = vk2+vr2-2.d0*vk*vr*(ctheta*cphi*salpha+stheta*cphi*calpha)
* Calculate the new semi-major axis.
      sep = 2.d0/r - vn2/(gmrkm*(m1n+m2))
      sep = 1.d0/sep
*     if(sep.le.0.d0)then
*        ecc = 1.1d0
*        goto 90
*     endif
* Determine the magnitude of the cross product of the separation vector
* and the new relative velocity.
      v1 = vk2*sphi*sphi
      v2 = (vk*ctheta*cphi-vr*salpha)**2
      hn2 = r*r*(v1 + v2)
* Calculate the new eccentricity.
      ecc2 = 1.d0 - hn2/(gmrkm*sep*(m1n+m2))
      ecc2 = MAX(ecc2,0.d0)
      ecc = SQRT(ecc2)
* Calculate the new orbital angular momentum taking care to convert
* hn to units of Rsun^2/yr.
      jorb = (m1n*m2/(m1n+m2))*SQRT(hn2)*(yearsc/rsunkm)
* Determine the angle between the new and old orbital angular
* momentum vectors.
      cmu = (vr*salpha-vk*ctheta*cphi)/SQRT(v1 + v2)
      mu = ACOS(cmu)
* Calculate the components of the velocity of the new centre-of-mass.
 90   continue
      if(ecc.le.1.0)then
* Calculate the components of the velocity of the new centre-of-mass.
         mx1 = vk*m1n/(m1n+m2)
         mx2 = vr*(m1-m1n)*m2/((m1n+m2)*(m1+m2))
         vs(1) = mx1*ctheta*cphi + mx2*salpha
         vs(2) = mx1*stheta*cphi + mx2*calpha
         vs(3) = mx1*sphi
      else
* Calculate the relative hyperbolic velocity at infinity (simple method).
         sep = r/(ecc-1.d0)
*        cmu = SQRT(ecc-1.d0)
*        mu = ATAN(cmu)
         mu = ACOS(1.d0/ecc)
         vr2 = gmrkm*(m1n+m2)/sep
         vr = SQRT(vr2)
         vs(1) = vr*SIN(mu)
         vs(2) = vr*COS(mu)
         vs(3) = 0.d0
         ecc = MIN(ecc,99.99d0)
      endif
*
 95   continue
* Save the information about the colculation of the natal kick velocity
* Save even the ecc to know what systems are still bound after the SN
*      if(kw.eq.13)then
*         WRITE(33,*)vk,phi,theta,ecc,sep,mfin,mrem,m1n
*      elseif(kw.eq.14)then
*         WRITE(44,*)vk,phi,theta,ecc,sep,mfin,mrem,m1n
*      endif
*
      RETURN
      END
***


! Copyright (c) 2019 Etienne Descamps
! All rights reserved.
!
! Redistribution and use in source and binary forms, with or without modification,
! are permitted provided that the following conditions are met:
!
! 1. Redistributions of source code must retain the above copyright notice,
!    this list of conditions and the following disclaimer.
!
! 2. Redistributions in binary form must reproduce the above copyright notice,
!    this list of conditions and the following disclaimer in the documentation and/or
!    other materials provided with the distribution.
!
! 3. Neither the name of the copyright holder nor the names of its contributors may be
!    used to endorse or promote products derived from this software without specific prior
!    written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
! ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
! WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
! IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
! INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
! (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
! LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
! THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
! NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE,
! EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Program test_utils
  Use ieee_arithmetic
  Use iso_c_binding
  Use mlf_utils
  !CALL test_sel(128, 65)
  !CALL test_sel(129, 65)
  !CALL test_sel(127, 64)
  !CALL test_median([5d0, 3d0, 2d0, 8d0, 1d0, 0d0, 6d0])
  !CALL test_median([5d0, 4d0, 2d0, 8d0, 1d0, 0d0, 6d0, 7d0])
  CALL test_qsort(128, 8)
Contains
  Subroutine test_qsort(N, ND)
    integer, intent(in) :: N, ND
    integer :: i, j
    integer, allocatable :: idx(:)
    real(c_double) :: r
    real(c_double), allocatable :: Array(:,:)
    ALLOCATE(Array(ND, N), idx(N))
    Array = 0
    Do i = 1, N
      CALL RANDOM_NUMBER(r)
      j = MIN(1+FLOOR(r*REAL(ND,8)),ND)
      CALL RANDOM_NUMBER(r)
      Array(j,i) = r
    End Do
    CALL QSortIdx(Array, idx)
    Do i = 1, N
      PRINT *, REAL(Array(:,idx(i)),4)
    End Do
  End Subroutine test_qsort

  Subroutine test_median(V)
    real(c_double) :: V(:)
    integer, allocatable :: K(:)
    ALLOCATE(K(SIZE(V)))
    CALL QSortIdx(V, K)
    PRINT *, Median(V, K)
  End Subroutine test_median
End


program main  ! torus topology

  implicit none
  include 'mpif.h'
  integer :: size, rank, rank2, rank3, ierr
  integer :: comm_torus, comm_row
  integer :: partner_left, partner_right
  integer :: sum, sbuf, rbuf, i
  integer :: dims(2), coords(2)
  logical :: periods(2), remain_dims(2)
  character(8) :: arg

  call mpi_init(ierr)
  call mpi_comm_size(MPI_COMM_WORLD, size, ierr)
  call mpi_comm_rank(MPI_COMM_WORLD, rank, ierr)

  if (command_argument_count() /= 2) then
     write(0,*) "Usage: ring-torus dims1 dims2"
     call mpi_abort(mpi_comm_world, 1, ierr)
  endif

  call get_command_argument(1, arg) ;  read(arg, *) dims(1)
  call get_command_argument(2, arg) ;  read(arg, *) dims(2)

  if (dims(1) * dims(2) /= size) then
     write(0,*) "ring-torus: dims1 * dims2 /= n_procs"
     call mpi_abort(mpi_comm_world, 1, ierr)
  endif

  periods(1) = .true.
  periods(2) = .true.
  remain_dims(1) = .false.
  remain_dims(2) = .true.

  call mpi_cart_create(MPI_COMM_WORLD, 2, dims, periods,.true.,comm_torus, ierr)
  call mpi_comm_rank(comm_torus, rank2, ierr)
  call mpi_cart_coords(comm_torus, rank2, 2, coords, ierr)

  call mpi_cart_sub(comm_torus, remain_dims, comm_row, ierr)
  call mpi_comm_rank(comm_row, rank3, ierr)

  write(6, "(5(a,i0),a)") &
      "ranks(orig,torus,row) = ", rank, ",", rank2, ",", rank3, &
      " : coords (x,y) = (", coords(1), ",", coords(2), ")"

  call mpi_cart_shift(comm_row, 0, 1, partner_left, partner_right, ierr)

  sum = 0
  sbuf = rank3
  do
     call mpi_sendrecv(sbuf, 1, MPI_INTEGER, partner_right, 0, &
                       rbuf, 1, MPI_INTEGER, partner_left, 0, &
                       comm_row, MPI_STATUS_IGNORE, ierr)
     sum = sum + rbuf
     sbuf = rbuf
     if (rbuf == rank3) exit
  enddo

  write(6,"(3(ai0))") "torus-sum(", coords(1), ",", coords(2), ") = ", sum

  call mpi_finalize(ierr)
end


module rhs_scalar_mod

  use iso_fortran_env, only: real64
  implicit none

  contains

  elemental subroutine rhs_scalar (t, y, f)
      implicit none

      real(real64), intent(in) :: t, y
      real(real64), intent(out) :: f

      f = 2.0d0*t
  end subroutine rhs_scalar

end module rhs_scalar_mod


program test_descriptors
  use libscalapackfx_module
  implicit none

  type(blacsgrid) :: mygrid
  type(blocklist) :: blist
  integer :: desc(DLEN_)
  integer :: ii, iglob, iloc, nelem
  integer :: iproc, nproc

  call blacsfx_pinfo(iproc, nproc)
  call mygrid%initgrid(2, 2)
  if (mygrid%mycol == -1) then
    print *, "IDLE Node:", iproc, " Exiting..."
    call blacsfx_exit()
    stop
  end if
  call scalafx_getdescriptor(mygrid, 5, 5, 2, 2, desc)
  call blist%init(mygrid, desc, "c")
  do ii = 1, size(blist)
    call blist%getblock(ii, iglob, iloc, nelem)
    print "(6(A,I3,2X))", "PROW:", mygrid%myrow, "PCOL:", mygrid%mycol,&
        & "II:", ii, "GLOB:", iglob, "LOC:", iloc, "NEL:", nelem
  end do
  call blacsfx_exit()

end program test_descriptors


! ##################################################################################################################################
! Begin MIT license text.
! _______________________________________________________________________________________________________

! Copyright 2019 Dr William R Case, Jr (dbcase29@gmail.com)

! Permission is hereby granted, free of charge, to any person obtaining a copy of this software and
! associated documentation files (the "Software"), to deal in the Software without restriction, including
! without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to
! the following conditions:

! The above copyright notice and this permission notice shall be included in all copies or substantial
! portions of the Software and documentation.

! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
! OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
! THE SOFTWARE.
! _______________________________________________________________________________________________________

! End MIT license text.

      SUBROUTINE B3D_ISOPARAMETRIC ( DPSHX, GAUSS_PT, IGAUS, JGAUS, KGAUS, MESSAG, WRT_BUG_THIS_TIME, BMAT )

! Generates strain/displ matrix BMAT for solid 3D elements. Called by HEXA, PENTA and TETRA subroutines

      USE PENTIUM_II_KIND, ONLY       :  BYTE, LONG, DOUBLE
      USE IOUNT1, ONLY                :  WRT_BUG, WRT_ERR, WRT_LOG, BUG, F04
      USE SCONTR, ONLY                :  BLNK_SUB_NAM, ELDT_BUG_BMAT_BIT, ELDT_BUG_BCHK_BIT
      USE TIMDAT, ONLY                :  TSEC
      USE SUBR_BEGEND_LEVELS, ONLY    :  B3D_ISOPARAMETRIC_BEGEND
      USE CONSTANTS_1, ONLY           :  ZERO
      USE MODEL_STUF, ONLY            :  EID, ELGP, TYPE
      USE DEBUG_PARAMETERS, ONLY      :  DEBUG

      USE B3D_ISOPARAMETRIC_USE_IFs

      IMPLICIT NONE

      CHARACTER(LEN=LEN(BLNK_SUB_NAM)):: SUBR_NAME = 'B3D_ISOPARAMETRIC'
      CHARACTER(LEN=*)  , INTENT(IN)  :: MESSAG            ! Messag to print out if BCHECK is run
      CHARACTER( 1*BYTE), INTENT(IN)  :: WRT_BUG_THIS_TIME ! If 'Y' then write to BUG file if WRT_BUG array says to

      INTEGER(LONG), INTENT(IN)       :: GAUSS_PT          ! Gauss point number (used for DEBUG output)
      INTEGER(LONG), INTENT(IN)       :: IGAUS             ! I index of Gaus point (needed for some optional output)
      INTEGER(LONG), INTENT(IN)       :: JGAUS             ! J index of Gaus point (needed for some optional output)
      INTEGER(LONG), INTENT(IN)       :: KGAUS             ! K index of Gaus point (needed for some optional output)
      INTEGER(LONG)                   :: I,J               ! DO loop indices
      INTEGER(LONG)                   :: II,JJ             ! Counters
      INTEGER(LONG)                   :: ID(3*ELGP)        ! An input to subr BCHECK, called herein
      INTEGER(LONG), PARAMETER        :: NR      = 6       ! An input to subr BCHECK, called herein
      INTEGER(LONG), PARAMETER        :: SUBR_BEGEND = B3D_ISOPARAMETRIC_BEGEND

      REAL(DOUBLE) , INTENT(IN)       :: DPSHX(3,ELGP)     ! Derivatives of the 4 node bilinear isopar interps wrt elem x and y
      REAL(DOUBLE) , INTENT(OUT)      :: BMAT(6,3*ELGP)    ! Output strain-displ matrix for this elem
      REAL(DOUBLE)                    :: BW(6,12)          ! Output from subr BCHECK (matrix of 3 elem strains for 14 various elem
                                                           ! rigid body motions/constant strain distortions)
! **********************************************************************************************************************************
      IF (WRT_LOG >= SUBR_BEGEND) THEN
         CALL OURTIM
         WRITE(F04,9001) SUBR_NAME,TSEC, WRT_BUG_THIS_TIME, WRT_BUG(7), WRT_BUG(8), WRT_BUG(9)
 9001    FORMAT(1X,A,' BEGN ',F10.3, 3X, A1, 3(I3))
      ENDIF
! **********************************************************************************************************************************
! Initialize outputs

      DO I=1,6
         DO J=1,3*ELGP
            BMAT(I,J) = ZERO
         ENDDO
      ENDDO

! Calc outputs

      JJ = 0
      DO J=1,ELGP

         JJ = JJ + 1
         BMAT(1,JJ) = DPSHX(1,J)
         BMAT(2,JJ) = ZERO
         BMAT(3,JJ) = ZERO
         BMAT(4,JJ) = DPSHX(2,J)
         BMAT(5,JJ) = ZERO
         BMAT(6,JJ) = DPSHX(3,J)

         JJ = JJ + 1
         BMAT(1,JJ) = ZERO
         BMAT(2,JJ) = DPSHX(2,J)
         BMAT(3,JJ) = ZERO
         BMAT(4,JJ) = DPSHX(1,J)
         BMAT(5,JJ) = DPSHX(3,J)
         BMAT(6,JJ) = ZERO

         JJ = JJ + 1
         BMAT(1,JJ) = ZERO
         BMAT(2,JJ) = ZERO
         BMAT(3,JJ) = DPSHX(3,J)
         BMAT(4,JJ) = ZERO
         BMAT(5,JJ) = DPSHX(2,J)
         BMAT(6,JJ) = DPSHX(1,J)

      ENDDO

      IF ((WRT_BUG_THIS_TIME == 'Y') .AND. (WRT_BUG(8) > 0)) THEN

         WRITE(BUG,1101) ELDT_BUG_BMAT_BIT, TYPE, EID
         WRITE(BUG,8901) IGAUS, JGAUS, KGAUS, SUBR_NAME
         DO I=1,6
            WRITE(BUG,8902) I,(BMAT(I,J),J=1,3*ELGP)
            WRITE(BUG,*)
         ENDDO
         WRITE(BUG,*)

      ENDIF

      IF ((WRT_BUG_THIS_TIME == 'Y') .AND. (WRT_BUG(9) > 0)) THEN
        IF (DEBUG(202) > 0) THEN
         JJ = 0                                            ! Calculate ID array
         DO I=1,ELGP
            II = 6*(I - 1)
            DO J=1,3
               II = II + 1
               JJ = JJ + 1
               ID(JJ) = II                                 ! Want JJ to range 1 to 3*ELGP and II to range 1 to 45 in increments of 3
            ENDDO
         ENDDO

         WRITE(BUG,1101) ELDT_BUG_BCHK_BIT, TYPE, EID
         WRITE(BUG,9100)
         WRITE(BUG,9101) MESSAG, IGAUS, JGAUS, KGAUS
         WRITE(BUG,9102)
         WRITE(BUG,9103)
         WRITE(BUG,9104)
         CALL BCHECK_3D ( BMAT, ELGP, ID, NR, 3*ELGP, BW )
        ENDIF
      ENDIF

! **********************************************************************************************************************************
      IF (WRT_LOG >= SUBR_BEGEND) THEN
         CALL OURTIM
         WRITE(F04,9002) SUBR_NAME,TSEC
 9002    FORMAT(1X,A,' END  ',F10.3)
      ENDIF

      RETURN

! **********************************************************************************************************************************
 1101 FORMAT(' ------------------------------------------------------------------------------------------------------------------',&
             '-----------------',/,                                                                                &
             ' ELDATA(',I2,',PRINT) requests for ',A,' element number ',I8, ' (from subr ', A, ')'/,                               &
             ' ==============================================================',/)

 8901 FORMAT(' Strain-displacement matrix B for Gauss point: I = ',I3,', J = ',I3,', K = ',I3,' for element in subr ',A,/)

 8902 FORMAT(' Row ',I2,/,6(1ES14.6))

 9100 FORMAT(47X,'   Check on strain-displacement matrix B for the element in subr BCHECK,',/)

 9101 FORMAT(47X,'                               S T R A I N S'/,                       &
             47X,'        (',A,' for Gauss point: I = ',I3,', J = ',I3,', K = ',I3,')')

 9102 FORMAT(47X,' Exx           Eyy           Ezz           Gxy           Gyz           Gzx      Note:')

 9103 FORMAT(1X,'      Element displacements consistent with:')

 9104 FORMAT(1X,'      ---------------------------------------')

! **********************************************************************************************************************************

      END SUBROUTINE B3D_ISOPARAMETRIC


    program demo_M_overload

     use, intrinsic :: iso_fortran_env, only : &
             & integer_kinds, int8, int16, int32, int64
     use, intrinsic :: iso_fortran_env, only : &
             & real32, real64, real128

     ! allow strings to be converted to integers
     use M_overload, only : int
     ! allow strings to be converted to floating point
     use M_overload, only : real,dble
     ! use == like .eqv.
     use M_overload, only : operator(==)
     ! use /= like .neqv.
     use M_overload, only : operator(/=)
     use M_overload, only : operator(//)
     ! take a single argument
     use M_overload, only : sign
     ! allow strings of different length on merge
     use M_overload, only : merge
     implicit none
     character(len=:),allocatable :: cmd
     character(len=*), parameter :: gen='(*("[",g0,"]":,","))'

       write(*,gen)merge('a','bbbbb',1.eq.1)
       write(*,gen)merge('a','bbbbb',1.eq.2)
       write(*,gen)merge(['a','b'],['bbbbb','ccccc'],1.eq.2)

       if(int('1234')               .eq.1234) &
        & write(*,*)'int("STRING") works '
       if(abs(real('1234.56789') - 1234.56789).lt.2*epsilon(0.0)) &
        & write(*,*)'real("STRING") works '
       if(abs(dble('1234.5678901234567')- 1234.5678901234567d0).lt.epsilon(0.0d0)) &
        & write(*,*)'dble("STRING") works '

       write(*,*) merge('int works for .FALSE.','int fails for .FALSE.',int(.FALSE.).ne.0)
       write(*,*) merge('int works for .TRUE.','int fails for .TRUE.',int(.TRUE.).eq.0)

       if (.true. == .true. ) &
       & write(*,*)'== works like .eqv. for LOGICAL values'
       if (.true. /= .false. ) &
       & write(*,*)'/= works like .neqv. for LOGICAL values'

       write(*,*)' The value is '//10//' which is less than '//20.2

       write(*,*) merge('sign works','sign fails',&
        & sign(10_int8).eq.1 &
        & .and. sign(-10_int8).eq.-1 )
       write(*,*) merge('sign works','sign fails',&
        & sign(10_int16).eq.1 &
        & .and. sign(-10_int16).eq.-1 )
       write(*,*) merge('sign works','sign fails',&
        & sign(10_int32).eq.1 &
        & .and. sign(-10_int32).eq.-1 )
       write(*,*) merge('sign works','sign fails',&
        & sign(10_int64).eq.1 &
        & .and. sign(-10_int64).eq.-1 )
       write(*,*) merge('sign works','sign fails',&
        & sign(10.0_real32).eq.1.0 &
        & .and. sign(-10.0_real32).eq.-1.0 )
       write(*,*) merge('sign works','sign fails',&
        & sign(10.0_real64).eq.1.0 &
        & .and. sign(-10.0_real64).eq.-1.0 )
       write(*,*) merge('sign works','sign fails',&
        & sign(10.0_real128).eq.1.0&
        & .and. sign(-10.0_real128).eq.-1.0 )
  contains

    end program demo_M_overload


*> \brief \b ILASLC scans a matrix for its last non-zero column.
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ILASLC + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       INTEGER FUNCTION ILASLC( M, N, A, LDA )
*
*       .. Scalar Arguments ..
*       INTEGER            M, N, LDA
*       ..
*       .. Array Arguments ..
*       REAL               A( LDA, * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> ILASLC scans A for its last non-zero column.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] M
*> \verbatim
*>          M is INTEGER
*>          The number of rows of the matrix A.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The number of columns of the matrix A.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*>          A is REAL array, dimension (LDA,N)
*>          The m by n matrix A.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>          The leading dimension of the array A. LDA >= max(1,M).
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup realOTHERauxiliary
*
*  =====================================================================
      INTEGER FUNCTION ILASLC( M, N, A, LDA )
*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      INTEGER            M, N, LDA
*     ..
*     .. Array Arguments ..
      REAL               A( LDA, * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL             ZERO
      PARAMETER ( ZERO = 0.0E+0 )
*     ..
*     .. Local Scalars ..
      INTEGER I
*     ..
*     .. Executable Statements ..
*
*     Quick test for the common case where one corner is non-zero.
      IF( N.EQ.0 ) THEN
         ILASLC = N
      ELSE IF( A(1, N).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN
         ILASLC = N
      ELSE
*     Now scan each column from the end, returning with the first non-zero.
         DO ILASLC = N, 1, -1
            DO I = 1, M
               IF( A(I, ILASLC).NE.ZERO ) RETURN
            END DO
         END DO
      END IF
      RETURN
      END

*> \brief \b ILASLR scans a matrix for its last non-zero row.
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ILASLR + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       INTEGER FUNCTION ILASLR( M, N, A, LDA )
*
*       .. Scalar Arguments ..
*       INTEGER            M, N, LDA
*       ..
*       .. Array Arguments ..
*       REAL               A( LDA, * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> ILASLR scans A for its last non-zero row.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] M
*> \verbatim
*>          M is INTEGER
*>          The number of rows of the matrix A.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The number of columns of the matrix A.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*>          A is REAL array, dimension (LDA,N)
*>          The m by n matrix A.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>          The leading dimension of the array A. LDA >= max(1,M).
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup realOTHERauxiliary
*
*  =====================================================================
      INTEGER FUNCTION ILASLR( M, N, A, LDA )
*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      INTEGER            M, N, LDA
*     ..
*     .. Array Arguments ..
      REAL               A( LDA, * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL             ZERO
      PARAMETER ( ZERO = 0.0E+0 )
*     ..
*     .. Local Scalars ..
      INTEGER I, J
*     ..
*     .. Executable Statements ..
*
*     Quick test for the common case where one corner is non-zero.
      IF( M.EQ.0 ) THEN
         ILASLR = M
      ELSEIF( A(M, 1).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN
         ILASLR = M
      ELSE
*     Scan up each column tracking the last zero row seen.
         ILASLR = 0
         DO J = 1, N
            I=M
            DO WHILE((A(MAX(I,1),J).EQ.ZERO).AND.(I.GE.1))
               I=I-1
            ENDDO
            ILASLR = MAX( ILASLR, I )
         END DO
      END IF
      RETURN
      END

*> \brief \b ILAENV2STAGE
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ILAENV2STAGE + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       INTEGER FUNCTION ILAENV2STAGE( ISPEC, NAME, OPTS, N1, N2, N3, N4 )
*
*       .. Scalar Arguments ..
*       CHARACTER*( * )    NAME, OPTS
*       INTEGER            ISPEC, N1, N2, N3, N4
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> ILAENV2STAGE is called from the LAPACK routines to choose problem-dependent
*> parameters for the local environment.  See ISPEC for a description of
*> the parameters.
*> It sets problem and machine dependent parameters useful for *_2STAGE and
*> related subroutines.
*>
*> ILAENV2STAGE returns an INTEGER
*> if ILAENV2STAGE >= 0: ILAENV2STAGE returns the value of the parameter
*>                       specified by ISPEC
*> if ILAENV2STAGE < 0:  if ILAENV2STAGE = -k, the k-th argument had an
*>                       illegal value.
*>
*> This version provides a set of parameters which should give good,
*> but not optimal, performance on many of the currently available
*> computers for the 2-stage solvers. Users are encouraged to modify this
*> subroutine to set the tuning parameters for their particular machine using
*> the option and problem size information in the arguments.
*>
*> This routine will not function correctly if it is converted to all
*> lower case.  Converting it to all upper case is allowed.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] ISPEC
*> \verbatim
*>          ISPEC is INTEGER
*>          Specifies the parameter to be returned as the value of
*>          ILAENV2STAGE.
*>          = 1: the optimal blocksize nb for the reduction to BAND
*>
*>          = 2: the optimal blocksize ib for the eigenvectors
*>               singular vectors update routine
*>
*>          = 3: The length of the array that store the Housholder
*>               representation for the second stage
*>               Band to Tridiagonal or Bidiagonal
*>
*>          = 4: The workspace needed for the routine in input.
*>
*>          = 5: For future release.
*> \endverbatim
*>
*> \param[in] NAME
*> \verbatim
*>          NAME is CHARACTER*(*)
*>          The name of the calling subroutine, in either upper case or
*>          lower case.
*> \endverbatim
*>
*> \param[in] OPTS
*> \verbatim
*>          OPTS is CHARACTER*(*)
*>          The character options to the subroutine NAME, concatenated
*>          into a single character string.  For example, UPLO = 'U',
*>          TRANS = 'T', and DIAG = 'N' for a triangular routine would
*>          be specified as OPTS = 'UTN'.
*> \endverbatim
*>
*> \param[in] N1
*> \verbatim
*>          N1 is INTEGER
*> \endverbatim
*>
*> \param[in] N2
*> \verbatim
*>          N2 is INTEGER
*> \endverbatim
*>
*> \param[in] N3
*> \verbatim
*>          N3 is INTEGER
*> \endverbatim
*>
*> \param[in] N4
*> \verbatim
*>          N4 is INTEGER
*>          Problem dimensions for the subroutine NAME; these may not all
*>          be required.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*> \author Nick R. Papior
*
*> \ingroup OTHERauxiliary
*
*> \par Further Details:
*  =====================
*>
*> \verbatim
*>
*>  The following conventions have been used when calling ILAENV2STAGE
*> from the LAPACK routines:
*>  1)  OPTS is a concatenation of all of the character options to
*>      subroutine NAME, in the same order that they appear in the
*>      argument list for NAME, even if they are not used in determining
*>      the value of the parameter specified by ISPEC.
*>  2)  The problem dimensions N1, N2, N3, N4 are specified in the order
*>      that they appear in the argument list for NAME.  N1 is used
*>      first, N2 second, and so on, and unused problem dimensions are
*>      passed a value of -1.
*>  3)  The parameter value returned by ILAENV2STAGE is checked for validity in
*>      the calling subroutine.
*>
*> \endverbatim
*>
*  =====================================================================
      INTEGER FUNCTION ILAENV2STAGE( ISPEC, NAME, OPTS, N1, N2, N3, N4 )
*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     July 2017
*
*     .. Scalar Arguments ..
      CHARACTER*( * )    NAME, OPTS
      INTEGER            ISPEC, N1, N2, N3, N4
*     ..
*
*  =====================================================================
*     ..
*     .. Local Scalars ..
      INTEGER            IISPEC
*     ..
*     .. External Functions ..
      INTEGER            IPARAM2STAGE
      EXTERNAL           IPARAM2STAGE
*     ..
*     .. Executable Statements ..
*
      GO TO ( 10, 10, 10, 10, 10 )ISPEC
*
*     Invalid value for ISPEC
*
      ILAENV2STAGE = -1
      RETURN
*
   10 CONTINUE
*
*     2stage eigenvalues and SVD or related subroutines.
*
      IISPEC = 16 + ISPEC
      ILAENV2STAGE = IPARAM2STAGE( IISPEC, NAME, OPTS,
     $                             N1, N2, N3, N4 )
      RETURN
*
*     End of ILAENV2STAGE
*
      END


! -----------------------------------------------------------------
! Programmer(s): Cody J. Balos @ LLNL
! -----------------------------------------------------------------
! SUNDIALS Copyright Start
! Copyright (c) 2002-2020, Lawrence Livermore National Security
! and Southern Methodist University.
! All rights reserved.
!
! See the top-level LICENSE and NOTICE files for details.
!
! SPDX-License-Identifier: BSD-3-Clause
! SUNDIALS Copyright End
! -----------------------------------------------------------------
! This file tests the Fortran 2003 interface to the SUNDIALS
! SPFGMR SUNLinearSolver implementation. We run three tests to
! exercise the solver:
!   1. simple tridiagonal system (no preconditioning)
!   2. simple tridiagonal system (jacobi preconditioning)
!   3. tridiagonal system w/ scale vector s1 (no preconditioning)
! -----------------------------------------------------------------

module test_fsunlinsol_spfgmr_serial
  use, intrinsic :: iso_c_binding
  use fsundials_nvector_mod
  implicit none

  integer(C_LONG), private, parameter :: N = 100
  integer(C_INT),  private, parameter :: pretype = 1     ! Preconditioning type (1 or 2)
  integer(C_INT),  private, parameter :: gstype  = 1     ! Gram-Schmidt orthoognalization type (1 or 2)
  integer(C_INT),  private, parameter :: maxl    = 100   ! maxium Krylov subspace dimension (> 0)
  real(C_DOUBLE),  private, parameter :: tol     = 1e-13 ! solver tolerance

  type, private :: UserData
    integer(C_LONG) :: N
    type(N_Vector), pointer  :: d, s1, s2
  end type

contains

  integer(C_INT) function unit_tests() result(fails)
    use, intrinsic :: iso_c_binding
    use fsundials_nvector_mod
    use fsundials_matrix_mod
    use fsundials_linearsolver_mod
    use fnvector_serial_mod
    use fsunlinsol_spfgmr_mod
    use test_sunlinsol

    implicit none

    type(SUNLinearSolver), pointer :: LS         ! test linear solver
    type(SUNMatrix),       pointer :: A          ! dummy SUNMatrix
    type(N_Vector),        pointer :: x, xhat, b ! test vectors
    type(UserData),        pointer :: probdata   ! problem data
    real(C_DOUBLE),        pointer :: xdata(:)   ! x vector data
    real(C_DOUBLE)                 :: tmpr       ! temporary real value
    integer(C_LONG)                :: j
    integer(C_INT)                 :: tmp

    ! setup
    fails = 0

    A => null()

    x    => FN_VNew_Serial(N)
    xhat => FN_VNew_Serial(N)
    b    => FN_VNew_Serial(N)

    allocate(probdata)
    probdata%N  = N
    probdata%d  => FN_VNew_Serial(N)
    probdata%s1 => FN_VNew_Serial(N)
    probdata%s2 => FN_VNew_Serial(N)

    ! fill xhat vector with uniform random data in [1, 2)
    xdata => FN_VGetArrayPointer(xhat)
    do j=1, N
      call random_number(tmpr)
      xdata(j) = ONE + tmpr
    end do

    ! fill Jacobi vector with matrix diagonal
    call FN_VConst(FIVE, probdata%d)

    ! create SPFGMR linear solver
    LS => FSUNLinSol_SPFGMR(x, pretype, maxl)

    ! run initialization tests
    fails = fails + Test_FSUNLinSolGetType(LS, SUNLINEARSOLVER_ITERATIVE, 0)
    fails = fails + Test_FSUNLinSolSetATimes(LS, c_loc(probdata),&
                                             c_funloc(ATimes), 0)
    fails = fails + Test_FSUNLinSolSetPreconditioner(LS,&
                                                     c_loc(probdata),&
                                                     c_funloc(PSetup),&
                                                     c_funloc(PSolve),&
                                                     0)
    fails = fails + Test_FSUNLinSolSetScalingVectors(LS, probdata%s1,&
                                                     probdata%s2, 0)
    fails = fails + Test_FSUNLinSolInitialize(LS, 0)
    fails = fails + Test_FSUNLinSolSpace(LS, 0)
    fails = fails + FSUNLinSol_SPFGMRSetGSType(LS, gstype)

    if (fails /= 0) then
      print *, 'FAIL: FSUNLinSol_SPFGMR module, initialization'
    else
      print *, 'SUCCESS: FSUNLinSol_SPFGMR module, initialization tests passed'
      print *, ''
    end if

    ! Test 1: simple Poisson-like solve (no preconditioning)

    ! set scaling vectors
    call FN_VConst(ONE, probdata%s1)
    call FN_VConst(ONE, probdata%s2)

    ! fill x vector with scaled version
    call FN_VDiv(xhat, probdata%s2, x)

    ! fill b vector with result of matrix-vector product
    fails = fails + ATimes(c_loc(probdata), x, b)

    ! Run tests with this setup
    fails = fails + FSUNLinSol_SPFGMRSetPrecType(LS, PREC_NONE);
    fails = fails + Test_FSUNLinSolSetup(LS, A, 0);
    fails = fails + Test_FSUNLinSolSolve(LS, A, x, b, tol, 0);
    fails = fails + Test_FSUNLinSolLastFlag(LS, 0);
    fails = fails + Test_FSUNLinSolNumIters(LS, 0);
    fails = fails + Test_FSUNLinSolResNorm(LS, 0);
    fails = fails + Test_FSUNLinSolResid(LS, 0);

    if (fails /= 0) then
      print *, 'FAIL: FSUNLinSol_SPFGMR module, problem 1'
    else
      print *, 'SUCCESS: FSUNLinSol_SPFGMR module, problem 1, all tests passed'
      print *, ''
    end if

    ! Test 2: simple Poisson-like solve (Jacobi preconditioning)

    ! set scaling vectors
    call FN_VConst(ONE, probdata%s1)
    call FN_VConst(ONE, probdata%s2)

    ! fill x vector with scaled version
    call FN_VDiv(xhat, probdata%s2, x)

    ! fill b vector with result of matrix-vector product
    fails = fails + ATimes(c_loc(probdata), x, b)

    ! Run tests with this setup
    fails = fails + FSUNLinSol_SPFGMRSetPrecType(LS, pretype);
    fails = fails + Test_FSUNLinSolSetup(LS, A, 0);
    fails = fails + Test_FSUNLinSolSolve(LS, A, x, b, tol, 0);
    fails = fails + Test_FSUNLinSolLastFlag(LS, 0);
    fails = fails + Test_FSUNLinSolNumIters(LS, 0);
    fails = fails + Test_FSUNLinSolResNorm(LS, 0);
    fails = fails + Test_FSUNLinSolResid(LS, 0);

    if (fails /= 0) then
      print *, 'FAIL: FSUNLinSol_SPFGMR module, problem 2'
    else
      print *, 'SUCCESS: FSUNLinSol_SPFGMR module, problem 2, all tests passed'
      print *, ''
    end if

    ! Test 3: Poisson-like solve w/ scaled rows (no preconditioning)

    ! set scaling vectors
    xdata => FN_VGetArrayPointer(probdata%s1)
    do j=1, N
      call random_number(tmpr)
      xdata(j) = ONE + 1000.0d0*tmpr
    end do
    call FN_VConst(ONE, probdata%s2)

    ! fill x vector with scaled version
    call FN_VDiv(xhat, probdata%s2, x)

    ! fill b vector with result of matrix-vector product
    fails = fails + ATimes(c_loc(probdata), x, b)

    ! Run tests with this setup
    fails = fails + FSUNLinSol_SPFGMRSetPrecType(LS, PREC_NONE);
    fails = fails + Test_FSUNLinSolSetup(LS, A, 0);
    fails = fails + Test_FSUNLinSolSolve(LS, A, x, b, tol, 0);
    fails = fails + Test_FSUNLinSolLastFlag(LS, 0);
    fails = fails + Test_FSUNLinSolNumIters(LS, 0);
    fails = fails + Test_FSUNLinSolResNorm(LS, 0);
    fails = fails + Test_FSUNLinSolResid(LS, 0);

    if (fails /= 0) then
      print *, 'FAIL: FSUNLinSol_SPFGMR module, problem 3'
    else
      print *, 'SUCCESS: FSUNLinSol_SPFGMR module, problem 3, all tests passed'
      print *, ''
    end if

    ! cleanup
    tmp = FSUNLinSolFree(LS)
    call FN_VDestroy(x)
    call FN_VDestroy(xhat)
    call FN_VDestroy(b)
    call FN_VDestroy(probdata%d)
    call FN_VDestroy(probdata%s1)
    call FN_VDestroy(probdata%s2)

  end function unit_tests

  integer(C_INT) function ATimes(udata, vvec, zvec) result(ret) bind(C)
    use, intrinsic :: iso_c_binding
    use fsundials_nvector_mod
    use test_utilities

    implicit none

    type(C_PTR), value :: udata
    type(N_Vector) :: vvec, zvec
    type(UserData), pointer :: probdata
    real(C_DOUBLE), pointer :: v(:), z(:), s1(:), s2(:)
    integer(C_LONG) :: i, N

    call c_f_pointer(udata, probdata)

    v  => FN_VGetArrayPointer(vvec)
    z  => FN_VGetArrayPointer(zvec)
    s1 => FN_VGetArrayPointer(probdata%s1)
    s2 => FN_VGetArrayPointer(probdata%s2)
    N  = probdata%N

    ! perform product at the left domain boundary (note: v is zero at the boundary)
    z(1) = (FIVE*v(1)*s2(1) - v(2)*s2(2))/s1(1)

    ! iterate through interior of local domain, performing product
    do i = 2, N-1
      z(i) = (-v(i-1)*s2(i-1) + FIVE*v(i)*s2(i) - v(i+1)*s2(i+1))/s1(i)
    end do

    ! perform product at the right domain boundary (note: v is zero at the boundary)
    z(N) = (-v(N-1)*s2(N-1) + FIVE*v(N)*s2(N))/s1(N)

    ret = 0
  end function ATimes

  integer(C_INT) function PSetup(udata) result(ret) bind(C)
    use, intrinsic :: iso_c_binding
    type(C_PTR), value :: udata
    ret = 0
  end function PSetup

  integer(C_INT) function PSolve(udata, rvec, zvec, tol, lr) &
      result(ret) bind(C)
    use, intrinsic :: iso_c_binding
    use fsundials_nvector_mod
    use test_utilities

    implicit none

    type(C_PTR),    value   :: udata
    type(N_Vector)          :: rvec, zvec
    real(C_DOUBLE)          :: tol
    integer(C_INT)          :: lr
    type(UserData), pointer :: probdata
    real(C_DOUBLE), pointer :: r(:), z(:), d(:)
    integer(C_LONG)         :: i, N

    call c_f_pointer(udata, probdata)

    r => FN_VGetArrayPointer(rvec)
    z => FN_VGetArrayPointer(zvec)
    d => FN_VGetArrayPointer(probdata%d)
    N = probdata%N

    do i=1, N
      z(i) = r(i) / d(i)
    end do

    ret = 0
  end function PSolve

end module

integer(C_INT) function check_vector(X, Y, tol) result(failure)
  use, intrinsic :: iso_c_binding
  use test_fsunlinsol_spfgmr_serial
  use test_utilities

  implicit none
  type(N_Vector)  :: x, y
  real(C_DOUBLE)  :: tol, maxerr
  integer(C_LONG) :: i, xlen, ylen
  real(C_DOUBLE), pointer :: xdata(:), ydata(:)

  failure = 0

  xdata => FN_VGetArrayPointer(x)
  ydata => FN_VGetArrayPointer(y)

  xlen = FN_VGetLength(x)
  ylen = FN_VGetLength(y)

  if (xlen /= ylen) then
    print *, 'FAIL: check_vector: different data array lengths'
    failure = 1
    return
  end if

  do i = 1, xlen
    failure = failure + FNEQTOL(xdata(i), ydata(i), FIVE*tol*abs(xdata(i)))
  end do

  if (failure > 0) then
    maxerr = ZERO
    do i = 1, xlen
      maxerr = max(abs(xdata(i)-ydata(i))/abs(xdata(i)), maxerr)
    end do
    write(*,'(A,E14.7,A,E14.7,A)') &
      "FAIL: check_vector failure: maxerr = ", maxerr, "  (tol = ", FIVE*tol, ")"
  end if

end function check_vector

program main
  !======== Inclusions ==========
  use, intrinsic :: iso_c_binding
  use test_fsunlinsol_spfgmr_serial

  !======== Declarations ========
  implicit none
  integer(C_INT) :: fails = 0

  !============== Introduction =============
  print *, 'SPFGMR SUNLinearSolver Fortran 2003 interface test'
  print *, ''

  fails = unit_tests()
  if (fails /= 0) then
    print *, 'FAILURE: n unit tests failed'
    stop 1
  else
    print *,'SUCCESS: all unit tests passed'
  end if
end program main


! Test that IOLENGTH works for dynamic arrays
program iolength_1
  implicit none
  ! 32 bit, i.e. 4 byte integer (every gcc architecture should have this?)
  integer, parameter :: int32 = selected_int_kind(9)
  integer(int32), allocatable :: a(:)
  integer :: iol, alength
  real :: r
  call random_number(r)
  alength = nint(r*20)
  allocate(a(alength))
  inquire (iolength = iol) a
  if ( 4*alength /= iol) then
     call abort
  end if
end program iolength_1


c     comment section
c
c     fm045
c
c         this routine tests arithmetic assignments using integer
c     variables connected by a series of arithmetic operators.
c     different combinations of parenthetical notation are exercized.
c
c
c      references
c        american national standard programming language fortran,
c              x3.9-1978
c
c        section 4.3, integer type
c        section 4.3.1, integer constant
c        section 6.1, arithmetic expressions
c        section 6.6, evaluation of expressions
c        section 10.1, arithmetic assignment statement
c
c
c
c      **********************************************************
c
c         a compiler validation system for the fortran language
c     based on specifications as defined in american national standard
c     programming language fortran x3.9-1978, has been developed by the
c     federal cobol compiler testing service.  the fortran compiler
c     validation system (fcvs) consists of audit routines, their related
c     data, and an executive system.  each audit routine is a fortran
c     program, subprogram or function which includes tests of specific
c     language elements and supporting procedures indicating the result
c     of executing these tests.
c
c         this particular program/subprogram/function contains features
c     found only in the subset as defined in x3.9-1978.
c
c         suggestions and comments should be forwarded to -
c
c                  department of the navy
c                  federal cobol compiler testing service
c                  washington, d.c.  20376
c
c      **********************************************************
c
c
c
c     initialization section
c
c     initialize constants
c      **************
c     i01 contains the logical unit number for the card reader.
      i01 = 5
c     i02 contains the logical unit number for the printer.
      i02 = 6
c     system environment section
c
cx010    this card is replaced by contents of fexec x-010 control card.
c     the cx010 card is for overriding the program default i01 = 5
c     (unit number for card reader).
cx011    this card is replaced by contents of fexec x-011 control card.
c     the cx011 card is for systems which require additional
c     fortran statements for files associated with cx010 above.
c
cx020    this card is replaced by contents of fexec x-020 control card.
c     the cx020 card is for overriding the program default i02 = 6
c     (unit number for printer).
cx021    this card is replaced by contents of fexec x-021 control card.
c     the cx021 card is for systems which require additional
c     fortran statements for files associated with cx020 above.
c
      ivpass=0
      ivfail=0
      ivdele=0
      iczero=0
c
c     write page headers
      write (i02,90000)
      write (i02,90001)
      write (i02,90002)
      write (i02, 90002)
      write (i02,90003)
      write (i02,90002)
      write (i02,90004)
      write (i02,90002)
      write (i02,90011)
      write (i02,90002)
      write (i02,90002)
      write (i02,90005)
      write (i02,90006)
      write (i02,90002)
c
c
c     test section
c
c         arithmetic assignment statement
c
c
c     tests 747 through 755 use the same string of variables and
c     operators, but use different combinations of parenthetical
c     notation  to alter priorities in order of evaluation.
c
c     tests 756 through 759 check the capability to enclose the entire
c     right hand side of an assignment statement in parentheses or sets
c     of nested parentheses.
c
c
c
c
c
c
c
      ivtnum = 747
c
c      ****  test 747  ****
c
      if (iczero) 37470, 7470, 37470
 7470 continue
      ivon01 = 15
      ivon02 =  9
      ivon03 =  4
      ivon04 = 18
      ivon05 =  6
      ivon06 =  2
      ivcomp = ivon01 + ivon02 - ivon03 * ivon04 / ivon05 ** ivon06
      go to 47470
37470 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 47470, 7481, 47470
47470 if (ivcomp - 22) 27470,17470,27470
17470 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 7481
27470 ivfail = ivfail + 1
      ivcorr = 22
      write (i02,80004) ivtnum, ivcomp, ivcorr
 7481 continue
      ivtnum = 748
c
c      ****  test 748  ****
c
      if (iczero) 37480, 7480, 37480
 7480 continue
      ivon01 = 15
      ivon02 =  9
      ivon03 =  4
      ivon04 = 18
      ivon05 =  6
      ivon06 =  2
      ivcomp = ((((ivon01 + ivon02) - ivon03) * ivon04) / ivon05)
     *         ** ivon06
      go to 47480
37480 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 47480, 7491, 47480
47480 if (ivcomp - 3600) 27480,17480,27480
17480 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 7491
27480 ivfail = ivfail + 1
      ivcorr = 3600
      write (i02,80004) ivtnum, ivcomp, ivcorr
 7491 continue
      ivtnum = 749
c
c      ****  test 749  ****
c
      if (iczero) 37490, 7490, 37490
 7490 continue
      ivon01 = 15
      ivon02 =  9
      ivon03 =  4
      ivon04 = 36
      ivon05 =  6
      ivon06 =  2
      ivcomp = (ivon01 + ivon02 - ivon03) * (ivon04 / ivon05 ** ivon06)
      go to 47490
37490 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 47490, 7501, 47490
47490 if (ivcomp - 20) 27490,17490,27490
17490 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 7501
27490 ivfail = ivfail + 1
      ivcorr = 20
      write (i02,80004) ivtnum, ivcomp, ivcorr
 7501 continue
      ivtnum = 750
c
c      ****  test 750  ****
c
      if (iczero) 37500, 7500, 37500
 7500 continue
      ivon01 = 15
      ivon02 =  9
      ivon03 =  4
      ivon04 = 36
      ivon05 =  6
      ivon06 =  2
      ivcomp = (ivon01 + ivon02) - (ivon03 * ivon04) / (ivon05 **
     *         ivon06)
      go to 47500
37500 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 47500, 7511, 47500
47500 if (ivcomp - 20) 27500,17500,27500
17500 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 7511
27500 ivfail = ivfail + 1
      ivcorr = 20
      write (i02,80004) ivtnum, ivcomp, ivcorr
 7511 continue
      ivtnum = 751
c
c      ****  test 751  ****
c
      if (iczero) 37510, 7510, 37510
 7510 continue
      ivon01 = 15
      ivon02 =  9
      ivon03 =  4
      ivon04 = 36
      ivon05 =  6
      ivon06 =  2
      ivcomp = ((ivon01 + ivon02) - (ivon03 * ivon04)) / (ivon05 **
     *         ivon06)
      go to 47510
37510 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero)  47510, 7521, 47510
47510 if (ivcomp + 3)  27510,17510,27510
17510 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 7521
27510 ivfail = ivfail + 1
      ivcorr = -3
c     actual answer is  -3.333333...     truncation is necessary
      write (i02,80004) ivtnum, ivcomp, ivcorr
 7521 continue
      ivtnum = 752
c
c      ****  test 752  ****
c
      if (iczero) 37520, 7520, 37520
 7520 continue
      ivon01 = 15
      ivon02 =  9
      ivon03 =  4
      ivon04 = 36
      ivon05 =  6
      ivon06 =  2
      ivcomp = (ivon01 + ivon02) - (ivon03 * ivon04 / ivon05) ** ivon06
      go to 47520
37520 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 47520, 7531, 47520
47520 if (ivcomp + 552) 27520,17520,27520
17520 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 7531
27520 ivfail = ivfail + 1
      ivcorr = -552
      write (i02,80004) ivtnum, ivcomp, ivcorr
 7531 continue
      ivtnum = 753
c
c      ****  test 753  ****
c
      if (iczero) 37530, 7530, 37530
 7530 continue
      ivon01 = 15
      ivon02 =  9
      ivon03 =  4
      ivon04 = 36
      ivon05 =  6
      ivon06 =  2
      ivcomp = ivon01 + (ivon02 - ivon03 * ivon04) / ivon05 ** ivon06
      go to 47530
37530 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 47530, 7541, 47530
47530 if (ivcomp - 12) 27530,17530,27530
17530 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 7541
27530 ivfail = ivfail + 1
      ivcorr = 12
c     actual answer is  11.25            truncation is necessary
c                                        during an intermediate step
      write (i02,80004) ivtnum, ivcomp, ivcorr
 7541 continue
      ivtnum = 754
c
c      ****  test 754  ****
c
      if (iczero) 37540, 7540, 37540
 7540 continue
      ivon01 = 15
      ivon02 =  9
      ivon03 =  4
      ivon04 = 36
      ivon05 =  6
      ivon06 =  2
      ivcomp = ivon01 + (ivon02 - ivon03) * (ivon04 / ivon05) ** ivon06
      go to 47540
37540 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 47540, 7551, 47540
47540 if (ivcomp - 195) 27540,17540,27540
17540 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 7551
27540 ivfail = ivfail + 1
      ivcorr = 195
      write (i02,80004) ivtnum, ivcomp, ivcorr
 7551 continue
      ivtnum = 755
c
c      ****  test 755  ****
c
      if (iczero) 37550, 7550, 37550
 7550 continue
      ivon01 = 15
      ivon02 =  9
      ivon03 =  4
      ivon04 = 36
      ivon05 =  6
      ivon06 =  2
      ivcomp = ((ivon01 + (ivon02 - ivon03) * ivon04) / ivon05) **
     *         ivon06
      go to 47550
37550 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 47550, 7561, 47550
47550 if (ivcomp - 1024)  27550,17550,27550
17550 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 7561
27550 ivfail = ivfail + 1
      ivcorr = 1024
c     actual answer is  1056.25         truncation is necessary
c                                       during an intermediate step
      write (i02,80004) ivtnum, ivcomp, ivcorr
 7561 continue
      ivtnum = 756
c
c      ****  test 756  ****
c          single parentheses
c
      if (iczero) 37560, 7560, 37560
 7560 continue
      ivon01 = 13
      ivon02 = 37
      ivcomp = (ivon01 + ivon02)
      go to 47560
37560 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 47560, 7571, 47560
47560 if (ivcomp - 50) 27560,17560,27560
17560 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 7571
27560 ivfail = ivfail + 1
      ivcorr = 50
      write (i02,80004) ivtnum, ivcomp, ivcorr
 7571 continue
      ivtnum = 757
c
c      ****  test 757  ****
c          nested parentheses (two sets)
c
      if (iczero) 37570, 7570, 37570
 7570 continue
      ivon01 = 13
      ivon02 = 37
      ivcomp = ((ivon01 - ivon02))
      go to 47570
37570 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 47570, 7581, 47570
47570 if (ivcomp + 24) 27570,17570,27570
17570 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 7581
27570 ivfail = ivfail + 1
      ivcorr = -24
      write (i02,80004) ivtnum, ivcomp, ivcorr
 7581 continue
      ivtnum = 758
c
c      ****  test 758  ****
c          nested parentheses (21 sets - same line)
c
      if (iczero) 37580, 7580, 37580
 7580 continue
      ivon01 = 13
      ivon02 = 37
      ivcomp = (((((((((((((((((((((ivon01 * ivon02)))))))))))))))))))))
      go to 47580
37580 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 47580, 7591, 47580
47580 if (ivcomp - 481) 27580,17580,27580
17580 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 7591
27580 ivfail = ivfail + 1
      ivcorr = 481
      write (i02,80004) ivtnum, ivcomp, ivcorr
 7591 continue
      ivtnum = 759
c
c      ****  test 759  ****
c          nested parentheses (57 sets - multiple lines)
c
      if (iczero) 37590, 7590, 37590
 7590 continue
      ivon01 = 13
      ivon02 = 37
      ivcomp = (((((((((((((((((((((((((((((((((((((((((((((((((((((((((
     *         ivon01 / ivon02
     *         )))))))))))))))))))))))))))))))))))))))))))))))))))))))))
      go to 47590
37590 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 47590, 7601, 47590
47590 if (ivcomp) 27590,17590,27590
17590 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 7601
27590 ivfail = ivfail + 1
      ivcorr = 0
      write (i02,80004) ivtnum, ivcomp, ivcorr
 7601 continue
c
c     write page footings and run summaries
99999 continue
      write (i02,90002)
      write (i02,90006)
      write (i02,90002)
      write (i02,90002)
      write (i02,90007)
      write (i02,90002)
      write (i02,90008)  ivfail
      write (i02,90009) ivpass
      write (i02,90010) ivdele
c
c
c     terminate routine execution
      stop
c
c     format statements for page headers
90000 format (1h1)
90002 format (1h )
90001 format (1h ,10x,34hfortran compiler validation system)
90003 format (1h ,21x,11hversion 1.0)
90004 format (1h ,10x,38hfor official use only - copyright 1978)
90005 format (1h ,5x,4htest,5x,9hpass/fail, 5x,8hcomputed,8x,7hcorrect)
90006 format (1h ,5x,46h----------------------------------------------)
90011 format (1h ,18x,17hsubset level test)
c
c     format statements for run summaries
90008 format (1h ,15x,i5,19h errors encountered)
90009 format (1h ,15x,i5,13h tests passed)
90010 format (1h ,15x,i5,14h tests deleted)
c
c     format statements for test results
80001 format (1h ,4x,i5,7x,4hpass)
80002 format (1h ,4x,i5,7x,4hfail)
80003 format (1h ,4x,i5,7x,7hdeleted)
80004 format (1h ,4x,i5,7x,4hfail,10x,i6,9x,i6)
80005 format (1h ,4x,i5,7x,4hfail,4x,e12.5,3x,e12.5)
c
90007 format (1h ,20x,20hend of program fm045)
      end