      SUBROUTINE MB04AD( JOB, COMPQ1, COMPQ2, COMPU1, COMPU2, N, Z, LDZ,
     $                   H, LDH, Q1, LDQ1, Q2, LDQ2, U11, LDU11, U12,
     $                   LDU12, U21, LDU21, U22, LDU22, T, LDT, ALPHAR,
     $                   ALPHAI, BETA, IWORK, LIWORK, DWORK, LDWORK,
     $                   INFO )
C
C     SLICOT RELEASE 5.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                                      (  0  I  )
C       S = T Z = J Z' J' Z, where J = (        ),                   (1)
C                                      ( -I  0  )
C
C     via generalized symplectic URV decomposition. That is, orthogonal
C     matrices Q1 and Q2 and orthogonal symplectic matrices U1 and U2
C     are computed such that
C
C                                   ( T11  T12 )
C       Q1' T U1 = Q1' J Z' J' U1 = (          ) = Tout,
C                                   (  0   T22 )
C
C                  ( Z11  Z12 )
C       U2' Z Q2 = (          ) = Zout,                              (2)
C                  (  0   Z22 )
C
C                  ( H11  H12 )
C       Q1' H Q2 = (          ) = Hout,
C                  (  0   H22 )
C
C     where T11, T22', Z11, Z22', H11 are upper triangular and H22' is
C     upper quasi-triangular. The notation M' denotes the transpose of
C     the matrix M.
C     Optionally, if COMPQ1 = 'I' or COMPQ1 = 'U', the orthogonal
C     transformation matrix Q1 will be computed.
C     Optionally, if COMPQ2 = 'I' or COMPQ2 = 'U', the orthogonal
C     transformation matrix Q2 will be computed.
C     Optionally, if COMPU1 = 'I' or COMPU1 = 'U', the orthogonal
C     symplectic transformation matrix
C
C            (  U11  U12  )
C       U1 = (            )
C            ( -U12  U11  )
C
C     will be computed.
C     Optionally, if COMPU2 = 'I' or COMPU2 = 'U', the orthogonal
C     symplectic transformation matrix
C
C            (  U21  U22  )
C       U2 = (            )
C            ( -U22  U21  )
C
C     will be computed.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     JOB     CHARACTER*1
C             Specifies the computation to be performed, as follows:
C             = 'E': compute the eigenvalues only; Z, T, and H will not
C                    necessarily be put into the forms in (2); H22' is
C                    upper Hessenberg;
C             = 'T': put Z, T, and H into the forms in (2), and return
C                    the eigenvalues in ALPHAR, ALPHAI and BETA.
C
C     COMPQ1  CHARACTER*1
C             Specifies whether to compute the orthogonal transformation
C             matrix Q1, as follows:
C             = 'N': Q1 is not computed;
C             = 'I': the array Q1 is initialized internally to the unit
C                    matrix, and the orthogonal matrix Q1 is returned;
C             = 'U': the array Q1 contains an orthogonal matrix Q01 on
C                    entry, and the product Q01*Q1 is returned, where Q1
C                    is the product of the orthogonal transformations
C                    that are applied to the pencil aT*Z - bH on the
C                    left to reduce T, Z, and H to the forms in (2),
C                    for COMPQ1 = 'I'.
C
C     COMPQ2  CHARACTER*1
C             Specifies whether to compute the orthogonal transformation
C             matrix Q2, as follows:
C             = 'N': Q2 is not computed;
C             = 'I': the array Q2 is initialized internally to the unit
C                    matrix, and the orthogonal matrix Q2 is returned;
C             = 'U': the array Q2 contains an orthogonal matrix Q02 on
C                    entry, and the product Q02*Q2 is returned, where Q2
C                    is the product of the orthogonal transformations
C                    that are applied to the pencil aT*Z - bH on the
C                    right to reduce T, Z, and H to the forms in (2),
C                    for COMPQ2 = 'I'.
C
C     COMPU1  CHARACTER*1
C             Specifies whether to compute the orthogonal symplectic
C             transformation matrix U1, as follows:
C             = 'N': U1 is not computed;
C             = 'I': the arrays U11 and U12 are initialized internally
C                    to the unit and zero matrices, respectively, and
C                    the corresponding submatrices of the orthogonal
C                    symplectic matrix U1 are returned;
C             = 'U': the arrays U11 and U12 contain the corresponding
C                    submatrices of an orthogonal symplectic matrix U01
C                    on entry, and the updated submatrices U11 and U12
C                    of the matrix product U01*U1 are returned, where U1
C                    is the product of the orthogonal symplectic
C                    transformations that are applied to the pencil
C                    aT*Z - bH to reduce T, Z, and H to the forms in (2),
C                    for COMPU1 = 'I'.
C
C     COMPU2  CHARACTER*1
C             Specifies whether to compute the orthogonal symplectic
C             transformation matrix U2, as follows:
C             = 'N': U2 is not computed;
C             = 'I': the arrays U21 and U22 are initialized internally
C                    to the unit and zero matrices, respectively, and
C                    the corresponding submatrices of the orthogonal
C                    symplectic matrix U2 are returned;
C             = 'U': the arrays U21 and U22 contain the corresponding
C                    submatrices of an orthogonal symplectic matrix U02
C                    on entry, and the updated submatrices U21 and U22
C                    of the matrix product U02*U2 are returned, where U2
C                    is the product of the orthogonal symplectic
C                    transformations that are applied to the pencil
C                    aT*Z - bH to reduce T, Z, and H to the forms in (2),
C                    for COMPU2 = 'I'.
C
C     Input/output Parameters
C
C     N       (input) INTEGER
C             The order of the pencil aS - bH.  N >= 0, even.
C
C     Z       (input/output) DOUBLE PRECISION array, dimension (LDZ, N)
C             On entry, the leading N-by-N part of this array must
C             contain the matrix Z.
C             On exit, if JOB = 'T', the leading N-by-N part of this
C             array contains the matrix Zout; otherwise, it contains the
C             matrix Z obtained just before the application of the
C             periodic QZ algorithm.
C             The elements of the (2,1) block, i.e., in the rows N/2+1
C             to N and in the columns 1 to N/2 are not set to zero, but
C             are unchanged on exit.
C
C     LDZ     INTEGER
C             The leading dimension of the array Z.  LDZ >= MAX(1, N).
C
C     H       (input/output) DOUBLE PRECISION array, dimension (LDH, N)
C             On entry, the leading N-by-N part of this array must
C             contain the Hamiltonian matrix H (H22 = -H11', H12 = H12',
C             H21 = H21').
C             On exit, if JOB = 'T', the leading N-by-N part of this
C             array contains the matrix Hout; otherwise, it contains the
C             matrix H obtained just before the application of the
C             periodic QZ algorithm.
C
C     LDH     INTEGER
C             The leading dimension of the array H.  LDH >= MAX(1, N).
C
C     Q1      (input/output) DOUBLE PRECISION array, dimension (LDQ1, N)
C             On entry, if COMPQ1 = 'U', then the leading N-by-N part of
C             this array must contain a given matrix Q01, and on exit,
C             the leading N-by-N part of this array contains the product
C             of the input matrix Q01 and the transformation matrix Q1
C             used to transform the matrices Z, T and H.
C             On exit, if COMPQ1 = 'I', then the leading N-by-N part of
C             this array contains the orthogonal transformation matrix
C             Q1.
C             If COMPQ1 = 'N', this array is not referenced.
C
C     LDQ1    INTEGER
C             The leading dimension of the array Q1.
C             LDQ1 >= 1,         if COMPQ1 = 'N';
C             LDQ1 >= MAX(1, N), if COMPQ1 = 'I' or COMPQ1 = 'U'.
C
C     Q2      (input/output) DOUBLE PRECISION array, dimension (LDQ2, N)
C             On entry, if COMPQ2 = 'U', then the leading N-by-N part of
C             this array must contain a given matrix Q02, and on exit,
C             the leading N-by-N part of this array contains the product
C             of the input matrix Q02 and the transformation matrix Q2
C             used to transform the matrices Z, T and H.
C             On exit, if COMPQ2 = 'I', then the leading N-by-N part of
C             this array contains the orthogonal transformation matrix
C             Q2.
C             If COMPQ2 = 'N', this array is not referenced.
C
C     LDQ2    INTEGER
C             The leading dimension of the array Q2.
C             LDQ2 >= 1,         if COMPQ2 = 'N';
C             LDQ2 >= MAX(1, N), if COMPQ2 = 'I' or COMPQ2 = 'U'.
C
C     U11     (input/output) DOUBLE PRECISION array, dimension
C                            (LDU11, N/2)
C             On entry, if COMPU1 = 'U', then the leading N/2-by-N/2
C             part of this array must contain the upper left block of a
C             given matrix U01, and on exit, the leading N/2-by-N/2 part
C             of this array contains the updated upper left block U11 of
C             the product of the input matrix U01 and the transformation
C             matrix U1 used to transform the matrices Z, T, and H.
C             On exit, if COMPU1 = 'I', then the leading N/2-by-N/2 part
C             of this array contains the upper left block U11 of the
C             orthogonal symplectic transformation matrix U1.
C             If COMPU1 = 'N' this array is not referenced.
C
C     LDU11   INTEGER
C             The leading dimension of the array U11.
C             LDU11 >= 1,           if COMPU1 = 'N';
C             LDU11 >= MAX(1, N/2), if COMPU1 = 'I' or COMPU1 = 'U'.
C
C     U12     (input/output) DOUBLE PRECISION array, dimension
C                            (LDU12, N/2)
C             On entry, if COMPU1 = 'U', then the leading N/2-by-N/2
C             part of this array must contain the upper right block of a
C             given matrix U01, and on exit, the leading N/2-by-N/2 part
C             of this array contains the updated upper right block U12
C             of the product of the input matrix U01 and the
C             transformation matrix U1 used to transform the matrices
C             Z, T, and H.
C             On exit, if COMPU1 = 'I', then the leading N/2-by-N/2 part
C             of this array contains the upper right block U12 of the
C             orthogonal symplectic transformation matrix U1.
C             If COMPU1 = 'N' this array is not referenced.
C
C     LDU12   INTEGER
C             The leading dimension of the array U12.
C             LDU12 >= 1,           if COMPU1 = 'N';
C             LDU12 >= MAX(1, N/2), if COMPU1 = 'I' or COMPU1 = 'U'.
C
C     U21     (input/output) DOUBLE PRECISION array, dimension
C                            (LDU21, N/2)
C             On entry, if COMPU2 = 'U', then the leading N/2-by-N/2
C             part of this array must contain the upper left block of a
C             given matrix U02, and on exit, the leading N/2-by-N/2 part
C             of this array contains the updated upper left block U21 of
C             the product of the input matrix U02 and the transformation
C             matrix U2 used to transform the matrices Z, T, and H.
C             On exit, if COMPU2 = 'I', then the leading N/2-by-N/2 part
C             of this array contains the upper left block U21 of the
C             orthogonal symplectic transformation matrix U2.
C             If COMPU2 = 'N' this array is not referenced.
C
C     LDU21   INTEGER
C             The leading dimension of the array U21.
C             LDU21 >= 1,           if COMPU2 = 'N';
C             LDU21 >= MAX(1, N/2), if COMPU2 = 'I' or COMPU2 = 'U'.
C
C     U22     (input/output) DOUBLE PRECISION array, dimension
C                            (LDU22, N/2)
C             On entry, if COMPU2 = 'U', then the leading N/2-by-N/2
C             part of this array must contain the upper right block of a
C             given matrix U02, and on exit, the leading N/2-by-N/2 part
C             of this array contains the updated upper right block U22
C             of the product of the input matrix U02 and the
C             transformation matrix U2 used to transform the matrices
C             Z, T, and H.
C             On exit, if COMPU2 = 'I', then the leading N/2-by-N/2 part
C             of this array contains the upper right block U22 of the
C             orthogonal symplectic transformation matrix U2.
C             If COMPU2 = 'N' this array is not referenced.
C
C     LDU22   INTEGER
C             The leading dimension of the array U22.
C             LDU22 >= 1,           if COMPU2 = 'N';
C             LDU22 >= MAX(1, N/2), if COMPU2 = 'I' or COMPU2 = 'U'.
C
C     T       (output) DOUBLE PRECISION array, dimension (LDT, N)
C             If JOB = 'T', the leading N-by-N part of this array
C             contains the matrix Tout; otherwise, it contains the
C             matrix T obtained just before the application of the
C             periodic QZ algorithm.
C
C     LDT     INTEGER
C             The leading dimension of the array T.  LDT >= MAX(1, N).
C
C     ALPHAR  (output) DOUBLE PRECISION array, dimension (N/2)
C             The real parts of each scalar alpha defining an eigenvalue
C             of the pencil aS - bH.
C
C     ALPHAI  (output) DOUBLE PRECISION array, dimension (N/2)
C             The imaginary parts of each scalar alpha defining an
C             eigenvalue of the pencil aS - bH.
C             If ALPHAI(j) is zero, then the j-th eigenvalue is real.
C
C     BETA    (output) DOUBLE PRECISION array, dimension (N/2)
C             The scalars beta defining the eigenvalues of the pencil
C             aS - bH.
C             If INFO = 0, the quantities alpha = (ALPHAR(j),ALPHAI(j)),
C             and beta = BETA(j) represent together the j-th eigenvalue
C             of the pencil aS - bH, in the form lambda = alpha/beta.
C             Since lambda may overflow, the ratios should not, in
C             general, be computed. Due to the skew-Hamiltonian/
C             Hamiltonian structure of the pencil, only half of the
C             spectrum is saved in 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             If INFO = 3, one or more BETA(j) is not representable, and
C             the eigenvalues are returned as described below.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (LIWORK)
C             On exit, if INFO = 3, IWORK(1), ..., IWORK(N/2) return the
C             scaling parameters for the eigenvalues of the pencil
C             aS - bH (see INFO = 3).
C
C     LIWORK  INTEGER
C             The dimension of the array IWORK.
C             LIWORK >= N/2+18.
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) returns the optimal value
C             of LDWORK, and DWORK(2) returns the machine base, b.
C             On exit, if INFO = -31, DWORK(1) returns the minimum value
C             of LDWORK.
C
C     LDWORK  INTEGER
C             The dimension of the array DWORK.
C             If JOB = 'E' and COMPQ1 = 'N' and COMPQ2 = 'N' and
C             COMPU1 = 'N' and COMPU2 = 'N', then
C                   LDWORK >= 3/2*N**2+MAX(N, 48);
C             else, LDWORK >=   3*N**2+MAX(N, 48).
C             For good performance LDWORK should generally be larger.
C
C             If LDWORK = -1, then a workspace query is assumed; the
C             routine only calculates the optimal size of the DWORK
C             array, returns this value as the first entry of the DWORK
C             array, and no error message related to LDWORK is issued by
C             XERBLA.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0: succesful exit.
C             < 0: if INFO = -i, the i-th argument had an illegal value.
C             = 1: the periodic QZ algorithm was not able to reveal
C                  information about the eigenvalues from the 2-by-2
C                  blocks in the SLICOT Library routine MB03BD;
C             = 2: the periodic QZ algorithm did not converge in the
C                  SLICOT Library routine MB03BD;
C             = 3: the eigenvalues will under- or overflow if evaluated;
C                  therefore, the j-th eigenvalue is represented by
C                  the quantities alpha = (ALPHAR(j),ALPHAI(j)),
C                  beta = BETA(j), and gamma = IWORK(j) in the form
C                  lambda = (alpha/beta) * b**gamma, where b is the
C                  machine base (often 2.0). This is not an error.
C
C     METHOD
C
C     The algorithm uses Givens rotations and Householder reflections to
C     annihilate elements in T, Z, and H such that T11, T22', Z11, Z22'
C     and H11 are upper triangular and H22' is upper Hessenberg. Finally
C     the periodic QZ algorithm is applied to transform H22' to upper
C     quasi-triangular form while T11, T22', Z11, Z22', and H11 stay in
C     upper triangular form.
C     See also page 17 in [1] for more details.
C
C     REFERENCES
C
C     [1] Benner, P., Byers, R., Losse, P., Mehrmann, V. and Xu, H.
C         Numerical Solution of Real Skew-Hamiltonian/Hamiltonian
C         Eigenproblems.
C         Tech. Rep., Technical University Chemnitz, Germany,
C         Nov. 2007.
C
C     NUMERICAL ASPECTS
C                                                               3
C     The algorithm is numerically backward stable and needs O(N ) real
C     floating point operations.
C
C     CONTRIBUTOR
C
C     Matthias Voigt, Fakultaet fuer Mathematik, Technische Universitaet
C     Chemnitz, December 03, 2008.
C     V. Sima, Dec. 2009 (SLICOT version of the routine DGEURV).
C
C     REVISIONS
C
C     V. Sima, Feb. 2010, Nov. 2010, Aug. 2011, Nov. 2011, July 2012,
C     Oct. 2012.
C     M. Voigt, Jan. 2012.
C
C     KEYWORDS
C
C     generalized symplectic URV decomposition, periodic QZ algorithm,
C     upper (quasi-)triangular matrix.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO, HALF, ONE, 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, COMPU1, COMPU2, JOB
      INTEGER            INFO, LDH, LDQ1, LDQ2, LDT, LDU11, LDU12,
     $                   LDU21, LDU22, LDWORK, LDZ, LIWORK, N
C
C     .. Array Arguments ..
      INTEGER            IWORK( * )
      DOUBLE PRECISION   ALPHAI( * ), ALPHAR( * ), BETA( * ),
     $                   DWORK( * ), H( LDH, * ), Q1( LDQ1, * ),
     $                   Q2( LDQ2, * ), T( LDT, * ), U11( LDU11, * ),
     $                   U12( LDU12, * ), U21( LDU21, * ),
     $                   U22( LDU22, * ), Z( LDZ, * )
C
C     .. Local Scalars ..
      LOGICAL            LCMPQ1, LCMPQ2, LCMPU1, LCMPU2, LINIQ1, LINIQ2,
     $                   LINIU1, LINIU2, LQUERY, LTRI, LUPDQ1, LUPDQ2,
     $                   LUPDU1, LUPDU2
      CHARACTER*16       CMPQ, CMPSC
      INTEGER            I, IMAT, IQ, ITAU, IWARN, IWRK, J, K, M, MINDW,
     $                   MM, OPTDW
      DOUBLE PRECISION   BASE, CO, EMAX, EMIN, PREC, SI, SQRB, TMP1,
     $                   TMP2
      COMPLEX*16         EIG
C
C     .. Local Arrays ..
      INTEGER            IDUM( 1 )
      DOUBLE PRECISION   DUM( 1 )
C
C     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLAMCH, DLAPY2
      EXTERNAL           DLAMCH, DLAPY2, LSAME
C
C     .. External Subroutines ..
      EXTERNAL           DGEMM, DGEQRF, DGERQF, DLACPY, DLARTG, DLASET,
     $                   DORMQR, DORMRQ, DROT, DSCAL, DSWAP, MA02AD,
     $                   MB03BD, XERBLA
C
C     .. Intrinsic Functions ..
      INTRINSIC          ABS, DBLE, DCMPLX, DIMAG, MAX, MIN, MOD, SQRT
C
C     .. Executable Statements ..
C
C     Decode the input arguments.
C
      M  = N/2
      MM = M*M
C
      LTRI   = LSAME( JOB,    'T' )
      LINIQ1 = LSAME( COMPQ1, 'I' )
      LUPDQ1 = LSAME( COMPQ1, 'U' )
      LINIQ2 = LSAME( COMPQ2, 'I' )
      LUPDQ2 = LSAME( COMPQ2, 'U' )
      LINIU1 = LSAME( COMPU1, 'I' )
      LUPDU1 = LSAME( COMPU1, 'U' )
      LINIU2 = LSAME( COMPU2, 'I' )
      LUPDU2 = LSAME( COMPU2, 'U' )
      LCMPQ1 = LINIQ1 .OR. LUPDQ1
      LCMPQ2 = LINIQ2 .OR. LUPDQ2
      LCMPU1 = LINIU1 .OR. LUPDU1
      LCMPU2 = LINIU2 .OR. LUPDU2
      IF( N.EQ.0 ) THEN
         MINDW = 2
      ELSE IF( LTRI .OR. LCMPQ1 .OR. LCMPQ2 .OR. LCMPU1 .OR. LCMPU2 )
     $   THEN
         MINDW = 12*MM + MAX( N, 48 )
      ELSE
         MINDW =  6*MM + MAX( N, 48 )
      END IF
      LQUERY = LDWORK.EQ.-1
C
C     Test the input arguments.
C
      INFO = 0
      IF( .NOT.( LSAME( JOB, 'E' ) .OR. LTRI ) ) THEN
         INFO = -1
      ELSE IF( .NOT.( LSAME( COMPQ1, 'N' ) .OR. LCMPQ1 ) ) THEN
         INFO = -2
      ELSE IF( .NOT.( LSAME( COMPQ2, 'N' ) .OR. LCMPQ2 ) ) THEN
         INFO = -3
      ELSE IF( .NOT.( LSAME( COMPU1, 'N' ) .OR. LCMPU1 ) ) THEN
         INFO = -4
      ELSE IF( .NOT.( LSAME( COMPU2, 'N' ) .OR. LCMPU2 ) ) THEN
         INFO = -5
      ELSE IF( N.LT.0 .OR. MOD( N, 2 ).NE.0 ) THEN
         INFO = -6
      ELSE IF( LDZ.LT.MAX( 1, N ) ) THEN
         INFO = -8
      ELSE IF( LDH.LT.MAX( 1, N ) ) THEN
         INFO = -10
      ELSE IF( LDQ1.LT.1  .OR. ( LCMPQ1 .AND.  LDQ1.LT.N ) ) THEN
         INFO = -12
      ELSE IF( LDQ2.LT.1  .OR. ( LCMPQ2 .AND.  LDQ2.LT.N ) ) THEN
         INFO = -14
      ELSE IF( LDU11.LT.1 .OR. ( LCMPU1 .AND. LDU11.LT.M ) ) THEN
         INFO = -16
      ELSE IF( LDU12.LT.1 .OR. ( LCMPU1 .AND. LDU12.LT.M ) ) THEN
         INFO = -18
      ELSE IF( LDU21.LT.1 .OR. ( LCMPU2 .AND. LDU21.LT.M ) ) THEN
         INFO = -20
      ELSE IF( LDU22.LT.1 .OR. ( LCMPU2 .AND. LDU22.LT.M ) ) THEN
         INFO = -22
      ELSE IF( LDT.LT.MAX( 1, N ) ) THEN
         INFO = -24
      ELSE IF( LIWORK.LT.M+18 ) THEN
         INFO = -29
      ELSE IF( .NOT.LQUERY .AND. LDWORK.LT.MINDW ) THEN
         DWORK( 1 ) = MINDW
         INFO = -31
      END IF
C
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'MB04AD', -INFO )
         RETURN
      ELSE IF( N.GT.0 ) THEN
C
C        Compute optimal workspace.
C
         IF( LQUERY ) THEN
            CALL DORMQR( 'Left', 'Transpose', N, N, M, T, LDT, DWORK, T,
     $                   LDT, DWORK, -1, INFO )
            CALL DORMRQ( 'Right', 'Transpose', N, M, M, Z, LDZ, DWORK,
     $                   H, LDH, DUM, -1, INFO )
            I = INT( DUM( 1 ) )
            OPTDW = MAX( INT( DWORK( 1 ) ), I )
            CALL DGERQF( M, M, DWORK, M, DWORK, DWORK, -1, INFO )
            CALL DORMRQ( 'Left', 'No Transpose', M, N, M, DWORK, M,
     $                   DWORK, H, LDH, DUM, -1, INFO )
            OPTDW = M + MAX( OPTDW, MM + MAX( INT( DWORK( 1 ) ),
     $                                        INT( DUM( 1 ) ) ) )
            IF( LCMPQ1 )
     $         OPTDW = MAX( OPTDW, M + MM + I )
            CALL DGEQRF( N, M, DWORK, N, DWORK, DWORK, -1, INFO )
            CALL DORMQR( 'Right', 'No Transpose', N, N, M, DWORK, N,
     $                   DWORK, H, LDH, DUM, -1, INFO )
            OPTDW = MAX( OPTDW, M + M*N + MAX( INT( DWORK( 1 ) ),
     $                                         INT( DUM( 1 ) ) ) )
            IF( LCMPQ2 ) THEN
               CALL DORMQR( 'Left', 'No Transpose', N, N, M, DWORK, N,
     $                      DWORK, Q2, LDQ2, DWORK, -1, INFO )
               OPTDW = MAX( OPTDW, M + M*N + INT( DWORK( 1 ) ) )
            END IF
            DWORK( 1 ) = MAX( OPTDW, MINDW )
            RETURN
         END IF
      END IF
C
C     Determine machine constants.
C
      BASE = DLAMCH( 'Base' )
      EMIN = DLAMCH( 'Minimum Exponent' )
      EMAX = DLAMCH( 'Largest Exponent' )
      PREC = DLAMCH( 'Precision' )
      SQRB = SQRT( BASE )
C
C     Quick return if possible.
C
      IF( N.EQ.0 ) THEN
         DWORK( 1 ) = TWO
         DWORK( 2 ) = BASE
         RETURN
      END IF
C
C     Initializations.
C
C     Set T = J Z' J'.
C
      CALL MA02AD( 'Full', M, M, Z( M+1, M+1 ), LDZ, T, LDT )
      CALL MA02AD( 'Full', M, M, Z( 1, M+1 ), LDZ, T( 1, M+1 ), LDT )
C
      DO 10 I = 1, M
         CALL DSCAL( M, -ONE, T( 1, M+I ), 1 )
   10 CONTINUE
C
      CALL MA02AD( 'Full', M, M, Z( M+1, 1 ), LDZ, T( M+1, 1 ), LDT )
C
      DO 20 I = 1, M
         CALL DSCAL( M, -ONE, T( M+1, I ), 1 )
   20 CONTINUE
C
      CALL MA02AD( 'Full', M, M, Z, LDZ, T( M+1, M+1 ), LDT )
C
      IF( LINIQ1 )
     $   CALL DLASET( 'Full', N, N, ZERO, ONE, Q1, LDQ1 )
C
      IF( LINIQ2 )
     $   CALL DLASET( 'Full', N, N, ZERO, ONE, Q2, LDQ2 )
C
      IF( LINIU1 ) THEN
         CALL DLASET( 'Full', M, M, ZERO,  ONE, U11, LDU11 )
         CALL DLASET( 'Full', M, M, ZERO, ZERO, U12, LDU12 )
      END IF
C
      IF( LINIU2 ) THEN
         CALL DLASET( 'Full', M, M, ZERO,  ONE, U21, LDU21 )
         CALL DLASET( 'Full', M, M, ZERO, ZERO, U22, LDU22 )
      END IF
C
C     STEP 1: Block triangularize T and Z.
C
C     (Note: Comments in the code beginning "Workspace:" describe the
C     minimal amount of real workspace needed at that point in the
C     code, as well as the preferred amount for good performance.
C     NB refers to the optimal block size for the immediately
C     following subroutine, as returned by ILAENV.)
C
      ITAU = 1
      IWRK = ITAU + M
C
C                                 ( T11 )
C     Perform a QR decomposition, (     ) = Q1*R1.
C                                 ( T21 )
C
C     Workspace:    need   IWRK + M - 1;
C                   prefer IWRK + M*NB - 1.
C
      CALL DGEQRF( N, M, T, LDT, DWORK( ITAU ), DWORK( IWRK ),
     $             LDWORK-IWRK+1, INFO )
C
C            ( T12 )
C     Update (     ).
C            ( T22 )
C
C     Workspace:    need   IWRK + M - 1;
C                   prefer IWRK + M*NB - 1.
C
      CALL DORMQR( 'Left', 'Transpose', N, M, M, T, LDT, DWORK( ITAU ),
     $             T( 1, M+1 ), LDT, DWORK( IWRK ), LDWORK-IWRK+1, INFO
     $           )
C
C     Update H.
C
C     Workspace:    need   IWRK + N - 1;
C                   prefer IWRK + N*NB - 1.
C
      CALL DORMQR( 'Left', 'Transpose', N, N, M, T, LDT, DWORK( ITAU ),
     $             H, LDH, DWORK( IWRK ), LDWORK-IWRK+1, INFO )
      OPTDW = MAX( MINDW, INT( DWORK( IWRK ) ) + IWRK - 1 )
C
      IF( LCMPQ1 ) THEN
C
C        Update Q1.
C
         CALL DORMQR( 'Right', 'No Transpose', N, N, M, T, LDT,
     $                DWORK( ITAU ), Q1, LDQ1, DWORK( IWRK ),
     $                LDWORK-IWRK+1, INFO )
      END IF
C
C     Set the strictly lower triangular part of [ T11; T21 ] to zero.
C
      CALL DLASET( 'Lower', N-1, M, ZERO, ZERO, T( 2, 1 ), LDT )
C
C     Perform an RQ decomposition, T22 = R2*Q2.
C
C     Workspace:    need   IWRK + M - 1;
C                   prefer IWRK + M*NB - 1.
C
      ITAU = MM   + 1
      IWRK = ITAU + M
      CALL MA02AD( 'Full', M, M, T( M+1, M+1 ), LDT, DWORK, M )
      CALL DGERQF( M, M, DWORK, M, DWORK( ITAU ), DWORK( IWRK ),
     $             LDWORK-IWRK+1, INFO )
      OPTDW = MAX( OPTDW, INT( DWORK( IWRK ) ) + IWRK - 1 )
      CALL MA02AD( 'Upper', M, M, DWORK, M, T( M+1, M+1 ), LDT )
C
C     Set the strictly upper triangular part of T22 to zero.
C
      IF( M.GT.1 )
     $   CALL DLASET( 'Upper', M-1, M-1, ZERO, ZERO, T( M+1, M+2 ), LDT
     $              )
C
C     Update H.
C
C     Workspace:    need   IWRK + N - 1;
C                   prefer IWRK + N*NB - 1.
C
      CALL DORMRQ( 'Left', 'No Transpose', M, N, M, DWORK, M,
     $             DWORK( ITAU ), H( M+1, 1 ), LDH, DWORK( IWRK ),
     $             LDWORK-IWRK+1, INFO )
      OPTDW = MAX( OPTDW, INT( DWORK( IWRK ) ) + IWRK - 1 )
C
      IF( LCMPQ1 ) THEN
C
C        Update Q1.
C
         CALL DORMRQ( 'Right', 'Transpose', N, M, M, DWORK, M,
     $                DWORK( ITAU ), Q1( 1, M+1 ), LDQ1, DWORK( IWRK ),
     $                LDWORK-IWRK+1, INFO )
         OPTDW = MAX( OPTDW, INT( DWORK( IWRK ) ) + IWRK - 1 )
      END IF
C
C     Perform a QR decomposition, ( Z21  Z22 )' = Q3*R3.
C
C     Workspace:    need   IWRK + M - 1;
C                   prefer IWRK + M*NB - 1.
C
      ITAU = M*N  + 1
      IWRK = ITAU + M
      CALL MA02AD( 'Full', M, N, Z( M+1, 1 ), LDZ, DWORK, N )
      CALL DGEQRF( N, M, DWORK, N, DWORK( ITAU ), DWORK( IWRK ),
     $             LDWORK-IWRK+1, INFO )
      OPTDW = MAX( OPTDW, INT( DWORK( IWRK ) ) + IWRK - 1 )
C
C     Update ( Z11  Z12 ).
C
      CALL DORMQR( 'Right', 'No Transpose', M, N, M, DWORK, N,
     $             DWORK( ITAU ), Z, LDZ, DWORK( IWRK ),
     $             LDWORK-IWRK+1, INFO )
      CALL MA02AD( 'Upper', M, M, DWORK, N, Z( M+1, M+1 ), LDZ )
C
C     Set the strictly upper triangular part of Z22 to zero.
C
      IF( M.GT.1 )
     $   CALL DLASET( 'Upper', M-1, M-1, ZERO, ZERO, Z( M+1, M+2 ), LDZ
     $              )
C
C     Update H.
C
      CALL DORMQR( 'Right', 'No Transpose', N, N, M, DWORK, N,
     $             DWORK( ITAU ), H, LDH, DWORK( IWRK ), LDWORK-IWRK+1,
     $             INFO )
      OPTDW = MAX( OPTDW, INT( DWORK( IWRK ) ) + IWRK - 1 )
C
      DO 30 I = 1, M
         CALL DSWAP( N, H( 1, I ), 1, H( 1, M+I ), 1 )
   30 CONTINUE
C
      IF( LCMPQ2 ) THEN
C
C        Update Q2.
C
         CALL DORMQR( 'Right', 'No Transpose', N, N, M, DWORK, N,
     $                DWORK( ITAU ), Q2, LDQ2, DWORK( IWRK ),
     $                LDWORK-IWRK+1, INFO )
         OPTDW = MAX( OPTDW, INT( DWORK( IWRK ) ) + IWRK - 1 )
C
         DO 40 I = 1, M
            CALL DSWAP( N, Q2( 1, I ), 1, Q2( 1, M+I ), 1 )
   40    CONTINUE
      END IF
C
C     Perform an RQ decomposition Z12 = R4*Q4.
C
      ITAU = 1
      IWRK = ITAU + M
      CALL DGERQF( M, M, Z( 1, M+1 ), LDZ, DWORK( ITAU ), DWORK( IWRK ),
     $             LDWORK-IWRK+1, INFO )
C
C     Update H.
C
      CALL DORMRQ( 'Right', 'Transpose', N, M, M, Z( 1, M+1 ), LDZ,
     $             DWORK( ITAU ), H, LDH, DWORK( IWRK ), LDWORK-IWRK+1,
     $             INFO )
      OPTDW = MAX( OPTDW, INT( DWORK( IWRK ) ) + IWRK - 1 )
C
      IF( LCMPQ2 ) THEN
C
C        Update Q2.
C
         CALL DORMRQ( 'Right', 'Transpose', N, M, M, Z( 1, M+1 ), LDZ,
     $                DWORK( ITAU ), Q2, LDQ2, DWORK( IWRK ),
     $                LDWORK-IWRK+1, INFO )
      END IF
C
C     Exchange Z11 and Z12 and set the strictly lower triangular part
C     of Z11 to zero.
C
      DUM( 1 ) = ZERO
C
      DO 50 I = 1, M - 1
         CALL DSWAP(  M, Z( 1, I ), 1, Z( 1, M+I ), 1 )
         CALL DCOPY( M-I, DUM, 0, Z( I+1, I ), 1 )
   50 CONTINUE
C
      CALL DSWAP( M, Z( 1, M ), 1, Z( 1, N ), 1 )
C
C     STEP 2: Eliminations in H.
C
      DO 100 K = 1, M
C
C        I. Annihilate H(m+k:n-1,k).
C
         DO 60 J = K, M-1
C
C           Determine a Givens rotation to annihilate H(m+j,k) from the
C           left.
C
            CALL DLARTG( H( M+J+1, K ), H( M+J, K ), CO, SI, TMP1 )
C
C           Update H.
C
            H( M+J+1, K ) = TMP1
            H(   M+J, K ) = ZERO
            CALL DROT( N-K, H( M+J+1, K+1 ), LDH, H( M+J, K+1 ), LDH,
     $                 CO, SI )
C
C           Update T.
C
            CALL DROT( J+1, T( M+J+1, M+1 ), LDT, T( M+J, M+1 ), LDT,
     $                 CO, SI )
C
            IF( LCMPQ1 ) THEN
C
C              Update Q1.
C
               CALL DROT( N, Q1( 1, M+J+1 ), 1, Q1( 1, M+J ), 1, CO, SI
     $                  )
            END IF
C
C           Determine a Givens rotation to annihilate T(m+j,m+j+1) from
C           the right.
C
            CALL DLARTG( T( M+J, M+J ), T( M+J, M+J+1 ), CO, SI, TMP1 )
C
C           Update T.
C
            CALL DROT( M, T( 1, M+J ), 1, T( 1, M+J+1 ), 1, CO , SI )
            T( M+J, M+J   ) = TMP1
            T( M+J, M+J+1 ) = ZERO
            CALL DROT( M-J, T( M+J+1, M+J ), 1, T( M+J+1, M+J+1 ), 1,
     $                 CO, SI )
            CALL DROT( J+1, T( 1, J ), 1, T( 1, J+1 ), 1, CO, SI )
C
            IF( LCMPU1 ) THEN
C
C              Update U11 and U12.
C
               CALL DROT( M, U11( 1, J ), 1, U11( 1, J+1 ), 1, CO, SI )
               CALL DROT( M, U12( 1, J ), 1, U12( 1, J+1 ), 1, CO, SI )
            END IF
C
C           Determine a Givens rotation to annihilate T(j+1,j) from the
C           left.
C
            CALL DLARTG( T( J, J ), T( J+1, J ), CO, SI, TMP1 )
C
C           Update T.
C
            T(   J, J ) = TMP1
            T( J+1, J ) = ZERO
            CALL DROT( N-J, T( J, J+1 ), LDT, T( J+1, J+1 ), LDT, CO, SI
     $               )
C
C           Update H.
C
            CALL DROT( N-K+1, H( J, K ), LDH, H( J+1, K ), LDH, CO, SI )
C
            IF( LCMPQ1 ) THEN
C
C              Update Q1.
C
               CALL DROT( N, Q1( 1, J ), 1, Q1( 1, J+1 ), 1, CO, SI )
            END IF
   60    CONTINUE
C
C        II. Annihilate H(n,k).
C
C        Determine a Givens rotation to annihilate H(n,k) form the left.
C
         CALL DLARTG( H( M, K ), H( N, K ), CO, SI, TMP1 )
C
C        Update H.
C
         H( M, K ) = TMP1
         H( N, K ) = ZERO
         CALL DROT( N-K, H( M, K+1 ), LDH, H( N, K+1 ), LDH, CO, SI )
C
C        Update T.
C
         CALL DROT( M, T( M, M+1 ), LDT, T( N, M+1 ), LDT, CO, SI )
         TMP1 =      -SI*T( M, M )
         T( M, M ) =  CO*T( M, M )
C
         IF( LCMPQ1 ) THEN
C
C           Update Q1.
C
            CALL DROT( N, Q1( 1, M ), 1, Q1( 1, N ), 1, CO, SI )
         END IF
C
C        Determine a Givens rotation to annihilate T(n,m) from the
C        right.
C
         CALL DLARTG( T( N, N ), TMP1, CO, SI, TMP2 )
C
C        Update T.
C
         CALL DROT( M, T( 1, N ), 1, T( 1, M ), 1, CO, SI )
         T( N, N ) = TMP2
C
         IF( LCMPU1 ) THEN
C
C           Update U11 and U12.
C
            CALL DROT( M, U12( 1, M ), 1, U11( 1, M ), 1, CO, SI )
         END IF
C
C        III. Annihilate H(k+1:m,k).
C
         DO 70 J = M, K+1, -1
C
C           Determine a Givens rotation to annihilate H(j,k) from the
C           left.
C
            CALL DLARTG( H( J-1, K ), H( J, K ), CO, SI, TMP1 )
C
C           Update H.
C
            H( J-1, K ) = TMP1
            H( J,   K ) = ZERO
            CALL DROT( N-K, H( J-1, K+1 ), LDH, H( J, K+1 ), LDH, CO, SI
     $               )
C
C           Update T.
C
            CALL DROT( N-J+2, T( J-1, J-1 ), LDT, T( J, J-1 ), LDT, CO,
     $                 SI )
C
            IF( LCMPQ1 ) THEN
C
C              Update Q1.
C
               CALL DROT( N, Q1( 1, J-1 ), 1, Q1( 1, J ), 1, CO, SI )
            END IF
C
C           Determine a Givens rotation to annihilate T(j,j-1) from the
C           right.
C
            CALL DLARTG( T( J, J ), T( J, J-1 ), CO, SI, TMP1 )
C
C           Update T.
C
            CALL DROT( M, T( 1, M+J ), 1, T( 1, M+J-1 ), 1, CO, SI )
            CALL DROT( M-J+2, T( M+J-1, M+J ), 1, T( M+J-1, M+J-1 ), 1,
     $                 CO, SI )
            T( J, J   ) = TMP1
            T( J, J-1 ) = ZERO
            CALL DROT( J-1, T( 1, J ), 1, T( 1, J-1 ), 1, CO, SI )
C
            IF( LCMPU1 ) THEN
C
C              Update U11 and U12.
C
               CALL DROT( M, U11( 1, J ), 1, U11( 1, J-1 ), 1, CO, SI )
               CALL DROT( M, U12( 1, J ), 1, U12( 1, J-1 ), 1, CO, SI )
            END IF
C
C           Determine a Givens rotation to annihilate T(m+j-1,m-j) from
C           the left.
C
            CALL DLARTG( T( M+J, M+J ), T( M+J-1, M+J ), CO, SI, TMP1 )
C
C           Update T.
C
            T( M+J,   M+J ) = TMP1
            T( M+J-1, M+J ) = ZERO
            CALL DROT( J-1, T( M+J, M+1 ), LDT, T( M+J-1, M+1 ), LDT,
     $                 CO, SI )
C
C           Update H.
C
            CALL DROT( N-K+1, H( M+J, K ), LDH, H( M+J-1, K ), LDH, CO,
     $                 SI )
C
            IF( LCMPQ1 ) THEN
C
C              Update Q1.
C
               CALL DROT( N, Q1( 1, M+J ), 1, Q1( 1, M+J-1 ), 1, CO, SI
     $                  )
            END IF
   70    CONTINUE
C
C        IV. Annihilate H(m+k,k+1:m-1).
C
         DO 80 J = K+1, M-1
C
C           Determine a Givens rotation to annihilate H(m+k,j) from the
C           right.
C
            CALL DLARTG( H( M+K, J+1 ), H( M+K, J ), CO, SI, TMP1 )
C
C           Update H.
C
            CALL DROT( M, H( 1, J+1 ), 1, H( 1, J ), 1, CO, SI )
            H( M+K, J+1 ) = TMP1
            H( M+K, J   ) = ZERO
            CALL DROT( M-K, H( M+K+1, J+1 ), 1, H( M+K+1, J ), 1, CO, SI
     $               )
C
C           Update Z.
C
            CALL DROT( J+1, Z( 1, J+1 ), 1, Z( 1, J ), 1, CO, SI )
C
            IF( LCMPQ2 ) THEN
C
C              Update Q2.
C
               CALL DROT( N, Q2( 1, J+1 ), 1, Q2( 1, J ), 1, CO, SI )
            END IF
C
C           Determine a Givens rotation to annihilate Z(j+1,j) from the
C           left.
C
            CALL DLARTG( Z( J, J ), Z( J+1, J ), CO, SI, TMP1 )
C
C           Update Z.
C
            Z( J,   J ) = TMP1
            Z( J+1, J ) = ZERO
            CALL DROT( N-J, Z( J, J+1 ), LDZ, Z( J+1, J+1 ), LDZ, CO, SI
     $               )
            CALL DROT( J+1, Z( M+J, M+1 ), LDZ, Z( M+J+1, M+1 ), LDZ,
     $                 CO, SI )
C
            IF( LCMPU2 ) THEN
C
C              Update U21 and U22.
C
               CALL DROT( M, U21( 1, J ), 1, U21( 1, J+1 ), 1, CO, SI )
               CALL DROT( M, U22( 1, J ), 1, U22( 1, J+1 ), 1, CO, SI )
            END IF
C
C           Determine a Givens rotation to annihilate Z(m+j,m+j+1) from
C           the right.
C
            CALL DLARTG( Z( M+J, M+J ), Z( M+J, M+J+1 ), CO, SI, TMP1 )
C
C           Update Z.
C
            Z( M+J, M+J   ) = TMP1
            Z( M+J, M+J+1 ) = ZERO
            CALL DROT( M, Z( 1, M+J ), 1, Z( 1, M+J+1 ), 1, CO, SI )
            CALL DROT( M-J, Z( M+J+1, M+J ), 1, Z( M+J+1, M+J+1 ), 1,
     $                 CO, SI )
C
C           Update H.
C
            CALL DROT( M, H( 1, M+J ), 1, H( 1, M+J+1 ), 1, CO, SI )
            CALL DROT( M-K+1, H( M+K, M+J ), 1, H( M+K, M+J+1 ), 1, CO,
     $                 SI )
C
            IF( LCMPQ2 ) THEN
C
C              Update Q2.
C
               CALL DROT( N, Q2( 1, M+J ), 1, Q2( 1, M+J+1 ), 1, CO, SI
     $                  )
            END IF
   80    CONTINUE
C
C        V. Annihilate H(m+k,m).
C
         IF( K.LT.M ) THEN
C
C           Determine a Givens rotation to annihilate H(m+k,m) from the
C           right.
C
            CALL DLARTG( H( M+K, N ), H( M+K, M ), CO, SI, TMP1 )
C
C           Update H.
C
            H( M+K, N ) = TMP1
            H( M+K, M ) = ZERO
            CALL DROT( M, H( 1, N ), 1, H( 1, M ), 1, CO, SI )
            CALL DROT( M-K, H( M+K+1, N ), 1, H( M+K+1, M ), 1, CO, SI )
C
C           Update Z.
C
            CALL DROT( M, Z( 1, N ), 1, Z( 1, M ), 1, CO, SI )
            TMP1 = -SI*Z( N, N )
            Z( N, N ) = CO*Z( N, N )
C
            IF( LCMPQ2 ) THEN
C
C              Update Q2.
C
               CALL DROT( N, Q2( 1, N ), 1, Q2( 1, M ), 1, CO, SI )
            END IF
C
C           Determine a Givens rotation to annihilate Z(n,m) from the
C           left.
C
            CALL DLARTG( Z( M, M ), TMP1, CO, SI, TMP2 )
C
C           Update Z.
C
            CALL DROT( M, Z( M, M+1 ), LDZ, Z( N, M+1 ), LDZ, CO, SI )
            Z( M, M ) = TMP2
C
            IF( LCMPU2 ) THEN
C
C              Update U2.
C
               CALL DROT( M, U21( 1, M ), 1, U22( 1, M ), 1, CO, SI )
            END IF
         ELSE
C
C           Determine a Givens rotation to annihilate H(n,m) from the
C           left.
C
            CALL DLARTG( H( M, M ), H( N, M ), CO, SI, TMP1 )
C
C           Update H.
C
            H( M, M ) = TMP1
            H( N, M ) = ZERO
            CALL DROT( M, H( M, M+1 ), LDH, H( N, M+1 ), LDH, CO, SI )
C
C           Update T.
C
            CALL DROT( M, T( M, M+1 ), LDT, T( N, M+1 ), LDT, CO, SI )
            T( M, M ) = CO*T( M, M )
C
            IF( LCMPQ1 ) THEN
C
C              Update Q1.
C
               CALL DROT( N, Q1( 1, M ), 1, Q1( 1, N ), 1, CO, SI )
            END IF
C
C           Determine a Givens rotation to annihilate T( N, M ) from the
C           right.
C
            CALL DLARTG( T( N, N ), -SI*T( M, M ), CO, SI, TMP2 )
C
C           Update T.
C
            CALL DROT( M, T( 1, N ), 1, T( 1, M ), 1, CO, SI )
            T( N, N ) = TMP2
C
            IF( LCMPU1 ) THEN
C
C              Update U1.
C
               CALL DROT( M, U12( 1, M ), 1, U11( 1, M ), 1, CO, SI )
            END IF
         END IF
C
C        VI. Annihilate H(m+k,m+k+2:n).
C
         DO 90 J = M, K+2, -1
C
C           Determine a Givens rotation to annihilate H(m+k,m+j) from
C           the right.
C
            CALL DLARTG( H( M+K, M+J-1 ), H( M+K, M+J ), CO, SI, TMP1 )
C
C           Update H.
C
            CALL DROT( M, H( 1, M+J-1 ), 1, H( 1, M+J ), 1, CO, SI )
            H( M+K, M+J-1 ) = TMP1
            H( M+K, M+J   ) = ZERO
            CALL DROT( M-K, H( M+K+1, M+J-1 ), 1, H( M+K+1, M+J ), 1,
     $                 CO, SI )
C
C           Update Z.
C
            CALL DROT( M, Z( 1, M+J-1 ), 1, Z( 1, M+J ), 1, CO, SI )
            CALL DROT( M-J+2, Z( M+J-1, M+J-1 ), 1, Z( M+J-1, M+J ), 1,
     $                 CO, SI )
C
            IF( LCMPQ2 ) THEN
C
C              Update Q2.
C
               CALL DROT( N, Q2( 1, M+J-1 ), 1, Q2( 1, M+J ), 1, CO, SI
     $                  )
            END IF
C
C           Determine a Givens rotation to annihilate Z(m+j-1,m+j) from
C           the left.
C
            CALL DLARTG( Z( M+J, M+J ), Z( M+J-1, M+J ), CO, SI, TMP1 )
C
C           Update Z.
C
            Z( M+J,   M+J ) = TMP1
            Z( M+J-1, M+J ) = ZERO
            CALL DROT( J-1, Z( M+J, M+1 ), LDZ, Z( M+J-1, M+1 ), LDZ,
     $                 CO, SI )
            CALL DROT( N-J+2, Z( J, J-1 ), LDZ, Z( J-1, J-1 ), LDZ, CO,
     $                 SI )
C
            IF( LCMPU2 ) THEN
C
C              Update U2.
C
               CALL DROT( M, U21( 1, J ), 1, U21( 1, J-1 ), 1, CO, SI )
               CALL DROT( M, U22( 1, J ), 1, U22( 1, J-1 ), 1, CO, SI )
            END IF
C
C           Determine a Givens rotation to annihilate Z(j,j-1) from the
C           right.
C
            CALL DLARTG( Z( J, J ), Z( J, J-1 ), CO, SI, TMP1 )
C
C           Update Z.
C
            Z( J, J   ) = TMP1
            Z( J, J-1 ) = ZERO
            CALL DROT( J-1, Z( 1, J ), 1, Z( 1, J-1 ), 1, CO, SI )
C
C           Update H.
C
            CALL DROT( M, H( 1, J ), 1, H( 1, J-1 ), 1, CO, SI )
            CALL DROT( M-K+1, H( M+K, J ), 1, H( M+K, J-1 ), 1, CO, SI )
C
            IF( LCMPQ2 ) THEN
C
C              Update Q2.
C
               CALL DROT( N, Q2( 1, J ), 1, Q2( 1, J-1 ), 1, CO, SI )
            END IF
   90    CONTINUE
C
  100 CONTINUE
C
C     Now T, Z, H are in block forms (1) and H22' is upper Hessenberg.
C
C     STEP 3: Apply periodic QZ algorithm to the generalized matrix
C
C                            -1    -1        -1    -1
C             product H22 T22   T11   H11 Z11   Z22   to transform H22'
C             to upper quasi-triangular form while T11, T22', Z11, Z22',
C             and H11 stay in upper triangular form.
C
C     Determine mode of computations.
C
      IQ = 1
      IF( LTRI .OR. LCMPQ1 .OR. LCMPQ2 .OR. LCMPU1 .OR. LCMPU2 ) THEN
         CMPQ = 'Initialize'
         IMAT =  6*MM + 1
         IWRK = 12*MM + 1
      ELSE
         CMPQ = 'No Computation'
         IMAT = 1
         IWRK = 6*MM + 1
      END IF
C
      IF( LTRI ) THEN
         CMPSC = 'Schur Form'
      ELSE
         CMPSC = 'Eigenvalues Only'
      END IF
C
C     Save matrices in structure that is required by MB03BD.
C
      CALL MA02AD( 'Lower', M, M, H( M+1, M+1 ), LDH, DWORK( IMAT ), M )
      CALL DCOPY(  M-1, H( M+1, M+2 ), LDH+1, DWORK( IMAT+1 ), M+1 )
      CALL DLASET( 'Lower', M-2, M-2, ZERO, ZERO, DWORK( IMAT+2 ), M )
      CALL MA02AD( 'Lower', M, M, T( M+1, M+1 ), LDT, DWORK( IMAT+MM ),
     $             M )
      CALL DLASET( 'Lower', M-1, M-1, ZERO, ZERO, DWORK( IMAT+MM+1 ),
     $             M )
      CALL DLACPY( 'Upper', M, M, T, LDT, DWORK( IMAT+2*MM ), M )
      CALL DLASET( 'Lower', M-1, M-1, ZERO, ZERO, DWORK( IMAT+2*MM+1 ),
     $             M )
      CALL DLACPY( 'Upper', M, M, H, LDH, DWORK( IMAT+3*MM ), M )
      CALL DLASET( 'Lower', M-1, M-1, ZERO, ZERO, DWORK( IMAT+3*MM+1 ),
     $             M )
      CALL DLACPY( 'Upper', M, M, Z, LDZ, DWORK( IMAT+4*MM ), M )
      CALL DLASET( 'Lower', M-1, M-1, ZERO, ZERO, DWORK( IMAT+4*MM+1 ),
     $             M )
      CALL MA02AD( 'Lower', M, M, Z( M+1, M+1 ), LDZ,
     $             DWORK( IMAT+5*MM ), M )
      CALL DLASET( 'Lower', M-1, M-1, ZERO, ZERO, DWORK( IMAT+5*MM+1 ),
     $             M )
C
      IWORK( M+1 ) =  1
      IWORK( M+2 ) = -1
      IWORK( M+3 ) = -1
      IWORK( M+4 ) =  1
      IWORK( M+5 ) = -1
      IWORK( M+6 ) = -1
C
C     Apply periodic QZ algorithm.
C     Workspace:          need   IWRK + MAX( 2*M, 48 ) - 1.
C     Integer workspace:  need   M + 18.
C
      CALL MB03BD( CMPSC, 'Careful', CMPQ, IDUM, 6, M, 1, 1, M,
     $             IWORK( M+1 ), DWORK( IMAT ), M, M, DWORK( IQ ), M, M,
     $             ALPHAR, ALPHAI, BETA, IWORK, IWORK( M+7 ),
     $             LIWORK-( M+6 ), DWORK( IWRK ), LDWORK-IWRK+1, IWARN,
     $             INFO )
      IF( IWARN.GT.0 .AND. IWARN.LT.M ) THEN
         INFO = 1
         RETURN
      ELSE IF( INFO.GT.0 ) THEN
         INFO = 2
         RETURN
      END IF
C
C     Compute the "non-negative" eigenvalues of the pencil aTZ - bH.
C     These are the eigenvalues with positive real parts or with
C     non-negative imaginary parts, when real parts are zero.
C
      DO 110 I = 1, M
         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
         IF( IWORK( I ).GE.2*EMIN .AND. IWORK( I ).LE.2*EMAX ) THEN
C
C           If B = SQRT(BASE**IWORK(i)) is between underflow and
C           overflow threshold, BETA(i) is divided by B.
C
            BETA(  I ) = BETA( I )/BASE**( HALF*IWORK( I ) )
            IWORK( I ) = 0
         ELSE
C
C           The eigenvalues are defined by ALPHAR, ALPHAI, BETA, and
C           IWORK, as for the SLICOT Library routine MB03BD.
C
            INFO = 3
            IF( MOD( IWORK( I ), 2 ).NE.0 )
     $         BETA( I ) =  BETA( I )/SQRB
            IWORK( I )   = IWORK( I )/2
         END IF
  110 CONTINUE
C
      IF( LTRI ) THEN
C
C        Update H.
C
         CALL DLACPY( 'Upper', M, M, DWORK( IMAT+3*MM ), M, H, LDH )
         CALL MA02AD( 'Full', M, M, DWORK( IMAT ), M, H( M+1, M+1 ),
     $                LDH )
         CALL DGEMM( 'Transpose', 'No Transpose', M, M, M, ONE,
     $               DWORK( IQ+3*MM ), M, H( 1, M+1 ), LDH, ZERO,
     $               DWORK( IMAT ), M )
         CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE,
     $               DWORK( IMAT ), M, DWORK, M, ZERO, H( 1, M+1 ),
     $               LDH )
C
C        Update T.
C
         CALL DLACPY( 'Upper', M, M, DWORK( IMAT+2*MM ), M, T, LDT )
         CALL DGEMM( 'Transpose', 'No Transpose', M, M, M, ONE,
     $               DWORK( IQ+3*MM ), M, T( 1, M+1 ), LDT, ZERO,
     $               DWORK( IMAT ), M )
         CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE,
     $               DWORK( IMAT ), M, DWORK( IQ+2*MM ), M, ZERO,
     $               T( 1, M+1 ), LDT )
         CALL MA02AD( 'Upper', M, M, DWORK( IMAT+MM ), M, T( M+1, M+1 ),
     $                LDT )
C
C        Update Z.
C
         CALL DLACPY( 'Upper', M, M, DWORK( IMAT+4*MM ), M, Z, LDZ )
         CALL DGEMM( 'Transpose', 'No Transpose', M, M, M, ONE,
     $               DWORK( IQ+5*MM ), M, Z( 1, M+1 ), LDZ, ZERO,
     $               DWORK( IMAT ), M )
         CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE,
     $               DWORK( IMAT ), M, DWORK, M, ZERO, Z( 1, M+1 ),
     $               LDZ )
         CALL MA02AD( 'Upper', M, M, DWORK( IMAT+5*MM ), M,
     $                Z( M+1, M+1 ), LDZ )
C
         IF( LCMPQ1 ) THEN
C
C           Update Q1.
C
            CALL DGEMM( 'No Transpose', 'No Transpose', N, M, M, ONE,
     $                  Q1, LDQ1, DWORK( IQ+3*MM ), M, ZERO,
     $                  DWORK( IMAT ), N )
            CALL DLACPY( 'Full', N, M, DWORK( IMAT ), N, Q1, LDQ1 )
            CALL DGEMM( 'No Transpose', 'No Transpose', N, M, M, ONE,
     $                  Q1( 1, M+1 ), LDQ1, DWORK( IQ+MM ), M, ZERO,
     $                  DWORK( IMAT ), N )
            CALL DLACPY( 'Full', N, M, DWORK( IMAT ), N, Q1( 1, M+1 ),
     $                   LDQ1 )
         END IF
C
         IF( LCMPQ2 ) THEN
C
C           Update Q2.
C
            CALL DGEMM( 'No Transpose', 'No Transpose', N, M, M, ONE,
     $                  Q2, LDQ2, DWORK( IQ+4*MM ), M, ZERO,
     $                  DWORK( IMAT ), N )
            CALL DLACPY( 'Full', N, M, DWORK( IMAT ), N, Q2, LDQ2 )
            CALL DGEMM( 'No Transpose', 'No Transpose', N, M, M, ONE,
     $                  Q2( 1, M+1 ), LDQ2, DWORK, M, ZERO,
     $                  DWORK( IMAT ), N )
            CALL DLACPY( 'Full', N, M, DWORK( IMAT ), N, Q2( 1, M+1 ),
     $                   LDQ2 )
         END IF
C
         IF( LCMPU1 ) THEN
C
C           Update U11 and U12.
C
            CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE,
     $                  U11, LDU11, DWORK( IQ+2*MM ), M, ZERO,
     $                  DWORK( IMAT ), M )
            CALL DLACPY( 'Full', M, M, DWORK( IMAT ), M, U11, LDU11 )
            CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE,
     $                  U12, LDU12, DWORK( IQ+2*MM ), M, ZERO,
     $                  DWORK( IMAT ), M )
            CALL DLACPY( 'Full', M, M, DWORK( IMAT ), M, U12, LDU12 )
         END IF
C
         IF( LCMPU2 ) THEN
C
C           Update U21 and U22.
C
            CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE,
     $                  U21, LDU21, DWORK( IQ+5*MM ), M, ZERO,
     $                  DWORK( IMAT ), M )
            CALL DLACPY( 'Full', M, M, DWORK( IMAT ), M, U21, LDU21 )
            CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE,
     $                  U22, LDU22, DWORK( IQ+5*MM ), M, ZERO,
     $                  DWORK( IMAT ), M )
            CALL DLACPY( 'Full', M, M, DWORK( IMAT ), M, U22, LDU22 )
         END IF
      END IF
C
      DWORK( 1 ) = OPTDW
      DWORK( 2 ) = BASE
      RETURN
C *** Last line of MB04AD ***
      END


	FUNCTION BXPA(F)
C
C	THIS FUNCTION RETURNS THE GAIN OF THE WIND X SEARCH COIL,PREAMP AND
C	INPUT STAGE ON THE 212 BOARD. (COMPLEX)
C
C
	COMPLEX BXPA
	COMPLEX CGAIN,Y1,Z1,Y2,Z2
	DATA Q,T0,F0 / 1.47,.749,1650./     		! T0 is in Volts/nT
	DATA C10,R1,R2,C1/ .952E-6, 49.9E3, 1.E6, 1.E-9/
	DATA TWOPI /6.2831853/
C
C
	BXPA=0.
	IF(F.EQ.0.) RETURN
	W = TWOPI*F
C	OUTPUT OF SEARCH COIL PLUS PREAMP, VOLTS/nT
	CGAIN = T0/CMPLX(1.,Q*(F/F0 - F0/F))
C
C	EFFECT OF INPUT ON 212 BOARD
C
	Y2 = CMPLX(1./R2,W*C1)
	Z1 = CMPLX(R1, -1./W/C10)
	CGAIN = CGAIN/(Z1*Y2)
C
	BXPA = CGAIN
	RETURN
	END


      subroutine DUREV( XT, TX, NDIM, RCOND, IWORK, WORK)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c>> 1996-03-30 DUREV Krogh  Added external statement.
c>> 1994-10-20 DUREV Krogh  Changes to use M77CON
c>> 1994-08-04 DUREV CLL Changed name of common from UCOM to UCOM1.
c>> 1992-02-17 CLL
c>> 1990-12-12 CLL DUREV  Initial code.
c     This subr does what is sometimes called series reversion.
c     Regarding N variables x sub j as functions of
c     N variables t sub i, and given a set of values of the t's and
c     the values of the x's and the 1st and 2nd partial derivatives of
c     the x's with respect to the t's evaluated at this set of t values,
c     this subr computes values at this point of the 1st and 2nd partial
c     derivatives of the t's with respect to the x's.
c     It is required that the matrix of 1st partials of the x's with
c     respect to the t's must be nonsingular.
c     ------------------------------------------------------------------
c                   Subroutine Arguments
c
c  XT(,) [in float]  Array containing values of N variables x sub 1
c     through x sub N, along with their partial derivatives of orders
c     1 and 2 with respect to N variables t sub 1 through t sub N, all
c     evaluated at the set of t values given in TX().
c     Data for x sub i is in XT(1:(N+2)*(N+1)/2),i).
c
c  TX(,) [inout float]  On entry TX(1,i), i = 1,..., N, must contain
c     values of the N variables t sub 1 thru t sub N.
c     Other values in the array TX() on entry are irrelevant.
c     This subr will compute 1st and 2nd partials of the t's with
c     respect to the x's and store these results in
c     TX(2:(N+2)*(N+1)/2),1:N).
c
c  NDIM  [in, integer]  Leading dimension for the arrays XT() and TX().
c     Require NDIM .ge. (N+2)*(N+1)/2.
c
c  RCOND  [out float]  Estimate of the reciprocal condition number of
c     the matrix of 1st partials of x's with respect to the t's.
c     RCOND will satisfy 0.0 .le. RCOND .le. 1.0.
c     Values near 1.0 indicate a well conditioned matrix, small values
c     indicate poor conditioning, zero indicates a singular matrix.  In
c     this latter case the subr will return without computing partials
c     of the t's with respect to the x's.
c
c  IWORK()  [scratch, integer]  Integer work space for this subroutine.
c
c  WORK(N,N,3) [scratch, float]  Floating-point work space for this
c     subroutine.  We use this as 3 NxN arrays.  In the calls to DGECO
c     and DGEI the last argument needs only N scratch locations.
c     ------------------------------------------------------------------
c              N, M1, M2 in common /UCOM1/
c
c  N [in]  Number of components in the (conceptual) x and t vectors.
c  M1, M2 [in]  We assume 0 .le. M1 .le. M2 .le. 2.  In other subrs of
c     the [D/S]UCOMP package, M1 and M2 select computation of partial
c     derivatives of orders M1 through M2, assuming all needed partial
c     derivatives of orders less than M1 are available.
c     This subr differs from others in the [D/S]UCOMP package in that
c     derivs of order 0, i.e., the values of t sub i for i = 1, ..., N,
c     associated with x sub j for j = 1, ..., N, must always be input to
c     this subr.  Thus this subr treats M1 = 0 like M1 = 1.
c     If M2 .eq. 0 this subr does nothing.
c     If M2 .eq. 1 this subr computes first partials of t w.r.t. x.
c     If M1 .le. 1 and M2 .eq. 2 this subr computes first and second
c     partials of t w.r.t. x.
c     If M1 .eq. 2 and M2 .eq. 2 this subr assumes first partials of t
c     w.r.t. x are available and computes second partials of t w.r.t. x.
c     ------------------------------------------------------------------
c--D replaces "?": ?UREV, ?DOT, ?GECO, ?GEI
c     Also uses ERMSG
c     ------------------------------------------------------------------
      external DDOT
      double precision DDOT
      integer N, M1, M2
      common/UCOM1/N,M1,M2
      save /UCOM1/
      integer I, IT, ITXX, IX, IXTT, IWORK(N), J, K, NDIM
      double precision RCOND, TX(NDIM,N), XT(NDIM,N), WORK(N,N,3)
c     ------------------------------------------------------------------
      if(M2 .eq. 0) return
      if(M1 .le. 1) then
c          Copy the matrix of 1st partials of x w.r.t. t to WORK2(*,*,1)
c
      do 20 IX = 1,N
         do 10 IT = 1,N
            WORK(IX,IT,1) = XT(1+IT,IX)
   10    continue
   20 continue
c
c        Compute an LU factorization and RCOND for this Jacobian matrix.
c
      call DGECO(WORK(1,1,1), N, N, IWORK, RCOND, WORK(1,1,3))
      if(RCOND .eq. 0.0d0) then
         call ERMSG('DUREV', 6, 0, 'Singular Jacobian matrix.','.')
         return
      endif
c
c        Compute the inverse Jacobian matrix in WORK(*,*,1) and copy
c        its elements into TX().  These elements are the 1st partials of
c        the t's w.r.t. the x's.
c
      call DGEI(WORK(1,1,1), N, N, IWORK, WORK(1,1,3))
c
      do 40 IT = 1,N
         do 30 IX = 1,N
            TX(1+IX,IT) = WORK(IT,IX,1)
   30    continue
   40 continue
      else
c
c          Copy 1st partials of t's w.r.t. x's from TX() to WORK(*,*,1).
c
      do 60 IT = 1,N
         do 50 IX = 1,N
            WORK(IT,IX,1) = TX(1+IX,IT)
   50    continue
   60 continue
      endif
c     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      if(M2 .lt. 2) return
c     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
c                 Main loop on K to compute 2nd partials
c                 of t sub K w.r.t. the x's.
c
      do 200 K = 1,N
c
c           Compute weighted sum of the Hessian matrices of the x's
c           using the 1st partial of t sub K w.r.t. x sub i as the
c           weight for the Hessian matrix of x sub i.
c           Store the resulting symmetric matrix in WORK(*,*,2).
c
         IXTT = 1 + N
         do 80 I = 1,N
            do 70 J = 1,I
               IXTT = IXTT + 1
               WORK(I,J,2) = DDOT(N, WORK(K,1,1),N, XT(IXTT,1),NDIM)
               WORK(J,I,2) = WORK(I,J,2)
   70       continue
   80    continue
c
c           Multiply the matrix in WORK(*,*,2) by WORK(*,*,1) from the
c           right and by the transpose of WORK(*,*,1) from the left and
c           invert the sign.  Put the result of the first multiplication
c           into WORK(*,*,3) and the lower triangle of the (symmetric)
c           final result into TX(*,K).
c
         do 100 I = 1,N
            do 90 J = 1,N
               WORK(I,J,3) = DDOT(N, WORK(I,1,2),N, WORK(1,J,1),1)
   90       continue
  100    continue
c
         ITXX = 1 + N
         do 120 I = 1,N
            do 110 J = 1,I
               ITXX = ITXX + 1
               TX(ITXX,K) = -DDOT(N, WORK(1,I,1),1, WORK(1,J,3),1)
  110       continue
  120    continue
  200 continue
      return
      end


*DECK QC25F
      SUBROUTINE QC25F (F, A, B, OMEGA, INTEGR, NRMOM, MAXP1, KSAVE,
     +   RESULT, ABSERR, NEVAL, RESABS, RESASC, MOMCOM, CHEBMO)
C***BEGIN PROLOGUE  QC25F
C***PURPOSE  To compute the integral I=Integral of F(X) over (A,B)
C            Where W(X) = COS(OMEGA*X) Or (WX)=SIN(OMEGA*X)
C            and to compute J=Integral of ABS(F) over (A,B). For small
C            value of OMEGA or small intervals (A,B) 15-point GAUSS-
C            KRONROD Rule used. Otherwise generalized CLENSHAW-CURTIS us
C***LIBRARY   SLATEC (QUADPACK)
C***CATEGORY  H2A2A2
C***TYPE      SINGLE PRECISION (QC25F-S, DQC25F-D)
C***KEYWORDS  CLENSHAW-CURTIS METHOD, GAUSS-KRONROD RULES,
C             INTEGRATION RULES FOR FUNCTIONS WITH COS OR SIN FACTOR,
C             QUADPACK, QUADRATURE
C***AUTHOR  Piessens, Robert
C             Applied Mathematics and Programming Division
C             K. U. Leuven
C           de Doncker, Elise
C             Applied Mathematics and Programming Division
C             K. U. Leuven
C***DESCRIPTION
C
C        Integration rules for functions with COS or SIN factor
C        Standard fortran subroutine
C        Real version
C
C        PARAMETERS
C         ON ENTRY
C           F      - Real
C                    Function subprogram defining the integrand
C                    function F(X). The actual name for F needs to
C                    be declared E X T E R N A L in the calling program.
C
C           A      - Real
C                    Lower limit of integration
C
C           B      - Real
C                    Upper limit of integration
C
C           OMEGA  - Real
C                    Parameter in the WEIGHT function
C
C           INTEGR - Integer
C                    Indicates which WEIGHT function is to be used
C                       INTEGR = 1   W(X) = COS(OMEGA*X)
C                       INTEGR = 2   W(X) = SIN(OMEGA*X)
C
C           NRMOM  - Integer
C                    The length of interval (A,B) is equal to the length
C                    of the original integration interval divided by
C                    2**NRMOM (we suppose that the routine is used in an
C                    adaptive integration process, otherwise set
C                    NRMOM = 0). NRMOM must be zero at the first call.
C
C           MAXP1  - Integer
C                    Gives an upper bound on the number of Chebyshev
C                    moments which can be stored, i.e. for the
C                    intervals of lengths ABS(BB-AA)*2**(-L),
C                    L = 0,1,2, ..., MAXP1-2.
C
C           KSAVE  - Integer
C                    Key which is one when the moments for the
C                    current interval have been computed
C
C         ON RETURN
C           RESULT - Real
C                    Approximation to the integral I
C
C           ABSERR - Real
C                    Estimate of the modulus of the absolute
C                    error, which should equal or exceed ABS(I-RESULT)
C
C           NEVAL  - Integer
C                    Number of integrand evaluations
C
C           RESABS - Real
C                    Approximation to the integral J
C
C           RESASC - Real
C                    Approximation to the integral of ABS(F-I/(B-A))
C
C         ON ENTRY AND RETURN
C           MOMCOM - Integer
C                    For each interval length we need to compute the
C                    Chebyshev moments. MOMCOM counts the number of
C                    intervals for which these moments have already been
C                    computed. If NRMOM.LT.MOMCOM or KSAVE = 1, the
C                    Chebyshev moments for the interval (A,B) have
C                    already been computed and stored, otherwise we
C                    compute them and we increase MOMCOM.
C
C           CHEBMO - Real
C                    Array of dimension at least (MAXP1,25) containing
C                    the modified Chebyshev moments for the first MOMCOM
C                    MOMCOM interval lengths
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  QCHEB, QK15W, QWGTF, R1MACH, SGTSL
C***REVISION HISTORY  (YYMMDD)
C   810101  DATE WRITTEN
C   861211  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C***END PROLOGUE  QC25F
C
      REAL A,ABSERR,AC,AN,AN2,AS,ASAP,ASS,B,CENTR,CHEBMO,
     1  CHEB12,CHEB24,CONC,CONS,COSPAR,D,QWGTF,
     2  D1,R1MACH,D2,ESTC,ESTS,F,FVAL,HLGTH,OFLOW,OMEGA,PARINT,PAR2,
     3  PAR22,P2,P3,P4,RESABS,RESASC,RESC12,RESC24,RESS12,RESS24,
     4  RESULT,SINPAR,V,X
      INTEGER I,IERS,INTEGR,ISYM,J,K,KSAVE,M,MAXP1,MOMCOM,NEVAL,
     1  NOEQU,NOEQ1,NRMOM
C
      DIMENSION CHEBMO(MAXP1,25),CHEB12(13),CHEB24(25),D(25),D1(25),
     1  D2(25),FVAL(25),V(28),X(11)
C
      EXTERNAL F, QWGTF
C
C           THE VECTOR X CONTAINS THE VALUES COS(K*PI/24)
C           K = 1, ...,11, TO BE USED FOR THE CHEBYSHEV EXPANSION OF F
C
      SAVE X
      DATA X(1),X(2),X(3),X(4),X(5),X(6),X(7),X(8),X(9),
     1  X(10),X(11)/
     2     0.9914448613738104E+00,     0.9659258262890683E+00,
     3     0.9238795325112868E+00,     0.8660254037844386E+00,
     4     0.7933533402912352E+00,     0.7071067811865475E+00,
     5     0.6087614290087206E+00,     0.5000000000000000E+00,
     6     0.3826834323650898E+00,     0.2588190451025208E+00,
     7     0.1305261922200516E+00/
C
C           LIST OF MAJOR VARIABLES
C           -----------------------
C
C           CENTR  - MID POINT OF THE INTEGRATION INTERVAL
C           HLGTH  - HALF-LENGTH OF THE INTEGRATION INTERVAL
C           FVAL   - VALUE OF THE FUNCTION F AT THE POINTS
C                    (B-A)*0.5*COS(K*PI/12) + (B+A)*0.5,
C                    K = 0, ..., 24
C           CHEB12 - COEFFICIENTS OF THE CHEBYSHEV SERIES EXPANSION
C                    OF DEGREE 12, FOR THE FUNCTION F, IN THE
C                    INTERVAL (A,B)
C           CHEB24 - COEFFICIENTS OF THE CHEBYSHEV SERIES EXPANSION
C                    OF DEGREE 24, FOR THE FUNCTION F, IN THE
C                    INTERVAL (A,B)
C           RESC12 - APPROXIMATION TO THE INTEGRAL OF
C                    COS(0.5*(B-A)*OMEGA*X)*F(0.5*(B-A)*X+0.5*(B+A))
C                    OVER (-1,+1), USING THE CHEBYSHEV SERIES
C                    EXPANSION OF DEGREE 12
C           RESC24 - APPROXIMATION TO THE SAME INTEGRAL, USING THE
C                    CHEBYSHEV SERIES EXPANSION OF DEGREE 24
C           RESS12 - THE ANALOGUE OF RESC12 FOR THE SINE
C           RESS24 - THE ANALOGUE OF RESC24 FOR THE SINE
C
C
C           MACHINE DEPENDENT CONSTANT
C           --------------------------
C
C           OFLOW IS THE LARGEST POSITIVE MAGNITUDE.
C
C***FIRST EXECUTABLE STATEMENT  QC25F
      OFLOW = R1MACH(2)
C
      CENTR = 0.5E+00*(B+A)
      HLGTH = 0.5E+00*(B-A)
      PARINT = OMEGA*HLGTH
C
C           COMPUTE THE INTEGRAL USING THE 15-POINT GAUSS-KRONROD
C           FORMULA IF THE VALUE OF THE PARAMETER IN THE INTEGRAND
C           IS SMALL.
C
      IF(ABS(PARINT).GT.0.2E+01) GO TO 10
      CALL QK15W(F,QWGTF,OMEGA,P2,P3,P4,INTEGR,A,B,RESULT,
     1  ABSERR,RESABS,RESASC)
      NEVAL = 15
      GO TO 170
C
C           COMPUTE THE INTEGRAL USING THE GENERALIZED CLENSHAW-
C           CURTIS METHOD.
C
   10 CONC = HLGTH*COS(CENTR*OMEGA)
      CONS = HLGTH*SIN(CENTR*OMEGA)
      RESASC = OFLOW
      NEVAL = 25
C
C           CHECK WHETHER THE CHEBYSHEV MOMENTS FOR THIS INTERVAL
C           HAVE ALREADY BEEN COMPUTED.
C
      IF(NRMOM.LT.MOMCOM.OR.KSAVE.EQ.1) GO TO 120
C
C           COMPUTE A NEW SET OF CHEBYSHEV MOMENTS.
C
      M = MOMCOM+1
      PAR2 = PARINT*PARINT
      PAR22 = PAR2+0.2E+01
      SINPAR = SIN(PARINT)
      COSPAR = COS(PARINT)
C
C           COMPUTE THE CHEBYSHEV MOMENTS WITH RESPECT TO COSINE.
C
      V(1) = 0.2E+01*SINPAR/PARINT
      V(2) = (0.8E+01*COSPAR+(PAR2+PAR2-0.8E+01)*SINPAR/
     1  PARINT)/PAR2
      V(3) = (0.32E+02*(PAR2-0.12E+02)*COSPAR+(0.2E+01*
     1  ((PAR2-0.80E+02)*PAR2+0.192E+03)*SINPAR)/
     2  PARINT)/(PAR2*PAR2)
      AC = 0.8E+01*COSPAR
      AS = 0.24E+02*PARINT*SINPAR
      IF(ABS(PARINT).GT.0.24E+02) GO TO 30
C
C           COMPUTE THE CHEBYSHEV MOMENTS AS THE
C           SOLUTIONS OF A BOUNDARY VALUE PROBLEM WITH 1
C           INITIAL VALUE (V(3)) AND 1 END VALUE (COMPUTED
C           USING AN ASYMPTOTIC FORMULA).
C
      NOEQU = 25
      NOEQ1 = NOEQU-1
      AN = 0.6E+01
      DO 20 K = 1,NOEQ1
        AN2 = AN*AN
        D(K) = -0.2E+01*(AN2-0.4E+01)*(PAR22-AN2-AN2)
        D2(K) = (AN-0.1E+01)*(AN-0.2E+01)*PAR2
        D1(K+1) = (AN+0.3E+01)*(AN+0.4E+01)*PAR2
        V(K+3) = AS-(AN2-0.4E+01)*AC
        AN = AN+0.2E+01
   20 CONTINUE
      AN2 = AN*AN
      D(NOEQU) = -0.2E+01*(AN2-0.4E+01)*(PAR22-AN2-AN2)
      V(NOEQU+3) = AS-(AN2-0.4E+01)*AC
      V(4) = V(4)-0.56E+02*PAR2*V(3)
      ASS = PARINT*SINPAR
      ASAP = (((((0.210E+03*PAR2-0.1E+01)*COSPAR-(0.105E+03*PAR2
     1  -0.63E+02)*ASS)/AN2-(0.1E+01-0.15E+02*PAR2)*COSPAR
     2  +0.15E+02*ASS)/AN2-COSPAR+0.3E+01*ASS)/AN2-COSPAR)/AN2
      V(NOEQU+3) = V(NOEQU+3)-0.2E+01*ASAP*PAR2*(AN-0.1E+01)*
     1   (AN-0.2E+01)
C
C           SOLVE THE TRIDIAGONAL SYSTEM BY MEANS OF GAUSSIAN
C           ELIMINATION WITH PARTIAL PIVOTING.
C
      CALL SGTSL(NOEQU,D1,D,D2,V(4),IERS)
      GO TO 50
C
C           COMPUTE THE CHEBYSHEV MOMENTS BY MEANS OF FORWARD
C           RECURSION.
C
   30 AN = 0.4E+01
      DO 40 I = 4,13
        AN2 = AN*AN
        V(I) = ((AN2-0.4E+01)*(0.2E+01*(PAR22-AN2-AN2)*V(I-1)-AC)
     1  +AS-PAR2*(AN+0.1E+01)*(AN+0.2E+01)*V(I-2))/
     2  (PAR2*(AN-0.1E+01)*(AN-0.2E+01))
        AN = AN+0.2E+01
   40 CONTINUE
   50 DO 60 J = 1,13
        CHEBMO(M,2*J-1) = V(J)
   60 CONTINUE
C
C           COMPUTE THE CHEBYSHEV MOMENTS WITH RESPECT TO SINE.
C
      V(1) = 0.2E+01*(SINPAR-PARINT*COSPAR)/PAR2
      V(2) = (0.18E+02-0.48E+02/PAR2)*SINPAR/PAR2
     1  +(-0.2E+01+0.48E+02/PAR2)*COSPAR/PARINT
      AC = -0.24E+02*PARINT*COSPAR
      AS = -0.8E+01*SINPAR
      IF(ABS(PARINT).GT.0.24E+02) GO TO 80
C
C           COMPUTE THE CHEBYSHEV MOMENTS AS THE
C           SOLUTIONS OF A BOUNDARY VALUE PROBLEM WITH 1
C           INITIAL VALUE (V(2)) AND 1 END VALUE (COMPUTED
C           USING AN ASYMPTOTIC FORMULA).
C
      AN = 0.5E+01
      DO 70 K = 1,NOEQ1
        AN2 = AN*AN
        D(K) = -0.2E+01*(AN2-0.4E+01)*(PAR22-AN2-AN2)
        D2(K) = (AN-0.1E+01)*(AN-0.2E+01)*PAR2
        D1(K+1) = (AN+0.3E+01)*(AN+0.4E+01)*PAR2
        V(K+2) = AC+(AN2-0.4E+01)*AS
        AN = AN+0.2E+01
   70 CONTINUE
      AN2 = AN*AN
      D(NOEQU) = -0.2E+01*(AN2-0.4E+01)*(PAR22-AN2-AN2)
      V(NOEQU+2) = AC+(AN2-0.4E+01)*AS
      V(3) = V(3)-0.42E+02*PAR2*V(2)
      ASS = PARINT*COSPAR
      ASAP = (((((0.105E+03*PAR2-0.63E+02)*ASS+(0.210E+03*PAR2
     1  -0.1E+01)*SINPAR)/AN2+(0.15E+02*PAR2-0.1E+01)*SINPAR-
     2  0.15E+02*ASS)/AN2-0.3E+01*ASS-SINPAR)/AN2-SINPAR)/AN2
      V(NOEQU+2) = V(NOEQU+2)-0.2E+01*ASAP*PAR2*(AN-0.1E+01)
     1  *(AN-0.2E+01)
C
C           SOLVE THE TRIDIAGONAL SYSTEM BY MEANS OF GAUSSIAN
C           ELIMINATION WITH PARTIAL PIVOTING.
C
      CALL SGTSL(NOEQU,D1,D,D2,V(3),IERS)
      GO TO 100
C
C           COMPUTE THE CHEBYSHEV MOMENTS BY MEANS OF
C           FORWARD RECURSION.
C
   80 AN = 0.3E+01
      DO 90 I = 3,12
        AN2 = AN*AN
        V(I) = ((AN2-0.4E+01)*(0.2E+01*(PAR22-AN2-AN2)*V(I-1)+AS)
     1  +AC-PAR2*(AN+0.1E+01)*(AN+0.2E+01)*V(I-2))
     2  /(PAR2*(AN-0.1E+01)*(AN-0.2E+01))
        AN = AN+0.2E+01
   90 CONTINUE
  100 DO 110 J = 1,12
        CHEBMO(M,2*J) = V(J)
  110 CONTINUE
  120 IF (NRMOM.LT.MOMCOM) M = NRMOM+1
       IF (MOMCOM.LT.MAXP1-1.AND.NRMOM.GE.MOMCOM) MOMCOM = MOMCOM+1
C
C           COMPUTE THE COEFFICIENTS OF THE CHEBYSHEV EXPANSIONS
C           OF DEGREES 12 AND 24 OF THE FUNCTION F.
C
      FVAL(1) = 0.5E+00*F(CENTR+HLGTH)
      FVAL(13) = F(CENTR)
      FVAL(25) = 0.5E+00*F(CENTR-HLGTH)
      DO 130 I = 2,12
        ISYM = 26-I
        FVAL(I) = F(HLGTH*X(I-1)+CENTR)
        FVAL(ISYM) = F(CENTR-HLGTH*X(I-1))
  130 CONTINUE
      CALL QCHEB(X,FVAL,CHEB12,CHEB24)
C
C           COMPUTE THE INTEGRAL AND ERROR ESTIMATES.
C
      RESC12 = CHEB12(13)*CHEBMO(M,13)
      RESS12 = 0.0E+00
      K = 11
      DO 140 J = 1,6
        RESC12 = RESC12+CHEB12(K)*CHEBMO(M,K)
        RESS12 = RESS12+CHEB12(K+1)*CHEBMO(M,K+1)
        K = K-2
  140 CONTINUE
      RESC24 = CHEB24(25)*CHEBMO(M,25)
      RESS24 = 0.0E+00
      RESABS = ABS(CHEB24(25))
      K = 23
      DO 150 J = 1,12
        RESC24 = RESC24+CHEB24(K)*CHEBMO(M,K)
        RESS24 = RESS24+CHEB24(K+1)*CHEBMO(M,K+1)
        RESABS = ABS(CHEB24(K))+ABS(CHEB24(K+1))
        K = K-2
  150 CONTINUE
      ESTC = ABS(RESC24-RESC12)
      ESTS = ABS(RESS24-RESS12)
      RESABS = RESABS*ABS(HLGTH)
      IF(INTEGR.EQ.2) GO TO 160
      RESULT = CONC*RESC24-CONS*RESS24
      ABSERR = ABS(CONC*ESTC)+ABS(CONS*ESTS)
      GO TO 170
  160 RESULT = CONC*RESS24+CONS*RESC24
      ABSERR = ABS(CONC*ESTS)+ABS(CONS*ESTC)
  170 RETURN
      END


Function fjet(x, wgt)
  Implicit Double Precision (A-H, O-Z)
  Real hipr1(100), hint1(100)
  Common /hparnt/hipr1, ihpr2(50), hint1, ihnt2(50)
  Dimension x(10)
  Save
  pt2 = dble(hint1(1)**2/4.0-hipr1(8)**2)*x(1) + dble(hipr1(8))**2
  xt = 2.0D0*dsqrt(pt2)/dble(hint1(1))
  ymx1 = dlog(1.0D0/xt+dsqrt(1.0D0/xt**2-1.0D0))
  y1 = 2.0D0*ymx1*x(2) - ymx1
  ymx2 = dlog(2.0D0/xt-dexp(y1))
  ymn2 = dlog(2.0D0/xt-dexp(-y1))
  y2 = (ymx2+ymn2)*x(3) - ymn2
  fjet = 2.0D0*ymx1*(ymx2+ymn2)*dble(hint1(1)**2/4.0-hipr1(8)**2)*g(y1, y2, pt2)/2.0D0
  Return
End Function fjet


cc Copyright (C) 2004-2009: Leslie Greengard and June-Yub Lee
cc Contact: greengard@cims.nyu.edu
cc
cc This software is being released under a FreeBSD license
cc (see license.txt in this directory).
cc
      program testfft
      implicit none
c
      integer i,ier,iflag,j,k1,k2,k3,mx,ms,mt,mu,n1,n2,n3,nj,nk
      parameter (mx=1000 000)
      real*8 xj(mx),yj(mx),zj(mx)
      real *8 sk(mx),tk(mx),uk(mx)
      real*8 err,pi,eps,salg,ealg
      real*8 t0,t1,second
      parameter (pi=3.141592653589793238462643383279502884197d0)
      complex*16 cj(mx),cj0(mx),cj1(mx)
      complex*16 fk0(mx),fk1(mx)
c
c     --------------------------------------------------
c     create some test data
c     --------------------------------------------------
c
      ms = 24/2
      mt = 16/2
      mu = 18/2
      n1 = 16/2
      n2 = 18/2
      n3 = 24/2
      nj = n1*n2*n3
      do k3 = -n3/2, (n3-1)/2
         do k2 = -n2/2, (n2-1)/2
            do k1 = -n1/2, (n1-1)/2
               j =  1 + (k1+n1/2+1) + (k2+n2/2)*n1 + (k3+n3/2)*n1*n2
               xj(j) = pi*dcos(-pi*k1/n1)
               yj(j) = pi*dcos(-pi*k2/n2)
               zj(j) = pi*dcos(-pi*k3/n3)
               cj(j) = dcmplx(dsin(pi*j/n1),dcos(pi*j/n2))
            enddo
         enddo
      enddo
c
c     -----------------------
c     start tests
c     -----------------------
c
      iflag = 1
      print*,'Starting 3D testing: ', 'nj =',nj, 'ms,mt,mu =',ms,mt,mu
      do i = 1,4
         if (i.eq.1) eps=1d-4
         if (i.eq.2) eps=1d-8
         if (i.eq.3) eps=1d-12
         if (i.eq.4) eps=1d-16
c extended/quad precision tests
         if (i.eq.5) eps=1d-20
         if (i.eq.6) eps=1d-24
         if (i.eq.7) eps=1d-28
         if (i.eq.8) eps=1d-32
	 print*,' '
	 print*,' Requested precision eps =',eps
	 print*,' '
c
c     -----------------------
c     call 3D Type 1 method
c     -----------------------
c
         call dirft3d1(nj,xj,yj,zj,cj,iflag,ms,mt,mu,fk0)
         call nufft3d1f90(nj,xj,yj,zj,cj,iflag,eps,ms,mt,mu,fk1,ier)
         print *, ' ier = ',ier
         call errcomp(fk0,fk1,ms*mt,err)
         print *, ' type 1 err = ',err
c
c     -----------------------
c      call 3D Type 2 method
c     -----------------------
         call dirft3d2(nj,xj,yj,zj,cj0,iflag,ms,mt,mu,fk0)
         call nufft3d2f90(nj,xj,yj,zj,cj1,iflag,eps,ms,mt,mu,fk1,ier)
         print *, ' ier = ',ier
         call errcomp(cj0,cj1,nj,err)
         print *, ' type 2 err = ',err
c
c     -----------------------
c      call 3D Type3 method
c     -----------------------
         nk = ms*mt*mu
         do k1 = 1, nk
            sk(k1) = 12*(dcos(k1*pi/nk))
            tk(k1) = 8*(dsin(-pi/2+k1*pi/nk))
            uk(k1) = 10*(dcos(k1*pi/nk))
         enddo

         call dirft3d3(nj,xj,yj,zj,cj,iflag,nk,sk,tk,uk,fk0)
         call nufft3d3f90(nj,xj,yj,zj,cj,iflag,eps,nk,sk,tk,uk,fk1,ier)
         print *, ' ier = ',ier
         call errcomp(fk0,fk1,nk,err)
         print *, ' type 3 err = ',err
      enddo
      stop
      end
c
c
c
c
c
      subroutine errcomp(fk0,fk1,n,err)
      implicit none
      integer k,n
      complex*16 fk0(n), fk1(n)
      real *8 salg,ealg,err
c
      ealg = 0d0
      salg = 0d0
      do k = 1, n
         ealg = ealg + cdabs(fk1(k)-fk0(k))**2
         salg = salg + cdabs(fk0(k))**2
      enddo
      err =sqrt(ealg/salg)
      return
      end


! MD5 of template: de2e124b77d41b637ba47e23b573548c
! Statistics
!
! ------------------------------------------------------------------------------
! Copyright (c) 2009-13, Thomas P. Robitaille
!
! All rights reserved.
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met:
!
!  * Redistributions of source code must retain the above copyright notice, this
!    list of conditions and the following disclaimer.
!
!  * 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.
!
! 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.
! ------------------------------------------------------------------------------

module lib_statistics

  use lib_array
  implicit none
  save

  private

  integer,parameter :: idp = selected_int_kind(13)
  integer,parameter :: sp = selected_real_kind(p=6,r=37)
  integer,parameter :: dp = selected_real_kind(p=15,r=307)

  public :: mean
  interface mean
     module procedure mean_sp
     module procedure mean_dp
  end interface mean

  public :: median
  interface median
     module procedure median_sp
     module procedure median_dp
  end interface median

  public :: quantile
  interface quantile
     module procedure quantile_sp
     module procedure quantile_dp
  end interface quantile

  public :: variance
  interface variance
     module procedure variance_sp
     module procedure variance_dp
  end interface variance

  public :: clipped_mean
  interface clipped_mean
     module procedure clipped_mean_sp
     module procedure clipped_mean_dp
  end interface clipped_mean

contains

  real(dp) function mean_dp(x, mask)
    implicit none
    real(dp),intent(in) :: x(:)
    logical,intent(in),optional :: mask(:)
    if(present(mask)) then
       mean_dp = sum(x, mask=mask)/size(x)
    else
       mean_dp = sum(x)/size(x)
    end if
  end function mean_dp

  real(dp) function median_dp(x)
    implicit none
    real(dp),intent(in) :: x(:)
    real(dp),dimension(size(x)) :: x_sorted
    integer :: n
    n = size(x)
    x_sorted = x
    call quicksort(x_sorted)
    if(mod(n,2).eq.0) then
       median_dp=(x_sorted(n/2)+x_sorted(n/2+1))/2.
    else
       median_dp=x_sorted((n-1)/2+1)
    end if
  end function median_dp

  real(dp) function quantile_dp(x, percent, mask)
    implicit none
    real(dp),intent(in) :: x(:), percent
    logical,intent(in),optional :: mask(:)
    real(dp),allocatable :: x_sorted(:)
    integer :: n, ipos
    if(present(mask)) then
       n = count(mask)
       allocate(x_sorted(n))
       x_sorted = pack(x, mask)
    else
       n = size(x)
       allocate(x_sorted(n))
       x_sorted = x
    end if
    call quicksort(x_sorted)
    if(percent >= 100._dp) then
       ipos = n
    else if(percent <= 0._dp) then
       ipos = 1
    else
       ipos=nint(percent/100._dp*real(n-1, dp))+1
    end if
    quantile_dp=x_sorted(ipos)
  end function quantile_dp

  real(dp) function variance_dp(x, mask)
    implicit none
    real(dp),intent(in) :: x(:)
    logical,intent(in),optional :: mask(:)
    variance_dp = sum(x-mean(x, mask=mask)**2._dp)/(size(x)-1)
  end function variance_dp

  real(dp) function clipped_mean_dp(x, n)
    implicit none
    real(dp),intent(in) :: x(:)
    integer,intent(in) :: n
    logical,dimension(size(x)) :: keep
    real(dp) :: sigma
    integer :: n_before
    keep = .true.
    n_before = 0
    do
       clipped_mean_dp = mean(x, mask=keep)
       sigma = sqrt(variance(x, mask=keep))
       keep = keep .and. abs(x-clipped_mean_dp) < real(n, dp) * sigma
       if(count(keep)==n_before) exit
       n_before = count(keep)
    end do
  end function clipped_mean_dp

  real(sp) function mean_sp(x, mask)
    implicit none
    real(sp),intent(in) :: x(:)
    logical,intent(in),optional :: mask(:)
    if(present(mask)) then
       mean_sp = sum(x, mask=mask)/size(x)
    else
       mean_sp = sum(x)/size(x)
    end if
  end function mean_sp

  real(sp) function median_sp(x)
    implicit none
    real(sp),intent(in) :: x(:)
    real(sp),dimension(size(x)) :: x_sorted
    integer :: n
    n = size(x)
    x_sorted = x
    call quicksort(x_sorted)
    if(mod(n,2).eq.0) then
       median_sp=(x_sorted(n/2)+x_sorted(n/2+1))/2.
    else
       median_sp=x_sorted((n-1)/2+1)
    end if
  end function median_sp

  real(sp) function quantile_sp(x, percent, mask)
    implicit none
    real(sp),intent(in) :: x(:), percent
    logical,intent(in),optional :: mask(:)
    real(sp),allocatable :: x_sorted(:)
    integer :: n, ipos
    if(present(mask)) then
       n = count(mask)
       allocate(x_sorted(n))
       x_sorted = pack(x, mask)
    else
       n = size(x)
       allocate(x_sorted(n))
       x_sorted = x
    end if
    call quicksort(x_sorted)
    if(percent >= 100._sp) then
       ipos = n
    else if(percent <= 0._sp) then
       ipos = 1
    else
       ipos=nint(percent/100._sp*real(n-1, sp))+1
    end if
    quantile_sp=x_sorted(ipos)
  end function quantile_sp

  real(sp) function variance_sp(x, mask)
    implicit none
    real(sp),intent(in) :: x(:)
    logical,intent(in),optional :: mask(:)
    variance_sp = sum(x-mean(x, mask=mask)**2._sp)/(size(x)-1)
  end function variance_sp

  real(sp) function clipped_mean_sp(x, n)
    implicit none
    real(sp),intent(in) :: x(:)
    integer,intent(in) :: n
    logical,dimension(size(x)) :: keep
    real(sp) :: sigma
    integer :: n_before
    keep = .true.
    n_before = 0
    do
       clipped_mean_sp = mean(x, mask=keep)
       sigma = sqrt(variance(x, mask=keep))
       keep = keep .and. abs(x-clipped_mean_sp) < real(n, sp) * sigma
       if(count(keep)==n_before) exit
       n_before = count(keep)
    end do
  end function clipped_mean_sp

end module lib_statistics


module potinv_interface
  interface
    subroutine potinv(a, q, u, v, xlam, eps, nmaxit, ier)
      implicit none
      real, dimension(:,:), intent(inout) :: a
      real, intent(in) :: q
      real, dimension(:), intent(out) :: u, v
      real, intent(inout) :: xlam
      real, intent(in) :: eps
      integer, intent(in) :: nmaxit
      integer, intent(out) :: ier
    end subroutine
  end interface
end module


	SUBROUTINE GGRFLM  ( ixtyp, iytyp, np, xl, yl, bmlx1, bmlx0,
     +			     bmly1, bmly0, xm, ym, iret )
C************************************************************************
C* GGRFLM								*
C* 									*
C* This subroutine converts graph linear intermediate coordinates	*
C* into map/graph coordinates.						*
C* 									*
C* GGRFLM  ( IXTYP, IYTYP, NP, XL, YL, BMLX1, BMLX0, BMLY1, BMLY0,	*
C*           XM, YM, IRET )						*
C*									*
C* Input parameters:							*
C*	IXTYP		INTEGER		X axis type			*
C*	IYTYP		INTEGER		Y axis type			*
C*	NP		INTEGER		Number of points		*
C* 	XL (NP)		REAL		X coordinates 			*
C* 	YL (NP)		REAL		Y coordinates			*
C*	BMLX1		REAL		X axis graph scaling factor	*
C*	BMLX0		REAL		X axis graph offset 		*
C*	BMLY1		REAL		Y axis graph scaling factor	*
C*	BMLY0		REAL		Y axis graph scaling factor	*
C* 									*
C* Output parameters: 							*
C*	XM (NP)		REAL		X coordinates			*
C*	YM (NP)		REAL		Y coordinates			*
C*	IRET		INTEGER		Return code			*
C**									*
C* Log:									*
C* G. Chatters/RDS	 7/84	GEMPLT Version 3.0			*
C* M. desJardins/GSFC	 6/85	GEMPLT Version 3.1			*
C* M. desJardins/GSFC	10/86	Added polar coordinates			*
C* M. desJardins/GSFC	 6/88	Documentation				*
C* K. Brill/NMC          7/90   SkewT offset multiplied by aspect ratio	*
C* M. desJardins/GSFC	 9/90	Use constants in GEMPRM.PRM		*
C************************************************************************
	INCLUDE		'ERROR.PRM'
	INCLUDE		'GEMPRM.PRM'
	INCLUDE         'XYDEF.CMN'
C*
	REAL		xl (*), yl (*), xm (*), ym (*)
C--------------------------------------------------------------------------
	iret = NORMAL
C
C*	Do transforms for polar coordinates.
C
	IF  ( ( ixtyp .eq. 5 ) .and. ( iytyp .eq. 5 ) )  THEN
	    DO  i = 1, np
		x = ( xl (i) - bmlx0 ) / bmlx1
		y = ( yl (i) - bmly0 ) / bmly1
		CALL XYTORT  ( x, y, r, theta, ier )
		xm (i) = r
		ym (i) = theta
	    END DO
	    RETURN
	END IF
C
C*	Do transform for x axis, then for y axis.
C
	IF  ( ixtyp .eq. 1 )  THEN
	    DO  i = 1, np
		xm(i) =  ( xl(i) - bmlx0 ) / bmlx1
	    END DO
C*
	  ELSE IF  ( ixtyp .eq. 2 )  THEN
	    DO  i = 1, np
		xm (i)  =  EXP  ( ( xl(i) - bmlx0 ) / bmlx1 )
	    END DO
C*
	  ELSE IF  ( ixtyp .eq. 3 ) THEN
	    DO  i = 1, np
		xm (i)  =  ( ( xl(i) - bmlx0 ) / bmlx1 ) ** AKAPPA
	    END DO
C*
	  ELSE IF  ( ixtyp .eq. 4 ) THEN
	    DO  i = 1, np
	        yoffst  =  yl (i) * yxgraf
		xm (i)  =  ( ( xl(i) - yoffst ) - bmlx0 ) / bmlx1
	    END DO
	END IF
C*
	IF  ( iytyp .eq. 1 )  THEN
	    DO  i = 1, np
		ym (i)  =  ( yl(i) - bmly0 ) / bmly1
	    END DO
C*
	  ELSE IF  ( iytyp .eq. 2  ) THEN
	    DO  i = 1, np
		ym (i)  =  EXP  ( ( yl(i) - bmly0 ) / bmly1 )
	    END DO
C*
	  ELSE IF  ( iytyp .eq. 3  ) THEN
	    DO  i = 1, np
		ym (i)  =  ( ( yl(i) - bmly0 ) / bmly1 ) ** AKAPPA
	    END DO
	END IF
C*
	RETURN
	END


c
c -------------------------------------------------------------
c
      subroutine vrm(qr,ql,rx,ixmin,ixmax,iflip,msize)
      implicit double precision (a-h,o-z)
      include "cuserdt.i"
      dimension qr(4,msize),ql(4,msize)
      dimension rx(4,msize), rlx(4), rrx(4), stateR(4), stateL(4)
      dimension rhor(msize),ur(msize),pr(msize),utr(msize)
      dimension rhol(msize),ul(msize),pl(msize),utl(msize)

      data      itno/2/, small/1.d-6/
c
c
c     # HLL vector Riemann solver
c     # Given primitive variables, compute
c     # conserved variables at interface by solving riemann problem
c     # only solve neighboring vertical interfaces
c
c      iflip = 1 indicates the normal velocity is in
c                qr(k,2) and the tangential in qr(k,3)
c            = 0 indicates the reverse.
c   done so a single riemann solver can be used for both columns and rows.
c
      if (ixmax .gt. msize) then
         write(6,*)" need to increase msize in vrm to ", ixmax
         stop
      endif

      inorm = 3 - iflip
      itan  = 2 + iflip

      do 10 k = ixmin, ixmax
         rhor(k) = qr(1,k)
         ur(k)   = qr(inorm,k)
         utr(k)  = qr(itan,k)
         pr(k)   = qr(4,k)
         rhol(k) = ql(1,k)
         ul(k)   = ql(inorm,k)
         utl(k)  = ql(itan,k)
         pl(k)   = ql(4,k)
  10     continue
c
      do 20 k = ixmin, ixmax
        aL  = dsqrt(gamma*pl(k)/rhol(k))
        aR  = dsqrt(gamma*pr(k)/rhor(k))

c       sL = ul(k) - aL;
c       sR = ur(k) + aR;
        sL = min((ul(k) - aL), (ur(k) - aR)) ! fancier option
        sR = max((ul(k) + aL), (ur(k) + aR))

        if (0.d0 .lt. sL) then   ! use left flux

         rx(1,k)     = rhol(k)*ul(k)
         rx(inorm,k) = rhol(k)*ul(k)*ul(k) + pl(k)
         rx(itan,k)  = rhol(k)*ul(k)*utl(k)
         etot        = .5d0*rhol(k)*(ul(k)*ul(k)+utl(k)*utl(k)) +
     .                  pl(k)/gamma1
         rx(4,k)     = ul(k)*(etot + pl(k))

        else if (0. .gt. sR) then   ! flux is right flux

         rx(1,k)     = rhor(k)*ur(k)
         rx(inorm,k) = rhor(k)*ur(k)*ur(k) + pr(k)
         rx(itan,k)  = rhor(k)*ur(k)*utr(k)
         etot        = .5d0*rhor(k)*(ur(k)*ur(k)+utr(k)*utr(k)) +
     .                  pr(k)/gamma1
         rx(4,k)     = ur(k)*(etot + pr(k))

        else
        ! middle flux
         rlx(1)     = rhol(k)*ul(k)
         rlx(inorm) = rhol(k)*ul(k)*ul(k) + pl(k)
         rlx(itan)  = rhol(k)*ul(k)*utl(k)
         etotl        = .5d0*rhol(k)*(ul(k)*ul(k)+utl(k)*utl(k)) +
     .                  pl(k)/gamma1
         rlx(4)     = ul(k)*(etotl + pl(k))

         rrx(1)     = rhor(k)*ur(k)
         rrx(inorm) = rhor(k)*ur(k)*ur(k) + pr(k)
         rrx(itan)  = rhor(k)*ur(k)*utr(k)
         etotr        = .5d0*rhor(k)*(ur(k)*ur(k)+utr(k)*utr(k)) +
     .                  pr(k)/gamma1
         rrx(4)     = ur(k)*(etotr + pr(k))

         stateL(1)     = rhol(k)
         stateL(inorm) = rhol(k)*ul(k)
         stateL(itan)  = rhol(k)*utl(k)
         stateL(4)     = etotl

         stateR(1)     = rhor(k)
         stateR(inorm) = rhor(k)*ur(k)
         stateR(itan)  = rhor(k)*utr(k)
         stateR(4)     = etotr

         rx(:,k)=(sR*rlx(:)-sL*rrx(:)
     .                       +sL*sR*( stateR(:)-stateL(:) ) )/ (sR-sL)
        endif
 20   continue

c
       return
       end


program ch1501
    ! Use of cmplx, aimag and conjg
    implicit none

    complex :: z, z1, z2, z3, zbar
    real :: x, y, zmod
    real :: x2 = 3., y2 = 4.
    real :: x3 = -2., y3 = -3.

    z1 = cmplx(1.,2.)
    z2 = cmplx(x2,y2)
    z3 = cmplx(x3,y3)
    z = z1*z2/z3
    x = real(z)
    y = aimag(z)
    zmod = abs(z)
    zbar = conjg(z)
    print 100, z1, z2, z3
    print 110, z, zmod, zbar

100 format (3(f4.1, ' + i', f4.1))
110 format (f4.1, ' + i', f4.1, /, &
        f4.1, /, &
        f4.1, ' + i', f4.1)
end program


integer function add2(a, b)
    integer a, b
    add2 = a + b
    return
end function add2


! $CLASSHG/codes/fortran/zeroin/myfcn.f90

! Provides the function power(x) = x**n - a.
! A zero of this function will be found using zeroin.

module myfcn

    implicit none
    real(kind=8) :: a
    integer :: n
    save

contains

real(kind=8) function power(x)

    implicit none
    real(kind=8) :: x
    power = x**n - a

end function power

end module myfcn


! { dg-do run }
program main
  implicit none
  integer, parameter :: n=5, m=3
  character(kind=4,len=5), dimension(n) :: a
  character(kind=4,len=5), dimension(n,m) :: b
  character(kind=4,len=5) :: res
  integer, dimension(n,m) :: v
  real, dimension(n,m) :: r
  integer :: i,j
  logical, dimension(n,m) :: mask
  character(kind=4,len=5), dimension(:,:), allocatable :: empty
  character(kind=4,len=5) , parameter :: all_zero = achar(0) // achar(0) // achar(0) // achar(0) // achar(0)
  logical :: smask

  write (unit=a,fmt='(I5.5)') (21-i*i+6*i,i=1,n)
  res = maxval(a)
  if (res /= 4_'00030') STOP 1
  do
     call random_number(r)
     v = int(r * 100)
     if (count(v > 20) > 1) exit
  end do
  write (unit=b,fmt='(I5.5)') v
  write (unit=res,fmt='(I5.5)') maxval(v)
  if (res /= maxval(b)) STOP 2
  smask = .true.
  if (res /= maxval(b, smask)) STOP 3
  smask = .false.
  if (all_zero /= maxval(b, smask)) STOP 4

  mask = v > 20
  write (unit=res,fmt='(I5.5)') maxval(v,mask)
  if (res /= maxval(b, mask)) STOP 5
  mask = .false.
  if (maxval(b, mask) /= all_zero) STOP 6
  allocate (empty(0:3,0))
  res = maxval(empty)
  if (res /= all_zero) STOP 7
end program main


!---------------------------------------------------------------------
!---------------------------------------------------------------------

      subroutine error_norm(rms)

!---------------------------------------------------------------------
!---------------------------------------------------------------------

!---------------------------------------------------------------------
!     this function computes the norm of the difference between the
!     computed solution and the exact solution
!---------------------------------------------------------------------

      use bt_data
      use mpinpb

      implicit none

      integer c, i, j, k, m, ii, jj, kk, d, error
      double precision xi, eta, zeta, u_exact(5), rms(5), rms_work(5),  &
     &     add

      do m = 1, 5
         rms_work(m) = 0.0d0
      enddo

      do c = 1, ncells
         kk = 0
         do k = cell_low(3,c), cell_high(3,c)
            zeta = dble(k) * dnzm1
            jj = 0
            do j = cell_low(2,c), cell_high(2,c)
               eta = dble(j) * dnym1
               ii = 0
               do i = cell_low(1,c), cell_high(1,c)
                  xi = dble(i) * dnxm1
                  call exact_solution(xi, eta, zeta, u_exact)

                  do m = 1, 5
                     add = u(m,ii,jj,kk,c)-u_exact(m)
                     rms_work(m) = rms_work(m) + add*add
                  enddo
                  ii = ii + 1
               enddo
               jj = jj + 1
            enddo
            kk = kk + 1
         enddo
      enddo

      call mpi_allreduce(rms_work, rms, 5, dp_type,  &
     &     MPI_SUM, comm_setup, error)

      do m = 1, 5
         do d = 1, 3
            rms(m) = rms(m) / dble(grid_points(d)-2)
         enddo
         rms(m) = dsqrt(rms(m))
      enddo

      return
      end

!---------------------------------------------------------------------
!---------------------------------------------------------------------

      subroutine rhs_norm(rms)

!---------------------------------------------------------------------
!---------------------------------------------------------------------

      use bt_data
      use mpinpb

      implicit none

      integer c, i, j, k, d, m, error
      double precision rms(5), rms_work(5), add

      do m = 1, 5
         rms_work(m) = 0.0d0
      enddo

      do c = 1, ncells
         do k = start(3,c), cell_size(3,c)-end(3,c)-1
            do j = start(2,c), cell_size(2,c)-end(2,c)-1
               do i = start(1,c), cell_size(1,c)-end(1,c)-1
                  do m = 1, 5
                     add = rhs(m,i,j,k,c)
                     rms_work(m) = rms_work(m) + add*add
                  enddo
               enddo
            enddo
         enddo
      enddo

      call mpi_allreduce(rms_work, rms, 5, dp_type,  &
     &     MPI_SUM, comm_setup, error)

      do m = 1, 5
         do d = 1, 3
            rms(m) = rms(m) / dble(grid_points(d)-2)
         enddo
         rms(m) = dsqrt(rms(m))
      enddo

      return
      end


MODULE test_module
CONTAINS
  SUBROUTINE test_array(array)
  IMPLICIT NONE
  REAL, DIMENSION(:,:) :: array
  INTEGER :: i1, i2, j1, j2
  ! Get details about array
  i1 = LBOUND(array,1)
  i2 = UBOUND(array,1)
  j1 = LBOUND(array,1)
  j2 = UBOUND(array,2)
  WRITE(*, 100) i1, i2, j1, j2
  100 FORMAT ('The bounds are: (',I2,':',I2','I2,':',I2,')')
  WRITE(*, 110) SHAPE(array)
  110 FORMAT ('The shape is:    ',2I4)
  WRITE(*, 120) SIZE(array)
  120 FORMAT ('The size is:     ',I4)
  END SUBROUTINE test_array
END MODULE test_module

PROGRAM assumed_shape
USE test_module
IMPLICIT NONE

REAL, DIMENSION(-5:5,-5:5) :: a = 0
REAL, DIMENSION(10,2) :: b = 1

WRITE(*, *) 'Calling test_array with array a:'
CALL test_array(a)
WRITE(*, *) 'Calling test_array with array b:'
CALL test_array(b)
END PROGRAM assumed_shape


        function pct_rejected(n_good_qc,n_bad_qc)

        n_total = n_good_qc + n_bad_qc

        if(n_total .gt. 0)then
            pct_rejected = (float(n_bad_qc) / float(n_total)) * 100.
        else
            pct_rejected = 0.
        endif

        return
        end


! { dg-do  run }
! Check that eoshift works for three-dimensional arrays.
module x
  implicit none
contains
  subroutine eoshift_3 (array, shift, boundary, dim, res)
    real, dimension(:,:,:), intent(in) :: array
    real, dimension(:,:,:), intent(out) :: res
    integer, dimension(:,:), intent(in) :: shift
    real, optional, dimension(:,:), intent(in) :: boundary
    integer, optional, intent(in) :: dim
    integer :: s1, s2, s3
    integer :: n1, n2, n3
    integer :: sh
    real :: b
    integer :: d

    if (present(dim)) then
       d = dim
    else
       d = 1
    end if

    n1 = size(array,1)
    n2 = size(array,2)
    n3 = size(array,3)

    select case(dim)
    case(1)
       do s3=1,n3
          do s2=1,n2
             sh = shift(s2,s3)
             b = boundary(s2,s3)
             if (sh > 0) then
                sh = min(sh, n1)
                do s1= 1, n1 - sh
                   res(s1,s2,s3) = array(s1+sh,s2,s3)
                end do
                do s1 = n1 - sh + 1,n1
                   res(s1,s2,s3) = b
                end do
             else
                sh = max(sh, -n1)
                do s1=1,-sh
                   res(s1,s2,s3) = b
                end do
                do s1= 1-sh,n1
                   res(s1,s2,s3) = array(s1+sh,s2,s3)
                end do
             end if
          end do
       end do
    case(2)
       do s3=1,n3
          do s1=1,n1
             sh = shift(s1,s3)
             b = boundary(s1,s3)
             if (sh > 0) then
                sh = min (sh, n2)
                do s2=1, n2 - sh
                   res(s1,s2,s3) = array(s1,s2+sh,s3)
                end do
                do s2=n2 - sh + 1, n2
                   res(s1,s2,s3) = b
                end do
             else
                sh = max(sh, -n2)
                do s2=1,-sh
                   res(s1,s2,s3) = b
                end do
                do s2=1-sh,n2
                   res(s1,s2,s3) = array(s1,s2+sh,s3)
                end do
             end if
          end do
       end do

    case(3)
       do s2=1, n2
          do s1=1,n1
             sh = shift(s1, s2)
             b = boundary(s1, s2)
             if (sh > 0) then
                sh = min(sh, n3)
                do s3=1,n3 - sh
                   res(s1,s2,s3) = array(s1,s2,s3+sh)
                end do
                do s3=n3 - sh + 1, n3
                   res(s1,s2,s3) = b
                end do
             else
                sh = max(sh, -n3)
                do s3=1,-sh
                   res(s1,s2,s3) = b
                end do
                do s3=1-sh,n3
                   res(s1,s2,s3) = array(s1,s2,s3+sh)
                end do
             end if
          end do
       end do

    case default
       stop "Illegal dim"
    end select
  end subroutine eoshift_3
  subroutine fill_shift(x, n)
    integer, intent(out), dimension(:,:) :: x
    integer, intent(in) :: n
    integer :: n1, n2, s1, s2
    integer :: v
    v = -n - 1
    n1 = size(x,1)
    n2 = size(x,2)
    do s2=1,n2
       do s1=1,n1
          x(s1,s2) = v
          v = v + 1
          if (v > n + 1) v = -n - 1
       end do
    end do
  end subroutine fill_shift
end module x

program main
  use x
  implicit none
  integer, parameter :: n1=10,n2=30,n3=40
  real, dimension(n1,n2,n3) :: a,b,c
  real, dimension(2*n1,n2,n3) :: a2, c2
  integer :: dim
  integer, dimension(n2,n3), target :: sh1
  integer, dimension(n1,n3), target :: sh2
  integer, dimension(n1,n2), target :: sh3
  real, dimension(n2,n3), target :: b1
  real, dimension(n1,n3), target :: b2
  real, dimension(n1,n2), target :: b3

  integer, dimension(:,:), pointer :: sp
  real, dimension(:,:), pointer :: bp

  call random_number(a)
  call random_number(b1)
  call random_number(b2)
  call random_number(b3)
  call fill_shift(sh1, n1)
  call fill_shift(sh2, n2)
  call fill_shift(sh3, n3)

  do dim=1,3
     if (dim == 1) then
        sp => sh1
        bp => b1
     else if (dim == 2) then
        sp => sh2
        bp => b2
     else
        sp => sh3
        bp => b3
     end if
     b = eoshift(a,shift=sp,dim=dim,boundary=bp)
     call eoshift_3 (a, shift=sp, dim=dim, boundary=bp,res=c)
     if (any (b /= c)) then
        STOP 1
     end if
     a2 = 42.
     a2(1:2*n1:2,:,:) = a
     b = eoshift(a2(1:2*n1:2,:,:), shift=sp, dim=dim, boundary=bp)
     if (any(b /= c)) then
        STOP 2
     end if
     c2 = 43.
     c2(1:2*n1:2,:,:) = eoshift(a, shift=sp, dim=dim, boundary=bp)
     if (any(c2(1:2*n1:2,:,:) /= c)) then
        STOP 3
     end if
     if (any(c2(2:2*n1:2,:,:) /= 43.)) then
        STOP 4
     end if
  end do
end program main