*===============================================================================

      SUBROUTINE GRAVTY(NDEG, RGC, GGC)

*-------------------------------------------------------------------------------
*              Earth's Gravitational Field (Truncated EGM2008)
*
*  IN:  NDEG - Degree of geopotential model (0-100)
*       RGC  - Geocentric position vector (km, WGS84 frame)
*
*  OUT: GGC  - Gravitational acceleration (km/s^2, WGS84 frame)
*
*  References
*
*   - Gottlieb, R.G., "Fast Gravity, Gravity Partials, Normalized Gravity,
*     Gravity Gradient Torque and Magnetic Field: Derivation, Code and Data",
*     NASA Contractor Report 188243, February 1993.
*
*   - Pavlis, N.K., S.A. Holmes, S.C. Kenyon, and J.K. Factor,
*     "An Earth Gravitational Model to Degree 2160: EGM2008", presented at the
*     2008 General Assembly of the European Geosciences Union, Vienna, Austria,
*     April 13-18, 2008.
*
*-------------------------------------------------------------------------------

      IMPLICIT DOUBLE PRECISION (A-L,O-Z)

      PARAMETER(NMAX = 100)

      PARAMETER(NF = 100)

      PARAMETER(GM = 3.986004415D5, RE = 6.3781363D3)

      DIMENSION RGC(1:3), GGC(1:3),
     &    CC(2:NMAX, 0:NMAX), SC(2:NMAX, 0:NMAX),
     &    ETA(2:NMAX, 0:NMAX-1), XI(2:NMAX, 0:NMAX-1),
     &    ZETA(0:NMAX, 0:NMAX),
     &    P(0:NMAX, 0:NMAX),
     &    RH(1:3), RHO(1:NMAX), S(0:NMAX), C(0:NMAX)

      LOGICAL SETUP
      SAVE SETUP, CC, SC, ETA, XI, ZETA, P
      DATA SETUP /.FALSE./

*-------------------------------------------------------------------------------

      IF (.NOT.SETUP) THEN

*  Read C & S coefficients for EGM2008 from file
      OPEN(NF,
     &    FILE = 'roam/EGM2008_to100_TideFree',
     &    STATUS = 'OLD')
  10  READ(NF,*) N, M, CNM, SNM, CSTD, SSTD
      IF (N .LE. NMAX) THEN
          CC(N,M) = CNM
          SC(N,M) = SNM
          GOTO 10
      ENDIF
      CLOSE(NF)

*  Precompute eta & xi coefficients
      DO 20 N = 2,NMAX
          DO 30 M = 0,N-1
              ETA(N,M) = DSQRT((N+M-1) * (2*N+1) * (N-M-1) /
     &                     (1D0 * (N+M) * (N-M) * (2*N-3)))
              XI(N,M) = DSQRT((2*N-1) * (2*N+1) / (1D0 * (N-M) * (N+M)))
  30      CONTINUE
  20  CONTINUE

*  Precompute zeta coefficients
      DO 40 N = 0,NMAX
          ZETA(N,0) = DSQRT(N * (N+1) / 2D0)
          DO 50 M = 1,N
              ZETA(N,M) = DSQRT(1D0 * (N-M) * (N+M+1))
  50      CONTINUE
  40  CONTINUE

*  Precompute constant Legendre functions
      P(0,0) = 1
      P(1,1) = DSQRT(3D0)
      DO 60 N = 2,NMAX
          P(N,N) = DSQRT((2*N+1) / (2D0 * N)) * P(N-1,N-1)
  60  CONTINUE

*  Indicate that everything is set up
      SETUP = .TRUE.

      ENDIF

*-------------------------------------------------------------------------------

*  Radius
      R = DSQRT(RGC(1)**2 + RGC(2)**2 + RGC(3)**2)

*  Radial unit vector
      RH(1) = RGC(1) / R
      RH(2) = RGC(2) / R
      RH(3) = RGC(3) / R

*  Powers of RE/R
      RHO(1) = RE / R
      DO 70 N = 2,NDEG
          RHO(N) = RHO(N-1) * RHO(1)
  70  CONTINUE

*  C~ & S~ Functions
      C(0) = 1
      S(0) = 0
      C(1) = RH(1)
      S(1) = RH(2)
      DO 80 N = 2,NDEG
          C(N) = C(1)*C(N-1) - S(1)*S(N-1)
          S(N) = S(1)*C(N-1) + C(1)*S(N-1)
  80  CONTINUE

*  Legendre Functions
      EPS = RH(3)
      P(1,0) = EPS * P(1,1)
      DO 90 N = 2,NDEG
          P(N,N-1) = XI(N,N-1)*EPS*P(N-1,N-1)
          DO 100 M = 0,N-2
              P(N,M) = XI(N,M)*EPS*P(N-1,M) - ETA(N,M)*P(N-2,M)
 100      CONTINUE
  90  CONTINUE

*  Summations
      J = 0
      K = 0
      Y = 1
      H = 0
      DO 110 N = 2,NDEG
          JN = 0
          KN = 0
          YN = (N+1) * CC(N,0) * P(N,0)
          HN = ZETA(N,0) * CC(N,0) * P(N,1)
          DO 120 M = 1,N
              JN = JN + M * P(N,M) * (CC(N,M)*C(M-1) + SC(N,M)*S(M-1))
              KN = KN - M * P(N,M) * (CC(N,M)*S(M-1) - SC(N,M)*C(M-1))
              YN = YN + (1+N+M) * P(N,M) *(CC(N,M)*C(M) + SC(N,M)*S(M))
 120      CONTINUE
          DO 130 M = 1,N-1
              HN = HN + ZETA(N,M) * P(N,M+1) *
     &               (CC(N,M)*C(M) + SC(N,M)*S(M))
 130      CONTINUE
          J = J + RHO(N) * JN
          K = K + RHO(N) * KN
          Y = Y + RHO(N) * YN
          H = H + RHO(N) * HN
 110  CONTINUE
      L = Y + RH(3) * H

*  Gravitational acceleration
      G = GM / (R * R)
      GGC(1) = -G * (L * RH(1) - J)
      GGC(2) = -G * (L * RH(2) - K)
      GGC(3) = -G * (L * RH(3) - H)

*-------------------------------------------------------------------------------

      RETURN
      END

*===============================================================================

      REAL FUNCTION DENSTY(DT, DRGC, DF107, DF107A, DAP)

*-------------------------------------------------------------------------------
*                   Atmospheric Density (NRLMSISE-00)
*
*  IN:  DT     - Time (JD/UT)
*       DRGC   - Geocentric position vector (km, WGS84 frame)
*       DF107  - 10.7 cm solar flux (sfu), previous day average
*       DF107A - 10.7 cm solar flux (sfu), 81-day average
*       DAP    - Geomagnetic index, daily average
*
*  OUT: Total mass density (kg/m^3)
*
*-------------------------------------------------------------------------------

*  Declarations
      IMPLICIT DOUBLE PRECISION (D)
      DIMENSION DRGC(3), NSW(25), RHO(9), T(2)
      LOGICAL SETUP
      SAVE SETUP
      DATA SETUP /.FALSE./

*-------------------------------------------------------------------------------

*  Settings
      IF (.NOT.SETUP) THEN
          NSW = 1
          CALL TSELEC(NSW)
          CALL METERS(.TRUE.)
          SETUP = .TRUE.
      ENDIF

*------------------------------------------------------------------------------

*  Day of year & second of day
      NDAY = INT(DMOD(DT-0.5D0, 365.25D0))
      DSEC = 86400D0 * DMOD(DT-0.5D0, 1D0)

*  Geodetic latitude, longitude, and altitude
      CALL GEOD(DRGC, 1D-2, DLAT, DLON, DALT)

*  Local standard time
      DLST = DSEC/3600 + DLON/15

*  Convert double precision parameters to real
      F107  = REAL(DF107)
      F107A = REAL(DF107A)
      AP    = REAL(DAP)
      GLAT  = REAL(DLAT)
      GLON  = REAL(DLON)
      GALT  = REAL(DALT)
      SEC   = REAL(DSEC)
      TLST  = REAL(DLST)

* Compute density using NRLMSISE-00 Model
      IF (GALT .GT. 1000.0) THEN
          DENSTY = 0
      ELSE
          IF (GALT .GT. 500.0) THEN
              CALL GTD7D(NDAY, SEC, GALT, GLAT, GLON, TLST, F107A, F107,
     2            AP, 48, RHO, T)
          ELSE
              CALL GTD7(NDAY, SEC, GALT, GLAT, GLON, TLST, F107A, F107,
     2            AP, 48, RHO, T)
          ENDIF
          DENSTY = RHO(6)
      ENDIF

      RETURN
      END

*===============================================================================

      SUBROUTINE GEOD(RGC, TOL, LAT, LON, ALT)

*-------------------------------------------------------------------------------
*              Geocentric to Geodetic Position Conversion (WGS84)
*
*  IN:  RGC - Geocentric position vector (km)
*       TOL - Latitude tolerance (deg)
*  OUT: LAT - Geodetic latitude (deg)
*       LON - Longitude (deg)
*       ALT - Geodetic altitude (km)
*
*-------------------------------------------------------------------------------

      IMPLICIT DOUBLE PRECISION (A-Z)

      DIMENSION RGC(3)

      PARAMETER(RE = 6.3781370D3, E2 = 6.69437999014D-3)
      PARAMETER(DEGRAD = 57.29577951308232D0)

      LON = DATAN2(RGC(2), RGC(1))

      R = DSQRT(RGC(1)**2 + RGC(2)**2 + RGC(3)**2)
      P = DSQRT(RGC(1)**2 + RGC(2)**2)
      Z = RGC(3)

      LATNEW = DATAN2(P, Z)

 140  LAT = LATNEW

      SLAT = DSIN(LAT)
      CLAT = DCOS(LAT)

      RN = RE / DSQRT(1 - E2 * SLAT**2)

      ALT = P / CLAT - RN

      LATNEW = DATAN((Z/P) / (1 - E2 * RN / (RN + ALT)))

      IF (DABS(LATNEW-LAT) .GT. (TOL / DEGRAD)) GOTO 140

      LAT = LAT * DEGRAD
      LON = LON * DEGRAD

      RETURN
      END

*===============================================================================

      SUBROUTINE ROTAX3(IAX, A, R)

*-------------------------------------------------------------------------------
*               Rotation About a Principal Axis in 3D
*  IN:     IAX - Axis index (1, 2, or 3)
*          A   - Angle (deg)
*  IN/OUT: R   - Vector to be rotated
*-------------------------------------------------------------------------------

      IMPLICIT DOUBLE PRECISION (A-H,O-Z)

      DIMENSION R(3)

      PARAMETER(RADDEG = 0.017453292519943295D0)

      AR = A * RADDEG

      C = DCOS(AR)
      S = DSIN(AR)

      IF     (IAX .EQ. 1) THEN
          R2 = R(2)
          R3 = R(3)
          R(2) =  R2*C + R3*S
          R(3) = -R2*S + R3*C
      ELSEIF (IAX .EQ. 2) THEN
          R1 = R(1)
          R3 = R(3)
          R(1) =  R1*C - R3*S
          R(3) =  R1*S + R3*C
      ELSEIF (IAX .EQ. 3) THEN
          R1 = R(1)
          R2 = R(2)
          R(1) =  R1*C + R2*S
          R(2) = -R1*S + R2*C
      ENDIF

      RETURN
      END

*===============================================================================

      SUBROUTINE QTDER(Q, W, QD)

*-------------------------------------------------------------------------------
*                   Time Derivative of Quaternion
*   IN:  Q  - Quaternion (vector/imaginary part first)
*        W  - Angular velocity
*   OUT: QD - Time derivative of Q
*-------------------------------------------------------------------------------

      DOUBLE PRECISION Q(4), W(3), QD(4)

      QD(1) =  0.5 * (Q(4)*W(1) + Q(2)*W(3) - Q(3)*W(2))
      QD(2) =  0.5 * (Q(4)*W(2) + Q(3)*W(1) - Q(1)*W(3))
      QD(3) =  0.5 * (Q(4)*W(3) + Q(1)*W(2) - Q(2)*W(1))

      QD(4) = -0.5 * (Q(1)*W(1) + Q(2)*W(2) + Q(3)*W(3))

      RETURN
      END

*===============================================================================


!*==ctplqt2.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief \b CTPLQT2
!
!  Definition:
!  ===========
!
!       SUBROUTINE CTPLQT2( M, N, L, A, LDA, B, LDB, T, LDT, INFO )
!
!       .. Scalar Arguments ..
!       INTEGER   INFO, LDA, LDB, LDT, N, M, L
!       ..
!       .. Array Arguments ..
!       COMPLEX   A( LDA, * ), B( LDB, * ), T( LDT, * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> CTPLQT2 computes a LQ a factorization of a complex "triangular-pentagonal"
!> matrix C, which is composed of a triangular block A and pentagonal block B,
!> using the compact WY representation for Q.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] M
!> \verbatim
!>          M is INTEGER
!>          The total number of rows of the matrix B.
!>          M >= 0.
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The number of columns of the matrix B, and the order of
!>          the triangular matrix A.
!>          N >= 0.
!> \endverbatim
!>
!> \param[in] L
!> \verbatim
!>          L is INTEGER
!>          The number of rows of the lower trapezoidal part of B.
!>          MIN(M,N) >= L >= 0.  See Further Details.
!> \endverbatim
!>
!> \param[in,out] A
!> \verbatim
!>          A is COMPLEX array, dimension (LDA,M)
!>          On entry, the lower triangular M-by-M matrix A.
!>          On exit, the elements on and below the diagonal of the array
!>          contain the lower triangular matrix L.
!> \endverbatim
!>
!> \param[in] LDA
!> \verbatim
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!> \endverbatim
!>
!> \param[in,out] B
!> \verbatim
!>          B is COMPLEX array, dimension (LDB,N)
!>          On entry, the pentagonal M-by-N matrix B.  The first N-L columns
!>          are rectangular, and the last L columns are lower trapezoidal.
!>          On exit, B contains the pentagonal matrix V.  See Further Details.
!> \endverbatim
!>
!> \param[in] LDB
!> \verbatim
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(1,M).
!> \endverbatim
!>
!> \param[out] T
!> \verbatim
!>          T is COMPLEX array, dimension (LDT,M)
!>          The N-by-N upper triangular factor T of the block reflector.
!>          See Further Details.
!> \endverbatim
!>
!> \param[in] LDT
!> \verbatim
!>          LDT is INTEGER
!>          The leading dimension of the array T.  LDT >= max(1,M)
!> \endverbatim
!>
!> \param[out] INFO
!> \verbatim
!>          INFO is INTEGER
!>          = 0: successful exit
!>          < 0: if INFO = -i, the i-th argument had an illegal value
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date June 2017
!
!> \ingroup doubleOTHERcomputational
!
!> \par Further Details:
!  =====================
!>
!> \verbatim
!>
!>  The input matrix C is a M-by-(M+N) matrix
!>
!>               C = [ A ][ B ]
!>
!>
!>  where A is an lower triangular M-by-M matrix, and B is M-by-N pentagonal
!>  matrix consisting of a M-by-(N-L) rectangular matrix B1 left of a M-by-L
!>  upper trapezoidal matrix B2:
!>
!>               B = [ B1 ][ B2 ]
!>                   [ B1 ]  <-     M-by-(N-L) rectangular
!>                   [ B2 ]  <-     M-by-L lower trapezoidal.
!>
!>  The lower trapezoidal matrix B2 consists of the first L columns of a
!>  N-by-N lower triangular matrix, where 0 <= L <= MIN(M,N).  If L=0,
!>  B is rectangular M-by-N; if M=L=N, B is lower triangular.
!>
!>  The matrix W stores the elementary reflectors H(i) in the i-th row
!>  above the diagonal (of A) in the M-by-(M+N) input matrix C
!>
!>               C = [ A ][ B ]
!>                   [ A ]  <- lower triangular M-by-M
!>                   [ B ]  <- M-by-N pentagonal
!>
!>  so that W can be represented as
!>
!>               W = [ I ][ V ]
!>                   [ I ]  <- identity, M-by-M
!>                   [ V ]  <- M-by-N, same form as B.
!>
!>  Thus, all of information needed for W is contained on exit in B, which
!>  we call V above.  Note that V has the same form as B; that is,
!>
!>               W = [ V1 ][ V2 ]
!>                   [ V1 ] <-     M-by-(N-L) rectangular
!>                   [ V2 ] <-     M-by-L lower trapezoidal.
!>
!>  The rows of V represent the vectors which define the H(i)'s.
!>  The (M+N)-by-(M+N) block reflector H is then given by
!>
!>               H = I - W**T * T * W
!>
!>  where W^H is the conjugate transpose of W and T is the upper triangular
!>  factor of the block reflector.
!> \endverbatim
!>
!  =====================================================================
      SUBROUTINE CTPLQT2(M,N,L,A,Lda,B,Ldb,T,Ldt,Info)
      IMPLICIT NONE
!*--CTPLQT2166
!
!  -- LAPACK computational routine (version 3.7.1) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     June 2017
!
!     .. Scalar Arguments ..
      INTEGER Info , Lda , Ldb , Ldt , N , M , L
!     ..
!     .. Array Arguments ..
      COMPLEX A(Lda,*) , B(Ldb,*) , T(Ldt,*)
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      COMPLEX ONE , ZERO
      PARAMETER (ZERO=(0.0E+0,0.0E+0),ONE=(1.0E+0,0.0E+0))
!     ..
!     .. Local Scalars ..
      INTEGER i , j , p , mp , np
      COMPLEX alpha
!     ..
!     .. External Subroutines ..
      EXTERNAL CLARFG , CGEMV , CGERC , CTRMV , XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC MAX , MIN
!     ..
!     .. Executable Statements ..
!
!     Test the input arguments
!
      Info = 0
      IF ( M<0 ) THEN
         Info = -1
      ELSEIF ( N<0 ) THEN
         Info = -2
      ELSEIF ( L<0 .OR. L>MIN(M,N) ) THEN
         Info = -3
      ELSEIF ( Lda<MAX(1,M) ) THEN
         Info = -5
      ELSEIF ( Ldb<MAX(1,M) ) THEN
         Info = -7
      ELSEIF ( Ldt<MAX(1,M) ) THEN
         Info = -9
      ENDIF
      IF ( Info/=0 ) THEN
         CALL XERBLA('CTPLQT2',-Info)
         RETURN
      ENDIF
!
!     Quick return if possible
!
      IF ( N==0 .OR. M==0 ) RETURN
!
      DO i = 1 , M
!
!        Generate elementary reflector H(I) to annihilate B(I,:)
!
         p = N - L + MIN(L,i)
         CALL CLARFG(p+1,A(i,i),B(i,1),Ldb,T(1,i))
         T(1,i) = CONJG(T(1,i))
         IF ( i<M ) THEN
            DO j = 1 , p
               B(i,j) = CONJG(B(i,j))
            ENDDO
!
!           W(M-I:1) := C(I+1:M,I:N) * C(I,I:N) [use W = T(M,:)]
!
            DO j = 1 , M - i
               T(M,j) = (A(i+j,i))
            ENDDO
            CALL CGEMV('N',M-i,p,ONE,B(i+1,1),Ldb,B(i,1),Ldb,ONE,T(M,1),&
     &                 Ldt)
!
!           C(I+1:M,I:N) = C(I+1:M,I:N) + alpha * C(I,I:N)*W(M-1:1)^H
!
            alpha = -(T(1,i))
            DO j = 1 , M - i
               A(i+j,i) = A(i+j,i) + alpha*(T(M,j))
            ENDDO
            CALL CGERC(M-i,p,(alpha),T(M,1),Ldt,B(i,1),Ldb,B(i+1,1),Ldb)
            DO j = 1 , p
               B(i,j) = CONJG(B(i,j))
            ENDDO
         ENDIF
      ENDDO
!
      DO i = 2 , M
!
!        T(I,1:I-1) := C(I:I-1,1:N)**H * (alpha * C(I,I:N))
!
         alpha = -(T(1,i))
         DO j = 1 , i - 1
            T(i,j) = ZERO
         ENDDO
         p = MIN(i-1,L)
         np = MIN(N-L+1,N)
         mp = MIN(p+1,M)
         DO j = 1 , N - L + p
            B(i,j) = CONJG(B(i,j))
         ENDDO
!
!        Triangular part of B2
!
         DO j = 1 , p
            T(i,j) = (alpha*B(i,N-L+j))
         ENDDO
         CALL CTRMV('L','N','N',p,B(1,np),Ldb,T(i,1),Ldt)
!
!        Rectangular part of B2
!
         CALL CGEMV('N',i-1-p,L,alpha,B(mp,np),Ldb,B(i,np),Ldb,ZERO,    &
     &              T(i,mp),Ldt)
!
!        B1

!
         CALL CGEMV('N',i-1,N-L,alpha,B,Ldb,B(i,1),Ldb,ONE,T(i,1),Ldt)
!

!
!        T(1:I-1,I) := T(1:I-1,1:I-1) * T(I,1:I-1)
!
         DO j = 1 , i - 1
            T(i,j) = CONJG(T(i,j))
         ENDDO
         CALL CTRMV('L','C','N',i-1,T,Ldt,T(i,1),Ldt)
         DO j = 1 , i - 1
            T(i,j) = CONJG(T(i,j))
         ENDDO
         DO j = 1 , N - L + p
            B(i,j) = CONJG(B(i,j))
         ENDDO
!
!        T(I,I) = tau(I)
!
         T(i,i) = T(1,i)
         T(1,i) = ZERO
      ENDDO
      DO i = 1 , M
         DO j = i + 1 , M
            T(i,j) = (T(j,i))
            T(j,i) = ZERO
         ENDDO
      ENDDO

!
!     End of CTPLQT2
!
      END SUBROUTINE CTPLQT2


      subroutine zpassf3 (ido,l1,cc,ch,wa1,wa2)
      implicit double precision (a-h,o-z)
      dimension       cc(ido,3,l1)           ,ch(ido,l1,3)           ,
     1                wa1(1)     ,wa2(1)
      data taur,taui /-.5d0,-.866025403784439d0/
      if (ido .ne. 2) go to 102
      do 101 k=1,l1
         tr2 = cc(1,2,k)+cc(1,3,k)
         cr2 = cc(1,1,k)+taur*tr2
         ch(1,k,1) = cc(1,1,k)+tr2
         ti2 = cc(2,2,k)+cc(2,3,k)
         ci2 = cc(2,1,k)+taur*ti2
         ch(2,k,1) = cc(2,1,k)+ti2
         cr3 = taui*(cc(1,2,k)-cc(1,3,k))
         ci3 = taui*(cc(2,2,k)-cc(2,3,k))
         ch(1,k,2) = cr2-ci3
         ch(1,k,3) = cr2+ci3
         ch(2,k,2) = ci2+cr3
         ch(2,k,3) = ci2-cr3
  101 continue
      return
  102 do 104 k=1,l1
         do 103 i=2,ido,2
            tr2 = cc(i-1,2,k)+cc(i-1,3,k)
            cr2 = cc(i-1,1,k)+taur*tr2
            ch(i-1,k,1) = cc(i-1,1,k)+tr2
            ti2 = cc(i,2,k)+cc(i,3,k)
            ci2 = cc(i,1,k)+taur*ti2
            ch(i,k,1) = cc(i,1,k)+ti2
            cr3 = taui*(cc(i-1,2,k)-cc(i-1,3,k))
            ci3 = taui*(cc(i,2,k)-cc(i,3,k))
            dr2 = cr2-ci3
            dr3 = cr2+ci3
            di2 = ci2+cr3
            di3 = ci2-cr3
            ch(i,k,2) = wa1(i-1)*di2-wa1(i)*dr2
            ch(i-1,k,2) = wa1(i-1)*dr2+wa1(i)*di2
            ch(i,k,3) = wa2(i-1)*di3-wa2(i)*dr3
            ch(i-1,k,3) = wa2(i-1)*dr3+wa2(i)*di3
  103    continue
  104 continue
      return
      end


      SUBROUTINE MB03ID( COMPQ, COMPU, N, A, LDA, C, LDC, D, LDD, B,
     $                   LDB, F, LDF, Q, LDQ, U1, LDU1, U2, LDU2, 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, with
C
C                          (  0  I  )      (  A  D  )      (  B  F  )
C       S = J Z' J' Z, J = (        ), Z = (        ), H = (        ),
C                          ( -I  0  )      (  0  C  )      (  0 -B' )
C
C     to the leading principal subpencil, while keeping the triangular
C     form. Above, A is upper triangular, B is upper quasi-triangular,
C     and C is lower triangular.
C     The matrices Z and H are transformed by an orthogonal symplectic
C     matrix U and an orthogonal matrix Q such that
C
C                       (  Aout  Dout  )
C       Zout = U' Z Q = (              ), and
C                       (    0   Cout  )
C                                                                    (1)
C                            (  Bout  Fout  )
C       Hout = J Q' J' H Q = (              ),
C                            (    0  -Bout' )
C
C     where Aout, Bout and Cout remain in triangular form. The notation
C     M' denotes the transpose of the matrix M.
C     Optionally, if COMPQ = 'I' or COMPQ = 'U', the orthogonal matrix Q
C     that fulfills (1) is computed.
C     Optionally, if COMPU = 'I' or COMPU = 'U', the orthogonal
C     symplectic matrix
C
C           (  U1  U2  )
C       U = (          )
C           ( -U2  U1  )
C
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     COMPU   CHARACTER*1
C             Specifies whether or not the orthogonal symplectic
C             transformations should be accumulated in the arrays U1 and
C             U2, as follows:
C             = 'N':  U1 and U2 are not computed;
C             = 'I':  the arrays U1 and U2 are initialized internally,
C                     and the submatrices U1 and U2 defining the
C                     orthogonal symplectic matrix U are returned;
C             = 'U':  the arrays U1 and U2 contain the corresponding
C                     submatrices of an orthogonal symplectic matrix U0
C                     on entry, and the updated submatrices U1 and U2
C                     of the matrix product U0*U are returned, where U
C                     is the product of the orthogonal symplectic
C                     transformations that are applied to the pencil
C                     aS - bH to reorder 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     C       (input/output) DOUBLE PRECISION array, dimension
C                            (LDC, N/2)
C             On entry, the leading N/2-by-N/2 part of this array must
C             contain the lower triangular matrix C. The elements of the
C             strictly upper 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 Cout.
C
C     LDC     INTEGER
C             The leading dimension of the array C.  LDC >= 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 matrix D.
C             On exit, the leading  N/2-by-N/2 part of this array
C             contains the transformed matrix Dout.
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 Z 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     U1      (input/output) DOUBLE PRECISION array, dimension
C                            (LDU1, N/2)
C             On entry, if COMPU = 'U', then the leading N/2-by-N/2 part
C             of this array must contain the upper left block of a
C             given matrix U0, and on exit, the leading N/2-by-N/2 part
C             of this array contains the updated upper left block U1 of
C             the product of the input matrix U0 and the transformation
C             matrix U used to transform the matrices Z and H.
C             On exit, if COMPU = 'I', then the leading N/2-by-N/2 part
C             of this array contains the upper left block U1 of the
C             orthogonal symplectic transformation matrix U.
C             If COMPU = 'N' this array is not referenced.
C
C     LDU1    INTEGER
C             The leading dimension of the array U1.
C             LDU1 >= 1,           if COMPU = 'N';
C             LDU1 >= MAX(1, N/2), if COMPU = 'I' or COMPU = 'U'.
C
C     U2      (input/output) DOUBLE PRECISION array, dimension
C                            (LDU2, N/2)
C             On entry, if COMPU = 'U', then the leading N/2-by-N/2 part
C             of this array must contain the upper right block of a
C             given matrix U0, and on exit, the leading N/2-by-N/2 part
C             of this array contains the updated upper right block U2 of
C             the product of the input matrix U0 and the transformation
C             matrix U used to transform the matrices Z and H.
C             On exit, if COMPU = 'I', then the leading N/2-by-N/2 part
C             of this array contains the upper right block U2 of the
C             orthogonal symplectic transformation matrix U.
C             If COMPU = 'N' this array is not referenced.
C
C     LDU2    INTEGER
C             The leading dimension of the array U2.
C             LDU2 >= 1,           if COMPU = 'N';
C             LDU2 >= MAX(1, N/2), if COMPU = 'I' or COMPU = '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 >= N+1.
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+48,171);
C             if COMPQ = 'I' or COMPQ = 'U',
C                LDWORK >= MAX(4*N+48,171).
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0: succesful exit;
C             < 0: if INFO = -i, the i-th argument had an illegal value;
C             = 1: the periodic QZ algorithm did not converge in SLICOT
C                  Library routine MB03BB;
C             = 2: an error occured during the execution of MB03CD;
C             = 3: an error occured during the execution of MB03GD.
C
C     METHOD
C
C     The algorithm reorders the eigenvalues like the following scheme:
C
C     Step 1: Reorder the eigenvalues in the subpencil aC'*A - 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 aC'*A - 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 aC'*A - bB and MM denotes the current
C             number of blocks in aC'*A - bB with eigenvalues with
C             negative real parts.
C
C     The algorithm uses a sequence of orthogonal transformations as
C     described on page 25 in [1]. To achieve those transformations the
C     elementary subroutines MB03CD and MB03GD 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     CONTRIBUTOR
C
C     Matthias Voigt, Fakultaet fuer Mathematik, Technische Universitaet
C     Chemnitz, November 21, 2008.
C     V. Sima, Dec. 2009 (SLICOT version of the routine DHAFNX).
C
C     REVISIONS
C
C     V. Sima, Aug. 2009; Feb. 2010; Oct. 2010; Nov. 2010; Feb. 2011,
C     Sep. 2011.
C     M. Voigt, Jan. 2012.
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, COMPU
      INTEGER            INFO, LDA, LDB, LDC, LDD, LDF, LDQ, LDU1, LDU2,
     $                   LDWORK, LIWORK, N, NEIG
C
C     .. Array Arguments ..
      INTEGER            IWORK( * )
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), C( LDC, * ),
     $                   D( LDD, * ), DWORK( *  ), F( LDF, * ),
     $                   Q( LDQ, * ), U1( LDU1, * ), U2( LDU2, * )
C
C     .. Local Scalars ..
      LOGICAL            LCMPQ, LCMPU, LINIQ, LINIU, LUPDQ, LUPDU
      INTEGER            DIM1, DIM2, HLP, I, I1, IA, IB, IB1, IB2, IB3,
     $                   IBS, IC, IHUPLE, IQ1, IQ2, IQ3, IQLOLE, IQLORI,
     $                   IQUPLE, IQUPRI, IR, IS, ITMP1, ITMP2, ITMP3,
     $                   IUPD, IUUPLE, IUUPRI, IWRK1, IWRK2, IWRK3,
     $                   IWRK4, IWRK5, IZLORI, IZUPLE, IZUPRI, J, K,
     $                   LDW, M, MM, MP, NCOL, NCOLS, NROW, NROWS,
     $                   OPTDW, R, SDIM, UPDS
      DOUBLE PRECISION   A2, BASE, C2, DN, F2, LGBAS, NRMB, PREC, Q11,
     $                   Q12, Q21, Q22, TMPA, TMPC, TOL, U11, U12
C
C     .. Local Arrays ..
      INTEGER            IDUM( 8 )
      DOUBLE PRECISION   DUM( 3, 4 ), PAR( 2 ), PRD( 2, 2, 3 )
C
C     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            MA01CD
      DOUBLE PRECISION   DLAMCH, DLANHS
      EXTERNAL           DLAMCH, DLANHS, LSAME, MA01CD
C
C     .. External Subroutines ..
      EXTERNAL           DAXPY, DCOPY, DGEMM, DLACPY, DLASET, DSCAL,
     $                   MA02AD, MB01RU, MB01RX, MB03BB, MB03CD, MB03GD,
     $                   XERBLA
C
C     .. Intrinsic Functions ..
      INTRINSIC          ABS, DBLE, LOG, MAX, MIN, MOD, SIGN
C
C     .. Executable Statements ..
C
C     Decode the input arguments.
C
      M     = N/2
      LINIQ = LSAME( COMPQ, 'I' )
      LUPDQ = LSAME( COMPQ, 'U' )
      LINIU = LSAME( COMPU, 'I' )
      LUPDU = LSAME( COMPU, 'U' )
      LCMPQ = LINIQ .OR. LUPDQ
      LCMPU = LINIU .OR. LUPDU
C
      IF( LCMPQ ) THEN
         OPTDW = MAX( 4*N + 48, 171 )
      ELSE
         OPTDW = MAX( 2*N + 48, 171 )
      END IF
C
C     Test the input arguments.
C
      INFO = 0
      IF( .NOT.( LSAME( COMPQ, 'N' ) .OR. LCMPQ ) ) THEN
         INFO = -1
      ELSE IF( .NOT.( LSAME( COMPU, 'N' ) .OR. LCMPU ) ) THEN
         INFO = -2
      ELSE IF( N.LT.0 .OR. MOD( N, 2 ).NE.0 ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -5
      ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
         INFO = -7
      ELSE IF( LDD.LT.MAX( 1, M ) ) THEN
         INFO = -9
      ELSE IF( LDB.LT.MAX( 1, M ) ) THEN
         INFO = -11
      ELSE IF( LDF.LT.MAX( 1, M ) ) THEN
         INFO = -13
      ELSE IF( LDQ.LT.1  .OR. ( LCMPQ .AND.  LDQ.LT.N ) ) THEN
         INFO = -15
      ELSE IF( LDU1.LT.1 .OR. ( LCMPU .AND. LDU1.LT.M ) ) THEN
         INFO = -17
      ELSE IF( LDU2.LT.1 .OR. ( LCMPU .AND. LDU2.LT.M ) ) THEN
         INFO = -19
      ELSE IF( LIWORK.LT.N+1 ) THEN
         INFO = -22
      ELSE IF( LDWORK.LT.OPTDW ) THEN
         INFO = -24
      END IF
      IF( INFO.NE.0) THEN
         CALL XERBLA( 'MB03ID', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( N.EQ.0 ) THEN
         NEIG = 0
         RETURN
      END IF
C
C     Determine machine constants.
C
      PREC  = DLAMCH( 'Precision' )
      BASE  = DLAMCH( 'Base' )
      LGBAS = LOG( BASE )
      DN    = DBLE( N )*PREC
      TOL   = MIN( DBLE( M ), 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 aC'*A - bB.
C             To find IWORK(IS+J) for the block J of size dim, compute
C                                      -T                      -1
C                sign( trace(C(rng,rng)  *B(rng,rng)*A(rng,rng)  ) ),
C
C             where rng = J:J+dim-1. For dim = 2, it is assumed that
C             both eigenvalues of the matrix above have real parts with
C             the same sign (true for a structured Schur form).
C
      I  = 1
      J  = 1
      IS = M + 1
C
C     Partition blocks.
C
      NRMB = DLANHS( 'One', M, B, LDB, DWORK )
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
            IWORK( IS+J ) = SIGN( ONE, A( I, I )*B( I, I )*C( I, I ) )
            I = I + 1
         ELSE
C
C           2-by-2 block.
C
            U11  = B( I+1, I )*A( I, I+1 )
            U12  = B( I+1, I )*C( I+1, I )
            TMPA = B( I+1, I+1 )*A( I, I ) - U11
            TMPC = B( I, I )*C( I+1, I+1 ) - U12
            IF( ABS( TMPA ).LE.PREC*ABS( U11 ) .AND.
     $          ABS( TMPC ).LE.PREC*ABS( U12 ) ) THEN
C
C              Severe cancellation. Use the periodic QZ algorithm.
C              Workspace: 30.
C
               IDUM( 1 ) =  1
               IDUM( 2 ) =  2
               IDUM( 3 ) =  3
               IDUM( 4 ) =  1
               IDUM( 5 ) = -1
               IDUM( 6 ) = -1
               CALL DLACPY( 'Full',  2, 2, B( I, I ), LDB, PRD, 2 )
               CALL DLACPY( 'Upper', 2, 2, A( I, I ), LDA,
     $                      PRD( 1, 1, 2 ), 2 )
               CALL MA02AD( 'Lower', 2, 2, C( I, I ), LDC,
     $                      PRD( 1, 1, 3 ), 2 )
               PRD( 2, 1, 2 ) = ZERO
               PRD( 2, 1, 3 ) = ZERO
               CALL MB03BB( BASE, LGBAS, PREC, 3, IDUM, IDUM( 4 ), 1,
     $                      PRD, 2, 2, DWORK, DWORK( 3 ), DWORK( 5 ),
     $                      IDUM( 7 ), DWORK( 7 ), INFO )
               IF( INFO.EQ.1 )
     $            RETURN
               IF( DWORK( 5 ).EQ.ZERO .OR. DWORK( 6 ).EQ.ZERO .OR.
     $               ABS( DWORK( 1 ) ).LE.DN* ABS( DWORK( 3 ) ) )
     $               THEN
                  IWORK( IS+J ) = 0
               ELSE
                  IWORK( IS+J ) = MA01CD( DWORK( 1 ), IDUM( 7 ),
     $                                    DWORK( 2 ), IDUM( 8 ) )
               END IF
            ELSE IF( C( I, I ).EQ.ZERO .OR. A( I+1, I+1 ).EQ.ZERO ) THEN
C
C              The pencil has infinite eigenvalues or it is singular.
C
               IWORK( IS+J ) = 0
            ELSE
               U11 = TMPA/A( I+1, I+1 ) + TMPC/C( I, I )
               IF( U11.EQ.ZERO ) THEN
                  IWORK( IS+J ) = 0
               ELSE
                  IWORK( IS+J ) = SIGN( ONE, U11 )*
     $                            SIGN( ONE, A( I, I )*C( I+1, I+1 ) )
               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
C
C        1-by-1 block
C
         IWORK( J ) = I
         IWORK( IS+J ) = SIGN( ONE, A( I, I )*B( I, I )*C( I, I ) )
         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
C     Initialize U1 and U2 if appropriate.
C
      IF( LINIU ) THEN
         CALL DLASET( 'Full', M, M, ZERO, ONE,  U1, LDU1 )
         CALL DLASET( 'Full', M, M, ZERO, ZERO, U2, LDU2 )
      END IF
C
      IF( M.GT.1 ) THEN
C
C        Save the elements A(M,M-1), C(M-1,M), and F(M,M-1), which might
C        be overwritten.
C
         A2 = A( M, M-1 )
         C2 = C( M-1, M )
         F2 = F( M, M-1 )
      END IF
C
C     STEP 1: Reorder the eigenvalues in the subpencil aC'*A - 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 MB03CD.
C
      IQ1   = 1
      IQ2   = IQ1 + 16
      IQ3   = IQ2 + 16
      IA    = IQ3 + 16
      IB    = IA  + 16
      IC    = IB  + 16
      IWRK1 = IC  + 16
      IWRK2 = IA
C
      K   = 1
      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
            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),
C              C(ib1:ib3-1,ib1:ib3-1), and B(ib1:ib3-1,ib1:ib3-1) to
C              DWORK as inputs for MB03CD. Also, set the additional
C              zero elements.
C
               CALL DLACPY( 'Upper', SDIM, SDIM, A( IB1, IB1 ), LDA,
     $                      DWORK( IA ), SDIM )
               CALL MA02AD( 'Lower', SDIM, SDIM, C( IB1, IB1 ), LDC,
     $                      DWORK( IC ), 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 )
               IF( DIM1.EQ.2 ) THEN
                  DWORK( IA+1 ) = ZERO
                  DWORK( IC+1 ) = ZERO
               END IF
               IF( DIM2.EQ.2 ) THEN
                  I1 = SDIM*( SDIM - 1 ) - 1
                  DWORK( IA+I1 ) = ZERO
                  DWORK( IC+I1 ) = ZERO
               END IF
               DWORK( IB+SDIM-1 ) = ZERO
               IF( SDIM.EQ.4 ) THEN
                  DWORK( IB+2 ) = ZERO
                  DWORK( IB+7 ) = ZERO
               END IF
C
C              Perform eigenvalue/matrix block exchange.
C              Workspace: IWRK1 + 16*DIM1 + 10*DIM2 + 22 <= IWRK1 + 74,
C              if SDIM > 2, and IWRK1 - 1, otherwise.
C
               CALL MB03CD( 'Upper', DIM1, DIM2, PREC, DWORK( IC ),
     $                      SDIM, DWORK( IA ),  SDIM,  DWORK( IB ),
     $                      SDIM, DWORK( IQ1 ), SDIM, DWORK( IQ2 ),
     $                      SDIM, DWORK( IQ3 ), SDIM, DWORK( IWRK1 ),
     $                      LDWORK-IWRK1+1, INFO )
               IF( INFO.GT.0 ) THEN
                  INFO = 2
                  RETURN
               END IF
C
C              Copy the transformed diagonal block of B, if sdim > 2.
C
               IF( SDIM.GT.2 ) THEN
                  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 )
               END IF
C
               NROWS = IB1 - 1
               NCOLS = M - IB3 + 1
               NROW  = IB3 - 1
               NCOL  = M - IB1 + 1
               CALL DLACPY( 'Lower', SDIM-1, SDIM-1, A( IB1+1, IB1 ),
     $                      LDA, DUM, 3 )
               CALL DLASET( 'Lower', SDIM-1, SDIM-1, ZERO, ZERO,
     $                      A( IB1+1, IB1 ), LDA )
               CALL DLACPY( 'Upper', SDIM-1, SDIM-1, C( IB1, IB1+1 ),
     $                      LDC, DUM( 1, 2 ), 3 )
               CALL DLASET( 'Upper', SDIM-1, SDIM-1, ZERO, ZERO,
     $                      C( IB1, IB1+1 ), LDC )
C
C              Update A.
C              Workspace: IWRK2 + 2*N - 1.
C
               CALL DGEMM(  'No Transpose', 'No Transpose', NROW, SDIM,
     $                      SDIM, ONE, A( 1, IB1 ), LDA, DWORK( IQ1 ),
     $                      SDIM, ZERO, DWORK( IWRK2 ), NROW )
               CALL DLACPY( 'Full', NROW, SDIM, DWORK( IWRK2 ), NROW,
     $                      A( 1, IB1 ), LDA )
               CALL DGEMM(  'Transpose', 'No Transpose', SDIM, NCOL,
     $                      SDIM, ONE, DWORK( IQ2 ), SDIM,
     $                      A( IB1, IB1 ), LDA, ZERO, DWORK( IWRK2 ),
     $                      SDIM )
               CALL DLACPY( 'Full', SDIM, NCOL, DWORK( IWRK2 ), SDIM,
     $                      A( IB1, IB1 ), LDA )
               CALL DLACPY( 'Lower', SDIM-1, SDIM-1, DUM, 3,
     $                      A( IB1+1, IB1 ), LDA )
C
C              Update C.
C
               CALL DGEMM(  'No Transpose', 'No Transpose', NCOL, SDIM,
     $                      SDIM, ONE, C( IB1, IB1 ), LDC, DWORK( IQ3 ),
     $                      SDIM, ZERO, DWORK( IWRK2 ), NCOL )
               CALL DLACPY( 'Full', NCOL, SDIM, DWORK( IWRK2 ), NCOL,
     $                      C( IB1, IB1 ), LDC )
               CALL DGEMM(  'Transpose', 'No Transpose', SDIM, NROW,
     $                      SDIM, ONE, DWORK( IQ2 ), SDIM, C( IB1, 1 ),
     $                      LDC, ZERO, DWORK( IWRK2 ), SDIM )
               CALL DLACPY( 'Full', SDIM, NROW, DWORK( IWRK2 ), SDIM,
     $                      C( IB1, 1 ), LDC )
               CALL DLACPY( 'Upper', SDIM-1, SDIM-1, DUM( 1, 2 ), 3,
     $                      C( IB1, IB1+1 ), LDC )
C
C              Update D.
C
               CALL DGEMM(  'No Transpose', 'No Transpose', M, SDIM,
     $                      SDIM, ONE, D( 1, IB1 ), LDD, DWORK( IQ3 ),
     $                      SDIM, ZERO, DWORK( IWRK2 ), M )
               CALL DLACPY( 'Full', M, SDIM, DWORK( IWRK2 ), M,
     $                      D( 1, IB1 ), LDD )
               CALL DGEMM(  'Transpose', 'No Transpose', SDIM, M, SDIM,
     $                      ONE, DWORK( IQ2 ), SDIM, D( IB1, 1 ), LDD,
     $                      ZERO, DWORK( IWRK2 ), SDIM )
               CALL DLACPY( 'Full', SDIM, M, DWORK( IWRK2 ), SDIM,
     $                      D( IB1, 1 ), LDD )
C
C              Update B.
C
               IF( SDIM.GT.2 ) THEN
                  NROW = NROWS
                  NCOL = NCOLS
                  IBS  = IB3
                  LDW  = MAX( 1, NROW )
               ELSE
                  IBS  = IB1
                  LDW  = NROW
               END IF
               CALL DGEMM(  'No Transpose', 'No Transpose', NROW, SDIM,
     $                      SDIM, ONE, B( 1, IB1 ), LDB, DWORK( IQ1 ),
     $                      SDIM, ZERO, DWORK( IWRK2 ), LDW )
               CALL DLACPY( 'Full', NROW, SDIM, DWORK( IWRK2 ), LDW,
     $                      B( 1, IB1 ), LDB )
               CALL DGEMM(  'Transpose', 'No Transpose', SDIM, NCOL,
     $                      SDIM, ONE, DWORK( IQ3 ), SDIM,
     $                      B( IB1, IBS ), LDB, ZERO, DWORK( IWRK2 ),
     $                      SDIM )
               CALL DLACPY( 'Full', SDIM, NCOL, DWORK( IWRK2 ), SDIM,
     $                      B( IB1, IBS ), LDB )
C
C              Update F.
C
               CALL DGEMM(  'No Transpose', 'No Transpose', NROWS, SDIM,
     $                      SDIM, ONE, F( 1, IB1 ), LDF, DWORK( IQ3 ),
     $                      SDIM, ZERO, DWORK( IWRK2 ), LDW )
               CALL DLACPY( 'Full', NROWS, SDIM, DWORK( IWRK2 ), LDW,
     $                      F( 1, IB1 ), LDF )
               CALL DGEMM(  'Transpose', 'No Transpose', SDIM, NCOLS,
     $                      SDIM, ONE, DWORK( IQ3 ), SDIM,
     $                      F( IB1, IB3 ), LDF, ZERO, DWORK( IWRK2 ),
     $                      SDIM )
               CALL DLACPY( 'Full', SDIM, NCOLS, DWORK( IWRK2 ), SDIM,
     $                      F( IB1, IB3 ), LDF )
               CALL MB01RU( 'Upper', 'Transpose', SDIM, SDIM, ZERO, ONE,
     $                      F( IB1, IB1 ), LDF, DWORK( IQ3 ), 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( IQ3 ), SDIM, ZERO, DWORK( IWRK2 ),
     $                         UPDS )
                  CALL DLACPY( 'Full', UPDS, SDIM, DWORK( IWRK2 ), UPDS,
     $                         Q( IUPD, M+IB1 ), LDQ )
               END IF
C
               IF( LCMPU ) THEN
C
C                 Update U1.
C
                  CALL DGEMM(  'No Transpose', 'No Transpose', M, SDIM,
     $                         SDIM, ONE, U1( 1, IB1 ), LDU1,
     $                         DWORK( IQ2 ), SDIM, ZERO, DWORK( IWRK2 ),
     $                         M )
                  CALL DLACPY( 'Full', M, SDIM, DWORK( IWRK2 ), M,
     $                         U1( 1, IB1 ), LDU1 )
               END IF
C
               IF( LUPDU ) THEN
C
C                 Update U2.
C
                  CALL DGEMM(  'No Transpose', 'No Transpose', M, SDIM,
     $                         SDIM, ONE, U2( 1, IB1 ), LDU2,
     $                         DWORK( IQ2 ), SDIM, ZERO, DWORK( IWRK2 ),
     $                         M )
                  CALL DLACPY( 'Full', M, SDIM, DWORK( IWRK2 ), M,
     $                         U2( 1, IB1 ), LDU2 )
               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
            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
   40 CONTINUE
      IF( K.GE.MM+1 ) THEN
         IF( IWORK( IS+K ).GT.0 ) THEN
            DO 50 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),
C              C(ib1:ib3-1,ib1:ib3-1), and B(ib1:ib3-1,ib1:ib3-1) to
C              DWORK as inputs for MB03CD. Also, set the additional
C              zero elements.
C
               CALL DLACPY( 'Upper', SDIM, SDIM, A( IB1, IB1 ), LDA,
     $                      DWORK( IA ), SDIM )
               CALL MA02AD( 'Lower', SDIM, SDIM, C( IB1, IB1 ), LDC,
     $                      DWORK( IC ), 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 )
               IF( DIM1.EQ.2 ) THEN
                  DWORK( IA+1 ) = ZERO
                  DWORK( IC+1 ) = ZERO
               END IF
               IF( DIM2.EQ.2 ) THEN
                  I1 = SDIM*( SDIM - 1 ) - 1
                  DWORK( IA+I1 ) = ZERO
                  DWORK( IC+I1 ) = ZERO
               END IF
               DWORK( IB+SDIM-1 ) = ZERO
               IF( SDIM.EQ.4 ) THEN
                  DWORK( IB+2 ) = ZERO
                  DWORK( IB+7 ) = ZERO
               END IF
C
C              Perform eigenvalue/matrix block exchange.
C
               CALL MB03CD( 'Upper', DIM1, DIM2, PREC, DWORK( IC ),
     $                      SDIM, DWORK( IA ),  SDIM,  DWORK( IB ),
     $                      SDIM, DWORK( IQ1 ), SDIM, DWORK( IQ2 ),
     $                      SDIM, DWORK( IQ3 ), SDIM, DWORK( IWRK1 ),
     $                      LDWORK-IWRK1+1, INFO )
               IF( INFO.GT.0 ) THEN
                  INFO = 2
                  RETURN
               END IF
C
C              Copy the transformed diagonal block of B, if sdim > 2.
C
               IF( SDIM.GT.2 ) THEN
                  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 )
               END IF
C
               NROWS = IB1 - 1
               NCOLS = M - IB3 + 1
               NROW  = IB3 - 1
               NCOL  = M - IB1 + 1
               CALL DLACPY( 'Lower', SDIM-1, SDIM-1, A( IB1+1, IB1 ),
     $                      LDA, DUM, 3 )
               CALL DLASET( 'Lower', SDIM-1, SDIM-1, ZERO, ZERO,
     $                      A( IB1+1, IB1 ), LDA )
               CALL DLACPY( 'Upper', SDIM-1, SDIM-1, C( IB1, IB1+1 ),
     $                      LDC, DUM( 1, 2 ), 3 )
               CALL DLASET( 'Upper', SDIM-1, SDIM-1, ZERO, ZERO,
     $                      C( IB1, IB1+1 ), LDC )
C
C              Update A.
C
               CALL DGEMM(  'No Transpose', 'No Transpose', NROW, SDIM,
     $                      SDIM, ONE, A( 1, IB1 ), LDA, DWORK( IQ1 ),
     $                      SDIM, ZERO, DWORK( IWRK2 ), NROW )
               CALL DLACPY( 'Full', NROW, SDIM, DWORK( IWRK2 ), NROW,
     $                      A( 1, IB1 ), LDA )
               CALL DGEMM(  'Transpose', 'No Transpose', SDIM, NCOL,
     $                      SDIM, ONE, DWORK( IQ2 ), SDIM,
     $                      A( IB1, IB1 ), LDA, ZERO, DWORK( IWRK2 ),
     $                      SDIM )
               CALL DLACPY( 'Full', SDIM, NCOL, DWORK( IWRK2 ), SDIM,
     $                      A( IB1, IB1 ), LDA )
               CALL DLACPY( 'Lower', SDIM-1, SDIM-1, DUM, 3,
     $                      A( IB1+1, IB1 ), LDA )
C
C              Update C.
C
               CALL DGEMM(  'No Transpose', 'No Transpose', NCOL, SDIM,
     $                      SDIM, ONE, C( IB1, IB1 ), LDC, DWORK( IQ3 ),
     $                      SDIM, ZERO, DWORK( IWRK2 ), NCOL )
               CALL DLACPY( 'Full', NCOL, SDIM, DWORK( IWRK2 ), NCOL,
     $                      C( IB1, IB1 ), LDC )
               CALL DGEMM(  'Transpose', 'No Transpose', SDIM, NROW,
     $                      SDIM, ONE, DWORK( IQ2 ), SDIM, C( IB1, 1 ),
     $                      LDC, ZERO, DWORK( IWRK2 ), SDIM )
               CALL DLACPY( 'Full', SDIM, NROW, DWORK( IWRK2 ), SDIM,
     $                      C( IB1, 1 ), LDC )
               CALL DLACPY( 'Upper', SDIM-1, SDIM-1, DUM( 1, 2 ), 3,
     $                      C( IB1, IB1+1 ), LDC )
C
C              Update D.
C
               CALL DGEMM(  'No Transpose', 'No Transpose', M, SDIM,
     $                      SDIM, ONE, D( 1, IB1 ), LDD, DWORK( IQ3 ),
     $                      SDIM, ZERO, DWORK( IWRK2 ), M )
               CALL DLACPY( 'Full', M, SDIM, DWORK( IWRK2 ), M,
     $                      D( 1, IB1 ), LDD )
               CALL DGEMM(  'Transpose', 'No Transpose', SDIM, M, SDIM,
     $                      ONE, DWORK( IQ2 ), SDIM, D( IB1, 1 ), LDD,
     $                      ZERO, DWORK( IWRK2 ), SDIM )
               CALL DLACPY( 'Full', SDIM, M, DWORK( IWRK2 ), SDIM,
     $                      D( IB1, 1 ), LDD )
C
C              Update B.
C
               IF( SDIM.GT.2 ) THEN
                  NROW = NROWS
                  NCOL = NCOLS
                  IBS  = IB3
                  LDW  = MAX( 1, NROW )
               ELSE
                  IBS  = IB1
                  LDW  = NROW
               END IF
               CALL DGEMM(  'No Transpose', 'No Transpose', NROW, SDIM,
     $                      SDIM, ONE, B( 1, IB1 ), LDB, DWORK( IQ1 ),
     $                      SDIM, ZERO, DWORK( IWRK2 ), LDW )
               CALL DLACPY( 'Full', NROW, SDIM, DWORK( IWRK2 ), LDW,
     $                      B( 1, IB1 ), LDB )
               CALL DGEMM(  'Transpose', 'No Transpose', SDIM, NCOL,
     $                      SDIM, ONE, DWORK( IQ3 ), SDIM,
     $                      B( IB1, IBS ), LDB, ZERO, DWORK( IWRK2 ),
     $                      SDIM )
               CALL DLACPY( 'Full', SDIM, NCOL, DWORK( IWRK2 ), SDIM,
     $                      B( IB1, IBS ), LDB )
C
C              Update F.
C
               CALL DGEMM(  'No Transpose', 'No Transpose', NROWS, SDIM,
     $                      SDIM, ONE, F( 1, IB1 ), LDF, DWORK( IQ3 ),
     $                      SDIM, ZERO, DWORK( IWRK2 ), LDW )
               CALL DLACPY( 'Full', NROWS, SDIM, DWORK( IWRK2 ), LDW,
     $                      F( 1, IB1 ), LDF )
               CALL DGEMM(  'Transpose', 'No Transpose', SDIM, NCOLS,
     $                      SDIM, ONE, DWORK( IQ3 ), SDIM,
     $                      F( IB1, IB3 ), LDF, ZERO, DWORK( IWRK2 ),
     $                      SDIM )
               CALL DLACPY( 'Full', SDIM, NCOLS, DWORK( IWRK2 ), SDIM,
     $                      F( IB1, IB3 ), LDF )
               CALL MB01RU( 'Upper', 'Transpose', SDIM, SDIM, ZERO, ONE,
     $                      F( IB1, IB1 ), LDF, DWORK( IQ3 ), 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( IQ3 ), SDIM, ZERO, DWORK( IWRK2 ),
     $                         UPDS )
                  CALL DLACPY( 'Full', UPDS, SDIM, DWORK( IWRK2 ), UPDS,
     $                         Q( IUPD, M+IB1 ), LDQ )
               END IF
C
               IF( LCMPU ) THEN
C
C                 Update U1.
C
                  CALL DGEMM(  'No Transpose', 'No Transpose', M, SDIM,
     $                         SDIM, ONE, U1( 1, IB1 ), LDU1,
     $                         DWORK( IQ2 ), SDIM, ZERO, DWORK( IWRK2 ),
     $                         M )
                  CALL DLACPY( 'Full', M, SDIM, DWORK( IWRK2 ), M,
     $                         U1( 1, IB1 ), LDU1 )
               END IF
C
               IF( LUPDU ) THEN
C
C                 Update U2.
C
                  CALL DGEMM(  'No Transpose', 'No Transpose', M, SDIM,
     $                         SDIM, ONE, U2( 1, IB1 ), LDU2,
     $                         DWORK( IQ2 ), SDIM, ZERO, DWORK( IWRK2 ),
     $                         M )
                  CALL DLACPY( 'Full', M, SDIM, DWORK( IWRK2 ), M,
     $                         U2( 1, IB1 ), LDU2 )
               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
   50       CONTINUE
            MP = MP - 1
         END IF
         K = K - 1
      GO TO 40
C
C     END WHILE 40
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 MB03GD.
C
      IQUPLE = 1
      IUUPLE = IQUPLE + 16
      IZUPLE = IUUPLE + 16
      IHUPLE = IZUPLE + 16
      IWRK5  = IHUPLE + 16
      IWRK3  = IZUPLE
      IWRK4  = IWRK3  + 2*N
      ITMP1  = IWRK3  + N
      ITMP2  = ITMP1  + 4
      ITMP3  = ITMP2  + 4
C
      DO 70 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( IR, M ) = ZERO
C
C           Build the (small) symmetric matrix F(M-1:M,M-1:M).
C
            F( M, IR ) =  F( IR, M )
         END IF
C
C        Calculate position of submatrices in DWORK.
C
         IZUPRI = IZUPLE + DIM1*SDIM
         IZLORI = IZUPRI + DIM1
         IUUPRI = IUUPLE + DIM1*SDIM
         IQLOLE = IQUPLE + DIM1
         IQUPRI = IQUPLE + DIM1*SDIM
         IQLORI = IQUPRI + DIM1
C
C        Generate input matrices for MB03GD built of submatrices of A,
C        D, C, B, and F.
C
         CALL DLACPY( 'Upper', DIM1, DIM1, A( IR, IR ), LDA,
     $                DWORK( IZUPLE ), SDIM )
         CALL DLACPY( 'Full',  DIM1, DIM1, D( IR, IR ), LDD,
     $                DWORK( IZUPRI ), SDIM )
         CALL DLACPY( 'Lower', DIM1, DIM1, C( IR, IR ), LDC,
     $                DWORK( IZLORI ), SDIM )
         CALL DLACPY( 'Full', DIM1, DIM1, B( IR, IR ), LDB,
     $                DWORK( IHUPLE ), SDIM )
         CALL DLACPY( 'Upper', DIM1, DIM1, F( IR, IR ), LDB,
     $                DWORK( IHUPLE+DIM1*SDIM ), SDIM )
         IF( DIM1.EQ.2 ) THEN
            DWORK( IZUPLE+1    ) = ZERO
            DWORK( IZLORI+SDIM ) = ZERO
         END IF
C
C        Perform eigenvalue exchange.
C        Workspace: IWRK5 + 11, if SDIM = 4.
C
         CALL MB03GD( SDIM, DWORK( IZUPLE ), SDIM, DWORK( IHUPLE ),
     $                SDIM, PAR, DWORK( IQUPLE ), SDIM, DWORK( IUUPLE ),
     $                SDIM, DWORK( IWRK5 ), LDWORK-IWRK5+1, INFO )
         IF( INFO.GT.0 ) THEN
            INFO = 3
            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 intermediate product Cf*Q21, with
C           Cf = C(M-1:M,M-1:M).
C
            CALL DGEMM( 'No Transpose', 'No Transpose', DIM1, DIM1,
     $                  DIM1, ONE, C( IR, IR ), LDC, DWORK( IQLOLE ),
     $                  SDIM, ZERO, DWORK( ITMP1 ), DIM1 )
C
C           Update C by transformations from the right.
C
            CALL DGEMM(  'No Transpose', 'No Transpose', DIM1, DIM1,
     $                   DIM1, ONE, C( IR, IR ), LDC, DWORK( IQLORI ),
     $                   SDIM, ZERO, DWORK( IWRK3 ), DIM1 )
            CALL DLACPY( 'Full', DIM1, DIM1, DWORK( IWRK3 ), DIM1,
     $                   C( IR, IR ), LDC )
C
C           Update A by transformations from the left.
C
            CALL DGEMM(  'Transpose', 'No Transpose', DIM1, DIM1, DIM1,
     $                   ONE, DWORK( IUUPLE ), SDIM, A( IR, IR ), LDA,
     $                   ZERO, DWORK( IWRK3 ), DIM1 )
            CALL DGEMM(  'Transpose', 'No Transpose', DIM1, DIM1, DIM1,
     $                   -ONE, DWORK( IUUPRI ), SDIM, DWORK( ITMP1 ),
     $                   DIM1, ONE, DWORK( IWRK3 ), DIM1 )
            CALL DLACPY( 'Full', DIM1, DIM1, DWORK( IWRK3 ), DIM1,
     $                   A( IR, IR ), LDA )
C
C           Update D by transformations from the left.
C
            CALL DLACPY( 'Full', DIM1, M, D( IR, 1 ), LDD,
     $                   DWORK( IWRK3 ), DIM1 )
            CALL DGEMM(  'Transpose', 'No Transpose', DIM1, M, DIM1,
     $                   ONE, DWORK( IUUPLE ), SDIM, DWORK( IWRK3 ),
     $                   DIM1, ZERO, D( IR, 1 ), LDD )
            CALL DGEMM(  'Transpose', 'No Transpose', DIM1, M, DIM1,
     $                   -ONE, DWORK( IUUPRI ), SDIM, C( IR, 1 ), LDC,
     $                   ONE, D( IR, 1 ), LDD )
C
C           Update C by transformations from the left.
C
            CALL DGEMM(  'Transpose', 'No Transpose', DIM1, M, DIM1,
     $                   ONE, DWORK( IUUPRI ), SDIM, DWORK( IWRK3 ),
     $                   DIM1, ZERO, DWORK( ITMP1 ), DIM1 )
            CALL DGEMM(  'Transpose', 'No Transpose', DIM1, M, DIM1,
     $                   ONE, DWORK( IUUPLE ), SDIM, C( IR, 1 ), LDC,
     $                   ONE, DWORK( ITMP1 ), DIM1 )
            CALL DLACPY( 'Full', DIM1, M, DWORK( ITMP1 ), DIM1,
     $                   C( IR, 1 ), LDC )
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
C
            IF( LCMPU ) THEN
C
C              Update U.
C              Workspace: ITMP1 + N - 1.
C
               CALL DLACPY( 'Full', M, DIM1, U1( 1, IR ), LDU1,
     $                      DWORK( ITMP1 ), M )
               CALL DGEMM(  'No Transpose', 'No Transpose', M, DIM1,
     $                      DIM1, ONE, DWORK( ITMP1 ), M,
     $                      DWORK( IUUPLE ), SDIM, ZERO, U1( 1, IR ),
     $                      LDU1 )
               CALL DGEMM(  'No Transpose', 'No Transpose', M, DIM1,
     $                      DIM1, -ONE, U2( 1, IR ), LDU2,
     $                      DWORK( IUUPRI ), SDIM, ONE,  U1( 1, IR ),
     $                      LDU1 )
               CALL DGEMM(  'No Transpose', 'No Transpose', M, DIM1,
     $                      DIM1, ONE, DWORK( ITMP1 ), M,
     $                      DWORK( IUUPRI ), SDIM, ZERO, DWORK( IWRK3 ),
     $                      M )
               CALL DGEMM(  'No Transpose', 'No Transpose', M, DIM1,
     $                      DIM1, ONE, U2( 1, IR ), LDU2,
     $                      DWORK( IUUPLE ), SDIM, ONE, DWORK( IWRK3 ),
     $                      M )
               CALL DLACPY( 'Full', M, DIM1, DWORK( IWRK3 ), M,
     $                      U2( 1, IR ), LDU2 )
            END IF
C
         ELSE
            U11 = DWORK( IUUPLE )
            U12 = DWORK( IUUPRI )
            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, A( 1, IR ), 1, DWORK( IWRK3 ), 1 )
            CALL DSCAL( M, Q11, A( 1, IR ), 1 )
            CALL DAXPY( M, Q21, D( 1, IR ), 1, A( 1, IR ), 1 )
C
C           Update D by transformations from the right.
C
            CALL DSCAL( M, Q22, D( 1, IR ), 1 )
            CALL DAXPY( M, Q12, DWORK( IWRK3 ), 1, D( 1, IR ), 1 )
C
C           Compute intermediate product C(M,M)*Q21.
C
            TMPC = C( IR, IR )*Q21
C
C           Update C by transformations from the right.
C
            C( IR, IR ) = C( IR, IR )*Q22
C
C           Update A by transformations from the left.
C
            A( IR, IR ) = U11*A( IR, IR ) - U12*TMPC
C
C           Update D by transformations from the left.
C
            CALL DCOPY( M, D( IR, 1 ), LDD, DWORK( IWRK3 ), 1 )
            CALL DSCAL( M,  U11, D( IR, 1 ), LDD )
            CALL DAXPY( M, -U12, C( IR, 1 ), LDC, D( IR, 1 ), LDD )
C
C           Update C by transformations from the left.
C
            CALL DSCAL( M, U11, C( IR, 1 ), LDC )
            CALL DAXPY( M, U12, DWORK( IWRK3 ), 1, C( IR, 1 ), LDC )
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
            IF( LCMPU ) THEN
C
C              Update U.
C
               CALL DCOPY( M, U1( 1, IR ), 1, DWORK( IWRK4 ), 1 )
               CALL DSCAL( M,  U11, U1( 1, IR ), 1 )
               CALL DAXPY( M, -U12, U2( 1, IR ), 1, U1( 1, IR ), 1 )
               CALL DSCAL( M,  U11, U2( 1, IR ), 1 )
               CALL DAXPY( M,  U12, DWORK( IWRK4 ), 1, U2( 1, IR ), 1 )
            END IF
         END IF
C
         MM = MM + 1
         DO 60 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),
C           C(ib1:ib3-1,ib1:ib3-1), and B(ib1:ib3-1,ib1:ib3-1) to
C           DWORK as inputs for MB03CD. Also, set the additional
C           zero elements.
C
            CALL DLACPY( 'Upper', SDIM, SDIM, A( IB1, IB1 ), LDA,
     $                   DWORK( IA ), SDIM )
            CALL MA02AD( 'Lower', SDIM, SDIM, C( IB1, IB1 ), LDC,
     $                   DWORK( IC ), 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 )
            IF( DIM1.EQ.2 ) THEN
               DWORK( IA+1 ) = ZERO
               DWORK( IC+1 ) = ZERO
            END IF
            IF( DIM2.EQ.2 ) THEN
               I1 = SDIM*( SDIM - 1 ) - 1
               DWORK( IA+I1 ) = ZERO
               DWORK( IC+I1 ) = ZERO
            END IF
            DWORK( IB+SDIM-1 ) = ZERO
            IF( SDIM.EQ.4 ) THEN
               DWORK( IB+2 ) = ZERO
               DWORK( IB+7 ) = ZERO
            END IF
C
C           Perform eigenvalue/matrix block exchange.
C
            CALL MB03CD( 'Upper', DIM1, DIM2, PREC, DWORK( IC ), SDIM,
     $                   DWORK( IA ),  SDIM,  DWORK( IB ), SDIM,
     $                   DWORK( IQ1 ), SDIM, DWORK( IQ2 ), SDIM,
     $                   DWORK( IQ3 ), SDIM, DWORK( IWRK1 ),
     $                   LDWORK-IWRK1+1, INFO )
            IF( INFO.GT.0 ) THEN
               INFO = 2
               RETURN
            END IF
C
C           Copy the transformed diagonal block of B, if sdim > 2.
C
            IF( SDIM.GT.2 ) THEN
               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 )
            END IF
C
            NROWS = IB1 - 1
            NCOLS = M - IB3 + 1
            NROW  = IB3 - 1
            NCOL  = M - IB1 + 1
            CALL DLACPY( 'Lower', SDIM-1, SDIM-1, A( IB1+1, IB1 ), LDA,
     $                   DUM, 3 )
            CALL DLASET( 'Lower', SDIM-1, SDIM-1, ZERO, ZERO,
     $                   A( IB1+1, IB1 ), LDA )
            CALL DLACPY( 'Upper', SDIM-1, SDIM-1, C( IB1, IB1+1 ), LDC,
     $                   DUM( 1, 2 ), 3 )
            CALL DLASET( 'Upper', SDIM-1, SDIM-1, ZERO, ZERO,
     $                   C( IB1, IB1+1 ), LDC )
C
C           Update A.
C
            CALL DGEMM(  'No Transpose', 'No Transpose', NROW, SDIM,
     $                   SDIM, ONE, A( 1, IB1 ), LDA, DWORK( IQ1 ),
     $                   SDIM, ZERO, DWORK( IWRK2 ), NROW )
            CALL DLACPY( 'Full', NROW, SDIM, DWORK( IWRK2 ), NROW,
     $                   A( 1, IB1 ), LDA )
            CALL DGEMM(  'Transpose', 'No Transpose', SDIM, NCOL, SDIM,
     $                   ONE, DWORK( IQ2 ), SDIM, A( IB1, IB1 ), LDA,
     $                   ZERO, DWORK( IWRK2 ), SDIM )
            CALL DLACPY( 'Full', SDIM, NCOL, DWORK( IWRK2 ), SDIM,
     $                   A( IB1, IB1 ), LDA )
            CALL DLACPY( 'Lower', SDIM-1, SDIM-1, DUM, 3,
     $                   A( IB1+1, IB1 ), LDA )
C
C           Update C.
C
            CALL DGEMM(  'No Transpose', 'No Transpose', NCOL, SDIM,
     $                   SDIM, ONE, C( IB1, IB1 ), LDC, DWORK( IQ3 ),
     $                   SDIM, ZERO, DWORK( IWRK2 ), NCOL )
            CALL DLACPY( 'Full', NCOL, SDIM, DWORK( IWRK2 ), NCOL,
     $                   C( IB1, IB1 ), LDC )
            CALL DGEMM(  'Transpose', 'No Transpose', SDIM, NROW, SDIM,
     $                   ONE, DWORK( IQ2 ), SDIM, C( IB1, 1 ), LDC,
     $                   ZERO, DWORK( IWRK2 ), SDIM )
            CALL DLACPY( 'Full', SDIM, NROW, DWORK( IWRK2 ), SDIM,
     $                   C( IB1, 1 ), LDC )
            CALL DLACPY( 'Upper', SDIM-1, SDIM-1, DUM( 1, 2 ), 3,
     $                   C( IB1, IB1+1 ), LDC )
C
C           Update D.
C
            CALL DGEMM(  'No Transpose', 'No Transpose', M, SDIM, SDIM,
     $                   ONE, D( 1, IB1 ), LDD, DWORK( IQ3 ), SDIM,
     $                   ZERO, DWORK( IWRK2 ), M )
            CALL DLACPY( 'Full', M, SDIM, DWORK( IWRK2 ), M,
     $                   D( 1, IB1 ), LDD )
            CALL DGEMM(  'Transpose', 'No Transpose', SDIM, M, SDIM,
     $                   ONE, DWORK( IQ2 ), SDIM, D( IB1, 1 ), LDD,
     $                   ZERO, DWORK( IWRK2 ), SDIM )
            CALL DLACPY( 'Full', SDIM, M, DWORK( IWRK2 ), SDIM,
     $                   D( IB1, 1 ), LDD )
C
C           Update B.
C
            IF( SDIM.GT.2 ) THEN
               NROW = NROWS
               NCOL = NCOLS
               IBS  = IB3
               LDW  = MAX( 1, NROW )
            ELSE
               IBS  = IB1
               LDW  = NROW
            END IF
            CALL DGEMM(  'No Transpose', 'No Transpose', NROW, SDIM,
     $                   SDIM, ONE, B( 1, IB1 ), LDB, DWORK( IQ1 ),
     $                   SDIM, ZERO, DWORK( IWRK2 ), LDW )
            CALL DLACPY( 'Full', NROW, SDIM, DWORK( IWRK2 ), LDW,
     $                   B( 1, IB1 ), LDB )
            CALL DGEMM(  'Transpose', 'No Transpose', SDIM, NCOL, SDIM,
     $                   ONE, DWORK( IQ3 ), SDIM, B( IB1, IBS ), LDB,
     $                   ZERO, DWORK( IWRK2 ), SDIM )
            CALL DLACPY( 'Full', SDIM, NCOL, DWORK( IWRK2 ), SDIM,
     $                   B( IB1, IBS ), LDB )
C
C           Update F.
C
            CALL DGEMM(  'No Transpose', 'No Transpose', NROWS, SDIM,
     $                   SDIM, ONE, F( 1, IB1 ), LDF, DWORK( IQ3 ),
     $                   SDIM, ZERO, DWORK( IWRK2 ), LDW )
            CALL DLACPY( 'Full', NROWS, SDIM, DWORK( IWRK2 ), LDW,
     $                   F( 1, IB1 ), LDF )
            CALL DGEMM(  'Transpose', 'No Transpose', SDIM, NCOLS, SDIM,
     $                   ONE, DWORK( IQ3 ), SDIM, F( IB1, IB3 ), LDF,
     $                   ZERO, DWORK( IWRK2 ), SDIM )
            CALL DLACPY( 'Full', SDIM, NCOLS, DWORK( IWRK2 ), SDIM,
     $                   F( IB1, IB3 ), LDF )
            CALL MB01RU( 'Upper', 'Transpose', SDIM, SDIM, ZERO, ONE,
     $                   F( IB1, IB1 ), LDF, DWORK( IQ3 ), 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', 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( IQ3 ),
     $                      SDIM, ZERO, DWORK( IWRK2 ), N )
               CALL DLACPY( 'Full', N, SDIM, DWORK( IWRK2 ), N,
     $                      Q( 1, M+IB1 ), LDQ )
            END IF
C
            IF( LCMPU ) THEN
C
C              Update U.
C
               CALL DGEMM(  'No Transpose', 'No Transpose', M, SDIM,
     $                      SDIM, ONE, U1( 1, IB1 ), LDU1, DWORK( IQ2 ),
     $                      SDIM, ZERO, DWORK( IWRK2 ), M )
               CALL DLACPY( 'Full', M, SDIM, DWORK( IWRK2 ), M,
     $                      U1( 1, IB1 ), LDU1 )
               CALL DGEMM(  'No Transpose', 'No Transpose', M, SDIM,
     $                      SDIM, ONE, U2( 1, IB1 ), LDU2, DWORK( IQ2 ),
     $                      SDIM, ZERO, DWORK( IWRK2 ), M )
               CALL DLACPY( 'Full', M, SDIM, DWORK( IWRK2 ), M,
     $                      U2( 1, IB1 ), LDU2 )
            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
            ELSE IF( HLP.EQ.-1 ) THEN
C
C              Second block was 2-by-2.
C
               IWORK( J+1 ) = IB1 + 2
            END IF
   60    CONTINUE
   70 CONTINUE
C
      IF( M.GT.1 ) THEN
C
C        Restore the elements A(M,M-1), C(M-1,M), and F(M,M-1).
C
         A( M, M-1 ) = A2
         C( M-1, M ) = C2
         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 MB03ID ***
      END


*DECK XLEGF
      SUBROUTINE XLEGF (DNU1, NUDIFF, MU1, MU2, THETA, ID, PQA, IPQA,
     1   IERROR)
C***BEGIN PROLOGUE  XLEGF
C***PURPOSE  Compute normalized Legendre polynomials and associated
C            Legendre functions.
C***LIBRARY   SLATEC
C***CATEGORY  C3A2, C9
C***TYPE      SINGLE PRECISION (XLEGF-S, DXLEGF-D)
C***KEYWORDS  LEGENDRE FUNCTIONS
C***AUTHOR  Smith, John M., (NBS and George Mason University)
C***DESCRIPTION
C
C   XLEGF: Extended-range Single-precision Legendre Functions
C
C   A feature of the XLEGF subroutine for Legendre functions is
C the use of extended-range arithmetic, a software extension of
C ordinary floating-point arithmetic that greatly increases the
C exponent range of the representable numbers. This avoids the
C need for scaling the solutions to lie within the exponent range
C of the most restrictive manufacturer's hardware. The increased
C exponent range is achieved by allocating an integer storage
C location together with each floating-point storage location.
C
C   The interpretation of the pair (X,I) where X is floating-point
C and I is integer is X*(IR**I) where IR is the internal radix of
C the computer arithmetic.
C
C   This subroutine computes one of the following vectors:
C
C 1. Legendre function of the first kind of negative order, either
C    a. P(-MU1,NU,X), P(-MU1-1,NU,X), ..., P(-MU2,NU,X) or
C    b. P(-MU,NU1,X), P(-MU,NU1+1,X), ..., P(-MU,NU2,X)
C 2. Legendre function of the second kind, either
C    a. Q(MU1,NU,X), Q(MU1+1,NU,X), ..., Q(MU2,NU,X) or
C    b. Q(MU,NU1,X), Q(MU,NU1+1,X), ..., Q(MU,NU2,X)
C 3. Legendre function of the first kind of positive order, either
C    a. P(MU1,NU,X), P(MU1+1,NU,X), ..., P(MU2,NU,X) or
C    b. P(MU,NU1,X), P(MU,NU1+1,X), ..., P(MU,NU2,X)
C 4. Normalized Legendre polynomials, either
C    a. PN(MU1,NU,X), PN(MU1+1,NU,X), ..., PN(MU2,NU,X) or
C    b. PN(MU,NU1,X), PN(MU,NU1+1,X), ..., PN(MU,NU2,X)
C
C where X = COS(THETA).
C
C   The input values to XLEGF are DNU1, NUDIFF, MU1, MU2, THETA,
C and ID. These must satisfy
C
C    DNU1 is REAL and greater than or equal to -0.5;
C    NUDIFF is INTEGER and non-negative;
C    MU1 is INTEGER and non-negative;
C    MU2 is INTEGER and greater than or equal to MU1;
C    THETA is REAL and in the half-open interval (0,PI/2];
C    ID is INTEGER and equal to 1, 2, 3 or 4;
C
C and  additionally either NUDIFF = 0 or MU2 = MU1.
C
C   If ID=1 and NUDIFF=0, a vector of type 1a above is computed
C with NU=DNU1.
C
C   If ID=1 and MU1=MU2, a vector of type 1b above is computed
C with NU1=DNU1, NU2=DNU1+NUDIFF and MU=MU1.
C
C   If ID=2 and NUDIFF=0, a vector of type 2a above is computed
C with NU=DNU1.
C
C   If ID=2 and MU1=MU2, a vector of type 2b above is computed
C with NU1=DNU1, NU2=DNU1+NUDIFF and MU=MU1.
C
C   If ID=3 and NUDIFF=0, a vector of type 3a above is computed
C with NU=DNU1.
C
C   If ID=3 and MU1=MU2, a vector of type 3b above is computed
C with NU1=DNU1, NU2=DNU1+NUDIFF and MU=MU1.
C
C   If ID=4 and NUDIFF=0, a vector of type 4a above is computed
C with NU=DNU1.
C
C   If ID=4 and MU1=MU2, a vector of type 4b above is computed
C with NU1=DNU1, NU2=DNU1+NUDIFF and MU=MU1.
C
C   In each case the vector of computed Legendre function values
C is returned in the extended-range vector (PQA(I),IPQA(I)). The
C length of this vector is either MU2-MU1+1 or NUDIFF+1.
C
C   Where possible, XLEGF returns IPQA(I) as zero. In this case the
C value of the Legendre function is contained entirely in PQA(I),
C so it can be used in subsequent computations without further
C consideration of extended-range arithmetic. If IPQA(I) is nonzero,
C then the value of the Legendre function is not representable in
C floating-point because of underflow or overflow. The program that
C calls XLEGF must test IPQA(I) to ensure correct usage.
C
C   IERROR is an error indicator. If no errors are detected, IERROR=0
C when control returns to the calling routine. If an error is detected,
C IERROR is returned as nonzero. The calling routine must check the
C value of IERROR.
C
C   If IERROR=110 or 111, invalid input was provided to XLEGF.
C   If IERROR=101,102,103, or 104, invalid input was provided to XSET.
C   If IERROR=105 or 106, an internal consistency error occurred in
C XSET (probably due to a software malfunction in the library routine
C I1MACH).
C   If IERROR=107, an overflow or underflow of an extended-range number
C was detected in XADJ.
C   If IERROR=108, an overflow or underflow of an extended-range number
C was detected in XC210.
C
C***SEE ALSO  XSET
C***REFERENCES  Olver and Smith, Associated Legendre Functions on the
C                 Cut, J Comp Phys, v 51, n 3, Sept 1983, pp 502--518.
C               Smith, Olver and Lozier, Extended-Range Arithmetic and
C                 Normalized Legendre Polynomials, ACM Trans on Math
C                 Softw, v 7, n 1, March 1981, pp 93--105.
C***ROUTINES CALLED  XERMSG, XPMU, XPMUP, XPNRM, XPQNU, XQMU, XQNU,
C                    XRED, XSET
C***REVISION HISTORY  (YYMMDD)
C   820728  DATE WRITTEN
C   890126  Revised to meet SLATEC CML recommendations.  (DWL and JMS)
C   901019  Revisions to prologue.  (DWL and WRB)
C   901106  Changed all specific intrinsics to generic.  (WRB)
C           Corrected order of sections in prologue and added TYPE
C           section.  (WRB)
C           CALLs to XERROR changed to CALLs to XERMSG.  (WRB)
C   920127  Revised PURPOSE section of prologue.  (DWL)
C***END PROLOGUE  XLEGF
      REAL PQA,DNU1,DNU2,SX,THETA,X,PI2
      DIMENSION PQA(*),IPQA(*)
C
C***FIRST EXECUTABLE STATEMENT  XLEGF
      IERROR=0
      CALL XSET (0, 0, 0.0, 0,IERROR)
      IF (IERROR.NE.0) RETURN
      PI2=2.*ATAN(1.)
C
C        ZERO OUTPUT ARRAYS
C
      L=(MU2-MU1)+NUDIFF+1
      DO 290 I=1,L
      PQA(I)=0.
  290 IPQA(I)=0
C
C        CHECK FOR VALID INPUT VALUES
C
      IF(NUDIFF.LT.0) GO TO 400
      IF(DNU1.LT.-.5) GO TO 400
      IF(MU2.LT.MU1) GO TO 400
      IF(MU1.LT.0) GO TO 400
      IF(THETA.LE.0..OR.THETA.GT.PI2) GO TO 420
      IF(ID.LT.1.OR.ID.GT.4) GO TO 400
      IF((MU1.NE.MU2).AND.(NUDIFF.GT.0)) GO TO 400
C
C        IF DNU1 IS NOT AN INTEGER, NORMALIZED P(MU,DNU,X)
C        CANNOT BE CALCULATED.  IF DNU1 IS AN INTEGER AND
C        MU1.GT.DNU2 THEN ALL VALUES OF P(+MU,DNU,X) AND
C        NORMALIZED P(MU,NU,X) WILL BE ZERO.
C
      DNU2=DNU1+NUDIFF
      IF((ID.EQ.3).AND.(MOD(DNU1,1.).NE.0.)) GO TO 295
      IF((ID.EQ.4).AND.(MOD(DNU1,1.).NE.0.)) GO TO 400
      IF((ID.EQ.3.OR.ID.EQ.4).AND.MU1.GT.DNU2) RETURN
  295 CONTINUE
C
      X=COS(THETA)
      SX=1./SIN(THETA)
      IF(ID.EQ.2) GO TO 300
      IF(MU2-MU1.LE.0) GO TO 360
C
C        FIXED NU, VARIABLE MU
C        CALL XPMU TO CALCULATE P(-MU1,NU,X),....,P(-MU2,NU,X)
C
      CALL XPMU(DNU1,DNU2,MU1,MU2,THETA,X,SX,ID,PQA,IPQA,IERROR)
      IF (IERROR.NE.0) RETURN
      GO TO 380
C
  300 IF(MU2.EQ.MU1) GO TO 320
C
C        FIXED NU, VARIABLE MU
C        CALL XQMU TO CALCULATE Q(MU1,NU,X),....,Q(MU2,NU,X)
C
      CALL XQMU(DNU1,DNU2,MU1,MU2,THETA,X,SX,ID,PQA,IPQA,IERROR)
      IF (IERROR.NE.0) RETURN
      GO TO 390
C
C        FIXED MU, VARIABLE NU
C        CALL XQNU TO CALCULATE Q(MU,DNU1,X),....,Q(MU,DNU2,X)
C
  320 CALL XQNU(DNU1,DNU2,MU1,THETA,X,SX,ID,PQA,IPQA,IERROR)
      IF (IERROR.NE.0) RETURN
      GO TO 390
C
C        FIXED MU, VARIABLE NU
C        CALL XPQNU TO CALCULATE P(-MU,DNU1,X),....,P(-MU,DNU2,X)
C
  360 CALL XPQNU(DNU1,DNU2,MU1,THETA,ID,PQA,IPQA,IERROR)
      IF (IERROR.NE.0) RETURN
C
C        IF ID = 3, TRANSFORM P(-MU,NU,X) VECTOR INTO
C        P(MU,NU,X) VECTOR.
C
  380 IF(ID.EQ.3) CALL XPMUP(DNU1,DNU2,MU1,MU2,PQA,IPQA,IERROR)
      IF (IERROR.NE.0) RETURN
C
C        IF ID = 4, TRANSFORM P(-MU,NU,X) VECTOR INTO
C        NORMALIZED P(MU,NU,X) VECTOR.
C
      IF(ID.EQ.4) CALL XPNRM(DNU1,DNU2,MU1,MU2,PQA,IPQA,IERROR)
      IF (IERROR.NE.0) RETURN
C
C        PLACE RESULTS IN REDUCED FORM IF POSSIBLE
C        AND RETURN TO MAIN PROGRAM.
C
  390 DO 395 I=1,L
      CALL XRED(PQA(I),IPQA(I),IERROR)
      IF (IERROR.NE.0) RETURN
  395 CONTINUE
      RETURN
C
C        *****     ERROR TERMINATION     *****
C
  400 CALL XERMSG ('SLATEC', 'XLEGF',
     +             'DNU1, NUDIFF, MU1, MU2, or ID not valid', 110, 1)
      IERROR=110
      RETURN
  420 CALL XERMSG ('SLATEC', 'XLEGF', 'THETA out of range', 111, 1)
      IERROR=111
      RETURN
      END