C
C SPDX-License-Identifier: BSD-3-Clause
C
      SUBROUTINE TG01ED( JOBA, L, N, M, P, A, LDA, E, LDE, B, LDB,
     $                   C, LDC, Q, LDQ, Z, LDZ, RANKE, RNKA22, TOL,
     $                   DWORK, LDWORK, INFO )
C
C     PURPOSE
C
C     To compute for the descriptor system (A-lambda E,B,C)
C     the orthogonal transformation matrices Q and Z such that the
C     transformed system (Q'*A*Z-lambda Q'*E*Z, Q'*B, C*Z) is in an
C     SVD (singular value decomposition) coordinate form with
C     the system matrices  Q'*A*Z and Q'*E*Z in the form
C
C                  ( A11  A12 )             ( Er  0 )
C         Q'*A*Z = (          ) ,  Q'*E*Z = (       ) ,
C                  ( A21  A22 )             (  0  0 )
C
C     where Er is an invertible diagonal matrix having on the diagonal
C     the decreasingly ordered nonzero singular values of E.
C     Optionally, the A22 matrix can be further reduced to the
C     SVD form
C
C                  ( Ar  0 )
C            A22 = (       ) ,
C                  (  0  0 )
C
C     where Ar is an invertible diagonal matrix having on the diagonal
C     the decreasingly ordered nonzero singular values of A22.
C     The left and/or right orthogonal transformations performed
C     to reduce E and A22 are accumulated.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     JOBA    CHARACTER*1
C             = 'N':  do not reduce A22;
C             = 'R':  reduce A22 to an SVD form.
C
C     Input/Output Parameters
C
C     L       (input) INTEGER
C             The number of rows of matrices A, B, and E.  L >= 0.
C
C     N       (input) INTEGER
C             The number of columns of matrices A, E, and C.  N >= 0.
C
C     M       (input) INTEGER
C             The number of columns of matrix B.  M >= 0.
C
C     P       (input) INTEGER
C             The number of rows of matrix C.  P >= 0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading L-by-N part of this array must
C             contain the state dynamics matrix A.
C             On exit, the leading L-by-N part of this array contains
C             the transformed matrix Q'*A*Z. If JOBA = 'R', this matrix
C             is in the form
C
C                           ( A11  *   *  )
C                  Q'*A*Z = (  *   Ar  0  ) ,
C                           (  *   0   0  )
C
C             where A11 is a RANKE-by-RANKE matrix and Ar is a
C             RNKA22-by-RNKA22 invertible diagonal matrix, with
C             decresingly ordered positive diagonal elements.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,L).
C
C     E       (input/output) DOUBLE PRECISION array, dimension (LDE,N)
C             On entry, the leading L-by-N part of this array must
C             contain the descriptor matrix E.
C             On exit, the leading L-by-N part of this array contains
C             the transformed matrix Q'*E*Z.
C
C                      ( Er  0 )
C             Q'*E*Z = (       ) ,
C                      (  0  0 )
C
C             where Er is a RANKE-by-RANKE invertible diagonal matrix
C             having on the diagonal the decreasingly ordered positive
C             singular values of E.
C
C     LDE     INTEGER
C             The leading dimension of array E.  LDE >= MAX(1,L).
C
C     B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
C             On entry, the leading L-by-M part of this array must
C             contain the input/state matrix B.
C             On exit, the leading L-by-M part of this array contains
C             the transformed matrix Q'*B.
C
C     LDB     INTEGER
C             The leading dimension of array B.
C             LDB >= MAX(1,L) if M > 0 or LDB >= 1 if M = 0.
C
C     C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
C             On entry, the leading P-by-N part of this array must
C             contain the state/output matrix C.
C             On exit, the leading P-by-N part of this array contains
C             the transformed matrix C*Z.
C
C     LDC     INTEGER
C             The leading dimension of array C.  LDC >= MAX(1,P).
C
C     Q       (output) DOUBLE PRECISION array, dimension (LDQ,L)
C             The leading L-by-L part of this array contains the
C             orthogonal matrix Q, which is the accumulated product of
C             transformations applied to A, E, and B on the left.
C
C     LDQ     INTEGER
C             The leading dimension of array Q.  LDQ >= MAX(1,L).
C
C     Z       (output) DOUBLE PRECISION array, dimension (LDZ,N)
C             The leading N-by-N part of this array contains the
C             orthogonal matrix Z, which is the accumulated product of
C             transformations applied to A, E, and C on the right.
C
C     LDZ     INTEGER
C             The leading dimension of array Z.  LDZ >= MAX(1,N).
C
C     RANKE   (output) INTEGER
C             The effective rank of matrix E, and thus also the order
C             of the invertible diagonal submatrix Er.
C             RANKE is computed as the number of singular values of E
C             greater than TOL*SVEMAX, where SVEMAX is the maximum
C             singular value of E.
C
C     RNKA22  (output) INTEGER
C             If JOBA = 'R', then RNKA22 is the effective rank of
C             matrix A22, and thus also the order of the invertible
C             diagonal submatrix Ar. RNKA22 is computed as the number
C             of singular values of A22 greater than TOL*SVAMAX,
C             where SVAMAX is an estimate of the maximum singular value
C             of A.
C             If JOBA = 'N', then RNKA22 is not referenced.
C
C     Tolerances
C
C     TOL     DOUBLE PRECISION
C             The tolerance to be used in determining the rank of E
C             and of A22. If TOL > 0, then singular values less than
C             TOL*SVMAX are treated as zero, where SVMAX is the maximum
C             singular value of E or an estimate of it for A and E.
C             If TOL <= 0, the default tolerance TOLDEF = EPS*L*N is
C             used instead, where EPS is the machine precision
C             (see LAPACK Library routine DLAMCH). TOL < 1.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) returns the optimal value
C             of LDWORK.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK >= MAX(1,MIN(L,N) +
C                           MAX(3*MIN(L,N)+MAX(L,N), 5*MIN(L,N), M, P)).
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             > 0:  the QR algorithm has failed to converge when computing
C                   singular value decomposition. In this case INFO
C                   specifies how many superdiagonals did not converge.
C                   This failure is not likely to occur.
C
C     METHOD
C
C     The routine computes the singular value decomposition (SVD) of E,
C     in the form
C
C                    ( Er  0 )
C           E  = Q * (       ) * Z'
C                    (  0  0 )
C
C     and finds the largest RANKE-by-RANKE leading diagonal submatrix
C     Er whose condition number is less than 1/TOL. RANKE defines thus
C     the effective rank of matrix E.
C     If JOBA = 'R' the same reduction is performed on A22 in the
C     partitioned matrix
C
C                  ( A11  A12 )
C         Q'*A*Z = (          ) ,
C                  ( A21  A22 )
C
C     to obtain it in the form
C
C                  ( Ar  0 )
C            A22 = (       ) ,
C                  (  0  0 )
C
C     with Ar an invertible diagonal matrix.
C
C     The accumulated transformations are also applied to the rest of
C     matrices
C
C          B <- Q' * B,  C <- C * Z.
C
C     NUMERICAL ASPECTS
C
C     The algorithm is numerically backward stable and requires
C     0( L*L*N )  floating point operations.
C
C     CONTRIBUTOR
C
C     A. Varga, German Aerospace Center, DLR Oberpfaffenhofen.
C     March 1999. Based on the RASP routine RPDSSV.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, July 1999,
C     Feb. 2000, Oct. 2001, May 2003, Feb. 2017, June 2017.
C
C     KEYWORDS
C
C     Descriptor system, matrix algebra, matrix operations,
C     orthogonal transformation.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D0, ZERO = 0.0D0 )
C     .. Scalar Arguments ..
      CHARACTER          JOBA
      INTEGER            INFO, L, LDA, LDB, LDC, LDE, LDQ, LDWORK,
     $                   LDZ, M, N, P, RNKA22, RANKE
      DOUBLE PRECISION   TOL
C     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), C( LDC, * ),
     $                   DWORK( * ),  E( LDE, * ), Q( LDQ, * ),
     $                   Z( LDZ, * )
C     .. Local Scalars ..
      LOGICAL            REDA
      INTEGER            I, IR1, J, KW, LA22, LN, LN2, LWR, NA22, WRKOPT
      DOUBLE PRECISION   EPSM, SVEMAX, SVLMAX, TOLDEF
C     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLAMCH, DLANGE
      EXTERNAL           DLAMCH, DLANGE, LSAME
C     .. External Subroutines ..
      EXTERNAL           DCOPY, DGEMM, DGEMV, DGEQRF, DGELQF, DGESVD,
     $                   DLACPY, DLASET, DORMQR, DORMLQ, DSWAP, MA02AD,
     $                   MB03UD, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC          DBLE, INT, MAX, MIN
C
C     .. Executable Statements ..
C
      REDA = LSAME( JOBA, 'R' )
C
C     Test the input parameters.
C
      INFO = 0
      WRKOPT = MIN( L, N ) +
     $         MAX( M, P, 3*MIN( L, N ) + MAX( L, N ), 5*MIN( L, N ) )
      IF( .NOT.LSAME( JOBA, 'N' ) .AND. .NOT.REDA ) THEN
         INFO = -1
      ELSE IF( L.LT.0 ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( M.LT.0 ) THEN
         INFO = -4
      ELSE IF( P.LT.0 ) THEN
         INFO = -5
      ELSE IF( LDA.LT.MAX( 1, L ) ) THEN
         INFO = -7
      ELSE IF( LDE.LT.MAX( 1, L ) ) THEN
         INFO = -9
      ELSE IF( LDB.LT.1 .OR. ( M.GT.0 .AND. LDB.LT.L ) ) THEN
         INFO = -11
      ELSE IF( LDC.LT.MAX( 1, P ) ) THEN
         INFO = -13
      ELSE IF( LDQ.LT.MAX( 1, L ) ) THEN
         INFO = -15
      ELSE IF( LDZ.LT.MAX( 1, N ) ) THEN
         INFO = -17
      ELSE IF( TOL.GE.ONE ) THEN
         INFO = -20
      ELSE IF( LDWORK.LT.MAX( 1, WRKOPT ) ) THEN
         INFO = -22
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'TG01ED', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( L.EQ.0 .OR. N.EQ.0 ) THEN
         IF( L.GT.0 )
     $      CALL DLASET( 'Full', L, L, ZERO, ONE, Q, LDQ )
         IF( N.GT.0 )
     $      CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ )
         DWORK(1) = ONE
         RANKE = 0
         IF( REDA ) RNKA22 = 0
         RETURN
      END IF
C
      LN = MIN( L, N )
      EPSM = DLAMCH( 'EPSILON' )
C
      TOLDEF = TOL
      IF( TOLDEF.LE.ZERO ) THEN
C
C        Use the default tolerance for rank determination.
C
         TOLDEF = EPSM * DBLE( L*N )
      END IF
C
C     Set the estimate of the maximum singular value of E to ||E||_F.
C
      SVLMAX = DLANGE( 'Frobenius', L, N, E, LDE, DWORK )
C
C     Compute the SVD of E
C
C                    ( Er  0 )
C           E = Qr * (       ) * Zr'
C                    (  0  0 )
C
C     Workspace: needed  MIN(L,N) + MAX(3*MIN(L,N)+MAX(L,N),5*MIN(L,N));
C                prefer larger.
C
      LWR = LDWORK - LN
      KW = LN + 1
C
      CALL DGESVD( 'A', 'A', L, N, E, LDE, DWORK, Q, LDQ, Z, LDZ,
     $             DWORK(KW), LWR, INFO )
      IF( INFO.GT.0 )
     $   RETURN
      WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) )
C
C     Determine the rank of E.
C
      RANKE = 0
      IF( DWORK(1).GT.TOLDEF ) THEN
         RANKE = 1
         SVEMAX = DWORK(1)
         DO 10 I = 2, LN
            IF( DWORK(I).LT.SVEMAX*TOLDEF ) GO TO 20
            RANKE = RANKE + 1
   10    CONTINUE
C
   20    CONTINUE
      END IF
C
C     Apply transformation on the rest of matrices.
C
      IF( RANKE.GT.0 ) THEN
C
C        A <-- Qr' * A * Zr.
C
         CALL DGEMM( 'Transpose', 'No transpose', L, N, L, ONE,
     $               Q, LDQ, A, LDA, ZERO, E, LDE )
         CALL DGEMM( 'No transpose', 'Transpose', L, N, N, ONE,
     $               E, LDE, Z, LDZ, ZERO, A, LDA )
C
C        B <-- Qr' * B.
C        Workspace: need   L;
C                   prefer L*M.
C
         IF( LWR.GT.L*M .AND. M.GT.0 ) THEN
C
            CALL DGEMM( 'Transpose', 'No transpose', L, M, L, ONE,
     $                  Q, LDQ, B, LDB, ZERO, DWORK(KW), L )
            CALL DLACPY( 'Full', L, M, DWORK(KW), L, B, LDB )
         ELSE
            DO 30 J = 1, M
               CALL DGEMV( 'Transpose', L, L, ONE, Q, LDQ, B(1,J), 1,
     $                     ZERO, DWORK(KW), 1 )
               CALL DCOPY( L, DWORK(KW), 1, B(1,J), 1 )
   30       CONTINUE
         END IF
C
C        C <-- C * Zr.
C        Workspace: need   N;
C                   prefer P*N.
C
         IF( LWR.GT.P*N ) THEN
C
            CALL DGEMM( 'No transpose', 'Transpose', P, N, N, ONE,
     $                  C, LDC, Z, LDZ, ZERO, DWORK(KW), MAX( 1, P ) )
            CALL DLACPY( 'Full', P, N, DWORK(KW), MAX( 1, P ), C, LDC )
         ELSE
            DO 40 I = 1, P
               CALL DGEMV( 'No transpose', N, N, ONE, Z, LDZ,
     $                     C(I,1), LDC, ZERO, DWORK(KW), 1 )
               CALL DCOPY( N, DWORK(KW), 1, C(I,1), LDC )
   40       CONTINUE
         END IF
         WRKOPT = MAX( WRKOPT, L*M, P*N )
      END IF
C
C     Reduce A22 if necessary.
C
      IF( REDA ) THEN
         LA22 = L - RANKE
         NA22 = N - RANKE
         LN2 = MIN( LA22, NA22 )
         IF( LN2.EQ.0 ) THEN
            IR1 = 1
            RNKA22 = 0
         ELSE
C
C           Set the estimate of maximum singular value of A to detect 
C           a negligible A22 submatrix.
C
            SVLMAX = DLANGE( 'Frobenius', L, N, A, LDA, DWORK )
C
C           Compute the SVD of A22 using a storage saving approach.
C
            IR1 = RANKE + 1
            IF( LA22.GE.NA22 ) THEN
C
C              Compute the QR decomposition of A22 in the form
C
C              A22 = Q2 * ( R2 ) ,
C                         ( 0  )
C
C              where R2 is upper triangular.
C              Workspace: need   MIN(L,N) + N;
C                         prefer MIN(L,N) + N*NB.
C
               CALL DGEQRF( LA22, NA22, A(IR1,IR1), LDA, DWORK(IR1),
     $                      DWORK(KW), LWR, INFO )
               WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) )
C
C              Apply transformation Q2 to A, B, and Q.
C
C              A <--diag(I, Q2') * A
C              Workspace: need   MIN(L,N) + N;
C                         prefer MIN(L,N) + N*NB.
C
               CALL DORMQR( 'Left', 'Transpose', LA22, RANKE, LN2,
     $                      A(IR1,IR1), LDA, DWORK(IR1), A(IR1,1), LDA,
     $                      DWORK(KW), LWR, INFO )
               WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) )
C
C              B <-- diag(I, Q2') * B
C              Workspace: need   MIN(L,N) + M;
C                         prefer MIN(L,N) + M*NB.
C
               IF ( M.GT.0 ) THEN
                  CALL DORMQR( 'Left', 'Transpose', LA22, M, LN2,
     $                         A(IR1,IR1), LDA, DWORK(IR1), B(IR1,1),
     $                         LDB, DWORK(KW), LWR, INFO )
                  WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) )
               END IF
C
C              Q <-- Q * diag(I, Q2)
C              Workspace: need   MIN(L,N) + L;
C                         prefer MIN(L,N) + L*NB.
C
               CALL DORMQR( 'Right', 'No transpose', L, LA22, LN2,
     $                       A(IR1,IR1), LDA, DWORK(IR1), Q(1,IR1), LDQ,
     $                       DWORK(KW), LWR, INFO )
               WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) )
C
C              Compute the SVD of the upper triangular submatrix R2 as
C
C                               ( Ar  0 )
C                    R2 = Q2r * (       ) * Z2r' ,
C                               (  0  0 )
C
C              where Q2r is stored in E and Z2r' is stored in A22.
C              Workspace: need   MAX(1,5*MIN(L,N));
C                         prefer larger.
C
               CALL MB03UD( 'Vectors', 'Vectors', LN2, A(IR1,IR1), LDA,
     $                      E(IR1,IR1), LDE, DWORK(IR1), DWORK(KW), LWR,
     $                      INFO )
               IF( INFO.GT.0 )
     $            RETURN
               WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) )
C
C              Determine the rank of A22.
C
               RNKA22 = 0
               IF( DWORK(IR1).GT.SVLMAX*EPSM ) THEN
                  RNKA22 = 1
                  DO 50 I = IR1+1, LN
                     IF( DWORK(I).LE.SVLMAX*TOLDEF ) GO TO 60
                     RNKA22 = RNKA22 + 1
   50             CONTINUE
C
   60             CONTINUE
               END IF
C
C              Apply transformation on the rest of matrices.
C
               IF( RNKA22.GT.0 ) THEN
C
C                 A <-- diag(I,Q2r') * A * diag(I,Zr2)
C
                  CALL DGEMM( 'Transpose', 'No transpose', LN2, RANKE,
     $                        LN2, ONE, E(IR1,IR1), LDE, A(IR1,1), LDA,
     $                        ZERO, E(IR1,1), LDE )
                  CALL DLACPY( 'Full', LN2, RANKE, E(IR1,1), LDE,
     $                         A(IR1,1), LDA )
                  CALL DGEMM( 'No transpose', 'Transpose', RANKE, LN2,
     $                        LN2, ONE, A(1,IR1), LDA, A(IR1,IR1), LDA,
     $                        ZERO, E(1,IR1), LDE )
                  CALL DLACPY( 'Full', RANKE, LN2, E(1,IR1), LDE,
     $                         A(1,IR1), LDA )
C
C                 B <-- diag(I,Q2r') * B
C
                  IF( LWR.GT.LN2*M .AND. M.GT.0 ) THEN
C
                     CALL DGEMM( 'Transpose', 'No transpose', LN2, M,
     $                           LN2, ONE, E(IR1,IR1), LDE, B(IR1,1),
     $                           LDB, ZERO, DWORK(KW), LN2 )
                     CALL DLACPY( 'Full', LN2, M, DWORK(KW), LN2,
     $                            B(IR1,1), LDB )
                  ELSE
                     DO 70 J = 1, M
                        CALL DGEMV( 'Transpose', LN2, LN2, ONE,
     $                              E(IR1,IR1), LDE, B( IR1,J), 1,
     $                              ZERO, DWORK(KW), 1 )
                        CALL DCOPY( LN2, DWORK(KW), 1, B(IR1,J), 1 )
   70                CONTINUE
                  END IF
C
C                 C <-- C * diag(I,Zr2)
C
                  IF( LWR.GT.P*LN2 .AND. P.GT.0 ) THEN
C
                     CALL DGEMM( 'No transpose', 'Transpose', P, LN2,
     $                           LN2, ONE, C(1,IR1), LDC, A(IR1,IR1),
     $                           LDA, ZERO, DWORK(KW), P )
                     CALL DLACPY( 'Full', P, LN2, DWORK( KW ), P,
     $                            C(1,IR1), LDC )
                  ELSE
                     DO 80 I = 1, P
                        CALL DGEMV( 'No transpose', LN2, LN2, ONE,
     $                              A(IR1,IR1), LDA, C(I,IR1), LDC,
     $                              ZERO, DWORK(KW), 1 )
                        CALL DCOPY( LN2, DWORK(KW), 1, C(I,IR1), LDC )
   80                CONTINUE
                  END IF
C
C                 Q <-- Q * diag(I, Qr2)
C
                  IF( LWR.GT.L*LN2 ) THEN
C
                     CALL DGEMM( 'No transpose', 'No transpose', L, LN2,
     $                           LN2, ONE, Q(1,IR1), LDQ, E(IR1,IR1),
     $                           LDE, ZERO, DWORK(KW), L )
                     CALL DLACPY( 'Full', L, LN2, DWORK(KW), L,
     $                            Q(1,IR1), LDQ )
                  ELSE
                     DO 90 I = 1, L
                        CALL DGEMV( 'Transpose', LN2, LN2, ONE,
     $                              E(IR1,IR1), LDE, Q(I,IR1), LDQ,
     $                              ZERO, DWORK(KW), 1 )
                        CALL DCOPY( LN2, DWORK(KW), 1, Q(I,IR1), LDQ )
   90                CONTINUE
                  END IF
C
C                 Z' <-- diag(I, Zr2') * Z'
C
                  IF( LWR.GT.N*LN2 ) THEN
C
                     CALL DGEMM( 'No transpose', 'No transpose', LN2, N,
     $                           LN2, ONE, A(IR1,IR1), LDA, Z(IR1,1),
     $                           LDZ, ZERO, DWORK(KW), LN2 )
                     CALL DLACPY( 'Full', LN2, N, DWORK(KW), LN2,
     $                            Z(IR1,1), LDZ )
                  ELSE
                     DO 100 J = 1, N
                        CALL DGEMV( 'No transpose', LN2, LN2, ONE,
     $                              A(IR1,IR1), LDA, Z(IR1,J), 1,
     $                              ZERO, DWORK(KW), 1 )
                        CALL DCOPY( LN2, DWORK(KW), 1, Z(IR1,J), 1 )
  100                CONTINUE
                  END IF
               END IF
            ELSE
C
C              Compute the LQ decomposition of A22 in the form
C
C                  A22 = ( L2 0 )* Z2
C
C              where L2 is lower triangular.
C              Workspace: need   MIN(L,N) + L;
C                         prefer MIN(L,N) + L*NB.
C
               CALL DGELQF( LA22, NA22, A(IR1,IR1), LDA, DWORK(IR1),
     $                      DWORK(KW), LWR, INFO )
               WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) )
C
C              Apply transformation Z2 to A, C, and Z.
C
C              A <-- A * diag(I, Z2')
C              Workspace: need   2*MIN(L,N);
C                         prefer MIN(L,N) + MIN(L,N)*NB.
C
               CALL DORMLQ( 'Right', 'Transpose', RANKE, NA22, LN2,
     $                      A(IR1,IR1), LDA, DWORK(IR1), A(1,IR1), LDA,
     $                      DWORK(KW), LWR, INFO )
               WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) )
C
C              C <-- C * diag(I, Z2')
C              Workspace: need   MIN(L,N) + P;
C                         prefer MIN(L,N) + P*NB.
C
               IF ( P.GT.0 ) THEN
                  CALL DORMLQ( 'Right', 'Transpose', P, NA22, LN2,
     $                         A(IR1,IR1), LDA, DWORK(IR1), C(1,IR1),
     $                         LDC, DWORK(KW), LWR, INFO )
                  WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) )
               END IF
C
C              Z' <-  diag(I, Z2) * Z'
C              Workspace: need   MIN(L,N) + N;
C                         prefer MIN(L,N) + N*NB.
C
               CALL DORMLQ( 'Left', 'No transpose', NA22, N, LN2,
     $                       A(IR1,IR1), LDA, DWORK(IR1), Z(IR1,1), LDZ,
     $                       DWORK(KW), LWR, INFO )
               WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) )
C
C              Compute the SVD of the lower triangular submatrix L2 as
C
C                              ( Ar  0 )
C                  L2' = Z2r * (       ) * Q2r'
C                              (  0  0 )
C
C              where Q2r' is stored in E and Z2r is stored in A22.
C              Workspace: need   MAX(1,5*MIN(L,N));
C                         prefer larger.
C
               CALL MA02AD( 'Lower', LN2, LN2, A(IR1,IR1), LDA,
     $                      E(IR1,IR1), LDE )
               CALL MB03UD( 'Vectors', 'Vectors', LN2, E(IR1,IR1), LDE,
     $                      A(IR1,IR1), LDA, DWORK(IR1), DWORK(KW),
     $                      LWR, INFO )
               IF( INFO.GT.0 )
     $            RETURN
               WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) )
C
C              Determine the rank of A22.
C
               RNKA22 = 0
               IF( DWORK(IR1).GT.SVLMAX*EPSM ) THEN
                  RNKA22 = 1
                  DO 110 I = IR1+1, LN
                     IF( DWORK(I).LE.SVLMAX*TOLDEF ) GO TO 120
                     RNKA22 = RNKA22 + 1
  110             CONTINUE
C
  120             CONTINUE
               END IF
C
C              Apply transformation on the rest of matrices.
C
               IF( RNKA22.GT.0 ) THEN
C
C                 A <-- diag(I,Q2r') * A * diag(I,Zr2)
C
                  CALL DGEMM( 'No transpose', 'No transpose', LN2,
     $                        RANKE, LN2, ONE, E(IR1,IR1), LDE,
     $                        A(IR1,1), LDA, ZERO, E(IR1,1), LDE )
                  CALL DLACPY( 'Full', LN2, RANKE, E(IR1,1), LDE,
     $                         A(IR1,1), LDA )
                  CALL DGEMM( 'No transpose', 'No transpose', RANKE,
     $                        LN2, LN2, ONE, A(1,IR1), LDA,
     $                        A(IR1,IR1), LDA, ZERO, E(1,IR1), LDE )
                  CALL DLACPY( 'Full', RANKE, LN2, E(1,IR1), LDE,
     $                         A(1,IR1), LDA )
C
C                 B <-- diag(I,Q2r') * B
C
                  IF( LWR.GT.LN2*M .AND. M.GT.0 ) THEN
C
                     CALL DGEMM( 'No transpose', 'No transpose', LN2, M,
     $                           LN2, ONE, E(IR1,IR1), LDE, B(IR1,1),
     $                           LDB, ZERO, DWORK(KW), LN2 )
                     CALL DLACPY( 'Full', LN2, M, DWORK(KW), LN2,
     $                            B(IR1,1), LDB )
                  ELSE
                     DO 130 J = 1, M
                        CALL DGEMV( 'No transpose', LN2, LN2, ONE,
     $                              E(IR1,IR1), LDE, B( IR1,J), 1,
     $                              ZERO, DWORK(KW), 1 )
                        CALL DCOPY( LN2, DWORK(KW), 1, B(IR1,J), 1 )
  130                CONTINUE
                  END IF
C
C                 C <-- C * diag(I,Zr2)
C
                  IF( LWR.GT.P*LN2 .AND. P.GT.0 ) THEN
C
                     CALL DGEMM( 'No transpose', 'No transpose', P, LN2,
     $                           LN2, ONE, C(1,IR1), LDC, A(IR1,IR1),
     $                           LDA, ZERO, DWORK(KW), P )
                     CALL DLACPY( 'Full', P, LN2, DWORK( KW ), P,
     $                            C(1,IR1), LDC )
                  ELSE
                     DO 140 I = 1, P
                        CALL DGEMV( 'Transpose', LN2, LN2, ONE,
     $                              A(IR1,IR1), LDA, C(I,IR1), LDC,
     $                              ZERO, DWORK(KW), 1 )
                        CALL DCOPY( LN2, DWORK(KW), 1, C(I,IR1), LDC )
  140                CONTINUE
                  END IF
C
C                 Q <-- Q * diag(I, Qr2)
C
                  IF( LWR.GT.L*LN2 ) THEN
C
                     CALL DGEMM( 'No transpose', 'Transpose', L, LN2,
     $                           LN2, ONE, Q(1,IR1), LDQ, E(IR1,IR1),
     $                           LDE, ZERO, DWORK(KW), L )
                     CALL DLACPY( 'Full', L, LN2, DWORK(KW), L,
     $                            Q(1,IR1), LDQ )
                  ELSE
                     DO 150 I = 1, L
                        CALL DGEMV( 'No transpose', LN2, LN2, ONE,
     $                              E(IR1,IR1), LDE, Q(I,IR1), LDQ,
     $                              ZERO, DWORK(KW), 1 )
                        CALL DCOPY( LN2, DWORK(KW), 1, Q(I,IR1), LDQ )
  150                CONTINUE
                  END IF
C
C                 Z' <-- diag(I, Zr2') * Z'
C
                  IF( LWR.GT.N*LN2 ) THEN
C
                     CALL DGEMM( 'Transpose', 'No transpose', LN2, N,
     $                           LN2, ONE, A(IR1,IR1), LDA, Z(IR1,1),
     $                           LDZ, ZERO, DWORK(KW), LN2 )
                     CALL DLACPY( 'Full', LN2, N, DWORK(KW), LN2,
     $                            Z(IR1,1), LDZ )
                  ELSE
                     DO 160 J = 1, N
                        CALL DGEMV( 'Transpose', LN2, LN2, ONE,
     $                              A(IR1,IR1), LDA, Z(IR1,J), 1,
     $                              ZERO, DWORK(KW), 1 )
                        CALL DCOPY( LN2, DWORK(KW), 1, Z(IR1,J), 1 )
  160                CONTINUE
                  END IF
               END IF
            END IF
         END IF
      END IF
C
C     Set E.
C
      CALL DLASET( 'Full', L, N, ZERO, ZERO, E, LDE )
      CALL DCOPY( RANKE, DWORK, 1, E, LDE+1 )
C
      IF( REDA ) THEN
C
C        Set A22.
C
         CALL DLASET( 'Full', LA22, NA22, ZERO, ZERO, A(IR1,IR1), LDA )
         CALL DCOPY( RNKA22, DWORK(IR1), 1, A(IR1,IR1), LDA+1 )
      END IF
C
C     Transpose Z.
C
      DO 170 I = 2, N
         CALL DSWAP( I-1, Z(1,I), 1, Z(I,1), LDZ )
  170 CONTINUE
C
      DWORK(1) = WRKOPT
C
      RETURN
C *** Last line of TG01ED ***
      END
