      SUBROUTINE MB03JP( COMPQ, N, A, LDA, D, LDD, B, LDB, F, LDF, Q,
     $                   LDQ, NEIG, IWORK, LIWORK, DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To move the eigenvalues with strictly negative real parts of an
C     N-by-N real skew-Hamiltonian/Hamiltonian pencil aS - bH in
C     structured Schur form,
C
C           (  A  D  )      (  B  F  )
C       S = (        ), H = (        ),
C           (  0  A' )      (  0 -B' )
C
C     with A upper triangular and B upper quasi-triangular, to the
C     leading principal subpencil, while keeping the triangular form.
C     The notation M' denotes the transpose of the matrix M.
C     The matrices S and H are transformed by an orthogonal matrix Q
C     such that
C
C                            (  Aout  Dout  )
C       Sout = J Q' J' S Q = (              ),
C                            (    0   Aout' )
C                                                                    (1)
C                            (  Bout  Fout  )           (  0  I  )
C       Hout = J Q' J' H Q = (              ), with J = (        ),
C                            (  0    -Bout' )           ( -I  0  )
C
C     where Aout is upper triangular and Bout is upper quasi-triangular.
C     Optionally, if COMPQ = 'I' or COMPQ = 'U', the orthogonal matrix Q
C     that fulfills (1), is computed.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     COMPQ   CHARACTER*1
C             Specifies whether or not the orthogonal transformations
C             should be accumulated in the array Q, as follows:
C             = 'N':  Q is not computed;
C             = 'I':  the array Q is initialized internally to the unit
C                     matrix, and the orthogonal matrix Q is returned;
C             = 'U':  the array Q contains an orthogonal matrix Q0 on
C                     entry, and the matrix Q0*Q is returned, where Q
C                     is the product of the orthogonal transformations
C                     that are applied to the pencil aS - bH to reorder
C                     the eigenvalues.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the pencil aS - bH.  N >= 0, even.
C
C     A       (input/output) DOUBLE PRECISION array, dimension
C                            (LDA, N/2)
C             On entry, the leading N/2-by-N/2 part of this array must
C             contain the upper triangular matrix A. The elements of the
C             strictly lower triangular part of this array are not used.
C             On exit, the leading  N/2-by-N/2 part of this array
C             contains the transformed matrix Aout.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= MAX(1, N/2).
C
C     D       (input/output) DOUBLE PRECISION array, dimension
C                           (LDD, N/2)
C             On entry, the leading N/2-by-N/2 part of this array must
C             contain the upper triangular part of the skew-symmetric
C             matrix D. The diagonal need not be set to zero.
C             On exit, the leading  N/2-by-N/2 part of this array
C             contains the transformed upper triangular part of the
C             matrix Dout.
C             The strictly lower triangular part of this array is
C             not referenced, except for the element D(N/2,N/2-1), but
C             its initial value is preserved.
C
C     LDD     INTEGER
C             The leading dimension of the array D.  LDD >= MAX(1, N/2).
C
C     B       (input/output) DOUBLE PRECISION array, dimension
C                            (LDB, N/2)
C             On entry, the leading N/2-by-N/2 part of this array must
C             contain the upper quasi-triangular matrix B.
C             On exit, the leading  N/2-by-N/2 part of this array
C             contains the transformed upper quasi-triangular part of
C             the matrix Bout.
C             The part below the first subdiagonal of this array is
C             not referenced.
C
C     LDB     INTEGER
C             The leading dimension of the array B.  LDB >= MAX(1, N/2).
C
C     F       (input/output) DOUBLE PRECISION array, dimension
C                           (LDF, N/2)
C             On entry, the leading N/2-by-N/2 part of this array must
C             contain the upper triangular part of the symmetric matrix
C             F.
C             On exit, the leading  N/2-by-N/2 part of this array
C             contains the transformed upper triangular part of the
C             matrix Fout.
C             The strictly lower triangular part of this array is not
C             referenced, except for the element F(N/2,N/2-1), but its
C             initial value is preserved.
C
C     LDF     INTEGER
C             The leading dimension of the array F.  LDF >= MAX(1, N/2).
C
C     Q       (input/output) DOUBLE PRECISION array, dimension (LDQ, N)
C             On entry, if COMPQ = 'U', then the leading N-by-N part of
C             this array must contain a given matrix Q0, and on exit,
C             the leading N-by-N part of this array contains the product
C             of the input matrix Q0 and the transformation matrix Q
C             used to transform the matrices S and H.
C             On exit, if COMPQ = 'I', then the leading N-by-N part of
C             this array contains the orthogonal transformation matrix
C             Q.
C             If COMPQ = 'N' this array is not referenced.
C
C     LDQ     INTEGER
C             The leading dimension of the array Q.
C             LDQ >= 1,         if COMPQ = 'N';
C             LDQ >= MAX(1, N), if COMPQ = 'I' or COMPQ = 'U'.
C
C     NEIG    (output) INTEGER
C             The number of eigenvalues in aS - bH with strictly
C             negative real part.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (LIWORK)
C
C     LIWORK  INTEGER
C             The dimension of the array IWORK.
C             LIWORK >= 3*N-3.
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C
C     LDWORK  INTEGER
C             The dimension of the array DWORK.
C             If COMPQ = 'N',
C                LDWORK >= MAX(2*N+32,108)+5*N/2;
C             if COMPQ = 'I' or COMPQ = 'U',
C                LDWORK >= MAX(4*N+32,108)+5*N/2.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0: succesful exit;
C             < 0: if INFO = -i, the i-th argument had an illegal value;
C             = 1: error occured during execution of MB03DD;
C             = 2: error occured during execution of MB03HD.
C
C     METHOD
C
C     The algorithm reorders the eigenvalues like the following scheme:
C
C     Step 1: Reorder the eigenvalues in the subpencil aA - bB.
C          I. Reorder the eigenvalues with negative real parts to the
C             top.
C         II. Reorder the eigenvalues with positive real parts to the
C             bottom.
C
C     Step 2: Reorder the remaining eigenvalues with negative real
C             parts in the pencil aS - bH.
C          I. Exchange the eigenvalues between the last diagonal block
C             in aA - bB and the last diagonal block in aS - bH.
C         II. Move the eigenvalues of the R-th block to the (MM+1)-th
C             block, where R denotes the number of upper quasi-
C             triangular blocks in aA - bB and MM denotes the current
C             number of blocks in aA - bB with eigenvalues with negative
C             real parts.
C
C     The algorithm uses a sequence of orthogonal transformations as
C     described on page 33 in [1]. To achieve those transformations the
C     elementary subroutines MB03DD and MB03HD are called for the
C     corresponding matrix structures.
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     FURTHER COMMENTS
C
C     For large values of N, the routine applies the transformations on
C     panels of columns. The user may specify in INFO the desired number
C     of columns. If on entry INFO <= 0, then the routine estimates a
C     suitable value of this number.
C
C     CONTRIBUTOR
C
C     V. Sima, Research Institute for Informatics, Bucharest, Oct. 2010.
C     M. Voigt, Max Planck Institute for Dynamics of Complex Technical
C     Systems, Magdeburg, Jan. 2012.
C
C     REVISIONS
C
C     V. Sima, Nov. 2010, July 2013, Aug. 2014, June 2015.
C     M. Voigt, July 2013.
C
C     KEYWORDS
C
C     Eigenvalue reordering, upper (quasi-)triangular matrix,
C     skew-Hamiltonian/Hamiltonian pencil, structured Schur form.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE, HALF, TEN
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0, HALF = 0.5D+0,
     $                     TEN = 1.0D+1 )
C
C     .. Scalar Arguments ..
      CHARACTER          COMPQ
      INTEGER            INFO, LDA, LDB, LDD, LDF, LDQ, LDWORK, LIWORK,
     $                   N, NEIG
C
C     .. Array Arguments ..
      INTEGER            IWORK( * )
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), D( LDD, * ),
     $                   DWORK( * ),  F( LDF, * ), Q( LDQ, * )
C
C     .. Local Scalars ..
      LOGICAL            LCMPQ, LINIQ, LUPDQ
      INTEGER            BLKUP, DIM1, DIM2, HLP, I, IA, IAUPLE, IB, IB1,
     $                   IB2, IB3, IBUPLE, IBUPRI, IC, ICOL, ICOLS, ICS,
     $                   IQ1, IQ2, IQLOLE, IQLORI, IQUPLE, IQUPRI, IR,
     $                   IS, ITMP1, ITMP2, ITMP3, IUPD, IWRK1, IWRK2,
     $                   IWRK3, IWRK4, IWRK5, J, JE, JS, K, LDW, M, M1,
     $                   MM, MP, NB, NC, NCOL, NP2, NROWS, OPTDW, R,
     $                   SDIM, UPDS
      DOUBLE PRECISION   A2, D1, D2, D3, F2, NRMA, NRMB, PREC, Q11, Q12,
     $                   Q21, Q22, TMP, TOL
C
C     .. Local Arrays ..
      DOUBLE PRECISION   PAR( 2 )
C
C     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DDOT, DLAMCH, DLANHS, DLANTR
      EXTERNAL           DDOT, DLAMCH, DLANHS, DLANTR, LSAME
C
C     .. External Subroutines ..
      EXTERNAL           DAXPY, DCOPY, DGEMM, DGEMV, DGEQRF, DLACPY,
     $                   DLASET, DSCAL, MB01LD, MB01RU, MB01RX, MB03DD,
     $                   MB03HD, XERBLA
C
C     .. Intrinsic Functions ..
      INTRINSIC          ABS, DBLE, INT, MAX, MIN, MOD, SIGN
C
C     .. Executable Statements ..
C
C     Decode the input arguments.
C
      M  = N/2
      M1 = MAX( 1, M )
      NB = INFO
      IF( NB.GT.0 )
     $   NB = MAX( NB, 2 )
C
      LINIQ = LSAME( COMPQ, 'I' )
      LUPDQ = LSAME( COMPQ, 'U' )
      LCMPQ = LINIQ .OR. LUPDQ
      IF( LCMPQ ) THEN
         OPTDW = MAX( 4*N+32, 108 ) + 5*M
      ELSE
         OPTDW = MAX( 2*N+32, 108 ) + 5*M
      END IF
C
C     Test the input arguments.
C
      INFO = 0
      IF( .NOT.( LSAME( COMPQ, 'N' ) .OR. LCMPQ ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 .OR. MOD( N, 2 ).NE.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.M1 ) THEN
         INFO = -4
      ELSE IF( LDD.LT.M1 ) THEN
         INFO = -6
      ELSE IF( LDB.LT.M1 ) THEN
         INFO = -8
      ELSE IF( LDF.LT.M1 ) THEN
         INFO = -10
      ELSE IF( LDQ.LT.1 .OR. ( LCMPQ .AND. LDQ.LT.N ) ) THEN
         INFO = -12
      ELSE IF( LIWORK.LT.3*N-3 ) THEN
         INFO = -15
      ELSE IF( LDWORK.LT.OPTDW ) THEN
         INFO = -17
      END IF
      IF( INFO.NE.0) THEN
         CALL XERBLA( 'MB03JP', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( N.EQ.0 ) THEN
         NEIG = 0
         RETURN
      END IF
C
C     A block algorithm is used for large M.
C
      IF( NB.LE.0 ) THEN
         CALL DGEQRF( M, M, A, LDA, DWORK, DWORK, -1, INFO )
         NB = MIN( MAX( INT( DWORK( 1 ) )/M1, 2 ), M )
      END IF
C
C     Determine machine constants.
C
      PREC = DLAMCH( 'Precision' )
      TOL  = MIN( DBLE( N ), TEN )*PREC
C
      PAR( 1 ) = PREC
      PAR( 2 ) = DLAMCH( 'Safe minimum' )
C
C     STEP 0: Determine location and size of diagonal blocks.
C             IWORK(J) and IWORK(IS+J) are used to indicate the
C             beginning index and the kind of eigenvalues of the
C             J-th diagonal block of the subpencil aA - bB. For a
C             2-by-2 block, it is assumed that both eigenvalues have
C             real parts with the same sign (true for a structured
C             Schur form).
C
      I  = 1
      J  = 1
      IS = M + 1
C
      NRMA = DLANTR( 'One', 'Upper', 'Non-diag', M, M, A, LDA, DWORK )
      NRMB = DLANHS( 'One', M, B, LDB, DWORK )
C
C     Partition blocks.
C
C     WHILE( I.LE.M-1 ) DO
C
   10 CONTINUE
      IF( I.LE.M-1 ) THEN
         IWORK( J ) = I
         IF( ABS( B( I+1, I ) ).LE.TOL*NRMB ) THEN
C
C           1-by-1 block.
C
            B( I+1, I ) = ZERO
            IF( ABS( A( I, I ) ).LE.TOL*NRMA .OR.
     $          ABS( B( I, I ) ).LE.TOL*NRMB ) THEN
C
C              Eigenvalue is infinite, 0, or 0/0.
C
               IWORK( IS+J ) = 0
            ELSE
               IWORK( IS+J ) = INT( SIGN( ONE, A( I, I )*B( I, I ) ) )
            END IF
            I = I + 1
         ELSE
C
C           2-by-2 block.
C
            IF( A( I, I ).EQ.ZERO .OR. A( I+1, I+1 ).EQ.ZERO ) THEN
C
C              Eigenvalue is infinite.
C
               IWORK( IS+J ) = 0
            ELSE
               TMP = ( B( I, I ) - ( B( I+1, I )   / A( I+1, I+1 ) )*
     $                               A( I, I+1 ) ) / A( I, I )  +
     $                               B( I+1, I+1 ) / A( I+1, I+1 )
               IF( TMP.EQ.ZERO ) THEN
                  IWORK( IS+J ) = 0
               ELSE
                  IWORK( IS+J ) = INT( SIGN( ONE, TMP ) )
               END IF
            END IF
            I = I + 2
         END IF
         J = J + 1
      GO TO 10
C
C     END WHILE 10
C
      END IF
C
      IF( I.EQ.M ) THEN
         IWORK( J ) = I
         IF( ABS( A( I, I ) ).LE.TOL*NRMA .OR.
     $       ABS( B( I, I ) ).LE.TOL*NRMB ) THEN
C
C           Eigenvalue is infinite or zero.
C
            IWORK( IS+J ) = 0
         ELSE
            IWORK( IS+J ) = INT( SIGN( ONE, A( I, I )*B( I, I ) ) )
         END IF
         J = J + 1
      END IF
C
      R = J - 1
C
C     Initialize Q if appropriate.
C
      IF( LINIQ ) THEN
         IUPD = M + 1
         UPDS = M
         CALL DLASET( 'Full', N, N, ZERO, ONE, Q, LDQ )
      ELSE IF( LUPDQ ) THEN
         IUPD = 1
         UPDS = N
      END IF
C
      IF( M.GT.1 ) THEN
C
C        Save the lower triangle of the submatrix D(M-1:M,M-1:M) and the
C        elements A(M,M-1), F(M,M-1), which might be overwritten.
C
         D1 = D( M-1, M-1 )
         D2 = D(   M, M-1 )
         D3 = D(   M,   M )
         A2 = A(   M, M-1 )
         F2 = F(   M, M-1 )
      END IF
C
C     STEP 1: Reorder the eigenvalues in the subpencil aA - bB.
C
      MM = 0
      MP = J
C
C     I. Reorder the eigenvalues with negative real parts to the top.
C
C     Set pointers for the inputs and outputs of MB03DD.
C
      IQ1   = 1
      IQ2   = IQ1 + 16
      IA    = IQ2 + 16
      IB    = IA  + 16
      IWRK1 = IB  + 16
      IWRK2 = IA
C
      K   = 1
      NP2 = N + 2
      IB3 = M + 1
      IWORK( R+1 ) = IB3
C
C     WHILE( K.LE.R ) DO
C
   20 CONTINUE
      IF( K.LE.R ) THEN
         IF( IWORK( IS+K ).LT.0 ) THEN
            ICOL = NP2
            IF ( LCMPQ ) THEN
               IWORK( ICOL ) = MAX( 109, IWRK2 + 4*N )
            ELSE
               IWORK( ICOL ) = MAX( 109, IWRK2 + 2*N )
            END IF
            DO 30 J = K - 1, MM + 1, -1
C
C              IB1, IB2, and IB3 are pointers to 3 consecutive blocks.
C
               IB1  = IWORK( J )
               IB2  = IWORK( J+1 )
               IB3  = IWORK( J+2 )
               DIM1 = IB2  - IB1
               DIM2 = IB3  - IB2
               SDIM = DIM1 + DIM2
C
C              Copy the relevant part of A(ib1:ib3-1,ib1:ib3-1) and
C              B(ib1:ib3-1,ib1:ib3-1) to DWORK as inputs for MB03DD.
C              Also, set the additional zero elements.
C
               CALL DLACPY( 'Upper', SDIM, SDIM, A( IB1, IB1 ), LDA,
     $                      DWORK( IA ), SDIM )
               CALL DLASET( 'Lower', SDIM-1, SDIM-1, ZERO, ZERO,
     $                      DWORK( IA+1 ), SDIM )
               CALL DLACPY( 'Upper', SDIM, SDIM, B( IB1, IB1 ), LDB,
     $                      DWORK( IB ), SDIM )
               CALL DCOPY(  SDIM-1, B( IB1+1, IB1 ), LDB+1,
     $                      DWORK( IB+1 ), SDIM+1 )
               CALL DLASET( 'Lower', SDIM-2, SDIM-2, ZERO, ZERO,
     $                      DWORK( IB+2 ), SDIM )
C
C              Perform eigenvalue/matrix block exchange.
C              Workspace: IWRK1 + 43 = 108.
C
               CALL MB03DD( 'Triangular', DIM1, DIM2, PREC, DWORK( IB ),
     $                      SDIM, DWORK( IA ), SDIM, DWORK( IQ1 ), SDIM,
     $                      DWORK( IQ2 ), SDIM, DWORK( IWRK1 ),
     $                      LDWORK-IWRK1+1, INFO )
               IF( INFO.GT.0 ) THEN
                  INFO = 1
                  RETURN
               END IF
C
C              Store data for blocked computations.
C              Workspace: MAX( 108, a*N+32 ) + 5*M, where
C                         a = 2, if COMPQ =  'N';
C                         a = 4, if COMPQ <> 'N'.

               IWORK( ICOL+1 ) = IB1
               IWORK( ICOL+2 ) = IB2
               IWORK( ICOL+3 ) = IB3
               IWORK( ICOL+4 ) = IWORK( ICOL ) + SDIM*SDIM
               CALL DLACPY( 'Full', SDIM, SDIM, DWORK( IQ2 ), SDIM,
     $                      DWORK( IWORK( ICOL ) ), SDIM )
               ICOL = ICOL + 4
C
C              Copy the transformed diagonal blocks, if sdim > 2.
C
               NROWS = IB1 - 1
               ICS   = IB3
               IF( SDIM.GT.2 ) THEN
                  CALL DLACPY( 'Upper', SDIM, SDIM, DWORK( IA ), SDIM,
     $                         A( IB1, IB1 ), LDA )
                  CALL DLACPY( 'Upper', SDIM, SDIM, DWORK( IB ), SDIM,
     $                         B( IB1, IB1 ), LDB )
                  CALL DCOPY(  SDIM-1, DWORK( IB+1 ), SDIM+1,
     $                         B( IB1+1, IB1 ), LDB+1 )
               ELSE
                  CALL DGEMM( 'Transpose', 'No Transpose', SDIM, SDIM,
     $                        SDIM, ONE, DWORK( IQ2 ), SDIM,
     $                        A( IB1, IB1 ), LDA, ZERO, DWORK( IA ),
     $                        SDIM )
                  CALL DGEMM( 'No Transpose', 'No Transpose', SDIM,
     $                        SDIM, SDIM, ONE, DWORK( IA ), SDIM,
     $                        DWORK( IQ1 ), SDIM, ZERO, A( IB1, IB1 ),
     $                        LDA )
                  CALL DGEMM( 'Transpose', 'No Transpose', SDIM, SDIM,
     $                        SDIM, ONE, DWORK( IQ2 ), SDIM,
     $                        B( IB1, IB1 ), LDB, ZERO, DWORK( IB ),
     $                        SDIM )
                  CALL DGEMM( 'No Transpose', 'No Transpose', SDIM,
     $                        SDIM, SDIM, ONE, DWORK( IB ), SDIM,
     $                        DWORK( IQ1 ), SDIM, ZERO, B( IB1, IB1 ),
     $                        LDB )
               END IF
C
               IC   = ICS
               LDW  = MAX( 1, NROWS )
C
C              Update A.
C              Workspace: IWRK2 + 2*N - 1.
C
               CALL DGEMM(  'No Transpose', 'No Transpose', NROWS, SDIM,
     $                      SDIM, ONE, A( 1, IB1 ), LDA, DWORK( IQ1 ),
     $                      SDIM, ZERO, DWORK( IWRK2 ), LDW )
               CALL DLACPY( 'Full', NROWS, SDIM, DWORK( IWRK2 ), LDW,
     $                      A( 1, IB1 ), LDA )
C
C              Update D.
C
               CALL DGEMM(  'No Transpose', 'No Transpose', NROWS, SDIM,
     $                      SDIM, ONE, D( 1, IB1 ), LDD, DWORK( IQ2 ),
     $                      SDIM, ZERO, DWORK( IWRK2 ), LDW )
               CALL DLACPY( 'Full', NROWS, SDIM, DWORK( IWRK2 ), LDW,
     $                      D( 1, IB1 ), LDD )
               CALL MB01LD( 'Upper', 'Transpose', SDIM, SDIM, ZERO, ONE,
     $                      D( IB1, IB1 ), LDD, DWORK( IQ2 ), SDIM,
     $                      D( IB1, IB1 ), LDD, DWORK( IWRK2 ),
     $                      LDWORK-IWRK2+1, INFO )
C
C              Update B.
C
               CALL DGEMM(  'No Transpose', 'No Transpose', NROWS, SDIM,
     $                      SDIM, ONE, B( 1, IB1 ), LDB, DWORK( IQ1 ),
     $                      SDIM, ZERO, DWORK( IWRK2 ), LDW )
               CALL DLACPY( 'Full', NROWS, SDIM, DWORK( IWRK2 ), LDW,
     $                      B( 1, IB1 ), LDB )
C
C              Update F.
C
               CALL DGEMM(  'No Transpose', 'No Transpose', NROWS, SDIM,
     $                      SDIM, ONE, F( 1, IB1 ), LDF, DWORK( IQ2 ),
     $                      SDIM, ZERO, DWORK( IWRK2 ), LDW )
               CALL DLACPY( 'Full', NROWS, SDIM, DWORK( IWRK2 ), LDW,
     $                      F( 1, IB1 ), LDF )
               CALL MB01RU( 'Upper', 'Transpose', SDIM, SDIM, ZERO, ONE,
     $                      F( IB1, IB1 ), LDF, DWORK( IQ2 ), SDIM,
     $                      F( IB1, IB1 ), LDF, DWORK( IWRK2 ),
     $                      LDWORK-IWRK2+1, INFO )
               CALL DSCAL( SDIM, HALF, F( IB1, IB1 ), LDF+1 )
C
               IF( LCMPQ ) THEN
C
C                 Update Q.
C                 Workspace: IWRK2 + 2*N - 1, if COMPQ = 'I';
C                            IWRK2 + 4*N - 1, if COMPQ = 'U'.
C
                  CALL DGEMM(  'No Transpose', 'No Transpose', UPDS,
     $                         SDIM, SDIM, ONE, Q( 1, IB1 ), LDQ,
     $                         DWORK( IQ1 ), SDIM, ZERO, DWORK( IWRK2 ),
     $                         UPDS )
                  CALL DLACPY( 'Full', UPDS, SDIM, DWORK( IWRK2 ), UPDS,
     $                         Q( 1, IB1 ), LDQ )
                  CALL DGEMM(  'No Transpose', 'No Transpose', UPDS,
     $                         SDIM, SDIM, ONE, Q( IUPD, M+IB1 ), LDQ,
     $                         DWORK( IQ2 ), SDIM, ZERO, DWORK( IWRK2 ),
     $                         UPDS )
                  CALL DLACPY( 'Full', UPDS, SDIM, DWORK( IWRK2 ), UPDS,
     $                         Q( IUPD, M+IB1 ), LDQ )
               END IF
C
C              Update index lists IWORK(1:M) and IWORK(M+2:N+1) if a
C              1-by-1 and 2-by-2 block have been swapped.
C
               HLP = DIM2 - DIM1
               IF( HLP.EQ.1 ) THEN
C
C                 First block was 2-by-2.
C
                  IWORK( J+1 ) = IB1 + 1
               ELSE IF( HLP.EQ.-1 ) THEN
C
C                 Second block was 2-by-2.
C
                  IWORK( J+1 ) = IB1 + 2
               END IF
C
C              Update IWORK(M+2:N+1).
C
               HLP = IWORK( IS+J )
               IWORK( IS+J )   = IWORK( IS+J+1 )
               IWORK( IS+J+1 ) = HLP
   30       CONTINUE
C
C           Panel Updates
C
C           Update A.
C
            ICOLS = NP2
            JE    = K - 1
C
C           WHILE( JE.GT.2 ) DO
   40       CONTINUE
            IF( JE.GE.MM+1 ) THEN
               NCOL  = 0
               NC    = 0
               ICOL  = ICOLS
               BLKUP = 0
               JS = IWORK( ICOL+3 )
               DO 50 J = JE, MM + 1, -1
                  DIM1 = IWORK( ICOL+2 ) - IWORK( ICOL+1 )
                  DIM2 = IWORK( ICOL+3 ) - IWORK( ICOL+2 )
                  SDIM = DIM1 + DIM2
                  CALL DGEMM(  'Transpose', 'No Transpose', SDIM, NCOL,
     $                         SDIM, ONE, DWORK( IWORK( ICOL ) ),
     $                         SDIM, A( IWORK( ICOL+1 ), JS ), LDA,
     $                         ZERO, DWORK( IWRK2 ), SDIM )
                  CALL DLACPY( 'Full', SDIM, NCOL, DWORK( IWRK2 ), SDIM,
     $                         A( IWORK( ICOL+1 ), JS ), LDA )
                  ICOL = ICOL + 4
                  NC = NC + DIM1
                  IF( NC.LE.NB ) THEN
                     NCOL = NCOL+DIM1
                     JS = IWORK( ICOLS+3 ) - NCOL
                     BLKUP = BLKUP+1
                  END IF
   50          CONTINUE
               JE =  JE - BLKUP
               ICOLS = ICOLS + 4*BLKUP
               GO TO 40
            END IF
C           END WHILE 40
C
            DO 70 JS = IWORK( N+5 ), M, NB
               JE = MIN( M, JS+NB-1 )
               NCOL = JE - JS + 1
               ICOL = NP2
               DO 60 J = K - 1, MM + 1, -1
                  DIM1 = IWORK( ICOL+2 ) - IWORK( ICOL+1 )
                  DIM2 = IWORK( ICOL+3 ) - IWORK( ICOL+2 )
                  SDIM = DIM1 + DIM2
                  CALL DGEMM(  'Transpose', 'No Transpose', SDIM, NCOL,
     $                         SDIM, ONE, DWORK( IWORK( ICOL ) ),
     $                         SDIM, A( IWORK( ICOL+1 ), JS ), LDA,
     $                         ZERO, DWORK( IWRK2 ), SDIM )
                  CALL DLACPY( 'Full', SDIM, NCOL, DWORK( IWRK2 ), SDIM,
     $                         A( IWORK( ICOL+1 ), JS ), LDA )
                  ICOL = ICOL + 4
   60          CONTINUE
   70       CONTINUE
C
C           Update D.
C
            ICOLS = NP2
            JE    = K - 1
C
C           WHILE( JE.GT.2 ) DO
   80       CONTINUE
            IF( JE.GE.MM+1 ) THEN
               NCOL  = 0
               NC    = 0
               ICOL  = ICOLS
               BLKUP = 0
               JS = IWORK( ICOL+3 )
               DO 90 J = JE, MM + 1, -1
                  DIM1 = IWORK( ICOL+2 ) - IWORK( ICOL+1 )
                  DIM2 = IWORK( ICOL+3 ) - IWORK( ICOL+2 )
                  SDIM = DIM1 + DIM2
                  CALL DGEMM(  'Transpose', 'No Transpose', SDIM, NCOL,
     $                         SDIM, ONE, DWORK( IWORK( ICOL ) ),
     $                         SDIM, D( IWORK( ICOL+1 ), JS ), LDD,
     $                         ZERO, DWORK( IWRK2 ), SDIM )
                  CALL DLACPY( 'Full', SDIM, NCOL, DWORK( IWRK2 ), SDIM,
     $                         D( IWORK( ICOL+1 ), JS ), LDD )
                  ICOL = ICOL + 4
                  NC = NC + DIM1
                  IF( NC.LE.NB ) THEN
                     NCOL = NCOL+DIM1
                     JS = IWORK( ICOLS+3 ) - NCOL
                     BLKUP = BLKUP+1
                  END IF
   90          CONTINUE
               JE =  JE - BLKUP
               ICOLS = ICOLS + 4*BLKUP
               GO TO 80
            END IF
C           END WHILE 80
C
            DO 110 JS = IWORK( N+5 ), M, NB
               JE = MIN( M, JS+NB-1 )
               NCOL = JE - JS + 1
               ICOL = NP2
               DO 100 J = K - 1, MM + 1, -1
                  DIM1 = IWORK( ICOL+2 ) - IWORK( ICOL+1 )
                  DIM2 = IWORK( ICOL+3 ) - IWORK( ICOL+2 )
                  SDIM = DIM1 + DIM2
                  CALL DGEMM(  'Transpose', 'No Transpose', SDIM, NCOL,
     $                         SDIM, ONE, DWORK( IWORK( ICOL ) ),
     $                         SDIM, D( IWORK( ICOL+1 ), JS ), LDD,
     $                         ZERO, DWORK( IWRK2 ), SDIM )
                  CALL DLACPY( 'Full', SDIM, NCOL, DWORK( IWRK2 ), SDIM,
     $                         D( IWORK( ICOL+1 ), JS ), LDD )
                  ICOL = ICOL + 4
  100          CONTINUE
  110       CONTINUE
C
C           Update B.
C
            ICOLS = NP2
            JE    = K - 1
C
C           WHILE( JE.GT.2 ) DO
  120       CONTINUE
            IF( JE.GE.MM+1 ) THEN
               NCOL  = 0
               NC    = 0
               ICOL  = ICOLS
               BLKUP = 0
               JS = IWORK( ICOL+3 )
               DO 130 J = JE, MM + 1, -1
                  DIM1 = IWORK( ICOL+2 ) - IWORK( ICOL+1 )
                  DIM2 = IWORK( ICOL+3 ) - IWORK( ICOL+2 )
                  SDIM = DIM1 + DIM2
                  CALL DGEMM(  'Transpose', 'No Transpose', SDIM, NCOL,
     $                         SDIM, ONE, DWORK( IWORK( ICOL ) ),
     $                         SDIM, B( IWORK( ICOL+1 ), JS ), LDB,
     $                         ZERO, DWORK( IWRK2 ), SDIM )
                  CALL DLACPY( 'Full', SDIM, NCOL, DWORK( IWRK2 ), SDIM,
     $                         B( IWORK( ICOL+1 ), JS ), LDB )
                  ICOL = ICOL + 4
                  NC = NC + DIM1
                  IF( NC.LE.NB ) THEN
                     NCOL = NCOL+DIM1
                     JS = IWORK( ICOLS+3 ) - NCOL
                     BLKUP = BLKUP+1
                  END IF
  130          CONTINUE
               JE =  JE - BLKUP
               ICOLS = ICOLS + 4*BLKUP
               GO TO 120
            END IF
C           END WHILE 120
C
            DO 150 JS = IWORK( N+5 ), M, NB
               JE = MIN( M, JS+NB-1 )
               NCOL = JE - JS + 1
               ICOL = NP2
               DO 140 J = K - 1, MM + 1, -1
                  DIM1 = IWORK( ICOL+2 ) - IWORK( ICOL+1 )
                  DIM2 = IWORK( ICOL+3 ) - IWORK( ICOL+2 )
                  SDIM = DIM1 + DIM2
                  CALL DGEMM(  'Transpose', 'No Transpose', SDIM, NCOL,
     $                         SDIM, ONE, DWORK( IWORK( ICOL ) ),
     $                         SDIM, B( IWORK( ICOL+1 ), JS ), LDB,
     $                         ZERO, DWORK( IWRK2 ), SDIM )
                  CALL DLACPY( 'Full', SDIM, NCOL, DWORK( IWRK2 ), SDIM,
     $                         B( IWORK( ICOL+1 ), JS ), LDB )
                  ICOL = ICOL + 4
  140          CONTINUE
  150       CONTINUE
C
C           Update F.
C
            ICOLS = NP2
            JE    = K - 1
C
C           WHILE( JE.GT.2 ) DO
  160       CONTINUE
            IF( JE.GE.MM+1 ) THEN
               NCOL  = 0
               NC    = 0
               ICOL  = ICOLS
               BLKUP = 0
               JS = IWORK( ICOL+3 )
               DO 170 J = JE, MM + 1, -1
                  DIM1 = IWORK( ICOL+2 ) - IWORK( ICOL+1 )
                  DIM2 = IWORK( ICOL+3 ) - IWORK( ICOL+2 )
                  SDIM = DIM1 + DIM2
                  CALL DGEMM(  'Transpose', 'No Transpose', SDIM, NCOL,
     $                         SDIM, ONE, DWORK( IWORK( ICOL ) ),
     $                         SDIM, F( IWORK( ICOL+1 ), JS ), LDF,
     $                         ZERO, DWORK( IWRK2 ), SDIM )
                  CALL DLACPY( 'Full', SDIM, NCOL, DWORK( IWRK2 ), SDIM,
     $                         F( IWORK( ICOL+1 ), JS ), LDF )
                  ICOL = ICOL + 4
                  NC = NC + DIM1
                  IF( NC.LE.NB ) THEN
                     NCOL = NCOL+DIM1
                     JS = IWORK( ICOLS+3 ) - NCOL
                     BLKUP = BLKUP+1
                  END IF
  170          CONTINUE
               JE =  JE - BLKUP
               ICOLS = ICOLS + 4*BLKUP
               GO TO 160
            END IF
C           END WHILE 160
C
            DO 190 JS = IWORK( N+5 ), M, NB
               JE = MIN( M, JS+NB-1 )
               NCOL = JE - JS + 1
               ICOL = NP2
               DO 180 J = K - 1, MM + 1, -1
                  DIM1 = IWORK( ICOL+2 ) - IWORK( ICOL+1 )
                  DIM2 = IWORK( ICOL+3 ) - IWORK( ICOL+2 )
                  SDIM = DIM1 + DIM2
                  CALL DGEMM(  'Transpose', 'No Transpose', SDIM, NCOL,
     $                         SDIM, ONE, DWORK( IWORK( ICOL ) ),
     $                         SDIM, F( IWORK( ICOL+1 ), JS ), LDF,
     $                         ZERO, DWORK( IWRK2 ), SDIM )
                  CALL DLACPY( 'Full', SDIM, NCOL, DWORK( IWRK2 ), SDIM,
     $                         F( IWORK( ICOL+1 ), JS ), LDF )
                  ICOL = ICOL + 4
  180          CONTINUE
  190       CONTINUE
C
            MM = MM + 1
         END IF
         K = K + 1
      GO TO 20
C
C     END WHILE 20
C
      END IF
C
C     II. Reorder the eigenvalues with positive real parts to the bottom.
C
      K = R
C
C     WHILE( K.GE.MM+1 ) DO
C
  200 CONTINUE
      IF( K.GE.MM + 1 ) THEN
         IF( IWORK( IS+K ).GT.0 ) THEN
            ICOL = NP2
            IF ( LCMPQ ) THEN
               IWORK( ICOL ) = MAX( 109, IWRK2 + 4*N )
            ELSE
               IWORK( ICOL ) = MAX( 109, IWRK2 + 2*N )
            END IF
            NC = IWORK( MP )
            DO 210 J = K, MP - 2
               IB1  = IWORK( J )
               IB2  = IWORK( J+1 )
               IB3  = IWORK( J+2 )
               DIM1 = IB2  - IB1
               DIM2 = IB3  - IB2
               SDIM = DIM1 + DIM2
C
C              Copy the relevant part of A(ib1:ib3-1,ib1:ib3-1) and
C              B(ib1:ib3-1,ib1:ib3-1) to DWORK as inputs for MB03DD.
C              Also, set the additional zero elements.
C
               CALL DLACPY( 'Upper', SDIM, SDIM, A( IB1, IB1 ), LDA,
     $                      DWORK( IA ), SDIM )
               CALL DLASET( 'Lower', SDIM-1, SDIM-1, ZERO, ZERO,
     $                      DWORK( IA+1 ), SDIM )
               CALL DLACPY( 'Upper', SDIM, SDIM, B( IB1, IB1 ), LDB,
     $                      DWORK( IB ), SDIM )
               CALL DCOPY(  SDIM-1, B( IB1+1, IB1 ), LDB+1,
     $                      DWORK( IB+1 ), SDIM+1 )
               CALL DLASET( 'Lower', SDIM-2, SDIM-2, ZERO, ZERO,
     $                      DWORK( IB+2 ), SDIM )
C
C              Perform eigenvalue/matrix block exchange.
C
               CALL MB03DD( 'Triangular', DIM1, DIM2, PREC, DWORK( IB ),
     $                      SDIM, DWORK( IA ), SDIM, DWORK( IQ1 ), SDIM,
     $                      DWORK( IQ2 ), SDIM, DWORK( IWRK1 ),
     $                      LDWORK-IWRK1+1, INFO )
               IF( INFO.GT.0 ) THEN
                  INFO = 1
                  RETURN
               END IF
C
C              Store data for blocked computations.
C
               IWORK( ICOL+1 ) = IB1
               IWORK( ICOL+2 ) = IB2
               IWORK( ICOL+3 ) = IB3
               IWORK( ICOL+4 ) = IWORK( ICOL ) + SDIM*SDIM
               CALL DLACPY( 'Full', SDIM, SDIM, DWORK( IQ2 ), SDIM,
     $                      DWORK( IWORK( ICOL ) ), SDIM )
               ICOL = ICOL + 4
C
C              Copy the transformed diagonal blocks, if sdim > 2.
C
               NROWS = IB1 - 1
               ICS   = IB3
               IF( SDIM.GT.2 ) THEN
                  CALL DLACPY( 'Upper', SDIM, SDIM, DWORK( IA ), SDIM,
     $                         A( IB1, IB1 ), LDA )
                  CALL DLACPY( 'Upper', SDIM, SDIM, DWORK( IB ), SDIM,
     $                         B( IB1, IB1 ), LDB )
                  CALL DCOPY(  SDIM-1, DWORK( IB+1 ), SDIM+1,
     $                         B( IB1+1, IB1 ), LDB+1 )
               ELSE
                  CALL DGEMM( 'Transpose', 'No Transpose', SDIM, SDIM,
     $                        SDIM, ONE, DWORK( IQ2 ), SDIM,
     $                        A( IB1, IB1 ), LDA, ZERO, DWORK( IA ),
     $                        SDIM )
                  CALL DGEMM( 'No Transpose', 'No Transpose', SDIM,
     $                        SDIM, SDIM, ONE, DWORK( IA ), SDIM,
     $                        DWORK( IQ1 ), SDIM, ZERO, A( IB1, IB1 ),
     $                        LDA )
                  CALL DGEMM( 'Transpose', 'No Transpose', SDIM, SDIM,
     $                        SDIM, ONE, DWORK( IQ2 ), SDIM,
     $                        B( IB1, IB1 ), LDB, ZERO, DWORK( IB ),
     $                        SDIM )
                  CALL DGEMM( 'No Transpose', 'No Transpose', SDIM,
     $                        SDIM, SDIM, ONE, DWORK( IB ), SDIM,
     $                        DWORK( IQ1 ), SDIM, ZERO, B( IB1, IB1 ),
     $                        LDB )
               END IF
C
               IC   = ICS
               LDW  = MAX( 1, NROWS )
C
C              Update A.
C
               CALL DGEMM(  'No Transpose', 'No Transpose', NROWS, SDIM,
     $                      SDIM, ONE, A( 1, IB1 ), LDA, DWORK( IQ1 ),
     $                      SDIM, ZERO, DWORK( IWRK2 ), LDW )
               CALL DLACPY( 'Full', NROWS, SDIM, DWORK( IWRK2 ), LDW,
     $                      A( 1, IB1 ), LDA )
               CALL DGEMM(  'Transpose', 'No Transpose', SDIM, NC-IB3,
     $                      SDIM, ONE, DWORK( IQ2 ), SDIM, A( IB1, IC ),
     $                      LDA, ZERO, DWORK( IWRK2 ), SDIM )
               CALL DLACPY( 'Full', SDIM, NC-IB3, DWORK( IWRK2 ),
     $                      SDIM, A( IB1, IC ), LDA )
C
C              Update D.
C
               CALL DGEMM(  'No Transpose', 'No Transpose', NROWS, SDIM,
     $                      SDIM, ONE, D( 1, IB1 ), LDD, DWORK( IQ2 ),
     $                      SDIM, ZERO, DWORK( IWRK2 ), LDW )
               CALL DLACPY( 'Full', NROWS, SDIM, DWORK( IWRK2 ), LDW,
     $                      D( 1, IB1 ), LDD )
               CALL DGEMM(  'Transpose', 'No Transpose', SDIM, NC-IB3,
     $                      SDIM, ONE, DWORK( IQ2 ), SDIM,
     $                      D( IB1, ICS ), LDD, ZERO, DWORK( IWRK2 ),
     $                      SDIM )
               CALL DLACPY( 'Full', SDIM, NC-IB3, DWORK( IWRK2 ),
     $                      SDIM, D( IB1, ICS ), LDD )
               CALL MB01LD( 'Upper', 'Transpose', SDIM, SDIM, ZERO, ONE,
     $                      D( IB1, IB1 ), LDD, DWORK( IQ2 ), SDIM,
     $                      D( IB1, IB1 ), LDD, DWORK( IWRK2 ),
     $                      LDWORK-IWRK2+1, INFO )
C
C              Update B.
C
               CALL DGEMM(  'No Transpose', 'No Transpose', NROWS, SDIM,
     $                      SDIM, ONE, B( 1, IB1 ), LDB, DWORK( IQ1 ),
     $                      SDIM, ZERO, DWORK( IWRK2 ), LDW )
               CALL DLACPY( 'Full', NROWS, SDIM, DWORK( IWRK2 ), LDW,
     $                      B( 1, IB1 ), LDB )
               CALL DGEMM(  'Transpose', 'No Transpose', SDIM, NC-IB3,
     $                      SDIM, ONE, DWORK( IQ2 ), SDIM, B( IB1, IC ),
     $                      LDB, ZERO, DWORK( IWRK2 ), SDIM )
               CALL DLACPY( 'Full', SDIM, NC-IB3, DWORK( IWRK2 ),
     $                      SDIM, B( IB1, IC ), LDB )
C
C              Update F.
C
               CALL DGEMM(  'No Transpose', 'No Transpose', NROWS, SDIM,
     $                      SDIM, ONE, F( 1, IB1 ), LDF, DWORK( IQ2 ),
     $                      SDIM, ZERO, DWORK( IWRK2 ), LDW )
               CALL DLACPY( 'Full', NROWS, SDIM, DWORK( IWRK2 ), LDW,
     $                      F( 1, IB1 ), LDF )
               CALL DGEMM(  'Transpose', 'No Transpose', SDIM, NC-IB3,
     $                      SDIM, ONE, DWORK( IQ2 ), SDIM,
     $                      F( IB1, ICS ), LDF, ZERO, DWORK( IWRK2 ),
     $                      SDIM )
               CALL DLACPY( 'Full', SDIM, NC-IB3, DWORK( IWRK2 ),
     $                      SDIM, F( IB1, ICS ), LDF )
               CALL MB01RU( 'Upper', 'Transpose', SDIM, SDIM, ZERO, ONE,
     $                      F( IB1, IB1 ), LDF, DWORK( IQ2 ), SDIM,
     $                      F( IB1, IB1 ), LDF, DWORK( IWRK2 ),
     $                      LDWORK-IWRK2+1, INFO )
               CALL DSCAL( SDIM, HALF, F( IB1, IB1 ), LDF+1 )
C
               IF( LCMPQ ) THEN
C
C                 Update Q.
C
                  CALL DGEMM(  'No Transpose', 'No Transpose', UPDS,
     $                         SDIM, SDIM, ONE, Q( 1, IB1 ), LDQ,
     $                         DWORK( IQ1 ), SDIM, ZERO, DWORK( IWRK2 ),
     $                         UPDS )
                  CALL DLACPY( 'Full', UPDS, SDIM, DWORK( IWRK2 ), UPDS,
     $                         Q( 1, IB1 ), LDQ )
                  CALL DGEMM(  'No Transpose', 'No Transpose', UPDS,
     $                         SDIM, SDIM, ONE, Q( IUPD, M+IB1 ), LDQ,
     $                         DWORK( IQ2 ), SDIM, ZERO, DWORK( IWRK2 ),
     $                         UPDS )
                  CALL DLACPY( 'Full', UPDS, SDIM, DWORK( IWRK2 ), UPDS,
     $                         Q( IUPD, M+IB1 ), LDQ )
               END IF
C
C              Update index list IWORK(1:M) if a 1-by-1 and 2-by-2 block
C              have been swapped. IWORK(M+2:N+1) is not needed anymore,
C              so it is not necessary to update it.
C
               HLP = DIM2 - DIM1
               IF( HLP.EQ.1 ) THEN
C
C                 First block was 2-by-2.
C
                  IWORK( J+1 ) = IB1 + 1
               ELSE IF( HLP.EQ.-1 ) THEN
C
C                 Second block was 2-by-2.
C
                  IWORK( J+1 ) = IB1 + 2
               END IF
  210       CONTINUE
C
C           Panel Updates.
C
C           Update A.
C
            DO 230 JS = IWORK( MP ), M, NB
               JE = MIN( M, JS+NB-1 )
               NCOL = JE - JS + 1
               ICOL = NP2
               DO 220 J = K, MP - 2
                  DIM1 = IWORK( ICOL+2 ) - IWORK( ICOL+1 )
                  DIM2 = IWORK( ICOL+3 ) - IWORK( ICOL+2 )
                  SDIM = DIM1 + DIM2
                  CALL DGEMM(  'Transpose', 'No Transpose', SDIM, NCOL,
     $                         SDIM, ONE, DWORK( IWORK( ICOL ) ),
     $                         SDIM, A( IWORK( ICOL+1 ), JS ), LDA,
     $                         ZERO, DWORK( IWRK2 ), SDIM )
                  CALL DLACPY( 'Full', SDIM, NCOL, DWORK( IWRK2 ), SDIM,
     $                         A( IWORK( ICOL+1 ), JS ), LDA )
                  ICOL = ICOL + 4
  220          CONTINUE
  230       CONTINUE
C
C           Update D.
C
            DO 250 JS = IWORK( MP ), M, NB
               JE = MIN( M, JS+NB-1 )
               NCOL = JE - JS + 1
               ICOL = NP2
               DO 240 J = K, MP - 2
                  DIM1 = IWORK( ICOL+2 ) - IWORK( ICOL+1 )
                  DIM2 = IWORK( ICOL+3 ) - IWORK( ICOL+2 )
                  SDIM = DIM1 + DIM2
                  CALL DGEMM(  'Transpose', 'No Transpose', SDIM, NCOL,
     $                         SDIM, ONE, DWORK( IWORK( ICOL ) ),
     $                         SDIM, D( IWORK( ICOL+1 ), JS ), LDD,
     $                         ZERO, DWORK( IWRK2 ), SDIM )
                  CALL DLACPY( 'Full', SDIM, NCOL, DWORK( IWRK2 ), SDIM,
     $                         D( IWORK( ICOL+1 ), JS ), LDD )
                  ICOL = ICOL + 4
  240          CONTINUE
  250       CONTINUE
C
C           Update B.
C
            DO 270 JS = IWORK( MP ), M, NB
               JE = MIN( M, JS+NB-1 )
               NCOL = JE - JS + 1
               ICOL = NP2
               DO 260 J = K, MP - 2
                  DIM1 = IWORK( ICOL+2 ) - IWORK( ICOL+1 )
                  DIM2 = IWORK( ICOL+3 ) - IWORK( ICOL+2 )
                  SDIM = DIM1 + DIM2
                  CALL DGEMM(  'Transpose', 'No Transpose', SDIM, NCOL,
     $                         SDIM, ONE, DWORK( IWORK( ICOL ) ),
     $                         SDIM, B( IWORK( ICOL+1 ), JS ), LDB,
     $                         ZERO, DWORK( IWRK2 ), SDIM )
                  CALL DLACPY( 'Full', SDIM, NCOL, DWORK( IWRK2 ), SDIM,
     $                         B( IWORK( ICOL+1 ), JS ), LDB )
                  ICOL = ICOL + 4
  260          CONTINUE
  270       CONTINUE
C
C           Update F.
C
            DO 290 JS = IWORK( MP ), M, NB
               JE = MIN( M, JS+NB-1 )
               NCOL = JE - JS + 1
               ICOL = NP2
               DO 280 J = K, MP - 2
                  DIM1 = IWORK( ICOL+2 ) - IWORK( ICOL+1 )
                  DIM2 = IWORK( ICOL+3 ) - IWORK( ICOL+2 )
                  SDIM = DIM1 + DIM2
                  CALL DGEMM(  'Transpose', 'No Transpose', SDIM, NCOL,
     $                         SDIM, ONE, DWORK( IWORK( ICOL ) ),
     $                         SDIM, F( IWORK( ICOL+1 ), JS ), LDF,
     $                         ZERO, DWORK( IWRK2 ), SDIM )
                  CALL DLACPY( 'Full', SDIM, NCOL, DWORK( IWRK2 ), SDIM,
     $                         F( IWORK( ICOL+1 ), JS ), LDF )
                  ICOL = ICOL + 4
  280          CONTINUE
  290       CONTINUE
C
            MP = MP - 1
         END IF
         K = K - 1
      GO TO 200
C
C     END WHILE 200
C
      END IF
C
C     STEP 2: Reorder the remaining eigenvalues with negative real parts.
C
C     Set pointers for the inputs and outputs of MB03HD.
C
      IQUPLE = 1
      IAUPLE = IQUPLE + 16
      IBUPLE = IAUPLE +  8
      IWRK5  = IBUPLE +  8
      IWRK3  = IAUPLE
      IWRK4  = IWRK3  + 2*N
      ITMP1  = IWRK3  + N
      ITMP2  = ITMP1  + 4
      ITMP3  = ITMP2  + 4
C
      DO 470 K = R, MP, -1
C
C        I. Exchange the eigenvalues between two diagonal blocks.
C
         IR   = IWORK( R )
         DIM1 = IWORK( R+1 ) - IR
         SDIM = 2*DIM1
C
         IF( DIM1.EQ.2 ) THEN
            A( M, IR ) = ZERO
C
C           Build the (small) full skew-symmetric matrix D(M-1:M,M-1:M)
C           and the (small) symmetric matrix F(M-1:M,M-1:M).
C
            D( IR, IR ) =  ZERO
            D(  M, IR ) = -D( IR, M )
            D(  M,  M ) =  ZERO
            F(  M, IR ) =  F( IR, M )
         END IF
C
C        Calculate position of submatrices in DWORK.
C
         IBUPRI = IBUPLE + DIM1*DIM1
         IQLOLE = IQUPLE + DIM1
         IQUPRI = IQUPLE + DIM1*SDIM
         IQLORI = IQUPRI + DIM1
C
C        Generate input matrices for MB03HD built of submatrices of A,
C        D, B, and F.
C
         IF( DIM1.EQ.2 ) THEN
            CALL DLACPY( 'Upper', DIM1, DIM1, A( IR, IR ), LDA,
     $                   DWORK( IAUPLE ), DIM1 )
            DWORK( IAUPLE+6 ) = D( IR, IR+1 )
            CALL DLACPY( 'Full', DIM1, DIM1, B( IR, IR ), LDB,
     $                   DWORK( IBUPLE ), DIM1 )
            CALL DLACPY( 'Upper', DIM1, DIM1, F( IR, IR ), LDF,
     $                   DWORK( IBUPRI ), DIM1 )
         ELSE
            DWORK( IBUPLE ) = B( IR, IR )
            DWORK( IBUPRI ) = F( IR, IR )
         END IF
C
C        Perform eigenvalue exchange.
C        Workspace: IWRK5 + 23, if SDIM = 4.
C
         CALL MB03HD( SDIM, DWORK( IAUPLE ), DIM1, DWORK( IBUPLE ),
     $                DIM1, PAR, DWORK( IQUPLE ), SDIM, DWORK( IWRK5 ),
     $                INFO )
         IF( INFO.GT.0 ) THEN
            INFO = 2
            RETURN
         END IF
C
         IF( DIM1.EQ.2 ) THEN
C
C           Update A by transformations from the right.
C           Workspace: IWRK3 + N - 1.
C
            CALL DLACPY( 'Full', M, DIM1, A( 1, IR ), LDA,
     $                   DWORK( IWRK3 ), M )
            CALL DGEMM(  'No Transpose', 'No Transpose', M, DIM1, DIM1,
     $                   ONE, DWORK( IWRK3 ), M, DWORK( IQUPLE ), SDIM,
     $                   ZERO, A( 1, IR ), LDA )
            CALL DGEMM(  'No Transpose', 'No Transpose', M, DIM1, DIM1,
     $                   ONE, D( 1, IR ), LDD, DWORK( IQLOLE ), SDIM,
     $                   ONE, A( 1, IR ), LDA )
C
C           Update D by transformations from the right.
C
            CALL DGEMM(  'No Transpose', 'No Transpose', M, DIM1, DIM1,
     $                   ONE, DWORK( IWRK3 ), M, DWORK( IQUPRI ), SDIM,
     $                   ZERO, DWORK( ITMP1 ), M )
            CALL DGEMM(  'No Transpose', 'No Transpose', M, DIM1, DIM1,
     $                   ONE, D( 1, IR ), LDD, DWORK( IQLORI ), SDIM,
     $                   ONE, DWORK( ITMP1 ), M )
            CALL DLACPY( 'Full', M, DIM1, DWORK( ITMP1 ), M, D( 1, IR ),
     $                   LDD )
C
C           Compute the intermediate product Af'*Q21 and the second
C           column of Af'*Q22, with Af = A(M-1:M,M-1:M).
C
            CALL DGEMM( 'Transpose', 'No Transpose', DIM1, DIM1, DIM1,
     $                  ONE, DWORK( IWRK3+M-DIM1 ), M, DWORK( IQLOLE ),
     $                  SDIM, ZERO, DWORK( ITMP1 ), DIM1 )
            CALL DGEMV( 'Transpose', DIM1, DIM1, ONE,
     $                  DWORK( IWRK3+M-DIM1 ), M, DWORK( IQLORI+SDIM ),
     $                  1, ZERO, DWORK( ITMP2 ), 1 )
C
C           Update A by transformations from the left.
C
            CALL DLACPY( 'Full', DIM1, DIM1, A( IR, IR ), LDA,
     $                   DWORK( IWRK3 ), DIM1 )
            CALL DGEMM(  'Transpose', 'No Transpose', DIM1, DIM1, DIM1,
     $                   -ONE, DWORK( IQUPRI ), SDIM, DWORK( ITMP1 ),
     $                   DIM1, ZERO, A( IR, IR ), LDA )
            CALL DGEMM(  'Transpose', 'No Transpose', DIM1, DIM1, DIM1,
     $                   ONE, DWORK( IQLORI ), SDIM, DWORK( IWRK3 ),
     $                   DIM1, ONE, A( IR, IR ), LDA )
C
C           Update D by transformations from the left.
C
            D( IR, M ) = DDOT( DIM1, DWORK( IQLORI ), 1, D( IR, M ), 1 )
     $                 - DDOT( DIM1, DWORK( IQUPRI ), 1, DWORK( ITMP2 ),
     $                         1 )
C
C           Update B by transformations from the right.
C
            CALL DLACPY( 'Full', M, DIM1, B( 1, IR ), LDB,
     $                   DWORK( IWRK3 ), M )
            CALL DGEMM(  'No Transpose', 'No Transpose', M, DIM1, DIM1,
     $                   ONE, DWORK( IWRK3 ), M, DWORK( IQUPLE ), SDIM,
     $                   ZERO, B( 1, IR ), LDB )
            CALL DGEMM(  'No Transpose', 'No Transpose', M, DIM1, DIM1,
     $                   ONE, F( 1, IR ), LDF, DWORK( IQLOLE ), SDIM,
     $                   ONE, B( 1, IR ), LDB )
C
C           Update F by transformations from the right.
C
            CALL DGEMM(  'No Transpose', 'No Transpose', M, DIM1, DIM1,
     $                   ONE, DWORK( IWRK3 ), M, DWORK( IQUPRI ), SDIM,
     $                   ZERO, DWORK( ITMP1 ), M )
            CALL DGEMM(  'No Transpose', 'No Transpose', M, DIM1, DIM1,
     $                   ONE, F( 1, IR ), LDF, DWORK( IQLORI ), SDIM,
     $                   ONE, DWORK( ITMP1 ), M )
            CALL DLACPY( 'Full', M, DIM1, DWORK( ITMP1 ), M, F( 1, IR ),
     $                   LDF )
C
C           Compute intermediate products Bf'*Q21 and Bf'*Q22, with
C           Bf = B(M-1:M,M-1:M).
C
            CALL DGEMM( 'Transpose', 'No Transpose', DIM1, DIM1, DIM1,
     $                  ONE, DWORK( IWRK3+M-DIM1 ), M, DWORK( IQLOLE ),
     $                  SDIM, ZERO, DWORK( ITMP1 ), DIM1 )
C
            CALL DGEMM( 'Transpose', 'No Transpose', DIM1, DIM1, DIM1,
     $                  ONE, DWORK( IWRK3+M-DIM1 ), M, DWORK( IQLORI ),
     $                  SDIM, ZERO, DWORK( ITMP2 ), DIM1 )
C
C           Update B by transformations from the left.
C
            CALL DLACPY( 'Full', DIM1, DIM1, B( IR, IR ), LDB,
     $                   DWORK( ITMP3 ), DIM1 )
            CALL DGEMM(  'Transpose', 'No Transpose', DIM1, DIM1, DIM1,
     $                   ONE, DWORK( IQUPRI ), SDIM, DWORK( ITMP1 ),
     $                   DIM1, ZERO, B( IR, IR ), LDB )
            CALL DGEMM(  'Transpose', 'No Transpose', DIM1, DIM1, DIM1,
     $                   ONE, DWORK( IQLORI ), SDIM, DWORK( ITMP3 ),
     $                   DIM1, ONE, B( IR, IR ), LDB )
C
C           Update F by transformations from the left.
C
            CALL MB01RX( 'Left', 'Upper', 'Transpose', DIM1, DIM1, ZERO,
     $                   ONE, DWORK( ITMP1 ), DIM1, DWORK( IQLORI ),
     $                   SDIM, F( IR, IR ), LDF, INFO )
            CALL MB01RX( 'Left', 'Upper', 'Transpose', DIM1, DIM1, ONE,
     $                   ONE, DWORK( ITMP1 ), DIM1, DWORK( IQUPRI ),
     $                   SDIM, DWORK( ITMP2 ), DIM1, INFO )
            CALL DLACPY( 'Upper', DIM1, DIM1, DWORK( ITMP1 ), DIM1,
     $                   F( IR, IR ), LDF )
C
            IF( LCMPQ ) THEN
C
C              Update Q.
C              Workspace: IWRK4 + 2*N - 1.
C
               CALL DLACPY( 'Full', N, DIM1, Q( 1, IR ), LDQ,
     $                      DWORK( IWRK4 ), N )
               CALL DGEMM(  'No Transpose', 'No Transpose', N, DIM1,
     $                      DIM1, ONE, DWORK( IWRK4 ), N,
     $                      DWORK( IQUPLE ), SDIM, ZERO, Q( 1, IR ),
     $                      LDQ )
               CALL DGEMM(  'No Transpose', 'No Transpose', N, DIM1,
     $                      DIM1, ONE, Q( 1, M+IR ), LDQ,
     $                      DWORK( IQLOLE ), SDIM, ONE, Q( 1, IR ),
     $                      LDQ )
               CALL DGEMM(  'No Transpose', 'No Transpose', N, DIM1,
     $                      DIM1, ONE, DWORK( IWRK4 ), N,
     $                      DWORK( IQUPRI ), SDIM, ZERO, DWORK( IWRK3 ),
     $                      N )
               CALL DGEMM(  'No Transpose', 'No Transpose', N, DIM1,
     $                      DIM1, ONE, Q( 1, M+IR ), LDQ,
     $                      DWORK( IQLORI ), SDIM, ONE, DWORK( IWRK3 ),
     $                      N )
               CALL DLACPY( 'Full', N, DIM1, DWORK( IWRK3 ), N,
     $                      Q( 1, M+IR ), LDQ )
            END IF
         ELSE
            Q11 = DWORK( IQUPLE )
            Q21 = DWORK( IQLOLE )
            Q12 = DWORK( IQUPRI )
            Q22 = DWORK( IQLORI )
C
C           Update A by transformations from the right.
C
            CALL DCOPY( M-1, A( 1, IR ), 1, DWORK( IWRK3 ), 1 )
            CALL DSCAL( M-1, Q11, A( 1, IR ), 1 )
            CALL DAXPY( M-1, Q21, D( 1, IR ), 1, A( 1, IR ), 1 )
C
C           Update D by transformations from the right.
C
            CALL DSCAL( M-1, Q22, D( 1, IR ), 1 )
            CALL DAXPY( M-1, Q12, DWORK( IWRK3 ), 1, D( 1, IR ), 1 )
C
C           Update B by transformations from the right.
C
            CALL DCOPY( M-1, B( 1, IR ), 1, DWORK( IWRK3 ), 1 )
            CALL DSCAL( M-1, Q11, B( 1, IR ), 1 )
            CALL DAXPY( M-1, Q21, F( 1, IR ), 1, B( 1, IR ), 1 )
C
C           Update F by transformations from the right.
C
            CALL DSCAL( M-1, Q22, F( 1, IR ), 1 )
            CALL DAXPY( M-1, Q12, DWORK( IWRK3 ), 1, F( 1, IR ), 1 )
C
C           Update B by transformations from the left.
C
            B( M, M ) = -B( M, M )
C
            IF( LCMPQ ) THEN
C
C              Update Q.
C
               CALL DCOPY( N, Q( 1, IR ), 1, DWORK( IWRK4 ), 1 )
               CALL DSCAL( N, Q11, Q( 1, IR ), 1 )
               CALL DAXPY( N, Q21, Q( 1, IR+M ), 1, Q( 1, IR ), 1 )
               CALL DSCAL( N, Q22, Q( 1, IR+M ), 1 )
               CALL DAXPY( N, Q12, DWORK( IWRK4 ), 1, Q( 1, IR+M ), 1 )
            END IF
C
         END IF
C
         MM = MM + 1
C
         ICOL = NP2
         IF ( LCMPQ ) THEN
            IWORK( ICOL ) = MAX( 109, IWRK2 + 4*N )
         ELSE
            IWORK( ICOL ) = MAX( 109, IWRK2 + 2*N )
         END IF
         DO 300 J = R - 1, MM, -1
            IB1  = IWORK( J )
            IB2  = IWORK( J+1 )
            IB3  = IWORK( J+2 )
            DIM1 = IB2  - IB1
            DIM2 = IB3  - IB2
            SDIM = DIM1 + DIM2
C
C           Copy the relevant part of A(ib1:ib3-1,ib1:ib3-1) and
C           B(ib1:ib3-1,ib1:ib3-1) to DWORK as inputs for MB03DD.
C           Also, set the additional zero elements.
C
            CALL DLACPY( 'Upper', SDIM, SDIM, A( IB1, IB1 ), LDA,
     $                   DWORK( IA ), SDIM )
            CALL DLASET( 'Lower', SDIM-1, SDIM-1, ZERO, ZERO,
     $                   DWORK( IA+1 ), SDIM )
            CALL DLACPY( 'Upper', SDIM, SDIM, B( IB1, IB1 ), LDB,
     $                   DWORK( IB ), SDIM )
            CALL DCOPY(  SDIM-1, B( IB1+1, IB1 ), LDB+1, DWORK( IB+1 ),
     $                   SDIM+1 )
            CALL DLASET( 'Lower', SDIM-2, SDIM-2, ZERO, ZERO,
     $                   DWORK( IB+2 ), SDIM )
C
C           Perform eigenvalue/matrix block exchange.
C
            CALL MB03DD( 'Triangular', DIM1, DIM2, PREC, DWORK( IB ),
     $                   SDIM, DWORK( IA ), SDIM, DWORK( IQ1 ), SDIM,
     $                   DWORK( IQ2 ), SDIM, DWORK( IWRK1 ),
     $                   LDWORK-IWRK1+1, INFO )
            IF( INFO.GT.0 ) THEN
               INFO = 1
               RETURN
            END IF
C
C           Store data for blocked computations.
C
            IWORK( ICOL+1 ) = IB1
            IWORK( ICOL+2 ) = IB2
            IWORK( ICOL+3 ) = IB3
            IWORK( ICOL+4 ) = IWORK( ICOL ) + SDIM*SDIM
            CALL DLACPY( 'Full', SDIM, SDIM, DWORK( IQ2 ), SDIM,
     $                   DWORK( IWORK( ICOL ) ), SDIM )
            ICOL = ICOL + 4
C
C           Copy the transformed diagonal blocks, if sdim > 2.
C
            NROWS = IB1 - 1
            ICS   = IB3
            IF( SDIM.GT.2 ) THEN
               CALL DLACPY( 'Upper', SDIM, SDIM, DWORK( IA ), SDIM,
     $                      A( IB1, IB1 ), LDA )
               CALL DLACPY( 'Upper', SDIM, SDIM, DWORK( IB ), SDIM,
     $                      B( IB1, IB1 ), LDB )
               CALL DCOPY(  SDIM-1, DWORK( IB+1 ), SDIM+1,
     $                      B( IB1+1, IB1 ), LDB+1 )
            ELSE
               CALL DGEMM( 'Transpose', 'No Transpose', SDIM, SDIM,
     $                     SDIM, ONE, DWORK( IQ2 ), SDIM, A( IB1, IB1 ),
     $                     LDA, ZERO, DWORK( IA ), SDIM )
               CALL DGEMM( 'No Transpose', 'No Transpose', SDIM, SDIM,
     $                     SDIM, ONE, DWORK( IA ), SDIM, DWORK( IQ1 ),
     $                     SDIM, ZERO, A( IB1, IB1 ), LDA )
               CALL DGEMM( 'Transpose', 'No Transpose', SDIM, SDIM,
     $                     SDIM, ONE, DWORK( IQ2 ), SDIM, B( IB1, IB1 ),
     $                     LDB, ZERO, DWORK( IB ), SDIM )
               CALL DGEMM( 'No Transpose', 'No Transpose', SDIM, SDIM,
     $                     SDIM, ONE, DWORK( IB ), SDIM, DWORK( IQ1 ),
     $                     SDIM, ZERO, B( IB1, IB1 ), LDB )
            END IF
            IC   = ICS
            LDW  = MAX( 1, NROWS )
C
C           Update A.
C
            CALL DGEMM(  'No Transpose', 'No Transpose', NROWS, SDIM,
     $                   SDIM, ONE, A( 1, IB1 ), LDA, DWORK( IQ1 ),
     $                   SDIM, ZERO, DWORK( IWRK2 ), LDW )
            CALL DLACPY( 'Full', NROWS, SDIM, DWORK( IWRK2 ), LDW,
     $                   A( 1, IB1 ), LDA )
C
C           Update D.
C
            CALL DGEMM(  'No Transpose', 'No Transpose', NROWS, SDIM,
     $                   SDIM, ONE, D( 1, IB1 ), LDD, DWORK( IQ2 ),
     $                   SDIM, ZERO, DWORK( IWRK2 ), LDW )
            CALL DLACPY( 'Full', NROWS, SDIM, DWORK( IWRK2 ), LDW,
     $                   D( 1, IB1 ), LDD )
            CALL MB01LD( 'Upper', 'Transpose', SDIM, SDIM, ZERO, ONE,
     $                   D( IB1, IB1 ), LDD, DWORK( IQ2 ), SDIM,
     $                   D( IB1, IB1 ), LDD, DWORK( IWRK2 ),
     $                   LDWORK-IWRK2+1, INFO )
C
C           Update B.
C
            CALL DGEMM(  'No Transpose', 'No Transpose', NROWS, SDIM,
     $                   SDIM, ONE, B( 1, IB1 ), LDB, DWORK( IQ1 ),
     $                   SDIM, ZERO, DWORK( IWRK2 ), LDW )
            CALL DLACPY( 'Full', NROWS, SDIM, DWORK( IWRK2 ), LDW,
     $                   B( 1, IB1 ), LDB )
C
C           Update F.
C
            CALL DGEMM(  'No Transpose', 'No Transpose', NROWS, SDIM,
     $                   SDIM, ONE, F( 1, IB1 ), LDF, DWORK( IQ2 ),
     $                   SDIM, ZERO, DWORK( IWRK2 ), LDW )
            CALL DLACPY( 'Full', NROWS, SDIM, DWORK( IWRK2 ), LDW,
     $                   F( 1, IB1 ), LDF )
            CALL MB01RU( 'Upper', 'Transpose', SDIM, SDIM, ZERO, ONE,
     $                   F( IB1, IB1 ), LDF, DWORK( IQ2 ), SDIM,
     $                   F( IB1, IB1 ), LDF, DWORK( IWRK2 ),
     $                   LDWORK-IWRK2+1, INFO )
            CALL DSCAL( SDIM, HALF, F( IB1, IB1 ), LDF+1 )
C
            IF( LCMPQ ) THEN
C
C              Update Q.
C              Workspace: IWRK2 + 4*N - 1.
C
               CALL DGEMM(  'No Transpose', 'No Transpose', N, SDIM,
     $                      SDIM, ONE, Q( 1, IB1 ), LDQ, DWORK( IQ1 ),
     $                      SDIM, ZERO, DWORK( IWRK2 ), N )
               CALL DLACPY( 'Full', N, SDIM, DWORK( IWRK2 ), N,
     $                      Q( 1, IB1 ), LDQ )
               CALL DGEMM(  'No Transpose', 'No Transpose', N, SDIM,
     $                      SDIM, ONE, Q( 1, M+IB1 ), LDQ, DWORK( IQ2 ),
     $                      SDIM, ZERO, DWORK( IWRK2 ), N )
               CALL DLACPY( 'Full', N, SDIM, DWORK( IWRK2 ), N,
     $                      Q( 1, M+IB1 ), LDQ )
            END IF
C
C           Update index list IWORK(1:M) if a 1-by-1 and 2-by-2 block
C           have been swapped.
C
            HLP = DIM2 - DIM1
            IF( HLP.EQ.1 ) THEN
C
C              First block was 2-by-2.
C
               IWORK( J+1 ) = IB1 + 1
C
            ELSE IF( HLP.EQ.-1 ) THEN
C
C              Second block was 2-by-2.
C
               IWORK( J+1 ) = IB1 + 2
            END IF
  300    CONTINUE
C
C        Panel Updates
C
C        Update A.
C
         ICOLS = NP2
         JE    = R - 1
C
C        WHILE( JE.GT.2 ) DO
  310    CONTINUE
         IF( JE.GE.MM ) THEN
            NCOL  = 0
            NC    = 0
            ICOL  = ICOLS
            BLKUP = 0
            JS = IWORK( ICOL+3 )
            DO 320 J = JE, MM, -1
               DIM1 = IWORK( ICOL+2 ) - IWORK( ICOL+1 )
               DIM2 = IWORK( ICOL+3 ) - IWORK( ICOL+2 )
               SDIM = DIM1 + DIM2
               CALL DGEMM(  'Transpose', 'No Transpose', SDIM, NCOL,
     $                      SDIM, ONE, DWORK( IWORK( ICOL ) ), SDIM,
     $                      A( IWORK( ICOL+1 ), JS ), LDA, ZERO,
     $                      DWORK( IWRK2 ), SDIM )
               CALL DLACPY( 'Full', SDIM, NCOL, DWORK( IWRK2 ), SDIM,
     $                      A( IWORK( ICOL+1 ), JS ), LDA )
               ICOL = ICOL + 4
               NC = NC + DIM1
               IF( NC.LE.NB ) THEN
                  NCOL = NCOL+DIM1
                  JS = IWORK( ICOLS+3 ) - NCOL
                  BLKUP = BLKUP+1
               END IF
  320       CONTINUE
            JE =  JE - BLKUP
            ICOLS = ICOLS + 4*BLKUP
            GO TO 310
         END IF
C        END WHILE 310
C
         DO 340 JS = IWORK( N+5 ), M, NB
            JE = MIN( M, JS+NB-1 )
            NCOL = JE - JS + 1
            ICOL = NP2
            DO 330 J = R - 1, MM, -1
               DIM1 = IWORK( ICOL+2 ) - IWORK( ICOL+1 )
               DIM2 = IWORK( ICOL+3 ) - IWORK( ICOL+2 )
               SDIM = DIM1 + DIM2
               CALL DGEMM(  'Transpose', 'No Transpose', SDIM, NCOL,
     $                      SDIM, ONE, DWORK( IWORK( ICOL ) ), SDIM,
     $                      A( IWORK( ICOL+1 ), JS ), LDA, ZERO,
     $                      DWORK( IWRK2 ), SDIM )
               CALL DLACPY( 'Full', SDIM, NCOL, DWORK( IWRK2 ), SDIM,
     $                      A( IWORK( ICOL+1 ), JS ), LDA )
               ICOL = ICOL + 4
  330       CONTINUE
  340    CONTINUE
C
C        Update D.
C
         ICOLS = NP2
         JE    = R - 1
C
C        WHILE( JE.GT.2 ) DO
  350    CONTINUE
         IF( JE.GE.MM ) THEN
            NCOL  = 0
            NC    = 0
            ICOL  = ICOLS
            BLKUP = 0
            JS = IWORK( ICOL+3 )
            DO 360 J = JE, MM, -1
               DIM1 = IWORK( ICOL+2 ) - IWORK( ICOL+1 )
               DIM2 = IWORK( ICOL+3 ) - IWORK( ICOL+2 )
               SDIM = DIM1 + DIM2
               CALL DGEMM(  'Transpose', 'No Transpose', SDIM, NCOL,
     $                      SDIM, ONE, DWORK( IWORK( ICOL ) ), SDIM,
     $                      D( IWORK( ICOL+1 ), JS ), LDD, ZERO,
     $                      DWORK( IWRK2 ), SDIM )
               CALL DLACPY( 'Full', SDIM, NCOL, DWORK( IWRK2 ), SDIM,
     $                      D( IWORK( ICOL+1 ), JS ), LDD )
               ICOL = ICOL + 4
               NC = NC + DIM1
               IF( NC.LE.NB ) THEN
                  NCOL = NCOL+DIM1
                  JS = IWORK( ICOLS+3 ) - NCOL
                  BLKUP = BLKUP+1
               END IF
  360       CONTINUE
            JE =  JE - BLKUP
            ICOLS = ICOLS + 4*BLKUP
            GO TO 350
         END IF
C        END WHILE 350
C
         DO 380 JS = IWORK( N+5 ), M, NB
            JE = MIN( M, JS+NB-1 )
            NCOL = JE - JS + 1
            ICOL = NP2
            DO 370 J = R - 1, MM, -1
               DIM1 = IWORK( ICOL+2 ) - IWORK( ICOL+1 )
               DIM2 = IWORK( ICOL+3 ) - IWORK( ICOL+2 )
               SDIM = DIM1 + DIM2
               CALL DGEMM(  'Transpose', 'No Transpose', SDIM, NCOL,
     $                      SDIM, ONE, DWORK( IWORK( ICOL ) ), SDIM,
     $                      D( IWORK( ICOL+1 ), JS ), LDD, ZERO,
     $                      DWORK( IWRK2 ), SDIM )
               CALL DLACPY( 'Full', SDIM, NCOL, DWORK( IWRK2 ), SDIM,
     $                      D( IWORK( ICOL+1 ), JS ), LDD )
               ICOL = ICOL + 4
  370       CONTINUE
  380    CONTINUE
C
C        Update B.
C
         ICOLS = NP2
         JE    = R - 1
C
C        WHILE( JE.GT.2 ) DO
  390    CONTINUE
         IF( JE.GE.MM ) THEN
            NCOL  = 0
            NC    = 0
            ICOL  = ICOLS
            BLKUP = 0
            JS = IWORK( ICOL+3 )
            DO 400 J = JE, MM, -1
               DIM1 = IWORK( ICOL+2 ) - IWORK( ICOL+1 )
               DIM2 = IWORK( ICOL+3 ) - IWORK( ICOL+2 )
               SDIM = DIM1 + DIM2
               CALL DGEMM(  'Transpose', 'No Transpose', SDIM, NCOL,
     $                      SDIM, ONE, DWORK( IWORK( ICOL ) ), SDIM,
     $                      B( IWORK( ICOL+1 ), JS ), LDB, ZERO,
     $                      DWORK( IWRK2 ), SDIM )
               CALL DLACPY( 'Full', SDIM, NCOL, DWORK( IWRK2 ), SDIM,
     $                      B( IWORK( ICOL+1 ), JS ), LDB )
               ICOL = ICOL + 4
               NC = NC + DIM1
               IF( NC.LE.NB ) THEN
                  NCOL = NCOL+DIM1
                  JS = IWORK( ICOLS+3 ) - NCOL
                  BLKUP = BLKUP+1
               END IF
  400       CONTINUE
            JE =  JE - BLKUP
            ICOLS = ICOLS + 4*BLKUP
            GO TO 390
         END IF
C        END WHILE 390
C
         DO 420 JS = IWORK( N+5 ), M, NB
            JE = MIN( M, JS+NB-1 )
            NCOL = JE - JS + 1
            ICOL = NP2
            DO 410 J = R - 1, MM, -1
               DIM1 = IWORK( ICOL+2 ) - IWORK( ICOL+1 )
               DIM2 = IWORK( ICOL+3 ) - IWORK( ICOL+2 )
               SDIM = DIM1 + DIM2
               CALL DGEMM(  'Transpose', 'No Transpose', SDIM, NCOL,
     $                      SDIM, ONE, DWORK( IWORK( ICOL ) ), SDIM,
     $                      B( IWORK( ICOL+1 ), JS ), LDB, ZERO,
     $                      DWORK( IWRK2 ), SDIM )
               CALL DLACPY( 'Full', SDIM, NCOL, DWORK( IWRK2 ), SDIM,
     $                      B( IWORK( ICOL+1 ), JS ), LDB )
               ICOL = ICOL + 4
  410       CONTINUE
  420    CONTINUE
C
C        Update F.
C
         ICOLS = NP2
         JE    = R - 1
C
C        WHILE( JE.GT.2 ) DO
  430    CONTINUE
         IF( JE.GE.MM ) THEN
            NCOL  = 0
            NC    = 0
            ICOL  = ICOLS
            BLKUP = 0
            JS = IWORK( ICOL+3 )
            DO 440 J = JE, MM, -1
               DIM1 = IWORK( ICOL+2 ) - IWORK( ICOL+1 )
               DIM2 = IWORK( ICOL+3 ) - IWORK( ICOL+2 )
               SDIM = DIM1 + DIM2
               CALL DGEMM(  'Transpose', 'No Transpose', SDIM, NCOL,
     $                      SDIM, ONE, DWORK( IWORK( ICOL ) ), SDIM,
     $                      F( IWORK( ICOL+1 ), JS ), LDF, ZERO,
     $                      DWORK( IWRK2 ), SDIM )
               CALL DLACPY( 'Full', SDIM, NCOL, DWORK( IWRK2 ), SDIM,
     $                      F( IWORK( ICOL+1 ), JS ), LDF )
               ICOL = ICOL + 4
               NC = NC + DIM1
               IF( NC.LE.NB ) THEN
                  NCOL = NCOL+DIM1
                  JS = IWORK( ICOLS+3 ) - NCOL
                  BLKUP = BLKUP+1
               END IF
  440       CONTINUE
            JE =  JE - BLKUP
            ICOLS = ICOLS + 4*BLKUP
            GO TO 430
         END IF
C        END WHILE 430
C
         DO 460 JS = IWORK( N+5 ), M, NB
            JE = MIN( M, JS+NB-1 )
            NCOL = JE - JS + 1
            ICOL = NP2
            DO 450 J = R - 1, MM, -1
               DIM1 = IWORK( ICOL+2 ) - IWORK( ICOL+1 )
               DIM2 = IWORK( ICOL+3 ) - IWORK( ICOL+2 )
               SDIM = DIM1 + DIM2
               CALL DGEMM(  'Transpose', 'No Transpose', SDIM, NCOL,
     $                      SDIM, ONE, DWORK( IWORK( ICOL ) ), SDIM,
     $                      F( IWORK( ICOL+1 ), JS ), LDF, ZERO,
     $                      DWORK( IWRK2 ), SDIM )
               CALL DLACPY( 'Full', SDIM, NCOL, DWORK( IWRK2 ), SDIM,
     $                      F( IWORK( ICOL+1 ), JS ), LDF )
               ICOL = ICOL + 4
  450       CONTINUE
  460    CONTINUE
C
  470 CONTINUE
C
      IF( M.GT.1 ) THEN
C
C        Restore the lower triangle of the submatrix D(M-1:M,M-1:M) and
C        the elements A(M,M-1) and F(M,M-1).
C
         D( M-1, M-1 ) = D1
         D(   M, M-1 ) = D2
         D(   M,   M ) = D3
         A(   M, M-1 ) = A2
         F(   M, M-1 ) = F2
      END IF
C
      IF( MM.GT.0 ) THEN
         NEIG = IWORK( MM+1 ) - 1
      ELSE
         NEIG = 0
      END IF
C
      RETURN
C *** Last line of MB03JP ***
      END


      subroutine clgen(j)

!!    ~ ~ ~ PURPOSE ~ ~ ~
!!    this subroutine calculates the daylength, distribution of
!!    radiation throughout the day and maximum radiation for day

!!    ~ ~ ~ INCOMING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    iida        |julian date   |day being simulated (current julian date)
!!    ipet        |none          |code for potential ET method
!!                               |0 Priestley-Taylor method
!!                               |1 Penman/Monteith method
!!                               |2 Hargreaves method
!!    j           |none          |HRU number
!!    latcos(:)   |none          |Cos(Latitude) for HRU
!!    latsin(:)   |none          |Sin(Latitude) for HRU
!!    npcp(:)     |none          |prior day category
!!                               |1 dry day
!!                               |2 wet day
!!    subp(:)     |mm H2O        |precipitation for the day in HRU
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ OUTGOING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    dayl(:)     |hours         |day length
!!    frad(:,:)   |none          |fraction of solar radiation occuring during
!!                               |hour in day in HRU
!!    hru_rmx(:)  |MJ/m^2        |maximum possible radiation for the day in HRU
!!    npcp(:)     |none          |prior day category
!!                               |1 dry day
!!                               |2 wet day
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ LOCAL DEFINITIONS ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    ch          |none          |(-Tan(sd)*Tan(lat))
!!    cosrho(:)   |none          |Cos(zenith angle for hour)
!!    dd          |none          |relative distance of the earth from the sun
!!    h           |none          |Acos(-Tan(sd)*Tan(lat))
!!    ii          |none          |counter
!!    sd          |radians       |solar declination: latitude at which the sun
!!                               |is directly overhead at noon
!!    totrho      |none          |sum of cosrho values for all hours of day
!!    yc          |none          |Cos(sd)*Cos(lat)
!!    ys          |none          |Sin(sd)*Sin(lat)
!!    w           |none          |hour angle
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ SUBROUTINES/FUNCTIONS CALLED ~ ~ ~
!!    Intrinsic: Sin, Tan, Acos, Cos, Real

!!    ~ ~ ~ ~ ~ ~ END SPECIFICATIONS ~ ~ ~ ~ ~ ~

      use parm

      integer, intent (in) :: j
      integer :: ii
      real*8 :: sd, ch, h, ys, yc, dd, w, cosrho(nstep), totrho

      !! Reset prior day category for precipitation
      if (subp(j) >= 0.1) then
        npcp(j) = 2
      else
        npcp(j) = 1
      end if

      !! Calculate Daylength !!
      !! calculate solar declination: equation 2.1.2 in SWAT manual
      sd = 0.
      sd = Asin(.4 * Sin((dfloat(iida) - 82.) / 58.09))  !!365/2pi = 58.09

      !! calculate the relative distance of the earth from the sun
      !! the eccentricity of the orbit
      !! equation 2.1.1 in SWAT manual
      dd = 0.
      dd = 1.0 + 0.033 * Cos(dfloat(iida) / 58.09)

      !!daylength = 2 * Acos(-Tan(sd) * Tan(lat)) / omega
      !!where the angular velocity of the earth's rotation, omega, is equal
      !! to 15 deg/hr or 0.2618 rad/hr and 2/0.2618 = 7.6374
      !! equation 2.1.6 in SWAT manual

      ch = 0.
      h = 0.
      ch = -latsin(hru_sub(j)) * Tan(sd) / latcos(hru_sub(j))
      if (ch > 1.) then    !! ch will be >= 1. if latitude exceeds +/- 66.5 deg in winter
        h = 0.
      elseif (ch >= -1.) then
        h = Acos(ch)
      else
        h = 3.1416         !! latitude exceeds +/- 66.5 deg in summer
      endif
      dayl(j) = 7.6394 * h

      !! Calculate Potential (maximum) Radiation !!
      !! equation 2.2.7 in SWAT manual
      ys = 0.
      yc = 0.
      ys = latsin(hru_sub(j)) * Sin(sd)
      yc = latcos(hru_sub(j)) * Cos(sd)
      hru_rmx(j) = 30. * dd * (h * ys + yc * Sin(h))

      !! Calculate fraction of radiation recieved during each hour in day
      !! this calculation assumes solar noon (when the angle between the
      !! observer on the earth to the sun and a line normal to the earth's
      !! at that position is at a minimum) falls at 12 noon in day.
      !! equation 2.2.10 in SWAT manual

      cosrho = 0.
      totrho = 0.
      do ii = 1, nstep
        !!angular velocity times hour away from solar noon. To calculate
        !!radiation for an hour, the hour angle for the midpoint of the
        !!time period is used. time = 0. at solar noon with positive values
        !! in the morning and negative in the evening
        w = 0.
        w = (12.5 - dfloat(ii)) * 0.2618 * idt / 60.   !!0.2618 rad/hr
        cosrho(ii) = ys + yc * Cos(w)
        if (cosrho(ii) <= 0.) cosrho(ii) = 0.
        totrho = totrho + cosrho(ii)
      end do
      if (totrho > 0.001) then
        do ii = 1, nstep
          frad(j,ii) = cosrho(ii) / totrho
        end do
      end if

      return
      end


      subroutine boostx(p_in,pt,ptt,p_out)
      implicit none
c--- Boost input vector p_in to output vector p_out using the same
c--- transformation as required to boost massive vector pt to ptt
      double precision p_in(4),pt(4),ptt(4),p_out(4),
     . p_tmp(4),beta(3),mass,gam,bdotp
      integer j

      mass=pt(4)**2-pt(1)**2-pt(2)**2-pt(3)**2
      if (mass .lt. 0d0) then
        write(6,*) 'mass**2 .lt. 0 in boostx.f, mass**2=',mass
        stop
      endif
      mass=dsqrt(mass)

c--- boost to the rest frame of pt
      gam=pt(4)/mass

      bdotp=0d0
      do j=1,3
        beta(j)=-pt(j)/pt(4)
        bdotp=bdotp+beta(j)*p_in(j)
      enddo
      p_tmp(4)=gam*(p_in(4)+bdotp)
      do j=1,3
        p_tmp(j)=p_in(j)+gam*beta(j)/(1d0+gam)*(p_in(4)+p_tmp(4))
      enddo

c--- boost from rest frame of pt to frame in which pt is identical
c--- with ptt, thus completing the transformation
      gam=ptt(4)/mass

      bdotp=0d0
      do j=1,3
        beta(j)=+ptt(j)/ptt(4)
        bdotp=bdotp+beta(j)*p_tmp(j)
      enddo
      p_out(4)=gam*(p_tmp(4)+bdotp)
      do j=1,3
        p_out(j)=p_tmp(j)+gam*beta(j)/(1d0+gam)*(p_out(4)+p_tmp(4))
      enddo

      return
      end


      double complex function a6ax(j1,j2,j3,j4,j5,j6,za,zb)
      implicit none
      include 'constants.f'
      include 'zprods_decl.f'
      include 'sprods_com.f'
      integer j1,j2,j3,j4,j5,j6
      double complex fmt,fzip
C     Implementation of BDKW Nucl Phys. 513, 3 (1998)
C     Eqn. (12.13). Their function is multipled by i*4*pi^2
      a6ax=
     .    +2d0*(fmt(s(j1,j2),s(j3,j4),s(j5,j6))
     .     -fzip(s(j1,j2),s(j3,j4),s(j5,j6)))/s(j5,j6)
     . *(zb(j6,j3)*za(j4,j2)*za(j2,j5)/za(j1,j2)
     . -zb(j6,j1)*zb(j1,j3)*za(j4,j5)/zb(j1,j2))
     .    +2d0*(fmt(s(j3,j4),s(j1,j2),s(j5,j6))
     .     -fzip(s(j3,j4),s(j1,j2),s(j5,j6)))/s(j5,j6)
     . *(zb(j6,j1)*za(j2,j4)*za(j4,j5)/za(j3,j4)
     . -zb(j6,j3)*zb(j3,j1)*za(j2,j5)/zb(j3,j4))
      return
      end


! RUN: bbc %s -o "-" | FileCheck %s

! Test real intrinsic operation lowering to FIR.

! CHECK-LABEL:eq0_test
LOGICAL FUNCTION eq0_test(x0, x1)
REAL(4) :: x0
REAL(4) :: x1
! CHECK-DAG:[[reg1:%[0-9]+]] = fir.load %arg0
! CHECK-DAG:[[reg2:%[0-9]+]] = fir.load %arg1
! CHECK:[[reg3:%[0-9]+]] = arith.cmpf oeq, [[reg1]], [[reg2]] : f32
! CHECK:fir.convert [[reg3]] {{.*}} -> !fir.logical<4>
eq0_test = x0 .EQ. x1
END FUNCTION

! CHECK-LABEL:ne1_test
LOGICAL FUNCTION ne1_test(x0, x1)
REAL(4) :: x0
REAL(4) :: x1
! CHECK-DAG:[[reg1:%[0-9]+]] = fir.load %arg0
! CHECK-DAG:[[reg2:%[0-9]+]] = fir.load %arg1
! CHECK:[[reg3:%[0-9]+]] = arith.cmpf une, [[reg1]], [[reg2]] : f32
! CHECK:fir.convert [[reg3]] {{.*}} -> !fir.logical<4>
ne1_test = x0 .NE. x1
END FUNCTION

! CHECK-LABEL:lt2_test
LOGICAL FUNCTION lt2_test(x0, x1)
REAL(4) :: x0
REAL(4) :: x1
! CHECK-DAG:[[reg1:%[0-9]+]] = fir.load %arg0
! CHECK-DAG:[[reg2:%[0-9]+]] = fir.load %arg1
! CHECK:[[reg3:%[0-9]+]] = arith.cmpf olt, [[reg1]], [[reg2]] : f32
! CHECK:fir.convert [[reg3]] {{.*}} -> !fir.logical<4>
lt2_test = x0 .LT. x1
END FUNCTION

! CHECK-LABEL:le3_test
LOGICAL FUNCTION le3_test(x0, x1)
REAL(4) :: x0
REAL(4) :: x1
! CHECK-DAG:[[reg1:%[0-9]+]] = fir.load %arg0
! CHECK-DAG:[[reg2:%[0-9]+]] = fir.load %arg1
! CHECK:[[reg3:%[0-9]+]] = arith.cmpf ole, [[reg1]], [[reg2]] : f32
! CHECK:fir.convert [[reg3]] {{.*}} -> !fir.logical<4>
le3_test = x0 .LE. x1
END FUNCTION

! CHECK-LABEL:gt4_test
LOGICAL FUNCTION gt4_test(x0, x1)
REAL(4) :: x0
REAL(4) :: x1
! CHECK-DAG:[[reg1:%[0-9]+]] = fir.load %arg0
! CHECK-DAG:[[reg2:%[0-9]+]] = fir.load %arg1
! CHECK:[[reg3:%[0-9]+]] = arith.cmpf ogt, [[reg1]], [[reg2]] : f32
! CHECK:fir.convert [[reg3]] {{.*}} -> !fir.logical<4>
gt4_test = x0 .GT. x1
END FUNCTION

! CHECK-LABEL:ge5_test
LOGICAL FUNCTION ge5_test(x0, x1)
REAL(4) :: x0
REAL(4) :: x1
! CHECK-DAG:[[reg1:%[0-9]+]] = fir.load %arg0
! CHECK-DAG:[[reg2:%[0-9]+]] = fir.load %arg1
! CHECK:[[reg3:%[0-9]+]] = arith.cmpf oge, [[reg1]], [[reg2]] : f32
! CHECK:fir.convert [[reg3]] {{.*}} -> !fir.logical<4>
ge5_test = x0 .GE. x1
END FUNCTION

! CHECK-LABEL:add6_test
REAL(4) FUNCTION add6_test(x0, x1)
REAL(4) :: x0
REAL(4) :: x1
! CHECK-DAG:[[reg1:%[0-9]+]] = fir.load %arg0
! CHECK-DAG:[[reg2:%[0-9]+]] = fir.load %arg1
! CHECK:addf [[reg1]], [[reg2]] : f32
add6_test = x0 + x1
END FUNCTION

! CHECK-LABEL:sub7_test
REAL(4) FUNCTION sub7_test(x0, x1)
REAL(4) :: x0
REAL(4) :: x1
! CHECK-DAG:[[reg1:%[0-9]+]] = fir.load %arg0
! CHECK-DAG:[[reg2:%[0-9]+]] = fir.load %arg1
! CHECK:subf [[reg1]], [[reg2]] : f32
sub7_test = x0 - x1
END FUNCTION

! CHECK-LABEL:mult8_test
REAL(4) FUNCTION mult8_test(x0, x1)
REAL(4) :: x0
REAL(4) :: x1
! CHECK-DAG:[[reg1:%[0-9]+]] = fir.load %arg0
! CHECK-DAG:[[reg2:%[0-9]+]] = fir.load %arg1
! CHECK:mulf [[reg1]], [[reg2]] : f32
mult8_test = x0 * x1
END FUNCTION

! CHECK-LABEL:div9_test
REAL(4) FUNCTION div9_test(x0, x1)
REAL(4) :: x0
REAL(4) :: x1
! CHECK-DAG:[[reg1:%[0-9]+]] = fir.load %arg0
! CHECK-DAG:[[reg2:%[0-9]+]] = fir.load %arg1
! CHECK:divf [[reg1]], [[reg2]] : f32
div9_test = x0 / x1
END FUNCTION


      program test8bbb

! pgf95 -mp -r8 -O3 -Mextend omp-test8BBB.f

      INTEGER n_threads, tid, OMP_get_num_threads, OMP_get_thread_num

      integer nx,ny,nz

      parameter (nx = 256, ny= 256, nz = 140)

      real, allocatable:: a(:,:,:), b(:,:,:), c(:,:,:)
      real time1, time2
      logical answer

      allocate ( a(0:nx+1,0:ny+1,0:nz+1),b(0:nx+1,0:ny+1,0:nz+1),c(0:nx+1,0:ny+1,0:nz+1))

!LOAD DUMMY DATA

         a = 5; b= 6; c= 7
      do k = 1, nz
        do j = 1, ny
         do i = 1, nx
           a(i,j,k) = i/real(j)*k; b(i,j,k) = 6*k*sqrt(real(i))/real(j) ; c(i,j,k)=7*i*(k*j)**1.1d0
      enddo;enddo;enddo

!FINISH LOAD OF DUMMY DATA

      write(6,*) 'number of threads    execution time(s) '

      do nthreads = 1, 16

         time1 = omp_get_wtime()
         call OMP_set_num_threads(nthreads)

         mem = 1
         call sedona (a,b,c,nx,ny,nz,mem)

         mem = 2
         call sedona (b,a,c,nx,ny,nz,mem)

         time2 = omp_get_wtime()

!$OMP PARALLEL

         if ( OMP_get_thread_num() .eq. 0) then
            write(6,*) omp_get_num_threads(), time2-time1
         endif

!$OMP END PARALLEL

      enddo

      end program test8bbb

!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&

      subroutine sedona(A,B,C,nx,ny,nz,mem)
      integer nx,ny,nz,mem

      real, intent(in ):: a(0:nx+1,0:ny+1,0:nz+1),b(0:nx+1,0:ny+1,0:nz+1)
      real, intent(out):: c(0:nx+1,0:ny+1,0:nz+1)
      integer i,j,k, tid,  OMP_get_thread_num
      real time

!$OMP PARALLEL  private(tid) Shared(a,b,c)

!$OMP DO

       do l = 1, 100
       do k = 1, nz
        do j = 1, ny
         do i = 1, nx
               c(i,j,k) =  a(i-1,j,k) * A(i,j,k) + A(i+1,j,k)* A(i,j-1,k)
     &                  + A(i,j+1,k)+ sin(A(i,j,k+1))+ A(i,j,k-1) + l
       enddo;enddo;enddo;enddo

!$OMP END DO

!$OMP END PARALLEL

      end  subroutine sedona


module camera_mod

    use vec3_class
    use ray_mod

    implicit none

    type :: camera
        real       :: vfov, aspect_ratio, aperture, focus_dist
        real       :: theta, h, viewport_height, viewport_width
        type(vec3) :: lookfrom, lookat, vup
        real,       private :: lens_radius
        type(vec3), private :: origin, horizontal, vertical, lower_left_corner, u, v, w
        contains
        procedure :: get_ray
    end type camera

    interface camera
        module procedure init_camera
    end interface camera

    contains

    function init_camera(lookfrom, lookat, vup, vfov, aspect_ratio, aperture, focus_dist) result(res)

        use utils, only : degrees_to_radians

        implicit none

        type(camera) :: res

        type(vec3), intent(IN) :: lookfrom, lookat, vup
        real,       intent(IN) :: vfov, aspect_ratio, aperture, focus_dist

        res%vfov = vfov
        res%aspect_ratio = aspect_ratio
        res%focus_dist = focus_dist

        res%theta = degrees_to_radians(vfov)
        res%h = tan(res%theta/2.)
        res%viewport_height = 2. * res%h
        res%viewport_width = res%aspect_ratio * res%viewport_height

        res%w = lookfrom - lookat
        res%w = res%w%magnitude()
        res%u = vup .cross. res%w
        res%u = res%u%magnitude()
        res%v = res%w .cross. res%u

        res%origin = lookfrom
        res%horizontal = res%focus_dist * res%viewport_width * res%u
        res%vertical = res%focus_dist * res%viewport_height * res%v
        res%lower_left_corner = res%origin - res%horizontal/2. - res%vertical/2. - res%focus_dist*res%w

        res%lens_radius = aperture / 2.
    end function init_camera

    type(ray_t) function get_ray(this, s, t)

        implicit none

        class(camera) :: this
        real, intent(IN) :: s, t

        type(vec3) :: rd, offset

        rd = this%lens_radius * random_in_unit_disk()
        offset = this%u * rd%x + this%v * rd%y

        get_ray = ray_t(offset + this%origin, this%lower_left_corner + s*this%horizontal + t*this%vertical - this%origin - offset)

    end function get_ray

end module camera_mod


      double precision function DLGAMA(X)
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 DLGAMA Krogh  Added external statement.
C>> 1995-11-16 DLGAMA Krogh  SFTRAN => Fortran 77
C>> 1995-10-24 DLGAMA Krogh  Removed blanks in numbers for C conversion.
C>> 1994-10-19 DLGAMA Krogh  Changes to use M77CON
C>> 1992-05-19 DLGAMA CLL Corrected computation of FRTBIG.
C>> 1991-10-21 DLGAMA CLL Eliminated DGAM1 as a separate subroutine.
C>> 1991-01-16 DLGAMA Lawson  Using DGAM1 in place of D2MACH/R2MACH
C>> 1986-03-18 DLGAMA Lawson  Initial code.
c--D replaces "?": ?LGAMA, ?GAMMA, ?RAT1, ?ERM1, ?ERV1
C
C     Designed and programmed by W.J.CODY, Argonne National Lab, 1982.
C     Minor changes for use in the JPL MATH77 library by C.L.LAWSON &
C     S.CHAN, JPL, 1983.
C  1992-05-19 CLL.  Noted that FRTBIG was being computed using XLBIG
c  before XLBIG was computed.  Thus branch on Y .GT. FRTBIG was
c  unreliable and was likely to cause wrong formulas to be used for
c  X between 12 and the correct value of FRTBIG.  Corrected this.
C ----------------------------------------------------------------------
C This routine calculated the LOG(GAMMA) function for a double
C     precision argument X. Computation is based on an algorithm
C     outlined in references 1 and 2. The program uses rational
C     functions that approximate LOG(GAMMA) to least 18
C     significant decimal digits. Approximations for X .LT. 12.0
C     are unpublished. Lower order approximations can be
C     substituted on machines with less precise arithmetic.
C
C  Explanaton of machine-dependent constants
C
C  XINF     The largest machine representable floating-point
C           number.
C
C  EPS      The smallest positive floating-point number such
C           that 1.0 + EPS .GT. 1.0
C
C  XGBIG  - A value such that    Gamma(XGBIG) = 0.875 * XINF.
c           (Computed and used in [D/S]GAMMA.)
C  XLBIG  - A value such that LogGamma(XLBIG) = 0.875 * XINF.
c           (Computed and used in [D/S]LGAMA.)
C
C  FRTBIG   The fourth root of XLBIG.
C
C-- Begin mask code changes
C      Values of XINF, XGBIG, and XLBIG for some machines:
C
c        XINF              XGBIG     XLBIG       Machines
c
c  2**127  = 0.170e39      34.81  0.180e37     Vax SP & DP; Unisys SP
c  2**128  = 0.340e39      35.00  0.358e37     IEEE SP
c  2**252  = 0.723e76      57.54  0.376e74     IBM30xx DP
c  2**1023 = 0.899e308    171.46  0.112e306    Unisys DP
c  2**1024 = 0.180e309    171.60  0.2216e306   IEEE DP
c  2**1070 = 0.126e323    177.78  0.1501e320   CDC/7600 SP
c  2**8191 = 0.550e2466   966.94  0.8464e2462  Cray SP & DP
C-- End mask code changes
c
c ----------------------------------------------------------------------
C
C     Error Messages
C     1) X .LE. 0., setting result large.
C     2) X too large., setting result large.
C
c     ------------------------------------------------------------------
      external         DRAT1, DGAMMA, D1MACH, DERM1, DERV1
      double precision DRAT1, DGAMMA, D1MACH
      double precision ALN4, C,CORR,D2,D4, DEL
      double precision EPS, FIVE, FRTBIG,FOUR,HALF
      double precision LOMEGA, ONE
      double precision P2,P4, P65,Q2,Q4,RES,SQRTPI
      double precision T1, T5, THRHAL,TWELVE, X,XLBIG,XDEN
      double precision XINF,XM1,XM2,XM4,XNUM
      double precision Y, Y1, Y2, YSQ, ZERO
      integer I, J
      dimension C(7),P2(8),P4(8),Q2(8),Q4(8)
C
      save XLBIG,XINF,EPS,FRTBIG
C
      DATA XINF/0.D0/
      DATA ONE,HALF,TWELVE,ZERO/1.0D0,0.5D0,12.0D0,0.0D0/
      DATA FOUR,FIVE,THRHAL / 4.D0,5.D0,1.5D0 /
      DATA SQRTPI/0.9189385332046727417803297D0/
      DATA P65 / 0.65D0 /
C                                           T5 = LN(SQRT(4*PI)) - HALF
      DATA T5 /0.76551212348464539649D0/
C                                           ALN4 = LN(4)
      DATA ALN4/1.3862943611198906188D0/
c ----------------------------------------------------------------------
C  NUMERATOR AND DENOMINATOR COEFFICIENTS FOR RATIONAL MINIMAX
C     APPROXIMATION OVER (1.5,4.0).
c ----------------------------------------------------------------------
      DATA D2/4.227843350984671393993777D-1/
      DATA P2/4.974607845568932035012064D0,5.424138599891070494101986D2,
     *        1.550693864978364947665077D4,1.847932904445632425417223D5,
     *        1.088204769468828767498470D6,3.338152967987029735917223D6,
     *        5.106661678927352456275255D6,3.074109054850539556250927D6/
      DATA Q2/1.830328399370592604055942D2,7.765049321445005871323047D3,
     *        1.331903827966074194402448D5,1.136705821321969608938755D6,
     *        5.267964117437946917577538D6,1.346701454311101692290052D7,
     *        1.782736530353274213975932D7,9.533095591844353613395747D6/
c ----------------------------------------------------------------------
C  NUMERATOR AND DENOMINATOR COEFFICIENTS FOR RATIONAL MINIMAX
C     APPROXIMATION OVER (4.0,12.0)
c ----------------------------------------------------------------------
      DATA D4/1.791759469228055000094023D0/
      DATA P4/1.474502166059939948905062D4,2.426813369486704502836312D6,
     *        1.214755574045093227939592D8,2.663432449630976949898078D9,
     *      2.940378956634553899906876D10,1.702665737765398868392998D11,
     *      4.926125793377430887588120D11,5.606251856223951465078242D11/
      DATA Q4/2.690530175870899333379843D3,6.393885654300092398984238D5,
     *        4.135599930241388052042842D7,1.120872109616147941376570D9,
     *      1.488613728678813811542398D10,1.016803586272438228077304D11,
     *      3.417476345507377132798597D11,4.463158187419713286462081D11/
c ----------------------------------------------------------------------
C  COEFFICIENTS FOR MINIMAX APPROXIMATION OVER (12,INF).
c ----------------------------------------------------------------------
      DATA C/-1.910444077728D-03,8.4171387781295D-04,
     *     -5.952379913043012D-04,7.93650793500350248D-04,
     *     -2.777777777777681622553D-03,8.333333333333333331554247D-02,
     *      5.7083835261D-03/
c ----------------------------------------------------------------------
      IF (XINF .EQ. ZERO) THEN
        XINF = D1MACH(2)
        EPS  = D1MACH(4)
c                           Compute XLBIG
c
c        XLBIG must satisfy  LogGamma(XLBIG) = 0.875 * XINF.
c        Solve this equation by successive substitution using the
c        approximation: log(gamma(x)) ~ x*(log(x) - 1).
c        Scale this equation by substituting y * 0.875 * XINF for x,
c        and solve the scaled equation for y.  y will range from
c        0.0121 when XINF = 2**127 to 0.000176 when XINF = 2**8191.
c
         LOMEGA = log(0.875d0 * XINF)
         Y1 = 0.01d0
         do 10 J=1,7
            Y2 = 1.0d0 /(LOMEGA + log(Y1) - 1.0d0)
            DEL = Y2 - Y1
            if(abs(DEL) .lt. 0.5d-5 * Y2) go to 20
            Y1 = Y2
   10    continue
   20    continue
         XLBIG = 0.875d0 * XINF * Y2
         FRTBIG = sqrt(sqrt(XLBIG))
      ENDIF
C
      Y = X
      IF (Y .LE. ZERO) THEN
        CALL DERM1('DLGAMA',2,0,'X .LE. 0.,SETTING RESULT LARGE','X',
     *             X,'.')
        GO TO 700
      ENDIF
      IF (Y .GT. XLBIG) THEN
        CALL DERM1('DLGAMA',2,0,'X TOO LARGE,SETTING RESULT LARGE','X',
     *             X,',')
        CALL DERV1('LIMIT FOR X',XLBIG,'.')
        GO TO 700
      ENDIF
      IF (Y .GT. TWELVE) GO TO 400
        IF (Y .GT. FIVE) THEN
          RES = log(DGAMMA(Y))
          GO TO 900
        END IF
      IF (Y .GT. FOUR) GO TO 300
      IF (Y .GT. THRHAL) GO TO 200
C
      IF (Y .GE. P65) THEN
        XM1 = (Y-HALF) - HALF
        RES = DRAT1(XM1)
      ELSE IF (Y .GT. HALF) THEN
C
C *** Here for .5 < Y < .65 we use the formula
C     LGAM(Y) = LGAM(2Y) - LGAM(Y+ 1/2) - Y*LOG(4) + LOG(SQRT(4*PI))
C
        XM1 = Y - HALF
        T1 = -DRAT1(XM1)
        XM1 = XM1 + XM1
        RES = (((T1+DRAT1(XM1)) - Y * ALN4) + HALF) + T5
      ELSE IF (Y .GT. EPS) THEN
        XM1 = Y
        RES = DRAT1(XM1) - log(Y)
      ELSE
        RES = -log(Y)
      END IF
      GO TO 900
c ----------------------------------------------------------------------
C  1.5 .LT. X .LE. 4.0
c ----------------------------------------------------------------------
  200 CONTINUE
      XM2 = (Y - ONE) - ONE
      XDEN = ONE
      XNUM = ZERO
      DO 240 I = 1,8
      XNUM = XNUM*XM2 + P2(I)
      XDEN = XDEN*XM2 + Q2(I)
  240 CONTINUE
      RES = XM2 * (D2 + XM2*(XNUM/XDEN))
      GO TO 900
c ---------------------------------------------------------------------
C  4.0 .LT. X .LE. 5.0
c ---------------------------------------------------------------------
  300 CONTINUE
      XM4 = Y - FOUR
      XDEN = -ONE
      XNUM = ZERO
      DO 340 I = 1,8
         XNUM = XNUM*XM4 + P4(I)
         XDEN = XDEN*XM4 + Q4(I)
  340 CONTINUE
      RES = D4 + XM4*(XNUM/XDEN)
      GO TO 900
c ---------------------------------------------------------------------
C  EVALUATE FOR ARGUMENT .GE. 12.0
c ---------------------------------------------------------------------
  400 CONTINUE
      RES = ZERO
      IF (Y .GT. FRTBIG) GO TO 460
      RES = C(7)
      YSQ = Y * Y
      DO 450 I = 1, 6
         RES = RES / YSQ + C(I)
  450 CONTINUE
  460 CONTINUE
      RES = RES / Y
      CORR = log(Y)
      RES = RES + SQRTPI - HALF*CORR
      RES = RES + Y*(CORR-ONE)
      GO TO 900
c ---------------------------------------------------------------------
C  RETURN FOR BAD ARGUMENTS
c ---------------------------------------------------------------------
  700 CONTINUE
      RES = XINF
c ---------------------------------------------------------------------
C  FINAL ADJUSTMENTS AND RETURN
c ---------------------------------------------------------------------
  900 CONTINUE
      DLGAMA = RES
      RETURN
      END
c     ==================================================================
      double precision function DRAT1(XM1)
C
C  Evaluate the rational function RAT1(XM1) which
C  with XM1 = X - 1 approximates LOG(GAMMA(X))
C  for .5 .LE. X .LE. 1.5 . This rational function
C  has poor error amplification properties for
C  .5 .le. X .le. 0.65 so we use it for
C  0.65 .le. X .le. 1.5.
c
c  D1, P1(), and Q1() are coefficients for a rational minimax
c  approximation over (0.5, 1.5).
c     ------------------------------------------------------------------
      integer I
      double precision D1, P1(8), Q1(8), XDEN, XNUM, XM1
      DATA D1/-5.772156649015328605195174D-1/
      DATA P1/4.945235359296727046734888D0,2.018112620856775083915565D2,
     *        2.290838373831346393026739D3,1.131967205903380828685045D4,
     *        2.855724635671635335736389D4,3.848496228443793359990269D4,
     *        2.637748787624195437963534D4,7.225813979700288197698961D3/
      DATA Q1/6.748212550303777196073036D1,1.113332393857199323513008D3,
     *        7.738757056935398733233834D3,2.763987074403340708898585D4,
     *        5.499310206226157329794414D4,6.161122180066002127833352D4,
     *        3.635127591501940507276287D4,8.785536302431013170870835D3/
c     ------------------------------------------------------------------
      XDEN = 1.0d0
      XNUM = 0.0d0
      do 140 I = 1,8
         XNUM = XNUM*XM1 + P1(I)
         XDEN = XDEN*XM1 + Q1(I)
  140 continue
      DRAT1 = XM1 * (D1 + XM1*(XNUM/XDEN))
      return
      end